Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/sysio.bli
There are no other files named sysio.bli in the archive.
MODULE sysio (IDENT = 'v1.1',
%if
%bliss(bliss32)
%then
language(bliss32),
addressing_mode(external=general,
nonexternal=long_relative)
%else
language(bliss36)
%fi
) =
BEGIN
! COPYRIGHT (C) 1982, 1983 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!++
! FACILITY:
! CMS Library
!
! ABSTRACT:
! The routines in this module use the system services to simulate
! the bare essentials of XPORT which CMS needs.
!
! ENVIRONMENT:
! User mode.
!
! AUTHOR: James B Sugerman, CREATION DATE: 11-May 1982
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
%if %bliss(bliss36) %then
expand_buffer,
%fi
io$open,
io$close,
io$get,
io$put,
io$rename,
io$delete;
!
! INCLUDE FILES:
!
LIBRARY 'xport:';
%if
%bliss(bliss32)
%then
LIBRARY 'sys$library:starlet';
%else
REQUIRE 'tendef:';
UNDECLARE
%quote $chlfd,
%quote $chcrt;
REQUIRE 'jsys:';
%fi
REQUIRE 'blissx:';
!
! MACROS:
!
%if Tops20 %then
MACRO
at_eof (jfn) =
BEGIN
LOCAL status;
gtsts((jfn); status);
.pointr (status,gs_eof)
END %,
sys_error (error) =
error ^ 3 %;
%fi
%if VaxVms %then
MACRO
iob$v_fst = $iob$filler2 %, !first time processing
iob$w_spa = $iob$filler3 %, !amount of free space at eof
iob$l_end = $iob$filler6 %, !last mapped byte in file (eof)
iob$l_cur = $iob$filler7 %, !current byte being read
iob$l_fir = $iob$filler8 %, !first byti in virtual memory
iob$l_lst = $iob$filler9 %; !last byte in v memory
%fi
MACRO
check_iob_length (iob) =
BEGIN
!+
! Simple test for IOB validity. Check if the length field is valid.
!-
MAP
iob : $xpo_iob(); ! incase not defined in outter level
IF .iob[iob$h_length] neq iob$k_length ! check length
THEN
BEGIN ! invalid; set error codes
iob[iob$g_comp_code] = xpo$_bad_iob;
iob[iob$g_2nd_code] = xpo$_bad_length;
RETURN xpo$_bad_iob;
END;
END %;
!
! EQUATED SYMBOLS:
!
%if %bliss(bliss36) %then
LITERAL
cr = 13,
lf = 10,
ff = 12,
ht = 9,
null = 0,
ctrl_z = 26,
initial_buffer_size = 512,
buffer_increment = 1000;
%fi
!
! OWN STORAGE:
!
OWN
d_default : $str_descriptor(string = '.'),
d_related : $str_descriptor(string = '.');
!
! EXTERNAL REFERENCES:
!
%if Tops20 %then
EXTERNAL ROUTINE
ascdec, !convert ascii to decimal
bug, !bug reporting routine
cvtas0, !create an asciz descriptor
decasz, !convert decimal to ascii with leading zeros
freas0, !free the memory created by cvtas0
jfnstr, !convert a jfn to a string
xpo$build_spec; !the XPORT file specification resolution routine
! CAUTION: undocumented interface USE WITH CARE!
%fi
global routine io$open(iobadr,sucadr,failadr) =
!++
! Functional Description:
!
! Opens a file with the system specific calls (RMS for the VAX;
! JSYS for Tops20) and fills in the IOB with the bare minimum
! needed by CMS.
!
! Formal Parameters:
!
! iobadr - address of IOB
!
! Implicit Inputs:
!
! NONE
!
! Implicit Outputs:
!
! field in the iob.
!
! Routine Value:
! Completion Codes:
!
! RMS or JSYS completion codes.
!
! Side Effects:
!
!
!
!--
BEGIN
%if VaxVms %then
LOCAL
status;
BIND
iob = .iobadr : $xpo_iob(),
file_spec = .iob[iob$a_file_spec] : $str_descriptor(),
fab = .iob[iob$a_rms_fab] : $fab_decl,
rab = .iob[iob$a_rms_rab] : $rab_decl,
nam = .fab[fab$l_nam] : $nam_decl;
check_iob_length(iob);
!+
! Fill in the appropiate FAB fields
!-
fab[fab$v_nef] = NOT .iob[iob$v_append];
fab[fab$v_cif] = .iob[iob$v_append] or .iob[iob$v_overwrite];
fab[fab$v_trn] = .iob[iob$v_overwrite];
fab[fab$v_get] = fab[fab$v_shrget] = fab[fab$v_ufo] = .iob[iob$v_input];
IF
.iob[iob$v_output] OR .iob[iob$v_append] OR .iob[iob$v_overwrite]
THEN
BEGIN
iob[iob$v_output] = true;
fab[fab$V_mxv] = .iob[iob$v_max_versi];
fab[fab$v_put] = true;
fab[fab$v_cr] = true;
fab[fab$v_nil] = true;
END;
!+
! SEQUENCED FILE
!-
IF
.iob[iob$v_sequenced]
THEN
fab[fab$b_rfm] = fab$c_vfc;
!+
! give the file spec to RMS
!-
fab[fab$l_fna] = .file_spec[str$a_pointer];
fab[fab$b_fns] = .file_spec[str$h_length];
!+
! and default
!-
IF
.iob[iob$a_default] neq 0
THEN
BEGIN
BIND
default_spec = .iob[iob$a_default] : $str_descriptor();
fab[fab$l_dna] = .default_spec[str$a_pointer];
fab[fab$b_dns] = .default_spec[str$h_length];
END;
!+
! do an RMS open for input
! NOTE: if nothing is specified the file is opened normally for input
! if input is specified the file is mapped
!-
IF
.iob[iob$v_input] or not .iob[iob$v_output]
THEN !MAPPED
BEGIN
LOCAL
xab : $xabfhc(); !header characteristics
iob[iob$v_input] = true;
fab[fab$l_xab] = xab;
status = $RMS_OPEN(fab=fab);
iob[iob$v_fst] = true; !file just opened
iob[iob$h_channel] = .fab[fab$l_stv]; !save channel number
iob[iob$w_spa] = (IF .xab[xab$w_ffb] EQL 0 !calculate free space at eof
THEN 0
ELSE 512 - .xab[xab$w_ffb]);
fab[fab$l_xab] = 0; !blank xab field
END
ELSE !OUtput file
BEGIN
status = $RMS_CREATE(fab=fab);
!For some reason RMS returns a RMS$_NORMAL if cif is not set ie. options=output
IF
.iob[iob$v_output] AND not .iob[iob$v_append] AND not .iob[iob$v_overwrite] and .status
THEN
status = fab[fab$l_sts] = rms$_created;
END;
!+
! return resultant descriptor
!-
IF
.status
THEN
$str_desc_init(descriptor = iob[iob$t_resultant],
string = (.nam[nam$b_rsl],.nam[nam$l_rsa]))
ELSE !nam block not filled in in case of error
$str_desc_init(descriptor = iob[iob$t_resultant],
string = file_spec);
!+
! fill in IOB
!-
iob[iob$g_comp_code] = .fab[fab$l_sts];
iob[iob$g_2nd_code] = .fab[fab$l_stv];
iob[iob$v_terminal] = ((.fab[fab$l_dev] and dev$m_trm) NEQ 0);
IF
.status
THEN
BEGIN
iob[iob$v_open] = true;
iob[iob$v_sequenced] = (.fab[fab$b_rfm] EQL fab$c_vfc AND
NOT .fab[fab$v_prn] and .fab[fab$b_fsz] EQL 2);
END;
!+
! fill in and connect the RAB
!-
IF
.status AND .iob[iob$a_rms_rab] NEQ 0
THEN
BEGIN
RAB[rab$v_eof] = .iob[iob$v_append];
rab[rab$v_tpt] = .iob[iob$v_overwrite];
rab[rab$l_rhb] = iob[iob$g_seq_numb];
$RMS_CONNECT(rab = rab);
END;
.status
%fi
%if Tops20 %then
LOCAL
jfn_flags, !the flags passed to getjfn
file_z_ptr, !pointer to asciz file name descriptor
open_flags, !the flags passed to openf
err_code, !error code returned by jsys
ret_byte, !byte returned by bin
f_new, !flag telling if append and overwrite is to a new file
dev_desig,
dev_chr,
dev_type, !hold device type (field from dev_chr)
job_and_units,
upd_ptr, !updated pointer
status;
BIND
iob = .iobadr : $xpo_iob(),
file_spec = .iob[iob$a_file_spec] : $str_descriptor(),
jfn = iob[iob$h_channel];
check_iob_length(iob);
IF !if nothing specified OPTIONS = INPUT.
not(.iob[iob$v_input] or .iob[iob$v_output] or .iob[iob$v_append] or
.iob[iob$v_overwrite])
THEN
iob[iob$v_input] = true;
!+
! get a job file number (jfn)
!-
IF
.iob[iob$v_input] or .iob[iob$v_append] or .iob[iob$v_overwrite]
THEN
BEGIN
jfn_flags = gj_sht or gj_old; !Try for a file already there
IF
.iob[iob$v_append] or .iob[iob$v_overwrite]
THEN
iob[iob$v_output] = true; ! XPORT convention
f_new = false;
END
ELSE
BEGIN
jfn_flags = gj_sht or gj_new or gj_fou; !otherwise a new file
f_new = true
END;
!+
! figure out file specification
!-
IF
.iob[iob$a_default] NEQ 0
THEN
BEGIN !we are using the xport file specification resolution routine
!however we must create a fake related descriptor to get it to work
iob[iob$a_related] = d_related;
xpo$build_spec(.iobadr);
cvtas0(iob[iob$t_resultant],file_z_ptr);
END
ELSE
cvtas0(file_spec,file_z_ptr);
!+
! try to get a jfn as specified. If we cannot and we are opening for append
! or overwrite then the file doesnt exist so create a new one.
!-
IF
(status = gtjfn(.jfn_flags,.file_z_ptr;jfn)) EQL 0
THEN
BEGIN
IF
.iob[iob$v_append] or .iob[iob$v_overwrite]
THEN
BEGIN
f_new = true;
status = gtjfn(gj_new or gj_fou or gj_sht,.file_z_ptr;jfn);
END;
END;
freas0(.file_z_ptr);
IF
.status EQL 0
THEN
BEGIN
err_code = .jfn; !error status returned insteaad of jfn on error
!+
! a resultant spec is needed anyway
!-
IF
.iob[iob$a_default] EQL 0
THEN
BEGIN
iob[iob$a_default] = d_default;
iob[iob$a_related] = d_related;
END;
xpo$build_spec(.iobadr);
END
ELSE
BEGIN
open_flags = fld(36,of_bsz) !since the first thing we do is check for
!sequencing make the byte size 36 bits
OR of_her; !generate IO interrupts
IF !NOTE: this flag must be set for append to
!a old file otherwise the file will get
!wiped out.
.iob[iob$v_input] or (NOT .f_new AND .iob[iob$v_append])
THEN
open_flags = .open_flags or of_rd;
IF
.iob[iob$v_output]
THEN
open_flags = .open_flags or of_wr or of_rtd;
gtsts(.jfn; status);
IF
(status = openf(.jfn,.open_flags;err_code)) NEQ 0
THEN
BEGIN
!+
! determine if this is a terminal
!-
dvchr(.jfn; dev_desig, dev_chr, job_and_units);
dev_type = .pointr(dev_chr, dv_typ);
IF
(.dev_type EQL $dvtty) OR (.dev_type EQL $dvpty)
THEN
iob[iob$v_terminal] = true
ELSE
BEGIN
IF
.dev_type EQL $dvdsk
THEN
BEGIN
!+
! determine if the file is sequenced
!-
IF
BIN(.jfn;ret_byte) NEQ 0
THEN
BEGIN
IF
.ret_byte
THEN
iob[iob$v_sequenced] = true;
END;
! set the byte size to 7 before setting the file position
sfbsz(.jfn,7);
!+
! position to the appropiate place in the file
!-
IF
.iob[iob$v_append]
THEN
sfptr(.jfn,-1)
ELSE
sfptr(.jfn,0);
END;
END;
! set the byte size to 7 (already done once for disk files)
sfbsz(.jfn,7);
!+
! fill in resultant specification
!-
jfnstr(jfn,iob[iob$t_resultant]);
END
ELSE !we couldn't open the file
BEGIN
jfnstr(jfn,iob[iob$t_resultant]);
rljfn(.jfn);
END;
END;
!+
! fill in IOB
!-
IF
.status NEQ 0
THEN
BEGIN
iob[iob$v_open] = true;
$str_desc_init (descriptor = iob[iob$t_string],
class = dynamic_bounded);
IF
.f_new
THEN
RETURN iob[iob$g_comp_code] = step$_created
ELSE
RETURN iob[iob$g_comp_code] = step$_normal;
END
ELSE
RETURN iob[iob$g_comp_code] = sys_error(.err_code);
%fi
END;
global routine io$close (iobadr,sucadr,failadr) =
!++
! Functional Description:
!
! Close specified file
! For bliss36 we close the file and/or release the jfn
! if it fails because the disk is full we force the file
! closed and return the error
! For bliss32 we deallocate the memory and deassign the channel if
! the file was mapped otherwise we just issue an RMS close.
!
! Formal Parameters:
!
! iobadr - address of IOB
!
! Implicit Inputs:
!
! none
!
! Implicit Outputs:
!
! none
!
! Routine Value:
! Completion Codes:
!
! Standard $RMS_CLOSE or JSYS values
!
! Side Effects:
!
! none
!
!--
begin ! cms$close
%if VaxVms %then
LOCAL
status;
bind
iob = .iobadr: $xpo_iob() , ! iob
fab = .iob[iob$a_rms_fab] : $fab_decl; ! corresponding FAB
check_iob_length(iob);
IF
.fab[fab$v_ufo]
THEN
BEGIN
LOCAL
retrange : VECTOR[2];
!+
! delete the mapped memory iff mapped and deassign the channel
!-
IF
not .iob[iob$v_fst]
THEN
BEGIN
retrange[0] = .iob[iob$l_fir];
retrange[1] = .iob[iob$l_lst];
status = $deltva(inadr=retrange);
END;
status = $dassgn(chan = .iob[iob$h_channel]);
END
ELSE
status = $rms_close(fab = fab, suc = .sucadr , err = .failadr);
!+
! set flags in IOB
!-
IF
.status
THEN
BEGIN
iob[iob$v_open]=0;
iob[iob$v_closed]=true;
END;
iob[iob$g_2nd_code] = .fab[fab$l_stv];
iob[iob$g_comp_code] = .status;
RETURN .status
%fi
%if Tops20 %then
LOCAL
err_code,
status;
BIND
iob = .iobadr : $xpo_iob(),
jfn = iob[iob$h_channel],
d_string = iob[iob$t_string] :
$str_descriptor(class=dynamic_bounded);
check_iob_length(iob);
!+
! close all files except terminals which instead just release the jfn
!-
IF
NOT .iob[iob$v_terminal]
THEN
BEGIN
IF
(status = closf(.jfn; err_code)) EQL 0
THEN
BEGIN
IF !If the disk is full force the file
!closed by setting the abort bit
.err_code EQL iox11
THEN
closf(.jfn or cz_abt);
END;
END
ELSE
BEGIN
rljfn(.jfn);
status = 1;
END;
!+
! set flags in IOB
!-
iob[iob$v_open]=0;
iob[iob$v_closed]=true;
iob[iob$v_eof] = false;
!+
! deallocate dynamic memory
!-
IF .d_string[str$h_maxlen] GTR 0
THEN
BEGIN
$xpo_free_mem (string = d_string);
d_string[str$h_length] = 0;
d_string[str$h_maxlen] = 0;
d_string[str$a_pointer] = 0;
END;
IF
.status EQL 0
THEN
RETURN iob[iob$g_comp_code] = sys_error(.err_code)
ELSE
RETURN iob[iob$g_comp_code] = step$_normal;
%fi
END;
%if Tops20 %then
routine expand_buffer (iobadr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Expand the input buffer used for reading data from a terminal or
! disk file. The buffer is described by the field iob$t_string.
!
! allocate memory for new string
! copy data into new area
! set pointers to new memory
! deallocate old memory
!
! FORMAL PARAMETERS:
!
! iobadr address of the iob
!
! IMPLICIT INPUTS:
!
! fields in the iob
!
! IMPLICIT OUTPUTS:
!
! fields in the iob
!
! ROUTINE VALUE:
!
! Character pointer into middle of iob$t_string. This pointer can be
! used to continue filling the buffer.
!
! SIDE EFFECTS:
!
! Dynamic memory is allocated and deallocated.
!--
begin
bind
iob = .iobadr : $xpo_iob(),
d_string = iob[iob$t_string] : $str_descriptor(class=dynamic_bounded);
local
status, ! return status from XPORT or
! system
new_maxlen, ! new max for buffer size
new_ptr, ! pointer to new buffer
d_old_string : ! desc for old buffer
$str_descriptor(class=dynamic),
continuation_point; ! return value for routine
! next char to be filled in
if .d_string[str$h_pfxlen] neq 0
then
bug(lit('EXPAND_BUFFER called with non-zero string prefix'));
!+
! Initialize a descriptor to point to old string, use it latter to
! reference string and to deallocate memory.
! Be carful - it is a dynamic_bounded string!
!-
$str_desc_init (descriptor = d_old_string,
class = dynamic,
string = (.d_string[str$h_maxlen],
.d_string[str$a_pointer]));
!+
! allocate memory for enlarged buffer
!-
new_maxlen = .d_string[str$h_maxlen] + buffer_increment;
status = $xpo_get_mem (characters = .new_maxlen,
result = new_ptr,
failure = 0);
if not .status
then
bug(lit('Unable to acquire dynamic memory (EXPAND_BUFFER)'));
!+
! move old data to new buffer and initialize the iob$t_string desc
!-
continuation_point =
ch$move (.d_old_string[str$h_length],
.d_old_string[str$a_pointer],
.new_ptr);
d_string[str$a_pointer] = .new_ptr;
d_string[str$h_maxlen] = .new_maxlen;
d_string[str$h_length] = .d_old_string[str$h_length];
!+
! return the old buffer
!-
$xpo_free_mem (string = d_old_string);
return .continuation_point;
end; !(of routine expand_buffer)
%fi
global routine io$get (iobadr,sucadr,failadr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Do all file get and puts with jsys for TOPS20 or RMS for the VAX.
! On the vax however if the file was mapped scan the section returning
! a poointer to the proper place in the section
!
! FORMAL PARAMETERS:
!
! iobadr address of the iob
!
! IMPLICIT INPUTS:
!
! fields in the iob
!
! IMPLICIT OUTPUTS:
!
! fields in the iob
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! standard RMS or jsys return codes
!
! SIDE EFFECTS:
!
! none
!--
BEGIN
%if VaxVms %then
LOCAL
status;
BIND
iob = .iobadr: $xpo_iob() ,
fab = .iob[iob$a_rms_fab] : $fab_decl,
rab = .iob[iob$a_rms_rab] : $rab_decl,
nam = .fab[fab$l_nam] : $nam_decl,
prompt = .iob[iob$a_prompt] : $str_descriptor();
check_iob_length(iob);
IF
.fab[fab$v_ufo]
THEN
BEGIN
local
size;
IF
.iob[iob$v_fst] !indicates first time
THEN
BEGIN
LOCAL
retrange : vector[2],
maprange : vector[2] initial(rep 2 of (1));
!+
! create and map section of the opened file
!-
status = $crmpsc(inadr=maprange,retadr=retrange,
flags=sec$m_expreg,chan=.fab[fab$l_stv]);
!FILE empty
IF
.status EQL ss$_endoffile
THEN
RETURN status = rms$_eof;
IF
.status
THEN
BEGIN
!+
! iob$l_end always holds the last byte in v mem of this file
! iob$l_cur always holds the current byte in v mem being read
! iob$l_fir always holds the first byte in virtual memory
! retrange[0] points to first mapped character
! retrange[1] points to last mapped character
!-
iob[iob$l_end] = ch$plus(.retrange[1],1-.iob[iob$w_spa]);
iob[iob$l_fir] = iob[iob$l_cur] = .retrange[0];
iob[iob$l_lst] = .retrange[1];
END;
iob[iob$v_fst] = false; !no longer first time
size = ..iob[iob$l_cur] AND %X'FFFF'; !size always in first
!two bytes
rab[rab$l_rbf] = ch$plus(.iob[iob$l_cur],2); !data starts after
END
ELSE !NOT FIRST TIME
BEGIN
!+
! goto start of next line (current pointers look at last line)
!-
size = .rab[rab$w_rsz] AND %x'FFFF'; !size in first two byte
!first location in next even byte
rab[rab$l_rbf] = ch$plus(.rab[rab$l_rbf],.size + (.size MOD 2) );
!+
! set up new pointers if not past the last page
!-
IF
.rab[rab$l_rbf] LSS .iob[iob$l_end]
THEN
BEGIN
size = ..rab[rab$l_rbf] AND %X'FFFF'; !size in first two byte
rab[rab$l_rbf] = ch$plus(.rab[rab$l_rbf],2);
END;
END;
rab[rab$w_rsz] =.size;
!+
! are we at the end of the file?
!-
IF
.rab[rab$l_rbf] GEQ .iob[iob$l_end]
THEN
status = rms$_eof
ELSE
status = rms$_normal;
END
ELSE
BEGIN
LOCAL
sequence : WORD;
!+
! initialize prompt fields in the rab
!-
IF
.iob[iob$a_prompt] NEQ 0
THEN
BEGIN
rab[rab$l_pbf] = .prompt[str$a_pointer];
rab[rab$b_psz] = .prompt[str$h_length];
END;
rab[rab$l_rhb] = sequence; !for sequenced files
status = $rms_get(rab = rab, suc = .sucadr, err = 0);
iob[iob$g_seq_numb] =(IF !return sequence # in IOB
.sequence EQL %X'FFFF'
THEN
0
ELSE
.sequence);
END;
!+
! return string in the iob
!-
IF .status
THEN
$str_desc_init(descriptor = iob[iob$t_string],
string = (.rab[rab$w_rsz],.rab[rab$l_rbf]));
iob[iob$g_2nd_code] = .rab[rab$l_stv];
iob[iob$g_comp_code] = .status;
.status
%fi
%if Tops20 %then
LOCAL
prompt_z_ptr, !pointer to asciz pointer of prompt
err_code, !returned error from jsys
byte_num, !what byte are we reading
asc_ptr, !
upd_ptr, !pointer to end of read string
upd_count:block[1],!count from sin
seq_num, !word holding sequence number
ret_byte, !
length, !length of gotten string
chars_read, !number of chars read so far
chars_remaining, !amount of space remaining in buffer
start_ptr, !ptr into buffer where chars are to be placed
status;
BIND
iob = .iobadr : $xpo_iob(),
prompt = .iob[iob$a_prompt] : $str_descriptor(),
d_string = iob[iob$t_string] : $str_descriptor(class = dynamic_bounded),
jfn = iob[iob$h_channel];
check_iob_length(iob);
!+
! return end of file if found last time (when last line is not
! terminated by a CRLF
!-
IF
.iob[iob$v_eof]
THEN
BEGIN
iob[iob$h_string] = 0;
return iob[iob$g_comp_code] = step$_eof;
END;
!+
! Setup
!-
if
.d_string[str$h_maxlen] eql 0
then
begin
!+
! This must be the first get operation for this IOB. Allocate memory
! for the data to be read.
!-
$xpo_get_mem (characters = initial_buffer_size,
descriptor = d_string);
end;
if
.d_string[str$h_pfxlen] gtr 0
then
begin
!+
! adjust (manually) the descriptor so there is no prefix
! (start each GET operation at beginning of buffer, if there are
! leading nulls, then advance it.)
!-
d_string[str$a_pointer] =
ch$plus (.d_string[str$a_pointer], -.d_string[str$h_pfxlen]);
d_string[str$h_length] = .d_string[str$h_length] + .d_string[str$h_pfxlen];
d_string[str$h_pfxlen] = 0;
end;
!+
! Read from the terminal
! NOTE: we assume all reading will be from the primary input!!!
!-
IF
.iob[iob$v_terminal]
THEN
BEGIN
LOCAL
TextI_Blk : vector[7]; ! argument block for TEXTI jsys
!+
! Prompt if requested
!-
IF
.iob[iob$a_prompt] NEQ 0
THEN
BEGIN
cvtas0(prompt,prompt_z_ptr);
psout(.prompt_z_ptr);
END
ELSE
prompt_z_ptr = 0;
start_ptr = .d_string[str$a_pointer];
chars_read = 0;
!+
! do static initialization of TEXTI argument block
!-
texti_blk[$rdcwb] = 6; ! count of words following
texti_blk[$rdflg] = (rd_crf or ! suppress CR and return LF only
rd_bel or ! break on CR or LF
rd_brk or ! break on Ctrl-Z or ESC
rd_jfn); ! word [$rdioj] contains JFNs
texti_blk[$rdioj] = hwf($priin,$priou); ! input & output JFNs
texti_blk[$rdrty] = .prompt_z_ptr; ! prompt string
REPEAT
BEGIN
chars_remaining = .d_string[str$h_maxlen] - .chars_read;
!+
! do dynamic initialization of TEXTI argument block
!-
texti_blk[$rddbp] = .start_ptr;
texti_blk[$rddbc] = .chars_remaining;
texti_blk[$rdbfp] = .d_string[str$a_pointer];
TEXTI(texti_blk);
length = (.chars_read +
.chars_remaining - .texti_blk[$rddbc] - 1);
IF .pointr((texti_blk[$rdflg]),rd_btm)
THEN
EXITLOOP ! break char terminated input
ELSE
BEGIN ! byte count exhausted
chars_read = .chars_read + .chars_remaining;
start_ptr = expand_buffer(iob);
END;
END; !(of REPEAT loop)
!+
! a break character has been seen (only way to exit loop)
!-
ret_byte = ch$rchar(ch$plus(.texti_blk[$rddbp],-1)); !determine terminating byte
if
.ret_byte EQL ctrl_z
THEN
BEGIN
iob[iob$v_eof] = true;
! see additional EOF processing at end of routine
END;
IF .prompt_z_ptr NEQ 0
THEN
freas0(.prompt_z_ptr);
END
ELSE
!+
! read from disk
!-
BEGIN
IF
.iob[iob$v_sequenced]
THEN
!+
! for sequenced files word align ourselves and read the next 6 characters.
! the first five are sequence numbers the next a tab (except for page marks)
!-
BEGIN
!word allign ourselves
WHILE true
DO
BEGIN
rfptr(.jfn;err_code,byte_num);
IF
.byte_num MOD 5 NEQ 0
THEN
BIN(.jfn;ret_byte)
ELSE
EXITLOOP;
END;
!read 5 characters (sequence number)
DO
BEGIN
seq_num = 0; ! clear low order bit
IF
(status = sin(.jfn,
ch$ptr(seq_num),
5,
lf;
err_code,
upd_ptr,
upd_count)) EQL 0
THEN
if
at_eof(.jfn)
THEN
RETURN iob[iob$g_comp_code] = step$_eof
ELSE
RETURN iob[iob$g_comp_code] = sys_error(.err_code);
END
UNTIL
.seq_num NEQ 0;
asc_ptr = ch$ptr(seq_num);
!translate to decimal
iob[iob$g_seq_numb] = ascdec(asc_ptr,5);
IF
.iob[iob$g_seq_numb] EQL -1
THEN
!+
! Page mark
!-
BEGIN
iob[iob$g_seq_numb] = 0;
ch$wchar(ff,.d_string[str$a_pointer]);
d_string[str$h_length] = 1;
BIN(.jfn;ret_byte) ;
RETURN iob[iob$g_comp_code] = step$_normal;
END;
!read tab
BIN(.jfn;ret_byte) ;
END;
!+
! read record from disk looking for lf as terminating byte
!-
start_ptr = .d_string[str$a_pointer]; !iob[iob$a_string];
chars_read = 0;
REPEAT
BEGIN
chars_remaining = .d_string[str$h_maxlen] - .chars_read;
IF
(status = sin(.jfn,
.start_ptr,
.chars_remaining,
lf;
err_code,
upd_ptr,
upd_count)) EQL 0
THEN
BEGIN
if
at_eof(.jfn)
THEN
BEGIN
LOCAL
pointer;
length = .chars_read + .chars_remaining - .upd_count;
!remove trailing nulls
pointer = ch$plus(.start_ptr,.length-1);
UNTIL ch$rchar(.pointer) NEQ 0 OR .length EQL 0
DO
BEGIN
pointer = ch$plus(.pointer,-1);
length = .length-1;
END;
iob[iob$v_eof] = true;
EXITLOOP;
END
ELSE
RETURN iob[iob$g_comp_code] = sys_error(.err_code);
END;
IF .upd_count eql 0 AND ch$rchar(ch$plus(.upd_ptr,-1)) neq lf
THEN
BEGIN
chars_read = .chars_read + .chars_remaining;
start_ptr = expand_buffer(iob);
END
ELSE IF ch$rchar(ch$plus(.upd_ptr,-2)) neq cr
THEN
BEGIN ! lone <LF> found in file
start_ptr = ch$plus(.upd_ptr,0);
chars_read = .chars_read + (.chars_remaining - .upd_count);
END
ELSE
BEGIN
length = .chars_read + .chars_remaining - .upd_count - 2;
!upd_count is the amount of space
!left wubtract of the CR and LF
EXITLOOP;
END;
END; !(of REPEAT loop)
END;
!+
! return a descriptor to the read string
!-
d_string[str$h_length] = .length;
WHILE ch$rchar(.d_string[str$a_pointer]) eql null and .d_string[str$h_length] GTR 0
DO
BEGIN
ch$rchar_a (d_string[str$a_pointer]);
d_string[str$h_pfxlen] = .d_string[str$h_pfxlen] + 1;
d_string[str$h_length] = .d_string[str$h_length] - 1;
END;
!+
!
!-
IF
.iob[iob$v_eof] and .d_string[str$h_length] EQL 0
THEN
RETURN iob[iob$g_comp_code] = step$_eof;
RETURN iob[iob$g_comp_code] = step$_normal;
%fi
END;
global routine io$put(iobadr,sucadr,failadr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Do a put using system services
!
! FORMAL PARAMETERS:
!
! iobadr address of iob
!
! IMPLICIT INPUTS:
!
! fields in iob
!
! IMPLICIT OUTPUTS:
!
! fields in iob
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! standard system return codes
!
! SIDE EFFECTS:
!
! none
!--
BEGIN
%if VaxVms %then
LOCAL
seq_num,
status;
BIND
iob = .iobadr : $xpo_iob(),
rab = .iob[iob$a_rms_rab] : $rab_decl,
string = .iob[iob$a_output] : $str_descriptor();
check_iob_length(iob);
rab[rab$l_rbf] = .string[str$a_pointer];
rab[rab$w_rsz] = .string[str$h_length];
rab[rab$l_rhb] = seq_num;
seq_num =(IF .iob[iob$g_seq_numb] EQL 0
THEN %X'FFFF' ELSE .iob[iob$g_seq_numb]);
status = $rms_put(rab = rab, suc = .sucadr, err = 0);
iob[iob$g_2nd_code] = .rab[rab$l_stv];
RETURN iob[iob$g_comp_code] = .status;
%fi
%if Tops20 %then
LOCAL
err_code : block[1],
seq_num,
byte_num,
t_pointer,
status;
BIND
iob = .iobadr : $xpo_iob(),
string = .iob[iob$a_output] : $str_descriptor(),
jfn = iob[iob$h_channel];
check_iob_length(iob);
!+
! for sequenced files output sequence number word aligned first
!-
IF
.iob[iob$v_sequenced] AND NOT .iob[iob$v_terminal]
THEN
BEGIN
!word allign ourselves
WHILE true
DO
BEGIN
rfptr(.jfn;err_code,byte_num);
IF
.byte_num MOD 5 NEQ 0
THEN
BEGIN
IF
(status = bout(.jfn,null)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
END
ELSE
EXITLOOP;
END;
IF
.iob[iob$g_seq_numb] EQL 0
THEN
!page mark
seq_num = ' '
ELSE
decasz(.iob[iob$g_seq_numb],ch$ptr(seq_num),5);
sfbsz(.jfn,36);
seq_num = .seq_num OR 1;
IF
(status = BOUT(.jfn,.seq_num)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
sfbsz(.jfn,7);
IF
.iob[iob$g_seq_numb] EQL 0
THEN
BEGIN
IF
(status = BOUT(.jfn,cr)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
IF
(status = BOUT(.jfn,ff)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
RETURN iob[iob$g_comp_code] = step$_normal;
END
ELSE
BEGIN
IF
(status = BOUT(.jfn,ht)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
END;
END;
IF
.string[str$h_length] NEQ 0
THEN
BEGIN
IF
(status = sout(.jfn,
.string[str$a_pointer],
-.string[str$h_length],
0;
err_code)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
END;
!+
! output a trailing CR LF
!-
IF
(status = bout(.jfn,cr)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
IF
(status = bout(.jfn,lf)) EQL 0
THEN
BEGIN
geter($fhslf;err_code);
RETURN iob[iob$g_comp_code] = sys_error(.err_code[rh]);
END;
RETURN iob[iob$g_comp_code] = step$_normal;
%fi
END;
global routine io$rename (iobadr,sucadr,failadr) =
!++
! Functional Description:
!
! Like an XPORT rename only we use RMS or JSYS calls to save time.
!
! Formal Parameters:
!
! iobadr - address of IOB
! sucadr - success return address
! failadr - failure return address
!
! Implicit Inputs:
!
! none
!
! Implicit Outputs:
!
! none
!
! Routine Value:
! Completion Codes:
!
! Standard $RENAME values
!
! Side Effects:
!
! none
!
!--
BEGIN
%if VAXVMS %then
bind
old_iob = .iobadr: $xpo_iob() ,
old_file_spec = .old_iob[iob$a_file_spec] : $str_descriptor(),
new_iob = .old_iob[iob$a_assoc_iob] : $xpo_iob(),
new_file_spec = .new_iob[iob$a_file_spec] : $str_descriptor(),
old_fab = .old_iob[iob$a_rms_fab] : $fab_decl;
LOCAL
status,
new_fab : $fab_decl,
new_nam : $nam_decl,
new_nam_buf : vector[ch$allocation(nam$c_maxrss)];
$fab_init(fab=new_fab,nam=new_nam);
$nam_init(nam=new_nam,esa = new_nam_buf,ess = nam$c_maxrss);
!+
! give the file spec to RMS
!-
old_fab[fab$l_fna] = .old_file_spec[str$a_pointer];
old_fab[fab$b_fns] = .old_file_spec[str$h_length];
new_fab[fab$l_fna] = .new_file_spec[str$a_pointer];
new_fab[fab$b_fns] = .new_file_spec[str$h_length];
status = $rms_rename(oldfab=old_fab,newfab=new_fab,err=.failadr,suc=.sucadr);
!+
! fill in the IOB
!-
$str_desc_init(descriptor = old_iob[iob$t_resultant],
string = (.new_nam[nam$b_rsl],.new_nam[nam$l_rsa]));
old_iob[iob$g_comp_code] = .old_fab[fab$l_sts];
old_iob[iob$g_2nd_code] = .old_fab[fab$l_stv];
old_iob[iob$v_terminal] = ((.new_fab[fab$l_dev] and dev$m_trm) NEQ 0);
.status
%fi
%if tops20 %then
bind
old_iob = .iobadr: $xpo_iob() ,
new_iob = .old_iob[iob$a_assoc_iob] : $xpo_iob(),
new_file_spec = .new_iob[iob$a_file_spec] : $str_descriptor(),
old_file_spec = .old_iob[iob$a_file_spec] : $str_descriptor(),
new_jfn = new_iob[iob$h_channel],
old_jfn = old_iob[iob$h_channel];
LOCAL
status,
old_file_z_ptr,
new_file_z_ptr,
err_code;
!+
! figure out file specification for new file
!-
IF
.new_iob[iob$a_default] NEQ 0
THEN
BEGIN !we are using the xport file specification resolution routine
!however we must create a fake related descriptor to get it to work
new_iob[iob$a_related] = d_related;
xpo$build_spec(new_iob);
cvtas0(new_iob[iob$t_resultant],new_file_z_ptr);
END
ELSE
cvtas0(new_file_spec,new_file_z_ptr);
IF
gtjfn(gj_sht or gj_new or gj_fou,.new_file_z_ptr;new_jfn) EQL 0
THEN
RETURN old_iob[iob$g_comp_code] = sys_error(.new_jfn);
freas0(.new_file_z_ptr);
!+
! figure out file specification for old file
!-
IF
.old_iob[iob$a_default] NEQ 0
THEN
BEGIN !we are using the xport file specification resolution routine
!however we must create a fake related descriptor to get it to work
old_iob[iob$a_related] = d_related;
xpo$build_spec(.iobadr);
cvtas0(old_iob[iob$t_resultant],old_file_z_ptr);
END
ELSE
cvtas0(old_file_spec,old_file_z_ptr);
IF
gtjfn(gj_sht or gj_old,.old_file_z_ptr;old_jfn) EQL 0
THEN
RETURN old_iob[iob$g_comp_code] = sys_error(.old_jfn);
freas0(.old_file_z_ptr);
IF
rnamf(.old_jfn,.new_jfn;err_code) EQL 0
THEN
RETURN old_iob[iob$g_comp_code] = sys_error(.err_code);
!+
! fill in resultant specification
!-
jfnstr(new_jfn,old_iob[iob$t_resultant]);
RETURN old_iob[iob$g_comp_code] = step$_normal;
%fi
END;
global routine io$delete (iobadr,sucadr,failadr) =
!++
! Functional Description:
!
! Like an XPORT delete only we use RMS to save time.
!
! Formal Parameters:
!
! iobadr - address of IOB
! sucadr - success return address
! failadr - failure return address
!
! Implicit Inputs:
!
! none
!
! Implicit Outputs:
!
! none
!
! Routine Value:
! Completion Codes:
!
! Standard $delete values
!
! Side Effects:
!
! none
!
!--
BEGIN
%if VaxVms %then
bind
iob = .iobadr: $xpo_iob() ,
file_spec = .iob[iob$a_file_spec] : $str_descriptor(),
fab = .iob[iob$a_rms_fab] : $fab_decl,
nam = .fab[fab$l_nam] : $nam_decl;
LOCAL
status;
!+
! give the file spec to RMS
!-
fab[fab$l_fna] = .file_spec[str$a_pointer];
fab[fab$b_fns] = .file_spec[str$h_length];
status = $rms_erase(fab=fab);
!=
! fill in the IOB
!-
$str_desc_init(descriptor = iob[iob$t_resultant],
string = (.nam[nam$b_rsl],.nam[nam$l_rsa]));
iob[iob$g_comp_code] = .fab[fab$l_sts];
iob[iob$g_2nd_code] = .fab[fab$l_stv];
.status
%fi
%if Tops20 %then
bind
iob = .iobadr: $xpo_iob() ,
file_spec = .iob[iob$a_file_spec] : $str_descriptor(),
jfn = iob[iob$h_channel];
LOCAL
err_code,
status,
file_z_ptr;
!+
! figure out file specification
!-
IF
.iob[iob$a_default] NEQ 0
THEN
BEGIN !we are using the xport file specification resolution routine
!however we must create a fake related descriptor to get it to work
iob[iob$a_related] = d_related;
xpo$build_spec(.iobadr);
cvtas0(iob[iob$t_resultant],file_z_ptr);
END
ELSE
cvtas0(file_spec,file_z_ptr);
IF
gtjfn(gj_sht or gj_old,.file_z_ptr;jfn) EQL 0
THEN
RETURN iob[iob$g_comp_code] = sys_error(.jfn);
freas0(.file_z_ptr);
IF
delf(.jfn;err_code) EQL 0
THEN
RETURN iob[iob$g_comp_code] = sys_error(.err_code);
!+
! fill in resultant specification
!-
jfnstr(jfn,iob[iob$t_resultant]);
RETURN iob[iob$g_comp_code] = step$_normal;
%fi
END;
END ! End of module
ELUDOM