#HD#: *getto.r* 2355 Oct-31-1984 07:58:21 # getto --- get to the last file in a path name integer function getto (pathin, pfilename, ppwd, attach_sw) character pathin (ARB) integer pfilename (16), ppwd (3) integer attach_sw include SWT_COMMON integer expand, mktr$ character dirname (MAXTREE), temp (MAXPATH) character fulltree (MAXTREE), diskname (17) integer count, loop, sp, tp, j, save_bplabel (4) shortcall mkonu$ (18) external bponu$ procedure check_code forward procedure getname forward procedure putname forward procedure restore_Bplabel forward call break$ (DISABLE) # no interruptions do j = 1, 4 # while changing save_bplabel (j) = Bplabel (j) # common block values call mklb$f ($1, Bplabel) call break$ (ENABLE) call mkonu$ ("BAD_PASSWORD$"v, loc (bponu$)) attach_sw = YES if (expand (pathin, temp, MAXPATH) == ERR) { attach_sw = NO restore_Bplabel return (ERR) } call mktr$ (temp, fulltree) call mapstr (fulltree, UPPER) if (pathin (1) == EOS) { # case of current directory call at$hom (Errcod) check_code tp = 1 putname pfilename (1) = KCURR # Primos key for current directory attach_sw = NO restore_Bplabel return (OK) } # Count the number of pathname elements to worry about count = 0 for (loop = 1; fulltree (loop) ~= EOS; loop += 1) if (fulltree (loop) == '>'c) count += 1 if (~ (fulltree (1) == '<'c | fulltree (1) == '*'c)) count += 1 loop = 1 repeat { if (loop ~= 1) { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } elif (fulltree (1) == '<'c) { # absolute partition reference if ( ~IS_DIGIT (fulltree (2))) { # partition name (characters) for (tp = 2; fulltree (tp) ~= '>'c; tp += 1) temp (tp - 1) = fulltree (tp) temp (tp - 1) = EOS tp += 1 # step past '>' sp = 1 call ctov (temp, sp, diskname, 17) if (count == 1) putname getname call at$abs (KSETC, diskname, dirname, Errcod) } else { # partition is specified by LDEV number for (tp = 1; fulltree (tp) ~= '>'c; tp += 1) temp (tp) = fulltree (tp) tp += 1 # step past '>' if (count == 1) putname temp (tp - 1) = '>'c for (; fulltree (tp) ~= '>'c && fulltree (tp) ~= EOS; tp += 1) temp (tp) = fulltree (tp) temp (tp) = EOS tp += 1 # step past '>' sp = 1 call ctov (temp, sp, dirname, MAXTREE) call at$ (KSETC, dirname, Errcod) } if (count == 1) { check_code call at$abs (KSETC, "*"v, "MFD XXXXXX"v, Errcod) check_code restore_Bplabel return (OK) } } elif (fulltree (1) == '*'c) { # name references current directory tp = 3 if (count == 1) { # name is in current directory attach_sw = NO putname restore_Bplabel return (OK) } else { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } } else { # absolute reference on any partition tp = 1 if (count == 1) putname getname call at$any (KSETC, dirname, Errcod) if (count == 1) { # special case of //name check_code call at$abs (KSETC, "*"v, "MFD XXXXXX"v, Errcod) check_code restore_Bplabel return (OK) } } check_code loop += 1 } until (loop >= count) putname restore_Bplabel return (OK) 1 continue # bad password return Errcod = EBPAS check_code # check_code --- check return code for errors procedure check_code { local i; integer i if (Errcod ~= 0) { call at$hom (i) attach_sw = NO restore_Bplabel return (ERR) } } # getname --- get the name of the next node in the treename procedure getname { local i, sp; integer i, sp for (i = 1; fulltree (tp) ~= '>'c && fulltree (tp) ~= EOS; {i += 1; tp += 1}) temp (i) = fulltree (tp) temp (i) = EOS tp += 1 # step past the '>' sp = 1 call ctov (temp, sp, dirname, 21) if (i > 40) { Errcod = EITRE check_code } } # putname --- put name and password into 'pfilename' and # 'ppwd' in packed format procedure putname { local i; integer i do i = 1,3 ppwd (i) = " " do i = 1,16 pfilename (i) = " " j = 0 for (i = tp; fulltree (i) ~= EOS && fulltree (i) ~= ' 'c && j <= 32; i += 1) spchar (pfilename, j, fulltree (i)) if (fulltree (i) ~= EOS) { j = 0 for (i += 1; fulltree (i) ~= EOS && j <= 6; i += 1) spchar (ppwd, j, fulltree (i)) } } # restore_Bplabel --- restore saved value of Bplabel procedure restore_Bplabel { local i; integer i call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing Bplabel (i) = save_bplabel (i) # common block values call break$ (ENABLE) } end #HD#: *tscan$.r* 2558 Oct-31-1984 07:58:21 # tscan$ --- traverse tree in the file system integer function tscan$ (path, buf, clev, nlev, action) integer buf (MAXDIRENTRY), clev, nlev, action character path (MAXPATH) common /c$tscn/ state, svgt, svat, sveos, svun (MAXLEV), svps (MAXLEV), svbf (MAXDIRENTRY, MAXLEV), svpw (3, MAXLEV), svpath (MAXPATH) character svpath # original pathname integer sveos, # intermediate EOS position svun, # file unit stack svps, # end of path stack svbf, # directory buffer stack svpw, # directory password stack state # current state bool svgt, # TRUE if a Ga. Tech Primos installation svat # TRUE if reattach has been done on this call integer type, code, i, l, pwd (3), opwd (3), npwd (3) integer follow, ctoc, expand, equal, upkfn$ procedure check_postorder forward procedure reattach forward procedure enter_pwd forward procedure enter_info forward procedure fix_path forward svat = FALSE # we've done no reattach yet on this call if (clev == 0) { # first call, initialize everything ### Set up the state vectors if (expand ("=GaTech="s, svpath, MAXPATH) == ERR || equal (svpath, "yes"s) == NO) svgt = FALSE else svgt = TRUE clev = 1 svps (clev) = ctoc (path, svpath, MAXPATH) + 1 if (and (action, REATTACH) ~= 0) reattach ### Open the current directory for reading call srch$$ (KREAD + KGETU, KCURR, 0, svun (clev), type, code) if (code ~= 0) { clev = 0 return (EOF) } call dir$rd (KINIT, svun (clev), loc (buf), MAXDIRENTRY, code) state = GET_NEXT_ENTRY } repeat { select (state) when (DESCEND) { # descend to next level if (and (action, REATTACH) ~= 0 && ~ svat) reattach if (clev >= nlev) { # are we at the limit? state = GET_NEXT_ENTRY check_postorder next } ### Attach to the new directory enter_pwd call at$swt (svbf (2, clev), 32, 0, pwd, KICUR, code) if (code ~= 0) { state = COULDNT_DESCEND return (ERR) } clev += 1 ### Open it for reading call srch$$ (KREAD + KGETU, KCURR, 0, svun (clev), type, code) if (code ~= 0) { state = ASCEND return (ERR) } state = GET_NEXT_ENTRY } when (COULDNT_DESCEND) { # couldn't descend into last dir if (~ svat) reattach state = GET_NEXT_ENTRY check_postorder } when (GET_NEXT_ENTRY) { # get next entry from this level if (and (action, REATTACH) ~= 0 && ~ svat) reattach path (svps (clev)) = EOS call dir$rd (KREAD, svun (clev), loc (buf), MAXDIRENTRY, code) if (code ~= 0) state = ATEOD elif (rs(buf(1),8) == 2 || rs(buf(1),8) == 3) { buf (1) = 0 # indicate preorder encounter fix_path if (and (buf (20), 8r10007) == 4) { # a ufd but not mfd enter_info # next time we're called, we will state = DESCEND # descend another level } if ( ~(and (buf (20), 7) == 4) # file type is NOT ufd || and (action, PREORDER) ~= 0) return (OK) } # else stay in this state } when (ATEOD) { # at end of directory if (and (action, REATTACH) ~= 0 && ~ svat) reattach call srch$$ (KCLOS, 0, 0, svun (clev), 0, code) state = ASCEND if (and (action, EODPAUSE) ~= 0) return (EOD) } when (ASCEND) { # pop up one level clev -= 1 if (clev <= 0) break reattach state = GET_NEXT_ENTRY check_postorder } else call error ("in tscan$: can't happen"s) } return (EOF) # check_postorder --- return entry on postorder encounter if desired procedure check_postorder { if (and (action, POSTORDER) ~= 0) { call move$ (svbf (1, clev), buf, MAXDIRENTRY) buf (1) = 1 # indicate postorder encounter return (OK) } } # enter_pwd --- get password for next lower directory procedure enter_pwd { local valid_name; bool valid_name local junk; integer junk call gpas$$ (svbf (2, clev), 32, opwd, npwd, code) call texto$ (opwd, 6, junk, valid_name) if (code == ENRIT) { pwd (1) = " " pwd (2) = " " pwd (3) = " " } elif (svgt && valid_name) { pwd (1) = npwd (1) pwd (2) = npwd (2) pwd (3) = npwd (3) } else { pwd (1) = opwd (1) pwd (2) = opwd (2) pwd (3) = opwd (3) } do i = 1, 3 svpw (i, clev) = pwd (i) l = sveos if (pwd (1) ~= " " && pwd (1) ~= 0) { path (l) = ':'c l += 1 + upkfn$ (pwd, 6, path (l + 1), MAXPATH - l) } svps (clev + 1) = l } # fix_path --- add name of current entry to pathname procedure fix_path { l = svps (clev) if (l > 1) { path (l) = '/'c l += 1 } l += upkfn$ (buf (2), 32, path (l), MAXPATH - l + 1) sveos = l } # enter_info --- save info in current directory entry procedure enter_info { call move$ (buf, svbf (1, clev), MAXDIRENTRY) } # reattach --- attach back to the same place procedure reattach { svat = TRUE call at$hom (code) if (follow (svpath, 0) == ERR) { state = ATEOD return (ERR) } for (i = 1; i < clev; i += 1) { call at$swt (svbf (2, i), 32, 0, svpw (1, i), KICUR, code) if (code ~= 0) { state = ATEOD return (ERR) } } } end #HD#: *vtterm.r* 6081 Oct-31-1984 07:58:22 # vtterm --- initialize the common block with values for # the terminal type given integer function vtterm (term_type) integer term_type (MAXTERMTYPE) include SWT_COMMON integer fd, i, bp, tp, sp, f, state integer len_ac (MAXCOORDTYPE), len_hc (MAXCOORDTYPE), len_vc (MAXCOORDTYPE) integer open, length, strbsr, equal, ctoi, getlin, mntoc integer vt$alc, ctoc, vt$ier, gttype, gtattr character fname (MAXLINE) character buf (MAXLINE), tbuf (MAXLINE), sbuf (MAXLINE) character mntoc ################################################################### # Instructions for adding new routines to vth: # # New coordinate types # 1. Increase the definition for MAXCOORDTYPE by one. # 2. Add code in 'vtterm' to check the applicability # of horizontal, vertical, and absolute positioning # sequences. # 3. Add another entry to the 'data' statements giving # the length of coordinates for the three positioning # sequences. # 4. Add code to 'vtpos' to correctly generate both # horizontal and vertical coordinates for the new # coordinate type. # # New positioning types # 1. Increase the definition for MAXPOSTYPE by one. # 2. Add code in 'vtterm' to check the applicability of # horizontal, vertical, and absolute positioning # sequences. # 3. Add code to 'vtpos' to perform the positioning. # # New input control functions: # 1. Add a definition for the function to the definitions # file. Define it to be one greater than the integer # used on the last control function definition. # 2. Add the definition and the string to be used to # recognize the function in the vth file # 3. Add the code to perform the function to the 'select' # statement in 'vt$get'. ################################################################### ### Length of absolute positioning coordinate sequences data len_ac / _ 2, # + ASCII char, + ASCII char 2, # , (b200) 6, # , (sbee) 3, # , (adds 980) 6, # (cg) 6/ # y, C (hp) ### Length of vertical positioning coordinate sequences data len_vc / _ 1, # + ASCII char 1, # (b200) 3, # (sbee) 1, # (adds 980) 3, # (cg) 3/ # (hp) ### Length of horizontal positioning coordinate sequences data len_hc / _ 1, # + ASCII char 1, # (b200) 3, # (sbee) 2, # (adds 980) 3, # (cg) 3/ # (hp) string_table ipos, itext, / ATTN, "attn", / DEFINE, "define", / DEFINITION, "definition", / VTH_ESCAPE, "escape", / FIX_SCREEN, "fix_screen", / FUNNY_RETURN, "funny_return", / GOBBLE_LEFT, "gobble_left", / GOBBLE_RIGHT, "gobble_right", / GOBBLE_SCAN_LEFT, "gobble_scan_left", / GOBBLE_SCAN_RIGHT, "gobble_scan_right", / GOBBLE_TAB_LEFT, "gobble_tab_left", / GOBBLE_TAB_RIGHT, "gobble_tab_right", / INSERT_BLANK, "insert_blank", / INSERT_NEWLINE, "insert_newline", / INSERT_TAB, "insert_tab", / KILL_ALL, "kill_all", / KILL_LEFT, "kill_left", / KILL_RIGHT, "kill_right", / KILL_RIGHT_AND_RETURN, "kill_right_and_return", / MOVE_DOWN, "move_down", / MOVE_LEFT, "move_left", / MOVE_RIGHT, "move_right", / MOVE_UP, "move_up", / PF, "pf", / RETURN, "return", / SCAN_LEFT, "scan_left", / SCAN_RIGHT, "scan_right", / SHIFT_CASE, "shift_case", / SKIP_LEFT, "skip_left", / SKIP_RIGHT, "skip_right", / TAB_CLEAR, "tab_clear", / TAB_LEFT, "tab_left", / TAB_RESET, "tab_reset", / TAB_RIGHT, "tab_right", / TAB_SET, "tab_set", / TOGGLE_INSERT_MODE, "toggle_insert_mode", / UNDEFINE, "undefine" string_table opos, otext, / ABS_POS, "abs_pos", / CLEAR_SCREEN, "clear_screen", / CLEAR_TO_EOL, "clear_to_eol", / CLEAR_TO_EOS, "clear_to_eos", / COLUMNS, "columns", / COORD_TYPE, "coord_type", / CURSOR_DOWN, "cursor_down", / CURSOR_HOME, "cursor_home", / CURSOR_LEFT, "cursor_left", / CURSOR_RIGHT, "cursor_right", / CURSOR_UP, "cursor_up", / DELAY_TIME, "delay_time", / DELETE_CHAR, "delete_char", / DELETE_LINE, "delete_line", / HOR_POS, "hor_pos", / INSERT_CHAR, "insert_char", / INSERT_LINE, "insert_line", / INSERT_STRING, "insert_string", / ROWS, "rows", / SHIFT_IN, "shift_in", / SHIFT_OUT, "shift_out", / SHIFT_TYPE, "shift_type", / VERT_POS, "vert_pos", / WRAP_AROUND, "wrap_around" procedure getword forward procedure getseq forward procedure interpret_input forward procedure interpret_output forward define (err (msg), return (vt$ier (msg, fname, buf, fd))) if (gttype (term_type) == NO || gtattr (TA_VTH_USEABLE) == NO) return (ERR) call encode (fname, MAXLINE, "=vth=/*s"s, term_type) fd = open (fname, READ) if (fd == ERR) return (ERR) Last_def = 0 Fn_used (1) = YES do i = 2, MAXESCAPE Fn_used (i) = NO do i = 1, CHARSETSIZE Fn_tab (i, 1) = EOS do i = 1, MAXCOLS Tabs (i) = NO do i = 1, MAXCOLS, 3 Tabs (i) = YES do i = 1, MAXROWS; { Input_start (i) = MAXCOLS Input_stop (i) = 0 } Maxrow = 8 Maxcol = 32 Tc_clear_screen (1) = EOS Tc_clear_to_eol (1) = EOS Tc_clear_to_eos (1) = EOS Tc_cursor_home (1) = EOS Tc_cursor_left (1) = EOS Tc_cursor_right (1) = EOS Tc_cursor_up (1) = EOS Tc_cursor_down (1) = EOS Tc_abs_pos (1) = EOS Tc_vert_pos (1) = EOS Tc_hor_pos (1) = EOS Tc_ins_line (1) = EOS Tc_del_line (1) = EOS Tc_ins_char (1) = EOS Tc_del_char (1) = EOS Tc_ins_str (1) = EOS Tc_shift_in (1) = EOS Tc_shift_out (1) = EOS Tc_coord_char = ' 'c Tc_shift_char = NUL Tc_coord_type = 0 Tc_seq_type = 0 Tc_delay_time = 0 Tc_wrap_around = YES Tc_clr_len = 9999 Tc_ceos_len = 9999 Tc_ceol_len = 9999 Tc_abs_len = 9999 Tc_vert_len = 9999 Tc_hor_len = 9999 state = ERR while (getlin (tbuf, fd) ~= EOF) { for ({tp = 1; bp = 1}; tbuf (tp) ~= NEWLINE && tbuf (tp) ~= EOS; {tp += 1; bp += 1}) { if (tbuf (tp) == '@'c && tbuf (tp + 1) ~= EOS) tp += 1 else if (tbuf (tp) == '#'c) break buf (bp) = tbuf (tp) } buf (bp) = EOS bp = 1 getword select when (tbuf (1) == EOS) ; when (equal (tbuf, "input"s) == YES) state = READ when (equal (tbuf, "output"s) == YES) state = WRITE ifany next select (state) when (ERR) err ("characteristic appears before 'input' or 'output'"s) when (READ) { f = strbsr (ipos, itext, 1, tbuf) if (f == EOF) err ("unrecognized keyword"s) f = itext (ipos (f)) interpret_input } when (WRITE) { f = strbsr (opos, otext, 1, tbuf) if (f == EOF) err ("unrecognized keyword"s) f = otext (opos (f)) interpret_output } } call close (fd) ### Fill in the default characters for the first table for (i = 1; i < CHARSETSIZE; i += 1) if (Fn_tab (i, 1) == EOS) Fn_tab (i, 1) = i + CHARSETBASE ### Check the plausibility of all control sequences if (Tc_clear_screen (1) == EOS) err ("Screen clear sequence required"s) Tc_clr_len = length (Tc_clear_screen) if (Tc_clear_to_eol (1) ~= EOS) Tc_ceol_len = length (Tc_clear_to_eol) if (Tc_clear_to_eos (1) ~= EOS) Tc_ceol_len = length (Tc_clear_to_eos) if (Tc_coord_type < 1 || Tc_coord_type > MAXCOORDTYPE) err ("Invalid coordinate type"s) select (Tc_seq_type) when (1, 2) { if (Tc_abs_pos (1) == EOS) err ("Absolute positioning sequence required"s) Tc_abs_len = length (Tc_abs_pos) + len_ac (Tc_coord_type) if (Tc_vert_pos (1) ~= EOS) Tc_vert_len = length (Tc_vert_pos) if (Tc_hor_pos (1) ~= EOS) Tc_hor_len = length (Tc_hor_pos) } when (3) { if (Tc_vert_pos (1) == EOS || Tc_hor_pos (1) == EOS) err ("Horizontal/vertical sequence missing"s) Tc_vert_len = length (Tc_vert_pos) + len_vc (Tc_coord_type) Tc_hor_len = length (Tc_hor_pos) + len_hc (Tc_coord_type) } else err ("Invalid sequence type"s) DEBUG call vt$db DEBUG call vt$db2 return (OK) # getword --- get a "word" from 'buf'; put it in 'tbuf' procedure getword { SKIPBL (buf, bp) for (tp = 1; buf (bp) ~= ' 'c && buf (bp) ~= EOS; {bp += 1; tp += 1}) tbuf (tp) = buf (bp) tbuf (tp) = EOS } # interpret_output --- interpret a line for an output control sequence procedure interpret_output { select (f) when (CLEAR_SCREEN) { getseq call ctoc (sbuf, Tc_clear_screen, SEQSIZE) } when (CLEAR_TO_EOL) { getseq call ctoc (sbuf, Tc_clear_to_eol, SEQSIZE) } when (CLEAR_TO_EOS) { getseq call ctoc (sbuf, Tc_clear_to_eos, SEQSIZE) } when (CURSOR_HOME) { getseq call ctoc (sbuf, Tc_cursor_home, SEQSIZE) } when (CURSOR_LEFT) { getseq call ctoc (sbuf, Tc_cursor_left, SEQSIZE) } when (CURSOR_RIGHT) { getseq call ctoc (sbuf, Tc_cursor_right, SEQSIZE) } when (CURSOR_UP) { getseq call ctoc (sbuf, Tc_cursor_up, SEQSIZE) } when (CURSOR_DOWN) { getseq call ctoc (sbuf, Tc_cursor_down, SEQSIZE) } when (ABS_POS) { getseq call ctoc (sbuf, Tc_abs_pos, SEQSIZE) } when (VERT_POS) { getseq call ctoc (sbuf, Tc_vert_pos, SEQSIZE) } when (HOR_POS) { getseq call ctoc (sbuf, Tc_hor_pos, SEQSIZE) } when (DELETE_LINE) { getseq call ctoc (sbuf, Tc_del_line, SEQSIZE) } when (INSERT_LINE) { getseq call ctoc (sbuf, Tc_ins_line, SEQSIZE) } when (INSERT_CHAR) { getseq call ctoc (sbuf, Tc_ins_char, SEQSIZE) } when (DELETE_CHAR) { getseq call ctoc (sbuf, Tc_del_char, SEQSIZE) } when (INSERT_STRING) { getseq call ctoc (sbuf, Tc_ins_str, SEQSIZE) } when (SHIFT_IN) { getseq call ctoc (sbuf, Tc_shift_in, SEQSIZE) } when (SHIFT_OUT) { getseq call ctoc (sbuf, Tc_shift_out, SEQSIZE) } when (COORD_TYPE) { Tc_seq_type = ctoi (buf, bp) Tc_coord_type = ctoi (buf, bp) SKIPBL (buf, bp) Tc_coord_char = mntoc (buf, bp, NUL) } when (SHIFT_TYPE) { SKIPBL (buf, bp) Tc_shift_char = mntoc (buf, bp, NUL) } when (WRAP_AROUND) { getword if (equal (tbuf, "YES"s) == YES) Tc_wrap_around = YES else Tc_wrap_around = NO } when (DELAY_TIME) Tc_delay_time = bound (ctoi (buf, bp), 1, MAXCOLS) when (ROWS) Maxrow = bound (ctoi (buf, bp), 1, MAXROWS) when (COLUMNS) Maxcol = bound (ctoi (buf, bp), 1, MAXCOLS) } # getseq --- get a control sequence from 'buf'; put it 'sbuf' procedure getseq { DEBUG local i, buf; integer i, buf (4) sp = 0 repeat { sp += 1 getword if (tbuf (1) == EOS) break tp = 1 sbuf (sp) = mntoc (tbuf, tp, EOS) } until (sbuf (sp) == EOS || sp >= MAXLINE) sbuf (sp) = EOS DEBUG for (i = 1; i <= sp; i += 1) { DEBUG call ctomn (sbuf (i), buf) DEBUG call print (ERROUT, "*s "s, buf) DEBUG } DEBUG call print (ERROUT, "*n"s) } # interpret_input --- interpret a line giving an input control sequence procedure interpret_input { local ent, tbl, pos; integer ent, tbl, pos if (f == CHAR) { getword f = mntoc (tbuf, 1, ' 'c) } else if (f == PF) f -= ctoi (buf, bp) getseq if (sp <= 1) err ("input control sequence must be specified"s) tbl = 1 for (i = 1; i < sp - 1; i += 1) { ent = Fn_tab (sbuf (i) - CHARSETBASE, tbl) if (ent == EOS) { if (vt$alc (tbl, sbuf (i) - CHARSETBASE) == ERR) err ("too many unique sequence prefixes"s) } else if (ent > GET_NEXT_TABLE) tbl = ent - GET_NEXT_TABLE else err ("proper substring of another sequence is illegal"s) } pos = sbuf (i) - CHARSETBASE if (Fn_tab (pos, tbl) ~= EOS) err ("sequence previously defined"s) if (f == DEFINITION) { if (sp + 1 >= MAXDEF) err ("too many definitions"s) getseq Last_def += 1 f += Last_def Def_buf (Last_def) = EOS Last_def += 1 + ctoc (sbuf, Def_buf (Last_def + 1), MAXDEF - Last_def) } Fn_tab (pos, tbl) = f } undefine (err) end #HD#: addset.r 131 Nov-27-1984 01:10:55 # addset --- put c in set (j) if it fits, increment j integer function addset (c, set, j, maxsiz) integer j, maxsiz character c, set (maxsiz) if (j > maxsiz) addset = NO else { set (j) = c j += 1 addset = YES } return end #HD#: amatch.r 670 Nov-27-1984 01:10:55 # amatch --- (non-recursive) look for match starting at lin (from) integer function amatch (lin, from, pat, tagbeg, tagend) character lin (ARB), pat (MAXPAT) integer from, tagend (9), tagbeg (9) integer omatch, patsiz integer i, j, offset, stack stack = 0 offset = from # next unexamined input character for (j = 1; pat (j) ~= EOS; j += patsiz (pat, j)) if (pat (j) == PAT_CLOSURE) { # a closure entry stack = j j += PAT_CLOSIZE # step over PAT_CLOSURE for (i = offset; lin (i) ~= EOS; ) # match as many as if (omatch (lin, i, pat, j) == NO) # possible break pat (stack + PAT_COUNT) = i - offset pat (stack + PAT_START) = offset offset = i # character that made us fail } else if (pat (j) == PAT_START_TAG) { i = pat (j + 1) tagbeg (i) = offset } else if (pat (j) == PAT_STOP_TAG) { i = pat (j + 1) tagend (i) = offset } else if (omatch (lin, offset, pat, j) == NO) { # non-closure for ( ; stack > 0; stack = pat (stack + PAT_PREVCL)) if (pat (stack + PAT_COUNT) > 0) break if (stack <= 0) { # stack is empty amatch = 0 # return failure return } pat (stack + PAT_COUNT) -= 1 j = stack + PAT_CLOSIZE offset = pat (stack + PAT_START) + pat (stack + PAT_COUNT) } # else omatch succeeded amatch = offset return # success end #HD#: at$swt.s 483 Nov-27-1984 01:10:55 * at$swt --- bad-password-proof interlude to atch$$ SUBR AT$SWT SEG RLIT include "=syscom=/errd.ins.pma" include "=incl=/lib_def.s.i" LINK AT$SWT ECB AT$0,,NAME,6,66 DATA 6,C'AT$SWT' PROC DYNM =38,NAME(3),NAMEL(3),LDISK(3),PWD(3),KEY(3),CODE(3) DYNM ARGS(6),DESCR(4) EXT MKONU$ AT$0 ARGT ENTR AT$SWT EAL BP_UNIT STL DESCR+0 EAL SB% STL DESCR+2 EAL CNAME STL ARGS+0 EAL DESCR STL ARGS+3 EAL ARGS JSXB MKONU$ CALL ATCH$$ AP NAME,*S AP NAMEL,*S AP LDISK,*S AP PWD,*S AP KEY,*S AP CODE,*SL PRTN BP LDA =E$BPAS STA CODE,* PRTN CNAME DATA 13,C'BAD_PASSWORD$' EJCT * bp_unit --- on-unit for the BAD_PASSWORD$ condition DYNM =20,CP(3),LABEL(4) LINK BP_UNIT ECB BP_UNIT0,,CP,1,28 DATA 11,C'AT$.BP_UNIT' PROC BP_UNIT0 ARGT STL LABEL+2 EAL BP IAB STL LABEL+0 CALL PL1$NL AP LABEL,SL END #HD#: atoc.r 323 Nov-27-1984 01:10:55 # atoc --- convert address to string integer function atoc (ptr, xstr, size) integer ptr (3), size character xstr (ARB) integer i integer gitoc, ctoc character str (18) i = 0 if (ptr (1) < 0) { i += 1 str (i) = 'f'c } i += 1 str (i) = and (rs (ptr (1), 13), 3) + '0'c # insert ring number str (i + 1) = '.'c i += gitoc (and (ptr (1), 8r7777), str (i + 2), 5, 8) + 1 str (i + 1) = '.'c i += gitoc (ptr (2), str (i + 2), 7, -8) + 1 if (and (ptr (1), 8r10000) ~= 0) { str (i + 1) = '.'c i += gitoc (rs (ptr (3), 12), str (i + 2), 3, 8) + 1 } return (ctoc (str, xstr, size)) end #HD#: bponu$.r 104 Nov-27-1984 01:10:56 # bponu$ --- on-unit for the BAD_PASSWORD$ condition subroutine bponu$ (cp) longint cp include SWT_COMMON call pl1$nl (Bplabel) call remark ("in bponu$: can't happen"s) return end #HD#: c$end.r 214 Nov-27-1984 01:10:56 # c$end --- clean up after statement count run, output data subroutine c$end integer fd, i integer create integer limit longint count (1) common /c$stc/ limit, count string outfile "_st_count" fd = create (outfile, READWRITE) if (fd == ERR) call cant (outfile) limit -= 1 # last entry is bogus do i = 1, limit call print (fd, "*l*n"p, count (i)) call close (fd) return end #HD#: c$incr.r 103 Nov-27-1984 01:10:56 # c$incr --- increment count for a given statement subroutine c$incr (stmt) integer stmt integer limit longint count (1) common /c$stc/ limit, count count (stmt) += 1 return end #HD#: call$$.s 2864 Nov-27-1984 01:10:56 * call$$ --- execute a P300 or SEG or EPF runfile as a procedure * * integer function call$$ (name, length) * integer name (16), length SUBR CALL$$ SEG RLIT include "=syscom=/errd.ins.pma" include "=syscom=/keys.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" EJCT LINK CALL$$ ECB CALL0,,NAME,3 DATA 6,C'CALL$$' PROC DYNM =38,NAME(3),LENGTH(3),ONUNIT(3) DYNM CODE,RTNSAVE(4),NEWECB(9),RVEC(9) DYNM ARGS(2*3),DESCR(4),STATE(MAXFILESTATE) DYNM FUNIT,TYPE,SMT(2) ECB_PB EQU XB%+0 ECB_FRAME EQU XB%+2 ECB_ROOT EQU XB%+3 ECB_ARGD EQU XB%+4 ECB_NARGS EQU XB%+5 ECB_LB EQU XB%+6 ECB_KEYS EQU XB%+8 RV_PB EQU RVEC+1 RV_L EQU RVEC+3 RV_X EQU RVEC+5 RV_KEYS EQU RVEC+6 RV_ECBAD EQU RVEC+7 K$VMR EQU '20 K$REST EQU '2 EXT MKONU$ CALL0 ARGT ENTR CALL$$ Set up ECB pointer in stack frame CRL Zero out the smt pointer STL SMT CALL MOVE$ Clear P300 fault vectors AP ZEROS,S AP SECTOR0,*S AP =14,SL CALL REST$$ Bring runfile into memory AP RVEC,S AP NAME,*S AP LENGTH,*S AP CODE,SL LDA CODE Check return code... BEQ CHECKECBAD ...successfully loaded SUB =E$BPAR See if we have a SEG runfile... BEQ SEGDIR ...maybe; try loading it LDA =ERR ...error in loading PRTN SEGDIR CALL LDSEG$ Try loading as a SEG runfile AP RVEC,S AP NAME,*S AP LENGTH,*S AP CODE,SL LDA CODE Check return code... BEQ CHECKECBAD ...successfully loaded SUB =E$NTSD See if we have an EPF BEQ EPF_LOAD ...maybe; try loading it LDA =ERR ...error in loading PRTN EPF_LOAD CALL BREAK$ Prevent wierd things during AP =DISABLE,SL the EPF restoration CALL SRCH$$ Attempt to open the file AP =K$VMR+K$GETU,S AP NAME,*S AP LENGTH,*S AP FUNIT,S AP TYPE,S AP CODE,SL LDA CODE Did it open correctly ?? BEQ EPF_REST Yes...next step CALL BREAK$ Didn't work, Re-enable breaks AP =ENABLE,SL LDA =ERR PRTN Return error EPF_REST CALL R$RUN Restore the file into memory AP =K$REST,S AP FUNIT,S AP CODE,SL STL SMT Save the SMT pointer CALL SRCH$$ Close the vmfa file AP =K$CLOS,S AP =C'',S AP =0,S AP FUNIT,S AP TYPE,S AP TYPE,SL Junk variable LDA CODE Test the return code BEQ CALLIT1 No error, prepare for execution LDA =ERR Return error PRTN CHECKECBAD LDL RV_ECBAD Check for address of main ECB... BLEQ CHECKRMODE ...missing, could be an R-mode program STLR PB%+15 Make ECB addressable through XB register CHECKECB LDA ECB_NARGS Check for zero arguments BNE RMODE LDA ECB_KEYS Check keys ANA =$5C1F Ignore exception enables & cond. codes ERA =$1800 Check for 64V addressing mode BEQ CALLIT ERA =$0800 Check for 32I addressing mode BNE RMODE CALLIT CALL BREAK$ Disable breaks AP =DISABLE,SL CALLIT1 LDA CMDSTAT See if we have a pending quit BEQ L1 LDL SMT Test for a leftover SMT BLEQ CALLITERR CALL R$DEL If one exists, delete it AP SMT,SL CALLITERR CALL BREAK$ Yes, reenable breaks AP =ENABLE,SL LDA =ERR Return error PRTN L1 DFLD RTLABEL Save current RTLABEL value locally DFST RTNSAVE LDLR PB%+13 Replace it with our own frame address STL RTLABEL+2 EAL RETURN and return pointer IAB STL RTLABEL CALL IOFL$ Mark file descriptors AP STATE,SL LDL ONUNIT See if caller wants an onunit for ANY$ BLT NOUNIT No STL DESCR+0 Set up onunit descriptor block EAL SB% STL DESCR+2 EAL ANY$ Set up shortcall argument list STL ARGS+0 EAL DESCR STL ARGS+3 EAL ARGS JSXB MKONU$ Establish the onunit NOUNIT CALL BREAK$ Reenable breaks AP =ENABLE,SL CALL AT$HOM Attach HOME AP CODE,SL LDL SMT Test for an epf run BLNE EPF_INVK If so, then invoke it LDX RV_X Load initial registers from RVEC LDL RV_L PCL RV_ECBAD,* Invoke the program JMP RETURN EPF_INVK CALL R$INVK Crank it up AP SMT,SL RETURN CALL BREAK$ Hold off breaks for a moment AP =DISABLE,SL LDL SMT Check for an epf BLEQ CLOSEIT No epf, close files CALL R$DEL Delete the epf memory image AP SMT,SL CLOSEIT CALL COF$ Close files opened by program AP STATE,SL CALL DUPLX$ Restore the terminal configuration AP =-1,SL ANA ='010000 (Save the "output suppressed" bit) STA CODE LDA LWORD ANA ='167777 ORA CODE STA CODE CALL DUPLX$ AP CODE,SL CALL RVONU$ Revert the default onunit AP ANY$,SL DFLD RTNSAVE Restore previous value of RTLABEL DFST RTLABEL CALL BREAK$ AP =ENABLE,SL LDA =OK Indicate successful invocation PRTN CHECKRMODE LDA RV_KEYS Check keys... BNE RMODE ...if they are non-zero, it's R-mode LDL DFT_ECBAD Guess at the location of the ECB STL RV_ECBAD STLR PB%+15 JMP CHECKECB See if it's there EJCT RMODE EAL NEWECB Build an ECB for the R-mode program STL RV_ECBAD STLR PB%+15 LDL RV_PB Set up initial procedure base... LDA ='4000 ...always in segment 4000 STL ECB_PB LDA =10 Set up minimum frame size STA ECB_FRAME STA ECB_ARGD CRA Set up stack root segment number STA ECB_ROOT STA ECB_NARGS No arguments to be passed LDLR PB%+14 Use current link frame STL ECB_LB LDA RV_KEYS Use keys from RVEC STA ECB_KEYS JMP CALLIT ANY$ DATA 4,C'ANY$' DFT_ECBAD DATA '4000,'1000 Default ECB location SECTOR0 DATA '4000,'60 Pointer to P300 fault vectors ZEROS BSZ 14 Size of P300 fault vectors END #HD#: cant.r 84 Nov-27-1984 01:10:56 # cant --- print cant open file message subroutine cant (str) character str (ARB) call putlin (str, ERROUT) call error (": can't open.") return end #HD#: catsub.r 259 Nov-27-1984 01:10:56 # catsub --- add replacement text to end of new subroutine catsub (lin, from, to, sub, new, k, maxnew) integer from (10), to (10), k, maxnew character lin (MAXLINE), new (maxnew), sub (MAXPAT) integer addset integer i, j, junk, ri for (i = 1; sub (i) ~= EOS; i += 1) if (sub (i) == PAT_DITTO) { i += 1 ri = sub (i) + 1 - PAT_MARK for (j = from (ri); j < to (ri); j += 1) junk = addset (lin (j), new, k, maxnew) } else junk = addset (sub (i), new, k, maxnew) return end #HD#: chkarg.r 302 Nov-27-1984 01:10:57 # chkarg --- get and parse single letter arguments integer function chkarg (ap, result) integer ap, result (26) character arg (MAXARG) integer letters, position, i integer getarg letters = 0 for (; getarg (ap, arg, MAXARG) ~= EOF && arg (1) == '-'c; ap += 1) for (i = 2; arg (i) ~= EOS; i += 1) { select when (IS_LOWER (arg (i))) position = arg (i) - 'a'c + 1 when (IS_UPPER (arg (i))) position = arg (i) - 'A'c + 1 else return (ERR) if (result (position) < 0) return (ERR) letters += 1 result (position) = letters } return (letters) end #HD#: chkinp.s 188 Nov-27-1984 01:10:57 * chkinp --- check for terminal input availability * * logical function chkinp (flag) * logical flag SUBR CHKINP SEG RLIT include "=incl=/lib_def.s.i" LINK CHKINP ECB START,,FLAG,1 DATA 6,C'CHKINP' PROC DYNM =20,FLAG(3) START ARGT ENTR CHKINP LT E64R D64R SKS '704 CRA E64V D64V STA FLAG,* PRTN END #HD#: chkstr.r 163 Nov-27-1984 01:10:57 # chkstr --- check if an EOS-terminated string is valid (all printable) integer function chkstr (str, len) character str (ARB) integer len integer i for (i = 1; i <= len && str (i) ~= EOS; i += 1) if (' 'c > str (i) || str (i) >= DEL) return (NO) if (i > len) return (NO) return (YES) end #HD#: chunk$.r 385 Nov-27-1984 01:10:57 # chunk$ --- read one 2K chunk of the runfile into memory integer function chunk$ (bp, seg, fd) longint bp integer seg, fd define (out,1) define (DB,#) integer code, junk, tfd call sgdr$$ (KSPOS, fd, seg + 2, junk, code) DB call errpr$ (KIRTN, code, "positioning segdir", 18, "chunk$", 6) if (code ~= 0) goto out call srch$$ (KREAD + KISEG + KGETU, fd, 0, tfd, junk, code) DB call errpr$ (KIRTN, code, "opening subfile", 15, "chunk$", 6) if (code ~= 0) goto out call prwf$$ (KREAD, tfd, bp, 8r4000, intl (0), junk, code) call srch$$ (KCLOS, 0, 0, tfd, 0, junk) call errpr$ (KIRTN, code, "reading subfile", 15, "chunk$", 6) if (code == 0) return (OK) out; return (ERR) undefine (out) undefine (DB) end #HD#: close.r 440 Nov-27-1984 01:10:57 # close --- close out an open file integer function close (fd) filedes fd include SWT_COMMON integer f if (fd == STDIN1 || fd == STDOUT1 || # ignore closes on standard ports fd == STDIN2 || fd == STDOUT2 || fd == STDIN3 || fd == STDOUT3) return (OK) if (fd < 1 || fd > NFILES) return (ERR) # not a legal file descriptor f = fd_offset (fd) if (Fd_flags (f) == 0) # file is not open return (ERR) if (LASTOP (f) ~= FD_INITIAL) call flush$ (fd) select (Fd_dev (f)) when (DEV_DSK) { call srch$$ (KCLOS, 0, 0, Fd_unit (f), 0, Errcod) Fd_flags (f) = 0 if (Errcod == 0) return (OK) } when (DEV_TTY) { if (fd ~= 1) # never close file #1 Fd_flags (f) = 0 return (OK) } when (DEV_NULL) { Fd_flags (f) = 0 return (OK) } return (ERR) # bad srch$$ or attempt to undefined device end #HD#: cof$.r 222 Nov-27-1984 01:10:57 # cof$ --- close files opened by the last user program subroutine cof$ (state) integer state (MAXFILESTATE) include SWT_COMMON integer i for (i = 1; state (i) ~= ERR; i += 1) if (Fd_flags (fd_offset (state (i))) ~= 0) call close (state (i)) for (i += 1; state (i) ~= ERR; i += 1) call srch$$ (KCLOS, 0, 0, state (i), 0, Errcod) Term_cp = 1 Term_buf (Term_cp) = EOS Term_count = 0 return end #HD#: cpfil$.r 242 Nov-27-1984 01:10:57 # cpfil$ --- copy one file to another subroutine cpfil$ (ifd, ofd, rc) integer ifd, ofd, rc include SWT_COMMON integer buf (1024), code, rnw, junk code = 0 repeat { call prwf$$ (KREAD + KPRER + KCONV, ifd, loc (buf), 1024, intl (0), rnw, Errcod) if (rnw > 0) call prwf$$ (KWRIT + KPRER, ofd, loc (buf), rnw, intl (0), junk, code) } until (Errcod ~= 0 || code ~= 0) rc = ERR if (Errcod == EEOF && code == 0) rc = OK return end #HD#: cpseg$.r 663 Nov-27-1984 01:10:57 # cpseg$ --- copy a segment directory subroutine cpseg$ (ifd, ofd, rc) integer ifd, ofd, rc include SWT_COMMON integer entrya, entryb, ifd2, ofd2, code, type rc = ERR ### Make the "to" segdir the same size as the "from" segdir call sgdr$$ (KGOND, ifd, entrya, entryb, Errcod) if (Errcod ~= 0) return call sgdr$$ (KMSIZ, ofd, entryb, entrya, Errcod) if (Errcod ~= 0) return entryb = -1 repeat { entrya = entryb + 1 ### Position both segdirs to the next entry call sgdr$$ (KFULL, ifd, entrya, entryb, code) if (entryb == -1) { # none left Errcod = 0 break } if (Errcod ~= 0) return call sgdr$$ (KSPOS, ofd, entryb, entrya, Errcod) if (Errcod ~= 0) return ### Open both entries call srch$$ (KREAD + KISEG + KGETU, ifd, 0, ifd2, type, Errcod) if (Errcod ~= 0) return call srch$$ (KRDWR + KISEG + KGETU + ls (type, 10), ofd, 0, ofd2, type, Errcod) if (Errcod ~= 0) { call srch$$ (KCLOS, 0, 0, ifd2, 0, code) return } ### Copy the entry if (type >= 2) call cpseg$ (ifd2, ofd2, code) else call cpfil$ (ifd2, ofd2, code) if (code == ERR) return ### Close the entries call srch$$ (KCLOS, 0, 0, ifd2, 0, Errcod) call srch$$ (KCLOS, 0, 0, ofd2, 0, Errcod) } rc = OK return end #HD#: create.r 150 Nov-27-1984 01:10:58 # create --- create a new file and open it file_des function create (path, mode) character path (ARB) integer mode integer fd integer open, trunc fd = open (path, mode) if (fd ~= ERR) if (trunc (fd) ~= ERR) return (fd) else call close (fd) return (ERR) end #HD#: ctoa.r 310 Nov-27-1984 01:10:58 # ctoa --- convert from character to address longint function ctoa (str, i) character str (ARB) integer i longint fault, ring, seg, word, bit longint gctol SKIPBL (str, i) if (str (i) == 'f'c || str (i) == 'F'c) { i += 1 fault = :20000000000 } else fault = 0 ring = ls (rt (gctol (str, i, 8), 2), 28) if (str (i) == '.'c) i += 1 seg = ls (rt (gctol (str, i, 8), 12), 16) if (str (i) == '.'c) i += 1 word = rt (gctol (str, i, 8), 16) if (str (i) == '.'c) # skip over bit number if present bit = gctol (str, i, 8) return (xor (fault, ring, seg, word)) end #HD#: ctoc.s 249 Nov-27-1984 01:10:58 * ctoc --- convert EOS-terminated string to EOS-terminated string SUBR CTOC SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK CTOC ECB CTOC0,,FROM,3 DATA 4,C'CTOC' PROC DYNM =20,FROM(3),TO(3),LEN(3) CTOC0 ARGT ENTR CTOC LDX =0 LDA LEN,* BEQ OUT TAY EAXB FROM,* EALB TO,* LOOP LDA XB%,X STA LB%,X ERA =EOS BEQ OUT IRX BDY LOOP DRX RCB LDA =EOS STA LB%,X OUT TXA PRTN END #HD#: ctod.r 1174 Nov-27-1984 01:10:58 # ctod --- convert string to double precision real longreal function ctod (str, i) character str (ARB) integer i define (MAXDIG,16) integer j, s, pe (28) integer gctoi longreal v, e, pv (28) character dig (MAXDIG) bool neg data pv / 1d 1, 1d 2, 1d 4, 1d 8, 1d 16, 1d 32, 1d 64, 1d 128, 1d 256, 1d 512, 1d 1024, 1d 2048, 1d 4096, 1d 8192, 1d -1, 1d -2, 1d -4, 1d -8, 1d -16, 1d -32, 1d -64, 1d -128, 1d -256, 1d -512, 1d-1024, 1d-2048, 1d-4096, 1d-8192 / data pe / 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, -1, -2, -4, -8, -16, -32, -64, -128, -256, -512, -1024, -2048, -4096, -8192 / SKIPBL (str, i) # ignore leading blanks neg = (str (i) == '-'c) # check for sign if (str (i) == '+'c || str (i) == '-'c) i += 1 while (str (i) == '0'c) # ignore high-order zeros i += 1 for (j = 1; j < MAXDIG && IS_DIGIT (str (i)); {j += 1; i += 1}) dig (j) = str (i) # collect significant integral digits for (s = 0; IS_DIGIT (str (i)); {s += 1; i += 1}) ; # ignore the rest, adjusting scale factor if (str (i) == '.'c) { # check for a fraction i += 1 if (j == 1) # special case to accurately handle 0.000ddd etc. while (str (i) == '0'c) { i += 1 s -= 1 } for (; j < MAXDIG && IS_DIGIT (str (i)); {j += 1; i += 1}) { dig (j) = str (i) s -= 1 # adjust scale factor } while (IS_DIGIT (str (i))) # discard insig. fractional digits i += 1 } while (j > 1 && dig (j - 1) == '0'c) { # truncate trailing zeros s += 1 # increment the scale factor (multiply by 10) j -= 1 # truncate one trailing zero (divide by 10) } dig (j) = EOS # terminate the digit string if (str (i) == 'e'c || str (i) == 'E'c) { # check for exponent i += 1 s += gctoi (str, i, 10) } v = 0.0 # now convert the mantissa bits for (j = 1; dig (j) ~= EOS; j += 1) v = v * 10.0 + (dig (j) - '0'c) e = 1.0 select when (s > 0) for (j = 14; j > 0; j -= 1) { if (s >= pe (j)) { s -= pe (j) e *= pv (j) } } when (s < 0) for (j = 28; j > 14; j -= 1) { if (s <= pe (j)) { s -= pe (j) e *= pv (j) } } ifany ctod = v * e else ctod = v if (neg) ctod = -ctod return undefine (MAXDIG) end #HD#: ctoi.r 128 Nov-27-1984 01:10:58 # ctoi --- convert decimal string to single precision integer integer function ctoi (str, i) character str (ARB) integer i SKIPBL (str, i) for (ctoi = 0; IS_DIGIT (str (i)); i += 1) ctoi = 10 * ctoi + (str (i) - '0'c) return end #HD#: ctol.r 128 Nov-27-1984 01:10:58 # ctol --- convert decimal string to double precision integer longint function ctol (str, i) character str (ARB) integer i SKIPBL (str, i) for (ctol = 0; IS_DIGIT (str (i)); i += 1) ctol = 10 * ctol + (str (i) - '0'c) return end #HD#: ctomn.r 367 Nov-27-1984 01:10:58 # ctomn --- translate ASCII control character to mnemonic string integer function ctomn (c, rep) character c, rep (4) integer i integer scopy string_table mnpos, mntext "NUL"/ "SOH"/ "STX"/ "ETX"/ "EOT"/ "ENQ"/ "ACK"/ "BEL"/ "BS"/ "HT"/ "LF"/ "VT"/ "FF"/ "CR"/ "SO"/ "SI"/ "DLE"/ "DC1"/ "DC2"/ "DC3"/ "DC4"/ "NAK"/ "SYN"/ "ETB"/ "CAN"/ "EM"/ "SUB"/ "ESC"/ "FS"/ "GS"/ "RS"/ "US"/ "SP"/ "DEL" i = and (c, 8r177) if (0 <= i && i <= 32) # non-printing character return (scopy (mntext, mnpos (i + 2), rep, 1)) elif (i == 127) # rubout (DEL) return (scopy (mntext, mnpos (33 + 2), rep, 1)) else { # printing character rep (1) = c rep (2) = EOS return (1) } end #HD#: ctop.r 156 Nov-27-1984 01:10:58 # ctop --- convert EOS-terminated string to packed string integer function ctop (str, i, pstr, len) character str (ARB) integer i, pstr (ARB), len integer max max = len * CHARS_PER_WORD for (ctop = 0; str (i) ~= EOS && ctop < max; i += 1) spchar (pstr, ctop, str (i)) return end #HD#: ctor.r 86 Nov-27-1984 01:10:59 # ctor --- convert string to single precision real real function ctor (str, i) character str (ARB) integer i longreal ctod return (ctod (str, i)) end #HD#: ctov.r 195 Nov-27-1984 01:10:59 # ctov --- convert EOS-terminated string to varying string integer function ctov (str, i, var, len) character str (ARB) integer i, var (ARB), len integer max max = (len - 1) * CHARS_PER_WORD + CHARS_PER_WORD for (ctov = CHARS_PER_WORD; str (i) ~= EOS && ctov < max; i += 1) spchar (var, ctov, str (i)) ctov -= CHARS_PER_WORD var (1) = ctov return end #HD#: date.r 1596 Nov-27-1984 01:10:59 # date --- pick up useful information about the time of day # Argument 1 is a switch, to select the data returned. # SYS_DATE => date, in format mm/dd/yy # SYS_TIME => time, in format hh:mm:ss # SYS_USERID => login name # SYS_PIDSTR => user number # SYS_DAY => day of the week # SYS_PID => numeric user number in str (1) # SYS_LDATE => name of day, name of month, day, and year # SYS_MINUTES=> number of minutes past midnight in str (1..2) # SYS_SECONDS=> number of seconds past midnight in str (1..2) # SYS_MSEC => number of msec past midnight in str (1..2) # Argument 2 is a string to receive data specified by # argument 1. # Length of string is returned as function value. integer function date (item, str) integer item character str (ARB) integer td (28), day, month, year integer encode, ptoc, wkday, mapup integer snum (2) longint lnum equivalence (snum, lnum) string_table ix, days _ / "sun" / "mon" / "tues" / "wednes" _ / "thurs" / "fri" / "satur" string_table iy, months _ / "January" / "February" / "March" _ / "April" / "May" / "June" _ / "July" / "August" / "September" _ / "October" / "November" / "December" if (item < SYS_DATE || item > SYS_MSEC) { str (1) = EOS return (0) } call timdat (td, 12 + MAXPACKEDUSERNAME) select (item) when (SYS_DATE) # date, in format mm/dd/yy return (encode (str, 9, "*,2p/*,2p/*,2p"s, td (1), td (2), td (3))) when (SYS_TIME) # time, in format hh:mm:ss return (encode (str, 9, "*2,,0i:*2,,0i:*2,,0i"s, td (4) / 60, mod (td (4), 60), td (5))) when (SYS_USERID) # login name return (ptoc (td (13), ' 'c, str, MAXUSERNAME)) when (SYS_PIDSTR) # user number return (encode (str, 4, "*3,,0i"s, td (12))) when (SYS_DAY) { # day of week td (1) = td (1) - '00' td (2) = td (2) - '00' td (3) = td (3) - '00' day = rs (td (2), 8) * 10 + rt (td (2), 8) month = rs (td (1), 8) * 10 + rt (td (1), 8) year = rs (td (3), 8) * 10 + rt (td (3), 8) return (encode (str, 20, "*sday"s, days (ix (wkday (month, day, year) + 1)))) } when (SYS_PID) { # numeric user number in str (1) str (1) = td (12) return (0) } when (SYS_LDATE) { # name of day, name of month, day, and year td (1) = td (1) - '00' td (2) = td (2) - '00' td (3) = td (3) - '00' day = rs (td (2), 8) * 10 + rt (td (2), 8) month = rs (td (1), 8) * 10 + rt (td (1), 8) year = rs (td (3), 8) * 10 + rt (td (3), 8) date = encode (str, 50, "*sday, *s *i, 19*i"s, days (ix (wkday (month, day, year) + 1)), months (iy (month + 1)), day, year) str (1) = mapup (str (1)) return } when (SYS_MINUTES) { # minutes past midnight lnum = td (4) str (1) = snum (1) str (2) = snum (2) return (0) } when (SYS_SECONDS) { # seconds past midnight lnum = intl (td (4)) * 60 + td (5) str (1) = snum (1) str (2) = snum (2) return (0) } when (SYS_MSEC) { # milliseconds past midnight lnum = (intl (td (4)) * 60 + td (5)) * 1000 _ + (td (6) * 1000) / td (11) str (1) = snum (1) str (2) = snum (2) return (0) } return (0) end #HD#: decode.r 5508 Nov-27-1984 01:10:59 # decode --- formatted memory-to-memory conversion routine integer function decode (str, sp, fmt, fp, ap, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) character str (ARB) integer sp, fmt (ARB), fp, ap, a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB) integer cur_sp, cur_fp, cur_ap integer i, num, m, l, tp integer default_width, default_base, default_delim integer width, base, delim integer ctoi, gctoi, length longint ln longint ctoa, gctol character term, tmp (MAXDECODE) real lr real ctor longreal ld longreal ctod procedure interpret_format forward procedure get_num forward procedure convert_num forward procedure error_in_field forward procedure get_str forward procedure decode_packed forward procedure decode_string forward procedure decode_bool forward procedure decode_tab forward procedure decode_addr forward procedure decode_varying forward procedure decode_integer forward procedure decode_longint forward procedure decode_real forward procedure decode_double forward procedure decode_newline forward procedure decode_fill forward procedure too_many_args forward default_width = 0 default_base = 0 default_delim = ' 'c for (; fmt (fp) ~= EOS; fp += 1) { cur_fp = fp # for error recovery cur_sp = sp cur_ap = ap if (fmt (fp) ~= FORMATFLAG) ; # ignore the character else { interpret_format select (fmt (fp)) when (GOTOFORM) ap = width when (DEFAULTFORM) { default_width = width default_base = base default_delim = delim } when (BOOLFORM) decode_bool when (YESNOFORM) decode_bool when (TABFORM) decode_tab when (ADDRFORM) decode_addr when (PACKEDSTRINGFORM) { term = '.'c decode_packed } when (HOLLERITHFORM) { term = EOS decode_packed } when (STRINGFORM) decode_string when (VARYINGFORM) decode_varying when (INTFORM) decode_integer when (LONGINTFORM) decode_longint when (REALFORM) decode_real when (FLOATFORM, DOUBLEFORM) decode_double when (NLINE) decode_newline when (FILLFORM) decode_fill } } return (EOF) # interpret_format --- interpret and set the flags for the format procedure interpret_format { fp +=1 # Get width if (fmt (fp) == ','c) # omitted, use default width = default_width elif (fmt (fp) ~= '#'c) { # indirect convert_num width = num } else { get_num width = num fp += 1 } if (fmt (fp) ~= ','c) # Get base base = default_base else { fp += 1 if (fmt (fp) ~= '#'c) { convert_num base = num } else { get_num base = num fp += 1 } } if (fmt (fp) ~= ','c) # Get delim delim = default_delim else if (fmt (fp + 1) ~= '#'c) { delim = fmt (fp + 1) fp += 2 } else if (fmt (fp + 2) == '#'c) { delim = '#'c fp += 3 } else { get_num delim = num fp += 2 } } # get_num --- grab a number from the argument list; put in 'num' procedure get_num { select (ap) when ( 1) num = a1 (1) when ( 2) num = a2 (1) when ( 3) num = a3 (1) when ( 4) num = a4 (1) when ( 5) num = a5 (1) when ( 6) num = a6 (1) when ( 7) num = a7 (1) when ( 8) num = a8 (1) when ( 9) num = a9 (1) when (10) num = a10 (1) else too_many_args ap += 1 } # convert_num --- grab a number from the format string; put in 'num' procedure convert_num { bool neg neg = (fmt (fp) == '-'c) if (fmt (fp) == '+'c || fmt (fp) == '-'c) fp += 1 num = ctoi (fmt, fp) if (neg) num = - num } # error_in_field --- a field contains an error; return error status procedure error_in_field { fp = cur_fp sp = cur_sp ap = cur_ap return (ERR) } # get_str --- get a delimited string from the input string procedure get_str { if (width > 0) { # delimited by size for (tp = 1; tp <= width && tp <= MAXDECODE; {tp += 1; sp += 1}) { if (str (sp) == NEWLINE || str (sp) == EOS) break tmp (tp) = str (sp) } for (; tp <= width && tp < MAXDECODE; tp += 1) tmp (tp) = ' 'c tmp (tp) = EOS } else { # delimited by delimiter if (delim == ' 'c) SKIPBL (str, sp) for (tp = 1; tp < MAXDECODE; {tp += 1; sp += 1}) { if (str (sp) == NEWLINE || str (sp) == EOS || str (sp) == delim) break tmp (tp) = str (sp) } tmp (tp) = EOS if (str (sp) == delim) # bump over delimiter sp += 1 } } # decode_packed --- decode a packed string procedure decode_packed { get_str if (base == 0) m = MAXLINE else m = base tmp (tp) = term tmp (tp + 1) = EOS i = 1 select (ap) when ( 1) call ctop (tmp, i, a1, m) when ( 2) call ctop (tmp, i, a2, m) when ( 3) call ctop (tmp, i, a3, m) when ( 4) call ctop (tmp, i, a4, m) when ( 5) call ctop (tmp, i, a5, m) when ( 6) call ctop (tmp, i, a6, m) when ( 7) call ctop (tmp, i, a7, m) when ( 8) call ctop (tmp, i, a8, m) when ( 9) call ctop (tmp, i, a9, m) when (10) call ctop (tmp, i, a10, m) else too_many_args ap += 1 } # decode_string --- decode an EOS-terminated string procedure decode_string { get_str if (base == 0) m = MAXLINE else m = base select (ap) when ( 1) call ctoc (tmp, a1, m) when ( 2) call ctoc (tmp, a2, m) when ( 3) call ctoc (tmp, a3, m) when ( 4) call ctoc (tmp, a4, m) when ( 5) call ctoc (tmp, a5, m) when ( 6) call ctoc (tmp, a6, m) when ( 7) call ctoc (tmp, a7, m) when ( 8) call ctoc (tmp, a8, m) when ( 9) call ctoc (tmp, a9, m) when (10) call ctoc (tmp, a10, m) else too_many_args ap += 1 } # decode_bool --- decode a boolean value procedure decode_bool { get_str tp = 1 SKIPBL (tmp, tp) select (tmp (tp)) when (EOS) if (base == 0) m = 0 else m = 1 when ('t'c, 'T'c, 'y'c, 'Y'c, '1'c, 'o'c, 'O'c) m = 1 when ('f'c, 'F'c, 'n'c, 'N'c, '0'c) m = 0 else error_in_field select (ap) when ( 1) a1 (1) = m when ( 2) a2 (1) = m when ( 3) a3 (1) = m when ( 4) a4 (1) = m when ( 5) a5 (1) = m when ( 6) a6 (1) = m when ( 7) a7 (1) = m when ( 8) a8 (1) = m when ( 9) a9 (1) = m when (10) a10 (1) = m else too_many_args ap += 1 } # decode_tab --- handle tab formats procedure decode_tab { m = length (str) if (width <= m) sp = width else sp = m } # decode_addr --- decode an address procedure decode_addr { get_str i = 1 ln = ctoa (tmp, i) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (ln, a1, 2) when ( 2) call move$ (ln, a2, 2) when ( 3) call move$ (ln, a3, 2) when ( 4) call move$ (ln, a4, 2) when ( 5) call move$ (ln, a5, 2) when ( 6) call move$ (ln, a6, 2) when ( 7) call move$ (ln, a7, 2) when ( 8) call move$ (ln, a8, 2) when ( 9) call move$ (ln, a9, 2) when (10) call move$ (ln, a10, 2) else too_many_args ap += 1 } # decode_varying --- decode a PL/I varying string procedure decode_varying { get_str if (base == 0) m = MAXLINE else m = base i = 1 select (ap) when ( 1) call ctov (tmp, i, a1, m) when ( 2) call ctov (tmp, i, a2, m) when ( 3) call ctov (tmp, i, a3, m) when ( 4) call ctov (tmp, i, a4, m) when ( 5) call ctov (tmp, i, a5, m) when ( 6) call ctov (tmp, i, a6, m) when ( 7) call ctov (tmp, i, a7, m) when ( 8) call ctov (tmp, i, a8, m) when ( 9) call ctov (tmp, i, a9, m) when (10) call ctov (tmp, i, a10, m) else too_many_args ap += 1 } # decode_integer --- decode a short integer procedure decode_integer { get_str if (base == 0) base = 10 i = 1 l = gctoi (tmp, i, base) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) a1 (1) = l when ( 2) a2 (1) = l when ( 3) a3 (1) = l when ( 4) a4 (1) = l when ( 5) a5 (1) = l when ( 6) a6 (1) = l when ( 7) a7 (1) = l when ( 8) a8 (1) = l when ( 9) a9 (1) = l when (10) a10 (1) = l else too_many_args ap += 1 } # decode_longint --- decode a long integer procedure decode_longint { get_str if (base == 0) base = 10 i = 1 ln = gctol (tmp, i, base) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (ln, a1, 2) when ( 2) call move$ (ln, a2, 2) when ( 3) call move$ (ln, a3, 2) when ( 4) call move$ (ln, a4, 2) when ( 5) call move$ (ln, a5, 2) when ( 6) call move$ (ln, a6, 2) when ( 7) call move$ (ln, a7, 2) when ( 8) call move$ (ln, a8, 2) when ( 9) call move$ (ln, a9, 2) when (10) call move$ (ln, a10, 2) else too_many_args ap += 1 } # decode_real --- decode a single-precision floating point number procedure decode_real { get_str i = 1 lr = ctor (tmp, i) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (lr, a1, 2) when ( 2) call move$ (lr, a2, 2) when ( 3) call move$ (lr, a3, 2) when ( 4) call move$ (lr, a4, 2) when ( 5) call move$ (lr, a5, 2) when ( 6) call move$ (lr, a6, 2) when ( 7) call move$ (lr, a7, 2) when ( 8) call move$ (lr, a8, 2) when ( 9) call move$ (lr, a9, 2) when (10) call move$ (lr, a10, 2) else too_many_args ap += 1 } # decode_double --- decode a double-precision floating point number procedure decode_double { get_str i = 1 ld = ctod (tmp, i) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (ld, a1, 4) when ( 2) call move$ (ld, a2, 4) when ( 3) call move$ (ld, a3, 4) when ( 4) call move$ (ld, a4, 4) when ( 5) call move$ (ld, a5, 4) when ( 6) call move$ (ld, a6, 4) when ( 7) call move$ (ld, a7, 4) when ( 8) call move$ (ld, a8, 4) when ( 9) call move$ (ld, a9, 4) when (10) call move$ (ld, a10, 4) else too_many_args ap += 1 } # decode_fill --- skip a specified number of characters procedure decode_fill { get_str # just thrown them away } # decode_newline --- skip a specified number of NEWLINES procedure decode_newline { if (width <= 0) { # skip one newline, if it's there if (str (sp) == NEWLINE) sp += 1 } else { # skip 'width' newlines i = 1 repeat { while (str (sp) ~= NEWLINE && str (sp) ~= EOS) sp += 1 if (str (sp) == NEWLINE) sp += 1 i += 1 } until (i > width) } if (str (sp) == EOS && fmt (fp + 1) ~= EOS) { fp += 1 return (OK) # get new input line } } # too_many_args --- issue an error message for too many arguments procedure too_many_args { call remark ("in decode: attempt to use more than 10 fields"p) tmp (1) = EOS } end #HD#: delarg.r 147 Nov-27-1984 01:11:00 # delarg --- delete an argument from the command line integer function delarg (ap) integer ap include SWT_COMMON integer i if (ap < 0 || ap >= Arg_c) return (EOF) for (i = ap + 1; i < Arg_c; i += 1) Arg_v (i) = Arg_v (i + 1) Arg_c -= 1 return (OK) end #HD#: delete.r 176 Nov-27-1984 01:11:00 # delete --- remove a symbol from the symbol table subroutine delete (symbol, st) character symbol (ARB) pointer st integer Mem (1) common /ds$mem/ Mem integer st$lu pointer node, pred if (st$lu (symbol, node, pred, st) == YES) { Mem (pred + ST_LINK) = Mem (node + ST_LINK) call dsfree (node) } return end #HD#: dgetl$.s 2717 Nov-27-1984 01:11:00 * dgetl$ --- read one line from a disk file * * integer functin dgetl$ (line, length, fd) * character line (ARB) * integer length * fd_struct fd SUBR DGETL$ (LINE, LENGTH, FD) SEG RLIT include "=syscom=/keys.ins.pma" include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" LINK DGETL$ ECB DGETL,,LINE,3 DATA 6,C'DGETL$' PROC DYNM =20,LINE(3),LENGTH(3),FD(3) DYNM LFD(8),RETURN,XSAVE,NWR,BUFP(2) UNIT EQU LFD+1 BUFSTART EQU LFD+2 BUFLEN EQU LFD+3 BUFEND EQU LFD+4 COUNT EQU LFD+5 BCOUNT EQU LFD+6 FLAGS EQU LFD+7 DGETL ARGT ENTR DGETL$ EAXB FD,* LDA LENGTH,* Get line length S1A Exclude space for EOS STA LENGTH SUB ='400 To allow short LB refs TAX EALB LINE,*X Access LINE through LB LDA LENGTH TCA TAX LINE is indexed by X LDA XB%+FDBCOUNT Check for compressed blanks BLE NOBLANKS TAY Save blank count in Y LDA =BLANK BLOOP1 STA LB%+'400,X Store a blank BDY BUMPX1 Decrement blank count STY XB%+FDBCOUNT Count exhausted, clear FD_BCOUNT BIX NOBLANKS and bump LINE index JMP STORE_EOS End of LINE reached BUMPX1 BIX BLOOP1 Bump LINE index and loop back STY XB%+FDBCOUNT End of LINE reached, save count JMP STORE_EOS NOBLANKS DFLD XB% Make a local copy of file descriptor DFST LFD DFLD XB%+4 DFST LFD+4 LDY BUFSTART Construct pointer to buffer EAL FDBUFADDR,*Y STL BUFP Save for later use by FILL_BUF LDA COUNT See of buffer is empty BNE NOTEMPTY JSY FILL_BUF It is, go fill it JMP LEFT_BYTE Jump into fetch loop NOTEMPTY LDY BUFEND Make buffer addressable thru XB EAXB FDBUFADDR,*Y TAY Buffer is indexed by Y LDA FLAGS See which byte to start with SPL 0 => left JMP# RIGHT_BYTE 1 => right EJCT LEFT_BYTE LDA XB%,Y Fetch word from buffer ICL Isolate left byte CAS =DC1 Check for blank compression flag SKP JMP DC1_LEFT STA LB%+'400,X Store character into LINE CAS =LF Check for NEWLINE SKP JMP# LF_LEFT BIX RIGHT_BYTE Bump LINE index, get next byte JMP END_LEFT End of LINE reached RIGHT_BYTE LDA XB%,Y Fetch word from buffer CAL Isolate right byte CAS =DC1 Check for blank compression flag SKP JMP DC1_RIGHT STA LB%+'400,X Store character into LINE CAS =LF Check for NEWLINE SKP JMP# LF_RIGHT BIX BUMPY1 Bump LINE index BIY END_RIGHT End of LINE, bump buffer index JMP END_RIGHT End of buffer reached BUMPY1 BIY LEFT_BYTE Bump buffer index, get next byte JSY FILL_BUF End of buffer reached, fill it JMP LEFT_BYTE EJCT DC1_LEFT LDA XB%,Y Get blank count from right byte CAL STY COUNT Save buffer index TAY Put blank count in Y LDA =BLANK BLOOPL STA LB%+'400,X BDY BUMPXL LDY COUNT Restore buffer index BIX BUMPYL Bump LINE index IRS# 3 Bump buffer index RCB Ignore end condition JMP END_RIGHT End of LINE reached BUMPYL BIY LEFT_BYTE Bump buffer index, get next byte JSY FILL_BUF Buffer empty, fill it JMP LEFT_BYTE BUMPXL BIX BLOOPL Bump line index, loop back STY BCOUNT End of LINE, save residual count LDY COUNT Restore buffer index IRS# 3 Bump buffer index RCB Ignore end condition JMP END_RIGHT DC1_RIGHT BIY GET_COUNT Bump buffer index JSY FILL_BUF Buffer is empty, fill it GET_COUNT LDA XB%,Y Get blank count from left byte ICL STY COUNT Save buffer index TAY Put blank count in Y LDA =BLANK BLOOPR STA LB%+'400,X Store a blank in LINE BDY BUMPXR Decrement count LDY COUNT No more blanks, restore buffer index BIX RIGHT_BYTE Bump LINE index, get next byte JMP END_LEFT End of LINE BUMPXR BIX BLOOPR Bump LINE index, loop back STY BCOUNT End of LINE, save residual count LDY COUNT Restore buffer index JMP END_LEFT EJCT FILL_BUF STY RETURN Save return address STX XSAVE Save X register across call PCL PRWFADDR,* Read next chunk from disk file AP =K$READ+K$CONV,S AP UNIT,S AP BUFP,S AP BUFLEN,S AP =0L,S AP NWR,S AP CODEADDR,*SL LDX XSAVE Restore X register LDA CODEADDR,* Test return code BEQ FILL_OK ERA =E$EOF Check for end of file BEQ FILL_EOF CRA Clear NWR STA NWR LDA =FDERR Some other error, set bit in FLAGS SKP FILL_EOF LDA# =FDEOF Set EOF bit in FLAGS ORA FLAGS STA FLAGS FILL_OK LDA NWR See how much we got STA COUNT BEQ RETURN_FD ADD BUFSTART Compute new end of buffer STA BUFEND TAY Construct pointer to same EAXB FDBUFADDR,*Y LDA NWR Set up Y with -NWR TCA TAY LDA RETURN STA# 7 EXT PRWF$$ PRWFADDR IP PRWF$$ FDBUFADDR IP FDBUF CODEADDR IP ERRCOD LF_RIGHT EQU * LF_LEFT IRX Bump LINE index RCB BIY END_RIGHT Bump buffer index JMP END_RIGHT In case buffer is empty END_LEFT LDA FLAGS Set byte indicator for right byte SSM JMP SET_BYTE END_RIGHT LDA FLAGS Set byte indicator for left byte SSP SET_BYTE STA FLAGS STY COUNT Save buffer count RETURN_FD EAXB FD,* Copy back local version of FD DFLD LFD+4 copy only modified portion DFST XB%+4 STORE_EOS LDA =EOS Terminate LINE STA LB%+'400,X TXA Return length of LINE ADD LENGTH PRTN END #HD#: dmark$.r 133 Nov-27-1984 01:11:01 # dmark$ --- return the position of a disk file file_mark function dmark$ (f) file_des f include SWT_COMMON integer junk call prwf$$ (KRPOS, Fd_unit (f), intl (0), 0, dmark$, junk, Errcod) if (Errcod ~= 0) return (ERR) return end #HD#: dmpcm$.r 838 Nov-27-1984 01:11:01 # dmpcm$ --- dump the Subsystem common areas for examination subroutine dmpcm$ (fd) filedes fd include SWT_COMMON integer i, tbpptr (2), trtptr (2) character estr (MAXLINE), kstr (MAXLINE), nlstr (MAXLINE) character eofstr (MAXLINE), escstr (MAXLINE), rtstr (MAXLINE) call ctomn (Echar, estr) call ctomn (Kchar, kstr) call ctomn (Nlchar, nlstr) call ctomn (Eofchar, eofstr) call ctomn (Escchar, escstr) call ctomn (Rtchar, rtstr) call print (fd, "Software Tools Common Area:*n"s) call print (fd, " Echar: *4s Kchar: *4s Nlchar: *4s*n"s, estr, kstr, nlstr) call print (fd, " Eofchar: *4s Escchar: *4s Rtchar: *4s*n"s, eofstr, escstr, rtstr) call print (fd, " Isphantom: *4y Cputype: *i Errcod: *i*n"s, Isphantom, Cputype, Errcod) call print (fd, " Kill_resp: *s*n"s, Kill_resp) call print (fd, " Stdporttbl: "s) for (i = 1; i <= MAXSTDPORTS; i += 1) call print (fd, " *3i"s, Stdporttbl (i)) call print (fd, "*n"s) call print (fd, " Passwd: *6s Prtdest: *s Prtform: *s*n"s, Passwd, Prt_dest, Prt_form) tbpptr (1) = Bplabel (2) # reverse the backward ptr's tbpptr (2) = Bplabel (1) trtptr (1) = Rtlabel (2) trtptr (2) = Rtlabel (1) call print (fd, " Bplabel: *a *a Rtlabel: *a *a*n"s, tbpptr (1), Bplabel (3), trtptr (1), Rtlabel (3)) call print (fd, " Cmdstat: *i Comunit: *i Firstuse: *i*n"s, Cmdstat, Comunit, Firstuse) call print (fd, " Termtype: *s Lword: *,-8i*n"s, Termtype, Lword) call print (fd, " Termattr: "s) for (i = 1; i <= MAXTERMATTR; i += 1) call print (fd, " *y"s, Termattr (i)) call print (fd, "*n"s) return end #HD#: dmpfd$.r 948 Nov-27-1984 01:11:01 # dmpfd$ --- dump the contents of a file descriptor subroutine dmpfd$ (fd, ofd) filedes fd, ofd include SWT_COMMON filedes mfd filedes mapsu character name (MAXPATH) integer f, junk integer gfnam$ longint pos procedure display_buffer (f) forward mfd = mapsu (fd) f = fd_offset (mfd) call print (ofd, "Dump of file descriptor *i at *,2a:*n"s, mfd, loc (Fdesc (f))) if (gfnam$ (mfd, name, MAXPATH) ~= ERR) { call putlin (name, ofd) if (Fd_dev (f) == DEV_DSK) { call prwf$$ (KRPOS, Fd_unit (f), loc (0), 0, pos, 0, junk) call print (ofd, " at word *l*n"s, pos) } else call putch (NEWLINE, ofd) } call print (ofd, "*3xDev: *3i*3xBufstart: *6i*3xBufend: *6i*3xBcount: *3i*n"s, Fd_dev (f), Fd_bufstart (f), Fd_bufend (f), Fd_bcount (f)) call print (ofd, "*3xUnit: *3,8i*3xBuflen: *6i*3xCount: *6i*3xFlags: *6,-8,0i*n"s, Fd_unit (f), Fd_buflen (f), Fd_count (f), Fd_flags (f)) call print (ofd, " Last file system return code was *i*n"s, Errcod) if (LASTOP (f) ~= FD_INITIAL && Fd_dev (f) == DEV_DSK) display_buffer (f) return # display_buffer --- print contents of file buffer if appropriate procedure display_buffer (f) { integer f local i, last, lb, rb integer i, last, lb, rb i = Fd_bufstart (f) call print (ofd, "Buffer (at *,2a) contains:*n"s, loc (Fd_buf (i + 1))) select (LASTOP (f)) when (FD_READF, FD_GETLIN) last = Fd_bufend (f) when (FD_WRITEF, FD_PUTLIN) last = i + Fd_buflen (f) + Fd_count (f) else last = 0 for ( ; i < last; i += 1) { lb = rs (Fd_buf (i + 1), 8) rb = rt (Fd_buf (i + 1), 8) if (lb >= ' 'c && lb < DEL) call putch (lb, ofd) else call print (ofd, "<*3,8,0i>"s, lb) if (rb >= ' 'c && rb < DEL) call putch (rb, ofd) else call print (ofd, "<*3,8,0i>"s, rb) } call putch (NEWLINE, ofd) } end #HD#: dodash.r 227 Nov-27-1984 01:11:01 # dodash --- expand array (i-1) - array (i+1) into set (j)... from valid subroutine dodash (valid, array, i, set, j, maxset) integer i, j, maxset character array (ARB), set (maxset), valid (ARB) character esc integer addset, index integer junk, k, limit i += 1 j -= 1 limit = index (valid, esc (array, i)) for (k = index (valid, set (j)); k <= limit; k += 1) junk = addset (valid (k), set, j, maxset) return end #HD#: dopen$.r 492 Nov-27-1984 01:11:01 # dopen$ --- open a disk file for reading and/or writing integer function dopen$ (path, fd, mode, ftype, delay) character path (ARB) filedes fd integer mode, ftype, delay include SWT_COMMON integer at, c, d, f, m, t, u, junk (3), fname (16) integer getto logical missin if (getto (path, fname, junk, at) == ERR) { call at$hom (c) return (ERR) # file could not be reached for some reason } if (missin (delay)) d = 0 else d = delay f = fd_offset (fd) m = or (mode, KGETU) call srch$$ (m, fname, 32, u, t, c) while (d ~= 0 && c == EFIUS) { call sleep$ (intl (500)) call srch$$ (m, fname, 32, u, t, c) if (d ~= -1) d -= 1 } Errcod = c if (c ~= 0) { if (at == YES) call at$hom (c) return (ERR) # Primos couldn't open the file } if (~missin (ftype)) ftype = t if (at == YES) call at$hom (c) Fd_unit (f) = u Fd_flags (f) |= FD_COMP + ls (rt (t, 3), 6) return (fd) end #HD#: dputl$.s 1823 Nov-27-1984 01:11:02 * dputl$ --- put one line on a disk file SUBR DPUTL$ (LINE, FD) SEG RLIT include "=syscom=/keys.ins.pma" include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" LINK DPUTL$ ECB DPUTL,,LINE,2 DATA 6,C'DPUTL$' PROC DYNM =20,LINE(3),FD(3) DYNM LFD(8),XSAVE,LSAVE(2),BUFP(2),RETURN(2),TEMP,JUNK UNIT EQU LFD+1 BUFSTART EQU LFD+2 BUFLEN EQU LFD+3 BUFEND EQU LFD+4 COUNT EQU LFD+5 BCOUNT EQU LFD+6 FLAGS EQU LFD+7 DPUTL ARGT ENTR DPUTL$ EAXB FD,* DFLD XB% DFST LFD DFLD XB%+4 DFST LFD+4 EAL * STA RETURN LDX BUFSTART EAL FDBUFADDR,*X STL BUFP LDX BUFLEN EAXB BUFP,*X LDY COUNT LDX =-'400 EALB LINE,*X LDX =0 LDA FLAGS CSA LDA BCOUNT BEQ NOBLANKS BCR BLANK_L LDA XB%,Y STA TEMP JMP BLANK_R NOBLANKS BCR LEFT_BYTE LDA XB%,Y STA TEMP JMP RIGHT_BYTE EJCT LEFT_BYTE LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_LEFT CAS =EOS SKP JMP# END_LEFT STORE_LEFT ICR CAS =NEWLINE.LS.8 SKP JMP# STORE_RIGHT STA TEMP BIX RIGHT_BYTE JMP END_LEFT RIGHT_BYTE LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_RIGHT CAS =EOS SKP JMP END_RIGHT CAL ERA TEMP STORE_RIGHT STA XB%,Y BIY *+3 JSY# EMPTY_BUF BIX LEFT_BYTE JMP END_RIGHT EJCT BLANK_LEFT IRS BCOUNT RCB BIX BLANK_L JMP# PUTBL_LEFT BLANK_L LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_LEFT CAS =EOS SKP JMP# END_LEFT PUTBL_LEFT IMA BCOUNT PUTBL_L BLE COMP_LEFT CAS =2 JMP# COMP_LEFT JMP# TWO_LEFT CRA IMA BCOUNT CAL ERA =BLANK.LS.8 JMP STORE_RIGHT TWO_LEFT LDA =(BLANK.LS.8)+BLANK STA XB%,Y BIY *+3 JSY# EMPTY_BUF CRA IMA BCOUNT JMP STORE_LEFT COMP_LEFT TAB CAS =0 CAS# =256 LDA# =255 LDA# =255 ERA =DC1.LS.8 STA XB%,Y BIY *+3 JSY# EMPTY_BUF CAL IAB SUB# 2 BNE PUTBL_L IMA BCOUNT JMP STORE_LEFT EJCT BLANK_RIGHT IRS BCOUNT RCB BIX BLANK_R JMP# PUTBL_RIGHT BLANK_R LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_RIGHT CAS =EOS SKP JMP# END_RIGHT PUTBL_RIGHT IMA BCOUNT PUTBL_R BLE COMP_RIGHT CAS =2 JMP# COMP_RIGHT JMP# TWO_RIGHT CRA IMA BCOUNT ICR IMA TEMP ERA =BLANK STA XB%,Y BIY *+3 JSY# EMPTY_BUF LDA TEMP CAS =NEWLINE.LS.8 SKP JMP# STORE_RIGHT BIX RIGHT_BYTE JMP END_LEFT TWO_RIGHT LDA TEMP ERA =BLANK STA XB%,Y BIY *+3 JSY# EMPTY_BUF CRA IMA BCOUNT CAL ERA =BLANK.LS.8 JMP STORE_RIGHT COMP_RIGHT TAB LDA TEMP ERA =DC1 STA XB%,Y BIY *+3 JSY# EMPTY_BUF TBA CAS =0 CAS# =256 LDA# =255 LDA =255 ICR STA TEMP ICL IAB SUB# 2 BNE PUTBL_R IMA BCOUNT CAL ERA TEMP JMP STORE_RIGHT EJCT EMPTY_BUF STL LSAVE STX XSAVE STY RETURN+1 PCL PRWFADDR,* AP =K$WRIT,S AP UNIT,S AP BUFP,S AP BUFLEN,S AP =0L,S AP JUNK,S AP CODEADDR,*SL LDA CODEADDR,* BNE EMPTY_ERR LDA BUFLEN TAY EAXB BUFP,*Y TCA TAY LDX XSAVE LDL LSAVE JMP% RETURN,* EMPTY_ERR LDA =FDERR ORA FLAGS STA FLAGS LDA =ERR JMP RETURN_FD EXT PRWF$$ PRWFADDR IP PRWF$$ FDBUFADDR IP FDBUF CODEADDR IP ERRCOD EJCT END_LEFT LDA FLAGS SSP JMP SET_FLAGS END_RIGHT LDA TEMP STA XB%,Y LDA FLAGS SSM SET_FLAGS STA FLAGS STY COUNT TXA RETURN_FD EAXB FD,* DFLD LFD+4 DFST XB%+4 PRTN END #HD#: dread$.r 795 Nov-27-1984 01:11:02 # dread$ --- read raw words from disk integer function dread$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer bp, bsize, bstart, ct, n, nwr, op, thresh, u n = nw # number of words left to read op = 0 # number of words already read u = Fd_unit (f) ct = -Fd_count (f) # number of words in file buffer bp = Fd_bufend (f) - ct # index (0 based) of current buffer word bsize = Fd_buflen (f) # size of file buffer bstart = Fd_bufstart (f) # index (0 based) of first buffer word thresh = bsize / 2 Errcod = 0 select when (ct >= n) { # enough words already in file buffer call move$ (Fd_buf (bp + 1), buf, n) ct -= n op = n n = 0 } when (ct > 0) { # empty file buffer into user's buffer call move$ (Fd_buf (bp + 1), buf, ct) op = ct n -= ct ct = 0 } select when (n >= thresh) { # read directly into user's buffer call prwf$$ (KREAD, u, loc (buf (op + 1)), n, intl (0), nwr, Errcod) if (Errcod == 0 || Errcod == EEOF) op += nwr } when (n > 0) { # read into file buffer, then copy call prwf$$ (KREAD, u, loc (Fd_buf (bstart + 1)), bsize, intl (0), ct, Errcod) if (Errcod ~= 0 && Errcod ~= EEOF) ct = 0 Fd_bufend (f) = bstart + ct # update end-of-buffer index if (n > ct) n = ct call move$ (Fd_buf (bstart + 1), buf (op + 1), n) ct -= n op += n } Fd_count (f) = -ct # update file descriptor if (Errcod == EEOF) Fd_flags (f) |= FD_EOF elif (Errcod ~= 0) Fd_flags (f) |= FD_ERR if (op > 0) return (op) return (EOF) end #HD#: dsdbiu.r 345 Nov-27-1984 01:11:02 # dsdbiu --- dump contents of block-in-use subroutine dsdbiu (b, form) pointer b character form integer Mem (1) common /ds$mem/ Mem integer l, s, lmax call print (ERROUT, "*5i *i words in use*n.", b, Mem (b + DS_SIZE)) l = 0 s = b + Mem (b + DS_SIZE) if (form == DIGIT) lmax = 5 else lmax = 50 for (b += DS_OHEAD; b < s; b += 1) { if (l == 0) call print (ERROUT, " .") if (form == DIGIT) call print (ERROUT, " *10i.", Mem (b)) elif (form == LETTER) call print (ERROUT, "*c.", Mem (b)) l += 1 if (l >= lmax) { l = 0 call print (ERROUT, "*n.") } } if (l ~= 0) call print (ERROUT, "*n.") return end #HD#: dsdump.r 315 Nov-27-1984 01:11:02 # dsdump --- produce semi-readable dump of storage subroutine dsdump (form) character form integer Mem (1) common /ds$mem/ Mem pointer p, t, q t = DS_AVAIL call print (ERROUT, "** DYNAMIC STORAGE DUMP ***n.") call print (ERROUT, "*5i *i words in use*n.", 1, DS_OHEAD + 1) p = Mem (t + DS_LINK) while (p ~= LAMBDA) { call print (ERROUT, "*5i *i words available*n.", p, Mem (p + DS_SIZE)) q = p + Mem (p + DS_SIZE) while (q ~= Mem (p + DS_LINK) && q < Mem (DS_MEMEND)) call dsdbiu (q, form) p = Mem (p + DS_LINK) } call print (ERROUT, "** END DUMP ***n.") return end #HD#: dseek$.r 257 Nov-27-1984 01:11:02 # dseek$ --- seek on a disk device integer function dseek$ (pos, f, ra) filemark pos integer f, ra include SWT_COMMON integer junk select (ra) when (ABS) { if (pos < 0) return (ERR) call prwf$$ (KPOSN + KPREA, Fd_unit (f), intl (0), 0, pos, junk, Errcod) if (Errcod ~= 0) return (EOF) } when (REL) { call prwf$$ (KPOSN + KPRER, Fd_unit (f), intl (0), 0, pos, junk, Errcod) if (Errcod ~= 0) return (EOF) } else return (ERR) return (OK) end #HD#: dsfree.r 502 Nov-27-1984 01:11:02 # dsfree --- return a block of storage to the available space list subroutine dsfree (block) pointer block integer Mem (1) common /ds$mem/ Mem pointer p0, p, q integer n character con (10) p0 = block - DS_OHEAD n = Mem (p0 + DS_SIZE) q = DS_AVAIL repeat { p = Mem (q + DS_LINK) if (p == LAMBDA || p > p0) break q = p } if (q + Mem (q + DS_SIZE) > p0) { call remark ("in dsfree: attempt to free unallocated block.") call remark ("type 'c' to continue.") call getlin (con, ERRIN, 10) if (con (1) ~= 'c'c && con (1) ~= 'C'c) stop return # do not attempt to free the block } if (p0 + n == p & p ~= LAMBDA) { n = n + Mem (p + DS_SIZE) Mem (p0 + DS_LINK) = Mem (p + DS_LINK) } else Mem (p0 + DS_LINK) = p if (q + Mem (q + DS_SIZE) == p0) { Mem (q + DS_SIZE) = Mem (q + DS_SIZE) + n Mem (q + DS_LINK) = Mem (p0 + DS_LINK) } else { Mem (q + DS_LINK) = p0 Mem (p0 + DS_SIZE) = n } return end #HD#: dsget.r 427 Nov-27-1984 01:11:03 # dsget --- get pointer to block of at least w available words pointer function dsget (w) integer w integer Mem (1) common /ds$mem/ Mem pointer p, q, l integer n, k character c (10) n = w + DS_OHEAD q = DS_AVAIL repeat { p = Mem (q + DS_LINK) if (p == LAMBDA) { call remark ("in dsget: out of storage space.") call remark ("type 'c' or 'i' for char or integer dump.") call getlin (c, ERRIN, 10) select (c (1)) when ('c'c, 'C'c) call dsdump (LETTER) when ('i'c, 'I'c) call dsdump (DIGIT) call error ("program terminated.") } if (Mem (p + DS_SIZE) >= n) break q = p } k = Mem (p + DS_SIZE) - n if (k >= DS_CLOSE) { Mem (p + DS_SIZE) = k l = p + k Mem (l + DS_SIZE) = n } else { Mem (q + DS_LINK) = Mem (p + DS_LINK) l = p } return (l + DS_OHEAD) end #HD#: dsinit.r 283 Nov-27-1984 01:11:03 # dsinit --- initialize dynamic storage space to w words subroutine dsinit (w) integer w integer Mem (1) common /ds$mem/ Mem pointer t if (w < 2 * DS_OHEAD + 2) call error ("in dsinit: unreasonably small memory size.") # set up avail list: t = DS_AVAIL Mem (t + DS_SIZE) = 0 Mem (t + DS_LINK) = DS_AVAIL + DS_OHEAD # set up first block of space: t = DS_AVAIL + DS_OHEAD Mem (t + DS_SIZE) = w - DS_OHEAD - 1 # -1 for MEMEND Mem (t + DS_LINK) = LAMBDA # record end of memory: Mem (DS_MEMEND) = w return end #HD#: dtoc.r 3835 Nov-27-1984 01:11:03 # dtoc --- convert double precision real to string integer function dtoc (val, out, w, d) longreal val character out (ARB) integer w, d define(DEBUG1,#) # list output and flags define(DEBUG2,#) # list scaling operations define(MAX_DIGITS,14) longreal v, pv (26), round (MAX_DIGITS) integer pe (26), i, e, j, len, no_digits, max_size bool neg, small, exp_format, BASIC_format character digits (17) string dig "0123456789" integer itoc data pv / 1d 2, 1d 4, 1d 8, 1d 16, 1d 32, 1d 64, 1d 128, 1d 256, 1d 512, 1d 1024, 1d 2048, 1d 4096, 1d 8192, 1d -2, 1d -4, 1d -8, 1d -16, 1d -32, 1d -64, 1d -128, 1d -256, 1d -512, 1d-1024, 1d-2048, 1d-4096, 1d-8192/ data pe / 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, -2, -4, -8, -16, -32, -64, -128, -256, -512, -1024, -2048, -4096, -8192/ data round / .05d0, .005d0, .0005d0, .00005d0, .000005d0, .0000005d0, .00000005d0, .000000005d0, .0000000005d0, .00000000005d0, .000000000005d0, .0000000000005d0, .00000000000005d0, .000000000000005d0/ DEBUG2 write (1, 1) val; 1 format ("input value ", E25.15) ### set flags indicating whether the number is greater or ### less that zero, and whether its absolute value is ### greater or less than 1 v = dabs (val) neg = (val < 0.0) small = (v < 0.1) ### scale number to 0.01 <= v < 10.0 e = -1 if (small) { # number is less than 0.1 for (i = 26; i > 13; i -= 1) if (v < pv (i)) { v /= pv (i) e += pe (i) DEBUG2 write (1, 2) e, v; 2 format ("scale ", I6, E25.15) } } else { for (i = 13; i > 0; i -= 1) if (v >= pv (i) / 10.0) { v /= pv (i) e += pe (i) DEBUG2 write (1, 3) e, v; 3 format ("scale ", I6, E25.15) } } ### scale number so that 0.1 <= v < 1.0 DEBUG2 write (1, 4) e, v; 4 format ("before last scale ", I6, E25.15) if (v >= 1.0) { # be sure 0.1 <= v < 1.0 v /= 10.0 e += 1 } elif (v < 0.1) { v *= 10.0 e -= 1 } if (v == 0.0) # not likely, but possible e = 0 DEBUG2 write (1, 5) e, v; 5 format ("after last scale ", I6, E25.15) ### start tally for the maximum size of the number to ### determine if an error should be returned. if (neg) max_size = 1 else max_size = 0 ### determine exact format for printing BASIC_format = (d > MAX_DIGITS) if (BASIC_format) { # BASIC-like format exp_format = (e > 5 | e < -2) if (exp_format) { no_digits = 6 max_size = max_size + 1 + 1 + 5 + 1 + 1 + 4 # 9 . 99999 e + 9999 } else { no_digits = 6 + min0 (0, e) # in case e is negative max_size = max_size + 1 + 1 + 5 # 9 . 99999 } } elif (d >= 0) { # Fortran 'F' format exp_format = (w < 1 + max0 (e, 1) + 1 + d) # + eee... . ddd... if (exp_format) { # is there too little space? no_digits = max0 (1, w - 1 - 1 - 6) # + 9 . e+9999 max_size = max_size + 1 + no_digits + 6 # . nnnnnn e+9999 } else { no_digits = e + d + 1 # negative e is OK here max_size = max_size + max0 (e, 0) + 1 + d # eee... . ddd... } } else { # d < 0 # Fortran 'E' format exp_format = TRUE no_digits = min0 (MAX_DIGITS, -d) # remember, d < 0 max_size = max_size + 1 + no_digits + 6 # . ddd... e+9999 } ### be sure the number of digits is in range no_digits = min0 (max0 (1, no_digits), MAX_DIGITS) ### round the number at digit (no_digits+ 1) v += round (no_digits) ### handle the unusual situation of rounding from .999... ### up to 1.000... if (v >= 1.0) { v /= 10.0 e += 1 if (~ exp_format) { max_size += 1 no_digits = min0 (MAX_DIGITS, no_digits + 1) } } ### see if the number will fit in 'w' characters if (max_size > w) { out (1) = '?'c out (2) = EOS dtoc = 1 DEBUG1 call print (ERROUT, "dtoc:*2i out:*s*n.", dtoc, out) return } DEBUG2 write (1, 6) v; 6 format ("after rounding ", E25.15) ### extract the first digits do i = 1, no_digits; { v *= 10.0d0 j = v # truncate to integer v -= j # lop off the integral part digits (i) = dig (j + 1) } DEBUG1 integer db1 DEBUG1 call print (ERROUT, "w:*2i d:*2i .", w, d) DEBUG1 call putlit ("small:.", '.'c, ERROUT) DEBUG1 if (small) DEBUG1 call putlit ("YES .", '.'c, ERROUT) DEBUG1 else DEBUG1 call putlit ("NO .", '.'c, ERROUT) DEBUG1 call putlit ("neg:.", '.'c, ERROUT) DEBUG1 if (neg) DEBUG1 call putlit ("YES .", '.'c, ERROUT) DEBUG1 else DEBUG1 call putlit ("NO .", '.'c, ERROUT) DEBUG1 call putlit ("exp_format:.", '.'c, ERROUT) DEBUG1 if (exp_format) DEBUG1 call putlit ("YES .", '.'c, ERROUT) DEBUG1 else DEBUG1 call putlit ("NO .", '.'c, ERROUT) DEBUG1 call print (ERROUT, "e:*6i no_digits:*2i .", e, no_digits) DEBUG1 call putlit ("digits:.", '.'c, ERROUT) DEBUG1 for (db1 = 1; db1 <= no_digits; db1 += 1) DEBUG1 call putch (digits (db1), ERROUT) DEBUG1 call putch (BLANK, ERROUT) ### take digit string and exponent and arrange into ### desired format, depending on 'exp_format' and 'BASIC_format' len = 1 if (neg) { out (1) = '-'c len += 1 } if (exp_format) { # set up exponential format out (len) = digits (1) out (len + 1) = '.'c len += 2 for (i = 2; i <= no_digits; i += 1) { out (len) = digits (i) len += 1 } if (BASIC_format) # if BASIC, skip trailing zeroes while (len > 2) { len -= 1 if (out (len) == '.'c) break else if (out (len) ~= '0'c) { len += 1 # non-digit -- keep it break } } out (len) = 'e'c len += 1 if (e < 0) { out (len) = '-'c len += 1 e = -e } len += itoc (e, out (len), w - len) } elif (e < 0) { # handle fixed numbers < 1 ### special case numbers from .5000... to .9999... if (d == 0 && e == -1 && digits (1) >= '5'c) out (len) = '1'c else out (len) = '0'c out (len + 1) = '.'c len += 2 for (i = 1; i < -e && i <= d; i += 1) { out (len) = '0'c len += 1 } for (j = 1; j <= no_digits && i <= d; j += 1) { out (len) = digits (j) len += 1 i += 1 } if (BASIC_format) # if BASIC, skip trailing zeroes while (len > 2) { len -= 1 if (out (len) == '.'c) break else if (out (len) ~= '0'c) { len += 1 # non-digit -- keep it break } } else for (i = 1; i < d + e - no_digits && i <= d; i += 1) { out (len) = '0'c len += 1 } } elif (e >= no_digits) { # handle numbers >= 1 with dp after figures for (i = 1; i <= no_digits; i += 1) { out (len) = digits (i) len += 1 } for (i = no_digits; i <= e; i += 1) { out (len) = '0'c len += 1 } if (~ BASIC_format) { # no trailing dp or zeroes in BASIC out (len) = '.'c len += 1 for (i = 1; i <= d; i += 1) { out (len) = '0'c len += 1 } } } else { # handle numbers > 1 with dp inside figures e += 1 for (i = 1; i <= e; i += 1) { out (len) = digits (i) len += 1 } out (len) = '.'c len += 1 for (j = 1; i <= no_digits && j <= d; j += 1) { out (len) = digits (i) i += 1 len += 1 } if (BASIC_format) # if BASIC, skip trailing zeroes while (len > 2) { len -= 1 if (out (len) == '.'c) break elif (out (len) ~= '0'c) { len += 1 # non-digit -- keep it break } } else for (i = 1; i <= e + d - no_digits && i <= d; i += 1) { out (len) = '0'c len += 1 } } out (len) = EOS dtoc = len - 1 DEBUG1 call print (ERROUT, "dtoc:*2i out:*s*n.", dtoc, out) return undefine (DEBUG1) undefine (DEBUG2) undefine (MAX_DIGITS) end #HD#: dwrit$.r 676 Nov-27-1984 01:11:03 # dwrit$ --- write raw words to disk integer function dwrit$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer i, bp, n, ip, nwr, ct, bstart, bsize, thresh n = nw # number of words to write ip = 0 # input buffer pointer ct = - Fd_count (f) # number of words left in buffer bp = Fd_bufend (f) - ct # index (0 based) of next buffer word bsize = Fd_buflen (f) # length of file buffer bstart = Fd_bufstart (f) # index (0 based) of first buffer word thresh = bsize / 2 Errcod = 0 if (nw >= thresh) { # write directly from user's buffer if (bsize - ct > 0) { call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (bstart + 1)), bsize - ct, intl (0), nwr, Errcod) bp = bstart ct = bsize } if (Errcod == 0) call prwf$$ (KWRIT, Fd_unit (f), loc (buf (ip + 1)), n, intl (0), nwr, Errcod) if (Errcod == 0) ip += nwr } else { while (n > 0) { if (ct <= 0) { call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (bstart + 1)), bsize, intl (0), nwr, Errcod) if (Errcod ~= 0) break bp = bstart ct = bsize } i = n if (i > ct) i = ct call move$ (buf (ip + 1), Fd_buf (bp + 1), i) ip += i bp += i n -= i ct -= i } } Fd_count (f) = -ct if (Errcod ~= 0) { Fd_flags (f) |= FD_ERR return (EOF) } return (ip) end #HD#: encode.r 7556 Nov-27-1984 01:11:04 # encode --- formatted memory-to-memory conversion routine integer function encode (str, max, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) character str (ARB) integer max, fmt (ARB), a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB) integer i, arg, cur, max_cur, num, m, l, default_width, default_base, default_fill integer width, rjust, base, fill integer ptoc, ctoc, gitoc, gltoc, rtoc, dtoc, vtoc, atoc, ctoi character term, tmp (MAXLINE) procedure interpret_format forward procedure get_num forward procedure convert_num forward procedure fill_field (len) forward procedure putstr forward procedure encode_packed forward procedure encode_string forward procedure encode_bool forward procedure encode_yesno forward procedure encode_tab forward procedure encode_addr forward procedure encode_varying forward procedure encode_integer forward procedure encode_longint forward procedure encode_real forward procedure encode_double forward procedure encode_newline forward procedure too_many_args forward define (putchar (x), {str (cur) = x; cur += 1}) arg = 1 cur = 1 max_cur = 1 default_width = 0 default_base = 0 default_fill = ' 'c for (i = 1; fmt (i) ~= EOS && cur < max; i += 1) { if (fmt (i) ~= FORMATFLAG) putchar (fmt (i)) else { interpret_format select (fmt (i)) when (GOTOFORM) arg = width when (DEFAULTFORM) { default_width = width default_base = base default_fill = fill } when (BOOLFORM) encode_bool when (YESNOFORM) encode_yesno when (TABFORM) encode_tab when (ADDRFORM) encode_addr when (PACKEDSTRINGFORM) { term = '.'c encode_packed } when (HOLLERITHFORM) { term = EOS encode_packed } when (STRINGFORM) encode_string when (CHARFORM) { # compatibility only base = 1 encode_string } when (VARYINGFORM) encode_varying when (INTFORM) encode_integer when (RCINTFORM) { # compatibility only base = -base encode_integer } when (LONGINTFORM) encode_longint when (RCLONGINTFORM) { # compatibility only base = -base encode_longint } when (REALFORM) encode_real when (FLOATFORM, DOUBLEFORM) encode_double when (NLINE) encode_newline when (FILLFORM) fill_field (width) else putchar (fmt (i)) } } if (max_cur > cur) cur = max_cur str (cur) = EOS return (cur - 1) # interpret_format --- interpret and set the flags for the format procedure interpret_format { ### Get width: i += 1 if (fmt (i) == ','c || IS_LETTER (fmt (i))) # default width = default_width else if (fmt (i) == '#'c) { # indirect get_num i += 1 width = num } else { # specified convert_num width = num } if (width >= 0) # Get rjust rjust = NO else { rjust = YES width = -width } ### Get base: if (fmt (i) ~= ','c) # no more format specs base = default_base else { i += 1 if (fmt (i) == ','c || IS_LETTER (fmt (i))) # default base = default_base else if (fmt (i) == '#'c) { # indirect get_num i += 1 base = num } else { # specified convert_num base = num } } ### Get fill character: if (fmt (i) ~= ','c) # no more format specs fill = default_fill elif (fmt (i + 1) ~= '#'c) { # not indirect fill = fmt (i + 1) i += 2 } elif (fmt (i + 2) == '#'c) { # double "#" fill = '#'c i += 3 } else { # indirect get_num fill = num i += 2 } } # get_num --- grab a number from the argument list; put in 'num' procedure get_num { select (arg) when ( 1) num = a1 (1) when ( 2) num = a2 (1) when ( 3) num = a3 (1) when ( 4) num = a4 (1) when ( 5) num = a5 (1) when ( 6) num = a6 (1) when ( 7) num = a7 (1) when ( 8) num = a8 (1) when ( 9) num = a9 (1) when (10) num = a10 (1) else too_many_args arg += 1 } # convert_num --- grab a number from the format string; put in 'num' procedure convert_num { bool neg neg = (fmt (i) == '-'c) if (fmt (i) == '+'c || fmt (i) == '-'c) i += 1 num = ctoi (fmt, i) if (neg) num = - num } # putstr --- put the string in 'tmp' into 'str' at 'cur' procedure putstr { cur += ctoc (tmp, str (cur), max - cur + 1) } # fill_field --- output 'len' fill character, but don't overflow 'str' procedure fill_field (len) { integer len local i integer i for (i = 1; i <= len && cur < max; {cur += 1; i += 1}) str (cur) = fill } # encode_packed --- encode a packed string procedure encode_packed { if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 select (arg) when ( 1) l = ptoc (a1, term, str (cur), m) when ( 2) l = ptoc (a2, term, str (cur), m) when ( 3) l = ptoc (a3, term, str (cur), m) when ( 4) l = ptoc (a4, term, str (cur), m) when ( 5) l = ptoc (a5, term, str (cur), m) when ( 6) l = ptoc (a6, term, str (cur), m) when ( 7) l = ptoc (a7, term, str (cur), m) when ( 8) l = ptoc (a8, term, str (cur), m) when ( 9) l = ptoc (a9, term, str (cur), m) when (10) l = ptoc (a10, term, str (cur), m) else too_many_args cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 select (arg) when ( 1) l = ptoc (a1, term, tmp, m) when ( 2) l = ptoc (a2, term, tmp, m) when ( 3) l = ptoc (a3, term, tmp, m) when ( 4) l = ptoc (a4, term, tmp, m) when ( 5) l = ptoc (a5, term, tmp, m) when ( 6) l = ptoc (a6, term, tmp, m) when ( 7) l = ptoc (a7, term, tmp, m) when ( 8) l = ptoc (a8, term, tmp, m) when ( 9) l = ptoc (a9, term, tmp, m) when (10) l = ptoc (a10, term, tmp, m) else too_many_args fill_field (width - l) putstr } arg += 1 } # encode_string --- encode an EOS-terminated string procedure encode_string { if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 select (arg) when ( 1) l = ctoc (a1, str (cur), m) when ( 2) l = ctoc (a2, str (cur), m) when ( 3) l = ctoc (a3, str (cur), m) when ( 4) l = ctoc (a4, str (cur), m) when ( 5) l = ctoc (a5, str (cur), m) when ( 6) l = ctoc (a6, str (cur), m) when ( 7) l = ctoc (a7, str (cur), m) when ( 8) l = ctoc (a8, str (cur), m) when ( 9) l = ctoc (a9, str (cur), m) when (10) l = ctoc (a10, str (cur), m) else too_many_args cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 select (arg) when ( 1) l = ctoc (a1, tmp, m) when ( 2) l = ctoc (a2, tmp, m) when ( 3) l = ctoc (a3, tmp, m) when ( 4) l = ctoc (a4, tmp, m) when ( 5) l = ctoc (a5, tmp, m) when ( 6) l = ctoc (a6, tmp, m) when ( 7) l = ctoc (a7, tmp, m) when ( 8) l = ctoc (a8, tmp, m) when ( 9) l = ctoc (a9, tmp, m) when (10) l = ctoc (a10, tmp, m) else too_many_args fill_field (width - l) putstr } arg += 1 } # encode_bool --- encode a boolean value procedure encode_bool { select (arg) when ( 1) l = a1 (1) when ( 2) l = a2 (1) when ( 3) l = a3 (1) when ( 4) l = a4 (1) when ( 5) l = a5 (1) when ( 6) l = a6 (1) when ( 7) l = a7 (1) when ( 8) l = a8 (1) when ( 9) l = a9 (1) when (10) l = a10 (1) else too_many_args if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 if (l ~= 0) # true l = ctoc ("TRUE"s, str (cur), m) else l = ctoc ("FALSE"s, str (cur), m) cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 if (l == 1) # true l = ctoc ("TRUE"s, tmp, m) else l = ctoc ("FALSE"s, tmp, m) fill_field (width - l) putstr } arg += 1 } # encode_yesno --- encode a YES/NO value procedure encode_yesno { select (arg) when ( 1) l = a1 (1) when ( 2) l = a2 (1) when ( 3) l = a3 (1) when ( 4) l = a4 (1) when ( 5) l = a5 (1) when ( 6) l = a6 (1) when ( 7) l = a7 (1) when ( 8) l = a8 (1) when ( 9) l = a9 (1) when (10) l = a10 (1) else too_many_args if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 if (l == YES) l = ctoc ("YES"s, str (cur), m) elif (l == NO) l = ctoc ("NO"s, str (cur), m) else l = ctoc ("?"s, str (cur), m) cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 if (l == YES) l = ctoc ("YES"s, tmp, m) elif (l == NO) l = ctoc ("NO"s, tmp, m) else l = ctoc ("?"s, tmp, m) fill_field (width - l) putstr } arg += 1 } # encode_tab --- handle tab formats procedure encode_tab { if (cur > max_cur) max_cur = cur for ( ; max_cur < width && max_cur < max; max_cur += 1) str (max_cur) = fill cur = width } # encode_addr --- encode an address procedure encode_addr { select (arg) when ( 1) l = atoc (a1, tmp, MAXLINE) when ( 2) l = atoc (a2, tmp, MAXLINE) when ( 3) l = atoc (a3, tmp, MAXLINE) when ( 4) l = atoc (a4, tmp, MAXLINE) when ( 5) l = atoc (a5, tmp, MAXLINE) when ( 6) l = atoc (a6, tmp, MAXLINE) when ( 7) l = atoc (a7, tmp, MAXLINE) when ( 8) l = atoc (a8, tmp, MAXLINE) when ( 9) l = atoc (a9, tmp, MAXLINE) when (10) l = atoc (a10, tmp, MAXLINE) else too_many_args if (rjust == NO) { fill_field (width - l) putstr } else { putstr fill_field (width - l) } arg += 1 } # encode_varying --- encode a PL/I varying string procedure encode_varying { if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 select (arg) when ( 1) l = vtoc (a1, str (cur), m) when ( 2) l = vtoc (a2, str (cur), m) when ( 3) l = vtoc (a3, str (cur), m) when ( 4) l = vtoc (a4, str (cur), m) when ( 5) l = vtoc (a5, str (cur), m) when ( 6) l = vtoc (a6, str (cur), m) when ( 7) l = vtoc (a7, str (cur), m) when ( 8) l = vtoc (a8, str (cur), m) when ( 9) l = vtoc (a9, str (cur), m) when (10) l = vtoc (a10, str (cur), m) else too_many_args cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 select (arg) when ( 1) l = vtoc (a1, tmp, m) when ( 2) l = vtoc (a2, tmp, m) when ( 3) l = vtoc (a3, tmp, m) when ( 4) l = vtoc (a4, tmp, m) when ( 5) l = vtoc (a5, tmp, m) when ( 6) l = vtoc (a6, tmp, m) when ( 7) l = vtoc (a7, tmp, m) when ( 8) l = vtoc (a8, tmp, m) when ( 9) l = vtoc (a9, tmp, m) when (10) l = vtoc (a10, tmp, m) else too_many_args fill_field (width - l) putstr } arg += 1 } # encode_integer --- encode and justify an integer procedure encode_integer { select (arg) when ( 1) l = gitoc (a1, tmp, MAXLINE, base) when ( 2) l = gitoc (a2, tmp, MAXLINE, base) when ( 3) l = gitoc (a3, tmp, MAXLINE, base) when ( 4) l = gitoc (a4, tmp, MAXLINE, base) when ( 5) l = gitoc (a5, tmp, MAXLINE, base) when ( 6) l = gitoc (a6, tmp, MAXLINE, base) when ( 7) l = gitoc (a7, tmp, MAXLINE, base) when ( 8) l = gitoc (a8, tmp, MAXLINE, base) when ( 9) l = gitoc (a9, tmp, MAXLINE, base) when (10) l = gitoc (a10, tmp, MAXLINE, base) else too_many_args if (rjust == NO) { fill_field (width - l) putstr } else { putstr fill_field (width - l) } arg += 1 } # encode_longint --- encode and justify an long integer procedure encode_longint { select (arg) when ( 1) l = gltoc (a1, tmp, MAXLINE, base) when ( 2) l = gltoc (a2, tmp, MAXLINE, base) when ( 3) l = gltoc (a3, tmp, MAXLINE, base) when ( 4) l = gltoc (a4, tmp, MAXLINE, base) when ( 5) l = gltoc (a5, tmp, MAXLINE, base) when ( 6) l = gltoc (a6, tmp, MAXLINE, base) when ( 7) l = gltoc (a7, tmp, MAXLINE, base) when ( 8) l = gltoc (a8, tmp, MAXLINE, base) when ( 9) l = gltoc (a9, tmp, MAXLINE, base) when (10) l = gltoc (a10, tmp, MAXLINE, base) else too_many_args if (rjust == NO) { fill_field (width - l) putstr } else { putstr fill_field (width - l) } arg += 1 } # encode_real --- encode a single-precision floating point number procedure encode_real { if (base == 0) base = 100 if (base > 14 || base < 0 || width == 0) m = MAXLINE - 1 else m = base + 20 select (arg) when ( 1) l = rtoc (a1, tmp, m, base) when ( 2) l = rtoc (a2, tmp, m, base) when ( 3) l = rtoc (a3, tmp, m, base) when ( 4) l = rtoc (a4, tmp, m, base) when ( 5) l = rtoc (a5, tmp, m, base) when ( 6) l = rtoc (a6, tmp, m, base) when ( 7) l = rtoc (a7, tmp, m, base) when ( 8) l = rtoc (a8, tmp, m, base) when ( 9) l = rtoc (a9, tmp, m, base) when (10) l = rtoc (a10, tmp, m, base) else too_many_args if (rjust == YES) { if (base < 0 && tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (width - l) } else if (base >= 0) { fill_field (width - l) putstr } else { fill_field (width + base - 8) if (tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (-base + 7 - l) } arg += 1 } # encode_double --- encode a double-precision floating point number procedure encode_double { if (base == 0) base = 100 if (base > 14 || base < 0 || width == 0) m = MAXLINE - 1 else m = base + 20 select (arg) when ( 1) l = dtoc (a1, tmp, m, base) when ( 2) l = dtoc (a2, tmp, m, base) when ( 3) l = dtoc (a3, tmp, m, base) when ( 4) l = dtoc (a4, tmp, m, base) when ( 5) l = dtoc (a5, tmp, m, base) when ( 6) l = dtoc (a6, tmp, m, base) when ( 7) l = dtoc (a7, tmp, m, base) when ( 8) l = dtoc (a8, tmp, m, base) when ( 9) l = dtoc (a9, tmp, m, base) when (10) l = dtoc (a10, tmp, m, base) else too_many_args if (rjust == YES) { if (base < 0 && tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (width - l) } else if (base >= 0) { fill_field (width - l) putstr } else { fill_field (width + base - 8) if (tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (-base + 7 - l) } arg += 1 } # encode_newline --- insert a specified number of NEWLINES procedure encode_newline { repeat { putchar (NEWLINE) width -= 1 } until (width <= 0 || cur >= max) } # too_many_args --- issue an error message for too many arguments procedure too_many_args { call remark ("in encode: attempt to use more than 10 fields"p) tmp (1) = EOS } undefine (putchar) end #HD#: enter.r 364 Nov-27-1984 01:11:05 # enter --- place a symbol in the symbol table, updating if already present integer function enter (symbol, info, st) character symbol (ARB) integer info (ARB) pointer st integer Mem (1) common /ds$mem/ Mem integer i, nodesize, fortrash integer st$lu, length pointer node, pred pointer dsget nodesize = Mem (st) if (st$lu (symbol, node, pred, st) == NO) { node = dsget (1 + nodesize + length (symbol) + 1) Mem (node + ST_LINK) = LAMBDA Mem (pred + ST_LINK) = node call scopy (symbol, 1, Mem, node + ST_DATA + nodesize) } for (i = 1; i <= nodesize; i += 1) { fortrash = node + ST_DATA + i - 1 Mem (fortrash) = info (i) } return (node + ST_DATA + nodesize) end #HD#: equal.s 358 Nov-27-1984 01:11:05 * equal --- compare str1 to str2; return YES if equal * * integer function equal (str1, str2) * character str1 (ARB), str2 (ARB) SUBR EQUAL SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK EQUAL ECB EQUAL$,,STR1,2 DATA 5,C'EQUAL' PROC DYNM =20,STR1(3),STR2(3) EQUAL$ ARGT ENTR EQUAL EAXB STR1,* XB := STR1 EALB STR2,* LB := STR2 LDX =0 X := 0 LOOP LDA XB%+0,X if (XB+X)^ <> (LB+X)^ then CAS LB%+0,X goto NE JMP NE JMP *+2 JMP NE CAS =EOS if (XB+X)^ = EOS then JMP *+2 go to EQ JMP EQ BIX LOOP X := X + 1; goto LOOP EQ LDA =YES return YES PRTN NE LDA =NO return NO PRTN END #HD#: error.r 78 Nov-27-1984 01:11:05 # error --- print fatal error message, then die subroutine error (buf) integer buf (ARB) call remark (buf) call seterr (1000) stop end #HD#: esc.r 206 Nov-27-1984 01:11:05 # esc --- map array (i) into escaped character if appropriate character function esc (array, i) character array (ARB) integer i if (array (i) ~= ESCAPE) esc = array (i) else if (array (i + 1) == EOS) # @ not special at end esc = ESCAPE else { i += 1 if (array (i) == 'n'c) esc = NEWLINE else if (array (i) == 't'c) esc = TAB else esc = array (i) } return end #HD#: exec.r 125 Nov-27-1984 01:11:05 # exec --- execute pathname subroutine exec (path) character path (ARB) integer file (16), j1 (3), j2 integer getto, findf$ if (getto (path, file, j1, j2) ~= ERR && findf$ (file) == YES) call resu$$ (file, 32) return end #HD#: execn.r 106 Nov-27-1984 01:11:05 # execn --- execute program named by a quoted string subroutine execn (name) integer name (ARB) character path (MAXSTR) call ptoc (name, '.'c, path, MAXSTR) call exec (path) return end #HD#: expand.r 669 Nov-27-1984 01:11:06 # expand --- convert a template into an EOS-terminated string integer function expand (template, str, strlen) integer strlen character template (ARB), str (strlen) integer ji, ti, si, pi, xi integer lutemp character c character jig (MAXLINE), pbuf (MAXLINE), xbuf (MAXLINE) procedure getchar forward si = 1 # 'str' index pi = 1 # 'pbuf' index ti = 1 # 'template' index for (getchar; si <= strlen && c ~= EOS; getchar) { if (c == '='c) { # start of a template? getchar for (ji = 1; ji <= MAXLINE && c ~= '='c && c ~= EOS; ji += 1) { jig (ji) = c getchar } jig (ji) = EOS if (c ~= '='c) { str (si) = EOS return (ERR) } if (ji <= 1) { # empty template .. expand to '='c str (si) = '='c si += 1 } else { xi = lutemp (jig, xbuf, MAXLINE) if (xi == EOF || xi + pi >= MAXLINE) { str (si) = EOS return (ERR) } for (; xi > 0; {xi -= 1; pi += 1}) pbuf (pi) = xbuf (xi) } } else { str (si) = c si += 1 } } str (si) = EOS if (c ~= EOS) return (ERR) return (si - 1) # getchar --- get a character from the template or pushback buffer procedure getchar { if (pi > 1) { pi -= 1 c = pbuf (pi) } else if (template (ti) ~= EOS) { c = template (ti) ti += 1 } else c = EOS } end #HD#: fcopy.r 389 Nov-27-1984 01:11:06 # fcopy --- copy file 'in' to file 'out' subroutine fcopy (ifd, ofd) file_des ifd, ofd include SWT_COMMON integer f1, f2, l integer getlin, readf character buf (1024) filedes in, out filedes mapsu in = mapsu (ifd) out = mapsu (ofd) f1 = fd_offset (in) f2 = fd_offset (out) if (Fd_dev (f1) == DEV_DSK && Fd_dev (f2) == DEV_DSK) { while (Fd_bcount (f1) ~= 0 || Fd_bcount (f2) ~= 0 || and (Fd_flags (f1), FD_BYTE) ~= 0 || and (Fd_flags (f2), FD_BYTE) ~= 0) { if (getlin (buf, in, 1024) == EOF) return call putlin (buf, out) } repeat { l = readf (buf, 1024, in) if (l == EOF || l == ERR) break call writef (buf, l, out) } } else while (getlin (buf, in) ~= EOF) call putlin (buf, out) return end #HD#: filcpy.r 1391 Nov-27-1984 01:11:06 # filcpy --- copy a file from here to there integer function filcpy (from, to) character from (ARB), to (ARB) integer attach, j1 (3), fd, code, ifd, ofd, otype, itype integer rnw, junk integer buf (MAXDIRENTRY), array (2) character fname (MAXPACKEDFNAME), tname (MAXPACKEDFNAME) character junk1 (MAXVARYFNAME) integer getto, remove character str (MAXLINE) procedure error_exit forward ifd = 0 ofd = 0 ### Open the "from" file and get its attributes if (getto (from, fname, j1, attach) == ERR) error_exit call srch$$ (KREAD + KGETU, KCURR, 0, fd, junk, code) if (code ~= 0) error_exit call ptov (fname, ' 'c, junk1, MAXVARYFNAME) call ent$rd (fd, junk1, loc(buf), MAXDIRENTRY, code) call srch$$ (KCLOS, 0, 0, fd, 0, junk) if (code ~= 0 || rt (buf (20), 8) >= 4) error_exit call srch$$ (KREAD + KGETU, fname, 32, ifd, itype, code) if (code ~= 0) error_exit ### Open the destination file with the same type if (getto (to, tname, j1, attach) == ERR) error_exit call srch$$ (KRDWR + KGETU + ls (itype, 10), tname, 32, ofd, otype, code) if (lt (otype, 14) ~= 0) # It's a special file -- can't copy to it error_exit if (rt (itype, 2) ~= rt (otype, 2)) { # Get rid of the old file ... call srch$$ (KCLOS, 0, 0, ofd, 0, code) call ptoc (tname, ' 'c, str, 33) if (remove (str) == ERR) error_exit call srch$$ (KRDWR + KGETU + ls (itype, 10), tname, 32, ofd, otype, code) if (code ~= 0) error_exit } elif (rt (otype, 2) >= 2) # clean out old segdir call rmseg$ (ofd) ### Both files are open and of the same type -- call the ### appropriate copy routine if (rt (itype, 2) >= 2) # segdirs call cpseg$ (ifd, ofd, code) else call cpfil$ (ifd, ofd, code) if (code == ERR) error_exit ### Truncate the "to" file if not a segdir if (otype < 2) { call prwf$$ (KTRNC, ofd, 0, 0, intl (0), rnw, code) if (code ~= 0) error_exit } ### Close both files call srch$$ (KCLOS, 0, 0, ifd, 0, code) call srch$$ (KCLOS, 0, 0, ofd, 0, code) ### Set the attributes on the "to" file, if possible array (1) = buf (18) array (2) = 0 call satr$$ (KPROT, tname, 32, array, code) array (1) = buf (21) array (2) = buf (22) call satr$$ (KDTIM, tname, 32, array, code) array (1) = rt (rs (buf (20), 10), 2) array (2) = 0 call satr$$ (KRWLK, tname, 32, array, code) if (and (buf (20), 8r40000) ~= 0) call satr$$ (KDMPB, tname, 32, intl (0), code) return (OK) # error_exit --- close the open files and return error status procedure error_exit { if (ifd ~= 0) call srch$$ (KCLOS, 0, 0, ifd, 0, code) if (ofd ~= 0) call srch$$ (KCLOS, 0, 0, ofd, 0, code) return (ERR) } end #HD#: file$p.s 2839 Nov-27-1984 01:11:06 * file$p --- connect SWT i/o to a Pascal file * * declaration: * * type name = array [1..7] of char; * * procedure file$p (var f: text; n: name); * extern; * * calling sequence: * * file$p (pascal_file_variable, 'swt_file'); * * entry (arg 1) = address of Pascal file block. * (arg 2) = string containing SWT file name. * * exit file connected. SUBR FILE$P SEG RLIT include "=syscom=/keys.ins.pma" include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK FILE$P ECB CONNECT,,FILE,2 DATA 6,C'FILE$P' PROC DYNM =20,FILE(3),NAME(3),CODE,ADDR(2),INDEX,UNIT DYNM SUNIT,PUNIT,I,PATH(MAXPATH),TREE(MAXPATH) FCB_FLAG EQU XB%+0 FCB_CUR_POS_PTR EQU XB%+1 FCB_BUF_SIZE EQU XB%+4 FCB_UNIT_NUM EQU XB%+6 FCB_NUM_OBJ EQU XB%+7 FCB_OBJ_SIZE EQU XB%+8 FCB_FILE_NAME EQU XB%+10 FCB_TOTAL_OBJ EQU XB%+74 FCB_BUFFER EQU XB%+75 CONNECT ARGT transfer arguments ENTR FILE$P EAL CONNECTA set address of first file name STL ADDR LDX =10 get number of SWT file names LDY =2 get offset halfway through name CONNECT1 LDL ADDR,* check first 4 characters of name SBL NAME,* BCNE CONNECT2 if not a match LDL ADDR,*Y check remainder of name ERL NAME,*Y ANL =-256L clear last character BLEQ CONNECT3 if a match CONNECT2 LDL ADDR advance address to next entry ADL =4L STL ADDR BDX CONNECT1 continue search CALL ERRPR$ signal bad file name error AP =K$NRTN,S AP =E$BNAM,S AP =0,S AP =0,S AP =C'FILE$P',S AP =6,SL CONNECT3 STX INDEX save loop index LDA =10 calculate index into units SUB INDEX 0 = STDIN, 1 = STDIN1, etc. TAX LDA CONNECTB,X set requested unit number STA UNIT CALL MAPSU convert unit to SWT unit number AP UNIT,SL STA SUNIT CALL FLUSH$ flush file buffer AP SUNIT,SL CALL MAPFD convert unit to PRIMOS unit number AP UNIT,SL STA PUNIT BLE CONNECT7 if file is not on disk CALL ATTDEV attach requested file AP PUNIT,S AP =7,S select compressed disk file AP PUNIT,S AP =128,SL buffer is 128 words EAXB FILE,* get address of file control block LDA INDEX see if file is input or output SUB =6 BCLT CONNECT4 if file is a standard output LDA =B'1110010000000000' set input file values STA FCB_FLAG CRA clear number of objects STA FCB_NUM_OBJ JMP CONNECT6 CONNECT4 LDA =B'0111010000000000' set output file values STA FCB_FLAG LDA =1 set number of objects to 1 STA FCB_NUM_OBJ LDA =C' ' blank fill the buffer LDX =128 CONNECT5 STA FCB_BUFFER-1,X BDX CONNECT5 CONNECT6 LDA PUNIT set file unit number STA FCB_UNIT_NUM JMP CONNECT11 CONNECT7 EAXB FILE,* get address of file control block LDA INDEX see if file in input or output SUB =6 BCLT CONNECT8 if file is a standard output LDA =B'1110011000000000' set input file value STA FCB_FLAG CRA clear number of objects STA FCB_NUM_OBJ JMP CONNECT10 CONNECT8 LDA =B'0111011000000000' set output file values STA FCB_FLAG LDA =1 set number of objects STA FCB_NUM_OBJ LDA =C' ' blank fill the buffer LDX =128 CONNECT9 STA FCB_BUFFER-1,X BDX CONNECT9 CONNECT10 LDA =1 set terminal file unit STA FCB_UNIT_NUM CONNECT11 EAL FCB_BUFFER get a pointer to the buffer STL FCB_CUR_POS_PTR CRA clear bit offset STA FCB_CUR_POS_PTR+2 LDA =256 initialize the buffer size STA FCB_TOTAL_OBJ XCA STL FCB_BUF_SIZE LDL =1L set object size to 1 byte STL FCB_OBJ_SIZE CLEAR_FNAME LDA =C' ' blank out the file name LDX =64 CONNECT12 STA FCB_FILE_NAME-1,X BDX CONNECT12 GET_FNAME CALL GFNAM$ get the name of the file AP UNIT,S AP PATH,S AP =MAXPATH,SL CAS =ERR did we get it? SKP JMP# STORE_BAD_PATH nope, store bad pathname CHECK_TTY CALL PTOC is the file AP DEV_TTY,S is connected to the AP =PERIOD,S terminal device ("/dev/tty") ? AP TREE,S AP =MAXPATH,SL CALL EQUAL AP PATH,S AP TREE,SL CAS =YES SKP JMP# STORE_TTY CHECK_NULL CALL PTOC is the file AP DEV_NULL,S connected to the AP =PERIOD,S null device ("/dev/null") ? AP TREE,S AP =MAXPATH,SL CALL EQUAL AP PATH,S AP TREE,SL CAS =YES Yes it is, Pascal doesn't SKP support I/O to /dev/null JMP# STORE_TTY use /dev/tty as filename CALL MKTR$ it is a valid disk file AP PATH,S AP TREE,SL LDA =1 store the file name into STA I the Pascal file control CALL CTOP block AP TREE,S AP I,S AP FILE,* AP FCB_FILE_NAME,S AP =64,SL PRTN STORE_TTY CALL MOVE$ store the TTY name into AP TTY_PATH,S the Pascal file control AP FILE,* block AP FCB_FILE_NAME,S AP =2,SL PRTN STORE_BAD_PATH CALL MOVE$ store the Bad Pathname message AP BAD_PATH,S into the Pascal file control AP FILE,* block AP FCB_FILE_NAME,S AP =9,SL PRTN LINK CONNECTA BCI 'STDIN ' table of SWT file names BCI 'STDIN1 ' BCI 'STDIN2 ' BCI 'STDIN3 ' BCI 'ERRIN ' BCI 'STDOUT ' BCI 'STDOUT1' BCI 'STDOUT2' BCI 'STDOUT3' BCI 'ERROUT ' CONNECTB DATA STDIN table of corresponding units DATA STDIN1 DATA STDIN2 DATA STDIN3 DATA ERRIN DATA STDOUT DATA STDOUT1 DATA STDOUT2 DATA STDOUT3 DATA ERROUT DEV_NULL BCI '/dev/null.' DEV_TTY BCI '/dev/tty.' BAD_PATH BCI 'path unobtainable ' TTY_PATH BCI 'TTY ' END #HD#: filset.r 520 Nov-27-1984 01:11:06 # filset --- expand set at array (i) into set (j), stop at delim subroutine filset (delim, array, i, set, j, maxset) integer i, j, maxset character array (ARB), delim, set (maxset) character esc integer addset, index integer junk string digits "0123456789" string lowalf "abcdefghijklmnopqrstuvwxyz" string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" for ( ; array (i) ~= delim && array (i) ~= EOS; i += 1) if (array (i) == ESCAPE) junk = addset (esc (array, i), set, j, maxset) else if (array (i) ~= PAT_DASH) junk = addset (array (i), set, j, maxset) else if (j <= 1 || array (i + 1) == EOS) # literal - junk = addset (PAT_DASH, set, j, maxset) else if (index (digits, set (j - 1)) > 0) call dodash (digits, array, i, set, j, maxset) else if (index (lowalf, set (j - 1)) > 0) call dodash (lowalf, array, i, set, j, maxset) else if (index (upalf, set (j - 1)) > 0) call dodash (upalf, array, i, set, j, maxset) else junk = addset (PAT_DASH, set, j, maxset) return end #HD#: filtst.r 2013 Nov-27-1984 01:11:07 # filtst --- function to perform several tests upon pathname integer function filtst (path, zero, permissions, exists, type, readable, writeable, dumped) integer path(MAXPATH) integer zero # file is or is not zero length integer permissions # type of permissions on the file integer exists # does path exist or not integer type # file type (SAM, DAM, UFD) integer readable # is file readable or not integer writeable # is file writeable or not integer dumped # is the dumped bit set or not #------------------------------------------------------------------------ # # returns YES, NO, ERR depending on if the specified # arguments were true, false, or not determinable # #------------------------------------------------------------------------ # # how args are represented: # # pathname: unpacked, EOS terminated string, SWT style # # exists: -1 == does not exist # 0 == do not test for existence # +1 == does exist # # permissions: as per PRIMOS directory bits # # zero: -1 == has non-zero length # 0 == do not test length # +1 == has zero length # # type: 0 == do not test type # otherwise, as per PRIMOS directory bits # except that the high order bit must be on # in order to distinguish between SAM file # test and do not test type. # # readable: -1 == file is not readable # 0 == do not test file readablilty # +1 == file is readable # # writeable: -1 == file is not writeable # 0 == do not test file writability # +1 == file is writeable # # dumped: -1 == file has not been dumped # 0 == do not test dumped bit # +1 == file has been dumped # #------------------------------------------------------------------------ integer p_fd, ppwd(32), pname(32), attach, temp character vname(MAXVARYFNAME) integer getto, open integer code, buf(MAXDIRENTRY), junk procedure return_NO forward procedure return_ERR forward if (getto (path, pname, ppwd, attach) == ERR) # get to the file return (ERR) if (exists ~= 0) { # check for existence call srch$$ (KEXST, pname, 32, p_fd, temp, code) if ((code == EFNTF && exists == -1) || (code == EFNTS && exists == -1) || (code == 0 && exists == 1)) ; else return_NO } if (readable ~= 0) { # check if readable temp = open (path, READ) if (temp ~= ERR) call close (temp) if (temp == ERR && readable == 1 || temp ~= ERR && readable == -1) return_NO } if (writeable ~= 0) { temp = open (path, WRITE) if (temp ~= ERR) call close (temp) if (temp == ERR && writeable == 1 || temp ~= ERR && writeable == -1) return_NO } if (zero ~= 0) { # check for zero / non-zero length call srch$$ (KREAD+KGETU, pname, 32, p_fd, temp, code) if (code ~= 0) return_ERR call prwf$$ (KPOSN+KPREA, p_fd, loc(temp), 0, intl(1), 0, code) call srch$$ (KCLOS, pname, 32, p_fd, temp, junk) if ((code == 0 && zero == -1) || (code == EEOF && zero == 1)) ; else return_NO } if (dumped ~= 0 || permissions ~= 0 || type ~= 0) { call srch$$ (KREAD+KGETU, KCURR, 0, p_fd, temp, code) if (code ~= 0) return_ERR call ptov (pname, ' 'c, vname, MAXVARYFNAME) call ent$rd (p_fd, vname, loc(buf), MAXDIRENTRY, code) call srch$$ (KCLOS, 0, 0, p_fd, temp, junk) if (code ~= 0) return_ERR if (permissions ~= 0) { if (permissions == and (buf(18), permissions)) ; else return_NO } if (type ~= 0) { temp = and (type, :77) if (temp == and (buf(20), :77)) ; else return_NO } if (dumped ~= 0) { if ((dumped == -1 && and (buf(20), :40000) == 0) || (dumped == 1 && and (buf(20), :40000) ~= 0)) ; else return_NO } } if (attach == YES) call at$hom (code) return (YES) # return_NO --- attach home and return NO procedure return_NO { if (attach == YES) call at$hom (code) return (NO) } # return_ERR --- attach home and return ERR procedure return_ERR { if (attach == YES) call at$hom (code) return (ERR) } end #HD#: findf$.r 126 Nov-27-1984 01:11:07 # findf$ --- does file exist in current directory integer function findf$ (file) integer file (16) integer junk, rc call srch$$ (KEXST, file, 32, 16, junk, rc) if (rc == EFNTF) findf$ = NO else findf$ = YES return end #HD#: finfo$.r 307 Nov-27-1984 01:11:07 # finfo$ --- return information about a file integer function finfo$ (path, entry, attach) character path (ARB) integer entry (ARB), attach integer code, fd, junk (3) character name (MAXPACKEDFNAME), vname (MAXVARYFNAME) integer getto finfo$ = ERR if (getto (path, name, junk, attach) == ERR) return call srch$$ (KREAD + KGETU, KCURR, 0, fd, junk, code) if (code ~= 0) return call ptov (name, ' 'c, vname, MAXVARYFNAME) call ent$rd (fd, vname, loc(entry), MAXDIRENTRY, code) call srch$$ (KCLOS, 0, 0, fd, 0, junk) if (code == 0) finfo$ = OK return end #HD#: first$.r 130 Nov-27-1984 01:11:07 # first$ --- find out if this is the first call here since login integer function first$ (flag) integer flag include SWT_COMMON if (First_use == 8r52525) flag = NO else { flag = YES First_use = 8r52525 } return (flag) end #HD#: flush$.r 797 Nov-27-1984 01:11:07 # flush$ --- flush out a file's buffer integer function flush$ (fd) filedes fd include SWT_COMMON integer f, junk character zerostr (2) data zerostr / 0, EOS / if (fd < 1 || fd > NFILES) return (ERR) f = fd_offset (fd) if (Fd_flags (f) == 0 || and (Fd_flags (f), FD_ERR) ~= 0) return (ERR) Errcod = 0 call break$ (DISABLE) select (Fd_dev (f)) when (DEV_DSK) { select (LASTOP (f)) when (FD_PUTLIN) { if (Fd_bcount (f) ~= 0) # flush blanks call dputl$ (zerostr, Fdesc (f)) elif (and (Fd_flags (f), FD_BYTE) ~= 0) Fd_count (f) += 1 if (Fd_count (f) + Fd_buflen (f) > 0) call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (Fd_bufstart (f) + 1)), Fd_count (f) + Fd_buflen (f), intl (0), junk, Errcod) } when (FD_GETLIN) { if (and (Fd_flags (f), FD_BYTE) ~= 0) Fd_count (f) += 1 if (Fd_count (f) < 0) call prwf$$ (KPOSN + KPRER, Fd_unit (f), intl (0), 0, intl (Fd_count (f)), junk, Errcod) } when (FD_WRITEF) { if (Fd_count (f) + Fd_buflen (f) ~= 0) { call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (Fd_bufstart (f) + 1)), Fd_count (f) + Fd_buflen (f), intl (0), junk, Errcod) } } when (FD_READF) { if (Fd_count (f) < 0) call prwf$$ (KPOSN + KPRER, Fd_unit (f), intl (0), 0, intl (Fd_count (f)), junk, Errcod) } } # when (DEV_DSK) Fd_bufend (f) = 0 Fd_count (f) = 0 Fd_bcount (f) = 0 Fd_flags (f) &= not (FD_BYTE) SET_LASTOP (f, FD_INITIAL) call break$ (ENABLE) if (Errcod ~= 0) { Fd_flags (f) |= FD_ERR return (ERR) } return (OK) end #HD#: follow.r 743 Nov-27-1984 01:11:07 # follow --- path name follower integer function follow (path, seth) character path (ARB) integer seth integer i, save_bplabel (4) integer getto, ptoc shortcall mkonu$ (18) external bponu$ include SWT_COMMON integer attach_sw integer pname (16), ppwd (3), unpackedn(40), vpack(21), i procedure restore_Bplabel forward call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing save_bplabel (i) = Bplabel (i) # common block values call mklb$f ($1, Bplabel) call break$ (ENABLE) call mkonu$ ("BAD_PASSWORD$"v, loc (bponu$)) if (path (1) == EOS) call at$hom (Errcod) elif (getto (path, pname, ppwd, attach_sw) == OK) { i = ptoc (pname, " "c, unpackedn, 33) # build the directory name unpackedn (i + 1) = " "c i += 2 call ptoc (ppwd, " "c, unpackedn(i), 7) # and password for converting i = 1 call ctov (unpackedn, i, vpack, 21) # to character varying call at$rel (seth, vpack, Errcod) # for at$rel } else { 1 call at$hom (i) restore_Bplabel return (ERR) } if (Errcod == 0) { restore_Bplabel return (OK) } else { call at$hom (i) restore_Bplabel return (ERR) } # restore_Bplabel --- restore saved value of Bplabel procedure restore_Bplabel { local i; integer i call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing Bplabel (i) = save_bplabel (i) # common block values call break$ (ENABLE) } end #HD#: gcdir$.r 192 Nov-27-1984 01:11:08 # gcdir$ --- get current directory pathname integer function gcdir$ (path) character path (ARB) integer curdir (MAXLINE), dirname (MAXLINE) integer size, code integer mkpa$ call gpath$ (KCURA, 0, curdir, MAXLINE, size, code) if (code ~= 0) return (ERR) call ptoc (curdir, EOS, dirname, size + 1) call mkpa$ (dirname, path, NO) return (OK) end #HD#: gcifu$.r 86 Nov-27-1984 01:11:08 # gcifu$ --- return the current value of Comunit integer function gcifu$ (funit) integer funit include SWT_COMMON funit = Comunit return (funit) end #HD#: gctoi.r 474 Nov-27-1984 01:11:08 # gctoi --- convert any radix string to single precision integer integer function gctoi (str, i, radix) character str (ARB) integer i, radix integer base, v, d, j integer index character mapdn bool neg string digits "0123456789abcdef" v = 0 base = radix SKIPBL (str, i) neg = (str (i) == '-'c) if (str (i) == '+'c || str (i) == '-'c) i += 1 if (str (i + 2) == 'r'c && str (i) == '1'c && IS_DIGIT (str (i + 1)) || str (i + 1) == 'r'c && IS_DIGIT (str (i))) { base = str (i) - '0'c j = i if (str (i + 1) ~= 'r'c) { j += 1 base = base * 10 + (str (j) - '0'c) } if (base < 2 || base > 16) base = radix else i = j + 2 } for (; str (i) ~= EOS; i += 1) { if (IS_DIGIT (str (i))) d = str (i) - '0'c else d = index (digits, mapdn (str (i))) - 1 if (d < 0 || d >= base) break v = v * base + d } if (neg) return (-v) else return (+v) end #HD#: gctol.r 479 Nov-27-1984 01:11:08 # gctol --- convert any radix string to double precision integer longint function gctol (str, i, radix) character str (ARB) integer i, radix longint v integer base, d, j integer index character mapdn bool neg string digits "0123456789abcdef" v = 0 base = radix SKIPBL (str, i) neg = (str (i) == '-'c) if (str (i) == '+'c || str (i) == '-'c) i += 1 if (str (i + 2) == 'r'c && str (i) == '1'c && IS_DIGIT (str (i + 1)) || str (i + 1) == 'r'c && IS_DIGIT (str (i))) { base = str (i) - '0'c j = i if (str (i + 1) ~= 'r'c) { j += 1 base = base * 10 + (str (j) - '0'c) } if (base < 2 || base > 16) base = radix else i = j + 2 } for (; str (i) ~= EOS; i += 1) { if (IS_DIGIT (str (i))) d = str (i) - '0'c else d = index (digits, mapdn (str (i))) - 1 if (d < 0 || d >= base) break v = v * base + d } if (neg) return (-v) else return (+v) end #HD#: geta$f.r 186 Nov-27-1984 01:11:08 # geta$f --- get an argument for a Fortran program integer function geta$f (ap, str, len) integer ap, len integer str (ARB) integer i integer getarg, ctop character arg (MAXARG) for (i = (len + 1) / 2; i > 0; i -= 1) str (i) = " " if (getarg (ap, arg, MAXARG) == EOF) return (-1) i = 1 return (ctop (arg, i, str, len / 2)) end #HD#: geta$p.r 185 Nov-27-1984 01:11:08 # geta$p --- get an argument for a Pascal program integer function geta$p (ap, str, len) integer ap, len integer str (ARB) integer i integer getarg, ctop character arg (MAXARG) for (i = (len + 1) / 2; i > 0; i -= 1) str (i) = " " if (getarg (ap, arg, MAXARG) == EOF) return (-1) i = 1 return (ctop (arg, i, str, len / 2)) end #HD#: geta$plg.plg 262 Nov-27-1984 01:11:09 /* geta$plg --- get an argument for a PL/I Subset G program */ geta$plg: procedure (ap, str, len) returns (fixed); declare ap fixed, str char (128) varying, len fixed; declare getarg entry (fixed, (128) fixed, fixed) returns (fixed), ctov entry ((128) fixed, fixed, char (128) var, fixed) returns (fixed); declare i fixed, arg (128) fixed; if getarg (ap, arg, 128) = -1 then return (-1); i = 1; return (ctov (arg, i, str, divide (len, 2, 15) + 1)); end geta$plg; #HD#: getarg.r 247 Nov-27-1984 01:11:09 # getarg --- get an argument from the linked string space integer function getarg (arg_p, str, size) integer arg_p, size character str (ARB) integer p, i include SWT_COMMON if (arg_p < 0 || arg_p >= Arg_c) { str (1) = EOS return (EOF) } p = Arg_v (arg_p + 1) for (i = 1; i < size; i += 1) { while (Ls_ref (p) >= 300) p = Ls_ref (p) - 300 if (Ls_ref (p) == EOS) break str (i) = Ls_ref (p) p += 1 } str (i) = EOS return (i - 1) end #HD#: getccl.r 304 Nov-27-1984 01:11:09 # getccl --- expand char class at arg (i) into pat (j) integer function getccl (arg, i, pat, j) character arg (MAXARG), pat (MAXPAT) integer i, j integer addset integer jstart, junk i += 1 # skip over [ if (arg (i) == PAT_NOT) { junk = addset (PAT_NCCL, pat, j, MAXPAT) i += 1 } else junk = addset (PAT_CCL, pat, j, MAXPAT) jstart = j junk = addset (0, pat, j, MAXPAT) # leave room for count call filset (PAT_CCLEND, arg, i, pat, j, MAXPAT) pat (jstart) = j - jstart - 1 if (arg (i) == PAT_CCLEND) getccl = OK else getccl = ERR return end #HD#: getch.r 114 Nov-27-1984 01:11:09 # getch --- get a character from a file character function getch (c, fd) character c integer fd character buf (2) integer getlin c = getlin (buf, fd, 2) if (c ~= EOF) c = buf (1) return (c) end #HD#: getfd$.r 440 Nov-27-1984 01:11:09 # getfd$ --- look for an empty file descriptor cleverly file_des function getfd$ (fd) file_des fd include SWT_COMMON integer limit procedure search (start, limit) forward ### Get the number of the last descriptor in the first page limit = ((loc (Fdmem) / 1024 * 1024 + 1024) - loc (Fdmem)) / FDSIZE ### Look for an empty descriptor search (Fd_lastfd, limit) search (Fd_lastfd, NFILES) return (ERR) # search --- search for any empty descriptor, modulo 'limit' procedure search (start, limit) { integer start, limit local i; integer i if (start < 1 || start > limit) start = 1 if (start >= limit) i = 1 else i = start + 1 while (Fd_flags (fd_offset (i)) ~= 0 && i ~= limit) if (i >= limit) i = 1 else i += 1 if (i ~= limit) { Fd_lastfd = i fd = i return (i) } } end #HD#: getkwd.r 287 Nov-27-1984 01:11:09 # getkwd --- get keyword type arguments from argument list integer function getkwd (keywd, value, length, defalt) character keywd (ARB), value (ARB), defalt (ARB) integer length integer i, j integer equal, getarg character arg (MAXARG) for (i = 1; getarg (i, arg, MAXARG) ~= EOF; i += 1) if (equal (keywd, arg) == YES) { getkwd = getarg (i + 1, value, length) if (getkwd == EOF) break return } for (j = 1; j < length && defalt (j) ~= EOS; j += 1) value (j) = defalt (j) value (j) = EOS getkwd = j - 1 return end #HD#: getlin.r 450 Nov-27-1984 01:11:09 # getlin --- read one line from a file integer function getlin (line, fd, xmax) character line (ARB) integer fd, xmax include SWT_COMMON integer off, max, f integer tgetl$, dgetl$, mapsu logical missin f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_READ) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) { line (1) = EOS return (EOF) } if (missin (xmax)) max = MAXLINE else max = xmax if (max <= 1) { line (1) = EOS return (0) } if (LASTOP (off) ~= FD_GETLIN) { call flush$ (f) SET_LASTOP (off, FD_GETLIN) } select (Fd_dev (off)) when (DEV_TTY) getlin = tgetl$ (line, max, off) when (DEV_DSK) getlin = dgetl$ (line, max, Fdesc (off)) when (DEV_NULL) getlin = 0 else getlin = 0 if (getlin == 0) { line (1) = EOS return (EOF) } return end #HD#: getto.r 2028 Nov-27-1984 01:11:10 # getto --- get to the last file in a path name integer function getto (pathin, pfilename, ppwd, attach_sw) character pathin (ARB) integer pfilename (16), ppwd (3) integer attach_sw include SWT_COMMON integer expand, mktr$ character dirname (MAXTREE), temp (MAXPATH) character fulltree (MAXTREE), diskname (17) integer count, loop, sp, tp, j, save_bplabel (4) shortcall mkonu$ (18) external bponu$ procedure check_code forward procedure getname forward procedure putname forward procedure restore_Bplabel forward call break$ (DISABLE) # no interruptions do j = 1, 4 # while changing save_bplabel (j) = Bplabel (j) # common block values call mklb$f ($1, Bplabel) call break$ (ENABLE) call mkonu$ ("BAD_PASSWORD$"v, loc (bponu$)) attach_sw = YES if (expand (pathin, temp, MAXPATH) == ERR) { attach_sw = NO restore_Bplabel return (ERR) } call mktr$ (temp, fulltree) call mapstr (fulltree, UPPER) if (pathin (1) == EOS) { # case of current directory call at$hom (Errcod) check_code tp = 1 putname pfilename (1) = KCURR # Primos key for current directory attach_sw = NO restore_Bplabel return (OK) } # Count the number of pathname elements to worry about count = 0 for (loop = 1; fulltree (loop) ~= EOS; loop += 1) if (fulltree (loop) == '>'c) count += 1 if (fulltree(1) ~= '*'c) count += 1 loop = 1 repeat { if (loop ~= 1) { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } elif (fulltree (1) == '<'c) { # absolute partition reference for (tp = 1; fulltree (tp) ~= '>'c; tp += 1) temp (tp) = fulltree (tp) tp += 1 # step past '>' if (count == 1) putname temp(tp - 1) = '>'c call ctoc("MFD XXXXXX"s, temp(tp), MAXPATH) sp = 1 call ctov (temp, sp, dirname, MAXTREE) call at$ (KSETC, dirname, Errcod) } elif (fulltree (1) == '*'c) { # name references current directory tp = 3 if (count == 1) { # name is in current directory attach_sw = NO putname restore_Bplabel return (OK) } else { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } } else { # absolute reference on any partition tp = 1 if (count == 1) putname getname call at$any (KSETC, dirname, Errcod) if (count == 1) { # special case of //name check_code call at$abs (KSETC, "*"v, "MFD XXXXXX"v, Errcod) check_code restore_Bplabel return (OK) } } check_code loop += 1 } until (loop >= count) putname restore_Bplabel return (OK) 1 continue # bad password return Errcod = EBPAS check_code # check_code --- check return code for errors procedure check_code { local i; integer i if (Errcod ~= 0) { call at$hom (i) attach_sw = NO restore_Bplabel return (ERR) } } # getname --- get the name of the next node in the treename procedure getname { local i, sp; integer i, sp for (i = 1; fulltree (tp) ~= '>'c && fulltree (tp) ~= EOS; {i += 1; tp += 1}) temp (i) = fulltree (tp) temp (i) = EOS tp += 1 # step past the '>' sp = 1 call ctov (temp, sp, dirname, 21) if (i > 40) { Errcod = EITRE check_code } } # putname --- put name and password into 'pfilename' and # 'ppwd' in packed format procedure putname { local i; integer i do i = 1,3 ppwd (i) = " " do i = 1,16 pfilename (i) = " " j = 0 for (i = tp; fulltree (i) ~= EOS && fulltree (i) ~= ' 'c && j <= 32; i += 1) spchar (pfilename, j, fulltree (i)) if (fulltree (i) ~= EOS) { j = 0 for (i += 1; fulltree (i) ~= EOS && j <= 6; i += 1) spchar (ppwd, j, fulltree (i)) } } # restore_Bplabel --- restore saved value of Bplabel procedure restore_Bplabel { local i; integer i call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing Bplabel (i) = save_bplabel (i) # common block values call break$ (ENABLE) } end #HD#: getvdn.r 319 Nov-27-1984 01:11:10 # getvdn --- return the name of a file in the user's variables directory subroutine getvdn (fn, pn, un) character fn (ARB), pn (ARB), un (ARB) integer i integer length, equal, ctoc, scopy character name (MAXLINE) logical missin include SWT_COMMON i = ctoc ("=vars=/"s, pn, MAXLINE) call date (SYS_USERID, name) if (missin (un) || equal (un, name) == YES) { i += scopy (name, 1, pn, i + 1) if (length (Passwd) ~= 0) { pn (i + 1) = ':'c i += scopy (Passwd, 1, pn, i + 2) + 1 } } else i += scopy (un, 1, pn, i + 1) pn (i + 1) = '/'c call scopy (fn, 1, pn, i + 2) return end #HD#: getwrd.r 163 Nov-27-1984 01:11:10 # getwrd --- get non-blank word from in(i) into out, increment i integer function getwrd (in, i, out) integer in (ARB), out (ARB) integer i, j SKIPBL (in, i) for (j = 1; in (i) ~= EOS && in (i) ~= ' 'c && in (i) ~= NEWLINE; {i += 1; j += 1}) out (j) = in (i) out (j) = EOS return (j - 1) end #HD#: gfdata.r 3692 Nov-27-1984 01:11:10 # gfdata --- get file infomation integer function gfdata (key, xpath, infobuf, attach_sw, auxil) integer key, attach_sw character xpath (ARB) integer infobuf (ARB), auxil (ARB) include SWT_COMMON integer ecw, fname, protectbits, typebits, date, time integer entrdbuf (MAXDIRENTRY) equivalence (ecw, entrdbuf), (fname, entrdbuf (2)) equivalence (protectbits, entrdbuf (18)), (typebits, entrdbuf (20)) equivalence (date, entrdbuf (21)), (time, entrdbuf (22)) integer vname (17), name (16) equivalence (vname (2), name) integer junk (MAXPATH), junk2 (MAXPATH), vtree (129), ppwd (3) integer i, j, pathname (MAXPATH) long_int fsize, qbuf (8) logical nameq$ longint szfil$ integer getto, gtacl$, mksacl, index, equal, mapdn, expand procedure do_protec forward procedure do_entrd forward procedure do_type forward procedure do_size forward procedure do_access forward procedure make_and_validate_tree forward attach_sw = NO Errcod = 0 if (expand (xpath, pathname, MAXPATH) == ERR) return (ERR) select (key) when (FILE_UFDQUOTA) { make_and_validate_tree call q$read (vtree, infobuf, 6, i, Errcod) if (i == 0) auxil (1) = YES else { auxil (1) = NO return (ERR) } } when (FILE_FULL_INFO) { do_entrd call move$ (entrdbuf, infobuf, MAXDIRENTRY) } when (FILE_TYPE) { do_entrd do_type } when (FILE_DMBITS) { do_entrd if (and (8r40000, typebits) ~= 0) infobuf (1) = YES else infobuf (1) = NO if (and (8r20000, typebits) ~= 0) infobuf (2) = YES else infobuf (2) = NO } when (FILE_RWLOCK) { do_entrd i = and (3, rs (typebits, 10)) select (i) when (0) call ctoc ("sys"s, infobuf, 7) when (1) call ctoc ("n-1"s, infobuf, 7) when (2) call ctoc ("n+1"s, infobuf, 7) when (3) call ctoc ("n+n"s, infobuf, 7) } when (FILE_TIMMOD) { do_entrd infobuf (1) = and (2r1111111, rs (date, 9)) infobuf (2) = and (2r1111, rs (date, 5)) infobuf (3) = and (2r11111, date) infobuf (6) = mod (time, 15) * 4 i = time / 15 infobuf (5) = mod (i, 60) infobuf (4) = i / 60 } when (FILE_ACL) { if (gtacl$ (pathname, 1, attach_sw) == ERR) return (ERR) elif (mksacl (auxil (2), infobuf, auxil (1), " "s) == ERR) return (ERR) } when (FILE_ACCESS) do_access when (FILE_PRIORITYACL) { if (gtacl$ (pathname, 2, attach_sw) == ERR) return (ERR) elif (mksacl (junk, infobuf, junk, " "s) == ERR) return (ERR) } when (FILE_DELSWITCH) { do_entrd if (and (protectbits, 8r200) ~= 0) infobuf (1) = YES else infobuf (1) = NO } when (FILE_SIZE) { do_entrd if (rs (ecw, 8) == 3) return (ERR) # cannot size an ACL! else do_size } when (FILE_PROTECTION) { do_entrd do_protec } when (FILE_PASSWORDS) { if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) call gpas$$ (name, 32, ppwd, junk, Errcod) if (Errcod ~= 0) return (ERR) call ptoc (ppwd, EOS, infobuf, 7) call ptoc (junk, EOS, auxil, 7) } ifany { if (attach_sw == YES) call at$hom (i) if (Errcod == 0) return (OK) else return (ERR) } else return (ERR) # bad key # do_protec --- interpret the (old style) protection for files procedure do_protec { local prot, loop, ind integer prot, loop, ind define (INSCHAR (x), {infobuf (ind) = x; ind += 1}) ind = 1 for (loop = 1; loop < 3; loop += 1) { if (loop == 1) prot = rs (protectbits, 8) else { prot = rt (protectbits, 8) INSCHAR ('/'c) } if (prot == 7) INSCHAR ('a'c) else { if (and (prot, 4) ~= 0) INSCHAR ('d'c) if (and (prot, 2) ~= 0) INSCHAR ('w'c) if (and (prot, 1) ~= 0) INSCHAR ('r'c) } } INSCHAR (EOS) undefine (INSCHAR) } # do_entrd --- read the directory entry for the pathname procedure do_entrd { local typ, funit, i integer typ, funit, i if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) call srch$$ (KREAD + KGETU, KCURR, 0, funit, typ, Errcod) if (Errcod ~= 0) return (ERR) vname (1) = 0 for (i = 1; vname (1) == 0 && i < 33; i += 1) if (rt(rs (name ( (i + 1) / 2), 8 * rt (i, 1)), 8) == ' 'c) vname (1) = i - 1 call ent$rd (funit, vname, loc (entrdbuf), MAXDIRENTRY, Errcod) call srch$$ (KCLOS, 0, 0, funit, typ, typ) if (Errcod ~= 0) return (ERR) } # do_type --- interpret the type of the file object procedure do_type { local action, type, special integer action, type, special if (rs (ecw, 8) == 3) call ctoc ("acat"s, infobuf, 7) else { type = and (8, typebits) special = and (8r10000, typebits) if (special ~= 0) { if (type == 4) call ctoc ("mfd"s, infobuf, 7) elif (nameq$ (fname, 32, "BOOT", 4)) call ctoc ("boot"s, infobuf, 7) elif (nameq$ (fname, 32, "BADSPT", 6)) call ctoc ("badspt"s, infobuf, 7) else call ctoc ("dskrat"s, infobuf, 7) } else { select (type) when (0) call ctoc ("sam"s, infobuf, 7) when (1) call ctoc ("dam"s, infobuf, 7) when (2) call ctoc ("sgs"s, infobuf, 7) when (3) call ctoc ("sgd"s, infobuf, 7) when (4) call ctoc ("ufd"s, infobuf, 7) else return (ERR) } } } # do_size --- determine the size of a file object procedure do_size { select (rt (typebits, 8)) when (0, 1) { # SAM or DAM file call srch$$ (KREAD + KGETU, name, 32, i, j, Errcod) if (Errcod ~= 0) return (ERR) fsize = szfil$ (i) call srch$$ (KCLOS, name, 32, i, j, j) if (fsize == ERR) return (ERR) call move$ (fsize, infobuf, 2) } when (2, 3) { # SAM directory or DAM directory call srch$$ (KREAD + KGETU, name, 32, i, j, Errcod) if (Errcod ~= 0) return (ERR) call szseg$ (fsize, i) call srch$$ (KCLOS, name, 32, i, j, j) if (fsize == ERR) return (ERR) call move$ (fsize, infobuf, 2) } when (4) { # UFD make_and_validate_tree call q$read (vtree, qbuf, 6, i, Errcod) if (Errcod ~= 0) return (ERR) call move$ (qbuf (1), auxil, 2) # words per disk record call move$ (qbuf (4), infobuf, 2) # total records used } else return (ERR) } # make_and_validate_tree --- make treename and see if it is valid procedure make_and_validate_tree { local i; integer i call mktr$ (pathname, junk) i = 1 call ctov (junk, i, vtree, 129) ### now see if it is a valid tree name if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) } # do_access --- determine the current access rights on a file object procedure do_access { local i; integer i string access_right_string "ADLPRUW" make_and_validate_tree i = 1 call ctov (auxil, i, junk (2), MAXPATH - 2) junk (1) = 2 junk (19) = 0 # return no group information call calac$ (vtree, loc (junk), "ALL"v, junk2, Errcod) if (Errcod ~= 0) return (ERR) call vtoc (junk2, junk, MAXLINE) if (equal (junk, "ALL"s) == YES) call ctoc ("$all"s, infobuf, 8) elif (equal (junk, "NONE"s) == YES) call ctoc ("$none"s, infobuf, 8) else { i = 1 for (j = 1; access_right_string (j) ~= EOS; j += 1) if (index (junk, access_right_string (j)) ~= 0) { infobuf (i) = mapdn (access_right_string (j)) i += 1 } infobuf (i) = EOS } } end #HD#: gfnam$.r 409 Nov-27-1984 01:11:11 # gfnam$ --- get pathname for an open file integer function gfnam$ (fd, path, size) filedes fd character path (ARB) integer size include SWT_COMMON filedes f filedes mapsu integer off, code, len, buf (MAXPATH) integer mkpa$, ctoc character name (MAXPATH) path (1) = EOS f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || Fd_flags (off) == 0) return (ERR) select (Fd_dev (off)) when (DEV_TTY) return (ctoc ("/dev/tty"s, path, size)) when (DEV_NULL) return (ctoc ("/dev/null"s, path, size)) when (DEV_DSK) { call gpath$ (KUNIT, Fd_unit (off), buf, MAXPATH, len, code) if (code == 0) { call ptoc (buf, EOS, name, min0 (size, len + 1)) return (mkpa$ (name, path, NO)) } path (1) = EOS return (ERR) } return (ERR) end #HD#: gfnarg.r 1244 Nov-27-1984 01:11:11 # gfnarg --- get the next file name from the argument list integer function gfnarg (name, state) character name (MAXPATH) integer state (4) integer l integer getarg, open, getlin string in1 "/dev/stdin1" string in2 "/dev/stdin2" string in3 "/dev/stdin3" procedure process_next_arg forward repeat { select (state (1)) when (1) { state (1) = 2 # new state state (2) = 1 # next argument state (3) = ERR # current input file state (4) = 0 # file argument count } when (2) { if (getarg (state (2), name, MAXARG) ~= EOF) { state (1) = 2 # stay in same state state (2) += 1 # bump argument count process_next_arg # may return on its own } else state (1) = 4 # EOF state } when (3) { l = getlin (name, state (3)) if (l ~= EOF) { name (l) = EOS return (OK) } if (state (3) > 0) call close (state (3)) state (1) = 2 } when (4) { state (1) = 5 if (state (4) == 0) {# no file arguments call scopy (in1, 1, name, 1) return (OK) } break } when (5) break else call error ("in gfnarg: bad state (1) value"p) } # end of infinite repeat name (1) = EOS return (EOF) procedure process_next_arg { select when (name (1) ~= '-'c) { state (4) += 1 # bump file argument count return (OK) } when (name (2) == EOS) { call scopy (in1, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == '1'c && name (3) == EOS) { call scopy (in1, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == '2'c && name (3) == EOS) { call scopy (in2, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == '3'c && name (3) == EOS) { call scopy (in3, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == 'n'c || name (2) == 'N'c) { state (1) = 3 # new state state (4) += 1 # bump file argument count select when (name (3) == EOS) state (3) = STDIN1 when (name (3) == '1'c && name (4) == EOS) state (3) = STDIN1 when (name (3) == '2'c && name (4) == EOS) state (3) = STDIN2 when (name (3) == '3'c && name (4) == EOS) state (3) = STDIN3 else { state (3) = open (name (3), READ) if (state (3) == ERR) { call print (ERROUT, "*s: can't open*n"p, name) state (1) = 2 } } } else return (ERR) } end #HD#: gitoc.r 740 Nov-27-1984 01:11:11 # gitoc --- convert single precision integer to any radix string integer function gitoc (int, str, size, base) integer int, size, base character str (size) integer n integer carry, d, i, radix bool unsigned string digits "0123456789ABCDEF" str (1) = EOS # digit string is generated backwards, then reversed if (size <= 1) return (0) radix = iabs (base) # get actual conversion radix if (radix < 2 || radix > 16) radix = 10 unsigned = (base < 0) # negative radices mean unsigned conversion if (unsigned) { n = rs (int, 1) # make pos. but keep high-order bits intact carry = and (int, 1) # get initial carry } else n = int i = 1 repeat { d = iabs (mod (n, radix)) # generate next digit if (unsigned) { # this is only half of actual digit value d = 2 * d + carry # get actual digit value if (d >= radix) { # check for generated carry d -= radix carry = 1 } else carry = 0 } i += 1 str (i) = digits (d + 1) # convert to character and store n /= radix } until (n == 0 || i >= size) if (unsigned) { if (carry ~= 0 && i < size) { # check for final carry i += 1 str (i) = '1'c } } elif (int < 0 && i < size) { # add sign if needed i += 1 str (i) = '-'c } gitoc = i - 1 # will return length of string for (d = 1; d < i; {d += 1; i -= 1}) { # reverse digits carry = str (d) str (d) = str (i) str (i) = carry } return end #HD#: gklarg.r 190 Nov-27-1984 01:11:11 # gklarg --- parse a single key-letter argument integer function gklarg (args, str) integer args (26) character str (ARB) integer i, k integer mapdn if (str (1) ~= '-'c) return (ERR) for (i = 2; str (i) ~= EOS; i += 1) { k = mapdn (str (i)) - 'a'c + 1 if (k < 1 || k > 26 || args (k) < 0) return (ERR) args (k) = 1 } return (OK) end #HD#: gltoc.r 745 Nov-27-1984 01:11:12 # gltoc --- convert double precision integer to any radix string integer function gltoc (int, str, size, base) longint int integer size, base character str (size) longint n integer carry, d, i, radix bool unsigned string digits "0123456789ABCDEF" str (1) = EOS # digit string is generated backwards, then reversed if (size <= 1) return (0) radix = iabs (base) # get actual conversion radix if (radix < 2 || radix > 16) radix = 10 unsigned = (base < 0) # negative radices mean unsigned conversion if (unsigned) { n = rs (int, 1) # make pos. but keep high-order bits intact carry = and (int, 1) # get initial carry } else n = int i = 1 repeat { d = iabs (mod (n, radix)) # generate next digit if (unsigned) { # this is only half of actual digit value d = 2 * d + carry # get actual digit value if (d >= radix) { # check for generated carry d -= radix carry = 1 } else carry = 0 } i += 1 str (i) = digits (d + 1) # convert to character and store n /= radix } until (n == 0 || i >= size) if (unsigned) { if (carry ~= 0 && i < size) { # check for final carry i += 1 str (i) = '1'c } } elif (int < 0 && i < size) { # add sign if needed i += 1 str (i) = '-'c } gltoc = i - 1 # will return length of string for (d = 1; d < i; {d += 1; i -= 1}) { # reverse digits carry = str (d) str (d) = str (i) str (i) = carry } return end #HD#: gtacl$.r 1073 Nov-27-1984 01:11:12 # gtacl$ --- get acl protection for a pathname into ACL common block integer function gtacl$ (path, key, attach_sw) character path (ARB) integer key, attach_sw include SWT_COMMON include ACL_COMMON integer indx, i, j character treen (MAXTREE), temp (MAXTREE) integer name (MAXPACKEDFNAME), pass(3) character vtree (MAXVARYFNAME), temptree (129) integer mktr$, equal, getto call mktr$ (path, treen) attach_sw = NO Acl_version = 2 Acl_count = 0 if (path (1) == EOS) return (OK) if (getto (path, name, pass, attach_sw) == ERR) return (ERR) i = 1 call ptov (name, ' 'c, vtree, MAXVARYFNAME) if (key == 1) call ac$lst (vtree, loc (Primos_acl), 32, temptree, Acl_type, Errcod) elif (key == 2) { call pa$lst (vtree, loc (Primos_acl), 32, Errcod) temptree (1) = 0 # zero-length varying string } else Errcod = EBKEY if (attach_sw == YES) call follow(EOS, 0) if (Errcod ~= 0) return (ERR) if (Acl_version > 2 | Acl_version < 1) { Errcod = EBVER return (ERR) } call vtoc (temptree, treen, MAXTREE) call mapstr (treen, LOWER) call mkpa$ (treen, Acl_name, NO) for (j = 1; j <= Acl_count; j += 1) { call vtoc (Acl_pairs (1, j), temp, MAXLINE) call mapstr (temp, LOWER) indx = 1 while (temp (indx) ~= ':'c) { if (temp (indx) ~= ' 'c) Acl_user (indx, j) = temp (indx) indx += 1 } Acl_user (indx, j) = EOS indx += 1 SKIPBL (temp, indx) if (equal (temp (indx), "all"s) == YES) Acl_mode (j) = ACL_ALL elif (equal (temp (indx), "none"s) == YES) Acl_mode (j) = ACL_NONE else { Acl_mode (j) = ACL_NONE while (temp (indx) ~= EOS) { select (temp (indx)) when ('a'c) Acl_mode (j) |= ACL_ADD when ('d'c) Acl_mode (j) |= ACL_DELETE when ('l'c) Acl_mode (j) |= ACL_LIST when ('p'c) Acl_mode (j) |= ACL_PROTECT when ('r'c) Acl_mode (j) |= ACL_READ when ('u'c) Acl_mode (j) |= ACL_USE when ('w'c) Acl_mode (j) |= ACL_WRITE else { Errcod = EBACL return (ERR) } indx += 1 } # end while } # end else } # end for return (OK) end #HD#: gtattr.r 110 Nov-27-1984 01:11:12 # gtattr --- get user's terminal attributes integer function gtattr (attr) integer attr include SWT_COMMON if (0 < attr && attr <= MAXTERMATTR) return (Term_attr (attr)) else return (NO) end #HD#: gtemp.r 384 Nov-27-1984 01:11:12 # gtemp --- parse a template and its definition integer function gtemp (str, nm, repl) character str (ARB), nm (MAXARG), repl (MAXARG) integer i, j, l l = 1 # throw away comments while (str (l) ~= EOS && str (l) ~= '#'c && str (l) ~= NEWLINE) l += 1 repeat l -= 1 # strip trailing blanks until (l <= 0 || str (l) ~= ' 'c) if (l <= 0) # this is a blank line return (EOF) l += 1 # remember where end of text is i = 1 SKIPBL (str, i) # grab the name for (j = 1; j < MAXARG && i < l && str (i) ~= ' 'c; {j += 1; i += 1}) nm (j) = str (i) nm (j) = EOS SKIPBL (str, i) # grab the replacement value for (j = 1; j < MAXARG && i < l; {j += 1; i += 1}) repl (j) = str (i) repl (j) = EOS return (OK) end #HD#: gttype.r 136 Nov-27-1984 01:11:12 # gttype --- get the string for the user's terminal type integer function gttype (str) character str (ARB) integer ttyp$f, ttyp$r, ttyp$q if ((ttyp$r (str) == NO || str (1) == EOS) && ttyp$f (str) == NO) return (ttyp$q (str, NO)) return (YES) end #HD#: gvlarg.r 392 Nov-27-1984 01:11:12 # gvlarg --- obtain the value of a key-letter argument integer function gvlarg (str, state) character str (ARB) integer state (4) integer getarg repeat { select (state (1)) when (1) { state (1) = 2 # new state state (2) = 1 # next argument state (3) = ERR # current input file state (4) = 0 # input file count } when (2) { if (getarg (state (2), str, MAXARG) ~= EOF) { state (1) = 2 # stay in same state if (str (1) == "-"c) str (1) = EOS else state (2) += 1 return (OK) } state (1) = 4 # EOF state } when (3) { str (1) = EOS return (OK) } when (4, 5) break else call error ("in gvlarg: bad state (1) value*n"p) } # end of infinite repeat str (1) = EOS return (EOF) end #HD#: icomn$.r 218 Nov-27-1984 01:11:13 # icomn$ --- initialize Subsystem common areas subroutine icomn$ include SWT_COMMON integer i Arg_c = 0 Cmdstat = 0 Errcod = 0 Comunit = 0 Passwd (1) = EOS Ls_top = MAXLSBUF - 1 Ls_na = 1 Ls_ho = 1 Ls_ref (1) = EOS Utemptop = 0 do i = 1, MAXTEMPHASH Uhashtb (i) = LAMBDA do i = 1, 4; { Rtlabel (i) = 0 Bplabel (i) = 0 } call ioinit # initialize I/O routines return end #HD#: index.s 391 Nov-27-1984 01:11:13 * index --- find character c in string str * * integer function index (str, c) * character c, str (ARB) * * for (index = 1; str (index) ~= EOS; index += 1) * if (str (index) == c) * return * index = 0 * return * end SUBR INDEX SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK INDEX ECB INDEX$,,STR,2 DATA 5,C'INDEX' PROC DYNM =20,STR(3),C(3) INDEX$ ARGT ENTR INDEX EAXB STR,* XB := STR LDX =0 X := 0 LOOP LDA XB%+0,X if (XB+X)^ = C then CAS =EOS if (XB+X)^ = EOS then JMP *+2 go to NE JMP NE CAS C,* if (XB+X)^ = C then JMP *+2 go to EQ JMP EQ BIX LOOP X := X + 1; goto LOOP EQ TXA return X + 1 A1A PRTN NE CRA return 0 PRTN END #HD#: init$f.r 208 Nov-27-1984 01:11:13 # init$f --- force the Fortran IOCS to understand the Subsystem subroutine init$f integer f integer mapfd, mapsu call flush$ (mapsu (STDIN)) call flush$ (mapsu (STDOUT)) f = mapfd (STDIN) if (f > 0) call attdev (5, 7, f, 128) else call attdev (5, 1, 0, 128) f = mapfd (STDOUT) if (f > 0) call attdev (6, 7, f, 128) else call attdev (6, 1, 0, 128) return end #HD#: init$p.r 590 Nov-27-1984 01:11:13 # init$p --- initialize the Pascal INPUT and OUTPUT files subroutine init$p integer f, i, path (MAXPATH), tree (MAXPATH) integer mapfd, mapsu, gfnam$ integer iflag, i1, i2, i3, i4, i5, iunit, i6, i7, i8 integer ifnam (64), i9, ibuf (128) common /p$ainp/ iflag, i1, i2, i3, i4, i5, iunit, i6, i7, i8, ifnam, i9, ibuf integer oflag, o1, o2, o3, o4, o5, ounit, o6, o7, o8 integer ofnam (64), o9, obuf (128) common /p$aout/ oflag, o1, o2, o3, o4, o5, ounit, o6, o7, o8, ofnam, o9, obuf call flush$ (mapsu (STDIN)) call flush$ (mapsu (STDOUT)) f = mapfd (STDIN) if (f > 0) { call attdev (f, 7, f, 128) iflag &= not (:1000) iunit = f i = 1 if (gfnam$ (STDIN, path, MAXPATH) ~= ERR) { call mktr$ (path, tree) call ctop (tree, i, ifnam, 64) } else call ctop ("pathname unobtainable"s, i, ifnam, 64) } f = mapfd (STDOUT) if (f > 0) { call attdev (f, 7, f, 128) oflag &= not (:1000) ounit = f i = 1 if (gfnam$ (STDOUT, path, MAXPATH) ~= ERR) { call mktr$ (path, tree) call ctop (tree, i, ofnam, 64) } else call ctop ("pathname unobtainable"s, i, ofnam, 64) } return end #HD#: init$plg.plg 334 Nov-27-1984 01:11:13 /* init$plg --- initialize a PL/I G program under the Subsystem */ init$plg: procedure; declare (sysin, sysprint) file; declare mapfd entry (fixed) returns (fixed), mapsu entry (fixed) returns (fixed), flush$ entry (fixed); declare fd fixed; call flush$ (mapsu (-10)); call flush$ (mapsu (-11)); fd = mapfd (-10); if fd > 0 then open file (sysin) stream input title (' -funit ' || fd); else open file (sysin) stream input title ('@tty'); fd = mapfd (-11); if fd > 0 then open file (sysprint) stream output title (' -funit ' || fd); else open file (sysprint) stream output title ('@tty'); end init$plg; #HD#: init.r 113 Nov-27-1984 01:11:13 # init --- initialization subroutine for Software Tools Subsystem subroutine init call remark ("You are trying to run a pre-version 9 compilation."p) call error ("Please recompile and try again."p) return end #HD#: input.r 610 Nov-27-1984 01:11:14 # input --- semi-formatted input routine integer function input (fd, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) file_des fd character fmt (ARB) integer a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB) integer ap, sp, fp, i integer getlin, decode, index, isatty file_des tf character str (MAXDECODE), tfmt (MAXDECODE) logical psw if (and (fmt (1), :177400) ~= 0) call ptoc (fmt, '.'c, tfmt, MAXDECODE) else call ctoc (fmt, tfmt, MAXDECODE) fp = 1 ap = 1 psw = (isatty (fd) ~= NO) tf = fd repeat { while (tfmt (fp) ~= FORMATFLAG) { if (psw) call putch (tfmt (fp), TTY) fp += 1 } if (tfmt (fp) == EOS) break if (getlin (str, tf, MAXDECODE) == EOF) return (EOF) sp = 1 select (decode (str, sp, tfmt, fp, ap, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)) when (OK) # there's more format left tf = fd when (EOF) # end of format break when (ERR) { # error in field i = index (str (sp), NEWLINE) # print only to first NEWLINE if (i ~= 0) str (sp + i - 1) = EOS call print (TTY, "Error: '*s' retype: "s, str (sp)) tf = TTY } } return (ap - 1) end #HD#: iofl$.r 254 Nov-27-1984 01:11:14 # iofl$ --- initialize open file list subroutine iofl$ (state) integer state (MAXFILESTATE) include SWT_COMMON integer fd, sp integer junk2, code longint junk1 sp = 1 do fd = 1, NFILES if (Fd_flags (fd_offset (fd)) == 0) { state (sp) = fd sp += 1 } state (sp) = ERR sp += 1 do fd = 1, 128; { call prwf$$ (KRPOS, fd, intl (0), 0, junk1, junk2, code) if (code ~= 0 && code ~= EBUNT) { state (sp) = fd sp += 1 } } state (sp) = ERR return end #HD#: ioinit.r 555 Nov-27-1984 01:11:14 # ioinit --- initialize Subsystem I/O areas subroutine ioinit include SWT_COMMON integer fd, i integer duplx$ character default_kresp (4) data default_kresp / '\'c, '\'c, NEWLINE, EOS / ### Initialize all file descriptors to the closed state: do fd = 1, NFILES Fd_flags (fd_offset (fd)) = 0 ### Initialize file descriptor 1 for terminal i/o: Fd_dev (TTY) = DEV_TTY Fd_unit (TTY) = 0 Fd_bufstart (TTY) = 0 Fd_buflen (TTY) = 0 Fd_bufend (TTY) = 0 Fd_count (TTY) = 0 Fd_bcount (TTY) = 0 Fd_flags (TTY) = FD_READ + FD_WRITE Fd_lastfd = 1 ### Set up term buffer and attributes: Echar = BS Kchar = DEL Rtchar = DC2 Escchar = ESC Eofchar = ETX Nlchar = NEWLINE call ctoc (default_kresp, Kill_resp, MAXKILLRESP) Term_cp = 1 Term_buf (Term_cp) = EOS Term_count = 0 do i = 1, MAXTERMATTR Term_attr (i) = NO Lword = duplx$ (-1) # record the terminal configuration Prt_form (1) = EOS Prt_dest (1) = EOS ### Set up initial standard port map: do fd = 1, MAX_STD_PORTS Std_port_tbl (fd) = TTY return end #HD#: isadsk.r 138 Nov-27-1984 01:11:14 # isadsk --- determine if a file descriptor refers to a terminal integer function isadsk (fd) file_des fd include SWT_COMMON integer f filedes mapsu f = fd_offset (mapsu (fd)) if (Fd_dev (f) == DEV_DSK) return (YES) else return (NO) end #HD#: isatty.r 138 Nov-27-1984 01:11:14 # isatty --- determine if a file descriptor refers to a terminal integer function isatty (fd) file_des fd include SWT_COMMON integer f filedes mapsu f = fd_offset (mapsu (fd)) if (Fd_dev (f) == DEV_TTY) return (YES) else return (NO) end #HD#: isnull.r 141 Nov-27-1984 01:11:14 # isnull --- determine if a file descriptor refers to the bit bucket integer function isnull (fd) file_des fd include SWT_COMMON integer f filedes mapsu f = fd_offset (mapsu (fd)) if (Fd_dev (f) == DEV_NULL) return (YES) else return (NO) end #HD#: isph$.r 78 Nov-27-1984 01:11:15 # isph$ --- return whether we are a phantom or not integer function isph$(dummy) integer dummy include SWT_COMMON return (Isphantom) end #HD#: itoc.r 320 Nov-27-1984 01:11:15 # itoc --- convert single precision integer to decimal string integer function itoc (int, str, size) integer int, size character str (size) integer intval integer d, i, j, k string digits "0123456789" intval = int str (1) = EOS i = 1 repeat { # generate digits i += 1 d = iabs (mod (intval, 10)) str (i) = digits (d + 1) intval /= 10 } until (intval == 0 || i >= size) if (int < 0 && i < size) { # then sign i += 1 str (i) = '-'c } itoc = i - 1 for (j = 1; j < i; j += 1) { # then reverse k = str (i) str (i) = str (j) str (j) = k i -= 1 } return end #HD#: jdate.r 215 Nov-27-1984 01:11:15 # jdate --- take month, day, and year and return day-of-year integer function jdate (m, d, y) integer m, d, y integer i, mdays (12) data mdays /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ jdate = d for (i = 1; i < m; i += 1) jdate += mdays (i) if (m > 2) { if (mod (y, 400) == 0) jdate += 1 else if (mod (y, 100) == 0) ; else if (mod (y, 4) == 0) jdate += 1 } return end #HD#: ldseg$.r 2148 Nov-27-1984 01:11:15 # ldseg$ --- load a segmented runfile into memory subroutine ldseg$ (rvec, name, len, code) integer rvec (9), name (ARB), len, code define (DB,#) integer symtab (1) common /sgsymt/ symtab integer bit, dfd, i, junk, n, rc, rev, sfd, wrd, addr (2), masks (16), segmap (512), sthead (21), svec (10), tvec (30) integer symtab_size integer chunk$ pointer p, q data masks / :100000, :040000, :020000, :010000, :004000, :002000, :001000, :000400, :000200, :000100, :000040, :000020, :000010, :000004, :000002, :000001 / procedure open_directory forward procedure return_error forward open_directory ### read and check the revision flag: call prwf$$ (KREAD, dfd, loc (rev), 1, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading rev", 11, "ldseg$", 6) if (rc ~= 0 || rev ~= -1) return_error ### read the size of the segment map: call prwf$$ (KREAD, dfd, loc (n), 1, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading n", 9, "ldseg$", 6) if (rc ~= 0 || n > 256) return_error ### read the segment bit map: call prwf$$ (KREAD, dfd, loc (segmap), n * 2, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading segmap", 14, "ldseg$", 6) if (rc ~= 0) return_error ### read the save vector: call prwf$$ (KREAD, dfd, loc (svec), 10, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading svec", 12, "ldseg$", 6) if (rc ~= 0) return_error ### read the time vector: call prwf$$ (KREAD, dfd, loc (tvec), 30, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading tvec", 12, "ldseg$", 6) if (rc ~= 0 || tvec (10) < 6) # we don't support old revs # tvec (10) == 6 == Rev 17 # tvec (10) == 7 == Rev 18 return_error ### check for compatiblity if (tvec (10) < 7) symtab_size = svec (9) else symtab_size = svec (10) ### read the symbol table: call prwf$$ (KREAD, dfd, loc (symtab), symtab_size, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading symtab", 14, "ldseg$", 6) if (rc ~= 0) return_error ### read the symbol table list head vector: call prwf$$ (KREAD, dfd, loc (sthead), 21, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading sthead", 14, "ldseg$", 6) if (rc ~= 0) return_error for (p = sthead (18); p ~= NULL; p = symtab (q + SG_CHAIN)) { q = symtab_size - (p * SG_NODESIZE) + 1 DB call print (TTY, "Examining symbol number *i at *i*n"p, DB p, q) DB call print (TTY, " *7,-8u*i*i*i*i*i*i*i*i*i*1n"p, DB symtab (q + 0), symtab (q + 1), symtab (q + 2), symtab (q + 3), DB symtab (q + 4), symtab (q + 5), symtab (q + 6), symtab (q + 7), DB symtab (q + 8)) if (symtab (q + SG_SEGNUM) <= 8r4000 # ignore shared segments || symtab (q + SG_FLAGS) >= 0) # segment is empty next call zmem$ (symtab (q)) # clear uninitialized areas n = and (symtab (q + SG_FLAGS), 8r777) * 32 addr (1) = symtab (q + SG_SEGNUM) addr (2) = 0 do i = 1, 32; { # each segment is divided into 32 2K chunks bit = rt (n, 4) wrd = rs (n, 4) if (and (segmap (wrd + 1), masks (bit + 1)) ~= 0) { DB call print (TTY, " loading chunk *i at *a*n"p, n, addr) if (chunk$ (addr, n, sfd) == ERR) return_error } n += 1 addr (2) += 8r4000 } } call srch$$ (KCLOS, 0, 0, dfd, 0, rc) call srch$$ (KCLOS, 0, 0, sfd, 0, rc) rvec (4) = svec (5) # initial A register setting rvec (5) = svec (6) # initial B register setting rvec (6) = svec (7) # initial X register setting rvec (7) = 0 # initial KEYS rvec (8) = svec (1) # address of ECB for main program rvec (9) = svec (2) code = 0 return # open_directory --- open the runfile and subfile 0 procedure open_directory { call srch$$ (KREAD + KGETU, name, len, sfd, junk, code) DB call errpr$ (KIRTN, code, "opening segdir", 14, "ldseg$", 6) if (code ~= 0) return call srch$$ (KREAD + KGETU + KISEG, sfd, 0, dfd, junk, code) DB call errpr$ (KIRTN, code, "opening seg 0", 13, "ldseg$", 6) if (code ~= 0) { call srch$$ (KCLOS, 0, 0, sfd, 0, junk) return } } # return_error --- clean up and return error status procedure return_error { call srch$$ (KCLOS, 0, 0, dfd, 0, rc) call srch$$ (KCLOS, 0, 0, sfd, 0, rc) code = EBPAR return } undefine (DB) end #HD#: ldtmp$.r 650 Nov-27-1984 01:11:15 # ldtmp$ --- load the per-user template area subroutine ldtmp$ include SWT_COMMON filedes fd filedes open integer i integer getlin, gtemp character str (MAXLINE), nm (MAXARG), repl (MAXARG) procedure add_entry forward define (out,1) call break$ (DISABLE) do i = 1, MAXTEMPHASH Uhashtb (i) = LAMBDA Utemptop = 0 fd = open ("=utemplate="s, READ) if (fd == ERR) { call break$ (ENABLE) return } while (getlin (str, fd) ~= EOF) if (gtemp (str, nm, repl) ~= EOF) add_entry # Add the entry to the table out; call close (fd) call break$ (ENABLE) return # add_entry --- add an entry to the template table procedure add_entry { local h, i, p, q, need integer h, i, p, q, need integer scopy, length need = length (nm) + length (repl) + 4 if (Utemptop + need > MAXTEMPBUF) { call print (ERROUT, "*s: too many user templates*n"s, nm) call seterr (1000) goto out } h = 0 for (i = 1; i <= 4 && nm (i) ~= EOS; i += 1) h += nm (i) h = mod (h, MAXTEMPHASH) + 1 p = Utemptop + 1 Utempbuf (p) = Uhashtb (h) Uhashtb (h) = p q = p + 2 + scopy (nm, 1, Utempbuf, p + 2) + 1 Utempbuf (p + 1) = q Utemptop = q + scopy (repl, 1, Utempbuf, q) } undefine (out) end #HD#: length.s 262 Nov-27-1984 01:11:15 * length --- returns length of a string * * integer function length (str) * character str (ARB) SUBR LENGTH SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK LENGTH ECB LENGTH$,,STR,1 DATA 6,C'LENGTH' PROC DYNM =20,STR(3) LENGTH$ ARGT ENTR LENGTH EAXB STR,* XB := STR LDX =0 X := 0 LDA =EOS LOOP CAS XB%,X if (XB+X)^ = EOS then JMP *+2 goto OUT JMP OUT BIX LOOP X := X + 1; goto LOOP OUT TXA return X PRTN END #HD#: locate.r 166 Nov-27-1984 01:11:16 # locate --- look for c in char class at pat (offset) integer function locate (c, pat, offset) character c, pat (MAXPAT) integer offset integer i # size of class is at pat (offset), characters follow for (i = offset + pat (offset); i > offset; i -= 1) if (c == pat (i)) return (YES) return (NO) end #HD#: lookac.r 145 Nov-27-1984 01:11:16 # lookac --- look up a name in the 'acl' common block integer function lookac (name) character name (ARB) include ACL_COMMON integer i integer equal for (i = 1; i <= Acl_count; i += 1) if (equal (Acl_user (1, i), name) == YES) return (i) return (ERR) end #HD#: lookup.r 247 Nov-27-1984 01:11:16 # lookup --- find a symbol in the symbol table, return its data integer function lookup (symbol, info, st) character symbol (ARB) integer info (ARB) pointer st integer Mem (1) common /ds$mem/ Mem integer i, nodesize integer st$lu pointer node, pred if (st$lu (symbol, node, pred, st) == NO) { lookup = NO return } nodesize = Mem (st) for (i = 1; i <= nodesize; i += 1) info (i) = Mem (node + ST_DATA - 1 + i) lookup = YES return end #HD#: lopen$.r 1894 Nov-27-1984 01:11:16 # lopen$ --- open a disk file in the spool queue filedes function lopen$ (path, fd, mode) character path (ARB) filedes fd integer mode include SWT_COMMON integer unit1, unit2, unit3, i, j, pp, bl, offset integer junk (3), info (29), banner (16), buf (100) integer mapdn, ctoi, ctop, parstm, mapup longint t character str (MAXPATH) procedure check forward procedure getstr forward unit1 = 0; unit2 = 0; unit3 = 0 info (3) = RAW do i = 4, 29 info (i) = " " i = 1 bl = ctop ("/DEV/LPS"s, i, banner, 16) # Parse the arguments for (pp = 1; path (pp) ~= EOS; pp += 1) select (mapdn (path (pp))) when ('/'c, '-'c, ' 'c) # argument separator ; when ('f'c) # Fortran forms control info (3) = or (and (info (3), not (LNR + RAW)), FTN) when ('r'c) # Raw forms control info (3) = or (and (info (3), not (LNR + FTN)), RAW) when ('s'c) # Standard forms control info (3) &= not (FTN + RAW) when ('h'c) # suppress header page info (3) |= NHD when ('j'c) # suppress trailing page eject info (3) |= NEJ when ('n'c) # generate line numbers info (3) |= LNR when ('a'c) { # specify destination printer info (3) |= ATL getstr j = 1 call ctop (str, j, info (13), 8) } when ('d'c) { # defer printing info (3) |= DEF getstr i = 1 if (parstm (str, i, t) == ERR) return (ERR) info (11) = ints (t / 60) } when ('b'c) { # specify banner getstr j = 1 bl = ctop (str, j, banner, 16) } when ('c'c) { # specify number of copies info (3) |= COP getstr i = 1 info (29) = ctoi (str, i) } when ('p'c) { # specify form type getstr j = 1 call ctop (str, j, info (4), 3) } else return (ERR) if (Prt_dest (1) ~= EOS && info (13) == " ") { info (3) |= ATL call ctoc (Prt_dest, str, MAXLINE) call mapstr (str, UPPER) j = 1 call ctop (str, j, info (13), 8) } if (Prt_form (1) ~= EOS && info (4) == " ") { call ctoc (Prt_form, str, MAXLINE) call mapstr (str, UPPER) j = 1 call ctop (str, j, info (4), 3) } # Open the current directory three times for reading to get three units # (we throw away the first unit because 'spool$' uses K$GETU # before using the units we are supplying!!) call srch$$ (KREAD + KGETU, KCURR, 32, unit1, junk, Errcod); check call srch$$ (KREAD + KGETU, KCURR, 32, unit2, junk, Errcod); check call srch$$ (KREAD + KGETU, KCURR, 32, unit3, junk, Errcod); check call srch$$ (KCLOS, 0, 0, unit1, junk, Errcod) call srch$$ (KCLOS, 0, 0, unit2, junk, Errcod) call srch$$ (KCLOS, 0, 0, unit3, junk, Errcod) info (1) = unit2 info (2) = unit3 # Open the file in the queue (always opened read/write) call spool$ (2, banner, bl, info, buf, 100, Errcod) if (Errcod ~= 0) return (ERR) # And fill in the detail in the descriptor offset = fd_offset (fd) Fd_unit (offset) = unit3 Fd_flags (offset) |= FD_WRITE + FD_COMP # be sure file is writable if (and (info (3), RAW + NHD) == RAW) { # raw with header: call putch (FF, fd) # put in formfeed call putch (NEWLINE, fd) } return (fd) # check --- check for a Primos file system error procedure check { if (Errcod ~= 0) { if (unit1 ~= 0) call srch$$ (KCLOS, 0, 0, unit1, junk, junk) if (unit2 ~= 0) call srch$$ (KCLOS, 0, 0, unit2, junk, junk) return (ERR) } } # getstr --- grab a string from the input path procedure getstr { local i integer i while (path (pp + 1) == '/'c || path (pp + 1) == ' 'c) pp += 1 for (i = 1; path (pp + 1) ~= EOS && path (pp + 1) ~= '/'c && path (pp + 1) ~= ' 'c; {pp += 1; i += 1}) str (i) = mapup (path (pp + 1)) str (i) = EOS } end #HD#: ltoc.r 325 Nov-27-1984 01:11:16 # ltoc --- convert double precision integer to decimal string integer function ltoc (int, str, size) longint int integer size character str (size) longint intval integer d, i, j, k string digits "0123456789" intval = int str (1) = EOS i = 1 repeat { # generate digits i += 1 d = iabs (mod (intval, 10)) str (i) = digits (d + 1) intval /= 10 } until (intval == 0 || i >= size) if (int < 0 && i < size) { # then sign i += 1 str (i) = '-'c } ltoc = i - 1 for (j = 1; j < i; j += 1) { # then reverse k = str (i) str (i) = str (j) str (j) = k i -= 1 } return end #HD#: lutemp.r 1051 Nov-27-1984 01:11:17 # lutemp --- look up a template in the template directory integer function lutemp (jig, str, strlen) character jig (ARB), str (ARB) integer strlen include "=incl=/temp_com.r.i" include PRIMOS_KEYS include SWT_COMMON integer h, p, i, l, code integer scopy, equal, mod, length character tbuf (MAXPATH), dirname(MAXTREE) for (i = 1; jig (i) ~= EOS; i += 1) tbuf (i) = jig (i) tbuf (i) = EOS h = 0 for (i = 1; i <= 4 && jig (i) ~= EOS; i += 1) h += tbuf (i) h = mod (h, MAXTEMPHASH) + 1 for (p = Uhashtb (h); p ~= LAMBDA; p = Utempbuf (p)) if (equal (tbuf, Utempbuf (p + 2)) == YES) break if (p ~= LAMBDA) { l = scopy (Utempbuf, Utempbuf (p + 1), tbuf, 1) if (l >= strlen) return (EOF) return (scopy (tbuf, 1, str, 1)) } for (p = Hashtb (h); p ~= LAMBDA; p = Tempbuf (p)) if (equal (tbuf, Tempbuf (p + 2)) == YES) break if (p == LAMBDA) return (EOF) select (- Tempbuf (p + 1)) when (TEMP_DATE) { # date call date (SYS_DATE, tbuf) tbuf (3) = tbuf (4); tbuf (4) = tbuf (5) tbuf (5) = tbuf (7); tbuf (6) = tbuf (8) tbuf (7) = EOS l = 6 } when (TEMP_TIME) { # time call date (SYS_TIME, tbuf) tbuf (3) = tbuf (4); tbuf (4) = tbuf (5) tbuf (5) = tbuf (7); tbuf (6) = tbuf (8) tbuf (7) = EOS l = 6 } when (TEMP_USER) { # user call date (SYS_USERID, tbuf) l = length (tbuf) while (l > 0 && tbuf (l) == ' 'c) l -= 1 tbuf (l + 1) = EOS call mapstr (tbuf, LOWER) } when (TEMP_PID) { # pid call date (SYS_PIDSTR, tbuf) l = length (tbuf) } when (TEMP_PASSWD) { # passwd l = scopy (Passwd, 1, tbuf, 1) } when (TEMP_DAY) { # day call date (SYS_DAY, tbuf) l = length (tbuf) } when (TEMP_HOME) { # home call gpath$(KINIA, 0, tbuf, MAXPATH, i, code) if (code ~= 0) return(EOF) call ptoc(tbuf, EOS, dirname, i + 1) call mkpa$(dirname, tbuf, NO) l = mapstr(tbuf, LOWER) } else l = scopy (Tempbuf, Tempbuf (p + 1), tbuf, 1) if (l >= strlen) return (EOF) return (scopy (tbuf, 1, str, 1)) end #HD#: makpat.r 927 Nov-27-1984 01:11:17 # makpat --- make pattern from arg (from), terminate at delim integer function makpat (arg, from, delim, pat) character arg (MAXARG), delim, pat (MAXPAT) integer from character esc integer addset, getccl, stclos integer i, j, junk, lastcl, lastj, lj, tag_nest, tag_num, tag_stack (9) j = 1 # pat index lastj = 1 lastcl = 0 tag_num = 0 tag_nest = 0 for (i = from; arg (i) ~= delim && arg (i) ~= EOS; i += 1) { lj = j if (arg (i) == PAT_ANY) junk = addset (PAT_ANY, pat, j, MAXPAT) else if (arg (i) == PAT_BOL && i == from) junk = addset (PAT_BOL, pat, j, MAXPAT) else if (arg (i) == PAT_EOL && arg (i + 1) == delim) junk = addset (PAT_EOL, pat, j, MAXPAT) else if (arg (i) == PAT_CCL) { if (getccl (arg, i, pat, j) == ERR) { makpat = ERR return } } else if (arg (i) == PAT_CLOSURE && i > from) { lj = lastj if (pat (lj) == PAT_BOL || pat (lj) == PAT_EOL || pat (lj) == PAT_CLOSURE || pat (lj) == PAT_START_TAG || pat (lj) == PAT_STOP_TAG) break lastcl = stclos (pat, j, lastj, lastcl) } else if (arg (i) == PAT_START_TAG) { if (tag_num >= 9) # too many tagged sub-patterns break tag_num += 1 tag_nest += 1 tag_stack (tag_nest) = tag_num junk = addset (PAT_START_TAG, pat, j, MAXPAT) junk = addset (tag_num, pat, j, MAXPAT) } else if (arg (i) == PAT_STOP_TAG && tag_nest > 0) { junk = addset (PAT_STOP_TAG, pat, j, MAXPAT) junk = addset (tag_stack (tag_nest), pat, j, MAXPAT) tag_nest -= 1 } else { junk = addset (PAT_CHAR, pat, j, MAXPAT) junk = addset (esc (arg, i), pat, j, MAXPAT) } lastj = lj } if (arg (i) ~= delim) # terminated early makpat = ERR else if (addset (EOS, pat, j, MAXPAT) == NO) # no room makpat = ERR else if (tag_nest ~= 0) makpat = ERR else makpat = i return end #HD#: maksub.r 416 Nov-27-1984 01:11:17 # maksub --- make substitution string in sub integer function maksub (arg, from, delim, sub) character arg (ARB), delim, sub (MAXPAT) integer from character esc, type integer addset integer i, j, junk j = 1 for (i = from; arg (i) ~= delim && arg (i) ~= EOS; i += 1) if (arg (i) == PAT_AND) { junk = addset (PAT_DITTO, sub, j, MAXPAT) junk = addset (0 + PAT_MARK, sub, j, MAXPAT) } else if (arg (i) == ESCAPE && type (arg (i + 1)) == DIGIT) { i += 1 junk = addset (PAT_DITTO, sub, j, MAXPAT) junk = addset (arg (i) - '0'c + PAT_MARK, sub, j, MAXPAT) } else junk = addset (esc (arg, i), sub, j, MAXPAT) if (arg (i) ~= delim) # missing delimiter maksub = ERR else if (addset (EOS, sub, j, MAXPAT) == NO) # no room maksub = ERR else maksub = i return end #HD#: mapdn.r 89 Nov-27-1984 01:11:17 # mapdn --- fold characters to lower case character function mapdn (c) character c if (IS_UPPER (c)) mapdn = c - 'A'c + 'a'c else mapdn = c return end #HD#: mapfd.r 163 Nov-27-1984 01:11:17 # mapfd --- convert fd to Primos funit integer function mapfd (fd) filedes fd include SWT_COMMON integer off, f integer mapsu f = mapsu (fd) if (f < 1 || f > NFILES) return (ERR) off = fd_offset (f) if (Fd_dev (off) == DEV_DSK) return (Fd_unit (off)) else return (ERR) end #HD#: mapstr.r 217 Nov-27-1984 01:11:17 # mapstr --- map case of a K&P string integer function mapstr (str, case) character str (ARB) integer case integer i if (case == UPPER) { for (i = 1; str (i) ~= EOS; i += 1) if (IS_LOWER (str (i))) str (i) = str (i) - 'a'c + 'A'c } else { for (i = 1; str (i) ~= EOS; i += 1) if (IS_UPPER (str (i))) str (i) = str (i) - 'A'c + 'a'c } mapstr = i - 1 # return length of string return end #HD#: mapsu.r 312 Nov-27-1984 01:11:18 # mapsu --- map standard unit to file descriptor file_des function mapsu (std_unit) file_des std_unit include SWT_COMMON integer i mapsu = std_unit if (mapsu > 0) # this test added for execution speed return do i = 1, 10 select (mapsu) when (STDIN1) mapsu = Std_port_tbl (1) when (STDIN2) mapsu = Std_port_tbl (3) when (STDIN3) mapsu = Std_port_tbl (5) when (STDOUT1) mapsu = Std_port_tbl (2) when (STDOUT2) mapsu = Std_port_tbl (4) when (STDOUT3) mapsu = Std_port_tbl (6) else return return (TTY) # infinite definition -- send back TTY end #HD#: mapup.r 88 Nov-27-1984 01:11:18 # mapup --- fold characters to upper case character function mapup (c) character c if (IS_LOWER (c)) mapup = c - 'a'c + 'A'c else mapup = c return end #HD#: markf.r 292 Nov-27-1984 01:11:18 # markf --- read the position of a file filemark function markf (fd) filedes fd include SWT_COMMON integer f, off integer mapsu longint tmark$, dmark$ f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_ERR) ~= 0 || Fd_flags (off) == 0) return (ERR) if (LASTOP (off) ~= FD_INITIAL) { call flush$ (f) SET_LASTOP (off, FD_INITIAL) } select (Fd_dev (off)) when (DEV_TTY) return (tmark$ (off)) when (DEV_DSK) return (dmark$ (off)) when (DEV_NULL) return (0) return (ERR) end #HD#: match.r 140 Nov-27-1984 01:11:18 # match --- find match anywhere on line integer function match (lin, pat) character lin (ARB), pat (MAXPAT) integer amatch integer i, junk (9) for (i = 1; lin (i) ~= EOS; i += 1) if (amatch (lin, i, pat, junk, junk) > 0) return (YES) return (NO) end #HD#: mkdir$.r 357 Nov-27-1984 01:11:18 # mkdir$ --- create a subdirectory integer function mkdir$ (name, owner, non_owner) character name (ARB), owner (ARB), non_owner (ARB) integer newdir (16), opw (3), npw (3), attach, code, i, junk (3) integer getto, findf$, ctop mkdir$ = ERR do i = 1, 3; { opw (i) = " " npw (i) = " " } i = 1 if (ctop (owner, i, opw, 3) == 0) opw (1) = 0 i = 1 if (ctop (non_owner, i, npw, 3) == 0) npw (1) = 0 if (getto (name, newdir, junk, attach) ~= ERR && findf$ (newdir) == NO) { call crea$$ (newdir, 32, opw, npw, code) call satr$$ (KPROT, newdir, 32, 16r07010000, junk) if (code == 0) mkdir$ = OK } if (attach ~= NO) call at$hom (code) return end #HD#: mkfd$.r 409 Nov-27-1984 01:11:18 # mkfd$ --- make a Subsystem file from an already open Primos unit file_des function mkfd$ (unit, mode) integer unit, mode include SWT_COMMON filedes fd, getfd$ integer f # Find an empty descriptor if (getfd$ (fd) == ERR) return (ERR) f = fd_offset (fd) call break$ (DISABLE) # Initialize the descriptor Fd_dev (f) = DEV_DSK Fd_unit (f) = unit Fd_bufstart (f) = fd * BUFSIZE - BUFSIZE Fd_buflen (f) = BUFSIZE Fd_bufend (f) = 0 Fd_count (f) = 0 Fd_bcount (f) = 0 Fd_flags (f) = FD_OPENED + FD_COMP + FD_INITIAL select (and (mode, 16r3)) # in case there are extra bits when (READ) Fd_flags (f) |= FD_READ when (WRITE) Fd_flags (f) |= FD_WRITE when (READWRITE) Fd_flags (f) |= FD_READ + FD_WRITE call break$ (ENABLE) return (fd) end #HD#: mkpa$.r 969 Nov-27-1984 01:11:19 # mkpa$ --- convert a treename into a pathname integer function mkpa$ (tree, path, default) character path (ARB), tree (ARB) integer default # where default is YES or NO controlling the conversion # of a simple name to a file in the current # directory or a UFD name. # YES assumes conversion to a UFD name integer i, tp integer index character mapdn procedure copy_and_convert forward # # current state of conversions: # # DIR>SUBDIR>FILE converts to '/name/dir/subdir/file' # DIR>SUBDIR>FILE converts to '//dir/subdir/file' # *>SUBDIR>FILE converts to 'subdir/file' # SIMPLENAME converts to either # 'simplename' # or # '//simplename' # depending on argument default # i = 1 SKIPBL (tree, i) if (index (tree, '>'c) == 0) { # is it a simple name? if (default == YES) { call scopy ('//'s, 1, path, 1) # give default disk name tp = 3 # and copy rest after } else tp = 1 copy_and_convert return (tp - 1) } if (tree (i) == '<'c) tp = 1 else if (tree (i) == '*'c && tree (i + 1) == '>'c) { i += 2 tp = 1 } else { call scopy ('//'s, 1, path, 1) i = 1 tp = 3 } copy_and_convert return (tp - 1) # copy_and_convert --- copy tree body and convert to path procedure copy_and_convert { SKIPBL (tree, i) while (tree (i) ~= EOS) { select (tree (i)) when ('<'c) { SKIPBL (tree, i) path (tp) = '/'c } when ('>'c) { SKIPBL (tree, i) path (tp) = '/'c } when ('/'c) { path (tp) = ESCAPE path (tp + 1) = '/'c tp += 1 } when (' 'c) { SKIPBL (tree, i) if (tree (i) ~= EOS && tree (i) ~= '>'c) path (tp) = ':'c tp += 1 while (tree (i) ~= EOS && tree (i) ~= '>'c) { path (tp) = tree (i) tp += 1 i += 1 } } else path (tp) = mapdn (tree (i)) i += 1 tp += 1 } path (tp) = EOS } end #HD#: mkpacl.r 519 Nov-27-1984 01:11:19 # mkpacl --- encode SWT ACL info into Primos structure subroutine mkpacl include ACL_COMMON integer i, j, k character temp (MAXACLLIST) integer encode define (INSCHAR (x), {temp (i) = x; i +=1}) Acl_version = 2 for (j = 1; j <= Acl_count; j += 1) { i = encode (temp, MAXACLLIST, "*s:"s, Acl_user (1, j)) i += 1 if (Acl_mode (j) == ACL_ALL) call ctoc ("all"s, temp (i), 4) elif (Acl_mode (j) == ACL_NONE) call ctoc ("none"s, temp (i), 5) else { if (and (ACL_ADD, Acl_mode (j)) ~= 0) INSCHAR ('a'c) if (and (ACL_DELETE, Acl_mode (j)) ~= 0) INSCHAR ('d'c) if (and (ACL_LIST, Acl_mode (j)) ~= 0) INSCHAR ('l'c) if (and (ACL_PROTECT, Acl_mode (j)) ~= 0) INSCHAR ('p'c) if (and (ACL_READ, Acl_mode (j)) ~= 0) INSCHAR ('r'c) if (and (ACL_USE, Acl_mode (j)) ~= 0) INSCHAR ('u'c) if (and (ACL_WRITE, Acl_mode (j)) ~= 0) INSCHAR ('w'c) INSCHAR (EOS) } k = 1 call ctov (temp, k, Acl_pairs (1, j), 41) } return undefine (INSCHAR) end #HD#: mksacl.r 634 Nov-27-1984 01:11:19 # mksacl --- encode the ACL structure integer function mksacl (ret_acl_path, access_pairs, type, separator) character ret_acl_path (ARB), access_pairs (ARB), separator (ARB) integer type include ACL_COMMON integer i, count integer encode, ctoc define (INSCHAR(x), {access_pairs (i) = x; i +=1}) call ctoc (Acl_name, ret_acl_path, MAXPATH) type = Acl_type i = 1 for (count = 1; count <= Acl_count; count += 1) { i += encode (access_pairs (i), MAXACLLIST, "*s="s, Acl_user (1, count)) if (Acl_mode (count) == ACL_NONE) i += ctoc ("$none"s, access_pairs (i), MAXACLLIST) elif (Acl_mode (count) == ACL_ALL) i += ctoc ("$all"s, access_pairs (i), MAXACLLIST) else { if (and (ACL_ADD, Acl_mode (count)) ~= 0) INSCHAR('a'c) if (and (ACL_DELETE, Acl_mode (count)) ~= 0) INSCHAR('d'c) if (and (ACL_LIST, Acl_mode (count)) ~= 0) INSCHAR('l'c) if (and (ACL_PROTECT, Acl_mode (count)) ~= 0) INSCHAR('p'c) if (and (ACL_READ, Acl_mode (count)) ~= 0) INSCHAR('r'c) if (and (ACL_USE, Acl_mode (count)) ~= 0) INSCHAR('u'c) if (and (ACL_WRITE, Acl_mode (count)) ~= 0) INSCHAR('w'c) } i += encode (access_pairs (i), MAXACLLIST, separator) } return (i - 1) undefine (INSCHAR) end #HD#: mktabl.r 193 Nov-27-1984 01:11:19 # mktabl --- make a new (empty) symbol table pointer function mktabl (nodesize) integer nodesize integer Mem (1) common /ds$mem/ Mem pointer st pointer dsget integer i st = dsget (ST_HTABSIZE + 1) # +1 for record of nodesize Mem (st) = nodesize mktabl = st do i = 1, ST_HTABSIZE; { st += 1 Mem (st) = LAMBDA # null link } return end #HD#: mktemp.r 172 Nov-27-1984 01:11:19 # mktemp --- open a temporary file and return its unit number filedes function mktemp (mode) integer mode integer i, fd character tempf (15) integer create for (i = 1; i <= 999; i += 1) { call encode (tempf, 15, "=temp=/tm*i"s, i) fd = create (tempf, mode) if (fd ~= ERR) return (fd) } return (ERR) end #HD#: mktr$ 0 Nov-27-1984 01:11:19 #HD#: mktr$.r 1047 Nov-27-1984 01:11:20 # mktr$ --- convert a pathname into a treename integer function mktr$ (path, tree) character path (ARB), tree (ARB) procedure inchar (char) forward procedure back$$ forward integer tp, i, mfdpwd, blank integer index, scopy tp = 1 i = 1 SKIPBL (path, i) blank = NO select (path (i)) when ('/'c) { mfdpwd = NO if (path (i + 1) == '/'c) # special case two leading slashes for (i += 2; path (i) == '/'c; i += 1) ; else { inchar ('<'c) for (i += 1; path (i) ~= '/'c && path (i) ~= EOS; i += 1) { if (path (i) == ESCAPE) { i += 1 inchar (path (i)) } else if (path (i) == ':'c) { tp += scopy (">MFD"s, 1, tree, tp) mfdpwd = YES blank = YES } else { if (blank == YES) inchar (' 'c) inchar (path (i)) blank = NO } } if (path (i) ~= '/'c && mfdpwd == NO) tp += scopy (">MFD XXXXXX"s, 1, tree, tp) } } when ('\'c) back$$ when (EOS) ; else { inchar ('*'c) inchar ('>'c) } for (; path (i) ~= EOS; i += 1) { if (path (i) == '/'c) { blank = NO while (path (i + 1) == '/'c) i += 1 if (path (i + 1) ~= EOS) inchar ('>'c) } elif (path (i) == ':'c) blank = YES else { if (blank == YES) inchar (' 'c) if (path (i) == ESCAPE) i += 1 inchar (path (i)) blank = NO } } tree (tp) = EOS return (tp - 1) # inchar --- put a character in the tree name procedure inchar (char) { character char tree (tp) = char tp += 1 } # back$$ --- intepret backslashes in a pathname procedure back$$ { local code, buf integer code, buf (MAXTREE) call gpath$ (2, 0, buf, MAXTREE * 2 - 1, tp, code) if (code ~= 0) return (ERR) call ptoc (buf, EOS, tree, tp + 1) call mapstr (tree, LOWER) for (tp += 1; path (i) == '\'c; i += 1) { repeat tp -= 1 until (tp < 1 || tree (tp) == '>'c) } if (tp < 1) tp = 1 tree (tp) = EOS if (path (i) ~= '/'c && path (i) ~= EOS) inchar ('>'c) elif (path (i) == EOS && index (tree, '>'c) == 0) tp += scopy (">MFD XXXXXX"s, 1, tree, tp) } end #HD#: mntoc.r 530 Nov-27-1984 01:11:20 # mntoc --- translate ASCII mnemonic into a character character function mntoc (buf, p, default) character buf (ARB), default integer p integer i, tp integer strbsr character c, tmp (MAXLINE) string_table pos, text ACK, "ack"/ BEL, "bel"/ BS, "bs"/ CAN, "can"/ CR, "cr"/ DC1, "dc1"/ DC2, "dc2"/ DC3, "dc3"/ DC4, "dc4"/ DEL, "del"/ DLE, "dle"/ EM, "em"/ ENQ, "enq"/ EOT, "eot"/ ESC, "esc"/ ETB, "etb"/ ETX, "etx"/ FF, "ff"/ FS, "fs"/ GS, "gs"/ HT, "ht"/ LF, "lf"/ NAK, "nak"/ NUL, "nul"/ RS, "rs"/ SI, "si"/ SO, "so"/ SOH, "soh"/ SP, "sp"/ STX, "stx"/ SUB, "sub"/ SYN, "syn"/ US, "us"/ VT, "vt" if (buf (p) == EOS) return (default) tp = 1 repeat { tmp (tp) = buf (p) tp += 1 p += 1 } until (~ (IS_LETTER (buf (p)) || IS_DIGIT (buf (p))) || tp >= MAXLINE) tmp (tp) = EOS if (tp == 2) c = tmp (1) else { call mapstr (tmp, LOWER) i = strbsr (pos, text, 1, tmp) if (i ~= EOF) c = text (pos (i)) else c = default } return (c) end #HD#: move$.s 521 Nov-27-1984 01:11:20 * move$ --- move blocks of memory around quickly * * subroutine move$ (from, to, count) * integer from (ARB), to (ARB), count * * integer i * * for (i = 1; i <= count; i += 1) * to (i) = from (i) * * return * end SUBR MOVE$ SEG RLIT include "=incl=/lib_def.s.i" LINK MOVE$ ECB MOVE,,FROM_PTR,3 DATA 5,C'MOVE$' PROC DYNM =20,FROM_PTR(3),TO_PTR(3),COUNT_PTR(3) MOVE ARGT ENTR MOVE$ LDA COUNT_PTR,* SNZ PRTN TAX EAXB FROM_PTR,*X EALB TO_PTR,*X TCA TAX SLN JMP L1 LDA XB%,X STA LB%,X BIX *+3 PRTN TXA L1 SAS 15 JMP L2 LDL XB%,X STL LB%,X IRX BIX *+3 PRTN TXA L2 SAS 14 JMP L3 DFLD XB%,X DFST LB%,X ADD =4 SNZ PRTN TAX L3 SAS 13 JMP L4 DFLD XB%,X DFST LB%,X DFLD XB%+4,X DFST LB%+4,X ADD =8 SNZ PRTN TAX L4 DFLD XB%,X DFST LB%,X DFLD XB%+4,X DFST LB%+4,X DFLD XB%+8,X DFST LB%+8,X DFLD XB%+12,X DFST LB%+12,X ADD =16 BNE L4-1 PRTN END #HD#: omatch.r 405 Nov-27-1984 01:11:20 # omatch --- try to match a single pattern at pat (j) integer function omatch (lin, i, pat, j) character lin (ARB), pat (MAXPAT) integer i, j integer locate integer bump omatch = NO if (lin (i) == EOS) return bump = -1 select (pat (j)) when (PAT_CHAR) { if (lin (i) == pat (j + 1)) bump = 1 } when (PAT_BOL) { if (i == 1) bump = 0 } when (PAT_ANY) { if (lin (i) ~= NEWLINE) bump = 1 } when (PAT_EOL) { if (lin (i) == NEWLINE) bump = 0 } when (PAT_CCL) { if (locate (lin (i), pat, j + 1) == YES) bump = 1 } when (PAT_NCCL) { if (lin (i) ~= NEWLINE && locate (lin (i), pat, j + 1) == NO) bump = 1 } else call error ("in omatch: can't happen"s) if (bump >= 0) { i += bump omatch = YES } return end #HD#: open.r 1355 Nov-27-1984 01:11:20 # open --- open a file for reading and/or writing filedes function open (path, mode, ftype, delay) character path (ARB) integer mode, ftype, delay include SWT_COMMON integer fd, f, i, j integer dopen$, lopen$, mapdn, strbsr, expand, getfd$ character dev_name (30), epath (MAXPATH) string_table dev_pos, dev_tab, / 1, ERRIN, "errin" _ / 1, ERROUT, "errout" _ / 4, 0, "lps" _ / 2, 0, "null" _ / 1, STDIN, "stdin" _ / 1, STDIN1, "stdin1" _ / 1, STDIN2, "stdin2" _ / 1, STDIN3, "stdin3" _ / 1, STDOUT, "stdout" _ / 1, STDOUT1, "stdout1" _ / 1, STDOUT2, "stdout2" _ / 1, STDOUT3, "stdout3" _ / 3, 0, "tty" procedure creturn (val) forward # Find an empty descriptor if (getfd$ (fd) == ERR) return (ERR) f = fd_offset (fd) call break$ (DISABLE) # Initialize the descriptor (except device type) Fd_bufstart (f) = fd * BUFSIZE - BUFSIZE Fd_buflen (f) = BUFSIZE Fd_bufend (f) = 0 Fd_count (f) = 0 Fd_bcount (f) = 0 select (and (mode, 3)) # look only at 2 low-order bits when (READ) Fd_flags (f) = FD_READ when (WRITE) Fd_flags (f) = FD_WRITE when (READWRITE) Fd_flags (f) = FD_READ + FD_WRITE else creturn (ERR) Fd_flags (f) |= FD_OPENED + FD_INITIAL # Expand the templates in the name: if (expand (path, epath, MAXPATH) == ERR) creturn (ERR) # Select the device type: i = 1 SKIPBL (epath, i) # Is it a disk file? if ( epath (i + 0) ~= '/'c || mapdn (epath (i + 1)) ~= 'd'c || mapdn (epath (i + 2)) ~= 'e'c || mapdn (epath (i + 3)) ~= 'v'c || epath (i + 4) ~= '/'c) { Fd_dev (f) = DEV_DSK creturn (dopen$ (path, fd, mode, ftype, delay)) } # It must be a device file i += 5 # skip past "/dev/" for (j = 1; epath (i) ~= EOS && epath (i) ~= '/'c && epath (i) ~= ' 'c; {j += 1; i += 1}) dev_name (j) = mapdn (epath (i)) dev_name (j) = EOS # Look up the device j = strbsr (dev_pos, dev_tab, 2, dev_name) if (j == EOF) creturn (ERR) select (dev_tab (dev_pos (j))) when (1) { Fd_flags (f) = 0 # give back the file descriptor creturn (dev_tab (dev_pos (j) + 1)) # return the standard port } when (2) { Fd_dev (f) = DEV_NULL creturn (fd) } when (3) { Fd_dev (f) = DEV_TTY creturn (fd) } when (4) { Fd_dev (f) = DEV_DSK creturn (lopen$ (epath (i), fd, mode)) } Fd_flags (f) = 0 call break$ (ENABLE) return (ERR) # error in table # creturn --- deallocate file descriptor if returning error status procedure creturn (val) { integer val if (val == ERR) Fd_flags (f) = 0 call break$ (ENABLE) return (val) } end #HD#: page.r 7414 Nov-27-1984 01:11:21 # page --- display a file on a CRT terminal one page at a time. define (BOUND(v,l,h),min0(max0(v,l),h)) define (BREAKLN,1) # Line number for processing QUIT$ define (MAXLNPP,64) # Maximum number of lines per page define (MAXPAGE,10000) # Maximum number of pages define (MSCREEN,86) # Maximum screen width + 1 define (FORWARD,0) # Key to search forward define (BACKWARD,1) # Key to search backward integer function page (fdin, promptin, epromptin, linesin, fdout, options) character promptin (ARB), epromptin (ARB) file_des fdin, fdout integer linesin, options external pg$brk file_des open file_mark markf integer isatty, vtinit, vtprt, vtgetl, getlin, ctoi, makpat, match, scopy logical missin character term (MAXTERMTYPE), screen (MSCREEN, MAXLNPP), input (MAXLINE), line (MAXLINE), temp (MAXLINE), prompt (MAXLINE), eprompt (MAXLINE), message (MAXLINE), emessage (MAXLINE) file_mark pages (MAXPAGE) integer vthrc (2), tempat (MAXPAT), pattern (MAXPAT) integer label (4) file_des ifd, ofd, tifd, tofd integer pg, last, index, lines, columns, size, first, start, begin, clear, i, j, k, l, m, missing_delim logical pause, vthout, error, noread, nopat, found string_table help_index, help_source, "The following commands (upper or lower case) are available:" _ / " D Display continuous pages" _ / " E Begin examining the file named " _ / " E Begin examining the original file" _ / " H or ? Display this command summary" _ / " M Change left margin of display" _ / " N Stop paging, normal status" _ / " P or ^ Display the previous page" _ / ' Q Same as "N"' _ / " S Change page size to " _ / " W Write a copy of the file into " _ / " X Stop paging, EOF status" _ / " Y or : Go to the next page" _ / ' Same as "X", does not work with vth' _ / ' Same as "Y"' _ / " Display page " _ / " - Display current page - " _ / " . Redisplay the current page" _ / " + Display current page + " _ / " $ Display the last page" _ / " /[/] Display next page containing " _ / " \[\] Display previous page containing " include SWT_COMMON procedure read_page (num) forward procedure display_page forward procedure find_page (direction) forward procedure exit (val) forward ifd = fdin ofd = fdout if (isatty (ofd) == NO) { call fcopy (ifd, ofd) return (OK) } call ctoc (promptin, prompt, MAXLINE) call ctoc (epromptin, eprompt, MAXLINE) if (missin (options)) { pause = TRUE vthout = FALSE } else { pause = and (options, PG_END) == 0 vthout = and (options, PG_VTH) ~= 0 } call break$ (DISABLE) do i = 1, 4 label (i) = Rtlabel (i) call mklb$f ($ BREAKLN, Rtlabel) call mkon$f ("QUIT$", 5, pg$brk) if (vthout) { vthout = vtinit (term) == OK if (vthout) { call vtinfo (VT_MAXRC, vthrc) lines = vthrc (1) - 1 columns = vthrc (2) call vtupd (YES) } } if (~vthout) { lines = BOUND (linesin, 1, MAXLNPP) columns = 80 } pg = 0 last = MAXPAGE - 1 size = 0 index = 0 first = 1 pages (1) = intl (0) do i = 2, MAXPAGE pages (i) = intl (-1) input (1) = EOS line (1) = EOS error = FALSE read_page (1) noread = TRUE nopat = TRUE call break$ (ENABLE) repeat { if (error) { error = FALSE clear = NO if (pg ~= last) if (vthout) { start = 1 + vtprt (vthrc (1), 1, message, pg) begin = start + vtprt (vthrc (1), start, "*s"s, input) + 1 } else call print (TTY, message, pg) else if (vthout) { start = 1 + vtprt (vthrc (1), 1, emessage, pg) begin = start + vtprt (vthrc (1), start, "*s"s, input) + 1 } else call print (TTY, emessage, pg) } else { clear = YES if (noread) noread = FALSE else read_page (pg + 1) display_page if (pg == last) { if (index == 0 || ifd == fdin && ~pause) { if (ifd ~= fdin) call close (ifd) exit (OK) } if (vthout) { start = 1 + vtprt (vthrc (1), 1, eprompt, pg) begin = start } else call print (TTY, eprompt, pg) } else if (vthout) { start = 1 + vtprt (vthrc (1), 1, prompt, pg) begin = start } else call print (TTY, prompt, pg) } input (1) = EOS if (vthout) { call vtenb (vthrc (1), start, vthrc (2) - start + 1) call vtread (vthrc (1), begin, clear) call vtenb (vthrc (1), start, 0) size = vtgetl (input, vthrc (1), start, vthrc (2) - start + 1) call vtclr (vthrc (1), 1, vthrc (1), vthrc (2)) call vtupd (NO) } else { size = getlin (input, TTY) if (size == EOF) { call putch (NEWLINE, TTY) if (ifd ~= fdin) call close (ifd) exit (EOF) } if (input (size) == NEWLINE) input (size) = EOS } call strim (input) i = 1 SKIPBL (input, i) select (input (i)) when ("d"c, "D"c) { i += 1 j = BOUND (ctoi (input, i), 1, MAXPAGE - pg - 1) for (k = 1; k < j && pg ~= last; k += 1) { read_page (pg + 1) if (pg ~= last) { display_page if (vthout) call vtupd (NO) } } if (pg == last) noread = TRUE } when ("e"c, "E"c) { i += 1 SKIPBL (input, i) if (input (i) ~= EOS) { tifd = open (input (i), READ) if (tifd ~= ERR) { if (ifd ~= fdin) call close (ifd) ifd = tifd for (j = 1; input (i) ~= EOS; i += 1) if (j < MAXLINE - 1) { line (j) = input (i) if (line (j) == '*'c) { line (j + 1) = '*'c j += 1 } j += 1 } line (j) = EOS call encode (prompt, MAXLINE, "*s [**i+]? "s, line) call encode (eprompt, MAXLINE, "*s [**i$]? "s, line) } else { call encode (message, MAXLINE, "*s: can't open [**i+]? "s, input (i)) call encode (emessage, MAXLINE, "*s: can't open [**i$]? "s, input (i)) error = TRUE } } else { if (ifd ~= fdin) call close (ifd) ifd = fdin call ctoc (promptin, prompt, MAXLINE) call ctoc (epromptin, eprompt, MAXLINE) } if (~error) { last = MAXPAGE - 1 do j = 2, MAXPAGE pages (j) = intl (-1) read_page (1) noread = TRUE } } when ("h"c, "H"c, "?"c) { if (vthout) call vtclr (1, 1, lines, vthrc (2)) for (i = 1; i <= help_index (1); i += 1) if (vthout) call vtputl (help_source (help_index (i + 1)), i, 1) else call print (ofd, "*s*n"s, help_source (help_index (i + 1))) input (1) = EOS call ctoc (prompt, message, MAXLINE) call ctoc (eprompt, emessage, MAXLINE) error = TRUE } when ("m"c, "M"c) { i += 1 first = max0 (ctoi (input, i), 1) read_page (pg) noread = TRUE } when ("n"c, "N"c, "q"c, "Q"c) { if (ifd ~= fdin) call close (ifd) exit (OK) } when ("p"c, "P"c, "^"c) { read_page (pg - 1) noread = TRUE } when ("s"c, "S"c) { if (~vthout) { i += 1 lines = BOUND (ctoi (input, i), 1, MAXLNPP) do j = 2, MAXPAGE pages (j) = intl (-1) read_page (1) } noread = TRUE } when ("w"c, "W"c) { i += 1 SKIPBL (input, i) if (input (i) ~= EOS) { tofd = open (input (i), READ) if (tofd == ERR) { tofd = open (input (i), WRITE) if (tofd ~= ERR) { call seekf (pages (1), ifd) call fcopy (ifd, tofd) call seekf (pages (pg + 1), ifd) call close (tofd) input (1) = EOS call ctoc (prompt, message, MAXLINE) call ctoc (eprompt, emessage, MAXLINE) error = TRUE } else { call encode (message, MAXLINE, "*s: can't open [**i+]? "s, input (i)) call encode (emessage, MAXLINE, "*s: can't open [**i$]? "s, input (i)) error = TRUE } } else { call close (tofd) call ctoc ("File already exists [*i+]? "s, message, MAXLINE) call ctoc ("File already exists [*i$]? "s, emessage, MAXLINE) error = TRUE } } else { call ctoc ("Path name missing [*i+]? "s, message, MAXLINE) call ctoc ("Path name missing [*i$]? "s, emessage, MAXLINE) error = TRUE } } when ("x"c, "X"c) { if (ifd ~= fdin) call close (ifd) exit (EOF) } when ("y"c, "Y"c, ":"c, EOS) if (pg == last) { if (ifd ~= fdin) call close (ifd) exit (OK) } when ("."c) noread = TRUE when ("$"c) { read_page (MAXPAGE - 1) noread = TRUE } when (SET_OF_DIGITS) { read_page (BOUND (ctoi (input, i), 1, MAXPAGE - 1)) noread = TRUE } when ("+"c) { i += 1 read_page (pg + BOUND (ctoi (input, i), 1, MAXPAGE - pg - 1)) noread = TRUE } when ("-"c) { i += 1 read_page (pg - max0 (ctoi (input, i), 1)) noread = TRUE } when ("/"c) { if (nopat && (input (i + 1) == "/"c || input (i + 1) == EOS)) { call ctoc ("No saved pattern [*i+]? "s, message, MAXLINE) call ctoc ("No saved pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } if (input (i + 1) == EOS) { input (i + 1) = input (i) input (i + 2) = EOS } else if (input (i + 1) ~= "/"c) { missing_delim = YES for (l = i + 1; input (l) ~= EOS; l += 1) if (input (l) == ESCAPE && input (l+1) == input (i)) l += 1 else if (input (l) == input (i)) { missing_delim = NO break } if (missing_delim == YES) { for (; input (l) ~= EOS; l += 1) ; input (l) = input (i) input (l + 1) = EOS } if (makpat (input, i+1, input (i), tempat) == ERR) { call ctoc ("Syntax error in pattern [*i+]? "s, message, MAXLINE) call ctoc ("Syntax error in pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } else { do j = 1, MAXPAT pattern (j) = tempat (j) nopat = FALSE } } find_page (FORWARD) if (~found) { call ctoc ("Pattern not found [*i+]? "s, message, MAXLINE) call ctoc ("Pattern not found [*i$]? "s, emessage, MAXLINE) error = TRUE } else noread = TRUE } when ("\"c) { if (nopat && (input (i + 1) == "\"c || input (i + 1) == EOS)) { call ctoc ("No saved pattern [*i+]? "s, message, MAXLINE) call ctoc ("No saved pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } if (input (i + 1) == EOS) { input (i + 1) = input (i) input (i + 2) = EOS } else if (input (i + 1) ~= "\"c) { missing_delim = YES for (l = i + 1; input (l) ~= EOS; l += 1) if (input (l) == ESCAPE && input (l+1) == input (i)) l += 1 else if (input (l) == input (i)) { missing_delim = NO break } if (missing_delim == YES) { for (; input (l) ~= EOS; l += 1) ; input (l) = input (i) input (l + 1) = EOS } if (makpat (input, i+1, input (i), tempat) == ERR) { call ctoc ("Syntax error in pattern [*i+]? "s, message, MAXLINE) call ctoc ("Syntax error in pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } else { do j = 1, MAXPAT pattern (j) = tempat (j) nopat = FALSE } } find_page (BACKWARD) if (~found) { call ctoc ("Pattern not found [*i+]? "s, message, MAXLINE) call ctoc ("Pattern not found [*i$]? "s, emessage, MAXLINE) error = TRUE } else noread = TRUE } when (CR) { # Kludge for QUIT$ onunit BREAKLN if (index < lines) read_page (pg) call ctoc (prompt, message, MAXLINE) call ctoc (eprompt, emessage, MAXLINE) error = TRUE } else { call ctoc ("Unknown command, enter '?' for help [*i+]? "s, message, MAXLINE) call ctoc ("Unknown command, enter '?' for help [*i$]? "s, emessage, MAXLINE) error = TRUE } } # read_page --- read the requested page from the file into the buffer. procedure read_page { integer num local i, flag integer i logical flag num = BOUND (num, 1, MAXPAGE - 1) if (num ~= pg + 1) { if (pages (num) == intl (-1)) for (pg -= 1; pages (pg + 2) ~= intl (-1); pg += 1) ; else pg = num - 1 call seekf (pages (pg + 1), ifd) line (1) = EOS size = 0 } while (pg < num) { index = 0 if (line (1) ~= EOS) { size = scopy (line, 1, screen (1, index + 1), 1) line (1) = EOS if (screen (size, index + 1) == NEWLINE) screen (size, index + 1) = EOS index += 1 } while (index < lines && size ~= EOF) { flag = TRUE for (i = first; i > 1; i -= size) { size = getlin (temp, ifd, min0 (i, MSCREEN)) if (size == EOF || temp (size) == NEWLINE) { flag = FALSE break } } if (flag) size = getlin (screen (1, index + 1), ifd, columns) else if (size ~= EOF) { screen (1, index + 1) = NEWLINE screen (2, index + 1) = EOS size = 1 } else screen (1, index + 1) = EOS if (size ~= EOF) { if (screen (size, index + 1) ~= NEWLINE) repeat i = getlin (temp, ifd, MSCREEN) until (i == EOF || temp (i) == NEWLINE) else screen (size, index + 1) = EOS index += 1 } } pg += 1 if (size ~= EOF) { if (pg + 1 < MAXPAGE && pages (pg + 1) == intl (-1)) pages (pg + 1) = markf (ifd) flag = TRUE for (i = first; i > 1; i -= size) { size = getlin (temp, ifd, min0 (i, MSCREEN)) if (size == EOF || temp (size) == NEWLINE) { flag = FALSE break } } if (flag) size = getlin (line, ifd, columns) else if (size ~= EOF) { line (1) = NEWLINE line (2) = EOS size = 1 } else line (1) = EOS if (size ~= EOF) { if (line (size) ~= NEWLINE) repeat i = getlin (temp, ifd, MSCREEN) until (i == EOF || temp (i) == NEWLINE) } else pages (pg + 1) = intl (-1) } if (size == EOF) { last = pg break } } } # display_page --- display buffer on screen. procedure display_page { local i integer i if (vthout) call vtclr (1, 1, lines, vthrc (2)) for (i = 1; i <= index; i += 1) if (vthout) call vtputl (screen (1, i), i, 1) else call print (ofd, "*s*n"s, screen (1, i)) } # find_page --- find next page (circularly) that contains "pattern". procedure find_page { integer direction local i, j integer i, j i = pg found = FALSE repeat { if (direction == BACKWARD) if (pg == 1) read_page (MAXPAGE - 1) else read_page (pg - 1) else { read_page (pg + 1) if (pg == last && index == 0) read_page (1) } for (j = 1; j <= index && ~found; j += 1) if (match (screen (1, j), pattern) == YES) found = TRUE } until (found || pg == i) } # exit --- stop vth if applicable and return from page. procedure exit { integer val if (vthout) { call vtupd (NO) call vtstop } do i = 1, 4 Rtlabel (i) = label (i) return (val) } end subroutine pg$brk (cp) longint cp include SWT_COMMON call pl1$nl (Rtlabel) return end undefine(BOUND) undefine(BREAKLN) undefine(MAXLNPP) undefine(MAXPAGE) undefine(MSCREEN) undefine(FORWARD) undefine(BACKWARD) #HD#: parsa$.r 1967 Nov-27-1984 01:11:22 # parsa$ --- parse acl changes integer function parsa$ (str) character str (ARB) include ACL_COMMON integer sp, i, j, defval integer cprot integer lookac, equal character text (33) character cname (33), cop, cflag (33) procedure getname forward procedure getprot forward ### Save the default value i = lookac ("$rest"s) if (i ~= ERR) defval = Acl_mode (i) else defval = 0 ### Do the parsing... call mapstr (str, LOWER) sp = 1 SKIPBL (str, sp) while (str (sp) ~= EOS) { ### Grab the name -- give up if none getname if (text (1) == EOS) return (ERR) call scopy (text, 1, cname, 1) ### Get the assignment operator -- give up if none SKIPBL (str, sp) if (str (sp) == ':'c || str (sp) == '+'c || str (sp) == '-'c || str (sp) == '='c) { cop = str (sp) sp += 1 if (str (sp) == '='c) sp += 1 } else return (ERR) ### Now get the protections SKIPBL (str, sp) if (cop == ':'c) { # grab a name in the acl getname i = lookac (text) if (i == ERR) return (ERR) cprot = Acl_mode (i) } else # just look for letters & stuff getprot ### Update the name in the acl i = lookac (cname) if (i == ERR) { # not there--assign an empty slot i = lookac (""s) # find a slot if (i == ERR) { Acl_count += 1 if (Acl_count > 32) return (ERR) i = Acl_count } call scopy (cname, 1, Acl_user (1, i), 1) Acl_mode (i) = defval } if (cop == '='c || cop == ':'c) Acl_mode (i) = cprot else if (cop == '+'c) Acl_mode (i) |= cprot else if (cop == '-'c) Acl_mode (i) &= not (cprot) SKIPBL (str, sp) } # end of while (str (sp) ... ### Clobber entries equal to $rest (get $rest, too) i = lookac ("$rest"s) if (i == ERR) defval = 0 else defval = Acl_mode (i) for (i = 1; i <= Acl_count; i += 1) if (Acl_mode (i) == defval) Acl_user (1, i) = EOS ### Squash out deleted entries for ({i = 1; j = 1}; i <= Acl_count; i += 1) if (Acl_user (1, i) ~= EOS) { if (i ~= j) { call scopy (Acl_user (1, i), 1, Acl_user (1, j), 1) Acl_mode (j) = Acl_mode (i) } j += 1 } Acl_count = j - 1 ### Put in a $rest at the end Acl_count += 1 if (Acl_count > 32) return (ERR) call scopy ("$rest"s, 1, Acl_user (1, Acl_count), 1) Acl_mode (Acl_count) = defval return (OK) # getname --- collect a name from str (sp) into text (1) procedure getname { local i; integer i text (1) = EOS if (IS_LETTER (str (sp)) || str (sp) == '.'c || str (sp) == '$'c) { text (1) = str (sp) for ({sp += 1; i = 2}; i <= 33 && (IS_LETTER (str (sp)) || IS_DIGIT (str (sp)) || str (sp) == '$'c || str (sp) == '_'c || str (sp) == '.'c); {sp += 1; i += 1}) text (i) = str (sp) text (i) = EOS } } # getprot --- get protection string from str (sp) and put in cprot procedure getprot { cprot = ACL_NONE if (str (sp) == '$'c) { getname select when (equal (text, "$owner"s) == YES) cprot = ACL_DELETE + ACL_ADD + ACL_LIST _ + ACL_USE + ACL_READ + ACL_WRITE when (equal (text, "$read"s) == YES) cprot = ACL_LIST + ACL_READ + ACL_USE when (equal (text, "$use"s) == YES) cprot = ACL_ADD + ACL_LIST + ACL_USE + ACL_READ when (equal (text, "$all"s) == YES) cprot = ACL_ALL when (equal (text, "$none"s) == YES) cprot = ACL_NONE when (equal (text, "$default"s) == YES) cprot = defval when (equal (text, "$def"s) == YES) cprot = defval else return (ERR) } else repeat { select (str (sp)) when ('a'c) cprot |= ACL_ADD when ('p'c) cprot |= ACL_PROTECT when ('l'c) cprot |= ACL_LIST when ('u'c) cprot |= ACL_USE when ('r'c) cprot |= ACL_READ when ('w'c) cprot |= ACL_WRITE when ('d'c) cprot |= ACL_DELETE when ('?'c) cprot |= defval when ('*'c) cprot |= ACL_ALL when ('0'c) ; else break sp += 1 } } end #HD#: parscl.r 1943 Nov-27-1984 01:11:22 # parscl --- parse command line arguments integer function parscl (str, buf) character str (ARB), buf (MAXARGBUF) integer ap, bp, cp, sp, lc, i, l, k, at, status integer argtype (26) integer getarg, gctoi, ctoc, strbsr character arg (MAXARG) character mapdn string_table atx, att, / ARG_FLAG, "f" _ / ARG_FLAG, "flag" _ / ARG_IGNORED, "ign" _ / ARG_IGNORED, "ignored" _ / ARG_NOT_ALLOWED, "na" _ / ARG_OPT_INT, "oi" _ / ARG_OPT_INT, "opt int" _ / ARG_OPT_STR, "opt str" _ / ARG_OPT_STR, "os" _ / ARG_REQ_INT, "req int" _ / ARG_REQ_STR, "req str" _ / ARG_REQ_INT, "ri" _ / ARG_REQ_STR, "rs" procedure get_argtype forward procedure next_argument forward do i = 1, 26 argtype (i) = ARG_NOT_ALLOWED ### Parse the command string for (sp = 1; str (sp) ~= EOS; sp += 1) if (IS_LETTER (str (sp))) { lc = mapdn (str (sp)) - 'a'c + 1 get_argtype argtype (lc) = at } ### Initialize the argument buffer do i = 1, 26 buf (i) = ARG_NOT_SEEN do i = 27, 52 buf (i) = 0 ### Examine the argument list bp = 54 ap = 1 next_argument while (status ~= EOF) { l = mapdn (arg (cp)) - 'a'c + 1 if (l < 1 || l > 26) return (ERR) buf (l) = ARG_LETTER_SEEN select (argtype (l)) when (ARG_NOT_ALLOWED) return (ERR) when (ARG_IGNORED) { if (cp ~= 2) # ignored args can only be first letters return (ERR) ap += 1 next_argument } when (ARG_REQ_INT, ARG_OPT_INT) if (arg (cp + 1) == EOS) { call delarg (ap) if (getarg (ap, arg, MAXARG) ~= EOF && (IS_DIGIT (arg (1)) || arg (1) == '-'c && IS_DIGIT (arg (2)))) { cp = 1 buf (l + 26) = gctoi (arg, cp, 10) if (arg (cp) ~= EOS) return (ERR) buf (l) = ARG_VALUE_SEEN call delarg (ap) } else if (argtype (l) == ARG_REQ_INT) return (ERR) next_argument } else { cp += 1 k = cp buf (l + 26) = gctoi (arg, cp, 10) if (k == cp) { # no number here if (argtype (l) == ARG_REQ_INT) return (ERR) } else # indicate that value was given buf (l) = ARG_VALUE_SEEN } when (ARG_REQ_STR, ARG_OPT_STR) if (arg (cp + 1) == EOS) { call delarg (ap) if (getarg (ap, arg, MAXARG) ~= EOF && arg (1) ~= '-'c ) { buf (l + 26) = bp bp += 1 + ctoc (arg, buf (bp), MAXARGBUF - bp) call delarg (ap) buf (l) = ARG_VALUE_SEEN } else if (argtype (l) == ARG_REQ_STR) return (ERR) next_argument } else { buf (l + 26) = bp bp += 1 + ctoc (arg (cp + 1), buf (bp), MAXARGBUF - bp) buf (l) = ARG_VALUE_SEEN call delarg (ap) next_argument } when (ARG_FLAG) cp += 1 if (arg (cp) == EOS) { # bump the argument pointer if necessary call delarg (ap) next_argument } } do i = 1, 26 if (buf (i) ~= ARG_VALUE_SEEN # ensure string opts are defined && (argtype (i) == ARG_OPT_STR || argtype (i) == ARG_REQ_STR)) buf (i + 26) = bp buf (bp) = EOS bp += 1 buf (53) = bp return (OK) # get_argtype --- get and parse an argument type procedure get_argtype { local tbuf, tp, x character tbuf (MAXLINE) integer tp, x at = ARG_FLAG while (str (sp + 1) ~= '<'c && ~ IS_LETTER (str (sp + 1)) && str (sp + 1) ~= EOS) sp += 1 if (str (sp + 1) == '<'c) { tp = 1 sp += 1 while (str (sp + 1) ~= '>'c && str (sp + 1) ~= EOS) { tbuf (tp) = str (sp + 1) sp += 1 tp += 1 } tbuf (tp) = EOS x = strbsr (atx, att, 1, tbuf) if (x == EOF) { call putlin (tbuf, ERROUT) call error (": unrecognized argument type in parscl"p) } at = att (atx (x)) } } # next_argument --- obtain the next argument to parse procedure next_argument { status = getarg (ap, arg, MAXARG) while (status ~= EOF && (arg (1) ~= '-'c || ~ IS_LETTER (arg (2)))) { ap += 1 status = getarg (ap, arg, MAXARG) } cp = 2 } end #HD#: parsdt.r 457 Nov-27-1984 01:11:22 # parsdt --- parse a date in mm/dd/yy format integer function parsdt (str, i, month, day, year) character str (ARB) integer i, month, day, year integer j, days (12) integer ctoi character today (9) # Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec # data days / 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / SKIPBL (str, i) if (~IS_DIGIT (str (i))) return (ERR) month = ctoi (str, i) if (str (i) == '/'c) { i += 1 day = ctoi (str, i) if (str (i) == '/'c) { i += 1 year = ctoi (str, i) } else { call date (SYS_DATE, today) j = 7 year = ctoi (today, j) } } else { day = month call date (SYS_DATE, today) j = 1 month = ctoi (today, j) j = 7 year = ctoi (today, j) } if (1 <= month && month <= 12 && 1 <= day && day <= days (month) && 0 <= year && year <= 99) parsdt = OK else parsdt = ERR return end #HD#: parstm.r 484 Nov-27-1984 01:11:22 # parstm --- convert time-of-day to number of seconds since midnight integer function parstm (str, i, val) character str (ARB) integer i longint val define (TWELVE_HOURS,43200) integer ctoi character mapdn SKIPBL (str, i) if (~IS_DIGIT (str (i))) return (ERR) val = ctoi (str, i) # get hours if (str (i) == ':'c) i += 1 val = val * intl (60) + ctoi (str, i) # get minutes, if present if (str (i) == ':'c) i += 1 val = val * intl (60) + ctoi (str, i) # get seconds, if present if (val >= TWELVE_HOURS * 2) # only so many seconds in a day return (ERR) SKIPBL (str, i) select (mapdn (str (i))) when ('p'c) if (val < TWELVE_HOURS) # if it's AM, add 12 hours val += TWELVE_HOURS when ('a'c) if (val >= TWELVE_HOURS) # if it's PM, subtract 12 hours val -= TWELVE_HOURS ifany { i += 1 if (mapdn (str (i)) == 'm'c) i += 1 } return (OK) undefine (TWELVE_HOURS) end #HD#: patsiz.r 270 Nov-27-1984 01:11:23 # patsiz --- returns size of pattern entry at pat (n) integer function patsiz (pat, n) character pat (MAXPAT) integer n if (pat (n) == PAT_CHAR || pat (n) == PAT_START_TAG || pat (n) == PAT_STOP_TAG) patsiz = 2 else if (pat (n) == PAT_BOL || pat (n) == PAT_EOL || pat (n) == PAT_ANY) patsiz = 1 else if (pat (n) == PAT_CCL || pat (n) == PAT_NCCL) patsiz = pat (n + 1) + 2 else if (pat (n) == PAT_CLOSURE) # optional patsiz = PAT_CLOSIZE else call error ("in patsiz: can't happen"s) return end #HD#: print.r 282 Nov-27-1984 01:11:23 # print --- easy-to-use semi-formatted print routine subroutine print (fd, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) integer fd, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10 character fmt (ARB) character str (MAXPRINT), fmt1 (MAXLINE) if (fmt (1) == EOS || and (fmt (1), :177400) == 0) call encode (str, MAXPRINT, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) else { call ptoc (fmt, '.'c, fmt1, MAXLINE) call encode (str, MAXPRINT, fmt1, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) } call putlin (str, fd) return end #HD#: ptoc.r 198 Nov-27-1984 01:11:23 # ptoc --- convert packed string to EOS-terminated string integer function ptoc (pstr, term, str, len) integer pstr (ARB), len character term, str (ARB) integer cp, i cp = 0 for (i = 1; i < len; i += 1) { fpchar (pstr, cp, str (i)) if (str (i) == ESCAPE) fpchar (pstr, cp, str (i)) elif (str (i) == term) break } str (i) = EOS return (i - 1) end #HD#: ptov.s 1004 Nov-27-1984 01:11:23 * ptov --- convert packed to varying string * * integer function ptov (pstr, termch, vstr, len) * integer pstr (ARB), vstr (ARB), len * character termch * * returns number of characters moved (<= (len - 1) * 2) SUBR PTOV SEG RLIT SYML include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK PTOV ECB CNVSTART,,PSTR,4 DATA 4,C'PTOV' PROC DYNM =20,PSTR(3),TERMCH(3),VSTR(3),LEN(3) DYNM CHAR, FLAG CNVSTART ARGT ENTR PTOV CRA STA VSTR,* set number chars in target LDA LEN,* BEQ QUIT no space - quit S1A BEQ QUIT not enough space - quit STA LEN save first word for count LDA TERMCH,* STA TERMCH CRA STA FLAG TAX S1A TAB set B reg for fetch LT TAY COPYCH JSXB GETNXT CAS =ESCAPE JMP# CHKTERM JMP# SAVENXT save nextchar if this is an "@" CHKTERM CAS TERMCH JMP# STASH JMP# QUIT quit if it's terminating char JMP# STASH SAVENXT JSXB GETNXT STASH JSXB SAVEIT JMP COPYCH QUIT LDA VSTR,* fetch count & return it PRTN * * SAVEIT --- stash character in A into next open space in target * resulting word is always zero filled * SAVEIT EQU * STA CHAR LDA FLAG BNE EVENCH LT set flag for 2nd char STA FLAG LDA CHAR ICA store as first char in target word STA VSTR,*Y IRS VSTR,* add 1 to count RCB JMP% XB%+0 go back for more EVENCH EQU * CRA set flag for 1st char STA FLAG LDA CHAR ORA VSTR,*Y pack char STA VSTR,*Y and stash it IRS VSTR,* add 1 to count & set 1st char flag RCB TYA CAS LEN used all available space? JMP# QUIT JMP# QUIT A1A TAY JMP% XB%+0 go back for more * * GETNXT --- get next character into A * if B < 0 then tap source, else use char in B * GETNXT EQU * CRA S1A IAB if B >= 0 then BGE GOTIT LDA PSTR,*X get next 2 chars TAB CAL IAB second in B, ICL first in A IRX set for next fetch GOTIT JMP% XB%+0 END #HD#: putch.r 105 Nov-27-1984 01:11:23 # putch --- put a character on a file integer function putch (c, fd) character c filedes fd integer putlin character buf (2) buf (1) = c; buf (2) = EOS return (putlin (buf, fd)) end #HD#: putdec.r 174 Nov-27-1984 01:11:23 # putdec --- put decimal integer n in field width >= w subroutine putdec (n, w, unit) integer n, w, unit character chars (20) integer itoc integer i, nd nd = itoc (n, chars, 20) for (i = nd + 1; i <= w; i += 1) call putch (' 'c, unit) for (i = 1; i <= nd; i += 1) call putch (chars (i), unit) return end #HD#: putlin.r 433 Nov-27-1984 01:11:24 # putlin --- put a line on a file integer function putlin (line, fd) character line (ARB) filedes fd include SWT_COMMON integer f, off integer dputl$, tputl$, mapsu f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_WRITE) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) select (Fd_dev (off)) when (DEV_TTY) { if (LASTOP (off) ~= FD_PUTLIN) { call flush$ (f) SET_LASTOP (off, FD_PUTLIN) } return (tputl$ (line, off)) } when (DEV_DSK) { if (LASTOP (off) ~= FD_PUTLIN) { call flush$ (f) Fd_count (off) = -Fd_buflen (off) SET_LASTOP (off, FD_PUTLIN) } return (dputl$ (line, Fdesc (off))) } when (DEV_NULL) { if (LASTOP (off) ~= FD_PUTLIN) { call flush$ (f) SET_LASTOP (off, FD_PUTLIN) } return (0) } else return (ERR) end #HD#: putlit.r 126 Nov-27-1984 01:11:24 # putlit --- write literal string on specified unit subroutine putlit (msg, delim, unit) integer msg (ARB), unit character delim character str (MAXLINE) call ptoc (msg, delim, str, MAXLINE) call putlin (str, unit) return end #HD#: readf.r 339 Nov-27-1984 01:11:24 # readf --- read raw words from a file integer function readf (buf, nw, fd) integer buf (ARB), nw filedes fd include SWT_COMMON integer off, f integer mapsu, tread$, dread$ f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_READ) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) if (nw <= 0) return (0) if (LASTOP (off) ~= FD_READF) { call flush$ (f) SET_LASTOP (off, FD_READF) } select (Fd_dev (off)) when (DEV_TTY) readf = tread$ (buf, nw, off) when (DEV_DSK) readf = dread$ (buf, nw, off) when (DEV_NULL) readf = EOF else readf = ERR return end #HD#: remark.r 140 Nov-27-1984 01:11:24 # remark --- print quoted string on ERROUT subroutine remark (msg) integer msg (ARB) if (and (msg (1), :177400) == 0 || msg (1) == EOS) # unpacked? call putlin (msg, ERROUT) else call putlit (msg, '.'c, ERROUT) call putch (NEWLINE, ERROUT) return end #HD#: remove.r 163 Nov-27-1984 01:11:24 # remove --- remove a file, return status integer function remove (path) character path (ARB) integer fname (16), attach, j1 (3), code integer getto, rmfil$ remove = ERR if (getto (path, fname, j1, attach) ~= ERR) remove = rmfil$ (fname) if (attach == YES) call at$hom (code) return end #HD#: reonu$.s 511 Nov-27-1984 01:11:24 * reonu$ --- on-unit for the REENTER$ condition SUBR REONU$ SEG RLIT LINK REONU$ ECB REENTER,,CFP,1 DATA 6,C'REONU$' PROC DYNM =20,CFP(3) DYNM TARGET(4) FRAME_PB EQU 2 Offset of return address FRAME_SB EQU 4 Offset of previous stack frame address TARGET_PB EQU TARGET TARGET_SB EQU TARGET+2 REENTER ARGT BLEQ PRTN_ Make sure we're passed a static link ANA ='7777 Mask out ring bits STL TARGET_SB Save locally EAXB SB% Point XB at our frame VLOOP EAXB XB%+FRAME_SB,* Point XB at caller's frame LDL XB%+FRAME_SB Check for end of stack... CLS NULL ...signified by null return SB JMP# *+2 PRTN_ PRTN Target not found, can't reenter ANA ='7777 Mask out ring bits ERL TARGET_SB See if he returns to target frame... BLNE VLOOP ...if not, check previous frame LDL XB%+FRAME_PB Construct a label for non-local goto IAB STL TARGET_PB CALL PL1$NL AP TARGET,SL NULL DATA '7777,0 Null pointer END #HD#: rewind.r 75 Nov-27-1984 01:11:24 # rewind --- position to beginning-of-file integer function rewind (fd) integer fd integer seekf return (seekf (intl (0), fd)) end #HD#: rmfil$.r 395 Nov-27-1984 01:11:25 # rmfil$ --- remove a file, return status integer function rmfil$ (name) integer name (MAXPACKEDFNAME) include SWT_COMMON integer fd, code, type character vname (MAXVARYFNAME) call srch$$ (KCLOS, name, 32, 0, 0, code) call srch$$ (KDELE, name, 32, 0, 0, Errcod) if (Errcod == EDNTE) { # non-empty directory, see if segdir call srch$$ (KRDWR + KGETU, name, 32, fd, type, code) if (code == 0) { if (type == 2 || type == 3) call rmseg$ (fd) call srch$$ (KCLOS, 0, 0, fd, 0, code) call srch$$ (KDELE, name, 32, 0, 0, Errcod) } } elif (Errcod == EIACL) { # access category, deletes differently call ptov (name, ' 'c, vname, MAXVARYFNAME) call cat$dl (vname, Errcod) } rmfil$ = ERR if (Errcod == 0) rmfil$ = OK return end #HD#: rmseg$.r 320 Nov-27-1984 01:11:25 # rmseg$ --- remove a segment directory subroutine rmseg$ (fd) integer fd integer entrya, entryb, fd, fd2, junk, code entryb = -1 repeat { entrya = entryb + 1 call sgdr$$ (KFULL, fd, entrya, entryb, code) if (entryb == -1 || code ~= 0) break call srch$$ (KDELE + KISEG, fd, 0, 0, 0, code) if (code == EDNTE) { # non-empty nested segdir call srch$$ (KRDWR + KISEG + KGETU, fd, 0, fd2, junk, code) if (code == 0) call rmseg$ (fd2) call srch$$ (KCLOS, 0, 0, fd2, junk, code) call srch$$ (KDELE + KISEG, fd, 0, 0, junk, code) } } call sgdr$$ (KMSIZ, fd, 0, entryb, code) return end #HD#: rmtabl.r 214 Nov-27-1984 01:11:25 # rmtabl --- remove a symbol table, deleting all entries subroutine rmtabl (st) pointer st integer Mem (1) common /ds$mem/ Mem integer i pointer walker, bucket, node bucket = st do i = 1, ST_HTABSIZE; { bucket = bucket + 1 walker = Mem (bucket) while (walker ~= LAMBDA) { node = walker walker = Mem (node + ST_LINK) call dsfree (node) } } call dsfree (st) return end #HD#: rmtemp.r 128 Nov-27-1984 01:11:25 # rmtemp --- rewind, truncate, and close a temporary made by mktemp integer function rmtemp (fd) integer fd integer close call rewind (fd) call trunc (fd) if (close (fd) == ERR) rmtemp = ERR else rmtemp = OK return end #HD#: rtn$$.s 272 Nov-27-1984 01:11:25 * rtn$$ --- return to frame indicated in RTLABEL SUBR RTN$$ SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" include "=incl=/temp_com.s.i" LINK RTN$$ ECB RTN0 DATA 5,C'RTN$$' PROC DYNM =20 CLDATA$FLAGS EQU XB% + 6 RTN0 EAXB CLDATAPTR EAXB XB%,* LDA CLDATA$FLAGS ANA ='020000 Was I run by DBG? BNE MUSTEXIT If I was I must exit CALL PL1$NL Not run by DBG AP RTLABEL,SL just return to the shell MUSTEXIT CALL EXIT END #HD#: rtoc.r 134 Nov-27-1984 01:11:25 # rtoc --- convert single precision real to string integer function rtoc (val, str, w, d) real val character str (ARB) integer w, d integer dtoc longreal fval fval = val # convert to double precision return (dtoc (fval, str, w, d)) end #HD#: scopy.s 337 Nov-27-1984 01:11:26 * scopy --- copy a string at from(i) to to(j) * * integer function scopy (from, i, to, j) * character from (ARB), to (ARB) * integer i, j SUBR SCOPY SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK SCOPY ECB SCOPY$,,FROM,4 DATA 5,C'SCOPY' PROC DYNM =20,FROM(3),I(3),TO(3),J(3) SCOPY$ ARGT ENTR SCOPY LDX I,* XB := FROM+I-1 EAXB FROM,*X LDX J,* LB := TO+J-1 EALB TO,*X LDX =0 LOOP LDA XB%-1,X (SB+x)^ := (LB+X)^ STA LB%-1,X CAS =EOS if (LB+X)^ = EOS then JMP *+2 goto OUT JMP OUT BIX LOOP X := X + 1; goto LOOP OUT TXA return X PRTN END #HD#: sctabl.r 595 Nov-27-1984 01:11:26 # sctabl --- scan symbol table, returning next entry or EOF integer function sctabl (table, sym, info, posn) pointer table, posn character sym (ARB) integer info (ARB) integer Mem (1) common /ds$mem/ Mem pointer bucket, walker pointer dsget integer nodesize, i if (posn == 0) { # just starting scan? posn = dsget (2) # get space for position info Mem (posn) = 1 # get index of first bucket Mem (posn + 1) = Mem (table + 1) # get pointer to first chain } bucket = Mem (posn) # recover previous position walker = Mem (posn + 1) nodesize = Mem (table) repeat { # until the next symbol, or none are left if (walker ~= LAMBDA) { # symbol available? call scopy (Mem, walker + ST_DATA + nodesize, sym, 1) for (i = 1; i <= nodesize; i += 1) info (i) = Mem (walker + ST_DATA + i - 1) Mem (posn) = bucket # save position of next symbol Mem (posn + 1) = Mem (walker + ST_LINK) sctabl = 1 # not EOF return } else { bucket = bucket + 1 if (bucket > ST_HTABSIZE) break walker = Mem (table + bucket) } } call dsfree (posn) # throw away position information posn = 0 sc_tabl = EOF return end #HD#: sdrop.r 188 Nov-27-1984 01:11:26 # sdrop --- drop characters from a string APL-style integer function sdrop (from, to, chars) character from (ARB), to (ARB) integer chars integer len integer ctoc, scopy, length len = length (from) if (chars < 0) return (ctoc (from, to, len + chars + 1)) else { if (chars < len) len = chars return (scopy (from, len + 1, to, 1)) } end #HD#: seekf.r 350 Nov-27-1984 01:11:26 # seekf --- position a file to a designated word integer function seekf (pos, fd, xra) filemark pos filedes fd integer xra include SWT_COMMON filedes f filedes mapsu integer off, ra integer tseek$, dseek$ logical missin f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_ERR) ~= 0 || Fd_flags (off) == 0) return (ERR) if (missin (xra)) ra = ABS else ra = xra call flush$ (f) Fd_flags (off) &= not (FD_EOF) select (Fd_dev (off)) when (DEV_TTY) return (tseek$ (pos, off, ra)) when (DEV_DSK) return (dseek$ (pos, off, ra)) when (DEV_NULL) return (EOF) return (ERR) end #HD#: seterr.r 74 Nov-27-1984 01:11:26 # seterr --- set the error return code subroutine seterr (stat) integer stat include SWT_COMMON Cmd_stat = stat return end #HD#: sfdata.r 2619 Nov-27-1984 01:11:26 # sfdata --- set file information integer function sfdata (key, xpath, infobuf, attach_sw, auxil) integer key, attach_sw character xpath (ARB) integer infobuf (ARB), auxil (ARB) integer getto, parsa$, index, equal, expand include SWT_COMMON include ACL_COMMON integer sarr (2) integer name (16), pathname (MAXPATH) integer junk (MAXTREE), junk2 (MAXTREE), vtree (129), ppwd (3) integer i, j, isacat long_int qbuf (8) procedure do_getto forward procedure do_protect forward procedure find_isacat forward procedure make_tree forward attach_sw = NO Errcod = 0 if (expand (xpath, pathname, MAXPATH) == ERR) return (ERR) select (key) when (FILE_UFDQUOTA) { make_tree call q$set (KSMAX, vtree, infobuf, Errcod) if (Errcod == EQEXC) Errcod = 0 } when (FILE_TYPE) return (ERR) # Cannot change a file type! when (FILE_DMBITS) { do_getto call satr$$ (KDMPB, name, 32, sarr, Errcod) } when (FILE_RWLOCK) { do_getto sarr (2) = 0 if (equal (infobuf, "n-1"s) == YES) sarr (1) = 1 elif (equal (infobuf, "sys"s) == YES) sarr (1) = 0 elif (equal (infobuf, "n+1"s) == YES) sarr (1) = 2 elif (equal (infobuf, "n+n"s) == YES) sarr (1) = 3 else return (ERR) call satr$$ (KRWLK, name, 32, sarr, Errcod) } when (FILE_TIMMOD) { do_getto sarr (1) = ls (mod (infobuf (1), 100), 9) sarr (1) |= ls (and (infobuf (2), 2r1111), 5) sarr (1) |= and (infobuf (3), 2r11111) sarr (2) = (infobuf (4)*60 + infobuf (5))*15 + infobuf (6)/4 call satr$$ (KDTIM, name, 32, sarr, Errcod) } when (FILE_ACL) { j = 1 find_isacat make_tree if (infobuf (1) == EOS && auxil (1) == EOS) { if (isacat == NO) call ac$dft (vtree, Errcod) else call cat$dl (vtree, Errcod) } elif (infobuf (1) == EOS) { j = 2 find_isacat if (isacat == NO) { call expand (auxil, junk2, MAXTREE) call mktr$ (junk2, junk) if (index (junk, ">"c) == 0) return (ERR) i = 1 call ctov (junk, i, junk2, MAXTREE) call ac$lik (vtree, junk2, Errcod) } else { i = 1 call ctov (auxil, i, junk2, MAXTREE) call ac$cat (vtree, junk2, Errcod) } } elif (auxil (1) == EOS) { if (gtacl$ (pathname, 1, attach_sw) == ERR) return (ERR) elif (parsa$ (infobuf) == ERR) return (ERR) else { call mkpacl if (index (junk, ">"c) == 0) do_getto call ac$set (KANY, vtree, loc (Primos_acl), Errcod) } } else { call expand (auxil, junk2, MAXTREE) if (gtacl$ (junk2, 1, attach_sw) == ERR) return (ERR) elif (parsa$ (infobuf) == ERR) return (ERR) else { call mkpacl if (index (junk, ">"c) == 0) do_getto call ac$set (KANY, vtree, loc (Primos_acl), Errcod) } } } when (FILE_ACCESS) return (ERR) # not defined -- can only set ACL when (FILE_PRIORITYACL) { i = 1 call ctov (infobuf, i, vtree, 129) if (auxil (1) == EOS) call pa$del (vtree, Errcod) else { call gtacl$ (EOS, 1, i) if (parsa$ (auxil) == ERR) return (ERR) else { call mkpacl call pa$set (vtree, loc (Primos_acl), Errcod) } } } when (FILE_DELSWITCH) { do_getto if (infobuf (1) == YES) sarr (1) = 1 else sarr (1) = 0 call satr$$ (KSDL, name, 32, sarr, Errcod) } when (FILE_SIZE) return (ERR) # like, fer sure when (FILE_FULL_INFO) return (ERR) # not defined when (FILE_PROTECTION) { do_getto do_protect } when (FILE_PASSWORDS) { attach_sw = YES if (follow (pathname, 0) == ERR) return (ERR) i = 1 call ctop (infobuf, i, junk, 3) i = 1 call ctop (auxil, i, junk2, 3) call spas$$ (junk, junk2, Errcod) } ifany { if (attach_sw == YES) call at$hom(i) if (Errcod ~= 0) return (ERR) else return (OK) } else return (ERR) # bad key procedure do_getto { if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) } procedure do_protect { local owner_bits, non_owner_bits, owner, prot integer owner_bits (4), non_owner_bits (4), owner, prot (2) string permissions "twra" data owner_bits / :2000, :1000, :400, :3400 / data non_owner_bits / :4, :2, :1, :7 / prot (1) = 0 # default --- no permissions for owner or nonowner prot (2) = 0 owner = YES for (i = 1; infobuf (i) ~= EOS; i += 1) if (infobuf (i) == '/'c) owner = NO else { j = index (permissions, infobuf (i)) if (j < 1) # illegal protection key return (ERR) if (owner == YES) prot (1) |= owner_bits (j) else prot (1) |= non_owner_bits (j) } call satr$$ (KPROT, name, 32, prot, Errcod) } procedure find_isacat { local buffer, suffix, meow character buffer (MAXPATH), suffix (7) integer meow if (j == 1) call ctoc (pathname, buffer, MAXPATH) else call ctoc (auxil, buffer, MAXPATH) for (meow = 1; buffer (meow) ~= EOS; meow += 1) continue if (meow < 7) isacat = NO else { meow -= 5 call ctoc (buffer (meow), suffix, 7) call mapstr (suffix, LOWER) isacat = equal (".acat"s, suffix) } } procedure make_tree { local i integer i call mktr$ (pathname, junk) i = 1 call ctov (junk, i, vtree, 129) if (index (junk, ">"c) == 0) do_getto } end #HD#: sprot$.r 538 Nov-27-1984 01:11:27 # sprot$ --- set protection attributes for a file integer function sprot$ (name, attr) character name (ARB), attr (ARB) include SWT_COMMON string permissions "twra" integer owner_bits (4), non_owner_bits (4) # 4 = length (permissions) integer i, j, owner, packed_name (16), code, prot (2), junk (3) integer attach, index, getto data owner_bits / :2000, :1000, :400, :3400 / data non_owner_bits / :4, :2, :1, :7 / prot (1) = 0 # default --- no permissions for owner or nonowner prot (2) = 0 sprot$ = ERR # guilty before trial owner = YES for (i = 1; attr (i) ~= EOS; i += 1) if (attr (i) == '/'c) owner = NO else { j = index (permissions, attr (i)) if (j < 1) # illegal protection key return if (owner == YES) prot (1) |= owner_bits (j) else prot (1) |= non_owner_bits (j) } if (getto (name, packed_name, junk, attach) == ERR) return call satr$$ (KPROT, packed_name, 32, prot, Errcod) if (attach ~= NO) call at$hom (code) if (Errcod == 0) sprot$ = OK return end #HD#: st$lu.r 311 Nov-27-1984 01:11:27 # st$lu --- symbol table lookup primitive integer function st$lu (symbol, node, pred, st) character symbol (ARB) pointer node, pred, st integer Mem (1) common /ds$mem/ Mem integer hash, i, nodesize integer equal nodesize = Mem (st) hash = 0 for (i = 1; symbol (i) ~= EOS; i += 1) hash += symbol (i) hash = mod (iabs (hash), ST_HTABSIZE) + 1 pred = st + hash node = Mem (pred) while (node ~= LAMBDA) { if (equal (symbol, Mem (node + ST_DATA + nodesize)) == YES) { st$lu = YES return } pred = node node = Mem (pred + ST_LINK) } st$lu = NO return end #HD#: stake.r 189 Nov-27-1984 01:11:27 # stake --- take characters from a string APL-style integer function stake (from, to, chars) character from (ARB), to (ARB) integer chars integer len integer length, ctoc, scopy len = length (from) if (chars < 0) { len += chars if (len < 0) len = 0 return (scopy (from, len + 1, to, 1)) } else return (ctoc (from, to, chars + 1)) end #HD#: stclos.r 312 Nov-27-1984 01:11:27 # stclos --- insert closure entry at pat (j) integer function stclos (pat, j, lastj, lastcl) character pat (MAXPAT) integer j, lastj, lastcl integer addset integer jp, jt, junk for (jp = j - 1; jp >= lastj; jp -= 1) { # make a hole jt = jp + PAT_CLOSIZE junk = addset (pat (jp), pat, jt, MAXPAT) } j += PAT_CLOSIZE stclos = lastj junk = addset (PAT_CLOSURE, pat, lastj, MAXPAT) # put closure in it junk = addset (0, pat, lastj, MAXPAT) # PAT_COUNT junk = addset (lastcl, pat, lastj, MAXPAT) # PAT_PREVCL junk = addset (0, pat, lastj, MAXPAT) # PAT_START return end #HD#: strbsr.r 251 Nov-27-1984 01:11:27 # strbsr --- perform a binary search of a string table integer function strbsr (pos, tab, offs, object) integer pos (ARB), offs character tab (ARB), object (ARB) integer i, j, k integer strcmp i = 2 j = pos (1) + 1 # length is first entry in position array repeat { k = (i + j) / 2 select (strcmp (tab (pos (k) + offs), object)) when (1) i = k + 1 # LESS when (2) return (k) # EQUALS when (3) j = k - 1 # GREATER } until (i > j) return (EOF) end #HD#: strcmp.r 211 Nov-27-1984 01:11:28 # strcmp --- compare two strings and return 1 2 or 3 for < = or > integer function strcmp (str1, str2) character str1 (ARB), str2 (ARB) integer i for (i = 1; str1 (i) == str2 (i); i += 1) if (str1 (i) == EOS) return (2) select when (str1 (i) == EOS || str1 (i) < str2 (i)) return (1) when (str2 (i) == EOS || str1 (i) > str2 (i)) return (3) return (2) # should never happen end #HD#: strim.r 141 Nov-27-1984 01:11:28 # strim --- trim trailing blanks and tabs from a string integer function strim (str) character str (ARB) integer lnb, i lnb = 0 for (i = 1; str (i) ~= EOS; i += 1) if (str (i) ~= ' 'c && str (i) ~= TAB) lnb = i str (lnb + 1) = EOS return (lnb) end #HD#: strlsr.r 195 Nov-27-1984 01:11:28 # strlsr --- perform a linear search of a string table integer function strlsr (pos, tab, offs, object) integer pos (ARB), offs character tab (ARB), object (ARB) integer i, j integer strcmp j = pos (1) + 1 # length is first entry in position array for (i = 2; i <= j; i += 1) if (strcmp (object, tab (pos (i) + offs)) == 2) return (i) return (EOF) end #HD#: substr.r 256 Nov-27-1984 01:11:28 # substr --- slice a substring from a string integer function substr (from, to, first, chars) character from (ARB), to (ARB) integer first, chars integer len, i, j, k integer length len = length (from) i = first if (i < 1) i += len + 1 if (chars < 0) { i += chars + 1 chars = - chars } j = i + chars - 1 if (i < 1) i = 1 if (j > len) j = len for (k = 0; i <= j; {k += 1; i += 1}) to (k + 1) = from (i) to (k + 1) = EOS return (k) end #HD#: swt.r 60 Nov-27-1984 01:11:28 # swt --- return to the Subsystem command interpreter subroutine swt call rtn$$ # never returns here end #HD#: sys$$.s 1389 Nov-27-1984 01:11:28 * sys$$ --- pass a command string to PRIMOS for execution SUBR SYS$$ SEG RLIT include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" LINK SYS$$ ECB SYS0,,CMD,2,189 DATA 5,C'SYS$$' PROC DYNM =38,CMD(3),FD(3) DYNM I,STATUS,F,TEMP,OLD_CU,CODE,DESCR(4),ARGS(6) DYNM COMMAND(128) EXT MKONU$ SYS0 ARGT ENTR SYS$$ LT i = 1 STA I CALL CTOV call ctov (cmd, i, command, 128) AP CMD,*S AP I,S AP COMMAND,S AP =128,SL CRA status = 0 STA STATUS LDA COMUNIT old_cu = Comunit STA OLD_CU CALL BREAK$ Disable breaks AP =DISABLE,SL LDA FD,* if (fd == ERR) # Don't change comi$$ ERA =ERR goto l2 BEQ L2 CALL MAPFD f = mapfd (fd) AP FD,*SL BLE L1 if (f <= 0) STA F goto l1 CALL MAPSU call flush$ (mapsu (fd)) AP FD,*SL STA TEMP CALL FLUSH$ AP TEMP,SL LDA F Comunit = f STA COMUNIT call comi$$ ("CONTIN", 6, f, code) CALL COMI$$ AP =C'CONTIN',S AP =6,S AP F,S AP CODE,SL JMP L2 goto l2 L1 CRA Comunit = 0 LDA COMUNIT call comi$$ ("PAUSE", 5, 0, code) CALL COMI$$ AP =C'PAUSE',S AP =5,S AP =0,S AP CODE,SL L2 EAL CLEANUP_ call mkonu$ to set up CLEANUP$ unit STL DESCR EAL SB% STL DESCR+2 EAL CLEANUP$ STL ARGS EAL DESCR STL ARGS+3 EAL ARGS JSXB MKONU$ CALL BREAK$ OK to reenable breaks now AP =ENABLE,SL CALL CP$ Pass command line to PRIMOS AP COMMAND,S AP I,S AP STATUS,SL LDA OLD_CU Comunit = old_cu STA COMUNIT BEQ L3 If (Comunit == 0) * goto l3 CALL COMI$$ call comi$$ ("CONTIN", 6, old_cu, code) AP =C'CONTIN',S AP =6,S AP OLD_CU,S AP CODE,SL JMP L4 goto l4 L3 CALL COMI$$ call comi$$ ("PAUSE", 5, 0, code) AP =C'PAUSE',S AP =5,S AP =0,S AP CODE,SL L4 LDA I if (i == 0) BEQ L5 goto l5 ERA =E$NCOM if (i == E$NCOM) BNE L6 goto l6 L5 LDA STATUS if (status > 0) BGT L6 goto l6 LDA =OK return (OK) PRTN L6 LDA =ERR return (ERR) PRTN CLEANUP$ DATA 8,C'CLEANUP$' EJCT * cleanup_ --- CLEANUP$ handler for sys$$ LINK CLEANUP_ ECB CLEANUP0,,CP,1,14 PROC DYNM =10,CP(3) DYNM RC CLEANUP0 ARGT STLR PB%+15 Save static link in XB LDA OLD_CU-SB%+XB% Comunit = old_cu STA COMUNIT if (Comunit == 0) BEQ L10 goto l10 CALL COMI$$ call comi$$ ("CONTIN", 6, Comunit, rc) AP =C'CONTIN',S AP =6,S AP COMUNIT,S AP RC,SL PRTN return L10 CALL COMI$$ call comi$$ ("PAUSE", 5, 0, rc) AP =C'PAUSE',S AP =5,S AP =0,S AP RC,SL PRTN return END #HD#: szfil$.r 252 Nov-27-1984 01:11:29 # szfil$ --- find number of records in a file longint function szfil$ (fd) integer fd include LIBRARY_DEFS include SWT_COMMON include PRIMOS_KEYS integer junk longint size define (BIGVALUE, :17777777) repeat call prwf$$ (KPOSN + KPRER, fd, loc (0), 0, BIG_VALUE, junk, Errcod) until (Errcod ~= 0) if (Errcod ~= EEOF) # encountered some error besides EOF return (ERR) call prwf$$ (KRPOS, fd, loc (0), 0, size, junk, Errcod) return (size) end #HD#: szseg$.r 541 Nov-27-1984 01:11:29 # szseg$ --- find number of records in a segment directory subroutine szseg$ (size, fd) longint size integer fd include LIBRARY_DEFS include SWT_COMMON include PRIMOS_KEYS integer entry_a, entry_b, nfd, ntype longint temp longint szfil$ size = ERR call sgdr$$ (KGOND, fd, entry_a, entry_b, Errcod) call sgdr$$ (KSPOS, fd, 0, entry_a, Errcod) if (Errcod ~= 0) return if (entry_b == 0) size = 1 else size = entry_b ### now size the contents of the segment directory: entry_b = -1 repeat { entry_a = entry_b + 1 call sgdr$$ (KFULL, fd, entry_a, entry_b, Errcod) if (entry_b == -1 || Errcod ~= 0) break call srch$$ (KREAD + KGETU + KISEG, fd, 0, nfd, ntype, Errcod) if (Errcod ~= 0) { size = ERR return } select (ntype) when (0, 1) # SAM or DAM file temp = szfil$ (nfd) when (2, 3) # SAM or DAM segment directory call szseg$ (temp, nfd) if (temp == ERR) { size = ERR return } else size += temp call srch$$ (KCLOS, 0, 0, nfd, 0, Errcod) } return end #HD#: t$clup.r 295 Nov-27-1984 01:11:29 # t$clup --- profiling routine called on program exit subroutine t$clup integer numrtn, sp longint record (4, 1), stack (4, 1) common /t$prof/ numrtn, record common /t$stak/ sp, stack integer i, code, fd integer create string profile "_profile" while (sp > 1) call t$exit # clean up in case exit was not from main call at$hom (code) # attach to home directory fd = create (profile, WRITE) if (fd == ERR) call cant (profile) for (i = 1; i <= numrtn; i += 1) call writef (record (1, i), 8, fd) call close (fd) return end #HD#: t$entr.r 419 Nov-27-1984 01:11:29 # t$entr --- profiling routine called on subprogram entry subroutine t$entr (routine) integer routine integer numrtn, sp longint stack (4, 1), record (4, 1) common /t$prof/ numrtn, record common /t$stak/ sp, stack integer i, j longint cpu, diskio, reel if (routine == 1) { # initializing; entering main program for (i = 1; i <= numrtn; i += 1) for (j = 1; j <= 4; j += 1) record (j, i) = 0 sp = 1 } if (sp > numrtn) { call tnou ('Stack overflow in profiler (t$entr)', 35) call swt } call t$time (reel, cpu, diskio) stack (1, sp) = routine # routine number stack (2, sp) = reel # real time clock stack (3, sp) = cpu # CPU time accumulator stack (4, sp) = diskio # diskio time accumulator record (1, routine) += 1 # number of calls sp += 1 return end #HD#: t$exit.r 316 Nov-27-1984 01:11:29 # t$exit --- profiling routine called on subprogram exit subroutine t$exit integer numrtn, sp longint stack (4, 1), record (4, 1) common /t$prof/ numrtn, record common /t$stak/ sp, stack longint reel, cpu, diskio integer routine, i call t$time (reel, cpu, diskio) sp -= 1 reel -= stack (2, sp) cpu -= stack (3, sp) diskio -= stack (4, sp) routine = stack (1, sp) record (2, routine) += reel record (3, routine) += cpu record (4, routine) += diskio for (i = sp - 1; i >= 1; i -= 1) { stack (2, i) += reel stack (3, i) += cpu stack (4, i) += diskio } return end #HD#: t$time.r 222 Nov-27-1984 01:11:30 # t$time --- profiling routine called to obtain current clock readings subroutine t$time (reel, cpu, diskio) longint reel, cpu, diskio integer time (28) call timdat (time, 28) # get various times from system reel = intl (time (4)) * 60 * time (11) + _ intl (time (5)) * time (11) + _ time (6) cpu = intl (time (7)) * time (11) + _ time (8) diskio = intl (time (9)) * time (11) + _ time (10) return end #HD#: t$trac.r 321 Nov-27-1984 01:11:30 # t$trac --- trace subroutine for Ratfor programs subroutine t$trac (mode, name) integer mode character name integer level, i data level / 0 / select (mode) when (1) { for (i = 1; i <= level & level <= 40; i += 1) { call putch ('|'c, ERROUT) call putch (' 'c, ERROUT) call putch (' 'c, ERROUT) } call print (ERROUT, "*p {*n"p, name) level += 1 } when (2) { level -= 1 for (i = 1; i <= level & level <= 40; i += 1) { call putch ('|'c, ERROUT) call putch (' 'c, ERROUT) call putch (' 'c, ERROUT) } call print (ERROUT, "..}*n"p) } when (3) { level = 0 } return end #HD#: tcook$.r 2593 Nov-27-1984 01:11:30 # tcook$ --- read and cook a line from the terminal define(AFLAG,16r100) define(EFLAG,16r200) integer function tcook$ (ubuf, size, tbuf, tptr) character ubuf (ARB), tbuf (MAXTERMBUF) integer size, tptr include SWT_COMMON integer duplx$ character c, t integer uptr procedure fill_term_buf forward procedure get_char forward procedure get_escape forward procedure put_kill_resp forward procedure erase_char forward procedure display_line forward procedure put_char forward for (uptr = 1; uptr < size; {uptr += 1; tptr += 1}) { if (tbuf (tptr) == EOS) fill_term_buf ubuf (uptr) = tbuf (tptr) if (ubuf (uptr) == NEWLINE || ubuf (uptr) == EOS) { if (ubuf (uptr) == NEWLINE) { uptr += 1 tptr += 1 } break } } ubuf (uptr) = EOS for (uptr = 1; ubuf (uptr) ~= EOS; uptr += 1) { if (and (ubuf (uptr), EFLAG) ~= 0) ubuf (uptr) -= EFLAG if (Termattr (TA_UPPER_ONLY) == YES) if (and (ubuf (uptr), AFLAG) ~= 0) { ubuf (uptr) -= AFLAG c = or (ubuf (uptr), 16r80) select when (c == "("c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("{"c, 16r7f)) when (c == ")"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("}"c, 16r7f)) when (c == "!"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("|"c, 16r7f)) when (c == "_"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("~"c, 16r7f)) when (c == "'"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("`"c, 16r7f)) } else { c = or (ubuf (uptr), 16r80) select when (c >= "a"c && c <= "z"c) ubuf (uptr) = ubuf (uptr) - "a"c + "A"c when (c >= "A"c && c <= "Z"c) ubuf (uptr) = ubuf (uptr) - "A"c + "a"c } } return (uptr - 1) # fill_term_buf --- fill the terminal buffer with cooked input procedure fill_term_buf { local i; integer i tptr = 1 tbuf (tptr) = EOS for (i = 1; i < MAXTERMBUF; i += 1) { get_char if (and (c, AFLAG) ~= 0) t = c - AFLAG else t = c select when (t == Escchar) { get_escape tbuf (i) = c } when (t == Kchar) { put_kill_resp uptr = 1 i = 0 } when (t == Echar) { if (t ~= c) call t1ou (Echar) if (i > 1) { i -= 1 t = tbuf (i) } else if (uptr > 1) { uptr -= 1 t = ubuf (uptr) } else t = 0 erase_char i -= 1 } when (t == Rtchar) { put_kill_resp display_line i -= 1 } when (t == Eofchar) { if (i > 1 || uptr > 1) put_kill_resp uptr = 1 i = 1 tbuf (i) = EOS break } when (t == Nlchar) { if (t ~= NEWLINE) call tonl tbuf (i) = NEWLINE tbuf (i + 1) = EOS break } else tbuf (i) = c tbuf (i + 1) = EOS } } # get_char --- read a character and convert case if necessary procedure get_char { call c1in (c) if (Termattr (TA_UPPER_ONLY) == YES && c == "@"c) { call c1in (c) if (c == Escchar) get_escape c += AFLAG } } # get_escape --- interpret and convert escape sequences procedure get_escape { local duplx; integer duplx duplx = duplx$ (-1) call duplx$ (or (duplx, -8r40000)) if (Escchar < " "c || Escchar > "~"c) call t1ou (NUL) else call t1ou (BS) call t1ou ("^"c) call c1in (c) select when ('0'c <= c && c <= '7'c) { t = ls (c - "0"c, 6) call c1in (c) t += ls (c - "0"c, 3) call c1in (c) c = t + c - "0"c } when (c == "/"c) { call t1ou (c) call c1in (c) c &= 16r7f } c += EFLAG put_char call duplx$ (duplx) } # put_kill_resp --- display the user's personal kill response procedure put_kill_resp { local i; integer i for (i = 1; Kill_resp (i) ~= EOS; i += 1) call t1ou (Kill_resp (i)) } # erase_char --- backspace over one character procedure erase_char { if (and (t, AFLAG) ~= 0) { call t1ou (Echar) t -= AFLAG } if (and (t, EFLAG) ~= 0) { t -= EFLAG if (t < 16r80) { call t1ou (Echar) t += 16r80 } if (t >= NUL && t <= US || t == DEL) call t1ou (Echar) call t1ou (Echar) } } # display_line --- display current terminal buffer procedure display_line { local p; integer p for (p = 1; p < uptr; p += 1) { c = ubuf (p) if (and (c, AFLAG) ~= 0) { call t1ou ("@"c) c -= AFLAG } if (and (c, EFLAG) ~= 0) { call t1ou ("^"c) if (c - EFLAG < 16r80) call t1ou ("/"c) } put_char } for (p = 1; tbuf (p) ~= EOS; p += 1) { c = tbuf (p) if (and (c, AFLAG) ~= 0) { call t1ou ("@"c) c -= AFLAG } if (and (c, EFLAG) ~= 0) { call t1ou ("^"c) if (c - EFLAG < 16r80) call t1ou ("/"c) } put_char } } # put_char --- display a single character procedure put_char { t = c if (and (t, EFLAG) ~= 0) { t -= EFLAG if (t < 16r80) t += 16r80 if (t >= NUL && t <= US || t == DEL) { call t1ou ("="c) if (t ~= DEL) call t1ou (t - NUL + "@"c) else call t1ou ("#"c) } else call t1ou (t) } else call t1ou (t) } end #HD#: tgetl$.r 117 Nov-27-1984 01:11:30 # tgetl$ --- return cooked data from the terminal integer function tgetl$ (buf, size, f) character buf (ARB) integer size, f include SWT_COMMON integer tcook$ return (tcook$ (buf, size, Termbuf, Termcp)) end #HD#: tmark$.r 63 Nov-27-1984 01:11:30 # tmark$ --- return the position of a terminal file (??) filemark function tmark$ (f) filedes f return (0) end #HD#: tputl$.r 890 Nov-27-1984 01:11:31 # tputl$ --- write one line to a cooked tty file integer function tputl$ (line, f) character line (ARB) integer f include SWT_COMMON integer i, bp, buf (MAXLINE) character c procedure putchar (ch) forward procedure outbuf forward bp = 0 for (i = 1; line (i) ~= EOS; i += 1) { c = or (16r80, line (i)) # get the character select (c) when (SET_OF_UPPER_CASE) { if (Term_attr (TA_UPPER_ONLY) == YES) putchar (ESCAPE) putchar (c) } when (SET_OF_LOWER_CASE) { if (Term_attr (TA_UPPER_ONLY) == YES) putchar (c - 'a'c + 'A'c) else putchar (c) } when (ESCAPE) { if (Term_attr (TA_UPPER_ONLY) == YES) putchar (ESCAPE) putchar (ESCAPE) } when ('{'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ('('c) } else putchar ('{'c) when ('}'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar (')'c) } else putchar ('}'c) when ('|'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ('!'c) } else putchar ('|'c) when ('`'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ("'"c) } else putchar ('`'c) when ('~'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ('_'c) } else putchar ('~'c) when (NEWLINE) { putchar (CR) putchar (LF) } else putchar (c) } outbuf return (i - 1) # outbuf --- put the buffer out to the terminal procedure outbuf { if (bp > 0) call tnoua (buf, bp) bp = 0 } # putchar --- put a character in the buffer procedure putchar (ch) { integer ch if (bp >= MAXLINE * 2) outbuf spchar (buf, bp, ch) } end #HD#: tquit$.r 130 Nov-27-1984 01:11:31 # tquit$ --- routine to interrogate break flag and dump buffer logical function tquit$ (flag) logical flag integer code call quit$ (flag) if (flag) { call tty$rs (:140000, code) call t1ou (NEWLINE) } tquit$ = flag return end #HD#: tread$.r 157 Nov-27-1984 01:11:31 # tread$ --- read raw words from terminal integer function tread$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer i for (i = 0; i < nw; i += 1) { call c1in (buf (i + 1)) if (buf (i + 1) == NEWLINE || buf (i + 1) == ETX) { i += 1 break } } return (i) end #HD#: trunc.r 296 Nov-27-1984 01:11:31 # trunc --- truncate a file integer function trunc (fd) filedes fd include SWT_COMMON filedes f filedes mapsu integer off f = mapsu (fd) if (f < 1 || f > NFILES) return (ERR) off = fd_offset (f) if (and (Fd_flags (off), FD_WRITE) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) call flush$ (f) select (Fd_dev (off)) when (DEV_TTY) return (OK) when (DEV_DSK) { call prwf$$ (KTRNC, Fd_unit (off), loc (0), 0, intl (0), 0, Errcod) if (Errcod == 0) return (OK) } when (DEV_NULL) return (OK) return (ERR) end #HD#: tscan$.r 2359 Nov-27-1984 01:11:31 # tscan$ --- traverse tree in the file system integer function tscan$ (path, buf, clev, nlev, action) integer buf (MAXDIRENTRY), clev, nlev, action character path (MAXPATH) include SWT_COMMON integer type, code, i, l, pwd (3), opwd (3), npwd (3) integer follow, ctoc, expand, equal, upkfn$ procedure check_postorder forward procedure reattach forward procedure enter_pwd forward procedure enter_info forward procedure fix_path forward Ts_at = NO # no reattach done on this call, yet if (clev == 0) { # first call, initialize everything ### Set up the state vectors if (expand ("=GaTech="s, Ts_path, MAXPATH) == ERR || equal (Ts_path, "yes"s) == NO) Ts_gt = NO else Ts_gt = YES clev = 1 Ts_ps (clev) = ctoc (path, Ts_path, MAXPATH) + 1 if (and (action, REATTACH) ~= 0) reattach ### Open the current directory for reading call srch$$ (KREAD + KGETU, KCURR, 0, Ts_un (clev), type, code) if (code ~= 0) { clev = 0 return (EOF) } call dir$rd (KINIT, Ts_un (clev), loc (buf), MAXDIRENTRY, code) Ts_state = GET_NEXT_ENTRY } repeat { select (Ts_state) when (DESCEND) { # descend to next level if (and (action, REATTACH) ~= 0 && (Ts_at == NO)) reattach if (clev >= nlev) { # are we at the limit? Ts_state = GET_NEXT_ENTRY check_postorder next } ### Attach to the new directory enter_pwd call at$swt (Ts_bf (2, clev), 32, 0, pwd, KICUR, code) if (code ~= 0) { Ts_state = COULDNT_DESCEND return (ERR) } clev += 1 ### Open it for reading call srch$$ (KREAD + KGETU, KCURR, 0, Ts_un (clev), type, code) if (code ~= 0) { Ts_state = ASCEND return (ERR) } Ts_state = GET_NEXT_ENTRY } when (COULDNT_DESCEND) { # couldn't descend into last dir if (Ts_at == NO) reattach Ts_state = GET_NEXT_ENTRY check_postorder } when (GET_NEXT_ENTRY) { # get next entry from this level if (and (action, REATTACH) ~= 0 && (Ts_at == NO)) reattach path (Ts_ps (clev)) = EOS call dir$rd (KREAD, Ts_un (clev), loc (buf), MAXDIRENTRY, code) if (code ~= 0) Ts_state = ATEOD elif (rs(buf(1),8) == 2 || rs(buf(1),8) == 3) { buf (1) = 0 # indicate preorder encounter fix_path if (and (buf (20), 8r10007) == 4) { # a ufd but not mfd enter_info # next time we're called, we will Ts_state = DESCEND # descend another level } if ( ~(and (buf (20), 7) == 4) # file type is NOT ufd || and (action, PREORDER) ~= 0) return (OK) } # else stay in this state } when (ATEOD) { # at end of directory if (and (action, REATTACH) ~= 0 && (Ts_at == NO)) reattach call srch$$ (KCLOS, 0, 0, Ts_un (clev), 0, code) Ts_state = ASCEND if (and (action, EODPAUSE) ~= 0) return (EOD) } when (ASCEND) { # pop up one level clev -= 1 if (clev <= 0) break reattach Ts_state = GET_NEXT_ENTRY check_postorder } else call error ("in tscan$: can't happen"s) } return (EOF) # check_postorder --- return entry on postorder encounter if desired procedure check_postorder { if (and (action, POSTORDER) ~= 0) { call move$ (Ts_bf (1, clev), buf, MAXDIRENTRY) buf (1) = 1 # indicate postorder encounter return (OK) } } # enter_pwd --- get password for next lower directory procedure enter_pwd { local valid_name; bool valid_name local junk; integer junk call gpas$$ (Ts_bf (2, clev), 32, opwd, npwd, code) call texto$ (opwd, 6, junk, valid_name) if (code == ENRIT) { pwd (1) = " " pwd (2) = " " pwd (3) = " " } elif (Ts_gt == YES && valid_name) { pwd (1) = npwd (1) pwd (2) = npwd (2) pwd (3) = npwd (3) } else { pwd (1) = opwd (1) pwd (2) = opwd (2) pwd (3) = opwd (3) } do i = 1, 3 Ts_pw (i, clev) = pwd (i) l = Ts_eos if (pwd (1) ~= " " && pwd (1) ~= 0) { path (l) = ':'c l += 1 + upkfn$ (pwd, 6, path (l + 1), MAXPATH - l) } Ts_ps (clev + 1) = l } # fix_path --- add name of current entry to pathname procedure fix_path { l = Ts_ps (clev) if (l > 1) { path (l) = '/'c l += 1 } l += upkfn$ (buf (2), 32, path (l), MAXPATH - l + 1) Ts_eos = l } # enter_info --- save info in current directory entry procedure enter_info { call move$ (buf, Ts_bf (1, clev), MAXDIRENTRY) } # reattach --- attach back to the same place procedure reattach { Ts_at = YES call at$hom (code) if (follow (Ts_path, 0) == ERR) { Ts_state = ATEOD return (ERR) } for (i = 1; i < clev; i += 1) { call at$swt (Ts_bf (2, i), 32, 0, Ts_pw (1, i), KICUR, code) if (code ~= 0) { Ts_state = ATEOD return (ERR) } } } end #HD#: tseek$.r 163 Nov-27-1984 01:11:32 # tseek$ --- seek on a terminal device (??) integer function tseek$ (pos, f, ra) longint pos integer f, ra include SWT_COMMON integer i character junk if (ra == ABS || pos < 0) return (ERR) # can't do this for a terminal for (i = 1; i <= pos; i += 1) call c1in (junk) return (OK) end #HD#: ttyp$f.r 366 Nov-27-1984 01:11:32 # ttyp$f --- obtain the terminal type from the 'terms' file integer function ttyp$f (ttype) character ttype (ARB) integer fd, pid, i, j integer open, ctoi, getlin, ttyp$v character str (MAXLINE) fd = open ("=termlist="s, READ) if (fd == ERR) { ttype (1) = EOS return (NO) } call date (SYS_PID, pid) # get the user's numeric process id ttype (1) = EOS while (getlin (str, fd) ~= EOF) { i = 1 j = ctoi (str (6), i) if (j == pid) { i = 11 SKIPBL (str, i) for (j = 1; i <= 16 && str (i) ~= EOS && str (i) ~= ' 'c; {i += 1; j += 1}) ttype (j) = str (i) ttype (j) = EOS break } } call close (fd) if (ttype (1) == EOS) return (NO) return (ttyp$v (ttype)) end #HD#: ttyp$l.r 466 Nov-27-1984 01:11:32 # ttyp$l --- list the available terminal types subroutine ttyp$l integer i, col integer input, length character ttype (MAXLINE), desc (MAXLINE) file_des fd file_des open define (MAXDESC, 25) procedure put forward call print (TTY, "Terminal types:*n"s) fd = open ("=ttypes="s, READ) if (fd == ERR) return col = 1 while (input (fd, "*s*,,,s"s, ttype, desc) ~= EOF) { i = 1 SKIPBL (desc, i) put } if (col ~= 1) call print (TTY, "*n"s) call close (fd) return # put --- put a terminal type out procedure put { if (col == 1) { call print (TTY, " *8,,.s.*#s "s, ttype, MAXDESC, desc (i)) if (length (desc (i)) > MAXDESC) call print (TTY, "*n"s) else col = 2 } else { if (length (desc (i)) > MAXDESC) call print (TTY, "*n"s) call print (TTY, " *8,,.s.*s*n"s, ttype, desc (i)) col = 1 } } undefine (MAXDEST) end #HD#: ttyp$q.r 391 Nov-27-1984 01:11:32 # ttyp$q --- obtain the terminal type from the user integer function ttyp$q (ttype, blankok) character ttype (ARB) integer blankok include SWT_COMMON integer i integer equal, input, ttyp$v character str (MAXLINE) while (input (TTY, "Enter terminal type: *s"s, str) ~= EOF) { call mapstr (str, LOWER) if (str (1) == EOS && blankok == YES) { do i = 1, MAXTERMATTR Term_attr (i) = NO Term_type (1) = EOS ttype (1) = EOS return (YES) } else if (equal (str, "?"s) == YES || equal (str, "help"s) == YES) call ttyp$l else if (ttyp$v (str) == YES) { call ctoc (str, ttype, MAXTERMTYPE) return (YES) } else call print (TTY, "Invalid terminal type; enter '?' for help.*n"s) } call print (TTY, "*n"s) return (NO) end #HD#: ttyp$r.r 157 Nov-27-1984 01:11:32 # ttyp$r --- get the terminal type from the common area integer function ttyp$r (ttype) character ttype (ARB) include SWT_COMMON integer chkstr if (chkstr (Termtype, MAXTERMTYPE) == NO) { ttype (1) = EOS return (NO) } call ctoc (Termtype, ttype, MAXTERMTYPE) return (YES) end #HD#: ttyp$v.r 350 Nov-27-1984 01:11:33 # ttyp$v --- check and set terminal type and attributes integer function ttyp$v (ttype) character ttype (ARB) include SWT_COMMON integer i, a (MAXTERMATTR) integer input, equal, ctoc character str (MAXLINE), junk (MAXLINE) file_des fd file_des open fd = open ("=ttypes="s, READ) if (fd == ERR) return (NO) ttyp$v = NO while (input (fd, "*s*,,,s*y*y*y*y*y*y"s, str, junk, a(1), a(2), a(3), a(4), a(5), a(6)) ~= EOF) if (equal (str, ttype) == YES) { call break$ (DISABLE) do i = 1, MAXTERMATTR Term_attr (i) = a (i) call ctoc (ttype, Term_type, MAXTERMTYPE) ttyp$v = YES call break$ (ENABLE) break } call close (fd) return end #HD#: twrit$.r 115 Nov-27-1984 01:11:33 # twrit$ --- write raw words to terminal integer function twrit$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer i for (i = 0; i < nw; i += 1) call t1ou (buf (i + 1)) return (i) end #HD#: type.r 284 Nov-27-1984 01:11:33 # type --- returns type of character character function type(c) character c select (c) when ('a'c, 'b'c, 'c'c, 'd'c, 'e'c, 'f'c, 'g'c, 'h'c, 'i'c, 'j'c, 'k'c, 'l'c, 'm'c, 'n'c, 'o'c, 'p'c, 'q'c, 'r'c, 's'c, 't'c, 'u'c, 'v'c, 'w'c, 'x'c, 'y'c, 'z'c, 'A'c, 'B'c, 'C'c, 'D'c, 'E'c, 'F'c, 'G'c, 'H'c, 'I'c, 'J'c, 'K'c, 'L'c, 'M'c, 'N'c, 'O'c, 'P'c, 'Q'c, 'R'c, 'S'c, 'T'c, 'U'c, 'V'c, 'W'c, 'X'c, 'Y'c, 'Z'c) type = LETTER when ('0'c, '1'c, '2'c, '3'c, '4'c, '5'c, '6'c, '7'c, '8'c, '9'c) type = DIGIT else type = c return end #HD#: upkfn$.r 263 Nov-27-1984 01:11:33 # upkfn$ --- unpack a file name; escape slashes integer function upkfn$ (name, len, str, max) integer name (ARB), len, max character str (ARB) integer l, cp character c character mapdn for ({l = 1; cp = 0}; l < max && cp < len; l += 1) { fpchar (name, cp, c) if (c == ' 'c) break if (c == '/'c || c == ESCAPE || c == '='c) { if (c == '='c) str (l) = c else str (l) = ESCAPE l += 1 if (l >= max) break } str (l) = mapdn (c) } str (l) = EOS return (l - 1) end #HD#: vfyusr.r 500 Nov-27-1984 01:11:33 # vfyusr --- function to see if a username really exists integer function vfyusr (user) character user (ARB) character key (MAXUSERNAME), line (MAXLINE) integer len integer ctoc, getlin, length, strcmp filedes fd filedes open if (length (user) >= MAXUSERNAME) # too long... don't bother testing return (ERR) fd = open ("=userlist="s, READ) if (fd == ERR) { call remark ("in vfyusr: can't read user list"p) return (ERR) } for (len = ctoc (user, key, MAXUSERNAME) + 1; len < MAXUSERNAME; len += 1) key (len) = ' 'c # pad with blanks to maximum length key (MAXUSERNAME) = EOS call mapstr (key, UPPER) vfyusr = ERR # assume the worst while (getlin (line, fd) ~= EOF) { line (MAXUSERNAME) = EOS # truncate line after login name select (strcmp (line, key)) when (2) { # name just read equals key vfyusr = OK break } # when (3) # name just read is greater than key # break } call close (fd) return end #HD#: vt$alc.r 209 Nov-27-1984 01:11:33 # vt$alc --- allocate another DFA table integer function vt$alc (tbl, c) integer tbl character c include SWT_COMMON integer i, j for (i = 1; i <= MAXESCAPE && Fn_used (i) == YES; i += 1) ; if (i > MAXESCAPE) # Is there enough room ?? return (ERR) Fn_used (i) = YES do j = 1, CHARSETSIZE Fn_tab (j, i) = EOS Fn_tab (c, tbl) = i + GET_NEXT_TABLE tbl = i return (OK) end #HD#: vt$clr.r 141 Nov-27-1984 01:11:34 # vt$clr --- send clear screen sequence integer function vt$clr (dummy) integer dummy include SWT_COMMON if (Tc_clear_screen (1) == EOS) return (ERR) send_str (Tc_clear_screen) call vt$del(Tc_clear_delay) # delay loop of characters return (OK) end #HD#: vt$db.r 674 Nov-27-1984 01:11:34 # vt$db --- dump terminal characteristics subroutine vt$db include SWT_COMMON character str (MAXLINE) call print (ERROUT, "Maxrow=*i, Maxcol=*i*n"s, Maxrow, Maxcol) call vt$db1 ("clear_screen"s, Tc_clear_screen) call vt$db1 ("clear_to_eol"s, Tc_clear_to_eol) call vt$db1 ("clear_to_eos"s, Tc_clear_to_eos) call vt$db1 ("cursor_home"s, Tc_cursor_home) call vt$db1 ("cursor_left"s, Tc_cursor_left) call vt$db1 ("cursor_right"s, Tc_cursor_right) call vt$db1 ("cursor_up"s, Tc_cursor_up) call vt$db1 ("cursor_down"s, Tc_cursor_down) call vt$db1 ("abs_pos"s, Tc_abs_pos) call vt$db1 ("vert_pos"s, Tc_vert_pos) call vt$db1 ("hor_pos"s, Tc_hor_pos) call ctomn (Tc_coord_char, str) call print (ERROUT, "coord_char=*s*n"s, str) call print (ERROUT, "coord_type=*i*n"s, Tc_coord_type) call print (ERROUT, "seq_type=*i*n"s, Tc_seq_type) call print (ERROUT, "delay_time=*i*n"s, Tc_delay_time) call print (ERROUT, "wrap_around=*y*n"s, Tc_wrap_around) call print (ERROUT, "clr_len=*i*n"s, Tc_clr_len) call print (ERROUT, "ceos_len=*i*n"s, Tc_ceos_len) call print (ERROUT, "ceol_len=*i*n"s, Tc_ceol_len) call print (ERROUT, "abs_len=*i*n"s, Tc_abs_len) call print (ERROUT, "vert_len=*i*n"s, Tc_vert_len) call print (ERROUT, "hor_len=*i*n"s, Tc_hor_len) return end #HD#: vt$db1.r 185 Nov-27-1984 01:11:35 # vt$db1 --- print mnemonics for special character sequence subroutine vt$db1 (title, seq) character title (ARB), seq (ARB) integer i character str (MAXLINE) call print (ERROUT, "*s="s, title) for (i = 1; seq (i) ~= EOS; i += 1) { call ctomn (seq (i), str) call print (ERROUT, "*s "s, str) } call print (ERROUT, "EOS*n"s) return end #HD#: vt$db2.r 423 Nov-27-1984 01:11:35 # vt$db2 --- print the contents of the terminal input tables subroutine vt$db2 include SWT_COMMON integer i, j character str (MAXLINE) for (i = 1; i <= MAXESCAPE; i += 1) if (Fn_used (i) == YES) { call print (ERROUT, "------ Table *i ------*n"s, i) for (j = 1; j <= CHARSETSIZE; j += 1) { if (Fn_tab (j, i) < 0) call print (ERROUT, "*4i"s, Fn_tab (j, i)) else if (Fn_tab (j, i) >= GET_NEXT_TABLE) call print (ERROUT, "*3in"s, Fn_tab (j, i) - GET_NEXT_TABLE) else if (Fn_tab (j, i) >= DEFINITION) call print (ERROUT, "*3id"s, Fn_tab (j, i) - DEFINITION) else if (Fn_tab (j, i) >= 1000) call print (ERROUT, "*3ic"s, Fn_tab (j, i) - 1000) else { call ctomn (Fn_tab (j, i), str) call print (ERROUT, " *3s"s, str) } if (mod (j, 16) == 0) call print (ERROUT, "*n"s) } } return end #HD#: vt$db3.r 209 Nov-27-1984 01:11:35 # vt$db3 --- dump the definitions for debugging subroutine vt$db3 include SWT_COMMON integer i character str (4) call print (ERROUT, "---- Define Table ----*n"s) call print (ERROUT, "Last_def=*i*n"s, Last_def) for (i = 1; i <= Last_def; i += 1) { if (mod (i, 16) == 0) call print (ERROUT, "*n"s) call ctomn (Def_buf (i), str) call print (ERROUT, "*4s"s, str) } return end #HD#: vt$def.r 839 Nov-27-1984 01:11:35 # vt$def --- accept a macro definition from the user integer function vt$def (ch) character ch include SWT_COMMON integer sp, i, cl, tbl integer vt$alc, vt$gsq character delim, c character seq (MAXSEQ) if (Last_def >= MAXDEF) { call vt$err ("No room for definition"s) return (ERR) } call vtmsg ("DEFINE: Enter delimiter"s, CHAR_MSG) call vtupd (NO) call c1in (delim) sp = vt$gsq ("DEFINE: Enter sequence"s, delim, seq, MAXSEQ) if (sp == ERR) return (sp) tbl = 1 for (i = 1; i < sp; i += 1) { c = Fn_tab (seq (i) - CHARSETBASE, tbl) select when (c == EOS) # allocate a new table if (vt$alc (tbl, seq (i) - CHARSETBASE) == ERR) { call vt$err ("Too many sequences"s) return (ERR) } when (c < GET_NEXT_TABLE) {# It's a character or a control seq call vt$err ("Illegal sequence"s) return (ERR) } else tbl = c - GET_NEXT_TABLE } cl = seq (i) - CHARSETBASE c = Fn_tab (cl, tbl) select when (c == DEFINE, c == UNDEFINE) { call vt$err ("Don't try that!"s) return (ERR) } when (c < DEFINITION) # it's some other character ; when (c < GET_NEXT_TABLE) # it's a definition call vt$rdf (cl, tbl) else { # it's another DFA table call vt$err ("Illegal prefix"s) return (ERR) } Last_def += 1 Def_buf (Last_def) = Fn_tab (cl, tbl) # squirrel away the old def Fn_tab (cl, tbl) = Last_def + DEFINITION Last_def += 1 sp = vt$gsq ("DEFINE: Enter definition"s, delim, Def_buf (Last_def), MAXDEF - Last_def + 1) if (sp == ERR) return (ERR) Last_def += sp call vtmsg (EOS, CHAR_MSG) call vtupd (NO) return (OK) end #HD#: vt$del.r 130 Nov-27-1984 01:11:36 # vt$del --- delay with characters subroutine vt$del(count) integer count include SWT_COMMON integer i if (count <= 0) return i = (intl (count) * Tc_speed) / 10000 while (i > 0) { send_char (NUL) i -= 1 } return end #HD#: vt$dsw.r 332 Nov-27-1984 01:11:36 # vt$dsw --- garbage collect the DFA subroutine vt$dsw include SWT_COMMON integer found, tbl, ent, i, ct ct = 0 repeat { found = NO do tbl = 1, MAXESCAPE if (Fn_used (tbl) == YES) { do ent = 1, CHARSETSIZE if (Fn_tab (ent, tbl) ~= EOS) next 2 found = YES break } if (found == NO) break Fn_used (tbl) = NO # return the table do i = 1, MAXESCAPE # remove all references to the table if (Fn_used (i) == YES) do ent = 1, CHARSETSIZE if (Fn_tab (ent, i) == GET_NEXT_TABLE + tbl) Fn_tab (ent, i) = EOS ct += 1 } DEBUG call vtprt (20, 1, "vt$dsw: *i tables returned"s, ct) return end #HD#: vt$err.r 120 Nov-27-1984 01:11:36 # vt$err --- display an error message and reset pushback pointer subroutine vt$err (msg) character msg (ARB) include SWT_COMMON call vtmsg (msg, CHAR_MSG) call vtupd (NO) Pb_ptr = 0 call t1ou (BEL) return end #HD#: vt$get.r 3450 Nov-27-1984 01:11:36 # vt$get --- get and edit a single line from input integer function vt$get (row, ccol, start, len) integer row, ccol, start, len include SWT_COMMON integer tab_pos, scan_pos, tbl, col, new_col, gobble, insert integer i, j, pos, status, last_status integer vt$idf, vt$def, vt$ndf character c, ci, termination, store procedure scan_for_char (char, wrap) forward procedure scan_for_tab (char) forward procedure update forward procedure get_char forward termination = EOS # not yet terminated col = ccol - start last_status = ERR status = OK while (termination == EOS) { col = bound (col, 1, len) if (status == ERR) send_char (BEL) else if (last_status == ERR) { call vtmsg (EOS, CHAR_MSG) call vtupd (NO) } last_status = status status = OK call vtmove (row, col + start - 1) # position the cursor get_char new_col = col store = EOF gobble = 0 insert = Insert_mode # assuming YES = 1 and NO = 0!!!!!!! select (c) ### Leftward cursor functions: when (MOVE_LEFT) new_col -= 1 when (TAB_LEFT) { scan_for_tab (TAB_LEFT) new_col = tab_pos } when (SKIP_LEFT) new_col = 1 when (SCAN_LEFT) { scan_for_char (c, YES) if (scan_pos <= 0) { status = ERR next } new_col = scan_pos } when (GOBBLE_LEFT) { new_col -= 1 gobble = 1 } when (GOBBLE_TAB_LEFT) { scan_for_tab (TAB_LEFT) new_col = tab_pos gobble = col - tab_pos } when (KILL_LEFT) { gobble = new_col - 1 new_col = 1 } when (GOBBLE_SCAN_LEFT) { scan_for_char (c, NO) if (scan_pos <= 0) { status = ERR next } new_col = scan_pos gobble = col - scan_pos } ### Rightward cursor functions: when (MOVE_RIGHT) new_col += 1 when (TAB_RIGHT) { scan_for_tab (TAB_RIGHT) new_col = tab_pos } when (SKIP_RIGHT) { for (i = len; i > 0 && Inbuf (i) == ' 'c; i -= 1) ; new_col = i + 1 } when (SCAN_RIGHT) { scan_for_char (c, YES) if (scan_pos <= 0) { status = ERR next } new_col = scan_pos } when (GOBBLE_RIGHT) gobble = 1 when (GOBBLE_TAB_RIGHT) { scan_for_tab (TAB_RIGHT) gobble = tab_pos - col } when (KILL_RIGHT) gobble = len - col + 1 when (GOBBLE_SCAN_RIGHT) { scan_for_char (c, NO) if (scan_pos <= 0) { status = ERR next } gobble = scan_pos - col } ### Line termination functions: when (RETURN) termination = ENTER when (KILL_RIGHT_AND_RETURN) { termination = ENTER gobble = len - col + 1 } when (FUNNY_RETURN, MOVE_UP, MOVE_DOWN) termination = c ### Character insertion functions: when (INSERT_BLANK) { insert = 1 store = ' 'c } when (INSERT_TAB) { scan_for_tab (TAB_RIGHT) insert = tab_pos - col store = ' 'c } when (INSERT_NEWLINE) { new_col += 1 insert = 1 store = NEWLINE } ### Tab related functions: when (TABSET) { Tabs (col) = YES next } when (TABRESET) { Tabs (col) = NO next } when (TABCLEAR) { do i = 1, MAXCOLS Tabs (i) = NO next } ### Miscellaneous control functions: when (TOGGLE_INSERT_MODE) { if (Insert_mode == YES) { Insert_mode = NO call vtmsg (EOS, INS_MSG) call vtupd (NO) } else { Insert_mode = YES call vtmsg ("INSERT"s, INS_MSG) call vtupd (NO) } next } when (SHIFT_CASE) { if (Invert_case == YES) { Invert_case = NO call vtmsg (EOS, CASE_MSG) call vtupd (NO) } else { Invert_case = YES call vtmsg ("CASE"s, CASE_MSG) call vtupd (NO) } next } when (KILL_ALL) { gobble = len new_col = 1 } when (FIX_SCREEN) { call vtupd (YES) next } when (VTH_ESCAPE) { call c1in (store) new_col += 1 } when (DEFINE) { status = vt$def (c) next } when (UNDEFINE) { status = vt$ndf (c) next } else if (c >= ' 'c && c < DEL) { new_col += 1 store = c if (Invert_case == YES && IS_LETTER (c)) store ^= 8r40 } else if (c < EOS) { # it's a termination of some sort termination = c next } else if (c >= DEFINITION) { status = vt$idf (c) next } else { call vt$err ("GARBAGE"s) status = ERR next } if (new_col < 1 || new_col > len) { # insure in range call vt$err ("MARGIN"s) status = ERR next } if (store ~= EOF) { # there is a character to store if (insert > 0) { for ({i = len - insert; j = len}; i >= col; {j -= 1; i -= 1}) Inbuf (j) = Inbuf (i) for ( ; j > i; j -= 1) Inbuf (j) = store update } else { pos = col + start - 1 call vtmove (row, pos) # make sure the cursor is in place if (store ~= ' 'c && Last_char (row) < pos) Last_char (row) = pos call vt$out (store) vt$pk (store, Curscr, row, pos) vt$pk (store, Newscr, row, pos) Inbuf (col) = store } } else if (gobble > 0) { for ({i = new_col; j = new_col + gobble}; j <= len; {i += 1; j += 1}) Inbuf (i) = Inbuf (j) for (; i <= len; i += 1) Inbuf (i) = ' 'c update } col = new_col DEBUG call vtprt (1, 1, "*i (*,8i) col=*i, lc=*i"s, c, c, col, Last_char (row)) DEBUG call vtpad (50) DEBUG call vtupd (NO) } ccol = start + col return (termination) # scan_for_char --- scan current line for a character procedure scan_for_char (char, wrap) { character char integer wrap local inc; integer inc get_char if (Invert_case == YES && IS_LETTER (c)) c ^= 8r40 # toggle case if (c == char) c = Last_char_scanned Last_char_scanned = c if (char == SCAN_LEFT || char == GOBBLE_SCAN_LEFT) inc = -1 else inc = +1 scan_pos = col repeat { if (scan_pos < 1) if (wrap == NO) break else scan_pos = len elif (scan_pos > len) if (wrap == NO) break else scan_pos = 1 else scan_pos += inc if (0 < scan_pos && scan_pos < len && Inbuf (scan_pos) == c) break } until (scan_pos == col) if (scan_pos <= 0 || scan_pos >= len || Inbuf (scan_pos) ~= c) scan_pos = 0 } # scan_for_tab --- find the next or previous tab stop procedure scan_for_tab (char) { character char local inc; integer inc inc = -1 tab_pos = col - 1 if (char == TAB_LEFT) { inc = -1 tab_pos = col - 1 } else { inc = +1 tab_pos = col + 1 } for ( ; 0 < tab_pos && tab_pos <= Maxcol; tab_pos += inc) if (Tabs (tab_pos) ~= NO) break } # update --- update the current input field on the screen procedure update { call vt$put (Inbuf, row, start, len) call vtupd (NO) } # get_char --- get an input character sequence; put result it 'c' procedure get_char { tbl = 1 repeat { if (Pb_ptr <= 0) { Nesting_count = 0 call c1in (ci) } else { ci = Pb_buf (Pb_ptr) Pb_ptr -= 1 } c = Fn_tab (ci - CHARSETBASE, tbl) if (c < GET_NEXT_TABLE) break tbl = c - GET_NEXT_TABLE } } end #HD#: vt$gsq.r 443 Nov-27-1984 01:11:37 # vt$gsq --- get a delimited sequence of characters integer function vt$gsq (msg, delim, seq, max) character msg (ARB), delim, seq (ARB) integer max include SWT_COMMON integer sp, tp integer encode, ctomn character c character text (MAXCOLS), dtext (4) call ctomn (delim, dtext) tp = 1 + encode (text, MAXCOLS, "*s (*s):"s, msg, dtext) call vtmsg (text, CHAR_MSG) call vtupd (NO) call c1in (c) for (sp = 1; c ~= delim && sp < max; sp += 1) { if (tp < MAXCOLS - 5) { text (tp) = ' 'c tp += 1 + ctomn (c, text (tp + 1)) call vtmsg (text, CHAR_MSG) call vtupd (NO) } seq (sp) = c call c1in (c) } if (sp >= max) { call vt$err ("Too long"s) seq (1) = EOS return (ERR) } if (sp <= 1) { call vt$err ("Empty sequence illegal"s) seq (1) = EOS return (ERR) } seq (sp) = EOS return (sp - 1) end #HD#: vt$idf.r 295 Nov-27-1984 01:11:37 # vt$idf --- invoke the definition of a user-defined key integer function vt$idf (c) character c include SWT_COMMON integer i, lim Nesting_count += 1 if (Nesting_count > MAXNEST) { call vt$err ("Attempted infinite recursion"s) return (ERR) } lim = c - DEFINITION + 1 for (i = lim; Def_buf (i) ~= EOS; i += 1) ; for ({i -= 1; Pb_ptr += 1}; i >= lim && Pb_ptr < MAXPB; {i -= 1; Pb_ptr += 1}) Pb_buf (Pb_ptr) = Def_buf (i) if (Pb_ptr >= MAXPB) { call vt$err ("Definition too long"s) return (ERR) } Pb_ptr -= 1 return (OK) end #HD#: vt$ier.r 157 Nov-27-1984 01:11:37 # vt$ier --- report error in initialization file integer function vt$ier (msg, name, line, fd) character msg (ARB), name (ARB), line (ARB) file_des fd call print (ERROUT, "error in vth file: *s*n"s, name) call print (ERROUT, "*s*nline: *s*n"s, msg, line) call close (fd) return (ERR) end #HD#: vt$ndf.r 450 Nov-27-1984 01:11:37 # vt$ndf --- remove a definition specified by the user integer function vt$ndf (ch) character ch include SWT_COMMON integer sp, tbl, i, cl integer vt$gsq character delim, c character seq (MAXSEQ) call vtmsg ("UNDEFINE: Enter delimiter"s, CHAR_MSG) call vtupd (NO) call c1in (delim) sp = vt$gsq ("UNDEFINE: Enter sequence"s, delim, seq, MAXSEQ) if (sp == ERR) return (ERR) tbl = 1 for (i = 1; i < sp; i += 1) { c = Fn_tab (seq (i) - CHARSETBASE, tbl) if (c < GET_NEXT_TABLE) { call vt$err ("Sequence not defined"s) return (ERR) } tbl = c - GET_NEXT_TABLE } cl = seq (i) - CHARSETBASE c = Fn_tab (cl, tbl) if (c < DEFINITION || c >= GET_NEXT_TABLE) { call vt$err ("Sequence not defined"s) return (ERR) } call vt$rdf (cl, tbl) call vt$dsw call vtmsg (EOS, CHAR_MSG) call vtupd (NO) return (OK) end #HD#: vt$out.r 366 Nov-27-1984 01:11:37 # vt$out --- output a character on the screen subroutine vt$out (chr) character chr include SWT_COMMON character tchr if (Currow == Maxrow && Curcol == Maxcol) return # refuse to make terminal scroll tchr = or (chr, 16r80) # ensure mark parity if (tchr >= ' 'c && tchr < DEL) # Is it printable?? send_char (tchr) # output character else if (Tc_shift_out (1) == EOS || tchr == Tc_shift_in (1) || tchr < NUL || tchr >= DEL) send_char (Unprintable_char) else { send_str (Tc_shift_out) send_char (tchr + Tc_shift_char - NUL) send_str (Tc_shift_in) } if (Curcol == Maxcol && Tc_wrap_around == YES) { Curcol = 1 Currow += 1 } else Curcol += 1 return end #HD#: vt$pos.r 1986 Nov-27-1984 01:11:38 # vt$pos --- position the cursor to row and col integer function vt$pos (row, col, crow, ccol) integer row, col, crow, ccol include SWT_COMMON integer i bool missin procedure row_coord forward procedure col_coord forward procedure b200_coord (pos) forward procedure sbee_coord (pos) forward if (row < 1 || col < 1 || row > Maxrow || col > Maxcol) return (ERR) # see if we can position relatively for speed if (~missin(crow) && ~missin(ccol) && Tc_seq_type ~= 4) if (row == crow && iabs(ccol - col) < Tc_abs_len) if (ccol >= col && Tc_cursor_left (1) ~= EOS) { for (i = ccol - col; i > 0; i -= 1) send_str (Tc_cursor_left) return } elif (Tc_cursor_right (1) ~= EOS) { for (i = col - ccol; i > 0; i -= 1) send_str (Tc_cursor_right) return } # can't position relatively ... got to go absolute select (Tc_seq_type) when (1) { # absolute, row first, column second send_str (Tc_abs_pos) row_coord col_coord } when (2) { # absolute, column first, row second send_str (Tc_abs_pos) col_coord row_coord } when (3) { # horizontal and vertical only send_str (Tc_vert_pos) row_coord call vt$del(Tc_pos_delay) send_str (Tc_hor_pos) col_coord } when (4) call vt$rel(row, col, crow, ccol) call vt$del(Tc_pos_delay) return (OK) # row_coord --- output the row coordinate for positioning procedure row_coord { local i, units, tens, hundreds integer i, units, tens, hundreds select (Tc_coord_type) when (1, 4) # simplest kind, most terms are here send_char (Tc_coord_char + row) when (2) # B200, SOL b200_coord (row) when (3) # superbee sbee_coord (row) when (5) { # colorgraphics i = 511 - 10 * (row - 1) units = mod (i, 10) i /= 10 tens = mod (i, 10) i /= 10 hundreds = mod (i, 10) send_char (" "c + 16 + hundreds) send_char (" "c + 16 + tens) send_char (" "c + 16 + units) } when (6) { # HP 9845 & HP 2621 i = row - 1 units = mod (i, 10) tens = i / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char ('y'c) } when (7) { # ansi positioning (vt100, pst100) units = mod (row, 10) tens = row / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char (';'c) } } # col_coord --- output the column coordinate for positioning procedure col_coord { local tcol, tens, units, hundreds, i integer tcol, tens, units, hundreds, i select (Tc_coord_type) when (1) # simplest kind, most terms are here send_char (Tc_coord_char + col) when (2) # B200, SOL b200_coord (col) when (3) # superbee sbee_coord (col) when (4) { # adds consul 980 send_char ('0'c + ((col - 1) / 10)) send_char ('0'c + mod (col - 1, 10)) } when (5) { # colorgraphics i = 6 * (col - 1) units = mod (i, 10) i /= 10 tens = mod (i, 10) i /= 10 hundreds = mod (i, 10) send_char (" "c + 16 + hundreds) send_char (" "c + 16 + tens) send_char (" "c + 16 + units) } when (6) { # HP 9845 & HP 2621 i = col - 1 units = mod (i, 10) tens = i / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char ('C'c) } when (7) { # ansi positioning (vt100, pst100) units = mod (col, 10) tens = col / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char ('H'c) } } # b200_coord --- put out a b200-style coordinate procedure b200_coord (pos) { integer pos local acc, units, tens; integer acc, units, tens acc = pos - 1 tens = acc / 10 units = acc - 10 * tens acc = units + 16 * tens send_char (acc) } # sbee_coord --- output a coordinate for the Superbee procedure sbee_coord (pos) { integer pos local acc; integer acc send_char ('0'c) acc = pos - 1 send_char ('0'c + (acc / 10)) send_char ('0'c + mod (acc, 10)) } end #HD#: vt$put.r 735 Nov-27-1984 01:11:38 # vt$put --- copy string into terminal buffer subroutine vt$put (str, row, col, clen) integer row, col, clen character str (ARB) include SWT_COMMON integer i, len character c len = clen DEBUG call print (ERROUT, "In vt$put('*,#s', *i, *i, *i)*n"s, DEBUG clen, str, row, col, clen) if (row > Maxrow || row < 1 || col < 1) { Pad_row = 1 Pad_col = Maxcol Pad_len = 0 return } # check for running off visible screen boundary if (col + len - 1 > Maxcol) len = Maxcol - col + 1 # update change boundaries if (row < Row_chg_start) Row_chg_start = row if (row > Row_chg_stop) Row_chg_stop = row if (col < Col_chg_start (row)) Col_chg_start (row) = col if (col + len - 1 > Col_chg_stop (row)) Col_chg_stop (row) = col + len - 1 if (col + len - 1 < Last_char (row)) ### Subsequent code uses for (i = len - 1; i >= 0; i -= 1) ### zero based array addressing vt$pk (str (i + 1), Newscr, row, col + i) else { for (i = len - 1; i >= 0 && str (i + 1) == ' 'c; i -= 1) vt$pk (' 'c, Newscr, row, col + i) if (i >= 0) { # some characters in the string Last_char (row) = col + i for (; i >= 0; i -= 1) vt$pk (str (i + 1), Newscr, row, col + i) } else { # the string is empty for (i = col; i > 0; i -= 1) { vt$upk (c, Newscr, row, i) if (c ~= ' 'c) break } Last_char (row) = i } } Pad_row = row Pad_col = col + len Pad_len = len return end #HD#: vt$rdf.r 333 Nov-27-1984 01:11:38 # vt$rdf --- remove the definition indicated by a DFA entry subroutine vt$rdf (c, tbl) integer c, tbl include SWT_COMMON integer p, len, i, j, lim integer length lim = Fn_tab (c, tbl) # for use in updating pointers p = lim - DEFINITION Fn_tab (c, tbl) = Def_buf (p) len = 1 + length (Def_buf (p + 1)) # Def_buf (p) might be EOS for ({i = p; j = p + len + 1}; j <= Last_def; {i += 1; j += 1}) Def_buf (i) = Def_buf (j) Last_def -= len + 1 do i = 1, MAXESCAPE if (Fn_used (i) == YES) do j = 1, CHARSETSIZE if (Fn_tab (j, i) >= lim && Fn_tab (j, i) < GET_NEXT_TABLE) Fn_tab (j, i) -= len + 1 return end #HD#: vtclr.r 238 Nov-27-1984 01:11:38 # vtclr --- clear a rectangle on the screen subroutine vtclr (srowx, scolx, erowx, ecolx) integer srowx, scolx, erowx, ecolx include SWT_COMMON integer srow, scol, erow, len, i character blanks (MAXCOLS) data blanks /MAXCOLS * ' 'c/ srow = max0 (srowx, 1) scol = max0 (scolx, 1) erow = min0 (erowx, Maxrow) len = min0 (ecolx, Maxcol) - scol + 1 for (i = srow; i <= erow; i += 1) call vt$put (blanks, i, scol, len) return end #HD#: vtdlin.r 1075 Nov-27-1984 01:11:39 # vtdlin --- delete 'cnt' lines at 'row' # # Warning --- This routine knows the format of the screen buffers integer function vtdlin (row, cnt) integer row, cnt include SWT_COMMON logical missin integer i, j, count character blanks (MAXCOLS) data blanks / MAXCOLS * ' 'c / count = 1 if (~ missin (cnt)) count = cnt if (row < 1 || row > Maxrow || count < 1) return (ERR) if (count + row - 1 > Maxrow) count = Maxrow - row + 1 call vtmove (row, 1) if (Tc_del_line (1) ~= EOS) for (i = 1; i <= count; i += 1) { send_str (Tc_del_line) call vt$del(Tc_line_delay) } else { for (i = row + count; i <= Maxrow; i += 1) { for (j = 1; j <= Last_char (i); j += 1) if (Curscr (j, i) ~= Curscr (j, i - count)) { call vtmove (i - count, j) call vt$out (Curscr (j, i)) } if (Last_char (i - count) > Last_char (i)) if (Tc_clear_to_eol (1) ~= EOS) { call vtmove (i - count, j) send_str (Tc_clear_to_eol) } else for (; j <= Last_char (i - count); j += 1) if (Curscr (j, i - count) ~= ' 'c) { call vtmove (i - count, j) call vt$out (' 'c) } } for (i = Maxrow - count + 1; i <= Maxrow; i += 1) if (Tc_clear_to_eol (1) ~= EOS) { call vtmove (i, 1) send_str (Tc_clear_to_eol) } else for (j = 1; j <= Last_char (i); j += 1) if (Curscr (j, i) ~= ' 'c) { call vtmove (i, j) call vt$out (' 'c) } } for (i = row; i + count <= Maxrow; i += 1) { call move$ (Curscr (1, i + count), Curscr (1, i), Maxcol) call move$ (Newscr (1, i + count), Newscr (1, i), Maxcol) Last_char (i) = Last_char (i + count) Col_chg_stop (i) = Col_chg_stop (i + count) Col_chg_start (i) = Col_chg_start (i + count) } for (; i <= Maxrow; i += 1) { call move$ (blanks, Curscr (1, i), Maxcol) call move$ (blanks, Newscr (1, i), Maxcol) Last_char (i) = 0 Col_chg_stop (i) = 0 Col_chg_start (i) = MAXCOLS } if (row < Row_chg_stop) Row_chg_stop -= count if (row < Row_chg_start) Row_chg_start -= count if (Row_chg_stop < 0) Row_chg_stop = 0 if (Row_chg_start < 0) Row_chg_start = 0 return (OK) end #HD#: vtenb.r 142 Nov-27-1984 01:11:39 # vtenb --- enable input on a line subroutine vtenb (row, col, len) integer row, col, len include SWT_COMMON if (row > Maxrow || row < 1) return Input_start (row) = bound (col, 1, Maxcol) Input_stop (row) = bound (col + len - 1, 1, Maxcol) return end #HD#: vtgetl.r 311 Nov-27-1984 01:11:39 # vtgetl --- get a line from the VTH screen integer function vtgetl (str, row, col, clen) character str (ARB) integer row, col, clen include SWT_COMMON integer pos, i, len character c len = clen if (row < 1 || row > Maxrow) { str (1) = EOS return (0) } pos = min0 (Maxcol, col + len - 1) while (pos >= col) { vt$upk (c, Newscr, row, pos) if (c ~= ' 'c) break pos -= 1 } i = pos - col + 1 len = i str (i + 1) = EOS if (i > 0) repeat { str (i) = c i -= 1 pos -= 1 if (i <= 0) break vt$upk (c, Newscr, row, pos) } return (len) end #HD#: vtilin.r 1109 Nov-27-1984 01:11:39 # vtilin --- insert 'cnt' lines at 'row' # # Warning --- This routine knows the format of the screen buffers integer function vtilin (row, cnt) integer row, cnt include SWT_COMMON logical missin integer i, j, count character blanks (MAXCOLS) data blanks / MAXCOLS * ' 'c / count = 1 if (~ missin (cnt)) count = cnt if (row < 1 || row > Maxrow || count < 1) return (ERR) if (count + row - 1 > Maxrow) count = Maxrow - row + 1 call vtmove (row, 1) if (Tc_ins_line (1) ~= EOS) for (i = row; i < row + count; i += 1) { send_str (Tc_ins_line) call vt$del(Tc_line_delay) } else { # fake it for (i = row; i < row + count; i += 1) if (Tc_clear_to_eol (1) ~= EOS) { call vtmove (i, 1) send_str (Tc_clear_to_eol) } else for (j = 1; j <= Last_char (i); j += 1) if (Curscr (j, i) ~= ' 'c) { call vtmove (i, j) call vt$out (' 'c) } for (; i <= Maxrow; i += 1) { for (j = 1; j <= Last_char (i - count); j += 1) if (Curscr (j, i) ~= Curscr (j, i - count)) { call vtmove (i, j) call vt$out (Curscr (j, i - count)) } if (Last_char (i) > Last_char (i - count)) if (Tc_clear_to_eol (1) ~= EOS) { call vtmove (i, j) send_str (Tc_clear_to_eol) } else for (; j <= Last_char (i); j += 1) if (Curscr (j, i) ~= Curscr (j, i - count)) { call vtmove (i, j) call vt$out (Curscr (j, i - count)) } } call vtmove (row, 1) # replace cursor } for (i = Maxrow; i - count >= row; i -= 1) { call move$ (Curscr (1, i - count), Curscr (1, i), Maxcol) call move$ (Newscr (1, i - count), Newscr (1, i), Maxcol) Last_char (i) = Last_char (i - count) Col_chg_stop (i) = Col_chg_stop (i - count) Col_chg_start (i) = Col_chg_start (i - count) } for (; i >= row; i -= 1) { call move$ (blanks, Curscr (1, i), Maxcol) call move$ (blanks, Newscr (1, i), Maxcol) Last_char (i) = 0 Col_chg_stop (i) = 0 Col_chg_start (i) = MAXCOLS } if (row < Row_chg_stop) Row_chg_stop += count if (row < Row_chg_start) Row_chg_start += count if (Row_chg_stop > MAXROWS) Row_chg_stop = MAXROWS if (Row_chg_start > MAXROWS) Row_chg_start = MAXROWS return (OK) end #HD#: vtinfo.r 386 Nov-27-1984 01:11:40 # vtinfo --- return certain information from the VTH common blocks integer function vtinfo (key, info) integer key, info (ARB) include SWT_COMMON select (key) when (VT_MAXRC) { # return the max row and max col info (1) = Maxrow info (2) = Maxcol } when (VT_WRAP) # return whether or not terminal wraps at eol info (1) = Tc_wrap_around when (VT_HWINS) { # terminal has hardware insert info (1) = NO if (Tc_ins_line (1) ~= EOS) info (1) = YES } when (VT_HWDEL) { info (1) = NO if (Tc_del_line (1) ~= EOS) info (1) = YES } when (VT_HWCEL) { info (1) = NO if (Tc_clear_to_eol (1) ~= EOS) info (1) = YES } when (VT_BAUD) info (1) = Tc_speed else return (ERR) # invalid key given return (OK) end #HD#: vtinit.r 559 Nov-27-1984 01:11:40 # vtinit --- initialize screen buffers, cursor position and # terminal characteristics integer function vtinit (term_type) integer term_type (MAXTERMTYPE) include SWT_COMMON integer vtterm, i, j integer duplx$ if (vtterm (term_type) == ERR) # get term characteristics return (ERR) DEBUG call print (ERROUT, "After call to vtterm*n"s) Currow = 0 Curcol = 0 do i = 1, MAXROWS; { Col_chg_start (i) = MAXCOLS Col_chg_stop (i) = 0 Last_char (i) = 0 } Row_chg_start = MAXROWS Row_chg_stop = 0 Msg_row = 0 do i = 1, MAX_COLS Msg_owner (i) = NOMSG Pad_row = 1 Pad_col = 1 Pad_len = 80 Display_time = NO for (i = 1; i <= MAX_ROWS; i += 1) for (j = 1; j <= MAX_COLS; j += 1) { Newscr (j, i) = ' 'c Curscr (j, i) = ' 'c } Unprintable_char = '?'c Last_char_scanned = EOS Insert_mode = NO Invert_case = NO Duplex = duplx$ (-1) call duplx$ (:140000) Input_wait = 0 # default: no timeout on input Pb_ptr = 0 Nesting_count = 0 DEBUG call vt$db # debug: call terminal char dumper return (OK) end #HD#: vtmove.r 161 Nov-27-1984 01:11:40 # vtmove --- position cursor to row, col with least cost subroutine vtmove (row, col) integer row, col include SWT_COMMON integer i character chr DEBUG call print (ERROUT, "In vtmove (*i, *i)*n"s, row, col) call vt$pos(row, col, Currow, Curcol) Currow = row Curcol = col return end #HD#: vtmsg.r 789 Nov-27-1984 01:11:40 # vtmsg --- display a message in the status line (if any) subroutine vtmsg (s, t) character s (ARB) integer t include SWT_COMMON integer col, need, c, first, last integer length character ch if (Msg_row <= 0) # Are we maintaining a status line? return for (first = 1; first <= Maxcol; first += 1) if (Msg_owner (first) == t) break for (last = first; last <= Maxcol; last += 1) { if (Msg_owner (last) ~= t) break Msg_owner (last) = NOMSG } need = length (s) + 2 # for two blanks if (need > 2) { # not empty message if (need <= last - first) # fits where was last time col = first # keep it there else # find another place for it for (col = 1; col < Maxcol; col = c) { while (col < Maxcol && Msg_owner (col) ~= NOMSG) col += 1 for (c = col; Msg_owner (c) == NOMSG; c += 1) if (c >= Maxcol) break if (c - col >= need) break } if (col + need > Maxcol) { # have to garbage collect col = 1 for (c = 1; c <= Maxcol; c += 1) if (Msg_owner (c) ~= NOMSG) { vt$upk (ch, Newscr, Msg_row, c) call vt$put (ch, Msg_row, col, 1) Msg_owner (col) = Msg_owner (c) col += 1 } for (c = col; c <= Maxcol; c += 1) Msg_owner (c) = NOMSG } call vt$put (' 'c, Msg_row, col, 1) call vt$put (s, Msg_row, col + 1, need - 2) call vt$put (' 'c, Msg_row, col + need - 1, 1) for (c = col; c <= min0 (col + need - 1, Maxcol); c += 1) Msg_owner (c) = t } do col = 1, Maxcol if (Msg_owner (col) == NOMSG) call vt$put ('.'c, Msg_row, col, 1) return end #HD#: vtoc.r 178 Nov-27-1984 01:11:40 # vtoc --- convert varying string to EOS-terminated string integer function vtoc (var, str, len) integer var (ARB), len character str (ARB) integer cp, max, i cp = CHARS_PER_WORD max = var (1) + 1 if (len < max) max = len for (i = 1; i < max; i += 1) fpchar (var, cp, str (i)) str (i) = EOS return (i - 1) end #HD#: vtop.s 505 Nov-27-1984 01:11:41 * vtop --- convert varying to packed string * * integer function vtop (vstr, pstr, len) * integer vstr (ARB), pstr (ARB), len * * returns number of characters moved SUBR VTOP SEG RLIT SYML include "=incl=/lib_def.s.i" LINK VTOP ECB CNVSTART,,VSTR,3 DATA 4,C'VTOP' PROC DYNM =20,VSTR(3),PSTR(3),LEN(3) DYNM NUMCH CNVSTART ARGT ENTR VTOP LDA VSTR,* get char count STA NUMCH BEQ QUIT RCB ARS 1 check for odd # chars BCR NOTODD A1A TAX LDA VSTR,*X null fill last char of last word ANA ='177400 STA VSTR,*X TXA recover the index NOTODD CAS LEN,* JMP# NOSPACE see if enough words available in JMP# GETINDX 'pstr' JMP# GETINDX NOSPACE LDA LEN,* ALS 1 STA NUMCH if not, reset # words to copy BLE QUIT no space or > 32767 - die ARS 1 GETINDX TAX set up index EAXB PSTR,* COPYCH LDA VSTR,*X do it backwards STA XB%-1,X BDX COPYCH QUIT LDA NUMCH bye bye PRTN END #HD#: vtopt.r 545 Nov-27-1984 01:11:41 # vtopt --- set options for the virtual terminal handler subroutine vtopt (opt, str) integer opt, str (ARB) include SWT_COMMON integer i, val character dots (MAXCOLS), blanks (MAXCOLS) data dots /MAXCOLS * '.'c/ data blanks /MAXCOLS * ' 'c/ val = str (1) select (opt) when (STATUS_ROW) { if (Msg_row > 0) call vt$put (blanks, Msg_row, 1, Maxcol) if (val < 1 || val > Maxrow) Msg_row = 0 else Msg_row = val if (Msg_row > 0) call vt$put (dots, Msg_row, 1, Maxcol) do i = 1, Maxcol Msg_owner (i) = NOMSG } when (INPUT_WAIT) if (val < 1) Input_wait = 0 else Input_wait = val when (DISPLAY_TIME) if (val == YES) Display_time = YES else Display_time = NO when (UNPRINTABLE_CHAR) if (val >= ' 'c && val < DEL) Unprintable_char = val else Unprintable_char = '?'c when (SET_TABS) { for (i = 1; str (i) ~= EOS && i <= Maxcol; i += 1) if (str (i) == ' 'c) Tabs (i) = NO else Tabs (i) = YES while (i <= Maxcol) { Tabs (i) = YES i += 1 } } return end #HD#: vtpad.r 288 Nov-27-1984 01:11:41 # vtpad --- pad the rest of a field with blanks subroutine vtpad (len) integer len include SWT_COMMON integer i character blanks (MAXCOLS) data blanks / MAXCOLS * ' 'c / i = min0 (80, Pad_col - Pad_len + len - 1) if (Pad_row < Row_chg_start) Row_chg_start = Pad_row if (Pad_row > Row_chg_stop) Row_chg_stop = Pad_row if (Pad_col < Col_chg_start (Pad_row)) Col_chg_start (Pad_row) = Pad_col if (i > Col_chg_stop (Pad_row)) Col_chg_stop (Pad_row) = i call vt$put (blanks, Pad_row, Pad_col, i - Pad_col + 1) return end #HD#: vtprt.r 391 Nov-27-1984 01:11:41 # vtprt --- place characters using formatted strings into # the new screen buffer integer function vtprt (row, col, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) include SWT_COMMON integer row, col character fmt (ARB) untyped a1, a2, a3, a4, a5, a6, a7, a8, a9, a10 character str (MAXLINE), fmt1 (MAXLINE) integer encode, size if (row > Maxrow || row < 1 || col < 1) return (ERR) if (and (fmt (1), :177400) == 0) size = encode (str, MAXLINE, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) else { call ptoc (fmt, '.'c, fmt1, MAXLINE) size = encode (str, MAXLINE, fmt1, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) } # now put the encoded string into screen buffer call vt$put (str, row, col, size) return (size) end #HD#: vtputl.r 119 Nov-27-1984 01:11:41 # vtputl --- put line into terminal screen buffer subroutine vtputl (str, row, col) integer row, col character str (ARB) include SWT_COMMON integer length call vt$put (str, row, col, length (str)) return end #HD#: vtread.r 767 Nov-27-1984 01:11:42 # vtread --- read characters from the user's terminal integer function vtread (crow, ccol, clr) integer crow, ccol, clr include SWT_COMMON integer row, col, i, j, t integer vt$get character fill (MAXCOLS) data fill /MAXCOLS * ' 'c/ procedure search (way) forward if (clr == YES) # clear the input areas if desired do i = 1, Maxrow if (Input_start (i) <= Input_stop (i)) call vt$put (fill, i, Input_start (i), Input_stop (i) - Input_start (i) + 1) call vtupd (NO) row = crow - 1 col = ccol search (+1) repeat { DEBUG call vtprt (2, 1, "row=*i, col=*i"s, row, col) DEBUG call vtupd (NO) for ({i = 1; j = Input_start (row)}; j <= Input_stop (row); {i += 1; j += 1}) vt$upk (Inbuf (i), Newscr, row, j) t = vt$get (row, col, Input_start (row), Input_stop (row) - Input_start (row) + 1) if (t == MOVE_UP) search (-1) else if (t == MOVE_DOWN) search (+1) else break } return (t) # search --- look for a line with an open input field procedure search (way) { integer way local lrow; integer lrow DEBUG call print (ERROUT, "search: way=*i, row=*i*n"s, way, row) lrow = mod (row + Maxrow - 1, Maxrow) + 1 row = mod (lrow + Maxrow + way - 1, Maxrow) + 1 while (Input_start (row) > Input_stop (row)) { DEBUG call print (ERROUT, "search: row=*i*n"s, row) if (row == lrow) return (0) row = mod (row + Maxrow + way - 1, Maxrow) + 1 } DEBUG call print (ERROUT, "search: found=*i*n"s, row) } end #HD#: vtstop.r 87 Nov-27-1984 01:11:42 # vtstop --- restore the user's terminal before quitting subroutine vtstop include SWT_COMMON call vtmove (Maxrow, 1) call duplx$ (Duplex) return end #HD#: vtterm.r 6397 Nov-27-1984 01:11:42 # vtterm --- initialize the common block with values for # the terminal type given integer function vtterm (term_type) integer term_type (MAXTERMTYPE) include SWT_COMMON integer fd, i, bp, tp, sp, f, state integer len_ac (MAXCOORDTYPE), len_hc (MAXCOORDTYPE), len_vc (MAXCOORDTYPE) integer open, length, strbsr, equal, ctoi, getlin, mntoc integer vt$alc, ctoc, vt$ier, gttype, gtattr character fname (MAXLINE) character buf (MAXLINE), tbuf (MAXLINE), sbuf (MAXLINE) character mntoc ################################################################### # Instructions for adding new routines to vth: # # New coordinate types # 1. Increase the definition for MAXCOORDTYPE by one. # 2. Add code in 'vtterm' to check the applicability # of horizontal, vertical, and absolute positioning # sequences. # 3. Add another entry to the 'data' statements giving # the length of coordinates for the three positioning # sequences. # 4. Add code to 'vt$pos' to correctly generate both # horizontal and vertical coordinates for the new # coordinate type. # # New positioning types # 1. Increase the definition for MAXPOSTYPE by one. # 2. Add code in 'vtterm' to check the applicability of # horizontal, vertical, and absolute positioning # sequences. # 3. Add code to 'vt$pos' to perform the positioning. # # New input control functions: # 1. Add a definition for the function to the definitions # file. Define it to be one greater than the integer # used on the last control function definition. # 2. Add the definition and the string to be used to # recognize the function in the vth file # 3. Add the code to perform the function to the 'select' # statement in 'vt$get'. ################################################################### ### Length of absolute positioning coordinate sequences data len_ac / _ 2, # + ASCII char, + ASCII char 2, # , (b200) 6, # , (sbee) 3, # , (adds 980) 6, # (cg) 6, # y, C (hp) 6/ # ;, H (ansi) ### Length of vertical positioning coordinate sequences data len_vc / _ 1, # + ASCII char 1, # (b200) 3, # (sbee) 1, # (adds 980) 3, # (cg) 3, # (hp) 3/ # ; (ansi) ### Length of horizontal positioning coordinate sequences data len_hc / _ 1, # + ASCII char 1, # (b200) 3, # (sbee) 2, # (adds 980) 3, # (cg) 3, # (hp) 3/ # H (ansi) string_table ipos, itext, / ATTN, "attn", / DEFINE, "define", / DEFINITION, "definition", / VTH_ESCAPE, "escape", / FIX_SCREEN, "fix_screen", / FUNNY_RETURN, "funny_return", / GOBBLE_LEFT, "gobble_left", / GOBBLE_RIGHT, "gobble_right", / GOBBLE_SCAN_LEFT, "gobble_scan_left", / GOBBLE_SCAN_RIGHT, "gobble_scan_right", / GOBBLE_TAB_LEFT, "gobble_tab_left", / GOBBLE_TAB_RIGHT, "gobble_tab_right", / INSERT_BLANK, "insert_blank", / INSERT_NEWLINE, "insert_newline", / INSERT_TAB, "insert_tab", / KILL_ALL, "kill_all", / KILL_LEFT, "kill_left", / KILL_RIGHT, "kill_right", / KILL_RIGHT_AND_RETURN, "kill_right_and_return", / MOVE_DOWN, "move_down", / MOVE_LEFT, "move_left", / MOVE_RIGHT, "move_right", / MOVE_UP, "move_up", / PF, "pf", / RETURN, "return", / SCAN_LEFT, "scan_left", / SCAN_RIGHT, "scan_right", / SHIFT_CASE, "shift_case", / SKIP_LEFT, "skip_left", / SKIP_RIGHT, "skip_right", / TAB_CLEAR, "tab_clear", / TAB_LEFT, "tab_left", / TAB_RESET, "tab_reset", / TAB_RIGHT, "tab_right", / TAB_SET, "tab_set", / TOGGLE_INSERT_MODE, "toggle_insert_mode", / UNDEFINE, "undefine" string_table opos, otext, / ABS_POS, "abs_pos", / CLEAR_DELAY, "clear_delay", / CLEAR_SCREEN, "clear_screen", / CLEAR_TO_EOL, "clear_to_eol", / CLEAR_TO_EOS, "clear_to_eos", / COLUMNS, "columns", / COORD_TYPE, "coord_type", / CURSOR_DOWN, "cursor_down", / CURSOR_HOME, "cursor_home", / CURSOR_LEFT, "cursor_left", / CURSOR_RIGHT, "cursor_right", / CURSOR_UP, "cursor_up", / DELETE_LINE, "delete_line", / HOR_POS, "hor_pos", / INSERT_LINE, "insert_line", / LINE_DELAY, "line_delay", / POS_DELAY, "pos_delay", / ROWS, "rows", / SHIFT_IN, "shift_in", / SHIFT_OUT, "shift_out", / SHIFT_TYPE, "shift_type", / VERT_POS, "vert_pos", / WRAP_AROUND, "wrap_around" procedure getword forward procedure getseq forward procedure interpret_input forward procedure interpret_output forward define (err (msg), return (vt$ier (msg, fname, buf, fd))) if (gttype (term_type) == NO || gtattr (TA_VTH_USEABLE) == NO) return (ERR) call encode (fname, MAXLINE, "=vth=/*s"s, term_type) fd = open (fname, READ) if (fd == ERR) return (ERR) Last_def = 0 Fn_used (1) = YES do i = 2, MAXESCAPE Fn_used (i) = NO do i = 1, CHARSETSIZE Fn_tab (i, 1) = EOS do i = 1, MAXCOLS Tabs (i) = NO do i = 1, MAXCOLS, 3 Tabs (i) = YES do i = 1, MAXROWS; { Input_start (i) = MAXCOLS Input_stop (i) = 0 } Maxrow = 8 Maxcol = 32 Tc_clear_screen (1) = EOS Tc_clear_to_eol (1) = EOS Tc_clear_to_eos (1) = EOS Tc_cursor_home (1) = EOS Tc_cursor_left (1) = EOS Tc_cursor_right (1) = EOS Tc_cursor_up (1) = EOS Tc_cursor_down (1) = EOS Tc_abs_pos (1) = EOS Tc_vert_pos (1) = EOS Tc_hor_pos (1) = EOS Tc_ins_line (1) = EOS Tc_del_line (1) = EOS Tc_shift_in (1) = EOS Tc_shift_out (1) = EOS Tc_coord_char = ' 'c Tc_shift_char = NUL Tc_coord_type = 0 Tc_seq_type = 0 Tc_clear_delay = 0 Tc_line_delay = 0 Tc_pos_delay = 0 Tc_speed = 9600 Tc_wrap_around = YES Tc_clr_len = 9999 Tc_ceos_len = 9999 Tc_ceol_len = 9999 Tc_abs_len = 9999 Tc_vert_len = 9999 Tc_hor_len = 9999 Tc_home_len = 9999 Tc_left_len = 9999 Tc_up_len = 9999 state = ERR while (getlin (tbuf, fd) ~= EOF) { for ({tp = 1; bp = 1}; tbuf (tp) ~= NEWLINE && tbuf (tp) ~= EOS; {tp += 1; bp += 1}) { if (tbuf (tp) == '@'c && tbuf (tp + 1) ~= EOS) tp += 1 else if (tbuf (tp) == '#'c) break buf (bp) = tbuf (tp) } buf (bp) = EOS bp = 1 getword select when (tbuf (1) == EOS) ; when (equal (tbuf, "input"s) == YES) state = READ when (equal (tbuf, "output"s) == YES) state = WRITE ifany next select (state) when (ERR) err ("characteristic appears before 'input' or 'output'"s) when (READ) { f = strbsr (ipos, itext, 1, tbuf) if (f == EOF) err ("unrecognized keyword"s) f = itext (ipos (f)) interpret_input } when (WRITE) { f = strbsr (opos, otext, 1, tbuf) if (f == EOF) err ("unrecognized keyword"s) f = otext (opos (f)) interpret_output } } call close (fd) ### Fill in the default characters for the first table for (i = 1; i < CHARSETSIZE; i += 1) if (Fn_tab (i, 1) == EOS) Fn_tab (i, 1) = i + CHARSETBASE ### Check the plausibility of all control sequences if (Tc_clear_screen (1) == EOS) { call remark ("Screen clear sequence required"p) return (ERR) } Tc_clr_len = length (Tc_clear_screen) if (Tc_clear_to_eol (1) ~= EOS) Tc_ceol_len = length (Tc_clear_to_eol) if (Tc_clear_to_eos (1) ~= EOS) Tc_ceol_len = length (Tc_clear_to_eos) if (Tc_cursor_left (1) ~= EOS) Tc_left_len = length (Tc_cursor_left) if (Tc_cursor_up (1) ~= EOS) Tc_up_len = length (Tc_cursor_up) if (Tc_cursor_home (1) ~= EOS) Tc_home_len = length (Tc_cursor_home) if (Tc_coord_type < 1 || Tc_coord_type > MAXCOORDTYPE) { call remark ("Invalid coordinate type"p) return (ERR) } select (Tc_seq_type) when (1, 2) { if (Tc_abs_pos (1) == EOS) { call remark ("Absolute positioning sequence required"p) return (ERR) } Tc_abs_len = length (Tc_abs_pos) + len_ac (Tc_coord_type) if (Tc_vert_pos (1) ~= EOS) Tc_vert_len = length (Tc_vert_pos) if (Tc_hor_pos (1) ~= EOS) Tc_hor_len = length (Tc_hor_pos) } when (3) { if (Tc_vert_pos (1) == EOS || Tc_hor_pos (1) == EOS) { call remark ("Horizontal/vertical sequence missing"p) return (ERR) } Tc_vert_len = length (Tc_vert_pos) + len_vc (Tc_coord_type) Tc_hor_len = length (Tc_hor_pos) + len_hc (Tc_coord_type) } when (4) { if (Tc_cursor_up (1) == EOS && Tc_cursor_home (1) == EOS) { call remark ("Cursor_home or cursor_up must be specified"p) return (ERR) } if (Tc_cursor_right (1) == EOS) { call remark ("Cursor_right must be specified"p) return (ERR) } } else { call remark ("Invalid sequence type"p) return (ERR) } DEBUG call vt$db DEBUG call vt$db2 return (OK) # getword --- get a "word" from 'buf'; put it in 'tbuf' procedure getword { SKIPBL (buf, bp) for (tp = 1; buf (bp) ~= ' 'c && buf (bp) ~= EOS; {bp += 1; tp += 1}) tbuf (tp) = buf (bp) tbuf (tp) = EOS } # interpret_output --- interpret a line for an output control sequence procedure interpret_output { select (f) when (CLEAR_SCREEN) { getseq call ctoc (sbuf, Tc_clear_screen, SEQSIZE) } when (CLEAR_TO_EOL) { getseq call ctoc (sbuf, Tc_clear_to_eol, SEQSIZE) } when (CLEAR_TO_EOS) { getseq call ctoc (sbuf, Tc_clear_to_eos, SEQSIZE) } when (CURSOR_HOME) { getseq call ctoc (sbuf, Tc_cursor_home, SEQSIZE) } when (CURSOR_LEFT) { getseq call ctoc (sbuf, Tc_cursor_left, SEQSIZE) } when (CURSOR_RIGHT) { getseq call ctoc (sbuf, Tc_cursor_right, SEQSIZE) } when (CURSOR_UP) { getseq call ctoc (sbuf, Tc_cursor_up, SEQSIZE) } when (CURSOR_DOWN) { getseq call ctoc (sbuf, Tc_cursor_down, SEQSIZE) } when (ABS_POS) { getseq call ctoc (sbuf, Tc_abs_pos, SEQSIZE) } when (VERT_POS) { getseq call ctoc (sbuf, Tc_vert_pos, SEQSIZE) } when (HOR_POS) { getseq call ctoc (sbuf, Tc_hor_pos, SEQSIZE) } when (DELETE_LINE) { getseq call ctoc (sbuf, Tc_del_line, SEQSIZE) } when (INSERT_LINE) { getseq call ctoc (sbuf, Tc_ins_line, SEQSIZE) } when (SHIFT_IN) { getseq call ctoc (sbuf, Tc_shift_in, SEQSIZE) } when (SHIFT_OUT) { getseq call ctoc (sbuf, Tc_shift_out, SEQSIZE) } when (COORD_TYPE) { Tc_seq_type = ctoi (buf, bp) Tc_coord_type = ctoi (buf, bp) SKIPBL (buf, bp) Tc_coord_char = mntoc (buf, bp, NUL) } when (SHIFT_TYPE) { SKIPBL (buf, bp) Tc_shift_char = mntoc (buf, bp, NUL) } when (WRAP_AROUND) { getword if (equal (tbuf, "YES"s) == YES) Tc_wrap_around = YES else Tc_wrap_around = NO } when (CLEAR_DELAY) Tc_clear_delay = bound (ctoi (buf, bp), 1, 5000) when (LINE_DELAY) Tc_line_delay = bound (ctoi (buf, bp), 1, 5000) when (POS_DELAY) Tc_pos_delay = bound (ctoi (buf, bp), 1, 5000) when (ROWS) Maxrow = bound (ctoi (buf, bp), 1, MAXROWS) when (COLUMNS) Maxcol = bound (ctoi (buf, bp), 1, MAXCOLS) } # getseq --- get a control sequence from 'buf'; put it 'sbuf' procedure getseq { DEBUG local i, buf; integer i, buf (4) sp = 0 repeat { sp += 1 getword if (tbuf (1) == EOS) break tp = 1 sbuf (sp) = mntoc (tbuf, tp, EOS) } until (sbuf (sp) == EOS || sp >= MAXLINE) sbuf (sp) = EOS DEBUG for (i = 1; i <= sp; i += 1) { DEBUG call ctomn (sbuf (i), buf) DEBUG call print (ERROUT, "*s "s, buf) DEBUG } DEBUG call print (ERROUT, "*n"s) } # interpret_input --- interpret a line giving an input control sequence procedure interpret_input { local ent, tbl, pos; integer ent, tbl, pos if (f == CHAR) { getword f = mntoc (tbuf, 1, ' 'c) } else if (f == PF) f -= ctoi (buf, bp) getseq if (sp <= 1) err ("input control sequence must be specified"s) tbl = 1 for (i = 1; i < sp - 1; i += 1) { ent = Fn_tab (sbuf (i) - CHARSETBASE, tbl) if (ent == EOS) { if (vt$alc (tbl, sbuf (i) - CHARSETBASE) == ERR) err ("too many unique sequence prefixes"s) } else if (ent > GET_NEXT_TABLE) tbl = ent - GET_NEXT_TABLE else err ("proper substring of another sequence is illegal"s) } pos = sbuf (i) - CHARSETBASE if (Fn_tab (pos, tbl) ~= EOS) err ("sequence previously defined"s) if (f == DEFINITION) { if (sp + 1 >= MAXDEF) err ("too many definitions"s) getseq Last_def += 1 f += Last_def Def_buf (Last_def) = EOS Last_def += 1 + ctoc (sbuf, Def_buf (Last_def + 1), MAXDEF - Last_def) } Fn_tab (pos, tbl) = f } undefine (err) end #HD#: vtupd.r 1026 Nov-27-1984 01:11:43 # vtupd --- update the screen with the new screen buffer subroutine vtupd (clr) integer clr include SWT_COMMON integer row, col, lim character nch, cch procedure watch forward if (Display_time == YES) watch if (clr == YES) { # update the whole screen (clear first) Currow = 1 # clearing moves the cursor Curcol = 1 call vt$clr (clr) for (row = 1; row <= Maxrow; row += 1) { if (Last_char (row) < Maxcol) lim = Last_char (row) else lim = Maxcol for (col = 1; col <= lim; col += 1) { vt$upk (nch, Newscr, row, col) if (nch ~= ' 'c) { call vtmove (row, col) call vt$out (nch) } vt$pk (nch, Curscr, row, col) } Col_chg_start (row) = MAXCOLS Col_chg_stop (row) = 0 } Row_chg_start = MAXROWS Row_chg_stop = 0 } else { # only update the changed parts of the screen for (row = Row_chg_start; row <= Row_chg_stop; row += 1) { if (Last_char (row) < Col_chg_stop (row) # can we clear && Tc_clear_to_eol (1) ~= EOS) # to end of line?? lim = Last_char (row) else lim = Col_chg_stop (row) for (col = Col_chg_start (row); col <= lim; col += 1) { vt$upk (nch, Newscr, row, col) vt$upk (cch, Curscr, row, col) if (nch ~= cch) { call vtmove (row, col) call vt$out (nch) vt$pk (nch, Curscr, row, col) } } for (; col <= Col_chg_stop (row); col += 1) { vt$upk (cch, Curscr, row, col) if (cch ~= ' 'c) break } if (col <= Col_chg_stop (row)) { # clear to end of line... call vtmove (row, col) send_str (Tc_clear_to_eol) Currow = Maxrow + 10; Curcol = Maxcol + 10 for (; col <= Col_chg_stop (row); col += 1) vt$pk (' 'c, Curscr, row, col) } Col_chg_start (row) = MAXCOLS Col_chg_stop (row) = 0 } Row_chg_start = MAXROWS Row_chg_stop = 0 } # watch --- display the current time on the screen procedure watch { local face character face (10) call date (SYS_TIME, face) face (6) = EOS # chop off seconds call vtmsg (face, TIME_MSG) } return end #HD#: wind.r 72 Nov-27-1984 01:11:43 # wind --- position to end-of-file integer function wind (fd) filedes fd integer seekf return (seekf (:17777777777, fd)) end #HD#: wkday.r 226 Nov-27-1984 01:11:43 # wkday --- get day-of-week corresponding to month,day,year integer function wkday (month, day, year) integer month, day, year integer lmonth, lday, lyear lmonth = month - 2 lday = day lyear = year if (lmonth <= 0) { lmonth += 12 lyear -= 1 } wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 34, 7) + 1 if (wkday < 1) # correct for the Fortran mod function wkday += 7 return end #HD#: writef.r 485 Nov-27-1984 01:11:43 # writef --- write raw words to a file integer function writef (buf, nw, fd) integer buf (ARB), nw, fd include SWT_COMMON integer off, f integer mapsu, twrit$, dwrit$ f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_WRITE) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) if (nw <= 0) return (0) select (Fd_dev (off)) when (DEV_TTY) { if (LASTOP (off) ~= FD_WRITEF) { call flush$ (f) SET_LASTOP (off, FD_WRITEF) } writef = twrit$ (buf, nw, off) } when (DEV_DSK) { if (LASTOP (off) ~= FD_WRITEF) { call flush$ (f) Fd_count (off) = -Fd_buflen (off) Fd_bufend (off) = Fd_bufstart (off) + Fd_buflen (off) SET_LASTOP (off, FD_WRITEF) } writef = dwrit$ (buf, nw, off) } when (DEV_NULL) { if (LASTOP (off) ~= FD_WRITEF) { call flush$ (f) SET_LASTOP (off, FD_WRITEF) } writef = EOF } else writef = ERR return end #HD#: zmem$.s 255 Nov-27-1984 01:11:44 * zmem$ --- clear uninitialized part of a segment for ldseg$ SUBR ZMEM$ (symbol_table_node) SEG RLIT include "=incl=/lib_def.s.i" LINK ZMEM$ ECB START,,NODE,1 DATA 5,C'ZMEM$' PROC DYNM =20,NODE(3),PTR(2) ST_SEGNUM EQU XB%+1 ST_LOW EQU XB%+3 ST_HIGH EQU XB%+4 START ARGT ENTR ZMEM$ EAXB NODE,* LDA ST_SEGNUM STA PTR LDA ST_LOW STA PTR+1 TCA A1A ADD ST_HIGH TAX EAXB PTR,* CRA LOOP STA XB%,X BDX LOOP PRTN END #HD#: vt$cel.r 117 Nov-27-1984 01:11:44 # vt$cel --- send a clear to end-of-line sequence integer function vt$cel (dummy) integer dummy include SWT_COMMON if (Tc_clear_to_eol (1) == EOS) return (ERR) send_str (Tc_clear_to_eol) return (OK) end #HD#: vt$dln.r 130 Nov-27-1984 01:11:44 # vt$dln --- send a delete line sequence integer function vt$dln (dummy) integer dummy include SWT_COMMON integer i if (Tc_del_line (1) == EOS) return (ERR) send_str (Tc_del_line) call vt$del(Tc_line_delay) return (OK) end #HD#: vt$iln.r 131 Nov-27-1984 01:11:44 # vt$iln --- send an insert line sequence integer function vt$iln (dummy) integer dummy include SWT_COMMON integer i if (Tc_ins_line (1) == EOS) return (ERR) send_str (Tc_ins_line) call vt$del(Tc_line_delay) return (OK) end #HD#: *vt$pos.r* 1742 Oct-31-1984 07:59:21 # vt$pos --- position the cursor absolutely to row and col integer function vt$pos (row, col) integer row, col include SWT_COMMON procedure row_coord forward procedure col_coord forward procedure b200_coord (pos) forward procedure sbee_coord (pos) forward if (row < 1 || col < 1 || row > Maxrow || col > Maxcol) return (ERR) select (Tc_seq_type) when (1) { # absolute, row first, column second send_str (Tc_abs_pos) row_coord col_coord } when (2) { # absolute, column first, row second send_str (Tc_abs_pos) col_coord row_coord } when (3) { # horizontal and vertical only send_str (Tc_vert_pos) row_coord send_str (Tc_hor_pos) col_coord } when (4) { # no absolute positioning! call print (STDOUT, "On the way.") } call vt$del # delay loop of characters return (OK) # row_coord --- output the row coordinate for positioning procedure row_coord { local i, units, tens, hundreds integer i, units, tens, hundreds select (Tc_coord_type) when (1, 4) # simplest kind, most terms are here send_char (Tc_coord_char + row) when (2) # B200, SOL b200_coord (row) when (3) # superbee sbee_coord (row) when (5) { # colorgraphics i = 511 - 10 * (row - 1) units = mod (i, 10) i /= 10 tens = mod (i, 10) i /= 10 hundreds = mod (i, 10) send_char (" "c + 16 + hundreds) send_char (" "c + 16 + tens) send_char (" "c + 16 + units) } when (6) { # HP 9845 & HP 2621 i = row - 1 units = mod (i, 10) tens = i / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char ('y'c) } when (7) { # ansi positioning (vt100, pst100) units = mod (row, 10) tens = row / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char (';'c) } } # col_coord --- output the column coordinate for positioning procedure col_coord { local tcol, tens, units, hundreds, i integer tcol, tens, units, hundreds, i select (Tc_coord_type) when (1) # simplest kind, most terms are here send_char (Tc_coord_char + col) when (2) # B200, SOL b200_coord (col) when (3) # superbee sbee_coord (col) when (4) { # adds consul 980 send_char ('0'c + ((col - 1) / 10)) send_char ('0'c + mod (col - 1, 10)) } when (5) { # colorgraphics i = 6 * (col - 1) units = mod (i, 10) i /= 10 tens = mod (i, 10) i /= 10 hundreds = mod (i, 10) send_char (" "c + 16 + hundreds) send_char (" "c + 16 + tens) send_char (" "c + 16 + units) } when (6) { # HP 9845 & HP 2621 i = col - 1 units = mod (i, 10) tens = i / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char ('C'c) } when (7) { # ansi positioning (vt100, pst100) units = mod (col, 10) tens = col / 10 if (tens ~= 0) send_char (tens + '0'c) send_char (units + '0'c) send_char ('H'c) } } # b200_coord --- put out a b200-style coordinate procedure b200_coord (pos) { integer pos local acc, units, tens; integer acc, units, tens acc = pos - 1 tens = acc / 10 units = acc - 10 * tens acc = units + 16 * tens send_char (acc) } # sbee_coord --- output a coordinate for the Superbee procedure sbee_coord (pos) { integer pos local acc; integer acc send_char ('0'c) acc = pos - 1 send_char ('0'c + (acc / 10)) send_char ('0'c + mod (acc, 10)) } end #HD#: *vtmove.r* 375 Oct-31-1984 07:59:21 # vtmove --- position cursor to row, col with least cost subroutine vtmove (row, col) integer row, col include SWT_COMMON integer i character chr DEBUG call print (ERROUT, "In vtmove (*i, *i)*n"s, row, col) # if the movement would take more chars than absolute positioning # do absolute, else relatively position along the line if (row ~= Currow || iabs (Curcol - col) > Tc_abs_len) call vt$pos (row, col) elif (Curcol > col) for (i = Curcol - col; i > 0; i -= 1) send_str (Tc_cursor_left) else while (Curcol < col) { vt$upk (chr, Newscr, row, Curcol) call vt$out (chr) # updates Curcol automatically } Currow = row Curcol = col # after the move, they had better be return end #HD#: vtbaud.r 117 Nov-27-1984 01:11:44 # vtbaud --- set the terminal baud rate subroutine vtbaud (rate) integer rate include SWT_COMMON if (rate > 19200) Tc_speed = 19200 elif (rate < 50) Tc_speed = 50 else Tc_speed = rate return end #HD#: vt$rel.r 693 Nov-27-1984 01:11:45 # vt$rel --- apply relative positioning to move the cursor subroutine vt$rel (row, col, crow, ccol) integer row, col, crow, ccol include SWT_COMMON integer r, c r = crow c = ccol # try to be intelligent in what little we have # home the cursor and move from there if that is faster if (iabs(row - r) + iabs(col - c) > Tc_home_len + row + col - 2) if (Tc_cursor_home (1) ~= EOS) { send_str (Tc_cursor_home) r = 1 c = 1 } if (Tc_cursor_up (1) ~= EOS) # get cursor up to, or above for (; r > row; r -= 1) send_str (Tc_cursor_up) elif (r > row) { send_str (Tc_cursor_home) r = 1 c = 1 } if (Tc_cursor_down (1) ~= EOS) # now drop it down for (; r < row; r += 1) send_str (Tc_cursor_down) elif (r < row) for (; r < row; r += 1) send_char (LF) # fairly universal # if a CR and move right is faster, then try that if (iabs(col - c) > col - 1) { send_char (CR) c = 1 } if (Tc_cursor_right (1) ~= EOS) # to the right, the far..... right for (; c < col; c += 1) send_str (Tc_cursor_right) elif (c < col) call error ("can't position cursor"p) if (Tc_cursor_left (1) ~= EOS) # finish up to the left for (; c > col; c -= 1) send_str (Tc_cursor_left) elif (c > col) { send_char (CR) for (c = 1; c < col; c += 1) send_str (Tc_cursor_right) } return end #HD#: arctemp.041 144389 Nov-11-1984 01:11:46 #HD#: *getto.r* 2355 Oct-31-1984 07:58:21 # getto --- get to the last file in a path name integer function getto (pathin, pfilename, ppwd, attach_sw) character pathin (ARB) integer pfilename (16), ppwd (3) integer attach_sw include SWT_COMMON integer expand, mktr$ character dirname (MAXTREE), temp (MAXPATH) character fulltree (MAXTREE), diskname (17) integer count, loop, sp, tp, j, save_bplabel (4) shortcall mkonu$ (18) external bponu$ procedure check_code forward procedure getname forward procedure putname forward procedure restore_Bplabel forward call break$ (DISABLE) # no interruptions do j = 1, 4 # while changing save_bplabel (j) = Bplabel (j) # common block values call mklb$f ($1, Bplabel) call break$ (ENABLE) call mkonu$ ("BAD_PASSWORD$"v, loc (bponu$)) attach_sw = YES if (expand (pathin, temp, MAXPATH) == ERR) { attach_sw = NO restore_Bplabel return (ERR) } call mktr$ (temp, fulltree) call mapstr (fulltree, UPPER) if (pathin (1) == EOS) { # case of current directory call at$hom (Errcod) check_code tp = 1 putname pfilename (1) = KCURR # Primos key for current directory attach_sw = NO restore_Bplabel return (OK) } # Count the number of pathname elements to worry about count = 0 for (loop = 1; fulltree (loop) ~= EOS; loop += 1) if (fulltree (loop) == '>'c) count += 1 if (~ (fulltree (1) == '<'c | fulltree (1) == '*'c)) count += 1 loop = 1 repeat { if (loop ~= 1) { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } elif (fulltree (1) == '<'c) { # absolute partition reference if ( ~IS_DIGIT (fulltree (2))) { # partition name (characters) for (tp = 2; fulltree (tp) ~= '>'c; tp += 1) temp (tp - 1) = fulltree (tp) temp (tp - 1) = EOS tp += 1 # step past '>' sp = 1 call ctov (temp, sp, diskname, 17) if (count == 1) putname getname call at$abs (KSETC, diskname, dirname, Errcod) } else { # partition is specified by LDEV number for (tp = 1; fulltree (tp) ~= '>'c; tp += 1) temp (tp) = fulltree (tp) tp += 1 # step past '>' if (count == 1) putname temp (tp - 1) = '>'c for (; fulltree (tp) ~= '>'c && fulltree (tp) ~= EOS; tp += 1) temp (tp) = fulltree (tp) temp (tp) = EOS tp += 1 # step past '>' sp = 1 call ctov (temp, sp, dirname, MAXTREE) call at$ (KSETC, dirname, Errcod) } if (count == 1) { check_code call at$abs (KSETC, "*"v, "MFD XXXXXX"v, Errcod) check_code restore_Bplabel return (OK) } } elif (fulltree (1) == '*'c) { # name references current directory tp = 3 if (count == 1) { # name is in current directory attach_sw = NO putname restore_Bplabel return (OK) } else { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } } else { # absolute reference on any partition tp = 1 if (count == 1) putname getname call at$any (KSETC, dirname, Errcod) if (count == 1) { # special case of //name check_code call at$abs (KSETC, "*"v, "MFD XXXXXX"v, Errcod) check_code restore_Bplabel return (OK) } } check_code loop += 1 } until (loop >= count) putname restore_Bplabel return (OK) 1 continue # bad password return Errcod = EBPAS check_code # check_code --- check return code for errors procedure check_code { local i; integer i if (Errcod ~= 0) { call at$hom (i) attach_sw = NO restore_Bplabel return (ERR) } } # getname --- get the name of the next node in the treename procedure getname { local i, sp; integer i, sp for (i = 1; fulltree (tp) ~= '>'c && fulltree (tp) ~= EOS; {i += 1; tp += 1}) temp (i) = fulltree (tp) temp (i) = EOS tp += 1 # step past the '>' sp = 1 call ctov (temp, sp, dirname, 21) if (i > 40) { Errcod = EITRE check_code } } # putname --- put name and password into 'pfilename' and # 'ppwd' in packed format procedure putname { local i; integer i do i = 1,3 ppwd (i) = " " do i = 1,16 pfilename (i) = " " j = 0 for (i = tp; fulltree (i) ~= EOS && fulltree (i) ~= ' 'c && j <= 32; i += 1) spchar (pfilename, j, fulltree (i)) if (fulltree (i) ~= EOS) { j = 0 for (i += 1; fulltree (i) ~= EOS && j <= 6; i += 1) spchar (ppwd, j, fulltree (i)) } } # restore_Bplabel --- restore saved value of Bplabel procedure restore_Bplabel { local i; integer i call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing Bplabel (i) = save_bplabel (i) # common block values call break$ (ENABLE) } end #HD#: *tscan$.r* 2558 Oct-31-1984 07:58:21 # tscan$ --- traverse tree in the file system integer function tscan$ (path, buf, clev, nlev, action) integer buf (MAXDIRENTRY), clev, nlev, action character path (MAXPATH) common /c$tscn/ state, svgt, svat, sveos, svun (MAXLEV), svps (MAXLEV), svbf (MAXDIRENTRY, MAXLEV), svpw (3, MAXLEV), svpath (MAXPATH) character svpath # original pathname integer sveos, # intermediate EOS position svun, # file unit stack svps, # end of path stack svbf, # directory buffer stack svpw, # directory password stack state # current state bool svgt, # TRUE if a Ga. Tech Primos installation svat # TRUE if reattach has been done on this call integer type, code, i, l, pwd (3), opwd (3), npwd (3) integer follow, ctoc, expand, equal, upkfn$ procedure check_postorder forward procedure reattach forward procedure enter_pwd forward procedure enter_info forward procedure fix_path forward svat = FALSE # we've done no reattach yet on this call if (clev == 0) { # first call, initialize everything ### Set up the state vectors if (expand ("=GaTech="s, svpath, MAXPATH) == ERR || equal (svpath, "yes"s) == NO) svgt = FALSE else svgt = TRUE clev = 1 svps (clev) = ctoc (path, svpath, MAXPATH) + 1 if (and (action, REATTACH) ~= 0) reattach ### Open the current directory for reading call srch$$ (KREAD + KGETU, KCURR, 0, svun (clev), type, code) if (code ~= 0) { clev = 0 return (EOF) } call dir$rd (KINIT, svun (clev), loc (buf), MAXDIRENTRY, code) state = GET_NEXT_ENTRY } repeat { select (state) when (DESCEND) { # descend to next level if (and (action, REATTACH) ~= 0 && ~ svat) reattach if (clev >= nlev) { # are we at the limit? state = GET_NEXT_ENTRY check_postorder next } ### Attach to the new directory enter_pwd call at$swt (svbf (2, clev), 32, 0, pwd, KICUR, code) if (code ~= 0) { state = COULDNT_DESCEND return (ERR) } clev += 1 ### Open it for reading call srch$$ (KREAD + KGETU, KCURR, 0, svun (clev), type, code) if (code ~= 0) { state = ASCEND return (ERR) } state = GET_NEXT_ENTRY } when (COULDNT_DESCEND) { # couldn't descend into last dir if (~ svat) reattach state = GET_NEXT_ENTRY check_postorder } when (GET_NEXT_ENTRY) { # get next entry from this level if (and (action, REATTACH) ~= 0 && ~ svat) reattach path (svps (clev)) = EOS call dir$rd (KREAD, svun (clev), loc (buf), MAXDIRENTRY, code) if (code ~= 0) state = ATEOD elif (rs(buf(1),8) == 2 || rs(buf(1),8) == 3) { buf (1) = 0 # indicate preorder encounter fix_path if (and (buf (20), 8r10007) == 4) { # a ufd but not mfd enter_info # next time we're called, we will state = DESCEND # descend another level } if ( ~(and (buf (20), 7) == 4) # file type is NOT ufd || and (action, PREORDER) ~= 0) return (OK) } # else stay in this state } when (ATEOD) { # at end of directory if (and (action, REATTACH) ~= 0 && ~ svat) reattach call srch$$ (KCLOS, 0, 0, svun (clev), 0, code) state = ASCEND if (and (action, EODPAUSE) ~= 0) return (EOD) } when (ASCEND) { # pop up one level clev -= 1 if (clev <= 0) break reattach state = GET_NEXT_ENTRY check_postorder } else call error ("in tscan$: can't happen"s) } return (EOF) # check_postorder --- return entry on postorder encounter if desired procedure check_postorder { if (and (action, POSTORDER) ~= 0) { call move$ (svbf (1, clev), buf, MAXDIRENTRY) buf (1) = 1 # indicate postorder encounter return (OK) } } # enter_pwd --- get password for next lower directory procedure enter_pwd { local valid_name; bool valid_name local junk; integer junk call gpas$$ (svbf (2, clev), 32, opwd, npwd, code) call texto$ (opwd, 6, junk, valid_name) if (code == ENRIT) { pwd (1) = " " pwd (2) = " " pwd (3) = " " } elif (svgt && valid_name) { pwd (1) = npwd (1) pwd (2) = npwd (2) pwd (3) = npwd (3) } else { pwd (1) = opwd (1) pwd (2) = opwd (2) pwd (3) = opwd (3) } do i = 1, 3 svpw (i, clev) = pwd (i) l = sveos if (pwd (1) ~= " " && pwd (1) ~= 0) { path (l) = ':'c l += 1 + upkfn$ (pwd, 6, path (l + 1), MAXPATH - l) } svps (clev + 1) = l } # fix_path --- add name of current entry to pathname procedure fix_path { l = svps (clev) if (l > 1) { path (l) = '/'c l += 1 } l += upkfn$ (buf (2), 32, path (l), MAXPATH - l + 1) sveos = l } # enter_info --- save info in current directory entry procedure enter_info { call move$ (buf, svbf (1, clev), MAXDIRENTRY) } # reattach --- attach back to the same place procedure reattach { svat = TRUE call at$hom (code) if (follow (svpath, 0) == ERR) { state = ATEOD return (ERR) } for (i = 1; i < clev; i += 1) { call at$swt (svbf (2, i), 32, 0, svpw (1, i), KICUR, code) if (code ~= 0) { state = ATEOD return (ERR) } } } end #HD#: *vtterm.r* 6081 Oct-31-1984 07:58:22 # vtterm --- initialize the common block with values for # the terminal type given integer function vtterm (term_type) integer term_type (MAXTERMTYPE) include SWT_COMMON integer fd, i, bp, tp, sp, f, state integer len_ac (MAXCOORDTYPE), len_hc (MAXCOORDTYPE), len_vc (MAXCOORDTYPE) integer open, length, strbsr, equal, ctoi, getlin, mntoc integer vt$alc, ctoc, vt$ier, gttype, gtattr character fname (MAXLINE) character buf (MAXLINE), tbuf (MAXLINE), sbuf (MAXLINE) character mntoc ################################################################### # Instructions for adding new routines to vth: # # New coordinate types # 1. Increase the definition for MAXCOORDTYPE by one. # 2. Add code in 'vtterm' to check the applicability # of horizontal, vertical, and absolute positioning # sequences. # 3. Add another entry to the 'data' statements giving # the length of coordinates for the three positioning # sequences. # 4. Add code to 'vtpos' to correctly generate both # horizontal and vertical coordinates for the new # coordinate type. # # New positioning types # 1. Increase the definition for MAXPOSTYPE by one. # 2. Add code in 'vtterm' to check the applicability of # horizontal, vertical, and absolute positioning # sequences. # 3. Add code to 'vtpos' to perform the positioning. # # New input control functions: # 1. Add a definition for the function to the definitions # file. Define it to be one greater than the integer # used on the last control function definition. # 2. Add the definition and the string to be used to # recognize the function in the vth file # 3. Add the code to perform the function to the 'select' # statement in 'vt$get'. ################################################################### ### Length of absolute positioning coordinate sequences data len_ac / _ 2, # + ASCII char, + ASCII char 2, # , (b200) 6, # , (sbee) 3, # , (adds 980) 6, # (cg) 6/ # y, C (hp) ### Length of vertical positioning coordinate sequences data len_vc / _ 1, # + ASCII char 1, # (b200) 3, # (sbee) 1, # (adds 980) 3, # (cg) 3/ # (hp) ### Length of horizontal positioning coordinate sequences data len_hc / _ 1, # + ASCII char 1, # (b200) 3, # (sbee) 2, # (adds 980) 3, # (cg) 3/ # (hp) string_table ipos, itext, / ATTN, "attn", / DEFINE, "define", / DEFINITION, "definition", / VTH_ESCAPE, "escape", / FIX_SCREEN, "fix_screen", / FUNNY_RETURN, "funny_return", / GOBBLE_LEFT, "gobble_left", / GOBBLE_RIGHT, "gobble_right", / GOBBLE_SCAN_LEFT, "gobble_scan_left", / GOBBLE_SCAN_RIGHT, "gobble_scan_right", / GOBBLE_TAB_LEFT, "gobble_tab_left", / GOBBLE_TAB_RIGHT, "gobble_tab_right", / INSERT_BLANK, "insert_blank", / INSERT_NEWLINE, "insert_newline", / INSERT_TAB, "insert_tab", / KILL_ALL, "kill_all", / KILL_LEFT, "kill_left", / KILL_RIGHT, "kill_right", / KILL_RIGHT_AND_RETURN, "kill_right_and_return", / MOVE_DOWN, "move_down", / MOVE_LEFT, "move_left", / MOVE_RIGHT, "move_right", / MOVE_UP, "move_up", / PF, "pf", / RETURN, "return", / SCAN_LEFT, "scan_left", / SCAN_RIGHT, "scan_right", / SHIFT_CASE, "shift_case", / SKIP_LEFT, "skip_left", / SKIP_RIGHT, "skip_right", / TAB_CLEAR, "tab_clear", / TAB_LEFT, "tab_left", / TAB_RESET, "tab_reset", / TAB_RIGHT, "tab_right", / TAB_SET, "tab_set", / TOGGLE_INSERT_MODE, "toggle_insert_mode", / UNDEFINE, "undefine" string_table opos, otext, / ABS_POS, "abs_pos", / CLEAR_SCREEN, "clear_screen", / CLEAR_TO_EOL, "clear_to_eol", / CLEAR_TO_EOS, "clear_to_eos", / COLUMNS, "columns", / COORD_TYPE, "coord_type", / CURSOR_DOWN, "cursor_down", / CURSOR_HOME, "cursor_home", / CURSOR_LEFT, "cursor_left", / CURSOR_RIGHT, "cursor_right", / CURSOR_UP, "cursor_up", / DELAY_TIME, "delay_time", / DELETE_CHAR, "delete_char", / DELETE_LINE, "delete_line", / HOR_POS, "hor_pos", / INSERT_CHAR, "insert_char", / INSERT_LINE, "insert_line", / INSERT_STRING, "insert_string", / ROWS, "rows", / SHIFT_IN, "shift_in", / SHIFT_OUT, "shift_out", / SHIFT_TYPE, "shift_type", / VERT_POS, "vert_pos", / WRAP_AROUND, "wrap_around" procedure getword forward procedure getseq forward procedure interpret_input forward procedure interpret_output forward define (err (msg), return (vt$ier (msg, fname, buf, fd))) if (gttype (term_type) == NO || gtattr (TA_VTH_USEABLE) == NO) return (ERR) call encode (fname, MAXLINE, "=vth=/*s"s, term_type) fd = open (fname, READ) if (fd == ERR) return (ERR) Last_def = 0 Fn_used (1) = YES do i = 2, MAXESCAPE Fn_used (i) = NO do i = 1, CHARSETSIZE Fn_tab (i, 1) = EOS do i = 1, MAXCOLS Tabs (i) = NO do i = 1, MAXCOLS, 3 Tabs (i) = YES do i = 1, MAXROWS; { Input_start (i) = MAXCOLS Input_stop (i) = 0 } Maxrow = 8 Maxcol = 32 Tc_clear_screen (1) = EOS Tc_clear_to_eol (1) = EOS Tc_clear_to_eos (1) = EOS Tc_cursor_home (1) = EOS Tc_cursor_left (1) = EOS Tc_cursor_right (1) = EOS Tc_cursor_up (1) = EOS Tc_cursor_down (1) = EOS Tc_abs_pos (1) = EOS Tc_vert_pos (1) = EOS Tc_hor_pos (1) = EOS Tc_ins_line (1) = EOS Tc_del_line (1) = EOS Tc_ins_char (1) = EOS Tc_del_char (1) = EOS Tc_ins_str (1) = EOS Tc_shift_in (1) = EOS Tc_shift_out (1) = EOS Tc_coord_char = ' 'c Tc_shift_char = NUL Tc_coord_type = 0 Tc_seq_type = 0 Tc_delay_time = 0 Tc_wrap_around = YES Tc_clr_len = 9999 Tc_ceos_len = 9999 Tc_ceol_len = 9999 Tc_abs_len = 9999 Tc_vert_len = 9999 Tc_hor_len = 9999 state = ERR while (getlin (tbuf, fd) ~= EOF) { for ({tp = 1; bp = 1}; tbuf (tp) ~= NEWLINE && tbuf (tp) ~= EOS; {tp += 1; bp += 1}) { if (tbuf (tp) == '@'c && tbuf (tp + 1) ~= EOS) tp += 1 else if (tbuf (tp) == '#'c) break buf (bp) = tbuf (tp) } buf (bp) = EOS bp = 1 getword select when (tbuf (1) == EOS) ; when (equal (tbuf, "input"s) == YES) state = READ when (equal (tbuf, "output"s) == YES) state = WRITE ifany next select (state) when (ERR) err ("characteristic appears before 'input' or 'output'"s) when (READ) { f = strbsr (ipos, itext, 1, tbuf) if (f == EOF) err ("unrecognized keyword"s) f = itext (ipos (f)) interpret_input } when (WRITE) { f = strbsr (opos, otext, 1, tbuf) if (f == EOF) err ("unrecognized keyword"s) f = otext (opos (f)) interpret_output } } call close (fd) ### Fill in the default characters for the first table for (i = 1; i < CHARSETSIZE; i += 1) if (Fn_tab (i, 1) == EOS) Fn_tab (i, 1) = i + CHARSETBASE ### Check the plausibility of all control sequences if (Tc_clear_screen (1) == EOS) err ("Screen clear sequence required"s) Tc_clr_len = length (Tc_clear_screen) if (Tc_clear_to_eol (1) ~= EOS) Tc_ceol_len = length (Tc_clear_to_eol) if (Tc_clear_to_eos (1) ~= EOS) Tc_ceol_len = length (Tc_clear_to_eos) if (Tc_coord_type < 1 || Tc_coord_type > MAXCOORDTYPE) err ("Invalid coordinate type"s) select (Tc_seq_type) when (1, 2) { if (Tc_abs_pos (1) == EOS) err ("Absolute positioning sequence required"s) Tc_abs_len = length (Tc_abs_pos) + len_ac (Tc_coord_type) if (Tc_vert_pos (1) ~= EOS) Tc_vert_len = length (Tc_vert_pos) if (Tc_hor_pos (1) ~= EOS) Tc_hor_len = length (Tc_hor_pos) } when (3) { if (Tc_vert_pos (1) == EOS || Tc_hor_pos (1) == EOS) err ("Horizontal/vertical sequence missing"s) Tc_vert_len = length (Tc_vert_pos) + len_vc (Tc_coord_type) Tc_hor_len = length (Tc_hor_pos) + len_hc (Tc_coord_type) } else err ("Invalid sequence type"s) DEBUG call vt$db DEBUG call vt$db2 return (OK) # getword --- get a "word" from 'buf'; put it in 'tbuf' procedure getword { SKIPBL (buf, bp) for (tp = 1; buf (bp) ~= ' 'c && buf (bp) ~= EOS; {bp += 1; tp += 1}) tbuf (tp) = buf (bp) tbuf (tp) = EOS } # interpret_output --- interpret a line for an output control sequence procedure interpret_output { select (f) when (CLEAR_SCREEN) { getseq call ctoc (sbuf, Tc_clear_screen, SEQSIZE) } when (CLEAR_TO_EOL) { getseq call ctoc (sbuf, Tc_clear_to_eol, SEQSIZE) } when (CLEAR_TO_EOS) { getseq call ctoc (sbuf, Tc_clear_to_eos, SEQSIZE) } when (CURSOR_HOME) { getseq call ctoc (sbuf, Tc_cursor_home, SEQSIZE) } when (CURSOR_LEFT) { getseq call ctoc (sbuf, Tc_cursor_left, SEQSIZE) } when (CURSOR_RIGHT) { getseq call ctoc (sbuf, Tc_cursor_right, SEQSIZE) } when (CURSOR_UP) { getseq call ctoc (sbuf, Tc_cursor_up, SEQSIZE) } when (CURSOR_DOWN) { getseq call ctoc (sbuf, Tc_cursor_down, SEQSIZE) } when (ABS_POS) { getseq call ctoc (sbuf, Tc_abs_pos, SEQSIZE) } when (VERT_POS) { getseq call ctoc (sbuf, Tc_vert_pos, SEQSIZE) } when (HOR_POS) { getseq call ctoc (sbuf, Tc_hor_pos, SEQSIZE) } when (DELETE_LINE) { getseq call ctoc (sbuf, Tc_del_line, SEQSIZE) } when (INSERT_LINE) { getseq call ctoc (sbuf, Tc_ins_line, SEQSIZE) } when (INSERT_CHAR) { getseq call ctoc (sbuf, Tc_ins_char, SEQSIZE) } when (DELETE_CHAR) { getseq call ctoc (sbuf, Tc_del_char, SEQSIZE) } when (INSERT_STRING) { getseq call ctoc (sbuf, Tc_ins_str, SEQSIZE) } when (SHIFT_IN) { getseq call ctoc (sbuf, Tc_shift_in, SEQSIZE) } when (SHIFT_OUT) { getseq call ctoc (sbuf, Tc_shift_out, SEQSIZE) } when (COORD_TYPE) { Tc_seq_type = ctoi (buf, bp) Tc_coord_type = ctoi (buf, bp) SKIPBL (buf, bp) Tc_coord_char = mntoc (buf, bp, NUL) } when (SHIFT_TYPE) { SKIPBL (buf, bp) Tc_shift_char = mntoc (buf, bp, NUL) } when (WRAP_AROUND) { getword if (equal (tbuf, "YES"s) == YES) Tc_wrap_around = YES else Tc_wrap_around = NO } when (DELAY_TIME) Tc_delay_time = bound (ctoi (buf, bp), 1, MAXCOLS) when (ROWS) Maxrow = bound (ctoi (buf, bp), 1, MAXROWS) when (COLUMNS) Maxcol = bound (ctoi (buf, bp), 1, MAXCOLS) } # getseq --- get a control sequence from 'buf'; put it 'sbuf' procedure getseq { DEBUG local i, buf; integer i, buf (4) sp = 0 repeat { sp += 1 getword if (tbuf (1) == EOS) break tp = 1 sbuf (sp) = mntoc (tbuf, tp, EOS) } until (sbuf (sp) == EOS || sp >= MAXLINE) sbuf (sp) = EOS DEBUG for (i = 1; i <= sp; i += 1) { DEBUG call ctomn (sbuf (i), buf) DEBUG call print (ERROUT, "*s "s, buf) DEBUG } DEBUG call print (ERROUT, "*n"s) } # interpret_input --- interpret a line giving an input control sequence procedure interpret_input { local ent, tbl, pos; integer ent, tbl, pos if (f == CHAR) { getword f = mntoc (tbuf, 1, ' 'c) } else if (f == PF) f -= ctoi (buf, bp) getseq if (sp <= 1) err ("input control sequence must be specified"s) tbl = 1 for (i = 1; i < sp - 1; i += 1) { ent = Fn_tab (sbuf (i) - CHARSETBASE, tbl) if (ent == EOS) { if (vt$alc (tbl, sbuf (i) - CHARSETBASE) == ERR) err ("too many unique sequence prefixes"s) } else if (ent > GET_NEXT_TABLE) tbl = ent - GET_NEXT_TABLE else err ("proper substring of another sequence is illegal"s) } pos = sbuf (i) - CHARSETBASE if (Fn_tab (pos, tbl) ~= EOS) err ("sequence previously defined"s) if (f == DEFINITION) { if (sp + 1 >= MAXDEF) err ("too many definitions"s) getseq Last_def += 1 f += Last_def Def_buf (Last_def) = EOS Last_def += 1 + ctoc (sbuf, Def_buf (Last_def + 1), MAXDEF - Last_def) } Fn_tab (pos, tbl) = f } undefine (err) end #HD#: addset.r 131 Nov-06-1984 08:48:16 # addset --- put c in set (j) if it fits, increment j integer function addset (c, set, j, maxsiz) integer j, maxsiz character c, set (maxsiz) if (j > maxsiz) addset = NO else { set (j) = c j += 1 addset = YES } return end #HD#: amatch.r 670 Nov-06-1984 08:48:16 # amatch --- (non-recursive) look for match starting at lin (from) integer function amatch (lin, from, pat, tagbeg, tagend) character lin (ARB), pat (MAXPAT) integer from, tagend (9), tagbeg (9) integer omatch, patsiz integer i, j, offset, stack stack = 0 offset = from # next unexamined input character for (j = 1; pat (j) ~= EOS; j += patsiz (pat, j)) if (pat (j) == PAT_CLOSURE) { # a closure entry stack = j j += PAT_CLOSIZE # step over PAT_CLOSURE for (i = offset; lin (i) ~= EOS; ) # match as many as if (omatch (lin, i, pat, j) == NO) # possible break pat (stack + PAT_COUNT) = i - offset pat (stack + PAT_START) = offset offset = i # character that made us fail } else if (pat (j) == PAT_START_TAG) { i = pat (j + 1) tagbeg (i) = offset } else if (pat (j) == PAT_STOP_TAG) { i = pat (j + 1) tagend (i) = offset } else if (omatch (lin, offset, pat, j) == NO) { # non-closure for ( ; stack > 0; stack = pat (stack + PAT_PREVCL)) if (pat (stack + PAT_COUNT) > 0) break if (stack <= 0) { # stack is empty amatch = 0 # return failure return } pat (stack + PAT_COUNT) -= 1 j = stack + PAT_CLOSIZE offset = pat (stack + PAT_START) + pat (stack + PAT_COUNT) } # else omatch succeeded amatch = offset return # success end #HD#: at$swt.s 483 Nov-06-1984 08:48:16 * at$swt --- bad-password-proof interlude to atch$$ SUBR AT$SWT SEG RLIT include "=syscom=/errd.ins.pma" include "=incl=/lib_def.s.i" LINK AT$SWT ECB AT$0,,NAME,6,66 DATA 6,C'AT$SWT' PROC DYNM =38,NAME(3),NAMEL(3),LDISK(3),PWD(3),KEY(3),CODE(3) DYNM ARGS(6),DESCR(4) EXT MKONU$ AT$0 ARGT ENTR AT$SWT EAL BP_UNIT STL DESCR+0 EAL SB% STL DESCR+2 EAL CNAME STL ARGS+0 EAL DESCR STL ARGS+3 EAL ARGS JSXB MKONU$ CALL ATCH$$ AP NAME,*S AP NAMEL,*S AP LDISK,*S AP PWD,*S AP KEY,*S AP CODE,*SL PRTN BP LDA =E$BPAS STA CODE,* PRTN CNAME DATA 13,C'BAD_PASSWORD$' EJCT * bp_unit --- on-unit for the BAD_PASSWORD$ condition DYNM =20,CP(3),LABEL(4) LINK BP_UNIT ECB BP_UNIT0,,CP,1,28 DATA 11,C'AT$.BP_UNIT' PROC BP_UNIT0 ARGT STL LABEL+2 EAL BP IAB STL LABEL+0 CALL PL1$NL AP LABEL,SL END #HD#: atoc.r 323 Nov-06-1984 08:48:16 # atoc --- convert address to string integer function atoc (ptr, xstr, size) integer ptr (3), size character xstr (ARB) integer i integer gitoc, ctoc character str (18) i = 0 if (ptr (1) < 0) { i += 1 str (i) = 'f'c } i += 1 str (i) = and (rs (ptr (1), 13), 3) + '0'c # insert ring number str (i + 1) = '.'c i += gitoc (and (ptr (1), 8r7777), str (i + 2), 5, 8) + 1 str (i + 1) = '.'c i += gitoc (ptr (2), str (i + 2), 7, -8) + 1 if (and (ptr (1), 8r10000) ~= 0) { str (i + 1) = '.'c i += gitoc (rs (ptr (3), 12), str (i + 2), 3, 8) + 1 } return (ctoc (str, xstr, size)) end #HD#: bponu$.r 104 Nov-06-1984 08:48:16 # bponu$ --- on-unit for the BAD_PASSWORD$ condition subroutine bponu$ (cp) longint cp include SWT_COMMON call pl1$nl (Bplabel) call remark ("in bponu$: can't happen"s) return end #HD#: c$end.r 214 Nov-06-1984 08:48:16 # c$end --- clean up after statement count run, output data subroutine c$end integer fd, i integer create integer limit longint count (1) common /c$stc/ limit, count string outfile "_st_count" fd = create (outfile, READWRITE) if (fd == ERR) call cant (outfile) limit -= 1 # last entry is bogus do i = 1, limit call print (fd, "*l*n"p, count (i)) call close (fd) return end #HD#: c$incr.r 103 Nov-06-1984 08:48:17 # c$incr --- increment count for a given statement subroutine c$incr (stmt) integer stmt integer limit longint count (1) common /c$stc/ limit, count count (stmt) += 1 return end #HD#: call$$.s 2864 Nov-06-1984 08:48:17 * call$$ --- execute a P300 or SEG or EPF runfile as a procedure * * integer function call$$ (name, length) * integer name (16), length SUBR CALL$$ SEG RLIT include "=syscom=/errd.ins.pma" include "=syscom=/keys.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" EJCT LINK CALL$$ ECB CALL0,,NAME,3 DATA 6,C'CALL$$' PROC DYNM =38,NAME(3),LENGTH(3),ONUNIT(3) DYNM CODE,RTNSAVE(4),NEWECB(9),RVEC(9) DYNM ARGS(2*3),DESCR(4),STATE(MAXFILESTATE) DYNM FUNIT,TYPE,SMT(2) ECB_PB EQU XB%+0 ECB_FRAME EQU XB%+2 ECB_ROOT EQU XB%+3 ECB_ARGD EQU XB%+4 ECB_NARGS EQU XB%+5 ECB_LB EQU XB%+6 ECB_KEYS EQU XB%+8 RV_PB EQU RVEC+1 RV_L EQU RVEC+3 RV_X EQU RVEC+5 RV_KEYS EQU RVEC+6 RV_ECBAD EQU RVEC+7 K$VMR EQU '20 K$REST EQU '2 EXT MKONU$ CALL0 ARGT ENTR CALL$$ Set up ECB pointer in stack frame CRL Zero out the smt pointer STL SMT CALL MOVE$ Clear P300 fault vectors AP ZEROS,S AP SECTOR0,*S AP =14,SL CALL REST$$ Bring runfile into memory AP RVEC,S AP NAME,*S AP LENGTH,*S AP CODE,SL LDA CODE Check return code... BEQ CHECKECBAD ...successfully loaded SUB =E$BPAR See if we have a SEG runfile... BEQ SEGDIR ...maybe; try loading it LDA =ERR ...error in loading PRTN SEGDIR CALL LDSEG$ Try loading as a SEG runfile AP RVEC,S AP NAME,*S AP LENGTH,*S AP CODE,SL LDA CODE Check return code... BEQ CHECKECBAD ...successfully loaded SUB =E$NTSD See if we have an EPF BEQ EPF_LOAD ...maybe; try loading it LDA =ERR ...error in loading PRTN EPF_LOAD CALL BREAK$ Prevent wierd things during AP =DISABLE,SL the EPF restoration CALL SRCH$$ Attempt to open the file AP =K$VMR+K$GETU,S AP NAME,*S AP LENGTH,*S AP FUNIT,S AP TYPE,S AP CODE,SL LDA CODE Did it open correctly ?? BEQ EPF_REST Yes...next step CALL BREAK$ Didn't work, Re-enable breaks AP =ENABLE,SL LDA =ERR PRTN Return error EPF_REST CALL R$RUN Restore the file into memory AP =K$REST,S AP FUNIT,S AP CODE,SL STL SMT Save the SMT pointer CALL SRCH$$ Close the vmfa file AP =K$CLOS,S AP =C'',S AP =0,S AP FUNIT,S AP TYPE,S AP TYPE,SL Junk variable LDA CODE Test the return code BEQ CALLIT1 No error, prepare for execution LDA =ERR Return error PRTN CHECKECBAD LDL RV_ECBAD Check for address of main ECB... BLEQ CHECKRMODE ...missing, could be an R-mode program STLR PB%+15 Make ECB addressable through XB register CHECKECB LDA ECB_NARGS Check for zero arguments BNE RMODE LDA ECB_KEYS Check keys ANA =$5C1F Ignore exception enables & cond. codes ERA =$1800 Check for 64V addressing mode BEQ CALLIT ERA =$0800 Check for 32I addressing mode BNE RMODE CALLIT CALL BREAK$ Disable breaks AP =DISABLE,SL CALLIT1 LDA CMDSTAT See if we have a pending quit BEQ L1 LDL SMT Test for a leftover SMT BLEQ CALLITERR CALL R$DEL If one exists, delete it AP SMT,SL CALLITERR CALL BREAK$ Yes, reenable breaks AP =ENABLE,SL LDA =ERR Return error PRTN L1 DFLD RTLABEL Save current RTLABEL value locally DFST RTNSAVE LDLR PB%+13 Replace it with our own frame address STL RTLABEL+2 EAL RETURN and return pointer IAB STL RTLABEL CALL IOFL$ Mark file descriptors AP STATE,SL LDL ONUNIT See if caller wants an onunit for ANY$ BLT NOUNIT No STL DESCR+0 Set up onunit descriptor block EAL SB% STL DESCR+2 EAL ANY$ Set up shortcall argument list STL ARGS+0 EAL DESCR STL ARGS+3 EAL ARGS JSXB MKONU$ Establish the onunit NOUNIT CALL BREAK$ Reenable breaks AP =ENABLE,SL CALL AT$HOM Attach HOME AP CODE,SL LDL SMT Test for an epf run BLNE EPF_INVK If so, then invoke it LDX RV_X Load initial registers from RVEC LDL RV_L PCL RV_ECBAD,* Invoke the program JMP RETURN EPF_INVK CALL R$INVK Crank it up AP SMT,SL RETURN CALL BREAK$ Hold off breaks for a moment AP =DISABLE,SL LDL SMT Check for an epf BLEQ CLOSEIT No epf, close files CALL R$DEL Delete the epf memory image AP SMT,SL CLOSEIT CALL COF$ Close files opened by program AP STATE,SL CALL DUPLX$ Restore the terminal configuration AP =-1,SL ANA ='010000 (Save the "output suppressed" bit) STA CODE LDA LWORD ANA ='167777 ORA CODE STA CODE CALL DUPLX$ AP CODE,SL CALL RVONU$ Revert the default onunit AP ANY$,SL DFLD RTNSAVE Restore previous value of RTLABEL DFST RTLABEL CALL BREAK$ AP =ENABLE,SL LDA =OK Indicate successful invocation PRTN CHECKRMODE LDA RV_KEYS Check keys... BNE RMODE ...if they are non-zero, it's R-mode LDL DFT_ECBAD Guess at the location of the ECB STL RV_ECBAD STLR PB%+15 JMP CHECKECB See if it's there EJCT RMODE EAL NEWECB Build an ECB for the R-mode program STL RV_ECBAD STLR PB%+15 LDL RV_PB Set up initial procedure base... LDA ='4000 ...always in segment 4000 STL ECB_PB LDA =10 Set up minimum frame size STA ECB_FRAME STA ECB_ARGD CRA Set up stack root segment number STA ECB_ROOT STA ECB_NARGS No arguments to be passed LDLR PB%+14 Use current link frame STL ECB_LB LDA RV_KEYS Use keys from RVEC STA ECB_KEYS JMP CALLIT ANY$ DATA 4,C'ANY$' DFT_ECBAD DATA '4000,'1000 Default ECB location SECTOR0 DATA '4000,'60 Pointer to P300 fault vectors ZEROS BSZ 14 Size of P300 fault vectors END #HD#: cant.r 84 Nov-06-1984 08:48:17 # cant --- print cant open file message subroutine cant (str) character str (ARB) call putlin (str, ERROUT) call error (": can't open.") return end #HD#: catsub.r 259 Nov-06-1984 08:48:17 # catsub --- add replacement text to end of new subroutine catsub (lin, from, to, sub, new, k, maxnew) integer from (10), to (10), k, maxnew character lin (MAXLINE), new (maxnew), sub (MAXPAT) integer addset integer i, j, junk, ri for (i = 1; sub (i) ~= EOS; i += 1) if (sub (i) == PAT_DITTO) { i += 1 ri = sub (i) + 1 - PAT_MARK for (j = from (ri); j < to (ri); j += 1) junk = addset (lin (j), new, k, maxnew) } else junk = addset (sub (i), new, k, maxnew) return end #HD#: chkarg.r 302 Nov-06-1984 08:48:17 # chkarg --- get and parse single letter arguments integer function chkarg (ap, result) integer ap, result (26) character arg (MAXARG) integer letters, position, i integer getarg letters = 0 for (; getarg (ap, arg, MAXARG) ~= EOF && arg (1) == '-'c; ap += 1) for (i = 2; arg (i) ~= EOS; i += 1) { select when (IS_LOWER (arg (i))) position = arg (i) - 'a'c + 1 when (IS_UPPER (arg (i))) position = arg (i) - 'A'c + 1 else return (ERR) if (result (position) < 0) return (ERR) letters += 1 result (position) = letters } return (letters) end #HD#: chkinp.s 188 Nov-06-1984 08:48:18 * chkinp --- check for terminal input availability * * logical function chkinp (flag) * logical flag SUBR CHKINP SEG RLIT include "=incl=/lib_def.s.i" LINK CHKINP ECB START,,FLAG,1 DATA 6,C'CHKINP' PROC DYNM =20,FLAG(3) START ARGT ENTR CHKINP LT E64R D64R SKS '704 CRA E64V D64V STA FLAG,* PRTN END #HD#: chkstr.r 163 Nov-06-1984 08:48:18 # chkstr --- check if an EOS-terminated string is valid (all printable) integer function chkstr (str, len) character str (ARB) integer len integer i for (i = 1; i <= len && str (i) ~= EOS; i += 1) if (' 'c > str (i) || str (i) >= DEL) return (NO) if (i > len) return (NO) return (YES) end #HD#: chunk$.r 385 Nov-06-1984 08:48:18 # chunk$ --- read one 2K chunk of the runfile into memory integer function chunk$ (bp, seg, fd) longint bp integer seg, fd define (out,1) define (DB,#) integer code, junk, tfd call sgdr$$ (KSPOS, fd, seg + 2, junk, code) DB call errpr$ (KIRTN, code, "positioning segdir", 18, "chunk$", 6) if (code ~= 0) goto out call srch$$ (KREAD + KISEG + KGETU, fd, 0, tfd, junk, code) DB call errpr$ (KIRTN, code, "opening subfile", 15, "chunk$", 6) if (code ~= 0) goto out call prwf$$ (KREAD, tfd, bp, 8r4000, intl (0), junk, code) call srch$$ (KCLOS, 0, 0, tfd, 0, junk) call errpr$ (KIRTN, code, "reading subfile", 15, "chunk$", 6) if (code == 0) return (OK) out; return (ERR) undefine (out) undefine (DB) end #HD#: close.r 440 Nov-06-1984 08:48:18 # close --- close out an open file integer function close (fd) filedes fd include SWT_COMMON integer f if (fd == STDIN1 || fd == STDOUT1 || # ignore closes on standard ports fd == STDIN2 || fd == STDOUT2 || fd == STDIN3 || fd == STDOUT3) return (OK) if (fd < 1 || fd > NFILES) return (ERR) # not a legal file descriptor f = fd_offset (fd) if (Fd_flags (f) == 0) # file is not open return (ERR) if (LASTOP (f) ~= FD_INITIAL) call flush$ (fd) select (Fd_dev (f)) when (DEV_DSK) { call srch$$ (KCLOS, 0, 0, Fd_unit (f), 0, Errcod) Fd_flags (f) = 0 if (Errcod == 0) return (OK) } when (DEV_TTY) { if (fd ~= 1) # never close file #1 Fd_flags (f) = 0 return (OK) } when (DEV_NULL) { Fd_flags (f) = 0 return (OK) } return (ERR) # bad srch$$ or attempt to undefined device end #HD#: cof$.r 222 Nov-06-1984 08:48:18 # cof$ --- close files opened by the last user program subroutine cof$ (state) integer state (MAXFILESTATE) include SWT_COMMON integer i for (i = 1; state (i) ~= ERR; i += 1) if (Fd_flags (fd_offset (state (i))) ~= 0) call close (state (i)) for (i += 1; state (i) ~= ERR; i += 1) call srch$$ (KCLOS, 0, 0, state (i), 0, Errcod) Term_cp = 1 Term_buf (Term_cp) = EOS Term_count = 0 return end #HD#: cpfil$.r 242 Nov-06-1984 08:48:18 # cpfil$ --- copy one file to another subroutine cpfil$ (ifd, ofd, rc) integer ifd, ofd, rc include SWT_COMMON integer buf (1024), code, rnw, junk code = 0 repeat { call prwf$$ (KREAD + KPRER + KCONV, ifd, loc (buf), 1024, intl (0), rnw, Errcod) if (rnw > 0) call prwf$$ (KWRIT + KPRER, ofd, loc (buf), rnw, intl (0), junk, code) } until (Errcod ~= 0 || code ~= 0) rc = ERR if (Errcod == EEOF && code == 0) rc = OK return end #HD#: cpseg$.r 663 Nov-06-1984 08:48:18 # cpseg$ --- copy a segment directory subroutine cpseg$ (ifd, ofd, rc) integer ifd, ofd, rc include SWT_COMMON integer entrya, entryb, ifd2, ofd2, code, type rc = ERR ### Make the "to" segdir the same size as the "from" segdir call sgdr$$ (KGOND, ifd, entrya, entryb, Errcod) if (Errcod ~= 0) return call sgdr$$ (KMSIZ, ofd, entryb, entrya, Errcod) if (Errcod ~= 0) return entryb = -1 repeat { entrya = entryb + 1 ### Position both segdirs to the next entry call sgdr$$ (KFULL, ifd, entrya, entryb, code) if (entryb == -1) { # none left Errcod = 0 break } if (Errcod ~= 0) return call sgdr$$ (KSPOS, ofd, entryb, entrya, Errcod) if (Errcod ~= 0) return ### Open both entries call srch$$ (KREAD + KISEG + KGETU, ifd, 0, ifd2, type, Errcod) if (Errcod ~= 0) return call srch$$ (KRDWR + KISEG + KGETU + ls (type, 10), ofd, 0, ofd2, type, Errcod) if (Errcod ~= 0) { call srch$$ (KCLOS, 0, 0, ifd2, 0, code) return } ### Copy the entry if (type >= 2) call cpseg$ (ifd2, ofd2, code) else call cpfil$ (ifd2, ofd2, code) if (code == ERR) return ### Close the entries call srch$$ (KCLOS, 0, 0, ifd2, 0, Errcod) call srch$$ (KCLOS, 0, 0, ofd2, 0, Errcod) } rc = OK return end #HD#: create.r 150 Nov-06-1984 08:48:18 # create --- create a new file and open it file_des function create (path, mode) character path (ARB) integer mode integer fd integer open, trunc fd = open (path, mode) if (fd ~= ERR) if (trunc (fd) ~= ERR) return (fd) else call close (fd) return (ERR) end #HD#: ctoa.r 310 Nov-06-1984 08:48:18 # ctoa --- convert from character to address longint function ctoa (str, i) character str (ARB) integer i longint fault, ring, seg, word, bit longint gctol SKIPBL (str, i) if (str (i) == 'f'c || str (i) == 'F'c) { i += 1 fault = :20000000000 } else fault = 0 ring = ls (rt (gctol (str, i, 8), 2), 28) if (str (i) == '.'c) i += 1 seg = ls (rt (gctol (str, i, 8), 12), 16) if (str (i) == '.'c) i += 1 word = rt (gctol (str, i, 8), 16) if (str (i) == '.'c) # skip over bit number if present bit = gctol (str, i, 8) return (xor (fault, ring, seg, word)) end #HD#: ctoc.s 249 Nov-06-1984 08:48:19 * ctoc --- convert EOS-terminated string to EOS-terminated string SUBR CTOC SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK CTOC ECB CTOC0,,FROM,3 DATA 4,C'CTOC' PROC DYNM =20,FROM(3),TO(3),LEN(3) CTOC0 ARGT ENTR CTOC LDX =0 LDA LEN,* BEQ OUT TAY EAXB FROM,* EALB TO,* LOOP LDA XB%,X STA LB%,X ERA =EOS BEQ OUT IRX BDY LOOP DRX RCB LDA =EOS STA LB%,X OUT TXA PRTN END #HD#: ctod.r 1174 Nov-06-1984 08:48:19 # ctod --- convert string to double precision real longreal function ctod (str, i) character str (ARB) integer i define (MAXDIG,16) integer j, s, pe (28) integer gctoi longreal v, e, pv (28) character dig (MAXDIG) bool neg data pv / 1d 1, 1d 2, 1d 4, 1d 8, 1d 16, 1d 32, 1d 64, 1d 128, 1d 256, 1d 512, 1d 1024, 1d 2048, 1d 4096, 1d 8192, 1d -1, 1d -2, 1d -4, 1d -8, 1d -16, 1d -32, 1d -64, 1d -128, 1d -256, 1d -512, 1d-1024, 1d-2048, 1d-4096, 1d-8192 / data pe / 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, -1, -2, -4, -8, -16, -32, -64, -128, -256, -512, -1024, -2048, -4096, -8192 / SKIPBL (str, i) # ignore leading blanks neg = (str (i) == '-'c) # check for sign if (str (i) == '+'c || str (i) == '-'c) i += 1 while (str (i) == '0'c) # ignore high-order zeros i += 1 for (j = 1; j < MAXDIG && IS_DIGIT (str (i)); {j += 1; i += 1}) dig (j) = str (i) # collect significant integral digits for (s = 0; IS_DIGIT (str (i)); {s += 1; i += 1}) ; # ignore the rest, adjusting scale factor if (str (i) == '.'c) { # check for a fraction i += 1 if (j == 1) # special case to accurately handle 0.000ddd etc. while (str (i) == '0'c) { i += 1 s -= 1 } for (; j < MAXDIG && IS_DIGIT (str (i)); {j += 1; i += 1}) { dig (j) = str (i) s -= 1 # adjust scale factor } while (IS_DIGIT (str (i))) # discard insig. fractional digits i += 1 } while (j > 1 && dig (j - 1) == '0'c) { # truncate trailing zeros s += 1 # increment the scale factor (multiply by 10) j -= 1 # truncate one trailing zero (divide by 10) } dig (j) = EOS # terminate the digit string if (str (i) == 'e'c || str (i) == 'E'c) { # check for exponent i += 1 s += gctoi (str, i, 10) } v = 0.0 # now convert the mantissa bits for (j = 1; dig (j) ~= EOS; j += 1) v = v * 10.0 + (dig (j) - '0'c) e = 1.0 select when (s > 0) for (j = 14; j > 0; j -= 1) { if (s >= pe (j)) { s -= pe (j) e *= pv (j) } } when (s < 0) for (j = 28; j > 14; j -= 1) { if (s <= pe (j)) { s -= pe (j) e *= pv (j) } } ifany ctod = v * e else ctod = v if (neg) ctod = -ctod return undefine (MAXDIG) end #HD#: ctoi.r 128 Nov-06-1984 08:48:19 # ctoi --- convert decimal string to single precision integer integer function ctoi (str, i) character str (ARB) integer i SKIPBL (str, i) for (ctoi = 0; IS_DIGIT (str (i)); i += 1) ctoi = 10 * ctoi + (str (i) - '0'c) return end #HD#: ctol.r 128 Nov-06-1984 08:48:19 # ctol --- convert decimal string to double precision integer longint function ctol (str, i) character str (ARB) integer i SKIPBL (str, i) for (ctol = 0; IS_DIGIT (str (i)); i += 1) ctol = 10 * ctol + (str (i) - '0'c) return end #HD#: ctomn.r 367 Nov-06-1984 08:48:19 # ctomn --- translate ASCII control character to mnemonic string integer function ctomn (c, rep) character c, rep (4) integer i integer scopy string_table mnpos, mntext "NUL"/ "SOH"/ "STX"/ "ETX"/ "EOT"/ "ENQ"/ "ACK"/ "BEL"/ "BS"/ "HT"/ "LF"/ "VT"/ "FF"/ "CR"/ "SO"/ "SI"/ "DLE"/ "DC1"/ "DC2"/ "DC3"/ "DC4"/ "NAK"/ "SYN"/ "ETB"/ "CAN"/ "EM"/ "SUB"/ "ESC"/ "FS"/ "GS"/ "RS"/ "US"/ "SP"/ "DEL" i = and (c, 8r177) if (0 <= i && i <= 32) # non-printing character return (scopy (mntext, mnpos (i + 2), rep, 1)) elif (i == 127) # rubout (DEL) return (scopy (mntext, mnpos (33 + 2), rep, 1)) else { # printing character rep (1) = c rep (2) = EOS return (1) } end #HD#: ctop.r 156 Nov-06-1984 08:48:19 # ctop --- convert EOS-terminated string to packed string integer function ctop (str, i, pstr, len) character str (ARB) integer i, pstr (ARB), len integer max max = len * CHARS_PER_WORD for (ctop = 0; str (i) ~= EOS && ctop < max; i += 1) spchar (pstr, ctop, str (i)) return end #HD#: ctor.r 86 Nov-06-1984 08:48:19 # ctor --- convert string to single precision real real function ctor (str, i) character str (ARB) integer i longreal ctod return (ctod (str, i)) end #HD#: ctov.r 195 Nov-06-1984 08:48:19 # ctov --- convert EOS-terminated string to varying string integer function ctov (str, i, var, len) character str (ARB) integer i, var (ARB), len integer max max = (len - 1) * CHARS_PER_WORD + CHARS_PER_WORD for (ctov = CHARS_PER_WORD; str (i) ~= EOS && ctov < max; i += 1) spchar (var, ctov, str (i)) ctov -= CHARS_PER_WORD var (1) = ctov return end #HD#: date.r 1596 Nov-06-1984 08:48:20 # date --- pick up useful information about the time of day # Argument 1 is a switch, to select the data returned. # SYS_DATE => date, in format mm/dd/yy # SYS_TIME => time, in format hh:mm:ss # SYS_USERID => login name # SYS_PIDSTR => user number # SYS_DAY => day of the week # SYS_PID => numeric user number in str (1) # SYS_LDATE => name of day, name of month, day, and year # SYS_MINUTES=> number of minutes past midnight in str (1..2) # SYS_SECONDS=> number of seconds past midnight in str (1..2) # SYS_MSEC => number of msec past midnight in str (1..2) # Argument 2 is a string to receive data specified by # argument 1. # Length of string is returned as function value. integer function date (item, str) integer item character str (ARB) integer td (28), day, month, year integer encode, ptoc, wkday, mapup integer snum (2) longint lnum equivalence (snum, lnum) string_table ix, days _ / "sun" / "mon" / "tues" / "wednes" _ / "thurs" / "fri" / "satur" string_table iy, months _ / "January" / "February" / "March" _ / "April" / "May" / "June" _ / "July" / "August" / "September" _ / "October" / "November" / "December" if (item < SYS_DATE || item > SYS_MSEC) { str (1) = EOS return (0) } call timdat (td, 12 + MAXPACKEDUSERNAME) select (item) when (SYS_DATE) # date, in format mm/dd/yy return (encode (str, 9, "*,2p/*,2p/*,2p"s, td (1), td (2), td (3))) when (SYS_TIME) # time, in format hh:mm:ss return (encode (str, 9, "*2,,0i:*2,,0i:*2,,0i"s, td (4) / 60, mod (td (4), 60), td (5))) when (SYS_USERID) # login name return (ptoc (td (13), ' 'c, str, MAXUSERNAME)) when (SYS_PIDSTR) # user number return (encode (str, 4, "*3,,0i"s, td (12))) when (SYS_DAY) { # day of week td (1) = td (1) - '00' td (2) = td (2) - '00' td (3) = td (3) - '00' day = rs (td (2), 8) * 10 + rt (td (2), 8) month = rs (td (1), 8) * 10 + rt (td (1), 8) year = rs (td (3), 8) * 10 + rt (td (3), 8) return (encode (str, 20, "*sday"s, days (ix (wkday (month, day, year) + 1)))) } when (SYS_PID) { # numeric user number in str (1) str (1) = td (12) return (0) } when (SYS_LDATE) { # name of day, name of month, day, and year td (1) = td (1) - '00' td (2) = td (2) - '00' td (3) = td (3) - '00' day = rs (td (2), 8) * 10 + rt (td (2), 8) month = rs (td (1), 8) * 10 + rt (td (1), 8) year = rs (td (3), 8) * 10 + rt (td (3), 8) date = encode (str, 50, "*sday, *s *i, 19*i"s, days (ix (wkday (month, day, year) + 1)), months (iy (month + 1)), day, year) str (1) = mapup (str (1)) return } when (SYS_MINUTES) { # minutes past midnight lnum = td (4) str (1) = snum (1) str (2) = snum (2) return (0) } when (SYS_SECONDS) { # seconds past midnight lnum = intl (td (4)) * 60 + td (5) str (1) = snum (1) str (2) = snum (2) return (0) } when (SYS_MSEC) { # milliseconds past midnight lnum = (intl (td (4)) * 60 + td (5)) * 1000 _ + (td (6) * 1000) / td (11) str (1) = snum (1) str (2) = snum (2) return (0) } return (0) end #HD#: decode.r 5508 Nov-06-1984 08:48:20 # decode --- formatted memory-to-memory conversion routine integer function decode (str, sp, fmt, fp, ap, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) character str (ARB) integer sp, fmt (ARB), fp, ap, a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB) integer cur_sp, cur_fp, cur_ap integer i, num, m, l, tp integer default_width, default_base, default_delim integer width, base, delim integer ctoi, gctoi, length longint ln longint ctoa, gctol character term, tmp (MAXDECODE) real lr real ctor longreal ld longreal ctod procedure interpret_format forward procedure get_num forward procedure convert_num forward procedure error_in_field forward procedure get_str forward procedure decode_packed forward procedure decode_string forward procedure decode_bool forward procedure decode_tab forward procedure decode_addr forward procedure decode_varying forward procedure decode_integer forward procedure decode_longint forward procedure decode_real forward procedure decode_double forward procedure decode_newline forward procedure decode_fill forward procedure too_many_args forward default_width = 0 default_base = 0 default_delim = ' 'c for (; fmt (fp) ~= EOS; fp += 1) { cur_fp = fp # for error recovery cur_sp = sp cur_ap = ap if (fmt (fp) ~= FORMATFLAG) ; # ignore the character else { interpret_format select (fmt (fp)) when (GOTOFORM) ap = width when (DEFAULTFORM) { default_width = width default_base = base default_delim = delim } when (BOOLFORM) decode_bool when (YESNOFORM) decode_bool when (TABFORM) decode_tab when (ADDRFORM) decode_addr when (PACKEDSTRINGFORM) { term = '.'c decode_packed } when (HOLLERITHFORM) { term = EOS decode_packed } when (STRINGFORM) decode_string when (VARYINGFORM) decode_varying when (INTFORM) decode_integer when (LONGINTFORM) decode_longint when (REALFORM) decode_real when (FLOATFORM, DOUBLEFORM) decode_double when (NLINE) decode_newline when (FILLFORM) decode_fill } } return (EOF) # interpret_format --- interpret and set the flags for the format procedure interpret_format { fp +=1 # Get width if (fmt (fp) == ','c) # omitted, use default width = default_width elif (fmt (fp) ~= '#'c) { # indirect convert_num width = num } else { get_num width = num fp += 1 } if (fmt (fp) ~= ','c) # Get base base = default_base else { fp += 1 if (fmt (fp) ~= '#'c) { convert_num base = num } else { get_num base = num fp += 1 } } if (fmt (fp) ~= ','c) # Get delim delim = default_delim else if (fmt (fp + 1) ~= '#'c) { delim = fmt (fp + 1) fp += 2 } else if (fmt (fp + 2) == '#'c) { delim = '#'c fp += 3 } else { get_num delim = num fp += 2 } } # get_num --- grab a number from the argument list; put in 'num' procedure get_num { select (ap) when ( 1) num = a1 (1) when ( 2) num = a2 (1) when ( 3) num = a3 (1) when ( 4) num = a4 (1) when ( 5) num = a5 (1) when ( 6) num = a6 (1) when ( 7) num = a7 (1) when ( 8) num = a8 (1) when ( 9) num = a9 (1) when (10) num = a10 (1) else too_many_args ap += 1 } # convert_num --- grab a number from the format string; put in 'num' procedure convert_num { bool neg neg = (fmt (fp) == '-'c) if (fmt (fp) == '+'c || fmt (fp) == '-'c) fp += 1 num = ctoi (fmt, fp) if (neg) num = - num } # error_in_field --- a field contains an error; return error status procedure error_in_field { fp = cur_fp sp = cur_sp ap = cur_ap return (ERR) } # get_str --- get a delimited string from the input string procedure get_str { if (width > 0) { # delimited by size for (tp = 1; tp <= width && tp <= MAXDECODE; {tp += 1; sp += 1}) { if (str (sp) == NEWLINE || str (sp) == EOS) break tmp (tp) = str (sp) } for (; tp <= width && tp < MAXDECODE; tp += 1) tmp (tp) = ' 'c tmp (tp) = EOS } else { # delimited by delimiter if (delim == ' 'c) SKIPBL (str, sp) for (tp = 1; tp < MAXDECODE; {tp += 1; sp += 1}) { if (str (sp) == NEWLINE || str (sp) == EOS || str (sp) == delim) break tmp (tp) = str (sp) } tmp (tp) = EOS if (str (sp) == delim) # bump over delimiter sp += 1 } } # decode_packed --- decode a packed string procedure decode_packed { get_str if (base == 0) m = MAXLINE else m = base tmp (tp) = term tmp (tp + 1) = EOS i = 1 select (ap) when ( 1) call ctop (tmp, i, a1, m) when ( 2) call ctop (tmp, i, a2, m) when ( 3) call ctop (tmp, i, a3, m) when ( 4) call ctop (tmp, i, a4, m) when ( 5) call ctop (tmp, i, a5, m) when ( 6) call ctop (tmp, i, a6, m) when ( 7) call ctop (tmp, i, a7, m) when ( 8) call ctop (tmp, i, a8, m) when ( 9) call ctop (tmp, i, a9, m) when (10) call ctop (tmp, i, a10, m) else too_many_args ap += 1 } # decode_string --- decode an EOS-terminated string procedure decode_string { get_str if (base == 0) m = MAXLINE else m = base select (ap) when ( 1) call ctoc (tmp, a1, m) when ( 2) call ctoc (tmp, a2, m) when ( 3) call ctoc (tmp, a3, m) when ( 4) call ctoc (tmp, a4, m) when ( 5) call ctoc (tmp, a5, m) when ( 6) call ctoc (tmp, a6, m) when ( 7) call ctoc (tmp, a7, m) when ( 8) call ctoc (tmp, a8, m) when ( 9) call ctoc (tmp, a9, m) when (10) call ctoc (tmp, a10, m) else too_many_args ap += 1 } # decode_bool --- decode a boolean value procedure decode_bool { get_str tp = 1 SKIPBL (tmp, tp) select (tmp (tp)) when (EOS) if (base == 0) m = 0 else m = 1 when ('t'c, 'T'c, 'y'c, 'Y'c, '1'c, 'o'c, 'O'c) m = 1 when ('f'c, 'F'c, 'n'c, 'N'c, '0'c) m = 0 else error_in_field select (ap) when ( 1) a1 (1) = m when ( 2) a2 (1) = m when ( 3) a3 (1) = m when ( 4) a4 (1) = m when ( 5) a5 (1) = m when ( 6) a6 (1) = m when ( 7) a7 (1) = m when ( 8) a8 (1) = m when ( 9) a9 (1) = m when (10) a10 (1) = m else too_many_args ap += 1 } # decode_tab --- handle tab formats procedure decode_tab { m = length (str) if (width <= m) sp = width else sp = m } # decode_addr --- decode an address procedure decode_addr { get_str i = 1 ln = ctoa (tmp, i) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (ln, a1, 2) when ( 2) call move$ (ln, a2, 2) when ( 3) call move$ (ln, a3, 2) when ( 4) call move$ (ln, a4, 2) when ( 5) call move$ (ln, a5, 2) when ( 6) call move$ (ln, a6, 2) when ( 7) call move$ (ln, a7, 2) when ( 8) call move$ (ln, a8, 2) when ( 9) call move$ (ln, a9, 2) when (10) call move$ (ln, a10, 2) else too_many_args ap += 1 } # decode_varying --- decode a PL/I varying string procedure decode_varying { get_str if (base == 0) m = MAXLINE else m = base i = 1 select (ap) when ( 1) call ctov (tmp, i, a1, m) when ( 2) call ctov (tmp, i, a2, m) when ( 3) call ctov (tmp, i, a3, m) when ( 4) call ctov (tmp, i, a4, m) when ( 5) call ctov (tmp, i, a5, m) when ( 6) call ctov (tmp, i, a6, m) when ( 7) call ctov (tmp, i, a7, m) when ( 8) call ctov (tmp, i, a8, m) when ( 9) call ctov (tmp, i, a9, m) when (10) call ctov (tmp, i, a10, m) else too_many_args ap += 1 } # decode_integer --- decode a short integer procedure decode_integer { get_str if (base == 0) base = 10 i = 1 l = gctoi (tmp, i, base) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) a1 (1) = l when ( 2) a2 (1) = l when ( 3) a3 (1) = l when ( 4) a4 (1) = l when ( 5) a5 (1) = l when ( 6) a6 (1) = l when ( 7) a7 (1) = l when ( 8) a8 (1) = l when ( 9) a9 (1) = l when (10) a10 (1) = l else too_many_args ap += 1 } # decode_longint --- decode a long integer procedure decode_longint { get_str if (base == 0) base = 10 i = 1 ln = gctol (tmp, i, base) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (ln, a1, 2) when ( 2) call move$ (ln, a2, 2) when ( 3) call move$ (ln, a3, 2) when ( 4) call move$ (ln, a4, 2) when ( 5) call move$ (ln, a5, 2) when ( 6) call move$ (ln, a6, 2) when ( 7) call move$ (ln, a7, 2) when ( 8) call move$ (ln, a8, 2) when ( 9) call move$ (ln, a9, 2) when (10) call move$ (ln, a10, 2) else too_many_args ap += 1 } # decode_real --- decode a single-precision floating point number procedure decode_real { get_str i = 1 lr = ctor (tmp, i) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (lr, a1, 2) when ( 2) call move$ (lr, a2, 2) when ( 3) call move$ (lr, a3, 2) when ( 4) call move$ (lr, a4, 2) when ( 5) call move$ (lr, a5, 2) when ( 6) call move$ (lr, a6, 2) when ( 7) call move$ (lr, a7, 2) when ( 8) call move$ (lr, a8, 2) when ( 9) call move$ (lr, a9, 2) when (10) call move$ (lr, a10, 2) else too_many_args ap += 1 } # decode_double --- decode a double-precision floating point number procedure decode_double { get_str i = 1 ld = ctod (tmp, i) SKIPBL (tmp, i) if (tmp (i) ~= EOS) error_in_field select (ap) when ( 1) call move$ (ld, a1, 4) when ( 2) call move$ (ld, a2, 4) when ( 3) call move$ (ld, a3, 4) when ( 4) call move$ (ld, a4, 4) when ( 5) call move$ (ld, a5, 4) when ( 6) call move$ (ld, a6, 4) when ( 7) call move$ (ld, a7, 4) when ( 8) call move$ (ld, a8, 4) when ( 9) call move$ (ld, a9, 4) when (10) call move$ (ld, a10, 4) else too_many_args ap += 1 } # decode_fill --- skip a specified number of characters procedure decode_fill { get_str # just thrown them away } # decode_newline --- skip a specified number of NEWLINES procedure decode_newline { if (width <= 0) { # skip one newline, if it's there if (str (sp) == NEWLINE) sp += 1 } else { # skip 'width' newlines i = 1 repeat { while (str (sp) ~= NEWLINE && str (sp) ~= EOS) sp += 1 if (str (sp) == NEWLINE) sp += 1 i += 1 } until (i > width) } if (str (sp) == EOS && fmt (fp + 1) ~= EOS) { fp += 1 return (OK) # get new input line } } # too_many_args --- issue an error message for too many arguments procedure too_many_args { call remark ("in decode: attempt to use more than 10 fields"p) tmp (1) = EOS } end #HD#: delarg.r 147 Nov-06-1984 08:48:20 # delarg --- delete an argument from the command line integer function delarg (ap) integer ap include SWT_COMMON integer i if (ap < 0 || ap >= Arg_c) return (EOF) for (i = ap + 1; i < Arg_c; i += 1) Arg_v (i) = Arg_v (i + 1) Arg_c -= 1 return (OK) end #HD#: delete.r 176 Nov-06-1984 08:48:21 # delete --- remove a symbol from the symbol table subroutine delete (symbol, st) character symbol (ARB) pointer st integer Mem (1) common /ds$mem/ Mem integer st$lu pointer node, pred if (st$lu (symbol, node, pred, st) == YES) { Mem (pred + ST_LINK) = Mem (node + ST_LINK) call dsfree (node) } return end #HD#: dgetl$.s 2717 Nov-06-1984 08:48:21 * dgetl$ --- read one line from a disk file * * integer functin dgetl$ (line, length, fd) * character line (ARB) * integer length * fd_struct fd SUBR DGETL$ (LINE, LENGTH, FD) SEG RLIT include "=syscom=/keys.ins.pma" include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" LINK DGETL$ ECB DGETL,,LINE,3 DATA 6,C'DGETL$' PROC DYNM =20,LINE(3),LENGTH(3),FD(3) DYNM LFD(8),RETURN,XSAVE,NWR,BUFP(2) UNIT EQU LFD+1 BUFSTART EQU LFD+2 BUFLEN EQU LFD+3 BUFEND EQU LFD+4 COUNT EQU LFD+5 BCOUNT EQU LFD+6 FLAGS EQU LFD+7 DGETL ARGT ENTR DGETL$ EAXB FD,* LDA LENGTH,* Get line length S1A Exclude space for EOS STA LENGTH SUB ='400 To allow short LB refs TAX EALB LINE,*X Access LINE through LB LDA LENGTH TCA TAX LINE is indexed by X LDA XB%+FDBCOUNT Check for compressed blanks BLE NOBLANKS TAY Save blank count in Y LDA =BLANK BLOOP1 STA LB%+'400,X Store a blank BDY BUMPX1 Decrement blank count STY XB%+FDBCOUNT Count exhausted, clear FD_BCOUNT BIX NOBLANKS and bump LINE index JMP STORE_EOS End of LINE reached BUMPX1 BIX BLOOP1 Bump LINE index and loop back STY XB%+FDBCOUNT End of LINE reached, save count JMP STORE_EOS NOBLANKS DFLD XB% Make a local copy of file descriptor DFST LFD DFLD XB%+4 DFST LFD+4 LDY BUFSTART Construct pointer to buffer EAL FDBUFADDR,*Y STL BUFP Save for later use by FILL_BUF LDA COUNT See of buffer is empty BNE NOTEMPTY JSY FILL_BUF It is, go fill it JMP LEFT_BYTE Jump into fetch loop NOTEMPTY LDY BUFEND Make buffer addressable thru XB EAXB FDBUFADDR,*Y TAY Buffer is indexed by Y LDA FLAGS See which byte to start with SPL 0 => left JMP# RIGHT_BYTE 1 => right EJCT LEFT_BYTE LDA XB%,Y Fetch word from buffer ICL Isolate left byte CAS =DC1 Check for blank compression flag SKP JMP DC1_LEFT STA LB%+'400,X Store character into LINE CAS =LF Check for NEWLINE SKP JMP# LF_LEFT BIX RIGHT_BYTE Bump LINE index, get next byte JMP END_LEFT End of LINE reached RIGHT_BYTE LDA XB%,Y Fetch word from buffer CAL Isolate right byte CAS =DC1 Check for blank compression flag SKP JMP DC1_RIGHT STA LB%+'400,X Store character into LINE CAS =LF Check for NEWLINE SKP JMP# LF_RIGHT BIX BUMPY1 Bump LINE index BIY END_RIGHT End of LINE, bump buffer index JMP END_RIGHT End of buffer reached BUMPY1 BIY LEFT_BYTE Bump buffer index, get next byte JSY FILL_BUF End of buffer reached, fill it JMP LEFT_BYTE EJCT DC1_LEFT LDA XB%,Y Get blank count from right byte CAL STY COUNT Save buffer index TAY Put blank count in Y LDA =BLANK BLOOPL STA LB%+'400,X BDY BUMPXL LDY COUNT Restore buffer index BIX BUMPYL Bump LINE index IRS# 3 Bump buffer index RCB Ignore end condition JMP END_RIGHT End of LINE reached BUMPYL BIY LEFT_BYTE Bump buffer index, get next byte JSY FILL_BUF Buffer empty, fill it JMP LEFT_BYTE BUMPXL BIX BLOOPL Bump line index, loop back STY BCOUNT End of LINE, save residual count LDY COUNT Restore buffer index IRS# 3 Bump buffer index RCB Ignore end condition JMP END_RIGHT DC1_RIGHT BIY GET_COUNT Bump buffer index JSY FILL_BUF Buffer is empty, fill it GET_COUNT LDA XB%,Y Get blank count from left byte ICL STY COUNT Save buffer index TAY Put blank count in Y LDA =BLANK BLOOPR STA LB%+'400,X Store a blank in LINE BDY BUMPXR Decrement count LDY COUNT No more blanks, restore buffer index BIX RIGHT_BYTE Bump LINE index, get next byte JMP END_LEFT End of LINE BUMPXR BIX BLOOPR Bump LINE index, loop back STY BCOUNT End of LINE, save residual count LDY COUNT Restore buffer index JMP END_LEFT EJCT FILL_BUF STY RETURN Save return address STX XSAVE Save X register across call PCL PRWFADDR,* Read next chunk from disk file AP =K$READ+K$CONV,S AP UNIT,S AP BUFP,S AP BUFLEN,S AP =0L,S AP NWR,S AP CODEADDR,*SL LDX XSAVE Restore X register LDA CODEADDR,* Test return code BEQ FILL_OK ERA =E$EOF Check for end of file BEQ FILL_EOF CRA Clear NWR STA NWR LDA =FDERR Some other error, set bit in FLAGS SKP FILL_EOF LDA# =FDEOF Set EOF bit in FLAGS ORA FLAGS STA FLAGS FILL_OK LDA NWR See how much we got STA COUNT BEQ RETURN_FD ADD BUFSTART Compute new end of buffer STA BUFEND TAY Construct pointer to same EAXB FDBUFADDR,*Y LDA NWR Set up Y with -NWR TCA TAY LDA RETURN STA# 7 EXT PRWF$$ PRWFADDR IP PRWF$$ FDBUFADDR IP FDBUF CODEADDR IP ERRCOD LF_RIGHT EQU * LF_LEFT IRX Bump LINE index RCB BIY END_RIGHT Bump buffer index JMP END_RIGHT In case buffer is empty END_LEFT LDA FLAGS Set byte indicator for right byte SSM JMP SET_BYTE END_RIGHT LDA FLAGS Set byte indicator for left byte SSP SET_BYTE STA FLAGS STY COUNT Save buffer count RETURN_FD EAXB FD,* Copy back local version of FD DFLD LFD+4 copy only modified portion DFST XB%+4 STORE_EOS LDA =EOS Terminate LINE STA LB%+'400,X TXA Return length of LINE ADD LENGTH PRTN END #HD#: dmark$.r 133 Nov-06-1984 08:48:21 # dmark$ --- return the position of a disk file file_mark function dmark$ (f) file_des f include SWT_COMMON integer junk call prwf$$ (KRPOS, Fd_unit (f), intl (0), 0, dmark$, junk, Errcod) if (Errcod ~= 0) return (ERR) return end #HD#: dmpcm$.r 838 Nov-06-1984 08:48:21 # dmpcm$ --- dump the Subsystem common areas for examination subroutine dmpcm$ (fd) filedes fd include SWT_COMMON integer i, tbpptr (2), trtptr (2) character estr (MAXLINE), kstr (MAXLINE), nlstr (MAXLINE) character eofstr (MAXLINE), escstr (MAXLINE), rtstr (MAXLINE) call ctomn (Echar, estr) call ctomn (Kchar, kstr) call ctomn (Nlchar, nlstr) call ctomn (Eofchar, eofstr) call ctomn (Escchar, escstr) call ctomn (Rtchar, rtstr) call print (fd, "Software Tools Common Area:*n"s) call print (fd, " Echar: *4s Kchar: *4s Nlchar: *4s*n"s, estr, kstr, nlstr) call print (fd, " Eofchar: *4s Escchar: *4s Rtchar: *4s*n"s, eofstr, escstr, rtstr) call print (fd, " Isphantom: *4y Cputype: *i Errcod: *i*n"s, Isphantom, Cputype, Errcod) call print (fd, " Kill_resp: *s*n"s, Kill_resp) call print (fd, " Stdporttbl: "s) for (i = 1; i <= MAXSTDPORTS; i += 1) call print (fd, " *3i"s, Stdporttbl (i)) call print (fd, "*n"s) call print (fd, " Passwd: *6s Prtdest: *s Prtform: *s*n"s, Passwd, Prt_dest, Prt_form) tbpptr (1) = Bplabel (2) # reverse the backward ptr's tbpptr (2) = Bplabel (1) trtptr (1) = Rtlabel (2) trtptr (2) = Rtlabel (1) call print (fd, " Bplabel: *a *a Rtlabel: *a *a*n"s, tbpptr (1), Bplabel (3), trtptr (1), Rtlabel (3)) call print (fd, " Cmdstat: *i Comunit: *i Firstuse: *i*n"s, Cmdstat, Comunit, Firstuse) call print (fd, " Termtype: *s Lword: *,-8i*n"s, Termtype, Lword) call print (fd, " Termattr: "s) for (i = 1; i <= MAXTERMATTR; i += 1) call print (fd, " *y"s, Termattr (i)) call print (fd, "*n"s) return end #HD#: dmpfd$.r 948 Nov-06-1984 08:48:22 # dmpfd$ --- dump the contents of a file descriptor subroutine dmpfd$ (fd, ofd) filedes fd, ofd include SWT_COMMON filedes mfd filedes mapsu character name (MAXPATH) integer f, junk integer gfnam$ longint pos procedure display_buffer (f) forward mfd = mapsu (fd) f = fd_offset (mfd) call print (ofd, "Dump of file descriptor *i at *,2a:*n"s, mfd, loc (Fdesc (f))) if (gfnam$ (mfd, name, MAXPATH) ~= ERR) { call putlin (name, ofd) if (Fd_dev (f) == DEV_DSK) { call prwf$$ (KRPOS, Fd_unit (f), loc (0), 0, pos, 0, junk) call print (ofd, " at word *l*n"s, pos) } else call putch (NEWLINE, ofd) } call print (ofd, "*3xDev: *3i*3xBufstart: *6i*3xBufend: *6i*3xBcount: *3i*n"s, Fd_dev (f), Fd_bufstart (f), Fd_bufend (f), Fd_bcount (f)) call print (ofd, "*3xUnit: *3,8i*3xBuflen: *6i*3xCount: *6i*3xFlags: *6,-8,0i*n"s, Fd_unit (f), Fd_buflen (f), Fd_count (f), Fd_flags (f)) call print (ofd, " Last file system return code was *i*n"s, Errcod) if (LASTOP (f) ~= FD_INITIAL && Fd_dev (f) == DEV_DSK) display_buffer (f) return # display_buffer --- print contents of file buffer if appropriate procedure display_buffer (f) { integer f local i, last, lb, rb integer i, last, lb, rb i = Fd_bufstart (f) call print (ofd, "Buffer (at *,2a) contains:*n"s, loc (Fd_buf (i + 1))) select (LASTOP (f)) when (FD_READF, FD_GETLIN) last = Fd_bufend (f) when (FD_WRITEF, FD_PUTLIN) last = i + Fd_buflen (f) + Fd_count (f) else last = 0 for ( ; i < last; i += 1) { lb = rs (Fd_buf (i + 1), 8) rb = rt (Fd_buf (i + 1), 8) if (lb >= ' 'c && lb < DEL) call putch (lb, ofd) else call print (ofd, "<*3,8,0i>"s, lb) if (rb >= ' 'c && rb < DEL) call putch (rb, ofd) else call print (ofd, "<*3,8,0i>"s, rb) } call putch (NEWLINE, ofd) } end #HD#: dodash.r 227 Nov-06-1984 08:48:22 # dodash --- expand array (i-1) - array (i+1) into set (j)... from valid subroutine dodash (valid, array, i, set, j, maxset) integer i, j, maxset character array (ARB), set (maxset), valid (ARB) character esc integer addset, index integer junk, k, limit i += 1 j -= 1 limit = index (valid, esc (array, i)) for (k = index (valid, set (j)); k <= limit; k += 1) junk = addset (valid (k), set, j, maxset) return end #HD#: dopen$.r 492 Nov-06-1984 08:48:22 # dopen$ --- open a disk file for reading and/or writing integer function dopen$ (path, fd, mode, ftype, delay) character path (ARB) filedes fd integer mode, ftype, delay include SWT_COMMON integer at, c, d, f, m, t, u, junk (3), fname (16) integer getto logical missin if (getto (path, fname, junk, at) == ERR) { call at$hom (c) return (ERR) # file could not be reached for some reason } if (missin (delay)) d = 0 else d = delay f = fd_offset (fd) m = or (mode, KGETU) call srch$$ (m, fname, 32, u, t, c) while (d ~= 0 && c == EFIUS) { call sleep$ (intl (500)) call srch$$ (m, fname, 32, u, t, c) if (d ~= -1) d -= 1 } Errcod = c if (c ~= 0) { if (at == YES) call at$hom (c) return (ERR) # Primos couldn't open the file } if (~missin (ftype)) ftype = t if (at == YES) call at$hom (c) Fd_unit (f) = u Fd_flags (f) |= FD_COMP + ls (rt (t, 3), 6) return (fd) end #HD#: dputl$.s 1823 Nov-06-1984 08:48:22 * dputl$ --- put one line on a disk file SUBR DPUTL$ (LINE, FD) SEG RLIT include "=syscom=/keys.ins.pma" include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" LINK DPUTL$ ECB DPUTL,,LINE,2 DATA 6,C'DPUTL$' PROC DYNM =20,LINE(3),FD(3) DYNM LFD(8),XSAVE,LSAVE(2),BUFP(2),RETURN(2),TEMP,JUNK UNIT EQU LFD+1 BUFSTART EQU LFD+2 BUFLEN EQU LFD+3 BUFEND EQU LFD+4 COUNT EQU LFD+5 BCOUNT EQU LFD+6 FLAGS EQU LFD+7 DPUTL ARGT ENTR DPUTL$ EAXB FD,* DFLD XB% DFST LFD DFLD XB%+4 DFST LFD+4 EAL * STA RETURN LDX BUFSTART EAL FDBUFADDR,*X STL BUFP LDX BUFLEN EAXB BUFP,*X LDY COUNT LDX =-'400 EALB LINE,*X LDX =0 LDA FLAGS CSA LDA BCOUNT BEQ NOBLANKS BCR BLANK_L LDA XB%,Y STA TEMP JMP BLANK_R NOBLANKS BCR LEFT_BYTE LDA XB%,Y STA TEMP JMP RIGHT_BYTE EJCT LEFT_BYTE LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_LEFT CAS =EOS SKP JMP# END_LEFT STORE_LEFT ICR CAS =NEWLINE.LS.8 SKP JMP# STORE_RIGHT STA TEMP BIX RIGHT_BYTE JMP END_LEFT RIGHT_BYTE LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_RIGHT CAS =EOS SKP JMP END_RIGHT CAL ERA TEMP STORE_RIGHT STA XB%,Y BIY *+3 JSY# EMPTY_BUF BIX LEFT_BYTE JMP END_RIGHT EJCT BLANK_LEFT IRS BCOUNT RCB BIX BLANK_L JMP# PUTBL_LEFT BLANK_L LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_LEFT CAS =EOS SKP JMP# END_LEFT PUTBL_LEFT IMA BCOUNT PUTBL_L BLE COMP_LEFT CAS =2 JMP# COMP_LEFT JMP# TWO_LEFT CRA IMA BCOUNT CAL ERA =BLANK.LS.8 JMP STORE_RIGHT TWO_LEFT LDA =(BLANK.LS.8)+BLANK STA XB%,Y BIY *+3 JSY# EMPTY_BUF CRA IMA BCOUNT JMP STORE_LEFT COMP_LEFT TAB CAS =0 CAS# =256 LDA# =255 LDA# =255 ERA =DC1.LS.8 STA XB%,Y BIY *+3 JSY# EMPTY_BUF CAL IAB SUB# 2 BNE PUTBL_L IMA BCOUNT JMP STORE_LEFT EJCT BLANK_RIGHT IRS BCOUNT RCB BIX BLANK_R JMP# PUTBL_RIGHT BLANK_R LDA LB%+'400,X CAS =BLANK SKP JMP# BLANK_RIGHT CAS =EOS SKP JMP# END_RIGHT PUTBL_RIGHT IMA BCOUNT PUTBL_R BLE COMP_RIGHT CAS =2 JMP# COMP_RIGHT JMP# TWO_RIGHT CRA IMA BCOUNT ICR IMA TEMP ERA =BLANK STA XB%,Y BIY *+3 JSY# EMPTY_BUF LDA TEMP CAS =NEWLINE.LS.8 SKP JMP# STORE_RIGHT BIX RIGHT_BYTE JMP END_LEFT TWO_RIGHT LDA TEMP ERA =BLANK STA XB%,Y BIY *+3 JSY# EMPTY_BUF CRA IMA BCOUNT CAL ERA =BLANK.LS.8 JMP STORE_RIGHT COMP_RIGHT TAB LDA TEMP ERA =DC1 STA XB%,Y BIY *+3 JSY# EMPTY_BUF TBA CAS =0 CAS# =256 LDA# =255 LDA =255 ICR STA TEMP ICL IAB SUB# 2 BNE PUTBL_R IMA BCOUNT CAL ERA TEMP JMP STORE_RIGHT EJCT EMPTY_BUF STL LSAVE STX XSAVE STY RETURN+1 PCL PRWFADDR,* AP =K$WRIT,S AP UNIT,S AP BUFP,S AP BUFLEN,S AP =0L,S AP JUNK,S AP CODEADDR,*SL LDA CODEADDR,* BNE EMPTY_ERR LDA BUFLEN TAY EAXB BUFP,*Y TCA TAY LDX XSAVE LDL LSAVE JMP% RETURN,* EMPTY_ERR LDA =FDERR ORA FLAGS STA FLAGS LDA =ERR JMP RETURN_FD EXT PRWF$$ PRWFADDR IP PRWF$$ FDBUFADDR IP FDBUF CODEADDR IP ERRCOD EJCT END_LEFT LDA FLAGS SSP JMP SET_FLAGS END_RIGHT LDA TEMP STA XB%,Y LDA FLAGS SSM SET_FLAGS STA FLAGS STY COUNT TXA RETURN_FD EAXB FD,* DFLD LFD+4 DFST XB%+4 PRTN END #HD#: dread$.r 795 Nov-06-1984 08:48:22 # dread$ --- read raw words from disk integer function dread$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer bp, bsize, bstart, ct, n, nwr, op, thresh, u n = nw # number of words left to read op = 0 # number of words already read u = Fd_unit (f) ct = -Fd_count (f) # number of words in file buffer bp = Fd_bufend (f) - ct # index (0 based) of current buffer word bsize = Fd_buflen (f) # size of file buffer bstart = Fd_bufstart (f) # index (0 based) of first buffer word thresh = bsize / 2 Errcod = 0 select when (ct >= n) { # enough words already in file buffer call move$ (Fd_buf (bp + 1), buf, n) ct -= n op = n n = 0 } when (ct > 0) { # empty file buffer into user's buffer call move$ (Fd_buf (bp + 1), buf, ct) op = ct n -= ct ct = 0 } select when (n >= thresh) { # read directly into user's buffer call prwf$$ (KREAD, u, loc (buf (op + 1)), n, intl (0), nwr, Errcod) if (Errcod == 0 || Errcod == EEOF) op += nwr } when (n > 0) { # read into file buffer, then copy call prwf$$ (KREAD, u, loc (Fd_buf (bstart + 1)), bsize, intl (0), ct, Errcod) if (Errcod ~= 0 && Errcod ~= EEOF) ct = 0 Fd_bufend (f) = bstart + ct # update end-of-buffer index if (n > ct) n = ct call move$ (Fd_buf (bstart + 1), buf (op + 1), n) ct -= n op += n } Fd_count (f) = -ct # update file descriptor if (Errcod == EEOF) Fd_flags (f) |= FD_EOF elif (Errcod ~= 0) Fd_flags (f) |= FD_ERR if (op > 0) return (op) return (EOF) end #HD#: dsdbiu.r 345 Nov-06-1984 08:48:23 # dsdbiu --- dump contents of block-in-use subroutine dsdbiu (b, form) pointer b character form integer Mem (1) common /ds$mem/ Mem integer l, s, lmax call print (ERROUT, "*5i *i words in use*n.", b, Mem (b + DS_SIZE)) l = 0 s = b + Mem (b + DS_SIZE) if (form == DIGIT) lmax = 5 else lmax = 50 for (b += DS_OHEAD; b < s; b += 1) { if (l == 0) call print (ERROUT, " .") if (form == DIGIT) call print (ERROUT, " *10i.", Mem (b)) elif (form == LETTER) call print (ERROUT, "*c.", Mem (b)) l += 1 if (l >= lmax) { l = 0 call print (ERROUT, "*n.") } } if (l ~= 0) call print (ERROUT, "*n.") return end #HD#: dsdump.r 315 Nov-06-1984 08:48:23 # dsdump --- produce semi-readable dump of storage subroutine dsdump (form) character form integer Mem (1) common /ds$mem/ Mem pointer p, t, q t = DS_AVAIL call print (ERROUT, "** DYNAMIC STORAGE DUMP ***n.") call print (ERROUT, "*5i *i words in use*n.", 1, DS_OHEAD + 1) p = Mem (t + DS_LINK) while (p ~= LAMBDA) { call print (ERROUT, "*5i *i words available*n.", p, Mem (p + DS_SIZE)) q = p + Mem (p + DS_SIZE) while (q ~= Mem (p + DS_LINK) && q < Mem (DS_MEMEND)) call dsdbiu (q, form) p = Mem (p + DS_LINK) } call print (ERROUT, "** END DUMP ***n.") return end #HD#: dseek$.r 257 Nov-06-1984 08:48:23 # dseek$ --- seek on a disk device integer function dseek$ (pos, f, ra) filemark pos integer f, ra include SWT_COMMON integer junk select (ra) when (ABS) { if (pos < 0) return (ERR) call prwf$$ (KPOSN + KPREA, Fd_unit (f), intl (0), 0, pos, junk, Errcod) if (Errcod ~= 0) return (EOF) } when (REL) { call prwf$$ (KPOSN + KPRER, Fd_unit (f), intl (0), 0, pos, junk, Errcod) if (Errcod ~= 0) return (EOF) } else return (ERR) return (OK) end #HD#: dsfree.r 502 Nov-06-1984 08:48:23 # dsfree --- return a block of storage to the available space list subroutine dsfree (block) pointer block integer Mem (1) common /ds$mem/ Mem pointer p0, p, q integer n character con (10) p0 = block - DS_OHEAD n = Mem (p0 + DS_SIZE) q = DS_AVAIL repeat { p = Mem (q + DS_LINK) if (p == LAMBDA || p > p0) break q = p } if (q + Mem (q + DS_SIZE) > p0) { call remark ("in dsfree: attempt to free unallocated block.") call remark ("type 'c' to continue.") call getlin (con, ERRIN, 10) if (con (1) ~= 'c'c && con (1) ~= 'C'c) stop return # do not attempt to free the block } if (p0 + n == p & p ~= LAMBDA) { n = n + Mem (p + DS_SIZE) Mem (p0 + DS_LINK) = Mem (p + DS_LINK) } else Mem (p0 + DS_LINK) = p if (q + Mem (q + DS_SIZE) == p0) { Mem (q + DS_SIZE) = Mem (q + DS_SIZE) + n Mem (q + DS_LINK) = Mem (p0 + DS_LINK) } else { Mem (q + DS_LINK) = p0 Mem (p0 + DS_SIZE) = n } return end #HD#: dsget.r 427 Nov-06-1984 08:48:23 # dsget --- get pointer to block of at least w available words pointer function dsget (w) integer w integer Mem (1) common /ds$mem/ Mem pointer p, q, l integer n, k character c (10) n = w + DS_OHEAD q = DS_AVAIL repeat { p = Mem (q + DS_LINK) if (p == LAMBDA) { call remark ("in dsget: out of storage space.") call remark ("type 'c' or 'i' for char or integer dump.") call getlin (c, ERRIN, 10) select (c (1)) when ('c'c, 'C'c) call dsdump (LETTER) when ('i'c, 'I'c) call dsdump (DIGIT) call error ("program terminated.") } if (Mem (p + DS_SIZE) >= n) break q = p } k = Mem (p + DS_SIZE) - n if (k >= DS_CLOSE) { Mem (p + DS_SIZE) = k l = p + k Mem (l + DS_SIZE) = n } else { Mem (q + DS_LINK) = Mem (p + DS_LINK) l = p } return (l + DS_OHEAD) end #HD#: dsinit.r 283 Nov-06-1984 08:48:23 # dsinit --- initialize dynamic storage space to w words subroutine dsinit (w) integer w integer Mem (1) common /ds$mem/ Mem pointer t if (w < 2 * DS_OHEAD + 2) call error ("in dsinit: unreasonably small memory size.") # set up avail list: t = DS_AVAIL Mem (t + DS_SIZE) = 0 Mem (t + DS_LINK) = DS_AVAIL + DS_OHEAD # set up first block of space: t = DS_AVAIL + DS_OHEAD Mem (t + DS_SIZE) = w - DS_OHEAD - 1 # -1 for MEMEND Mem (t + DS_LINK) = LAMBDA # record end of memory: Mem (DS_MEMEND) = w return end #HD#: dtoc.r 3835 Nov-06-1984 08:48:23 # dtoc --- convert double precision real to string integer function dtoc (val, out, w, d) longreal val character out (ARB) integer w, d define(DEBUG1,#) # list output and flags define(DEBUG2,#) # list scaling operations define(MAX_DIGITS,14) longreal v, pv (26), round (MAX_DIGITS) integer pe (26), i, e, j, len, no_digits, max_size bool neg, small, exp_format, BASIC_format character digits (17) string dig "0123456789" integer itoc data pv / 1d 2, 1d 4, 1d 8, 1d 16, 1d 32, 1d 64, 1d 128, 1d 256, 1d 512, 1d 1024, 1d 2048, 1d 4096, 1d 8192, 1d -2, 1d -4, 1d -8, 1d -16, 1d -32, 1d -64, 1d -128, 1d -256, 1d -512, 1d-1024, 1d-2048, 1d-4096, 1d-8192/ data pe / 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, -2, -4, -8, -16, -32, -64, -128, -256, -512, -1024, -2048, -4096, -8192/ data round / .05d0, .005d0, .0005d0, .00005d0, .000005d0, .0000005d0, .00000005d0, .000000005d0, .0000000005d0, .00000000005d0, .000000000005d0, .0000000000005d0, .00000000000005d0, .000000000000005d0/ DEBUG2 write (1, 1) val; 1 format ("input value ", E25.15) ### set flags indicating whether the number is greater or ### less that zero, and whether its absolute value is ### greater or less than 1 v = dabs (val) neg = (val < 0.0) small = (v < 0.1) ### scale number to 0.01 <= v < 10.0 e = -1 if (small) { # number is less than 0.1 for (i = 26; i > 13; i -= 1) if (v < pv (i)) { v /= pv (i) e += pe (i) DEBUG2 write (1, 2) e, v; 2 format ("scale ", I6, E25.15) } } else { for (i = 13; i > 0; i -= 1) if (v >= pv (i) / 10.0) { v /= pv (i) e += pe (i) DEBUG2 write (1, 3) e, v; 3 format ("scale ", I6, E25.15) } } ### scale number so that 0.1 <= v < 1.0 DEBUG2 write (1, 4) e, v; 4 format ("before last scale ", I6, E25.15) if (v >= 1.0) { # be sure 0.1 <= v < 1.0 v /= 10.0 e += 1 } elif (v < 0.1) { v *= 10.0 e -= 1 } if (v == 0.0) # not likely, but possible e = 0 DEBUG2 write (1, 5) e, v; 5 format ("after last scale ", I6, E25.15) ### start tally for the maximum size of the number to ### determine if an error should be returned. if (neg) max_size = 1 else max_size = 0 ### determine exact format for printing BASIC_format = (d > MAX_DIGITS) if (BASIC_format) { # BASIC-like format exp_format = (e > 5 | e < -2) if (exp_format) { no_digits = 6 max_size = max_size + 1 + 1 + 5 + 1 + 1 + 4 # 9 . 99999 e + 9999 } else { no_digits = 6 + min0 (0, e) # in case e is negative max_size = max_size + 1 + 1 + 5 # 9 . 99999 } } elif (d >= 0) { # Fortran 'F' format exp_format = (w < 1 + max0 (e, 1) + 1 + d) # + eee... . ddd... if (exp_format) { # is there too little space? no_digits = max0 (1, w - 1 - 1 - 6) # + 9 . e+9999 max_size = max_size + 1 + no_digits + 6 # . nnnnnn e+9999 } else { no_digits = e + d + 1 # negative e is OK here max_size = max_size + max0 (e, 0) + 1 + d # eee... . ddd... } } else { # d < 0 # Fortran 'E' format exp_format = TRUE no_digits = min0 (MAX_DIGITS, -d) # remember, d < 0 max_size = max_size + 1 + no_digits + 6 # . ddd... e+9999 } ### be sure the number of digits is in range no_digits = min0 (max0 (1, no_digits), MAX_DIGITS) ### round the number at digit (no_digits+ 1) v += round (no_digits) ### handle the unusual situation of rounding from .999... ### up to 1.000... if (v >= 1.0) { v /= 10.0 e += 1 if (~ exp_format) { max_size += 1 no_digits = min0 (MAX_DIGITS, no_digits + 1) } } ### see if the number will fit in 'w' characters if (max_size > w) { out (1) = '?'c out (2) = EOS dtoc = 1 DEBUG1 call print (ERROUT, "dtoc:*2i out:*s*n.", dtoc, out) return } DEBUG2 write (1, 6) v; 6 format ("after rounding ", E25.15) ### extract the first digits do i = 1, no_digits; { v *= 10.0d0 j = v # truncate to integer v -= j # lop off the integral part digits (i) = dig (j + 1) } DEBUG1 integer db1 DEBUG1 call print (ERROUT, "w:*2i d:*2i .", w, d) DEBUG1 call putlit ("small:.", '.'c, ERROUT) DEBUG1 if (small) DEBUG1 call putlit ("YES .", '.'c, ERROUT) DEBUG1 else DEBUG1 call putlit ("NO .", '.'c, ERROUT) DEBUG1 call putlit ("neg:.", '.'c, ERROUT) DEBUG1 if (neg) DEBUG1 call putlit ("YES .", '.'c, ERROUT) DEBUG1 else DEBUG1 call putlit ("NO .", '.'c, ERROUT) DEBUG1 call putlit ("exp_format:.", '.'c, ERROUT) DEBUG1 if (exp_format) DEBUG1 call putlit ("YES .", '.'c, ERROUT) DEBUG1 else DEBUG1 call putlit ("NO .", '.'c, ERROUT) DEBUG1 call print (ERROUT, "e:*6i no_digits:*2i .", e, no_digits) DEBUG1 call putlit ("digits:.", '.'c, ERROUT) DEBUG1 for (db1 = 1; db1 <= no_digits; db1 += 1) DEBUG1 call putch (digits (db1), ERROUT) DEBUG1 call putch (BLANK, ERROUT) ### take digit string and exponent and arrange into ### desired format, depending on 'exp_format' and 'BASIC_format' len = 1 if (neg) { out (1) = '-'c len += 1 } if (exp_format) { # set up exponential format out (len) = digits (1) out (len + 1) = '.'c len += 2 for (i = 2; i <= no_digits; i += 1) { out (len) = digits (i) len += 1 } if (BASIC_format) # if BASIC, skip trailing zeroes while (len > 2) { len -= 1 if (out (len) == '.'c) break else if (out (len) ~= '0'c) { len += 1 # non-digit -- keep it break } } out (len) = 'e'c len += 1 if (e < 0) { out (len) = '-'c len += 1 e = -e } len += itoc (e, out (len), w - len) } elif (e < 0) { # handle fixed numbers < 1 ### special case numbers from .5000... to .9999... if (d == 0 && e == -1 && digits (1) >= '5'c) out (len) = '1'c else out (len) = '0'c out (len + 1) = '.'c len += 2 for (i = 1; i < -e && i <= d; i += 1) { out (len) = '0'c len += 1 } for (j = 1; j <= no_digits && i <= d; j += 1) { out (len) = digits (j) len += 1 i += 1 } if (BASIC_format) # if BASIC, skip trailing zeroes while (len > 2) { len -= 1 if (out (len) == '.'c) break else if (out (len) ~= '0'c) { len += 1 # non-digit -- keep it break } } else for (i = 1; i < d + e - no_digits && i <= d; i += 1) { out (len) = '0'c len += 1 } } elif (e >= no_digits) { # handle numbers >= 1 with dp after figures for (i = 1; i <= no_digits; i += 1) { out (len) = digits (i) len += 1 } for (i = no_digits; i <= e; i += 1) { out (len) = '0'c len += 1 } if (~ BASIC_format) { # no trailing dp or zeroes in BASIC out (len) = '.'c len += 1 for (i = 1; i <= d; i += 1) { out (len) = '0'c len += 1 } } } else { # handle numbers > 1 with dp inside figures e += 1 for (i = 1; i <= e; i += 1) { out (len) = digits (i) len += 1 } out (len) = '.'c len += 1 for (j = 1; i <= no_digits && j <= d; j += 1) { out (len) = digits (i) i += 1 len += 1 } if (BASIC_format) # if BASIC, skip trailing zeroes while (len > 2) { len -= 1 if (out (len) == '.'c) break elif (out (len) ~= '0'c) { len += 1 # non-digit -- keep it break } } else for (i = 1; i <= e + d - no_digits && i <= d; i += 1) { out (len) = '0'c len += 1 } } out (len) = EOS dtoc = len - 1 DEBUG1 call print (ERROUT, "dtoc:*2i out:*s*n.", dtoc, out) return undefine (DEBUG1) undefine (DEBUG2) undefine (MAX_DIGITS) end #HD#: dwrit$.r 676 Nov-06-1984 08:48:24 # dwrit$ --- write raw words to disk integer function dwrit$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer i, bp, n, ip, nwr, ct, bstart, bsize, thresh n = nw # number of words to write ip = 0 # input buffer pointer ct = - Fd_count (f) # number of words left in buffer bp = Fd_bufend (f) - ct # index (0 based) of next buffer word bsize = Fd_buflen (f) # length of file buffer bstart = Fd_bufstart (f) # index (0 based) of first buffer word thresh = bsize / 2 Errcod = 0 if (nw >= thresh) { # write directly from user's buffer if (bsize - ct > 0) { call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (bstart + 1)), bsize - ct, intl (0), nwr, Errcod) bp = bstart ct = bsize } if (Errcod == 0) call prwf$$ (KWRIT, Fd_unit (f), loc (buf (ip + 1)), n, intl (0), nwr, Errcod) if (Errcod == 0) ip += nwr } else { while (n > 0) { if (ct <= 0) { call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (bstart + 1)), bsize, intl (0), nwr, Errcod) if (Errcod ~= 0) break bp = bstart ct = bsize } i = n if (i > ct) i = ct call move$ (buf (ip + 1), Fd_buf (bp + 1), i) ip += i bp += i n -= i ct -= i } } Fd_count (f) = -ct if (Errcod ~= 0) { Fd_flags (f) |= FD_ERR return (EOF) } return (ip) end #HD#: encode.r 7556 Nov-06-1984 08:48:24 # encode --- formatted memory-to-memory conversion routine integer function encode (str, max, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) character str (ARB) integer max, fmt (ARB), a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB) integer i, arg, cur, max_cur, num, m, l, default_width, default_base, default_fill integer width, rjust, base, fill integer ptoc, ctoc, gitoc, gltoc, rtoc, dtoc, vtoc, atoc, ctoi character term, tmp (MAXLINE) procedure interpret_format forward procedure get_num forward procedure convert_num forward procedure fill_field (len) forward procedure putstr forward procedure encode_packed forward procedure encode_string forward procedure encode_bool forward procedure encode_yesno forward procedure encode_tab forward procedure encode_addr forward procedure encode_varying forward procedure encode_integer forward procedure encode_longint forward procedure encode_real forward procedure encode_double forward procedure encode_newline forward procedure too_many_args forward define (putchar (x), {str (cur) = x; cur += 1}) arg = 1 cur = 1 max_cur = 1 default_width = 0 default_base = 0 default_fill = ' 'c for (i = 1; fmt (i) ~= EOS && cur < max; i += 1) { if (fmt (i) ~= FORMATFLAG) putchar (fmt (i)) else { interpret_format select (fmt (i)) when (GOTOFORM) arg = width when (DEFAULTFORM) { default_width = width default_base = base default_fill = fill } when (BOOLFORM) encode_bool when (YESNOFORM) encode_yesno when (TABFORM) encode_tab when (ADDRFORM) encode_addr when (PACKEDSTRINGFORM) { term = '.'c encode_packed } when (HOLLERITHFORM) { term = EOS encode_packed } when (STRINGFORM) encode_string when (CHARFORM) { # compatibility only base = 1 encode_string } when (VARYINGFORM) encode_varying when (INTFORM) encode_integer when (RCINTFORM) { # compatibility only base = -base encode_integer } when (LONGINTFORM) encode_longint when (RCLONGINTFORM) { # compatibility only base = -base encode_longint } when (REALFORM) encode_real when (FLOATFORM, DOUBLEFORM) encode_double when (NLINE) encode_newline when (FILLFORM) fill_field (width) else putchar (fmt (i)) } } if (max_cur > cur) cur = max_cur str (cur) = EOS return (cur - 1) # interpret_format --- interpret and set the flags for the format procedure interpret_format { ### Get width: i += 1 if (fmt (i) == ','c || IS_LETTER (fmt (i))) # default width = default_width else if (fmt (i) == '#'c) { # indirect get_num i += 1 width = num } else { # specified convert_num width = num } if (width >= 0) # Get rjust rjust = NO else { rjust = YES width = -width } ### Get base: if (fmt (i) ~= ','c) # no more format specs base = default_base else { i += 1 if (fmt (i) == ','c || IS_LETTER (fmt (i))) # default base = default_base else if (fmt (i) == '#'c) { # indirect get_num i += 1 base = num } else { # specified convert_num base = num } } ### Get fill character: if (fmt (i) ~= ','c) # no more format specs fill = default_fill elif (fmt (i + 1) ~= '#'c) { # not indirect fill = fmt (i + 1) i += 2 } elif (fmt (i + 2) == '#'c) { # double "#" fill = '#'c i += 3 } else { # indirect get_num fill = num i += 2 } } # get_num --- grab a number from the argument list; put in 'num' procedure get_num { select (arg) when ( 1) num = a1 (1) when ( 2) num = a2 (1) when ( 3) num = a3 (1) when ( 4) num = a4 (1) when ( 5) num = a5 (1) when ( 6) num = a6 (1) when ( 7) num = a7 (1) when ( 8) num = a8 (1) when ( 9) num = a9 (1) when (10) num = a10 (1) else too_many_args arg += 1 } # convert_num --- grab a number from the format string; put in 'num' procedure convert_num { bool neg neg = (fmt (i) == '-'c) if (fmt (i) == '+'c || fmt (i) == '-'c) i += 1 num = ctoi (fmt, i) if (neg) num = - num } # putstr --- put the string in 'tmp' into 'str' at 'cur' procedure putstr { cur += ctoc (tmp, str (cur), max - cur + 1) } # fill_field --- output 'len' fill character, but don't overflow 'str' procedure fill_field (len) { integer len local i integer i for (i = 1; i <= len && cur < max; {cur += 1; i += 1}) str (cur) = fill } # encode_packed --- encode a packed string procedure encode_packed { if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 select (arg) when ( 1) l = ptoc (a1, term, str (cur), m) when ( 2) l = ptoc (a2, term, str (cur), m) when ( 3) l = ptoc (a3, term, str (cur), m) when ( 4) l = ptoc (a4, term, str (cur), m) when ( 5) l = ptoc (a5, term, str (cur), m) when ( 6) l = ptoc (a6, term, str (cur), m) when ( 7) l = ptoc (a7, term, str (cur), m) when ( 8) l = ptoc (a8, term, str (cur), m) when ( 9) l = ptoc (a9, term, str (cur), m) when (10) l = ptoc (a10, term, str (cur), m) else too_many_args cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 select (arg) when ( 1) l = ptoc (a1, term, tmp, m) when ( 2) l = ptoc (a2, term, tmp, m) when ( 3) l = ptoc (a3, term, tmp, m) when ( 4) l = ptoc (a4, term, tmp, m) when ( 5) l = ptoc (a5, term, tmp, m) when ( 6) l = ptoc (a6, term, tmp, m) when ( 7) l = ptoc (a7, term, tmp, m) when ( 8) l = ptoc (a8, term, tmp, m) when ( 9) l = ptoc (a9, term, tmp, m) when (10) l = ptoc (a10, term, tmp, m) else too_many_args fill_field (width - l) putstr } arg += 1 } # encode_string --- encode an EOS-terminated string procedure encode_string { if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 select (arg) when ( 1) l = ctoc (a1, str (cur), m) when ( 2) l = ctoc (a2, str (cur), m) when ( 3) l = ctoc (a3, str (cur), m) when ( 4) l = ctoc (a4, str (cur), m) when ( 5) l = ctoc (a5, str (cur), m) when ( 6) l = ctoc (a6, str (cur), m) when ( 7) l = ctoc (a7, str (cur), m) when ( 8) l = ctoc (a8, str (cur), m) when ( 9) l = ctoc (a9, str (cur), m) when (10) l = ctoc (a10, str (cur), m) else too_many_args cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 select (arg) when ( 1) l = ctoc (a1, tmp, m) when ( 2) l = ctoc (a2, tmp, m) when ( 3) l = ctoc (a3, tmp, m) when ( 4) l = ctoc (a4, tmp, m) when ( 5) l = ctoc (a5, tmp, m) when ( 6) l = ctoc (a6, tmp, m) when ( 7) l = ctoc (a7, tmp, m) when ( 8) l = ctoc (a8, tmp, m) when ( 9) l = ctoc (a9, tmp, m) when (10) l = ctoc (a10, tmp, m) else too_many_args fill_field (width - l) putstr } arg += 1 } # encode_bool --- encode a boolean value procedure encode_bool { select (arg) when ( 1) l = a1 (1) when ( 2) l = a2 (1) when ( 3) l = a3 (1) when ( 4) l = a4 (1) when ( 5) l = a5 (1) when ( 6) l = a6 (1) when ( 7) l = a7 (1) when ( 8) l = a8 (1) when ( 9) l = a9 (1) when (10) l = a10 (1) else too_many_args if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 if (l ~= 0) # true l = ctoc ("TRUE"s, str (cur), m) else l = ctoc ("FALSE"s, str (cur), m) cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 if (l == 1) # true l = ctoc ("TRUE"s, tmp, m) else l = ctoc ("FALSE"s, tmp, m) fill_field (width - l) putstr } arg += 1 } # encode_yesno --- encode a YES/NO value procedure encode_yesno { select (arg) when ( 1) l = a1 (1) when ( 2) l = a2 (1) when ( 3) l = a3 (1) when ( 4) l = a4 (1) when ( 5) l = a5 (1) when ( 6) l = a6 (1) when ( 7) l = a7 (1) when ( 8) l = a8 (1) when ( 9) l = a9 (1) when (10) l = a10 (1) else too_many_args if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 if (l == YES) l = ctoc ("YES"s, str (cur), m) elif (l == NO) l = ctoc ("NO"s, str (cur), m) else l = ctoc ("?"s, str (cur), m) cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 if (l == YES) l = ctoc ("YES"s, tmp, m) elif (l == NO) l = ctoc ("NO"s, tmp, m) else l = ctoc ("?"s, tmp, m) fill_field (width - l) putstr } arg += 1 } # encode_tab --- handle tab formats procedure encode_tab { if (cur > max_cur) max_cur = cur for ( ; max_cur < width && max_cur < max; max_cur += 1) str (max_cur) = fill cur = width } # encode_addr --- encode an address procedure encode_addr { select (arg) when ( 1) l = atoc (a1, tmp, MAXLINE) when ( 2) l = atoc (a2, tmp, MAXLINE) when ( 3) l = atoc (a3, tmp, MAXLINE) when ( 4) l = atoc (a4, tmp, MAXLINE) when ( 5) l = atoc (a5, tmp, MAXLINE) when ( 6) l = atoc (a6, tmp, MAXLINE) when ( 7) l = atoc (a7, tmp, MAXLINE) when ( 8) l = atoc (a8, tmp, MAXLINE) when ( 9) l = atoc (a9, tmp, MAXLINE) when (10) l = atoc (a10, tmp, MAXLINE) else too_many_args if (rjust == NO) { fill_field (width - l) putstr } else { putstr fill_field (width - l) } arg += 1 } # encode_varying --- encode a PL/I varying string procedure encode_varying { if (rjust == NO) { m = max - cur + 1 if (base ~= 0 && base + 1 < m) m = base + 1 select (arg) when ( 1) l = vtoc (a1, str (cur), m) when ( 2) l = vtoc (a2, str (cur), m) when ( 3) l = vtoc (a3, str (cur), m) when ( 4) l = vtoc (a4, str (cur), m) when ( 5) l = vtoc (a5, str (cur), m) when ( 6) l = vtoc (a6, str (cur), m) when ( 7) l = vtoc (a7, str (cur), m) when ( 8) l = vtoc (a8, str (cur), m) when ( 9) l = vtoc (a9, str (cur), m) when (10) l = vtoc (a10, str (cur), m) else too_many_args cur += l fill_field (width - l) } else { if (base == 0 || base + 1 >= MAXLINE) m = MAXLINE else m = base + 1 select (arg) when ( 1) l = vtoc (a1, tmp, m) when ( 2) l = vtoc (a2, tmp, m) when ( 3) l = vtoc (a3, tmp, m) when ( 4) l = vtoc (a4, tmp, m) when ( 5) l = vtoc (a5, tmp, m) when ( 6) l = vtoc (a6, tmp, m) when ( 7) l = vtoc (a7, tmp, m) when ( 8) l = vtoc (a8, tmp, m) when ( 9) l = vtoc (a9, tmp, m) when (10) l = vtoc (a10, tmp, m) else too_many_args fill_field (width - l) putstr } arg += 1 } # encode_integer --- encode and justify an integer procedure encode_integer { select (arg) when ( 1) l = gitoc (a1, tmp, MAXLINE, base) when ( 2) l = gitoc (a2, tmp, MAXLINE, base) when ( 3) l = gitoc (a3, tmp, MAXLINE, base) when ( 4) l = gitoc (a4, tmp, MAXLINE, base) when ( 5) l = gitoc (a5, tmp, MAXLINE, base) when ( 6) l = gitoc (a6, tmp, MAXLINE, base) when ( 7) l = gitoc (a7, tmp, MAXLINE, base) when ( 8) l = gitoc (a8, tmp, MAXLINE, base) when ( 9) l = gitoc (a9, tmp, MAXLINE, base) when (10) l = gitoc (a10, tmp, MAXLINE, base) else too_many_args if (rjust == NO) { fill_field (width - l) putstr } else { putstr fill_field (width - l) } arg += 1 } # encode_longint --- encode and justify an long integer procedure encode_longint { select (arg) when ( 1) l = gltoc (a1, tmp, MAXLINE, base) when ( 2) l = gltoc (a2, tmp, MAXLINE, base) when ( 3) l = gltoc (a3, tmp, MAXLINE, base) when ( 4) l = gltoc (a4, tmp, MAXLINE, base) when ( 5) l = gltoc (a5, tmp, MAXLINE, base) when ( 6) l = gltoc (a6, tmp, MAXLINE, base) when ( 7) l = gltoc (a7, tmp, MAXLINE, base) when ( 8) l = gltoc (a8, tmp, MAXLINE, base) when ( 9) l = gltoc (a9, tmp, MAXLINE, base) when (10) l = gltoc (a10, tmp, MAXLINE, base) else too_many_args if (rjust == NO) { fill_field (width - l) putstr } else { putstr fill_field (width - l) } arg += 1 } # encode_real --- encode a single-precision floating point number procedure encode_real { if (base == 0) base = 100 if (base > 14 || base < 0 || width == 0) m = MAXLINE - 1 else m = base + 20 select (arg) when ( 1) l = rtoc (a1, tmp, m, base) when ( 2) l = rtoc (a2, tmp, m, base) when ( 3) l = rtoc (a3, tmp, m, base) when ( 4) l = rtoc (a4, tmp, m, base) when ( 5) l = rtoc (a5, tmp, m, base) when ( 6) l = rtoc (a6, tmp, m, base) when ( 7) l = rtoc (a7, tmp, m, base) when ( 8) l = rtoc (a8, tmp, m, base) when ( 9) l = rtoc (a9, tmp, m, base) when (10) l = rtoc (a10, tmp, m, base) else too_many_args if (rjust == YES) { if (base < 0 && tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (width - l) } else if (base >= 0) { fill_field (width - l) putstr } else { fill_field (width + base - 8) if (tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (-base + 7 - l) } arg += 1 } # encode_double --- encode a double-precision floating point number procedure encode_double { if (base == 0) base = 100 if (base > 14 || base < 0 || width == 0) m = MAXLINE - 1 else m = base + 20 select (arg) when ( 1) l = dtoc (a1, tmp, m, base) when ( 2) l = dtoc (a2, tmp, m, base) when ( 3) l = dtoc (a3, tmp, m, base) when ( 4) l = dtoc (a4, tmp, m, base) when ( 5) l = dtoc (a5, tmp, m, base) when ( 6) l = dtoc (a6, tmp, m, base) when ( 7) l = dtoc (a7, tmp, m, base) when ( 8) l = dtoc (a8, tmp, m, base) when ( 9) l = dtoc (a9, tmp, m, base) when (10) l = dtoc (a10, tmp, m, base) else too_many_args if (rjust == YES) { if (base < 0 && tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (width - l) } else if (base >= 0) { fill_field (width - l) putstr } else { fill_field (width + base - 8) if (tmp (1) ~= '-'c) { putchar (fill) l += 1 } putstr fill_field (-base + 7 - l) } arg += 1 } # encode_newline --- insert a specified number of NEWLINES procedure encode_newline { repeat { putchar (NEWLINE) width -= 1 } until (width <= 0 || cur >= max) } # too_many_args --- issue an error message for too many arguments procedure too_many_args { call remark ("in encode: attempt to use more than 10 fields"p) tmp (1) = EOS } undefine (putchar) end #HD#: enter.r 364 Nov-06-1984 08:48:25 # enter --- place a symbol in the symbol table, updating if already present integer function enter (symbol, info, st) character symbol (ARB) integer info (ARB) pointer st integer Mem (1) common /ds$mem/ Mem integer i, nodesize, fortrash integer st$lu, length pointer node, pred pointer dsget nodesize = Mem (st) if (st$lu (symbol, node, pred, st) == NO) { node = dsget (1 + nodesize + length (symbol) + 1) Mem (node + ST_LINK) = LAMBDA Mem (pred + ST_LINK) = node call scopy (symbol, 1, Mem, node + ST_DATA + nodesize) } for (i = 1; i <= nodesize; i += 1) { fortrash = node + ST_DATA + i - 1 Mem (fortrash) = info (i) } return (node + ST_DATA + nodesize) end #HD#: equal.s 358 Nov-06-1984 08:48:25 * equal --- compare str1 to str2; return YES if equal * * integer function equal (str1, str2) * character str1 (ARB), str2 (ARB) SUBR EQUAL SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK EQUAL ECB EQUAL$,,STR1,2 DATA 5,C'EQUAL' PROC DYNM =20,STR1(3),STR2(3) EQUAL$ ARGT ENTR EQUAL EAXB STR1,* XB := STR1 EALB STR2,* LB := STR2 LDX =0 X := 0 LOOP LDA XB%+0,X if (XB+X)^ <> (LB+X)^ then CAS LB%+0,X goto NE JMP NE JMP *+2 JMP NE CAS =EOS if (XB+X)^ = EOS then JMP *+2 go to EQ JMP EQ BIX LOOP X := X + 1; goto LOOP EQ LDA =YES return YES PRTN NE LDA =NO return NO PRTN END #HD#: error.r 78 Nov-06-1984 08:48:25 # error --- print fatal error message, then die subroutine error (buf) integer buf (ARB) call remark (buf) call seterr (1000) stop end #HD#: esc.r 206 Nov-06-1984 08:48:26 # esc --- map array (i) into escaped character if appropriate character function esc (array, i) character array (ARB) integer i if (array (i) ~= ESCAPE) esc = array (i) else if (array (i + 1) == EOS) # @ not special at end esc = ESCAPE else { i += 1 if (array (i) == 'n'c) esc = NEWLINE else if (array (i) == 't'c) esc = TAB else esc = array (i) } return end #HD#: exec.r 125 Nov-06-1984 08:48:26 # exec --- execute pathname subroutine exec (path) character path (ARB) integer file (16), j1 (3), j2 integer getto, findf$ if (getto (path, file, j1, j2) ~= ERR && findf$ (file) == YES) call resu$$ (file, 32) return end #HD#: execn.r 106 Nov-06-1984 08:48:26 # execn --- execute program named by a quoted string subroutine execn (name) integer name (ARB) character path (MAXSTR) call ptoc (name, '.'c, path, MAXSTR) call exec (path) return end #HD#: expand.r 669 Nov-06-1984 08:48:26 # expand --- convert a template into an EOS-terminated string integer function expand (template, str, strlen) integer strlen character template (ARB), str (strlen) integer ji, ti, si, pi, xi integer lutemp character c character jig (MAXLINE), pbuf (MAXLINE), xbuf (MAXLINE) procedure getchar forward si = 1 # 'str' index pi = 1 # 'pbuf' index ti = 1 # 'template' index for (getchar; si <= strlen && c ~= EOS; getchar) { if (c == '='c) { # start of a template? getchar for (ji = 1; ji <= MAXLINE && c ~= '='c && c ~= EOS; ji += 1) { jig (ji) = c getchar } jig (ji) = EOS if (c ~= '='c) { str (si) = EOS return (ERR) } if (ji <= 1) { # empty template .. expand to '='c str (si) = '='c si += 1 } else { xi = lutemp (jig, xbuf, MAXLINE) if (xi == EOF || xi + pi >= MAXLINE) { str (si) = EOS return (ERR) } for (; xi > 0; {xi -= 1; pi += 1}) pbuf (pi) = xbuf (xi) } } else { str (si) = c si += 1 } } str (si) = EOS if (c ~= EOS) return (ERR) return (si - 1) # getchar --- get a character from the template or pushback buffer procedure getchar { if (pi > 1) { pi -= 1 c = pbuf (pi) } else if (template (ti) ~= EOS) { c = template (ti) ti += 1 } else c = EOS } end #HD#: fcopy.r 389 Nov-06-1984 08:48:26 # fcopy --- copy file 'in' to file 'out' subroutine fcopy (ifd, ofd) file_des ifd, ofd include SWT_COMMON integer f1, f2, l integer getlin, readf character buf (1024) filedes in, out filedes mapsu in = mapsu (ifd) out = mapsu (ofd) f1 = fd_offset (in) f2 = fd_offset (out) if (Fd_dev (f1) == DEV_DSK && Fd_dev (f2) == DEV_DSK) { while (Fd_bcount (f1) ~= 0 || Fd_bcount (f2) ~= 0 || and (Fd_flags (f1), FD_BYTE) ~= 0 || and (Fd_flags (f2), FD_BYTE) ~= 0) { if (getlin (buf, in, 1024) == EOF) return call putlin (buf, out) } repeat { l = readf (buf, 1024, in) if (l == EOF || l == ERR) break call writef (buf, l, out) } } else while (getlin (buf, in) ~= EOF) call putlin (buf, out) return end #HD#: filcpy.r 1391 Nov-06-1984 08:48:26 # filcpy --- copy a file from here to there integer function filcpy (from, to) character from (ARB), to (ARB) integer attach, j1 (3), fd, code, ifd, ofd, otype, itype integer rnw, junk integer buf (MAXDIRENTRY), array (2) character fname (MAXPACKEDFNAME), tname (MAXPACKEDFNAME) character junk1 (MAXVARYFNAME) integer getto, remove character str (MAXLINE) procedure error_exit forward ifd = 0 ofd = 0 ### Open the "from" file and get its attributes if (getto (from, fname, j1, attach) == ERR) error_exit call srch$$ (KREAD + KGETU, KCURR, 0, fd, junk, code) if (code ~= 0) error_exit call ptov (fname, ' 'c, junk1, MAXVARYFNAME) call ent$rd (fd, junk1, loc(buf), MAXDIRENTRY, code) call srch$$ (KCLOS, 0, 0, fd, 0, junk) if (code ~= 0 || rt (buf (20), 8) >= 4) error_exit call srch$$ (KREAD + KGETU, fname, 32, ifd, itype, code) if (code ~= 0) error_exit ### Open the destination file with the same type if (getto (to, tname, j1, attach) == ERR) error_exit call srch$$ (KRDWR + KGETU + ls (itype, 10), tname, 32, ofd, otype, code) if (lt (otype, 14) ~= 0) # It's a special file -- can't copy to it error_exit if (rt (itype, 2) ~= rt (otype, 2)) { # Get rid of the old file ... call srch$$ (KCLOS, 0, 0, ofd, 0, code) call ptoc (tname, ' 'c, str, 33) if (remove (str) == ERR) error_exit call srch$$ (KRDWR + KGETU + ls (itype, 10), tname, 32, ofd, otype, code) if (code ~= 0) error_exit } elif (rt (otype, 2) >= 2) # clean out old segdir call rmseg$ (ofd) ### Both files are open and of the same type -- call the ### appropriate copy routine if (rt (itype, 2) >= 2) # segdirs call cpseg$ (ifd, ofd, code) else call cpfil$ (ifd, ofd, code) if (code == ERR) error_exit ### Truncate the "to" file if not a segdir if (otype < 2) { call prwf$$ (KTRNC, ofd, 0, 0, intl (0), rnw, code) if (code ~= 0) error_exit } ### Close both files call srch$$ (KCLOS, 0, 0, ifd, 0, code) call srch$$ (KCLOS, 0, 0, ofd, 0, code) ### Set the attributes on the "to" file, if possible array (1) = buf (18) array (2) = 0 call satr$$ (KPROT, tname, 32, array, code) array (1) = buf (21) array (2) = buf (22) call satr$$ (KDTIM, tname, 32, array, code) array (1) = rt (rs (buf (20), 10), 2) array (2) = 0 call satr$$ (KRWLK, tname, 32, array, code) if (and (buf (20), 8r40000) ~= 0) call satr$$ (KDMPB, tname, 32, intl (0), code) return (OK) # error_exit --- close the open files and return error status procedure error_exit { if (ifd ~= 0) call srch$$ (KCLOS, 0, 0, ifd, 0, code) if (ofd ~= 0) call srch$$ (KCLOS, 0, 0, ofd, 0, code) return (ERR) } end #HD#: file$p.s 2839 Nov-06-1984 08:48:27 * file$p --- connect SWT i/o to a Pascal file * * declaration: * * type name = array [1..7] of char; * * procedure file$p (var f: text; n: name); * extern; * * calling sequence: * * file$p (pascal_file_variable, 'swt_file'); * * entry (arg 1) = address of Pascal file block. * (arg 2) = string containing SWT file name. * * exit file connected. SUBR FILE$P SEG RLIT include "=syscom=/keys.ins.pma" include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK FILE$P ECB CONNECT,,FILE,2 DATA 6,C'FILE$P' PROC DYNM =20,FILE(3),NAME(3),CODE,ADDR(2),INDEX,UNIT DYNM SUNIT,PUNIT,I,PATH(MAXPATH),TREE(MAXPATH) FCB_FLAG EQU XB%+0 FCB_CUR_POS_PTR EQU XB%+1 FCB_BUF_SIZE EQU XB%+4 FCB_UNIT_NUM EQU XB%+6 FCB_NUM_OBJ EQU XB%+7 FCB_OBJ_SIZE EQU XB%+8 FCB_FILE_NAME EQU XB%+10 FCB_TOTAL_OBJ EQU XB%+74 FCB_BUFFER EQU XB%+75 CONNECT ARGT transfer arguments ENTR FILE$P EAL CONNECTA set address of first file name STL ADDR LDX =10 get number of SWT file names LDY =2 get offset halfway through name CONNECT1 LDL ADDR,* check first 4 characters of name SBL NAME,* BCNE CONNECT2 if not a match LDL ADDR,*Y check remainder of name ERL NAME,*Y ANL =-256L clear last character BLEQ CONNECT3 if a match CONNECT2 LDL ADDR advance address to next entry ADL =4L STL ADDR BDX CONNECT1 continue search CALL ERRPR$ signal bad file name error AP =K$NRTN,S AP =E$BNAM,S AP =0,S AP =0,S AP =C'FILE$P',S AP =6,SL CONNECT3 STX INDEX save loop index LDA =10 calculate index into units SUB INDEX 0 = STDIN, 1 = STDIN1, etc. TAX LDA CONNECTB,X set requested unit number STA UNIT CALL MAPSU convert unit to SWT unit number AP UNIT,SL STA SUNIT CALL FLUSH$ flush file buffer AP SUNIT,SL CALL MAPFD convert unit to PRIMOS unit number AP UNIT,SL STA PUNIT BLE CONNECT7 if file is not on disk CALL ATTDEV attach requested file AP PUNIT,S AP =7,S select compressed disk file AP PUNIT,S AP =128,SL buffer is 128 words EAXB FILE,* get address of file control block LDA INDEX see if file is input or output SUB =6 BCLT CONNECT4 if file is a standard output LDA =B'1110010000000000' set input file values STA FCB_FLAG CRA clear number of objects STA FCB_NUM_OBJ JMP CONNECT6 CONNECT4 LDA =B'0111010000000000' set output file values STA FCB_FLAG LDA =1 set number of objects to 1 STA FCB_NUM_OBJ LDA =C' ' blank fill the buffer LDX =128 CONNECT5 STA FCB_BUFFER-1,X BDX CONNECT5 CONNECT6 LDA PUNIT set file unit number STA FCB_UNIT_NUM JMP CONNECT11 CONNECT7 EAXB FILE,* get address of file control block LDA INDEX see if file in input or output SUB =6 BCLT CONNECT8 if file is a standard output LDA =B'1110011000000000' set input file value STA FCB_FLAG CRA clear number of objects STA FCB_NUM_OBJ JMP CONNECT10 CONNECT8 LDA =B'0111011000000000' set output file values STA FCB_FLAG LDA =1 set number of objects STA FCB_NUM_OBJ LDA =C' ' blank fill the buffer LDX =128 CONNECT9 STA FCB_BUFFER-1,X BDX CONNECT9 CONNECT10 LDA =1 set terminal file unit STA FCB_UNIT_NUM CONNECT11 EAL FCB_BUFFER get a pointer to the buffer STL FCB_CUR_POS_PTR CRA clear bit offset STA FCB_CUR_POS_PTR+2 LDA =256 initialize the buffer size STA FCB_TOTAL_OBJ XCA STL FCB_BUF_SIZE LDL =1L set object size to 1 byte STL FCB_OBJ_SIZE CLEAR_FNAME LDA =C' ' blank out the file name LDX =64 CONNECT12 STA FCB_FILE_NAME-1,X BDX CONNECT12 GET_FNAME CALL GFNAM$ get the name of the file AP UNIT,S AP PATH,S AP =MAXPATH,SL CAS =ERR did we get it? SKP JMP# STORE_BAD_PATH nope, store bad pathname CHECK_TTY CALL PTOC is the file AP DEV_TTY,S is connected to the AP =PERIOD,S terminal device ("/dev/tty") ? AP TREE,S AP =MAXPATH,SL CALL EQUAL AP PATH,S AP TREE,SL CAS =YES SKP JMP# STORE_TTY CHECK_NULL CALL PTOC is the file AP DEV_NULL,S connected to the AP =PERIOD,S null device ("/dev/null") ? AP TREE,S AP =MAXPATH,SL CALL EQUAL AP PATH,S AP TREE,SL CAS =YES Yes it is, Pascal doesn't SKP support I/O to /dev/null JMP# STORE_TTY use /dev/tty as filename CALL MKTR$ it is a valid disk file AP PATH,S AP TREE,SL LDA =1 store the file name into STA I the Pascal file control CALL CTOP block AP TREE,S AP I,S AP FILE,* AP FCB_FILE_NAME,S AP =64,SL PRTN STORE_TTY CALL MOVE$ store the TTY name into AP TTY_PATH,S the Pascal file control AP FILE,* block AP FCB_FILE_NAME,S AP =2,SL PRTN STORE_BAD_PATH CALL MOVE$ store the Bad Pathname message AP BAD_PATH,S into the Pascal file control AP FILE,* block AP FCB_FILE_NAME,S AP =9,SL PRTN LINK CONNECTA BCI 'STDIN ' table of SWT file names BCI 'STDIN1 ' BCI 'STDIN2 ' BCI 'STDIN3 ' BCI 'ERRIN ' BCI 'STDOUT ' BCI 'STDOUT1' BCI 'STDOUT2' BCI 'STDOUT3' BCI 'ERROUT ' CONNECTB DATA STDIN table of corresponding units DATA STDIN1 DATA STDIN2 DATA STDIN3 DATA ERRIN DATA STDOUT DATA STDOUT1 DATA STDOUT2 DATA STDOUT3 DATA ERROUT DEV_NULL BCI '/dev/null.' DEV_TTY BCI '/dev/tty.' BAD_PATH BCI 'path unobtainable ' TTY_PATH BCI 'TTY ' END #HD#: filset.r 520 Nov-06-1984 08:48:27 # filset --- expand set at array (i) into set (j), stop at delim subroutine filset (delim, array, i, set, j, maxset) integer i, j, maxset character array (ARB), delim, set (maxset) character esc integer addset, index integer junk string digits "0123456789" string lowalf "abcdefghijklmnopqrstuvwxyz" string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" for ( ; array (i) ~= delim && array (i) ~= EOS; i += 1) if (array (i) == ESCAPE) junk = addset (esc (array, i), set, j, maxset) else if (array (i) ~= PAT_DASH) junk = addset (array (i), set, j, maxset) else if (j <= 1 || array (i + 1) == EOS) # literal - junk = addset (PAT_DASH, set, j, maxset) else if (index (digits, set (j - 1)) > 0) call dodash (digits, array, i, set, j, maxset) else if (index (lowalf, set (j - 1)) > 0) call dodash (lowalf, array, i, set, j, maxset) else if (index (upalf, set (j - 1)) > 0) call dodash (upalf, array, i, set, j, maxset) else junk = addset (PAT_DASH, set, j, maxset) return end #HD#: filtst.r 2013 Nov-06-1984 08:48:27 # filtst --- function to perform several tests upon pathname integer function filtst (path, zero, permissions, exists, type, readable, writeable, dumped) integer path(MAXPATH) integer zero # file is or is not zero length integer permissions # type of permissions on the file integer exists # does path exist or not integer type # file type (SAM, DAM, UFD) integer readable # is file readable or not integer writeable # is file writeable or not integer dumped # is the dumped bit set or not #------------------------------------------------------------------------ # # returns YES, NO, ERR depending on if the specified # arguments were true, false, or not determinable # #------------------------------------------------------------------------ # # how args are represented: # # pathname: unpacked, EOS terminated string, SWT style # # exists: -1 == does not exist # 0 == do not test for existence # +1 == does exist # # permissions: as per PRIMOS directory bits # # zero: -1 == has non-zero length # 0 == do not test length # +1 == has zero length # # type: 0 == do not test type # otherwise, as per PRIMOS directory bits # except that the high order bit must be on # in order to distinguish between SAM file # test and do not test type. # # readable: -1 == file is not readable # 0 == do not test file readablilty # +1 == file is readable # # writeable: -1 == file is not writeable # 0 == do not test file writability # +1 == file is writeable # # dumped: -1 == file has not been dumped # 0 == do not test dumped bit # +1 == file has been dumped # #------------------------------------------------------------------------ integer p_fd, ppwd(32), pname(32), attach, temp character vname(MAXVARYFNAME) integer getto, open integer code, buf(MAXDIRENTRY), junk procedure return_NO forward procedure return_ERR forward if (getto (path, pname, ppwd, attach) == ERR) # get to the file return (ERR) if (exists ~= 0) { # check for existence call srch$$ (KEXST, pname, 32, p_fd, temp, code) if ((code == EFNTF && exists == -1) || (code == EFNTS && exists == -1) || (code == 0 && exists == 1)) ; else return_NO } if (readable ~= 0) { # check if readable temp = open (path, READ) if (temp ~= ERR) call close (temp) if (temp == ERR && readable == 1 || temp ~= ERR && readable == -1) return_NO } if (writeable ~= 0) { temp = open (path, WRITE) if (temp ~= ERR) call close (temp) if (temp == ERR && writeable == 1 || temp ~= ERR && writeable == -1) return_NO } if (zero ~= 0) { # check for zero / non-zero length call srch$$ (KREAD+KGETU, pname, 32, p_fd, temp, code) if (code ~= 0) return_ERR call prwf$$ (KPOSN+KPREA, p_fd, loc(temp), 0, intl(1), 0, code) call srch$$ (KCLOS, pname, 32, p_fd, temp, junk) if ((code == 0 && zero == -1) || (code == EEOF && zero == 1)) ; else return_NO } if (dumped ~= 0 || permissions ~= 0 || type ~= 0) { call srch$$ (KREAD+KGETU, KCURR, 0, p_fd, temp, code) if (code ~= 0) return_ERR call ptov (pname, ' 'c, vname, MAXVARYFNAME) call ent$rd (p_fd, vname, loc(buf), MAXDIRENTRY, code) call srch$$ (KCLOS, 0, 0, p_fd, temp, junk) if (code ~= 0) return_ERR if (permissions ~= 0) { if (permissions == and (buf(18), permissions)) ; else return_NO } if (type ~= 0) { temp = and (type, :77) if (temp == and (buf(20), :77)) ; else return_NO } if (dumped ~= 0) { if ((dumped == -1 && and (buf(20), :40000) == 0) || (dumped == 1 && and (buf(20), :40000) ~= 0)) ; else return_NO } } if (attach == YES) call at$hom (code) return (YES) # return_NO --- attach home and return NO procedure return_NO { if (attach == YES) call at$hom (code) return (NO) } # return_ERR --- attach home and return ERR procedure return_ERR { if (attach == YES) call at$hom (code) return (ERR) } end #HD#: findf$.r 126 Nov-06-1984 08:48:27 # findf$ --- does file exist in current directory integer function findf$ (file) integer file (16) integer junk, rc call srch$$ (KEXST, file, 32, 16, junk, rc) if (rc == EFNTF) findf$ = NO else findf$ = YES return end #HD#: finfo$.r 307 Nov-06-1984 08:48:28 # finfo$ --- return information about a file integer function finfo$ (path, entry, attach) character path (ARB) integer entry (ARB), attach integer code, fd, junk (3) character name (MAXPACKEDFNAME), vname (MAXVARYFNAME) integer getto finfo$ = ERR if (getto (path, name, junk, attach) == ERR) return call srch$$ (KREAD + KGETU, KCURR, 0, fd, junk, code) if (code ~= 0) return call ptov (name, ' 'c, vname, MAXVARYFNAME) call ent$rd (fd, vname, loc(entry), MAXDIRENTRY, code) call srch$$ (KCLOS, 0, 0, fd, 0, junk) if (code == 0) finfo$ = OK return end #HD#: first$.r 130 Nov-06-1984 08:48:28 # first$ --- find out if this is the first call here since login integer function first$ (flag) integer flag include SWT_COMMON if (First_use == 8r52525) flag = NO else { flag = YES First_use = 8r52525 } return (flag) end #HD#: flush$.r 797 Nov-06-1984 08:48:28 # flush$ --- flush out a file's buffer integer function flush$ (fd) filedes fd include SWT_COMMON integer f, junk character zerostr (2) data zerostr / 0, EOS / if (fd < 1 || fd > NFILES) return (ERR) f = fd_offset (fd) if (Fd_flags (f) == 0 || and (Fd_flags (f), FD_ERR) ~= 0) return (ERR) Errcod = 0 call break$ (DISABLE) select (Fd_dev (f)) when (DEV_DSK) { select (LASTOP (f)) when (FD_PUTLIN) { if (Fd_bcount (f) ~= 0) # flush blanks call dputl$ (zerostr, Fdesc (f)) elif (and (Fd_flags (f), FD_BYTE) ~= 0) Fd_count (f) += 1 if (Fd_count (f) + Fd_buflen (f) > 0) call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (Fd_bufstart (f) + 1)), Fd_count (f) + Fd_buflen (f), intl (0), junk, Errcod) } when (FD_GETLIN) { if (and (Fd_flags (f), FD_BYTE) ~= 0) Fd_count (f) += 1 if (Fd_count (f) < 0) call prwf$$ (KPOSN + KPRER, Fd_unit (f), intl (0), 0, intl (Fd_count (f)), junk, Errcod) } when (FD_WRITEF) { if (Fd_count (f) + Fd_buflen (f) ~= 0) { call prwf$$ (KWRIT, Fd_unit (f), loc (Fd_buf (Fd_bufstart (f) + 1)), Fd_count (f) + Fd_buflen (f), intl (0), junk, Errcod) } } when (FD_READF) { if (Fd_count (f) < 0) call prwf$$ (KPOSN + KPRER, Fd_unit (f), intl (0), 0, intl (Fd_count (f)), junk, Errcod) } } # when (DEV_DSK) Fd_bufend (f) = 0 Fd_count (f) = 0 Fd_bcount (f) = 0 Fd_flags (f) &= not (FD_BYTE) SET_LASTOP (f, FD_INITIAL) call break$ (ENABLE) if (Errcod ~= 0) { Fd_flags (f) |= FD_ERR return (ERR) } return (OK) end #HD#: follow.r 743 Nov-06-1984 08:48:28 # follow --- path name follower integer function follow (path, seth) character path (ARB) integer seth integer i, save_bplabel (4) integer getto, ptoc shortcall mkonu$ (18) external bponu$ include SWT_COMMON integer attach_sw integer pname (16), ppwd (3), unpackedn(40), vpack(21), i procedure restore_Bplabel forward call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing save_bplabel (i) = Bplabel (i) # common block values call mklb$f ($1, Bplabel) call break$ (ENABLE) call mkonu$ ("BAD_PASSWORD$"v, loc (bponu$)) if (path (1) == EOS) call at$hom (Errcod) elif (getto (path, pname, ppwd, attach_sw) == OK) { i = ptoc (pname, " "c, unpackedn, 33) # build the directory name unpackedn (i + 1) = " "c i += 2 call ptoc (ppwd, " "c, unpackedn(i), 7) # and password for converting i = 1 call ctov (unpackedn, i, vpack, 21) # to character varying call at$rel (seth, vpack, Errcod) # for at$rel } else { 1 call at$hom (i) restore_Bplabel return (ERR) } if (Errcod == 0) { restore_Bplabel return (OK) } else { call at$hom (i) restore_Bplabel return (ERR) } # restore_Bplabel --- restore saved value of Bplabel procedure restore_Bplabel { local i; integer i call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing Bplabel (i) = save_bplabel (i) # common block values call break$ (ENABLE) } end #HD#: gcdir$.r 192 Nov-06-1984 08:48:28 # gcdir$ --- get current directory pathname integer function gcdir$ (path) character path (ARB) integer curdir (MAXLINE), dirname (MAXLINE) integer size, code integer mkpa$ call gpath$ (KCURA, 0, curdir, MAXLINE, size, code) if (code ~= 0) return (ERR) call ptoc (curdir, EOS, dirname, size + 1) call mkpa$ (dirname, path, NO) return (OK) end #HD#: gcifu$.r 86 Nov-06-1984 08:48:28 # gcifu$ --- return the current value of Comunit integer function gcifu$ (funit) integer funit include SWT_COMMON funit = Comunit return (funit) end #HD#: gctoi.r 474 Nov-06-1984 08:48:29 # gctoi --- convert any radix string to single precision integer integer function gctoi (str, i, radix) character str (ARB) integer i, radix integer base, v, d, j integer index character mapdn bool neg string digits "0123456789abcdef" v = 0 base = radix SKIPBL (str, i) neg = (str (i) == '-'c) if (str (i) == '+'c || str (i) == '-'c) i += 1 if (str (i + 2) == 'r'c && str (i) == '1'c && IS_DIGIT (str (i + 1)) || str (i + 1) == 'r'c && IS_DIGIT (str (i))) { base = str (i) - '0'c j = i if (str (i + 1) ~= 'r'c) { j += 1 base = base * 10 + (str (j) - '0'c) } if (base < 2 || base > 16) base = radix else i = j + 2 } for (; str (i) ~= EOS; i += 1) { if (IS_DIGIT (str (i))) d = str (i) - '0'c else d = index (digits, mapdn (str (i))) - 1 if (d < 0 || d >= base) break v = v * base + d } if (neg) return (-v) else return (+v) end #HD#: gctol.r 479 Nov-06-1984 08:48:29 # gctol --- convert any radix string to double precision integer longint function gctol (str, i, radix) character str (ARB) integer i, radix longint v integer base, d, j integer index character mapdn bool neg string digits "0123456789abcdef" v = 0 base = radix SKIPBL (str, i) neg = (str (i) == '-'c) if (str (i) == '+'c || str (i) == '-'c) i += 1 if (str (i + 2) == 'r'c && str (i) == '1'c && IS_DIGIT (str (i + 1)) || str (i + 1) == 'r'c && IS_DIGIT (str (i))) { base = str (i) - '0'c j = i if (str (i + 1) ~= 'r'c) { j += 1 base = base * 10 + (str (j) - '0'c) } if (base < 2 || base > 16) base = radix else i = j + 2 } for (; str (i) ~= EOS; i += 1) { if (IS_DIGIT (str (i))) d = str (i) - '0'c else d = index (digits, mapdn (str (i))) - 1 if (d < 0 || d >= base) break v = v * base + d } if (neg) return (-v) else return (+v) end #HD#: geta$f.r 186 Nov-06-1984 08:48:29 # geta$f --- get an argument for a Fortran program integer function geta$f (ap, str, len) integer ap, len integer str (ARB) integer i integer getarg, ctop character arg (MAXARG) for (i = (len + 1) / 2; i > 0; i -= 1) str (i) = " " if (getarg (ap, arg, MAXARG) == EOF) return (-1) i = 1 return (ctop (arg, i, str, len / 2)) end #HD#: geta$p.r 185 Nov-06-1984 08:48:29 # geta$p --- get an argument for a Pascal program integer function geta$p (ap, str, len) integer ap, len integer str (ARB) integer i integer getarg, ctop character arg (MAXARG) for (i = (len + 1) / 2; i > 0; i -= 1) str (i) = " " if (getarg (ap, arg, MAXARG) == EOF) return (-1) i = 1 return (ctop (arg, i, str, len / 2)) end #HD#: geta$plg.plg 262 Nov-06-1984 08:48:29 /* geta$plg --- get an argument for a PL/I Subset G program */ geta$plg: procedure (ap, str, len) returns (fixed); declare ap fixed, str char (128) varying, len fixed; declare getarg entry (fixed, (128) fixed, fixed) returns (fixed), ctov entry ((128) fixed, fixed, char (128) var, fixed) returns (fixed); declare i fixed, arg (128) fixed; if getarg (ap, arg, 128) = -1 then return (-1); i = 1; return (ctov (arg, i, str, divide (len, 2, 15) + 1)); end geta$plg; #HD#: getarg.r 247 Nov-06-1984 08:48:30 # getarg --- get an argument from the linked string space integer function getarg (arg_p, str, size) integer arg_p, size character str (ARB) integer p, i include SWT_COMMON if (arg_p < 0 || arg_p >= Arg_c) { str (1) = EOS return (EOF) } p = Arg_v (arg_p + 1) for (i = 1; i < size; i += 1) { while (Ls_ref (p) >= 300) p = Ls_ref (p) - 300 if (Ls_ref (p) == EOS) break str (i) = Ls_ref (p) p += 1 } str (i) = EOS return (i - 1) end #HD#: getccl.r 304 Nov-06-1984 08:48:30 # getccl --- expand char class at arg (i) into pat (j) integer function getccl (arg, i, pat, j) character arg (MAXARG), pat (MAXPAT) integer i, j integer addset integer jstart, junk i += 1 # skip over [ if (arg (i) == PAT_NOT) { junk = addset (PAT_NCCL, pat, j, MAXPAT) i += 1 } else junk = addset (PAT_CCL, pat, j, MAXPAT) jstart = j junk = addset (0, pat, j, MAXPAT) # leave room for count call filset (PAT_CCLEND, arg, i, pat, j, MAXPAT) pat (jstart) = j - jstart - 1 if (arg (i) == PAT_CCLEND) getccl = OK else getccl = ERR return end #HD#: getch.r 114 Nov-06-1984 08:48:31 # getch --- get a character from a file character function getch (c, fd) character c integer fd character buf (2) integer getlin c = getlin (buf, fd, 2) if (c ~= EOF) c = buf (1) return (c) end #HD#: getfd$.r 440 Nov-06-1984 08:48:31 # getfd$ --- look for an empty file descriptor cleverly file_des function getfd$ (fd) file_des fd include SWT_COMMON integer limit procedure search (start, limit) forward ### Get the number of the last descriptor in the first page limit = ((loc (Fdmem) / 1024 * 1024 + 1024) - loc (Fdmem)) / FDSIZE ### Look for an empty descriptor search (Fd_lastfd, limit) search (Fd_lastfd, NFILES) return (ERR) # search --- search for any empty descriptor, modulo 'limit' procedure search (start, limit) { integer start, limit local i; integer i if (start < 1 || start > limit) start = 1 if (start >= limit) i = 1 else i = start + 1 while (Fd_flags (fd_offset (i)) ~= 0 && i ~= limit) if (i >= limit) i = 1 else i += 1 if (i ~= limit) { Fd_lastfd = i fd = i return (i) } } end #HD#: getkwd.r 287 Nov-06-1984 08:48:31 # getkwd --- get keyword type arguments from argument list integer function getkwd (keywd, value, length, defalt) character keywd (ARB), value (ARB), defalt (ARB) integer length integer i, j integer equal, getarg character arg (MAXARG) for (i = 1; getarg (i, arg, MAXARG) ~= EOF; i += 1) if (equal (keywd, arg) == YES) { getkwd = getarg (i + 1, value, length) if (getkwd == EOF) break return } for (j = 1; j < length && defalt (j) ~= EOS; j += 1) value (j) = defalt (j) value (j) = EOS getkwd = j - 1 return end #HD#: getlin.r 450 Nov-06-1984 08:48:31 # getlin --- read one line from a file integer function getlin (line, fd, xmax) character line (ARB) integer fd, xmax include SWT_COMMON integer off, max, f integer tgetl$, dgetl$, mapsu logical missin f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_READ) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) { line (1) = EOS return (EOF) } if (missin (xmax)) max = MAXLINE else max = xmax if (max <= 1) { line (1) = EOS return (0) } if (LASTOP (off) ~= FD_GETLIN) { call flush$ (f) SET_LASTOP (off, FD_GETLIN) } select (Fd_dev (off)) when (DEV_TTY) getlin = tgetl$ (line, max, off) when (DEV_DSK) getlin = dgetl$ (line, max, Fdesc (off)) when (DEV_NULL) getlin = 0 else getlin = 0 if (getlin == 0) { line (1) = EOS return (EOF) } return end #HD#: getto.r 2028 Nov-06-1984 08:48:31 # getto --- get to the last file in a path name integer function getto (pathin, pfilename, ppwd, attach_sw) character pathin (ARB) integer pfilename (16), ppwd (3) integer attach_sw include SWT_COMMON integer expand, mktr$ character dirname (MAXTREE), temp (MAXPATH) character fulltree (MAXTREE), diskname (17) integer count, loop, sp, tp, j, save_bplabel (4) shortcall mkonu$ (18) external bponu$ procedure check_code forward procedure getname forward procedure putname forward procedure restore_Bplabel forward call break$ (DISABLE) # no interruptions do j = 1, 4 # while changing save_bplabel (j) = Bplabel (j) # common block values call mklb$f ($1, Bplabel) call break$ (ENABLE) call mkonu$ ("BAD_PASSWORD$"v, loc (bponu$)) attach_sw = YES if (expand (pathin, temp, MAXPATH) == ERR) { attach_sw = NO restore_Bplabel return (ERR) } call mktr$ (temp, fulltree) call mapstr (fulltree, UPPER) if (pathin (1) == EOS) { # case of current directory call at$hom (Errcod) check_code tp = 1 putname pfilename (1) = KCURR # Primos key for current directory attach_sw = NO restore_Bplabel return (OK) } # Count the number of pathname elements to worry about count = 0 for (loop = 1; fulltree (loop) ~= EOS; loop += 1) if (fulltree (loop) == '>'c) count += 1 if (fulltree(1) ~= '*'c) count += 1 loop = 1 repeat { if (loop ~= 1) { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } elif (fulltree (1) == '<'c) { # absolute partition reference for (tp = 1; fulltree (tp) ~= '>'c; tp += 1) temp (tp) = fulltree (tp) tp += 1 # step past '>' if (count == 1) putname temp(tp - 1) = '>'c call ctoc("MFD XXXXXX"s, temp(tp), MAXPATH) sp = 1 call ctov (temp, sp, dirname, MAXTREE) call at$ (KSETC, dirname, Errcod) } elif (fulltree (1) == '*'c) { # name references current directory tp = 3 if (count == 1) { # name is in current directory attach_sw = NO putname restore_Bplabel return (OK) } else { # name relative to current directory getname call at$rel (KSETC, dirname, Errcod) } } else { # absolute reference on any partition tp = 1 if (count == 1) putname getname call at$any (KSETC, dirname, Errcod) if (count == 1) { # special case of //name check_code call at$abs (KSETC, "*"v, "MFD XXXXXX"v, Errcod) check_code restore_Bplabel return (OK) } } check_code loop += 1 } until (loop >= count) putname restore_Bplabel return (OK) 1 continue # bad password return Errcod = EBPAS check_code # check_code --- check return code for errors procedure check_code { local i; integer i if (Errcod ~= 0) { call at$hom (i) attach_sw = NO restore_Bplabel return (ERR) } } # getname --- get the name of the next node in the treename procedure getname { local i, sp; integer i, sp for (i = 1; fulltree (tp) ~= '>'c && fulltree (tp) ~= EOS; {i += 1; tp += 1}) temp (i) = fulltree (tp) temp (i) = EOS tp += 1 # step past the '>' sp = 1 call ctov (temp, sp, dirname, 21) if (i > 40) { Errcod = EITRE check_code } } # putname --- put name and password into 'pfilename' and # 'ppwd' in packed format procedure putname { local i; integer i do i = 1,3 ppwd (i) = " " do i = 1,16 pfilename (i) = " " j = 0 for (i = tp; fulltree (i) ~= EOS && fulltree (i) ~= ' 'c && j <= 32; i += 1) spchar (pfilename, j, fulltree (i)) if (fulltree (i) ~= EOS) { j = 0 for (i += 1; fulltree (i) ~= EOS && j <= 6; i += 1) spchar (ppwd, j, fulltree (i)) } } # restore_Bplabel --- restore saved value of Bplabel procedure restore_Bplabel { local i; integer i call break$ (DISABLE) # no interruptions do i = 1, 4 # while changing Bplabel (i) = save_bplabel (i) # common block values call break$ (ENABLE) } end #HD#: getvdn.r 319 Nov-06-1984 08:48:31 # getvdn --- return the name of a file in the user's variables directory subroutine getvdn (fn, pn, un) character fn (ARB), pn (ARB), un (ARB) integer i integer length, equal, ctoc, scopy character name (MAXLINE) logical missin include SWT_COMMON i = ctoc ("=vars=/"s, pn, MAXLINE) call date (SYS_USERID, name) if (missin (un) || equal (un, name) == YES) { i += scopy (name, 1, pn, i + 1) if (length (Passwd) ~= 0) { pn (i + 1) = ':'c i += scopy (Passwd, 1, pn, i + 2) + 1 } } else i += scopy (un, 1, pn, i + 1) pn (i + 1) = '/'c call scopy (fn, 1, pn, i + 2) return end #HD#: getwrd.r 163 Nov-06-1984 08:48:32 # getwrd --- get non-blank word from in(i) into out, increment i integer function getwrd (in, i, out) integer in (ARB), out (ARB) integer i, j SKIPBL (in, i) for (j = 1; in (i) ~= EOS && in (i) ~= ' 'c && in (i) ~= NEWLINE; {i += 1; j += 1}) out (j) = in (i) out (j) = EOS return (j - 1) end #HD#: gfdata.r 3692 Nov-06-1984 08:48:32 # gfdata --- get file infomation integer function gfdata (key, xpath, infobuf, attach_sw, auxil) integer key, attach_sw character xpath (ARB) integer infobuf (ARB), auxil (ARB) include SWT_COMMON integer ecw, fname, protectbits, typebits, date, time integer entrdbuf (MAXDIRENTRY) equivalence (ecw, entrdbuf), (fname, entrdbuf (2)) equivalence (protectbits, entrdbuf (18)), (typebits, entrdbuf (20)) equivalence (date, entrdbuf (21)), (time, entrdbuf (22)) integer vname (17), name (16) equivalence (vname (2), name) integer junk (MAXPATH), junk2 (MAXPATH), vtree (129), ppwd (3) integer i, j, pathname (MAXPATH) long_int fsize, qbuf (8) logical nameq$ longint szfil$ integer getto, gtacl$, mksacl, index, equal, mapdn, expand procedure do_protec forward procedure do_entrd forward procedure do_type forward procedure do_size forward procedure do_access forward procedure make_and_validate_tree forward attach_sw = NO Errcod = 0 if (expand (xpath, pathname, MAXPATH) == ERR) return (ERR) select (key) when (FILE_UFDQUOTA) { make_and_validate_tree call q$read (vtree, infobuf, 6, i, Errcod) if (i == 0) auxil (1) = YES else { auxil (1) = NO return (ERR) } } when (FILE_FULL_INFO) { do_entrd call move$ (entrdbuf, infobuf, MAXDIRENTRY) } when (FILE_TYPE) { do_entrd do_type } when (FILE_DMBITS) { do_entrd if (and (8r40000, typebits) ~= 0) infobuf (1) = YES else infobuf (1) = NO if (and (8r20000, typebits) ~= 0) infobuf (2) = YES else infobuf (2) = NO } when (FILE_RWLOCK) { do_entrd i = and (3, rs (typebits, 10)) select (i) when (0) call ctoc ("sys"s, infobuf, 7) when (1) call ctoc ("n-1"s, infobuf, 7) when (2) call ctoc ("n+1"s, infobuf, 7) when (3) call ctoc ("n+n"s, infobuf, 7) } when (FILE_TIMMOD) { do_entrd infobuf (1) = and (2r1111111, rs (date, 9)) infobuf (2) = and (2r1111, rs (date, 5)) infobuf (3) = and (2r11111, date) infobuf (6) = mod (time, 15) * 4 i = time / 15 infobuf (5) = mod (i, 60) infobuf (4) = i / 60 } when (FILE_ACL) { if (gtacl$ (pathname, 1, attach_sw) == ERR) return (ERR) elif (mksacl (auxil (2), infobuf, auxil (1), " "s) == ERR) return (ERR) } when (FILE_ACCESS) do_access when (FILE_PRIORITYACL) { if (gtacl$ (pathname, 2, attach_sw) == ERR) return (ERR) elif (mksacl (junk, infobuf, junk, " "s) == ERR) return (ERR) } when (FILE_DELSWITCH) { do_entrd if (and (protectbits, 8r200) ~= 0) infobuf (1) = YES else infobuf (1) = NO } when (FILE_SIZE) { do_entrd if (rs (ecw, 8) == 3) return (ERR) # cannot size an ACL! else do_size } when (FILE_PROTECTION) { do_entrd do_protec } when (FILE_PASSWORDS) { if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) call gpas$$ (name, 32, ppwd, junk, Errcod) if (Errcod ~= 0) return (ERR) call ptoc (ppwd, EOS, infobuf, 7) call ptoc (junk, EOS, auxil, 7) } ifany { if (attach_sw == YES) call at$hom (i) if (Errcod == 0) return (OK) else return (ERR) } else return (ERR) # bad key # do_protec --- interpret the (old style) protection for files procedure do_protec { local prot, loop, ind integer prot, loop, ind define (INSCHAR (x), {infobuf (ind) = x; ind += 1}) ind = 1 for (loop = 1; loop < 3; loop += 1) { if (loop == 1) prot = rs (protectbits, 8) else { prot = rt (protectbits, 8) INSCHAR ('/'c) } if (prot == 7) INSCHAR ('a'c) else { if (and (prot, 4) ~= 0) INSCHAR ('d'c) if (and (prot, 2) ~= 0) INSCHAR ('w'c) if (and (prot, 1) ~= 0) INSCHAR ('r'c) } } INSCHAR (EOS) undefine (INSCHAR) } # do_entrd --- read the directory entry for the pathname procedure do_entrd { local typ, funit, i integer typ, funit, i if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) call srch$$ (KREAD + KGETU, KCURR, 0, funit, typ, Errcod) if (Errcod ~= 0) return (ERR) vname (1) = 0 for (i = 1; vname (1) == 0 && i < 33; i += 1) if (rt(rs (name ( (i + 1) / 2), 8 * rt (i, 1)), 8) == ' 'c) vname (1) = i - 1 call ent$rd (funit, vname, loc (entrdbuf), MAXDIRENTRY, Errcod) call srch$$ (KCLOS, 0, 0, funit, typ, typ) if (Errcod ~= 0) return (ERR) } # do_type --- interpret the type of the file object procedure do_type { local action, type, special integer action, type, special if (rs (ecw, 8) == 3) call ctoc ("acat"s, infobuf, 7) else { type = and (8, typebits) special = and (8r10000, typebits) if (special ~= 0) { if (type == 4) call ctoc ("mfd"s, infobuf, 7) elif (nameq$ (fname, 32, "BOOT", 4)) call ctoc ("boot"s, infobuf, 7) elif (nameq$ (fname, 32, "BADSPT", 6)) call ctoc ("badspt"s, infobuf, 7) else call ctoc ("dskrat"s, infobuf, 7) } else { select (type) when (0) call ctoc ("sam"s, infobuf, 7) when (1) call ctoc ("dam"s, infobuf, 7) when (2) call ctoc ("sgs"s, infobuf, 7) when (3) call ctoc ("sgd"s, infobuf, 7) when (4) call ctoc ("ufd"s, infobuf, 7) else return (ERR) } } } # do_size --- determine the size of a file object procedure do_size { select (rt (typebits, 8)) when (0, 1) { # SAM or DAM file call srch$$ (KREAD + KGETU, name, 32, i, j, Errcod) if (Errcod ~= 0) return (ERR) fsize = szfil$ (i) call srch$$ (KCLOS, name, 32, i, j, j) if (fsize == ERR) return (ERR) call move$ (fsize, infobuf, 2) } when (2, 3) { # SAM directory or DAM directory call srch$$ (KREAD + KGETU, name, 32, i, j, Errcod) if (Errcod ~= 0) return (ERR) call szseg$ (fsize, i) call srch$$ (KCLOS, name, 32, i, j, j) if (fsize == ERR) return (ERR) call move$ (fsize, infobuf, 2) } when (4) { # UFD make_and_validate_tree call q$read (vtree, qbuf, 6, i, Errcod) if (Errcod ~= 0) return (ERR) call move$ (qbuf (1), auxil, 2) # words per disk record call move$ (qbuf (4), infobuf, 2) # total records used } else return (ERR) } # make_and_validate_tree --- make treename and see if it is valid procedure make_and_validate_tree { local i; integer i call mktr$ (pathname, junk) i = 1 call ctov (junk, i, vtree, 129) ### now see if it is a valid tree name if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) } # do_access --- determine the current access rights on a file object procedure do_access { local i; integer i string access_right_string "ADLPRUW" make_and_validate_tree i = 1 call ctov (auxil, i, junk (2), MAXPATH - 2) junk (1) = 2 junk (19) = 0 # return no group information call calac$ (vtree, loc (junk), "ALL"v, junk2, Errcod) if (Errcod ~= 0) return (ERR) call vtoc (junk2, junk, MAXLINE) if (equal (junk, "ALL"s) == YES) call ctoc ("$all"s, infobuf, 8) elif (equal (junk, "NONE"s) == YES) call ctoc ("$none"s, infobuf, 8) else { i = 1 for (j = 1; access_right_string (j) ~= EOS; j += 1) if (index (junk, access_right_string (j)) ~= 0) { infobuf (i) = mapdn (access_right_string (j)) i += 1 } infobuf (i) = EOS } } end #HD#: gfnam$.r 409 Nov-06-1984 08:48:32 # gfnam$ --- get pathname for an open file integer function gfnam$ (fd, path, size) filedes fd character path (ARB) integer size include SWT_COMMON filedes f filedes mapsu integer off, code, len, buf (MAXPATH) integer mkpa$, ctoc character name (MAXPATH) path (1) = EOS f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || Fd_flags (off) == 0) return (ERR) select (Fd_dev (off)) when (DEV_TTY) return (ctoc ("/dev/tty"s, path, size)) when (DEV_NULL) return (ctoc ("/dev/null"s, path, size)) when (DEV_DSK) { call gpath$ (KUNIT, Fd_unit (off), buf, MAXPATH, len, code) if (code == 0) { call ptoc (buf, EOS, name, min0 (size, len + 1)) return (mkpa$ (name, path, NO)) } path (1) = EOS return (ERR) } return (ERR) end #HD#: gfnarg.r 1244 Nov-06-1984 08:48:33 # gfnarg --- get the next file name from the argument list integer function gfnarg (name, state) character name (MAXPATH) integer state (4) integer l integer getarg, open, getlin string in1 "/dev/stdin1" string in2 "/dev/stdin2" string in3 "/dev/stdin3" procedure process_next_arg forward repeat { select (state (1)) when (1) { state (1) = 2 # new state state (2) = 1 # next argument state (3) = ERR # current input file state (4) = 0 # file argument count } when (2) { if (getarg (state (2), name, MAXARG) ~= EOF) { state (1) = 2 # stay in same state state (2) += 1 # bump argument count process_next_arg # may return on its own } else state (1) = 4 # EOF state } when (3) { l = getlin (name, state (3)) if (l ~= EOF) { name (l) = EOS return (OK) } if (state (3) > 0) call close (state (3)) state (1) = 2 } when (4) { state (1) = 5 if (state (4) == 0) {# no file arguments call scopy (in1, 1, name, 1) return (OK) } break } when (5) break else call error ("in gfnarg: bad state (1) value"p) } # end of infinite repeat name (1) = EOS return (EOF) procedure process_next_arg { select when (name (1) ~= '-'c) { state (4) += 1 # bump file argument count return (OK) } when (name (2) == EOS) { call scopy (in1, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == '1'c && name (3) == EOS) { call scopy (in1, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == '2'c && name (3) == EOS) { call scopy (in2, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == '3'c && name (3) == EOS) { call scopy (in3, 1, name, 1) state (4) += 1 # bump file argument count return (OK) } when (name (2) == 'n'c || name (2) == 'N'c) { state (1) = 3 # new state state (4) += 1 # bump file argument count select when (name (3) == EOS) state (3) = STDIN1 when (name (3) == '1'c && name (4) == EOS) state (3) = STDIN1 when (name (3) == '2'c && name (4) == EOS) state (3) = STDIN2 when (name (3) == '3'c && name (4) == EOS) state (3) = STDIN3 else { state (3) = open (name (3), READ) if (state (3) == ERR) { call print (ERROUT, "*s: can't open*n"p, name) state (1) = 2 } } } else return (ERR) } end #HD#: gitoc.r 740 Nov-06-1984 08:48:33 # gitoc --- convert single precision integer to any radix string integer function gitoc (int, str, size, base) integer int, size, base character str (size) integer n integer carry, d, i, radix bool unsigned string digits "0123456789ABCDEF" str (1) = EOS # digit string is generated backwards, then reversed if (size <= 1) return (0) radix = iabs (base) # get actual conversion radix if (radix < 2 || radix > 16) radix = 10 unsigned = (base < 0) # negative radices mean unsigned conversion if (unsigned) { n = rs (int, 1) # make pos. but keep high-order bits intact carry = and (int, 1) # get initial carry } else n = int i = 1 repeat { d = iabs (mod (n, radix)) # generate next digit if (unsigned) { # this is only half of actual digit value d = 2 * d + carry # get actual digit value if (d >= radix) { # check for generated carry d -= radix carry = 1 } else carry = 0 } i += 1 str (i) = digits (d + 1) # convert to character and store n /= radix } until (n == 0 || i >= size) if (unsigned) { if (carry ~= 0 && i < size) { # check for final carry i += 1 str (i) = '1'c } } elif (int < 0 && i < size) { # add sign if needed i += 1 str (i) = '-'c } gitoc = i - 1 # will return length of string for (d = 1; d < i; {d += 1; i -= 1}) { # reverse digits carry = str (d) str (d) = str (i) str (i) = carry } return end #HD#: gklarg.r 190 Nov-06-1984 08:48:33 # gklarg --- parse a single key-letter argument integer function gklarg (args, str) integer args (26) character str (ARB) integer i, k integer mapdn if (str (1) ~= '-'c) return (ERR) for (i = 2; str (i) ~= EOS; i += 1) { k = mapdn (str (i)) - 'a'c + 1 if (k < 1 || k > 26 || args (k) < 0) return (ERR) args (k) = 1 } return (OK) end #HD#: gltoc.r 745 Nov-06-1984 08:48:33 # gltoc --- convert double precision integer to any radix string integer function gltoc (int, str, size, base) longint int integer size, base character str (size) longint n integer carry, d, i, radix bool unsigned string digits "0123456789ABCDEF" str (1) = EOS # digit string is generated backwards, then reversed if (size <= 1) return (0) radix = iabs (base) # get actual conversion radix if (radix < 2 || radix > 16) radix = 10 unsigned = (base < 0) # negative radices mean unsigned conversion if (unsigned) { n = rs (int, 1) # make pos. but keep high-order bits intact carry = and (int, 1) # get initial carry } else n = int i = 1 repeat { d = iabs (mod (n, radix)) # generate next digit if (unsigned) { # this is only half of actual digit value d = 2 * d + carry # get actual digit value if (d >= radix) { # check for generated carry d -= radix carry = 1 } else carry = 0 } i += 1 str (i) = digits (d + 1) # convert to character and store n /= radix } until (n == 0 || i >= size) if (unsigned) { if (carry ~= 0 && i < size) { # check for final carry i += 1 str (i) = '1'c } } elif (int < 0 && i < size) { # add sign if needed i += 1 str (i) = '-'c } gltoc = i - 1 # will return length of string for (d = 1; d < i; {d += 1; i -= 1}) { # reverse digits carry = str (d) str (d) = str (i) str (i) = carry } return end #HD#: gtacl$.r 1073 Nov-06-1984 08:48:33 # gtacl$ --- get acl protection for a pathname into ACL common block integer function gtacl$ (path, key, attach_sw) character path (ARB) integer key, attach_sw include SWT_COMMON include ACL_COMMON integer indx, i, j character treen (MAXTREE), temp (MAXTREE) integer name (MAXPACKEDFNAME), pass(3) character vtree (MAXVARYFNAME), temptree (129) integer mktr$, equal, getto call mktr$ (path, treen) attach_sw = NO Acl_version = 2 Acl_count = 0 if (path (1) == EOS) return (OK) if (getto (path, name, pass, attach_sw) == ERR) return (ERR) i = 1 call ptov (name, ' 'c, vtree, MAXVARYFNAME) if (key == 1) call ac$lst (vtree, loc (Primos_acl), 32, temptree, Acl_type, Errcod) elif (key == 2) { call pa$lst (vtree, loc (Primos_acl), 32, Errcod) temptree (1) = 0 # zero-length varying string } else Errcod = EBKEY if (attach_sw == YES) call follow(EOS, 0) if (Errcod ~= 0) return (ERR) if (Acl_version > 2 | Acl_version < 1) { Errcod = EBVER return (ERR) } call vtoc (temptree, treen, MAXTREE) call mapstr (treen, LOWER) call mkpa$ (treen, Acl_name, NO) for (j = 1; j <= Acl_count; j += 1) { call vtoc (Acl_pairs (1, j), temp, MAXLINE) call mapstr (temp, LOWER) indx = 1 while (temp (indx) ~= ':'c) { if (temp (indx) ~= ' 'c) Acl_user (indx, j) = temp (indx) indx += 1 } Acl_user (indx, j) = EOS indx += 1 SKIPBL (temp, indx) if (equal (temp (indx), "all"s) == YES) Acl_mode (j) = ACL_ALL elif (equal (temp (indx), "none"s) == YES) Acl_mode (j) = ACL_NONE else { Acl_mode (j) = ACL_NONE while (temp (indx) ~= EOS) { select (temp (indx)) when ('a'c) Acl_mode (j) |= ACL_ADD when ('d'c) Acl_mode (j) |= ACL_DELETE when ('l'c) Acl_mode (j) |= ACL_LIST when ('p'c) Acl_mode (j) |= ACL_PROTECT when ('r'c) Acl_mode (j) |= ACL_READ when ('u'c) Acl_mode (j) |= ACL_USE when ('w'c) Acl_mode (j) |= ACL_WRITE else { Errcod = EBACL return (ERR) } indx += 1 } # end while } # end else } # end for return (OK) end #HD#: gtattr.r 110 Nov-06-1984 08:48:34 # gtattr --- get user's terminal attributes integer function gtattr (attr) integer attr include SWT_COMMON if (0 < attr && attr <= MAXTERMATTR) return (Term_attr (attr)) else return (NO) end #HD#: gtemp.r 384 Nov-06-1984 08:48:34 # gtemp --- parse a template and its definition integer function gtemp (str, nm, repl) character str (ARB), nm (MAXARG), repl (MAXARG) integer i, j, l l = 1 # throw away comments while (str (l) ~= EOS && str (l) ~= '#'c && str (l) ~= NEWLINE) l += 1 repeat l -= 1 # strip trailing blanks until (l <= 0 || str (l) ~= ' 'c) if (l <= 0) # this is a blank line return (EOF) l += 1 # remember where end of text is i = 1 SKIPBL (str, i) # grab the name for (j = 1; j < MAXARG && i < l && str (i) ~= ' 'c; {j += 1; i += 1}) nm (j) = str (i) nm (j) = EOS SKIPBL (str, i) # grab the replacement value for (j = 1; j < MAXARG && i < l; {j += 1; i += 1}) repl (j) = str (i) repl (j) = EOS return (OK) end #HD#: gttype.r 136 Nov-06-1984 08:48:34 # gttype --- get the string for the user's terminal type integer function gttype (str) character str (ARB) integer ttyp$f, ttyp$r, ttyp$q if ((ttyp$r (str) == NO || str (1) == EOS) && ttyp$f (str) == NO) return (ttyp$q (str, NO)) return (YES) end #HD#: gvlarg.r 392 Nov-06-1984 08:48:34 # gvlarg --- obtain the value of a key-letter argument integer function gvlarg (str, state) character str (ARB) integer state (4) integer getarg repeat { select (state (1)) when (1) { state (1) = 2 # new state state (2) = 1 # next argument state (3) = ERR # current input file state (4) = 0 # input file count } when (2) { if (getarg (state (2), str, MAXARG) ~= EOF) { state (1) = 2 # stay in same state if (str (1) == "-"c) str (1) = EOS else state (2) += 1 return (OK) } state (1) = 4 # EOF state } when (3) { str (1) = EOS return (OK) } when (4, 5) break else call error ("in gvlarg: bad state (1) value*n"p) } # end of infinite repeat str (1) = EOS return (EOF) end #HD#: icomn$.r 218 Nov-06-1984 08:48:34 # icomn$ --- initialize Subsystem common areas subroutine icomn$ include SWT_COMMON integer i Arg_c = 0 Cmdstat = 0 Errcod = 0 Comunit = 0 Passwd (1) = EOS Ls_top = MAXLSBUF - 1 Ls_na = 1 Ls_ho = 1 Ls_ref (1) = EOS Utemptop = 0 do i = 1, MAXTEMPHASH Uhashtb (i) = LAMBDA do i = 1, 4; { Rtlabel (i) = 0 Bplabel (i) = 0 } call ioinit # initialize I/O routines return end #HD#: index.s 391 Nov-06-1984 08:48:34 * index --- find character c in string str * * integer function index (str, c) * character c, str (ARB) * * for (index = 1; str (index) ~= EOS; index += 1) * if (str (index) == c) * return * index = 0 * return * end SUBR INDEX SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK INDEX ECB INDEX$,,STR,2 DATA 5,C'INDEX' PROC DYNM =20,STR(3),C(3) INDEX$ ARGT ENTR INDEX EAXB STR,* XB := STR LDX =0 X := 0 LOOP LDA XB%+0,X if (XB+X)^ = C then CAS =EOS if (XB+X)^ = EOS then JMP *+2 go to NE JMP NE CAS C,* if (XB+X)^ = C then JMP *+2 go to EQ JMP EQ BIX LOOP X := X + 1; goto LOOP EQ TXA return X + 1 A1A PRTN NE CRA return 0 PRTN END #HD#: init$f.r 208 Nov-06-1984 08:48:34 # init$f --- force the Fortran IOCS to understand the Subsystem subroutine init$f integer f integer mapfd, mapsu call flush$ (mapsu (STDIN)) call flush$ (mapsu (STDOUT)) f = mapfd (STDIN) if (f > 0) call attdev (5, 7, f, 128) else call attdev (5, 1, 0, 128) f = mapfd (STDOUT) if (f > 0) call attdev (6, 7, f, 128) else call attdev (6, 1, 0, 128) return end #HD#: init$p.r 590 Nov-06-1984 08:48:35 # init$p --- initialize the Pascal INPUT and OUTPUT files subroutine init$p integer f, i, path (MAXPATH), tree (MAXPATH) integer mapfd, mapsu, gfnam$ integer iflag, i1, i2, i3, i4, i5, iunit, i6, i7, i8 integer ifnam (64), i9, ibuf (128) common /p$ainp/ iflag, i1, i2, i3, i4, i5, iunit, i6, i7, i8, ifnam, i9, ibuf integer oflag, o1, o2, o3, o4, o5, ounit, o6, o7, o8 integer ofnam (64), o9, obuf (128) common /p$aout/ oflag, o1, o2, o3, o4, o5, ounit, o6, o7, o8, ofnam, o9, obuf call flush$ (mapsu (STDIN)) call flush$ (mapsu (STDOUT)) f = mapfd (STDIN) if (f > 0) { call attdev (f, 7, f, 128) iflag &= not (:1000) iunit = f i = 1 if (gfnam$ (STDIN, path, MAXPATH) ~= ERR) { call mktr$ (path, tree) call ctop (tree, i, ifnam, 64) } else call ctop ("pathname unobtainable"s, i, ifnam, 64) } f = mapfd (STDOUT) if (f > 0) { call attdev (f, 7, f, 128) oflag &= not (:1000) ounit = f i = 1 if (gfnam$ (STDOUT, path, MAXPATH) ~= ERR) { call mktr$ (path, tree) call ctop (tree, i, ofnam, 64) } else call ctop ("pathname unobtainable"s, i, ofnam, 64) } return end #HD#: init$plg.plg 334 Nov-06-1984 08:48:35 /* init$plg --- initialize a PL/I G program under the Subsystem */ init$plg: procedure; declare (sysin, sysprint) file; declare mapfd entry (fixed) returns (fixed), mapsu entry (fixed) returns (fixed), flush$ entry (fixed); declare fd fixed; call flush$ (mapsu (-10)); call flush$ (mapsu (-11)); fd = mapfd (-10); if fd > 0 then open file (sysin) stream input title (' -funit ' || fd); else open file (sysin) stream input title ('@tty'); fd = mapfd (-11); if fd > 0 then open file (sysprint) stream output title (' -funit ' || fd); else open file (sysprint) stream output title ('@tty'); end init$plg; #HD#: init.r 113 Nov-06-1984 08:48:35 # init --- initialization subroutine for Software Tools Subsystem subroutine init call remark ("You are trying to run a pre-version 9 compilation."p) call error ("Please recompile and try again."p) return end #HD#: input.r 610 Nov-06-1984 08:48:35 # input --- semi-formatted input routine integer function input (fd, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) file_des fd character fmt (ARB) integer a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB) integer ap, sp, fp, i integer getlin, decode, index, isatty file_des tf character str (MAXDECODE), tfmt (MAXDECODE) logical psw if (and (fmt (1), :177400) ~= 0) call ptoc (fmt, '.'c, tfmt, MAXDECODE) else call ctoc (fmt, tfmt, MAXDECODE) fp = 1 ap = 1 psw = (isatty (fd) ~= NO) tf = fd repeat { while (tfmt (fp) ~= FORMATFLAG) { if (psw) call putch (tfmt (fp), TTY) fp += 1 } if (tfmt (fp) == EOS) break if (getlin (str, tf, MAXDECODE) == EOF) return (EOF) sp = 1 select (decode (str, sp, tfmt, fp, ap, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)) when (OK) # there's more format left tf = fd when (EOF) # end of format break when (ERR) { # error in field i = index (str (sp), NEWLINE) # print only to first NEWLINE if (i ~= 0) str (sp + i - 1) = EOS call print (TTY, "Error: '*s' retype: "s, str (sp)) tf = TTY } } return (ap - 1) end #HD#: iofl$.r 254 Nov-06-1984 08:48:35 # iofl$ --- initialize open file list subroutine iofl$ (state) integer state (MAXFILESTATE) include SWT_COMMON integer fd, sp integer junk2, code longint junk1 sp = 1 do fd = 1, NFILES if (Fd_flags (fd_offset (fd)) == 0) { state (sp) = fd sp += 1 } state (sp) = ERR sp += 1 do fd = 1, 128; { call prwf$$ (KRPOS, fd, intl (0), 0, junk1, junk2, code) if (code ~= 0 && code ~= EBUNT) { state (sp) = fd sp += 1 } } state (sp) = ERR return end #HD#: ioinit.r 555 Nov-06-1984 08:48:35 # ioinit --- initialize Subsystem I/O areas subroutine ioinit include SWT_COMMON integer fd, i integer duplx$ character default_kresp (4) data default_kresp / '\'c, '\'c, NEWLINE, EOS / ### Initialize all file descriptors to the closed state: do fd = 1, NFILES Fd_flags (fd_offset (fd)) = 0 ### Initialize file descriptor 1 for terminal i/o: Fd_dev (TTY) = DEV_TTY Fd_unit (TTY) = 0 Fd_bufstart (TTY) = 0 Fd_buflen (TTY) = 0 Fd_bufend (TTY) = 0 Fd_count (TTY) = 0 Fd_bcount (TTY) = 0 Fd_flags (TTY) = FD_READ + FD_WRITE Fd_lastfd = 1 ### Set up term buffer and attributes: Echar = BS Kchar = DEL Rtchar = DC2 Escchar = ESC Eofchar = ETX Nlchar = NEWLINE call ctoc (default_kresp, Kill_resp, MAXKILLRESP) Term_cp = 1 Term_buf (Term_cp) = EOS Term_count = 0 do i = 1, MAXTERMATTR Term_attr (i) = NO Lword = duplx$ (-1) # record the terminal configuration Prt_form (1) = EOS Prt_dest (1) = EOS ### Set up initial standard port map: do fd = 1, MAX_STD_PORTS Std_port_tbl (fd) = TTY return end #HD#: isadsk.r 138 Nov-06-1984 08:48:36 # isadsk --- determine if a file descriptor refers to a terminal integer function isadsk (fd) file_des fd include SWT_COMMON integer f filedes mapsu f = fd_offset (mapsu (fd)) if (Fd_dev (f) == DEV_DSK) return (YES) else return (NO) end #HD#: isatty.r 138 Nov-06-1984 08:48:36 # isatty --- determine if a file descriptor refers to a terminal integer function isatty (fd) file_des fd include SWT_COMMON integer f filedes mapsu f = fd_offset (mapsu (fd)) if (Fd_dev (f) == DEV_TTY) return (YES) else return (NO) end #HD#: isnull.r 141 Nov-06-1984 08:48:36 # isnull --- determine if a file descriptor refers to the bit bucket integer function isnull (fd) file_des fd include SWT_COMMON integer f filedes mapsu f = fd_offset (mapsu (fd)) if (Fd_dev (f) == DEV_NULL) return (YES) else return (NO) end #HD#: isph$.r 78 Nov-06-1984 08:48:36 # isph$ --- return whether we are a phantom or not integer function isph$(dummy) integer dummy include SWT_COMMON return (Isphantom) end #HD#: itoc.r 320 Nov-06-1984 08:48:36 # itoc --- convert single precision integer to decimal string integer function itoc (int, str, size) integer int, size character str (size) integer intval integer d, i, j, k string digits "0123456789" intval = int str (1) = EOS i = 1 repeat { # generate digits i += 1 d = iabs (mod (intval, 10)) str (i) = digits (d + 1) intval /= 10 } until (intval == 0 || i >= size) if (int < 0 && i < size) { # then sign i += 1 str (i) = '-'c } itoc = i - 1 for (j = 1; j < i; j += 1) { # then reverse k = str (i) str (i) = str (j) str (j) = k i -= 1 } return end #HD#: jdate.r 215 Nov-06-1984 08:48:37 # jdate --- take month, day, and year and return day-of-year integer function jdate (m, d, y) integer m, d, y integer i, mdays (12) data mdays /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ jdate = d for (i = 1; i < m; i += 1) jdate += mdays (i) if (m > 2) { if (mod (y, 400) == 0) jdate += 1 else if (mod (y, 100) == 0) ; else if (mod (y, 4) == 0) jdate += 1 } return end #HD#: ldseg$.r 2148 Nov-06-1984 08:48:37 # ldseg$ --- load a segmented runfile into memory subroutine ldseg$ (rvec, name, len, code) integer rvec (9), name (ARB), len, code define (DB,#) integer symtab (1) common /sgsymt/ symtab integer bit, dfd, i, junk, n, rc, rev, sfd, wrd, addr (2), masks (16), segmap (512), sthead (21), svec (10), tvec (30) integer symtab_size integer chunk$ pointer p, q data masks / :100000, :040000, :020000, :010000, :004000, :002000, :001000, :000400, :000200, :000100, :000040, :000020, :000010, :000004, :000002, :000001 / procedure open_directory forward procedure return_error forward open_directory ### read and check the revision flag: call prwf$$ (KREAD, dfd, loc (rev), 1, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading rev", 11, "ldseg$", 6) if (rc ~= 0 || rev ~= -1) return_error ### read the size of the segment map: call prwf$$ (KREAD, dfd, loc (n), 1, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading n", 9, "ldseg$", 6) if (rc ~= 0 || n > 256) return_error ### read the segment bit map: call prwf$$ (KREAD, dfd, loc (segmap), n * 2, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading segmap", 14, "ldseg$", 6) if (rc ~= 0) return_error ### read the save vector: call prwf$$ (KREAD, dfd, loc (svec), 10, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading svec", 12, "ldseg$", 6) if (rc ~= 0) return_error ### read the time vector: call prwf$$ (KREAD, dfd, loc (tvec), 30, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading tvec", 12, "ldseg$", 6) if (rc ~= 0 || tvec (10) < 6) # we don't support old revs # tvec (10) == 6 == Rev 17 # tvec (10) == 7 == Rev 18 return_error ### check for compatiblity if (tvec (10) < 7) symtab_size = svec (9) else symtab_size = svec (10) ### read the symbol table: call prwf$$ (KREAD, dfd, loc (symtab), symtab_size, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading symtab", 14, "ldseg$", 6) if (rc ~= 0) return_error ### read the symbol table list head vector: call prwf$$ (KREAD, dfd, loc (sthead), 21, intl (0), junk, rc) DB call errpr$ (KIRTN, rc, "reading sthead", 14, "ldseg$", 6) if (rc ~= 0) return_error for (p = sthead (18); p ~= NULL; p = symtab (q + SG_CHAIN)) { q = symtab_size - (p * SG_NODESIZE) + 1 DB call print (TTY, "Examining symbol number *i at *i*n"p, DB p, q) DB call print (TTY, " *7,-8u*i*i*i*i*i*i*i*i*i*1n"p, DB symtab (q + 0), symtab (q + 1), symtab (q + 2), symtab (q + 3), DB symtab (q + 4), symtab (q + 5), symtab (q + 6), symtab (q + 7), DB symtab (q + 8)) if (symtab (q + SG_SEGNUM) <= 8r4000 # ignore shared segments || symtab (q + SG_FLAGS) >= 0) # segment is empty next call zmem$ (symtab (q)) # clear uninitialized areas n = and (symtab (q + SG_FLAGS), 8r777) * 32 addr (1) = symtab (q + SG_SEGNUM) addr (2) = 0 do i = 1, 32; { # each segment is divided into 32 2K chunks bit = rt (n, 4) wrd = rs (n, 4) if (and (segmap (wrd + 1), masks (bit + 1)) ~= 0) { DB call print (TTY, " loading chunk *i at *a*n"p, n, addr) if (chunk$ (addr, n, sfd) == ERR) return_error } n += 1 addr (2) += 8r4000 } } call srch$$ (KCLOS, 0, 0, dfd, 0, rc) call srch$$ (KCLOS, 0, 0, sfd, 0, rc) rvec (4) = svec (5) # initial A register setting rvec (5) = svec (6) # initial B register setting rvec (6) = svec (7) # initial X register setting rvec (7) = 0 # initial KEYS rvec (8) = svec (1) # address of ECB for main program rvec (9) = svec (2) code = 0 return # open_directory --- open the runfile and subfile 0 procedure open_directory { call srch$$ (KREAD + KGETU, name, len, sfd, junk, code) DB call errpr$ (KIRTN, code, "opening segdir", 14, "ldseg$", 6) if (code ~= 0) return call srch$$ (KREAD + KGETU + KISEG, sfd, 0, dfd, junk, code) DB call errpr$ (KIRTN, code, "opening seg 0", 13, "ldseg$", 6) if (code ~= 0) { call srch$$ (KCLOS, 0, 0, sfd, 0, junk) return } } # return_error --- clean up and return error status procedure return_error { call srch$$ (KCLOS, 0, 0, dfd, 0, rc) call srch$$ (KCLOS, 0, 0, sfd, 0, rc) code = EBPAR return } undefine (DB) end #HD#: ldtmp$.r 650 Nov-06-1984 08:48:37 # ldtmp$ --- load the per-user template area subroutine ldtmp$ include SWT_COMMON filedes fd filedes open integer i integer getlin, gtemp character str (MAXLINE), nm (MAXARG), repl (MAXARG) procedure add_entry forward define (out,1) call break$ (DISABLE) do i = 1, MAXTEMPHASH Uhashtb (i) = LAMBDA Utemptop = 0 fd = open ("=utemplate="s, READ) if (fd == ERR) { call break$ (ENABLE) return } while (getlin (str, fd) ~= EOF) if (gtemp (str, nm, repl) ~= EOF) add_entry # Add the entry to the table out; call close (fd) call break$ (ENABLE) return # add_entry --- add an entry to the template table procedure add_entry { local h, i, p, q, need integer h, i, p, q, need integer scopy, length need = length (nm) + length (repl) + 4 if (Utemptop + need > MAXTEMPBUF) { call print (ERROUT, "*s: too many user templates*n"s, nm) call seterr (1000) goto out } h = 0 for (i = 1; i <= 4 && nm (i) ~= EOS; i += 1) h += nm (i) h = mod (h, MAXTEMPHASH) + 1 p = Utemptop + 1 Utempbuf (p) = Uhashtb (h) Uhashtb (h) = p q = p + 2 + scopy (nm, 1, Utempbuf, p + 2) + 1 Utempbuf (p + 1) = q Utemptop = q + scopy (repl, 1, Utempbuf, q) } undefine (out) end #HD#: length.s 262 Nov-06-1984 08:48:37 * length --- returns length of a string * * integer function length (str) * character str (ARB) SUBR LENGTH SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK LENGTH ECB LENGTH$,,STR,1 DATA 6,C'LENGTH' PROC DYNM =20,STR(3) LENGTH$ ARGT ENTR LENGTH EAXB STR,* XB := STR LDX =0 X := 0 LDA =EOS LOOP CAS XB%,X if (XB+X)^ = EOS then JMP *+2 goto OUT JMP OUT BIX LOOP X := X + 1; goto LOOP OUT TXA return X PRTN END #HD#: locate.r 166 Nov-06-1984 08:48:37 # locate --- look for c in char class at pat (offset) integer function locate (c, pat, offset) character c, pat (MAXPAT) integer offset integer i # size of class is at pat (offset), characters follow for (i = offset + pat (offset); i > offset; i -= 1) if (c == pat (i)) return (YES) return (NO) end #HD#: lookac.r 145 Nov-06-1984 08:48:38 # lookac --- look up a name in the 'acl' common block integer function lookac (name) character name (ARB) include ACL_COMMON integer i integer equal for (i = 1; i <= Acl_count; i += 1) if (equal (Acl_user (1, i), name) == YES) return (i) return (ERR) end #HD#: lookup.r 247 Nov-06-1984 08:48:38 # lookup --- find a symbol in the symbol table, return its data integer function lookup (symbol, info, st) character symbol (ARB) integer info (ARB) pointer st integer Mem (1) common /ds$mem/ Mem integer i, nodesize integer st$lu pointer node, pred if (st$lu (symbol, node, pred, st) == NO) { lookup = NO return } nodesize = Mem (st) for (i = 1; i <= nodesize; i += 1) info (i) = Mem (node + ST_DATA - 1 + i) lookup = YES return end #HD#: lopen$.r 1894 Nov-06-1984 08:48:38 # lopen$ --- open a disk file in the spool queue filedes function lopen$ (path, fd, mode) character path (ARB) filedes fd integer mode include SWT_COMMON integer unit1, unit2, unit3, i, j, pp, bl, offset integer junk (3), info (29), banner (16), buf (100) integer mapdn, ctoi, ctop, parstm, mapup longint t character str (MAXPATH) procedure check forward procedure getstr forward unit1 = 0; unit2 = 0; unit3 = 0 info (3) = RAW do i = 4, 29 info (i) = " " i = 1 bl = ctop ("/DEV/LPS"s, i, banner, 16) # Parse the arguments for (pp = 1; path (pp) ~= EOS; pp += 1) select (mapdn (path (pp))) when ('/'c, '-'c, ' 'c) # argument separator ; when ('f'c) # Fortran forms control info (3) = or (and (info (3), not (LNR + RAW)), FTN) when ('r'c) # Raw forms control info (3) = or (and (info (3), not (LNR + FTN)), RAW) when ('s'c) # Standard forms control info (3) &= not (FTN + RAW) when ('h'c) # suppress header page info (3) |= NHD when ('j'c) # suppress trailing page eject info (3) |= NEJ when ('n'c) # generate line numbers info (3) |= LNR when ('a'c) { # specify destination printer info (3) |= ATL getstr j = 1 call ctop (str, j, info (13), 8) } when ('d'c) { # defer printing info (3) |= DEF getstr i = 1 if (parstm (str, i, t) == ERR) return (ERR) info (11) = ints (t / 60) } when ('b'c) { # specify banner getstr j = 1 bl = ctop (str, j, banner, 16) } when ('c'c) { # specify number of copies info (3) |= COP getstr i = 1 info (29) = ctoi (str, i) } when ('p'c) { # specify form type getstr j = 1 call ctop (str, j, info (4), 3) } else return (ERR) if (Prt_dest (1) ~= EOS && info (13) == " ") { info (3) |= ATL call ctoc (Prt_dest, str, MAXLINE) call mapstr (str, UPPER) j = 1 call ctop (str, j, info (13), 8) } if (Prt_form (1) ~= EOS && info (4) == " ") { call ctoc (Prt_form, str, MAXLINE) call mapstr (str, UPPER) j = 1 call ctop (str, j, info (4), 3) } # Open the current directory three times for reading to get three units # (we throw away the first unit because 'spool$' uses K$GETU # before using the units we are supplying!!) call srch$$ (KREAD + KGETU, KCURR, 32, unit1, junk, Errcod); check call srch$$ (KREAD + KGETU, KCURR, 32, unit2, junk, Errcod); check call srch$$ (KREAD + KGETU, KCURR, 32, unit3, junk, Errcod); check call srch$$ (KCLOS, 0, 0, unit1, junk, Errcod) call srch$$ (KCLOS, 0, 0, unit2, junk, Errcod) call srch$$ (KCLOS, 0, 0, unit3, junk, Errcod) info (1) = unit2 info (2) = unit3 # Open the file in the queue (always opened read/write) call spool$ (2, banner, bl, info, buf, 100, Errcod) if (Errcod ~= 0) return (ERR) # And fill in the detail in the descriptor offset = fd_offset (fd) Fd_unit (offset) = unit3 Fd_flags (offset) |= FD_WRITE + FD_COMP # be sure file is writable if (and (info (3), RAW + NHD) == RAW) { # raw with header: call putch (FF, fd) # put in formfeed call putch (NEWLINE, fd) } return (fd) # check --- check for a Primos file system error procedure check { if (Errcod ~= 0) { if (unit1 ~= 0) call srch$$ (KCLOS, 0, 0, unit1, junk, junk) if (unit2 ~= 0) call srch$$ (KCLOS, 0, 0, unit2, junk, junk) return (ERR) } } # getstr --- grab a string from the input path procedure getstr { local i integer i while (path (pp + 1) == '/'c || path (pp + 1) == ' 'c) pp += 1 for (i = 1; path (pp + 1) ~= EOS && path (pp + 1) ~= '/'c && path (pp + 1) ~= ' 'c; {pp += 1; i += 1}) str (i) = mapup (path (pp + 1)) str (i) = EOS } end #HD#: ltoc.r 325 Nov-06-1984 08:48:38 # ltoc --- convert double precision integer to decimal string integer function ltoc (int, str, size) longint int integer size character str (size) longint intval integer d, i, j, k string digits "0123456789" intval = int str (1) = EOS i = 1 repeat { # generate digits i += 1 d = iabs (mod (intval, 10)) str (i) = digits (d + 1) intval /= 10 } until (intval == 0 || i >= size) if (int < 0 && i < size) { # then sign i += 1 str (i) = '-'c } ltoc = i - 1 for (j = 1; j < i; j += 1) { # then reverse k = str (i) str (i) = str (j) str (j) = k i -= 1 } return end #HD#: lutemp.r 1051 Nov-06-1984 08:48:38 # lutemp --- look up a template in the template directory integer function lutemp (jig, str, strlen) character jig (ARB), str (ARB) integer strlen include "=incl=/temp_com.r.i" include PRIMOS_KEYS include SWT_COMMON integer h, p, i, l, code integer scopy, equal, mod, length character tbuf (MAXPATH), dirname(MAXTREE) for (i = 1; jig (i) ~= EOS; i += 1) tbuf (i) = jig (i) tbuf (i) = EOS h = 0 for (i = 1; i <= 4 && jig (i) ~= EOS; i += 1) h += tbuf (i) h = mod (h, MAXTEMPHASH) + 1 for (p = Uhashtb (h); p ~= LAMBDA; p = Utempbuf (p)) if (equal (tbuf, Utempbuf (p + 2)) == YES) break if (p ~= LAMBDA) { l = scopy (Utempbuf, Utempbuf (p + 1), tbuf, 1) if (l >= strlen) return (EOF) return (scopy (tbuf, 1, str, 1)) } for (p = Hashtb (h); p ~= LAMBDA; p = Tempbuf (p)) if (equal (tbuf, Tempbuf (p + 2)) == YES) break if (p == LAMBDA) return (EOF) select (- Tempbuf (p + 1)) when (TEMP_DATE) { # date call date (SYS_DATE, tbuf) tbuf (3) = tbuf (4); tbuf (4) = tbuf (5) tbuf (5) = tbuf (7); tbuf (6) = tbuf (8) tbuf (7) = EOS l = 6 } when (TEMP_TIME) { # time call date (SYS_TIME, tbuf) tbuf (3) = tbuf (4); tbuf (4) = tbuf (5) tbuf (5) = tbuf (7); tbuf (6) = tbuf (8) tbuf (7) = EOS l = 6 } when (TEMP_USER) { # user call date (SYS_USERID, tbuf) l = length (tbuf) while (l > 0 && tbuf (l) == ' 'c) l -= 1 tbuf (l + 1) = EOS call mapstr (tbuf, LOWER) } when (TEMP_PID) { # pid call date (SYS_PIDSTR, tbuf) l = length (tbuf) } when (TEMP_PASSWD) { # passwd l = scopy (Passwd, 1, tbuf, 1) } when (TEMP_DAY) { # day call date (SYS_DAY, tbuf) l = length (tbuf) } when (TEMP_HOME) { # home call gpath$(KINIA, 0, tbuf, MAXPATH, i, code) if (code ~= 0) return(EOF) call ptoc(tbuf, EOS, dirname, i + 1) call mkpa$(dirname, tbuf, NO) l = mapstr(tbuf, LOWER) } else l = scopy (Tempbuf, Tempbuf (p + 1), tbuf, 1) if (l >= strlen) return (EOF) return (scopy (tbuf, 1, str, 1)) end #HD#: makpat.r 927 Nov-06-1984 08:48:39 # makpat --- make pattern from arg (from), terminate at delim integer function makpat (arg, from, delim, pat) character arg (MAXARG), delim, pat (MAXPAT) integer from character esc integer addset, getccl, stclos integer i, j, junk, lastcl, lastj, lj, tag_nest, tag_num, tag_stack (9) j = 1 # pat index lastj = 1 lastcl = 0 tag_num = 0 tag_nest = 0 for (i = from; arg (i) ~= delim && arg (i) ~= EOS; i += 1) { lj = j if (arg (i) == PAT_ANY) junk = addset (PAT_ANY, pat, j, MAXPAT) else if (arg (i) == PAT_BOL && i == from) junk = addset (PAT_BOL, pat, j, MAXPAT) else if (arg (i) == PAT_EOL && arg (i + 1) == delim) junk = addset (PAT_EOL, pat, j, MAXPAT) else if (arg (i) == PAT_CCL) { if (getccl (arg, i, pat, j) == ERR) { makpat = ERR return } } else if (arg (i) == PAT_CLOSURE && i > from) { lj = lastj if (pat (lj) == PAT_BOL || pat (lj) == PAT_EOL || pat (lj) == PAT_CLOSURE || pat (lj) == PAT_START_TAG || pat (lj) == PAT_STOP_TAG) break lastcl = stclos (pat, j, lastj, lastcl) } else if (arg (i) == PAT_START_TAG) { if (tag_num >= 9) # too many tagged sub-patterns break tag_num += 1 tag_nest += 1 tag_stack (tag_nest) = tag_num junk = addset (PAT_START_TAG, pat, j, MAXPAT) junk = addset (tag_num, pat, j, MAXPAT) } else if (arg (i) == PAT_STOP_TAG && tag_nest > 0) { junk = addset (PAT_STOP_TAG, pat, j, MAXPAT) junk = addset (tag_stack (tag_nest), pat, j, MAXPAT) tag_nest -= 1 } else { junk = addset (PAT_CHAR, pat, j, MAXPAT) junk = addset (esc (arg, i), pat, j, MAXPAT) } lastj = lj } if (arg (i) ~= delim) # terminated early makpat = ERR else if (addset (EOS, pat, j, MAXPAT) == NO) # no room makpat = ERR else if (tag_nest ~= 0) makpat = ERR else makpat = i return end #HD#: maksub.r 416 Nov-06-1984 08:48:39 # maksub --- make substitution string in sub integer function maksub (arg, from, delim, sub) character arg (ARB), delim, sub (MAXPAT) integer from character esc, type integer addset integer i, j, junk j = 1 for (i = from; arg (i) ~= delim && arg (i) ~= EOS; i += 1) if (arg (i) == PAT_AND) { junk = addset (PAT_DITTO, sub, j, MAXPAT) junk = addset (0 + PAT_MARK, sub, j, MAXPAT) } else if (arg (i) == ESCAPE && type (arg (i + 1)) == DIGIT) { i += 1 junk = addset (PAT_DITTO, sub, j, MAXPAT) junk = addset (arg (i) - '0'c + PAT_MARK, sub, j, MAXPAT) } else junk = addset (esc (arg, i), sub, j, MAXPAT) if (arg (i) ~= delim) # missing delimiter maksub = ERR else if (addset (EOS, sub, j, MAXPAT) == NO) # no room maksub = ERR else maksub = i return end #HD#: mapdn.r 89 Nov-06-1984 08:48:39 # mapdn --- fold characters to lower case character function mapdn (c) character c if (IS_UPPER (c)) mapdn = c - 'A'c + 'a'c else mapdn = c return end #HD#: mapfd.r 163 Nov-06-1984 08:48:39 # mapfd --- convert fd to Primos funit integer function mapfd (fd) filedes fd include SWT_COMMON integer off, f integer mapsu f = mapsu (fd) if (f < 1 || f > NFILES) return (ERR) off = fd_offset (f) if (Fd_dev (off) == DEV_DSK) return (Fd_unit (off)) else return (ERR) end #HD#: mapstr.r 217 Nov-06-1984 08:48:39 # mapstr --- map case of a K&P string integer function mapstr (str, case) character str (ARB) integer case integer i if (case == UPPER) { for (i = 1; str (i) ~= EOS; i += 1) if (IS_LOWER (str (i))) str (i) = str (i) - 'a'c + 'A'c } else { for (i = 1; str (i) ~= EOS; i += 1) if (IS_UPPER (str (i))) str (i) = str (i) - 'A'c + 'a'c } mapstr = i - 1 # return length of string return end #HD#: mapsu.r 312 Nov-06-1984 08:48:39 # mapsu --- map standard unit to file descriptor file_des function mapsu (std_unit) file_des std_unit include SWT_COMMON integer i mapsu = std_unit if (mapsu > 0) # this test added for execution speed return do i = 1, 10 select (mapsu) when (STDIN1) mapsu = Std_port_tbl (1) when (STDIN2) mapsu = Std_port_tbl (3) when (STDIN3) mapsu = Std_port_tbl (5) when (STDOUT1) mapsu = Std_port_tbl (2) when (STDOUT2) mapsu = Std_port_tbl (4) when (STDOUT3) mapsu = Std_port_tbl (6) else return return (TTY) # infinite definition -- send back TTY end #HD#: mapup.r 88 Nov-06-1984 08:48:39 # mapup --- fold characters to upper case character function mapup (c) character c if (IS_LOWER (c)) mapup = c - 'a'c + 'A'c else mapup = c return end #HD#: markf.r 292 Nov-06-1984 08:48:40 # markf --- read the position of a file filemark function markf (fd) filedes fd include SWT_COMMON integer f, off integer mapsu longint tmark$, dmark$ f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_ERR) ~= 0 || Fd_flags (off) == 0) return (ERR) if (LASTOP (off) ~= FD_INITIAL) { call flush$ (f) SET_LASTOP (off, FD_INITIAL) } select (Fd_dev (off)) when (DEV_TTY) return (tmark$ (off)) when (DEV_DSK) return (dmark$ (off)) when (DEV_NULL) return (0) return (ERR) end #HD#: match.r 140 Nov-06-1984 08:48:40 # match --- find match anywhere on line integer function match (lin, pat) character lin (ARB), pat (MAXPAT) integer amatch integer i, junk (9) for (i = 1; lin (i) ~= EOS; i += 1) if (amatch (lin, i, pat, junk, junk) > 0) return (YES) return (NO) end #HD#: mkdir$.r 357 Nov-06-1984 08:48:40 # mkdir$ --- create a subdirectory integer function mkdir$ (name, owner, non_owner) character name (ARB), owner (ARB), non_owner (ARB) integer newdir (16), opw (3), npw (3), attach, code, i, junk (3) integer getto, findf$, ctop mkdir$ = ERR do i = 1, 3; { opw (i) = " " npw (i) = " " } i = 1 if (ctop (owner, i, opw, 3) == 0) opw (1) = 0 i = 1 if (ctop (non_owner, i, npw, 3) == 0) npw (1) = 0 if (getto (name, newdir, junk, attach) ~= ERR && findf$ (newdir) == NO) { call crea$$ (newdir, 32, opw, npw, code) call satr$$ (KPROT, newdir, 32, 16r07010000, junk) if (code == 0) mkdir$ = OK } if (attach ~= NO) call at$hom (code) return end #HD#: mkfd$.r 409 Nov-06-1984 08:48:40 # mkfd$ --- make a Subsystem file from an already open Primos unit file_des function mkfd$ (unit, mode) integer unit, mode include SWT_COMMON filedes fd, getfd$ integer f # Find an empty descriptor if (getfd$ (fd) == ERR) return (ERR) f = fd_offset (fd) call break$ (DISABLE) # Initialize the descriptor Fd_dev (f) = DEV_DSK Fd_unit (f) = unit Fd_bufstart (f) = fd * BUFSIZE - BUFSIZE Fd_buflen (f) = BUFSIZE Fd_bufend (f) = 0 Fd_count (f) = 0 Fd_bcount (f) = 0 Fd_flags (f) = FD_OPENED + FD_COMP + FD_INITIAL select (and (mode, 16r3)) # in case there are extra bits when (READ) Fd_flags (f) |= FD_READ when (WRITE) Fd_flags (f) |= FD_WRITE when (READWRITE) Fd_flags (f) |= FD_READ + FD_WRITE call break$ (ENABLE) return (fd) end #HD#: mkpa$.r 969 Nov-06-1984 08:48:40 # mkpa$ --- convert a treename into a pathname integer function mkpa$ (tree, path, default) character path (ARB), tree (ARB) integer default # where default is YES or NO controlling the conversion # of a simple name to a file in the current # directory or a UFD name. # YES assumes conversion to a UFD name integer i, tp integer index character mapdn procedure copy_and_convert forward # # current state of conversions: # # DIR>SUBDIR>FILE converts to '/name/dir/subdir/file' # DIR>SUBDIR>FILE converts to '//dir/subdir/file' # *>SUBDIR>FILE converts to 'subdir/file' # SIMPLENAME converts to either # 'simplename' # or # '//simplename' # depending on argument default # i = 1 SKIPBL (tree, i) if (index (tree, '>'c) == 0) { # is it a simple name? if (default == YES) { call scopy ('//'s, 1, path, 1) # give default disk name tp = 3 # and copy rest after } else tp = 1 copy_and_convert return (tp - 1) } if (tree (i) == '<'c) tp = 1 else if (tree (i) == '*'c && tree (i + 1) == '>'c) { i += 2 tp = 1 } else { call scopy ('//'s, 1, path, 1) i = 1 tp = 3 } copy_and_convert return (tp - 1) # copy_and_convert --- copy tree body and convert to path procedure copy_and_convert { SKIPBL (tree, i) while (tree (i) ~= EOS) { select (tree (i)) when ('<'c) { SKIPBL (tree, i) path (tp) = '/'c } when ('>'c) { SKIPBL (tree, i) path (tp) = '/'c } when ('/'c) { path (tp) = ESCAPE path (tp + 1) = '/'c tp += 1 } when (' 'c) { SKIPBL (tree, i) if (tree (i) ~= EOS && tree (i) ~= '>'c) path (tp) = ':'c tp += 1 while (tree (i) ~= EOS && tree (i) ~= '>'c) { path (tp) = tree (i) tp += 1 i += 1 } } else path (tp) = mapdn (tree (i)) i += 1 tp += 1 } path (tp) = EOS } end #HD#: mkpacl.r 519 Nov-06-1984 08:48:41 # mkpacl --- encode SWT ACL info into Primos structure subroutine mkpacl include ACL_COMMON integer i, j, k character temp (MAXACLLIST) integer encode define (INSCHAR (x), {temp (i) = x; i +=1}) Acl_version = 2 for (j = 1; j <= Acl_count; j += 1) { i = encode (temp, MAXACLLIST, "*s:"s, Acl_user (1, j)) i += 1 if (Acl_mode (j) == ACL_ALL) call ctoc ("all"s, temp (i), 4) elif (Acl_mode (j) == ACL_NONE) call ctoc ("none"s, temp (i), 5) else { if (and (ACL_ADD, Acl_mode (j)) ~= 0) INSCHAR ('a'c) if (and (ACL_DELETE, Acl_mode (j)) ~= 0) INSCHAR ('d'c) if (and (ACL_LIST, Acl_mode (j)) ~= 0) INSCHAR ('l'c) if (and (ACL_PROTECT, Acl_mode (j)) ~= 0) INSCHAR ('p'c) if (and (ACL_READ, Acl_mode (j)) ~= 0) INSCHAR ('r'c) if (and (ACL_USE, Acl_mode (j)) ~= 0) INSCHAR ('u'c) if (and (ACL_WRITE, Acl_mode (j)) ~= 0) INSCHAR ('w'c) INSCHAR (EOS) } k = 1 call ctov (temp, k, Acl_pairs (1, j), 41) } return undefine (INSCHAR) end #HD#: mksacl.r 634 Nov-06-1984 08:48:41 # mksacl --- encode the ACL structure integer function mksacl (ret_acl_path, access_pairs, type, separator) character ret_acl_path (ARB), access_pairs (ARB), separator (ARB) integer type include ACL_COMMON integer i, count integer encode, ctoc define (INSCHAR(x), {access_pairs (i) = x; i +=1}) call ctoc (Acl_name, ret_acl_path, MAXPATH) type = Acl_type i = 1 for (count = 1; count <= Acl_count; count += 1) { i += encode (access_pairs (i), MAXACLLIST, "*s="s, Acl_user (1, count)) if (Acl_mode (count) == ACL_NONE) i += ctoc ("$none"s, access_pairs (i), MAXACLLIST) elif (Acl_mode (count) == ACL_ALL) i += ctoc ("$all"s, access_pairs (i), MAXACLLIST) else { if (and (ACL_ADD, Acl_mode (count)) ~= 0) INSCHAR('a'c) if (and (ACL_DELETE, Acl_mode (count)) ~= 0) INSCHAR('d'c) if (and (ACL_LIST, Acl_mode (count)) ~= 0) INSCHAR('l'c) if (and (ACL_PROTECT, Acl_mode (count)) ~= 0) INSCHAR('p'c) if (and (ACL_READ, Acl_mode (count)) ~= 0) INSCHAR('r'c) if (and (ACL_USE, Acl_mode (count)) ~= 0) INSCHAR('u'c) if (and (ACL_WRITE, Acl_mode (count)) ~= 0) INSCHAR('w'c) } i += encode (access_pairs (i), MAXACLLIST, separator) } return (i - 1) undefine (INSCHAR) end #HD#: mktabl.r 193 Nov-06-1984 08:48:41 # mktabl --- make a new (empty) symbol table pointer function mktabl (nodesize) integer nodesize integer Mem (1) common /ds$mem/ Mem pointer st pointer dsget integer i st = dsget (ST_HTABSIZE + 1) # +1 for record of nodesize Mem (st) = nodesize mktabl = st do i = 1, ST_HTABSIZE; { st += 1 Mem (st) = LAMBDA # null link } return end #HD#: mktemp.r 172 Nov-06-1984 08:48:41 # mktemp --- open a temporary file and return its unit number filedes function mktemp (mode) integer mode integer i, fd character tempf (15) integer create for (i = 1; i <= 999; i += 1) { call encode (tempf, 15, "=temp=/tm*i"s, i) fd = create (tempf, mode) if (fd ~= ERR) return (fd) } return (ERR) end #HD#: mktr$ 0 Nov-06-1984 08:48:41 #HD#: mktr$.r 1047 Nov-06-1984 08:48:41 # mktr$ --- convert a pathname into a treename integer function mktr$ (path, tree) character path (ARB), tree (ARB) procedure inchar (char) forward procedure back$$ forward integer tp, i, mfdpwd, blank integer index, scopy tp = 1 i = 1 SKIPBL (path, i) blank = NO select (path (i)) when ('/'c) { mfdpwd = NO if (path (i + 1) == '/'c) # special case two leading slashes for (i += 2; path (i) == '/'c; i += 1) ; else { inchar ('<'c) for (i += 1; path (i) ~= '/'c && path (i) ~= EOS; i += 1) { if (path (i) == ESCAPE) { i += 1 inchar (path (i)) } else if (path (i) == ':'c) { tp += scopy (">MFD"s, 1, tree, tp) mfdpwd = YES blank = YES } else { if (blank == YES) inchar (' 'c) inchar (path (i)) blank = NO } } if (path (i) ~= '/'c && mfdpwd == NO) tp += scopy (">MFD XXXXXX"s, 1, tree, tp) } } when ('\'c) back$$ when (EOS) ; else { inchar ('*'c) inchar ('>'c) } for (; path (i) ~= EOS; i += 1) { if (path (i) == '/'c) { blank = NO while (path (i + 1) == '/'c) i += 1 if (path (i + 1) ~= EOS) inchar ('>'c) } elif (path (i) == ':'c) blank = YES else { if (blank == YES) inchar (' 'c) if (path (i) == ESCAPE) i += 1 inchar (path (i)) blank = NO } } tree (tp) = EOS return (tp - 1) # inchar --- put a character in the tree name procedure inchar (char) { character char tree (tp) = char tp += 1 } # back$$ --- intepret backslashes in a pathname procedure back$$ { local code, buf integer code, buf (MAXTREE) call gpath$ (2, 0, buf, MAXTREE * 2 - 1, tp, code) if (code ~= 0) return (ERR) call ptoc (buf, EOS, tree, tp + 1) call mapstr (tree, LOWER) for (tp += 1; path (i) == '\'c; i += 1) { repeat tp -= 1 until (tp < 1 || tree (tp) == '>'c) } if (tp < 1) tp = 1 tree (tp) = EOS if (path (i) ~= '/'c && path (i) ~= EOS) inchar ('>'c) elif (path (i) == EOS && index (tree, '>'c) == 0) tp += scopy (">MFD XXXXXX"s, 1, tree, tp) } end #HD#: mntoc.r 530 Nov-06-1984 08:48:42 # mntoc --- translate ASCII mnemonic into a character character function mntoc (buf, p, default) character buf (ARB), default integer p integer i, tp integer strbsr character c, tmp (MAXLINE) string_table pos, text ACK, "ack"/ BEL, "bel"/ BS, "bs"/ CAN, "can"/ CR, "cr"/ DC1, "dc1"/ DC2, "dc2"/ DC3, "dc3"/ DC4, "dc4"/ DEL, "del"/ DLE, "dle"/ EM, "em"/ ENQ, "enq"/ EOT, "eot"/ ESC, "esc"/ ETB, "etb"/ ETX, "etx"/ FF, "ff"/ FS, "fs"/ GS, "gs"/ HT, "ht"/ LF, "lf"/ NAK, "nak"/ NUL, "nul"/ RS, "rs"/ SI, "si"/ SO, "so"/ SOH, "soh"/ SP, "sp"/ STX, "stx"/ SUB, "sub"/ SYN, "syn"/ US, "us"/ VT, "vt" if (buf (p) == EOS) return (default) tp = 1 repeat { tmp (tp) = buf (p) tp += 1 p += 1 } until (~ (IS_LETTER (buf (p)) || IS_DIGIT (buf (p))) || tp >= MAXLINE) tmp (tp) = EOS if (tp == 2) c = tmp (1) else { call mapstr (tmp, LOWER) i = strbsr (pos, text, 1, tmp) if (i ~= EOF) c = text (pos (i)) else c = default } return (c) end #HD#: move$.s 521 Nov-06-1984 08:48:42 * move$ --- move blocks of memory around quickly * * subroutine move$ (from, to, count) * integer from (ARB), to (ARB), count * * integer i * * for (i = 1; i <= count; i += 1) * to (i) = from (i) * * return * end SUBR MOVE$ SEG RLIT include "=incl=/lib_def.s.i" LINK MOVE$ ECB MOVE,,FROM_PTR,3 DATA 5,C'MOVE$' PROC DYNM =20,FROM_PTR(3),TO_PTR(3),COUNT_PTR(3) MOVE ARGT ENTR MOVE$ LDA COUNT_PTR,* SNZ PRTN TAX EAXB FROM_PTR,*X EALB TO_PTR,*X TCA TAX SLN JMP L1 LDA XB%,X STA LB%,X BIX *+3 PRTN TXA L1 SAS 15 JMP L2 LDL XB%,X STL LB%,X IRX BIX *+3 PRTN TXA L2 SAS 14 JMP L3 DFLD XB%,X DFST LB%,X ADD =4 SNZ PRTN TAX L3 SAS 13 JMP L4 DFLD XB%,X DFST LB%,X DFLD XB%+4,X DFST LB%+4,X ADD =8 SNZ PRTN TAX L4 DFLD XB%,X DFST LB%,X DFLD XB%+4,X DFST LB%+4,X DFLD XB%+8,X DFST LB%+8,X DFLD XB%+12,X DFST LB%+12,X ADD =16 BNE L4-1 PRTN END #HD#: omatch.r 405 Nov-06-1984 08:48:42 # omatch --- try to match a single pattern at pat (j) integer function omatch (lin, i, pat, j) character lin (ARB), pat (MAXPAT) integer i, j integer locate integer bump omatch = NO if (lin (i) == EOS) return bump = -1 select (pat (j)) when (PAT_CHAR) { if (lin (i) == pat (j + 1)) bump = 1 } when (PAT_BOL) { if (i == 1) bump = 0 } when (PAT_ANY) { if (lin (i) ~= NEWLINE) bump = 1 } when (PAT_EOL) { if (lin (i) == NEWLINE) bump = 0 } when (PAT_CCL) { if (locate (lin (i), pat, j + 1) == YES) bump = 1 } when (PAT_NCCL) { if (lin (i) ~= NEWLINE && locate (lin (i), pat, j + 1) == NO) bump = 1 } else call error ("in omatch: can't happen"s) if (bump >= 0) { i += bump omatch = YES } return end #HD#: open.r 1355 Nov-06-1984 08:48:42 # open --- open a file for reading and/or writing filedes function open (path, mode, ftype, delay) character path (ARB) integer mode, ftype, delay include SWT_COMMON integer fd, f, i, j integer dopen$, lopen$, mapdn, strbsr, expand, getfd$ character dev_name (30), epath (MAXPATH) string_table dev_pos, dev_tab, / 1, ERRIN, "errin" _ / 1, ERROUT, "errout" _ / 4, 0, "lps" _ / 2, 0, "null" _ / 1, STDIN, "stdin" _ / 1, STDIN1, "stdin1" _ / 1, STDIN2, "stdin2" _ / 1, STDIN3, "stdin3" _ / 1, STDOUT, "stdout" _ / 1, STDOUT1, "stdout1" _ / 1, STDOUT2, "stdout2" _ / 1, STDOUT3, "stdout3" _ / 3, 0, "tty" procedure creturn (val) forward # Find an empty descriptor if (getfd$ (fd) == ERR) return (ERR) f = fd_offset (fd) call break$ (DISABLE) # Initialize the descriptor (except device type) Fd_bufstart (f) = fd * BUFSIZE - BUFSIZE Fd_buflen (f) = BUFSIZE Fd_bufend (f) = 0 Fd_count (f) = 0 Fd_bcount (f) = 0 select (and (mode, 3)) # look only at 2 low-order bits when (READ) Fd_flags (f) = FD_READ when (WRITE) Fd_flags (f) = FD_WRITE when (READWRITE) Fd_flags (f) = FD_READ + FD_WRITE else creturn (ERR) Fd_flags (f) |= FD_OPENED + FD_INITIAL # Expand the templates in the name: if (expand (path, epath, MAXPATH) == ERR) creturn (ERR) # Select the device type: i = 1 SKIPBL (epath, i) # Is it a disk file? if ( epath (i + 0) ~= '/'c || mapdn (epath (i + 1)) ~= 'd'c || mapdn (epath (i + 2)) ~= 'e'c || mapdn (epath (i + 3)) ~= 'v'c || epath (i + 4) ~= '/'c) { Fd_dev (f) = DEV_DSK creturn (dopen$ (path, fd, mode, ftype, delay)) } # It must be a device file i += 5 # skip past "/dev/" for (j = 1; epath (i) ~= EOS && epath (i) ~= '/'c && epath (i) ~= ' 'c; {j += 1; i += 1}) dev_name (j) = mapdn (epath (i)) dev_name (j) = EOS # Look up the device j = strbsr (dev_pos, dev_tab, 2, dev_name) if (j == EOF) creturn (ERR) select (dev_tab (dev_pos (j))) when (1) { Fd_flags (f) = 0 # give back the file descriptor creturn (dev_tab (dev_pos (j) + 1)) # return the standard port } when (2) { Fd_dev (f) = DEV_NULL creturn (fd) } when (3) { Fd_dev (f) = DEV_TTY creturn (fd) } when (4) { Fd_dev (f) = DEV_DSK creturn (lopen$ (epath (i), fd, mode)) } Fd_flags (f) = 0 call break$ (ENABLE) return (ERR) # error in table # creturn --- deallocate file descriptor if returning error status procedure creturn (val) { integer val if (val == ERR) Fd_flags (f) = 0 call break$ (ENABLE) return (val) } end #HD#: page.r 7414 Nov-06-1984 08:48:43 # page --- display a file on a CRT terminal one page at a time. define (BOUND(v,l,h),min0(max0(v,l),h)) define (BREAKLN,1) # Line number for processing QUIT$ define (MAXLNPP,64) # Maximum number of lines per page define (MAXPAGE,10000) # Maximum number of pages define (MSCREEN,86) # Maximum screen width + 1 define (FORWARD,0) # Key to search forward define (BACKWARD,1) # Key to search backward integer function page (fdin, promptin, epromptin, linesin, fdout, options) character promptin (ARB), epromptin (ARB) file_des fdin, fdout integer linesin, options external pg$brk file_des open file_mark markf integer isatty, vtinit, vtprt, vtgetl, getlin, ctoi, makpat, match, scopy logical missin character term (MAXTERMTYPE), screen (MSCREEN, MAXLNPP), input (MAXLINE), line (MAXLINE), temp (MAXLINE), prompt (MAXLINE), eprompt (MAXLINE), message (MAXLINE), emessage (MAXLINE) file_mark pages (MAXPAGE) integer vthrc (2), tempat (MAXPAT), pattern (MAXPAT) integer label (4) file_des ifd, ofd, tifd, tofd integer pg, last, index, lines, columns, size, first, start, begin, clear, i, j, k, l, m, missing_delim logical pause, vthout, error, noread, nopat, found string_table help_index, help_source, "The following commands (upper or lower case) are available:" _ / " D Display continuous pages" _ / " E Begin examining the file named " _ / " E Begin examining the original file" _ / " H or ? Display this command summary" _ / " M Change left margin of display" _ / " N Stop paging, normal status" _ / " P or ^ Display the previous page" _ / ' Q Same as "N"' _ / " S Change page size to " _ / " W Write a copy of the file into " _ / " X Stop paging, EOF status" _ / " Y or : Go to the next page" _ / ' Same as "X", does not work with vth' _ / ' Same as "Y"' _ / " Display page " _ / " - Display current page - " _ / " . Redisplay the current page" _ / " + Display current page + " _ / " $ Display the last page" _ / " /[/] Display next page containing " _ / " \[\] Display previous page containing " include SWT_COMMON procedure read_page (num) forward procedure display_page forward procedure find_page (direction) forward procedure exit (val) forward ifd = fdin ofd = fdout if (isatty (ofd) == NO) { call fcopy (ifd, ofd) return (OK) } call ctoc (promptin, prompt, MAXLINE) call ctoc (epromptin, eprompt, MAXLINE) if (missin (options)) { pause = TRUE vthout = FALSE } else { pause = and (options, PG_END) == 0 vthout = and (options, PG_VTH) ~= 0 } call break$ (DISABLE) do i = 1, 4 label (i) = Rtlabel (i) call mklb$f ($ BREAKLN, Rtlabel) call mkon$f ("QUIT$", 5, pg$brk) if (vthout) { vthout = vtinit (term) == OK if (vthout) { call vtinfo (VT_MAXRC, vthrc) lines = vthrc (1) - 1 columns = vthrc (2) call vtupd (YES) } } if (~vthout) { lines = BOUND (linesin, 1, MAXLNPP) columns = 80 } pg = 0 last = MAXPAGE - 1 size = 0 index = 0 first = 1 pages (1) = intl (0) do i = 2, MAXPAGE pages (i) = intl (-1) input (1) = EOS line (1) = EOS error = FALSE read_page (1) noread = TRUE nopat = TRUE call break$ (ENABLE) repeat { if (error) { error = FALSE clear = NO if (pg ~= last) if (vthout) { start = 1 + vtprt (vthrc (1), 1, message, pg) begin = start + vtprt (vthrc (1), start, "*s"s, input) + 1 } else call print (TTY, message, pg) else if (vthout) { start = 1 + vtprt (vthrc (1), 1, emessage, pg) begin = start + vtprt (vthrc (1), start, "*s"s, input) + 1 } else call print (TTY, emessage, pg) } else { clear = YES if (noread) noread = FALSE else read_page (pg + 1) display_page if (pg == last) { if (index == 0 || ifd == fdin && ~pause) { if (ifd ~= fdin) call close (ifd) exit (OK) } if (vthout) { start = 1 + vtprt (vthrc (1), 1, eprompt, pg) begin = start } else call print (TTY, eprompt, pg) } else if (vthout) { start = 1 + vtprt (vthrc (1), 1, prompt, pg) begin = start } else call print (TTY, prompt, pg) } input (1) = EOS if (vthout) { call vtenb (vthrc (1), start, vthrc (2) - start + 1) call vtread (vthrc (1), begin, clear) call vtenb (vthrc (1), start, 0) size = vtgetl (input, vthrc (1), start, vthrc (2) - start + 1) call vtclr (vthrc (1), 1, vthrc (1), vthrc (2)) call vtupd (NO) } else { size = getlin (input, TTY) if (size == EOF) { call putch (NEWLINE, TTY) if (ifd ~= fdin) call close (ifd) exit (EOF) } if (input (size) == NEWLINE) input (size) = EOS } call strim (input) i = 1 SKIPBL (input, i) select (input (i)) when ("d"c, "D"c) { i += 1 j = BOUND (ctoi (input, i), 1, MAXPAGE - pg - 1) for (k = 1; k < j && pg ~= last; k += 1) { read_page (pg + 1) if (pg ~= last) { display_page if (vthout) call vtupd (NO) } } if (pg == last) noread = TRUE } when ("e"c, "E"c) { i += 1 SKIPBL (input, i) if (input (i) ~= EOS) { tifd = open (input (i), READ) if (tifd ~= ERR) { if (ifd ~= fdin) call close (ifd) ifd = tifd for (j = 1; input (i) ~= EOS; i += 1) if (j < MAXLINE - 1) { line (j) = input (i) if (line (j) == '*'c) { line (j + 1) = '*'c j += 1 } j += 1 } line (j) = EOS call encode (prompt, MAXLINE, "*s [**i+]? "s, line) call encode (eprompt, MAXLINE, "*s [**i$]? "s, line) } else { call encode (message, MAXLINE, "*s: can't open [**i+]? "s, input (i)) call encode (emessage, MAXLINE, "*s: can't open [**i$]? "s, input (i)) error = TRUE } } else { if (ifd ~= fdin) call close (ifd) ifd = fdin call ctoc (promptin, prompt, MAXLINE) call ctoc (epromptin, eprompt, MAXLINE) } if (~error) { last = MAXPAGE - 1 do j = 2, MAXPAGE pages (j) = intl (-1) read_page (1) noread = TRUE } } when ("h"c, "H"c, "?"c) { if (vthout) call vtclr (1, 1, lines, vthrc (2)) for (i = 1; i <= help_index (1); i += 1) if (vthout) call vtputl (help_source (help_index (i + 1)), i, 1) else call print (ofd, "*s*n"s, help_source (help_index (i + 1))) input (1) = EOS call ctoc (prompt, message, MAXLINE) call ctoc (eprompt, emessage, MAXLINE) error = TRUE } when ("m"c, "M"c) { i += 1 first = max0 (ctoi (input, i), 1) read_page (pg) noread = TRUE } when ("n"c, "N"c, "q"c, "Q"c) { if (ifd ~= fdin) call close (ifd) exit (OK) } when ("p"c, "P"c, "^"c) { read_page (pg - 1) noread = TRUE } when ("s"c, "S"c) { if (~vthout) { i += 1 lines = BOUND (ctoi (input, i), 1, MAXLNPP) do j = 2, MAXPAGE pages (j) = intl (-1) read_page (1) } noread = TRUE } when ("w"c, "W"c) { i += 1 SKIPBL (input, i) if (input (i) ~= EOS) { tofd = open (input (i), READ) if (tofd == ERR) { tofd = open (input (i), WRITE) if (tofd ~= ERR) { call seekf (pages (1), ifd) call fcopy (ifd, tofd) call seekf (pages (pg + 1), ifd) call close (tofd) input (1) = EOS call ctoc (prompt, message, MAXLINE) call ctoc (eprompt, emessage, MAXLINE) error = TRUE } else { call encode (message, MAXLINE, "*s: can't open [**i+]? "s, input (i)) call encode (emessage, MAXLINE, "*s: can't open [**i$]? "s, input (i)) error = TRUE } } else { call close (tofd) call ctoc ("File already exists [*i+]? "s, message, MAXLINE) call ctoc ("File already exists [*i$]? "s, emessage, MAXLINE) error = TRUE } } else { call ctoc ("Path name missing [*i+]? "s, message, MAXLINE) call ctoc ("Path name missing [*i$]? "s, emessage, MAXLINE) error = TRUE } } when ("x"c, "X"c) { if (ifd ~= fdin) call close (ifd) exit (EOF) } when ("y"c, "Y"c, ":"c, EOS) if (pg == last) { if (ifd ~= fdin) call close (ifd) exit (OK) } when ("."c) noread = TRUE when ("$"c) { read_page (MAXPAGE - 1) noread = TRUE } when (SET_OF_DIGITS) { read_page (BOUND (ctoi (input, i), 1, MAXPAGE - 1)) noread = TRUE } when ("+"c) { i += 1 read_page (pg + BOUND (ctoi (input, i), 1, MAXPAGE - pg - 1)) noread = TRUE } when ("-"c) { i += 1 read_page (pg - max0 (ctoi (input, i), 1)) noread = TRUE } when ("/"c) { if (nopat && (input (i + 1) == "/"c || input (i + 1) == EOS)) { call ctoc ("No saved pattern [*i+]? "s, message, MAXLINE) call ctoc ("No saved pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } if (input (i + 1) == EOS) { input (i + 1) = input (i) input (i + 2) = EOS } else if (input (i + 1) ~= "/"c) { missing_delim = YES for (l = i + 1; input (l) ~= EOS; l += 1) if (input (l) == ESCAPE && input (l+1) == input (i)) l += 1 else if (input (l) == input (i)) { missing_delim = NO break } if (missing_delim == YES) { for (; input (l) ~= EOS; l += 1) ; input (l) = input (i) input (l + 1) = EOS } if (makpat (input, i+1, input (i), tempat) == ERR) { call ctoc ("Syntax error in pattern [*i+]? "s, message, MAXLINE) call ctoc ("Syntax error in pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } else { do j = 1, MAXPAT pattern (j) = tempat (j) nopat = FALSE } } find_page (FORWARD) if (~found) { call ctoc ("Pattern not found [*i+]? "s, message, MAXLINE) call ctoc ("Pattern not found [*i$]? "s, emessage, MAXLINE) error = TRUE } else noread = TRUE } when ("\"c) { if (nopat && (input (i + 1) == "\"c || input (i + 1) == EOS)) { call ctoc ("No saved pattern [*i+]? "s, message, MAXLINE) call ctoc ("No saved pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } if (input (i + 1) == EOS) { input (i + 1) = input (i) input (i + 2) = EOS } else if (input (i + 1) ~= "\"c) { missing_delim = YES for (l = i + 1; input (l) ~= EOS; l += 1) if (input (l) == ESCAPE && input (l+1) == input (i)) l += 1 else if (input (l) == input (i)) { missing_delim = NO break } if (missing_delim == YES) { for (; input (l) ~= EOS; l += 1) ; input (l) = input (i) input (l + 1) = EOS } if (makpat (input, i+1, input (i), tempat) == ERR) { call ctoc ("Syntax error in pattern [*i+]? "s, message, MAXLINE) call ctoc ("Syntax error in pattern [*i$]? "s, emessage, MAXLINE) error = TRUE next } else { do j = 1, MAXPAT pattern (j) = tempat (j) nopat = FALSE } } find_page (BACKWARD) if (~found) { call ctoc ("Pattern not found [*i+]? "s, message, MAXLINE) call ctoc ("Pattern not found [*i$]? "s, emessage, MAXLINE) error = TRUE } else noread = TRUE } when (CR) { # Kludge for QUIT$ onunit BREAKLN if (index < lines) read_page (pg) call ctoc (prompt, message, MAXLINE) call ctoc (eprompt, emessage, MAXLINE) error = TRUE } else { call ctoc ("Unknown command, enter '?' for help [*i+]? "s, message, MAXLINE) call ctoc ("Unknown command, enter '?' for help [*i$]? "s, emessage, MAXLINE) error = TRUE } } # read_page --- read the requested page from the file into the buffer. procedure read_page { integer num local i, flag integer i logical flag num = BOUND (num, 1, MAXPAGE - 1) if (num ~= pg + 1) { if (pages (num) == intl (-1)) for (pg -= 1; pages (pg + 2) ~= intl (-1); pg += 1) ; else pg = num - 1 call seekf (pages (pg + 1), ifd) line (1) = EOS size = 0 } while (pg < num) { index = 0 if (line (1) ~= EOS) { size = scopy (line, 1, screen (1, index + 1), 1) line (1) = EOS if (screen (size, index + 1) == NEWLINE) screen (size, index + 1) = EOS index += 1 } while (index < lines && size ~= EOF) { flag = TRUE for (i = first; i > 1; i -= size) { size = getlin (temp, ifd, min0 (i, MSCREEN)) if (size == EOF || temp (size) == NEWLINE) { flag = FALSE break } } if (flag) size = getlin (screen (1, index + 1), ifd, columns) else if (size ~= EOF) { screen (1, index + 1) = NEWLINE screen (2, index + 1) = EOS size = 1 } else screen (1, index + 1) = EOS if (size ~= EOF) { if (screen (size, index + 1) ~= NEWLINE) repeat i = getlin (temp, ifd, MSCREEN) until (i == EOF || temp (i) == NEWLINE) else screen (size, index + 1) = EOS index += 1 } } pg += 1 if (size ~= EOF) { if (pg + 1 < MAXPAGE && pages (pg + 1) == intl (-1)) pages (pg + 1) = markf (ifd) flag = TRUE for (i = first; i > 1; i -= size) { size = getlin (temp, ifd, min0 (i, MSCREEN)) if (size == EOF || temp (size) == NEWLINE) { flag = FALSE break } } if (flag) size = getlin (line, ifd, columns) else if (size ~= EOF) { line (1) = NEWLINE line (2) = EOS size = 1 } else line (1) = EOS if (size ~= EOF) { if (line (size) ~= NEWLINE) repeat i = getlin (temp, ifd, MSCREEN) until (i == EOF || temp (i) == NEWLINE) } else pages (pg + 1) = intl (-1) } if (size == EOF) { last = pg break } } } # display_page --- display buffer on screen. procedure display_page { local i integer i if (vthout) call vtclr (1, 1, lines, vthrc (2)) for (i = 1; i <= index; i += 1) if (vthout) call vtputl (screen (1, i), i, 1) else call print (ofd, "*s*n"s, screen (1, i)) } # find_page --- find next page (circularly) that contains "pattern". procedure find_page { integer direction local i, j integer i, j i = pg found = FALSE repeat { if (direction == BACKWARD) if (pg == 1) read_page (MAXPAGE - 1) else read_page (pg - 1) else { read_page (pg + 1) if (pg == last && index == 0) read_page (1) } for (j = 1; j <= index && ~found; j += 1) if (match (screen (1, j), pattern) == YES) found = TRUE } until (found || pg == i) } # exit --- stop vth if applicable and return from page. procedure exit { integer val if (vthout) { call vtupd (NO) call vtstop } do i = 1, 4 Rtlabel (i) = label (i) return (val) } end subroutine pg$brk (cp) longint cp include SWT_COMMON call pl1$nl (Rtlabel) return end undefine(BOUND) undefine(BREAKLN) undefine(MAXLNPP) undefine(MAXPAGE) undefine(MSCREEN) undefine(FORWARD) undefine(BACKWARD) #HD#: parsa$.r 1967 Nov-06-1984 08:48:44 # parsa$ --- parse acl changes integer function parsa$ (str) character str (ARB) include ACL_COMMON integer sp, i, j, defval integer cprot integer lookac, equal character text (33) character cname (33), cop, cflag (33) procedure getname forward procedure getprot forward ### Save the default value i = lookac ("$rest"s) if (i ~= ERR) defval = Acl_mode (i) else defval = 0 ### Do the parsing... call mapstr (str, LOWER) sp = 1 SKIPBL (str, sp) while (str (sp) ~= EOS) { ### Grab the name -- give up if none getname if (text (1) == EOS) return (ERR) call scopy (text, 1, cname, 1) ### Get the assignment operator -- give up if none SKIPBL (str, sp) if (str (sp) == ':'c || str (sp) == '+'c || str (sp) == '-'c || str (sp) == '='c) { cop = str (sp) sp += 1 if (str (sp) == '='c) sp += 1 } else return (ERR) ### Now get the protections SKIPBL (str, sp) if (cop == ':'c) { # grab a name in the acl getname i = lookac (text) if (i == ERR) return (ERR) cprot = Acl_mode (i) } else # just look for letters & stuff getprot ### Update the name in the acl i = lookac (cname) if (i == ERR) { # not there--assign an empty slot i = lookac (""s) # find a slot if (i == ERR) { Acl_count += 1 if (Acl_count > 32) return (ERR) i = Acl_count } call scopy (cname, 1, Acl_user (1, i), 1) Acl_mode (i) = defval } if (cop == '='c || cop == ':'c) Acl_mode (i) = cprot else if (cop == '+'c) Acl_mode (i) |= cprot else if (cop == '-'c) Acl_mode (i) &= not (cprot) SKIPBL (str, sp) } # end of while (str (sp) ... ### Clobber entries equal to $rest (get $rest, too) i = lookac ("$rest"s) if (i == ERR) defval = 0 else defval = Acl_mode (i) for (i = 1; i <= Acl_count; i += 1) if (Acl_mode (i) == defval) Acl_user (1, i) = EOS ### Squash out deleted entries for ({i = 1; j = 1}; i <= Acl_count; i += 1) if (Acl_user (1, i) ~= EOS) { if (i ~= j) { call scopy (Acl_user (1, i), 1, Acl_user (1, j), 1) Acl_mode (j) = Acl_mode (i) } j += 1 } Acl_count = j - 1 ### Put in a $rest at the end Acl_count += 1 if (Acl_count > 32) return (ERR) call scopy ("$rest"s, 1, Acl_user (1, Acl_count), 1) Acl_mode (Acl_count) = defval return (OK) # getname --- collect a name from str (sp) into text (1) procedure getname { local i; integer i text (1) = EOS if (IS_LETTER (str (sp)) || str (sp) == '.'c || str (sp) == '$'c) { text (1) = str (sp) for ({sp += 1; i = 2}; i <= 33 && (IS_LETTER (str (sp)) || IS_DIGIT (str (sp)) || str (sp) == '$'c || str (sp) == '_'c || str (sp) == '.'c); {sp += 1; i += 1}) text (i) = str (sp) text (i) = EOS } } # getprot --- get protection string from str (sp) and put in cprot procedure getprot { cprot = ACL_NONE if (str (sp) == '$'c) { getname select when (equal (text, "$owner"s) == YES) cprot = ACL_DELETE + ACL_ADD + ACL_LIST _ + ACL_USE + ACL_READ + ACL_WRITE when (equal (text, "$read"s) == YES) cprot = ACL_LIST + ACL_READ + ACL_USE when (equal (text, "$use"s) == YES) cprot = ACL_ADD + ACL_LIST + ACL_USE + ACL_READ when (equal (text, "$all"s) == YES) cprot = ACL_ALL when (equal (text, "$none"s) == YES) cprot = ACL_NONE when (equal (text, "$default"s) == YES) cprot = defval when (equal (text, "$def"s) == YES) cprot = defval else return (ERR) } else repeat { select (str (sp)) when ('a'c) cprot |= ACL_ADD when ('p'c) cprot |= ACL_PROTECT when ('l'c) cprot |= ACL_LIST when ('u'c) cprot |= ACL_USE when ('r'c) cprot |= ACL_READ when ('w'c) cprot |= ACL_WRITE when ('d'c) cprot |= ACL_DELETE when ('?'c) cprot |= defval when ('*'c) cprot |= ACL_ALL when ('0'c) ; else break sp += 1 } } end #HD#: parscl.r 1943 Nov-06-1984 08:48:44 # parscl --- parse command line arguments integer function parscl (str, buf) character str (ARB), buf (MAXARGBUF) integer ap, bp, cp, sp, lc, i, l, k, at, status integer argtype (26) integer getarg, gctoi, ctoc, strbsr character arg (MAXARG) character mapdn string_table atx, att, / ARG_FLAG, "f" _ / ARG_FLAG, "flag" _ / ARG_IGNORED, "ign" _ / ARG_IGNORED, "ignored" _ / ARG_NOT_ALLOWED, "na" _ / ARG_OPT_INT, "oi" _ / ARG_OPT_INT, "opt int" _ / ARG_OPT_STR, "opt str" _ / ARG_OPT_STR, "os" _ / ARG_REQ_INT, "req int" _ / ARG_REQ_STR, "req str" _ / ARG_REQ_INT, "ri" _ / ARG_REQ_STR, "rs" procedure get_argtype forward procedure next_argument forward do i = 1, 26 argtype (i) = ARG_NOT_ALLOWED ### Parse the command string for (sp = 1; str (sp) ~= EOS; sp += 1) if (IS_LETTER (str (sp))) { lc = mapdn (str (sp)) - 'a'c + 1 get_argtype argtype (lc) = at } ### Initialize the argument buffer do i = 1, 26 buf (i) = ARG_NOT_SEEN do i = 27, 52 buf (i) = 0 ### Examine the argument list bp = 54 ap = 1 next_argument while (status ~= EOF) { l = mapdn (arg (cp)) - 'a'c + 1 if (l < 1 || l > 26) return (ERR) buf (l) = ARG_LETTER_SEEN select (argtype (l)) when (ARG_NOT_ALLOWED) return (ERR) when (ARG_IGNORED) { if (cp ~= 2) # ignored args can only be first letters return (ERR) ap += 1 next_argument } when (ARG_REQ_INT, ARG_OPT_INT) if (arg (cp + 1) == EOS) { call delarg (ap) if (getarg (ap, arg, MAXARG) ~= EOF && (IS_DIGIT (arg (1)) || arg (1) == '-'c && IS_DIGIT (arg (2)))) { cp = 1 buf (l + 26) = gctoi (arg, cp, 10) if (arg (cp) ~= EOS) return (ERR) buf (l) = ARG_VALUE_SEEN call delarg (ap) } else if (argtype (l) == ARG_REQ_INT) return (ERR) next_argument } else { cp += 1 k = cp buf (l + 26) = gctoi (arg, cp, 10) if (k == cp) { # no number here if (argtype (l) == ARG_REQ_INT) return (ERR) } else # indicate that value was given buf (l) = ARG_VALUE_SEEN } when (ARG_REQ_STR, ARG_OPT_STR) if (arg (cp + 1) == EOS) { call delarg (ap) if (getarg (ap, arg, MAXARG) ~= EOF && arg (1) ~= '-'c ) { buf (l + 26) = bp bp += 1 + ctoc (arg, buf (bp), MAXARGBUF - bp) call delarg (ap) buf (l) = ARG_VALUE_SEEN } else if (argtype (l) == ARG_REQ_STR) return (ERR) next_argument } else { buf (l + 26) = bp bp += 1 + ctoc (arg (cp + 1), buf (bp), MAXARGBUF - bp) buf (l) = ARG_VALUE_SEEN call delarg (ap) next_argument } when (ARG_FLAG) cp += 1 if (arg (cp) == EOS) { # bump the argument pointer if necessary call delarg (ap) next_argument } } do i = 1, 26 if (buf (i) ~= ARG_VALUE_SEEN # ensure string opts are defined && (argtype (i) == ARG_OPT_STR || argtype (i) == ARG_REQ_STR)) buf (i + 26) = bp buf (bp) = EOS bp += 1 buf (53) = bp return (OK) # get_argtype --- get and parse an argument type procedure get_argtype { local tbuf, tp, x character tbuf (MAXLINE) integer tp, x at = ARG_FLAG while (str (sp + 1) ~= '<'c && ~ IS_LETTER (str (sp + 1)) && str (sp + 1) ~= EOS) sp += 1 if (str (sp + 1) == '<'c) { tp = 1 sp += 1 while (str (sp + 1) ~= '>'c && str (sp + 1) ~= EOS) { tbuf (tp) = str (sp + 1) sp += 1 tp += 1 } tbuf (tp) = EOS x = strbsr (atx, att, 1, tbuf) if (x == EOF) { call putlin (tbuf, ERROUT) call error (": unrecognized argument type in parscl"p) } at = att (atx (x)) } } # next_argument --- obtain the next argument to parse procedure next_argument { status = getarg (ap, arg, MAXARG) while (status ~= EOF && (arg (1) ~= '-'c || ~ IS_LETTER (arg (2)))) { ap += 1 status = getarg (ap, arg, MAXARG) } cp = 2 } end #HD#: parsdt.r 457 Nov-06-1984 08:48:44 # parsdt --- parse a date in mm/dd/yy format integer function parsdt (str, i, month, day, year) character str (ARB) integer i, month, day, year integer j, days (12) integer ctoi character today (9) # Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec # data days / 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / SKIPBL (str, i) if (~IS_DIGIT (str (i))) return (ERR) month = ctoi (str, i) if (str (i) == '/'c) { i += 1 day = ctoi (str, i) if (str (i) == '/'c) { i += 1 year = ctoi (str, i) } else { call date (SYS_DATE, today) j = 7 year = ctoi (today, j) } } else { day = month call date (SYS_DATE, today) j = 1 month = ctoi (today, j) j = 7 year = ctoi (today, j) } if (1 <= month && month <= 12 && 1 <= day && day <= days (month) && 0 <= year && year <= 99) parsdt = OK else parsdt = ERR return end #HD#: parstm.r 484 Nov-06-1984 08:48:44 # parstm --- convert time-of-day to number of seconds since midnight integer function parstm (str, i, val) character str (ARB) integer i longint val define (TWELVE_HOURS,43200) integer ctoi character mapdn SKIPBL (str, i) if (~IS_DIGIT (str (i))) return (ERR) val = ctoi (str, i) # get hours if (str (i) == ':'c) i += 1 val = val * intl (60) + ctoi (str, i) # get minutes, if present if (str (i) == ':'c) i += 1 val = val * intl (60) + ctoi (str, i) # get seconds, if present if (val >= TWELVE_HOURS * 2) # only so many seconds in a day return (ERR) SKIPBL (str, i) select (mapdn (str (i))) when ('p'c) if (val < TWELVE_HOURS) # if it's AM, add 12 hours val += TWELVE_HOURS when ('a'c) if (val >= TWELVE_HOURS) # if it's PM, subtract 12 hours val -= TWELVE_HOURS ifany { i += 1 if (mapdn (str (i)) == 'm'c) i += 1 } return (OK) undefine (TWELVE_HOURS) end #HD#: patsiz.r 270 Nov-06-1984 08:48:44 # patsiz --- returns size of pattern entry at pat (n) integer function patsiz (pat, n) character pat (MAXPAT) integer n if (pat (n) == PAT_CHAR || pat (n) == PAT_START_TAG || pat (n) == PAT_STOP_TAG) patsiz = 2 else if (pat (n) == PAT_BOL || pat (n) == PAT_EOL || pat (n) == PAT_ANY) patsiz = 1 else if (pat (n) == PAT_CCL || pat (n) == PAT_NCCL) patsiz = pat (n + 1) + 2 else if (pat (n) == PAT_CLOSURE) # optional patsiz = PAT_CLOSIZE else call error ("in patsiz: can't happen"s) return end #HD#: print.r 282 Nov-06-1984 08:48:45 # print --- easy-to-use semi-formatted print routine subroutine print (fd, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) integer fd, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10 character fmt (ARB) character str (MAXPRINT), fmt1 (MAXLINE) if (fmt (1) == EOS || and (fmt (1), :177400) == 0) call encode (str, MAXPRINT, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) else { call ptoc (fmt, '.'c, fmt1, MAXLINE) call encode (str, MAXPRINT, fmt1, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) } call putlin (str, fd) return end #HD#: ptoc.r 198 Nov-06-1984 08:48:45 # ptoc --- convert packed string to EOS-terminated string integer function ptoc (pstr, term, str, len) integer pstr (ARB), len character term, str (ARB) integer cp, i cp = 0 for (i = 1; i < len; i += 1) { fpchar (pstr, cp, str (i)) if (str (i) == ESCAPE) fpchar (pstr, cp, str (i)) elif (str (i) == term) break } str (i) = EOS return (i - 1) end #HD#: ptov.s 1004 Nov-06-1984 08:48:45 * ptov --- convert packed to varying string * * integer function ptov (pstr, termch, vstr, len) * integer pstr (ARB), vstr (ARB), len * character termch * * returns number of characters moved (<= (len - 1) * 2) SUBR PTOV SEG RLIT SYML include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK PTOV ECB CNVSTART,,PSTR,4 DATA 4,C'PTOV' PROC DYNM =20,PSTR(3),TERMCH(3),VSTR(3),LEN(3) DYNM CHAR, FLAG CNVSTART ARGT ENTR PTOV CRA STA VSTR,* set number chars in target LDA LEN,* BEQ QUIT no space - quit S1A BEQ QUIT not enough space - quit STA LEN save first word for count LDA TERMCH,* STA TERMCH CRA STA FLAG TAX S1A TAB set B reg for fetch LT TAY COPYCH JSXB GETNXT CAS =ESCAPE JMP# CHKTERM JMP# SAVENXT save nextchar if this is an "@" CHKTERM CAS TERMCH JMP# STASH JMP# QUIT quit if it's terminating char JMP# STASH SAVENXT JSXB GETNXT STASH JSXB SAVEIT JMP COPYCH QUIT LDA VSTR,* fetch count & return it PRTN * * SAVEIT --- stash character in A into next open space in target * resulting word is always zero filled * SAVEIT EQU * STA CHAR LDA FLAG BNE EVENCH LT set flag for 2nd char STA FLAG LDA CHAR ICA store as first char in target word STA VSTR,*Y IRS VSTR,* add 1 to count RCB JMP% XB%+0 go back for more EVENCH EQU * CRA set flag for 1st char STA FLAG LDA CHAR ORA VSTR,*Y pack char STA VSTR,*Y and stash it IRS VSTR,* add 1 to count & set 1st char flag RCB TYA CAS LEN used all available space? JMP# QUIT JMP# QUIT A1A TAY JMP% XB%+0 go back for more * * GETNXT --- get next character into A * if B < 0 then tap source, else use char in B * GETNXT EQU * CRA S1A IAB if B >= 0 then BGE GOTIT LDA PSTR,*X get next 2 chars TAB CAL IAB second in B, ICL first in A IRX set for next fetch GOTIT JMP% XB%+0 END #HD#: putch.r 105 Nov-06-1984 08:48:45 # putch --- put a character on a file integer function putch (c, fd) character c filedes fd integer putlin character buf (2) buf (1) = c; buf (2) = EOS return (putlin (buf, fd)) end #HD#: putdec.r 174 Nov-06-1984 08:48:45 # putdec --- put decimal integer n in field width >= w subroutine putdec (n, w, unit) integer n, w, unit character chars (20) integer itoc integer i, nd nd = itoc (n, chars, 20) for (i = nd + 1; i <= w; i += 1) call putch (' 'c, unit) for (i = 1; i <= nd; i += 1) call putch (chars (i), unit) return end #HD#: putlin.r 433 Nov-06-1984 08:48:45 # putlin --- put a line on a file integer function putlin (line, fd) character line (ARB) filedes fd include SWT_COMMON integer f, off integer dputl$, tputl$, mapsu f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_WRITE) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) select (Fd_dev (off)) when (DEV_TTY) { if (LASTOP (off) ~= FD_PUTLIN) { call flush$ (f) SET_LASTOP (off, FD_PUTLIN) } return (tputl$ (line, off)) } when (DEV_DSK) { if (LASTOP (off) ~= FD_PUTLIN) { call flush$ (f) Fd_count (off) = -Fd_buflen (off) SET_LASTOP (off, FD_PUTLIN) } return (dputl$ (line, Fdesc (off))) } when (DEV_NULL) { if (LASTOP (off) ~= FD_PUTLIN) { call flush$ (f) SET_LASTOP (off, FD_PUTLIN) } return (0) } else return (ERR) end #HD#: putlit.r 126 Nov-06-1984 08:48:46 # putlit --- write literal string on specified unit subroutine putlit (msg, delim, unit) integer msg (ARB), unit character delim character str (MAXLINE) call ptoc (msg, delim, str, MAXLINE) call putlin (str, unit) return end #HD#: readf.r 339 Nov-06-1984 08:48:46 # readf --- read raw words from a file integer function readf (buf, nw, fd) integer buf (ARB), nw filedes fd include SWT_COMMON integer off, f integer mapsu, tread$, dread$ f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_READ) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) if (nw <= 0) return (0) if (LASTOP (off) ~= FD_READF) { call flush$ (f) SET_LASTOP (off, FD_READF) } select (Fd_dev (off)) when (DEV_TTY) readf = tread$ (buf, nw, off) when (DEV_DSK) readf = dread$ (buf, nw, off) when (DEV_NULL) readf = EOF else readf = ERR return end #HD#: remark.r 140 Nov-06-1984 08:48:46 # remark --- print quoted string on ERROUT subroutine remark (msg) integer msg (ARB) if (and (msg (1), :177400) == 0 || msg (1) == EOS) # unpacked? call putlin (msg, ERROUT) else call putlit (msg, '.'c, ERROUT) call putch (NEWLINE, ERROUT) return end #HD#: remove.r 163 Nov-06-1984 08:48:46 # remove --- remove a file, return status integer function remove (path) character path (ARB) integer fname (16), attach, j1 (3), code integer getto, rmfil$ remove = ERR if (getto (path, fname, j1, attach) ~= ERR) remove = rmfil$ (fname) if (attach == YES) call at$hom (code) return end #HD#: reonu$.s 511 Nov-06-1984 08:48:46 * reonu$ --- on-unit for the REENTER$ condition SUBR REONU$ SEG RLIT LINK REONU$ ECB REENTER,,CFP,1 DATA 6,C'REONU$' PROC DYNM =20,CFP(3) DYNM TARGET(4) FRAME_PB EQU 2 Offset of return address FRAME_SB EQU 4 Offset of previous stack frame address TARGET_PB EQU TARGET TARGET_SB EQU TARGET+2 REENTER ARGT BLEQ PRTN_ Make sure we're passed a static link ANA ='7777 Mask out ring bits STL TARGET_SB Save locally EAXB SB% Point XB at our frame VLOOP EAXB XB%+FRAME_SB,* Point XB at caller's frame LDL XB%+FRAME_SB Check for end of stack... CLS NULL ...signified by null return SB JMP# *+2 PRTN_ PRTN Target not found, can't reenter ANA ='7777 Mask out ring bits ERL TARGET_SB See if he returns to target frame... BLNE VLOOP ...if not, check previous frame LDL XB%+FRAME_PB Construct a label for non-local goto IAB STL TARGET_PB CALL PL1$NL AP TARGET,SL NULL DATA '7777,0 Null pointer END #HD#: rewind.r 75 Nov-06-1984 08:48:46 # rewind --- position to beginning-of-file integer function rewind (fd) integer fd integer seekf return (seekf (intl (0), fd)) end #HD#: rmfil$.r 395 Nov-06-1984 08:48:47 # rmfil$ --- remove a file, return status integer function rmfil$ (name) integer name (MAXPACKEDFNAME) include SWT_COMMON integer fd, code, type character vname (MAXVARYFNAME) call srch$$ (KCLOS, name, 32, 0, 0, code) call srch$$ (KDELE, name, 32, 0, 0, Errcod) if (Errcod == EDNTE) { # non-empty directory, see if segdir call srch$$ (KRDWR + KGETU, name, 32, fd, type, code) if (code == 0) { if (type == 2 || type == 3) call rmseg$ (fd) call srch$$ (KCLOS, 0, 0, fd, 0, code) call srch$$ (KDELE, name, 32, 0, 0, Errcod) } } elif (Errcod == EIACL) { # access category, deletes differently call ptov (name, ' 'c, vname, MAXVARYFNAME) call cat$dl (vname, Errcod) } rmfil$ = ERR if (Errcod == 0) rmfil$ = OK return end #HD#: rmseg$.r 320 Nov-06-1984 08:48:47 # rmseg$ --- remove a segment directory subroutine rmseg$ (fd) integer fd integer entrya, entryb, fd, fd2, junk, code entryb = -1 repeat { entrya = entryb + 1 call sgdr$$ (KFULL, fd, entrya, entryb, code) if (entryb == -1 || code ~= 0) break call srch$$ (KDELE + KISEG, fd, 0, 0, 0, code) if (code == EDNTE) { # non-empty nested segdir call srch$$ (KRDWR + KISEG + KGETU, fd, 0, fd2, junk, code) if (code == 0) call rmseg$ (fd2) call srch$$ (KCLOS, 0, 0, fd2, junk, code) call srch$$ (KDELE + KISEG, fd, 0, 0, junk, code) } } call sgdr$$ (KMSIZ, fd, 0, entryb, code) return end #HD#: rmtabl.r 214 Nov-06-1984 08:48:47 # rmtabl --- remove a symbol table, deleting all entries subroutine rmtabl (st) pointer st integer Mem (1) common /ds$mem/ Mem integer i pointer walker, bucket, node bucket = st do i = 1, ST_HTABSIZE; { bucket = bucket + 1 walker = Mem (bucket) while (walker ~= LAMBDA) { node = walker walker = Mem (node + ST_LINK) call dsfree (node) } } call dsfree (st) return end #HD#: rmtemp.r 128 Nov-06-1984 08:48:47 # rmtemp --- rewind, truncate, and close a temporary made by mktemp integer function rmtemp (fd) integer fd integer close call rewind (fd) call trunc (fd) if (close (fd) == ERR) rmtemp = ERR else rmtemp = OK return end #HD#: rtn$$.s 272 Nov-06-1984 08:48:47 * rtn$$ --- return to frame indicated in RTLABEL SUBR RTN$$ SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" include "=incl=/temp_com.s.i" LINK RTN$$ ECB RTN0 DATA 5,C'RTN$$' PROC DYNM =20 CLDATA$FLAGS EQU XB% + 6 RTN0 EAXB CLDATAPTR EAXB XB%,* LDA CLDATA$FLAGS ANA ='020000 Was I run by DBG? BNE MUSTEXIT If I was I must exit CALL PL1$NL Not run by DBG AP RTLABEL,SL just return to the shell MUSTEXIT CALL EXIT END #HD#: rtoc.r 134 Nov-06-1984 08:48:47 # rtoc --- convert single precision real to string integer function rtoc (val, str, w, d) real val character str (ARB) integer w, d integer dtoc longreal fval fval = val # convert to double precision return (dtoc (fval, str, w, d)) end #HD#: scopy.s 337 Nov-06-1984 08:48:48 * scopy --- copy a string at from(i) to to(j) * * integer function scopy (from, i, to, j) * character from (ARB), to (ARB) * integer i, j SUBR SCOPY SEG RLIT include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" LINK SCOPY ECB SCOPY$,,FROM,4 DATA 5,C'SCOPY' PROC DYNM =20,FROM(3),I(3),TO(3),J(3) SCOPY$ ARGT ENTR SCOPY LDX I,* XB := FROM+I-1 EAXB FROM,*X LDX J,* LB := TO+J-1 EALB TO,*X LDX =0 LOOP LDA XB%-1,X (SB+x)^ := (LB+X)^ STA LB%-1,X CAS =EOS if (LB+X)^ = EOS then JMP *+2 goto OUT JMP OUT BIX LOOP X := X + 1; goto LOOP OUT TXA return X PRTN END #HD#: sctabl.r 595 Nov-06-1984 08:48:48 # sctabl --- scan symbol table, returning next entry or EOF integer function sctabl (table, sym, info, posn) pointer table, posn character sym (ARB) integer info (ARB) integer Mem (1) common /ds$mem/ Mem pointer bucket, walker pointer dsget integer nodesize, i if (posn == 0) { # just starting scan? posn = dsget (2) # get space for position info Mem (posn) = 1 # get index of first bucket Mem (posn + 1) = Mem (table + 1) # get pointer to first chain } bucket = Mem (posn) # recover previous position walker = Mem (posn + 1) nodesize = Mem (table) repeat { # until the next symbol, or none are left if (walker ~= LAMBDA) { # symbol available? call scopy (Mem, walker + ST_DATA + nodesize, sym, 1) for (i = 1; i <= nodesize; i += 1) info (i) = Mem (walker + ST_DATA + i - 1) Mem (posn) = bucket # save position of next symbol Mem (posn + 1) = Mem (walker + ST_LINK) sctabl = 1 # not EOF return } else { bucket = bucket + 1 if (bucket > ST_HTABSIZE) break walker = Mem (table + bucket) } } call dsfree (posn) # throw away position information posn = 0 sc_tabl = EOF return end #HD#: sdrop.r 188 Nov-06-1984 08:48:48 # sdrop --- drop characters from a string APL-style integer function sdrop (from, to, chars) character from (ARB), to (ARB) integer chars integer len integer ctoc, scopy, length len = length (from) if (chars < 0) return (ctoc (from, to, len + chars + 1)) else { if (chars < len) len = chars return (scopy (from, len + 1, to, 1)) } end #HD#: seekf.r 350 Nov-06-1984 08:48:48 # seekf --- position a file to a designated word integer function seekf (pos, fd, xra) filemark pos filedes fd integer xra include SWT_COMMON filedes f filedes mapsu integer off, ra integer tseek$, dseek$ logical missin f = mapsu (fd) off = fd_offset (f) if (f < 1 || f > NFILES || and (Fd_flags (off), FD_ERR) ~= 0 || Fd_flags (off) == 0) return (ERR) if (missin (xra)) ra = ABS else ra = xra call flush$ (f) Fd_flags (off) &= not (FD_EOF) select (Fd_dev (off)) when (DEV_TTY) return (tseek$ (pos, off, ra)) when (DEV_DSK) return (dseek$ (pos, off, ra)) when (DEV_NULL) return (EOF) return (ERR) end #HD#: seterr.r 74 Nov-06-1984 08:48:48 # seterr --- set the error return code subroutine seterr (stat) integer stat include SWT_COMMON Cmd_stat = stat return end #HD#: sfdata.r 2619 Nov-06-1984 08:48:48 # sfdata --- set file information integer function sfdata (key, xpath, infobuf, attach_sw, auxil) integer key, attach_sw character xpath (ARB) integer infobuf (ARB), auxil (ARB) integer getto, parsa$, index, equal, expand include SWT_COMMON include ACL_COMMON integer sarr (2) integer name (16), pathname (MAXPATH) integer junk (MAXTREE), junk2 (MAXTREE), vtree (129), ppwd (3) integer i, j, isacat long_int qbuf (8) procedure do_getto forward procedure do_protect forward procedure find_isacat forward procedure make_tree forward attach_sw = NO Errcod = 0 if (expand (xpath, pathname, MAXPATH) == ERR) return (ERR) select (key) when (FILE_UFDQUOTA) { make_tree call q$set (KSMAX, vtree, infobuf, Errcod) if (Errcod == EQEXC) Errcod = 0 } when (FILE_TYPE) return (ERR) # Cannot change a file type! when (FILE_DMBITS) { do_getto call satr$$ (KDMPB, name, 32, sarr, Errcod) } when (FILE_RWLOCK) { do_getto sarr (2) = 0 if (equal (infobuf, "n-1"s) == YES) sarr (1) = 1 elif (equal (infobuf, "sys"s) == YES) sarr (1) = 0 elif (equal (infobuf, "n+1"s) == YES) sarr (1) = 2 elif (equal (infobuf, "n+n"s) == YES) sarr (1) = 3 else return (ERR) call satr$$ (KRWLK, name, 32, sarr, Errcod) } when (FILE_TIMMOD) { do_getto sarr (1) = ls (mod (infobuf (1), 100), 9) sarr (1) |= ls (and (infobuf (2), 2r1111), 5) sarr (1) |= and (infobuf (3), 2r11111) sarr (2) = (infobuf (4)*60 + infobuf (5))*15 + infobuf (6)/4 call satr$$ (KDTIM, name, 32, sarr, Errcod) } when (FILE_ACL) { j = 1 find_isacat make_tree if (infobuf (1) == EOS && auxil (1) == EOS) { if (isacat == NO) call ac$dft (vtree, Errcod) else call cat$dl (vtree, Errcod) } elif (infobuf (1) == EOS) { j = 2 find_isacat if (isacat == NO) { call expand (auxil, junk2, MAXTREE) call mktr$ (junk2, junk) if (index (junk, ">"c) == 0) return (ERR) i = 1 call ctov (junk, i, junk2, MAXTREE) call ac$lik (vtree, junk2, Errcod) } else { i = 1 call ctov (auxil, i, junk2, MAXTREE) call ac$cat (vtree, junk2, Errcod) } } elif (auxil (1) == EOS) { if (gtacl$ (pathname, 1, attach_sw) == ERR) return (ERR) elif (parsa$ (infobuf) == ERR) return (ERR) else { call mkpacl if (index (junk, ">"c) == 0) do_getto call ac$set (KANY, vtree, loc (Primos_acl), Errcod) } } else { call expand (auxil, junk2, MAXTREE) if (gtacl$ (junk2, 1, attach_sw) == ERR) return (ERR) elif (parsa$ (infobuf) == ERR) return (ERR) else { call mkpacl if (index (junk, ">"c) == 0) do_getto call ac$set (KANY, vtree, loc (Primos_acl), Errcod) } } } when (FILE_ACCESS) return (ERR) # not defined -- can only set ACL when (FILE_PRIORITYACL) { i = 1 call ctov (infobuf, i, vtree, 129) if (auxil (1) == EOS) call pa$del (vtree, Errcod) else { call gtacl$ (EOS, 1, i) if (parsa$ (auxil) == ERR) return (ERR) else { call mkpacl call pa$set (vtree, loc (Primos_acl), Errcod) } } } when (FILE_DELSWITCH) { do_getto if (infobuf (1) == YES) sarr (1) = 1 else sarr (1) = 0 call satr$$ (KSDL, name, 32, sarr, Errcod) } when (FILE_SIZE) return (ERR) # like, fer sure when (FILE_FULL_INFO) return (ERR) # not defined when (FILE_PROTECTION) { do_getto do_protect } when (FILE_PASSWORDS) { attach_sw = YES if (follow (pathname, 0) == ERR) return (ERR) i = 1 call ctop (infobuf, i, junk, 3) i = 1 call ctop (auxil, i, junk2, 3) call spas$$ (junk, junk2, Errcod) } ifany { if (attach_sw == YES) call at$hom(i) if (Errcod ~= 0) return (ERR) else return (OK) } else return (ERR) # bad key procedure do_getto { if (getto (pathname, name, ppwd, attach_sw) == ERR) return (ERR) } procedure do_protect { local owner_bits, non_owner_bits, owner, prot integer owner_bits (4), non_owner_bits (4), owner, prot (2) string permissions "twra" data owner_bits / :2000, :1000, :400, :3400 / data non_owner_bits / :4, :2, :1, :7 / prot (1) = 0 # default --- no permissions for owner or nonowner prot (2) = 0 owner = YES for (i = 1; infobuf (i) ~= EOS; i += 1) if (infobuf (i) == '/'c) owner = NO else { j = index (permissions, infobuf (i)) if (j < 1) # illegal protection key return (ERR) if (owner == YES) prot (1) |= owner_bits (j) else prot (1) |= non_owner_bits (j) } call satr$$ (KPROT, name, 32, prot, Errcod) } procedure find_isacat { local buffer, suffix, meow character buffer (MAXPATH), suffix (7) integer meow if (j == 1) call ctoc (pathname, buffer, MAXPATH) else call ctoc (auxil, buffer, MAXPATH) for (meow = 1; buffer (meow) ~= EOS; meow += 1) continue if (meow < 7) isacat = NO else { meow -= 5 call ctoc (buffer (meow), suffix, 7) call mapstr (suffix, LOWER) isacat = equal (".acat"s, suffix) } } procedure make_tree { local i integer i call mktr$ (pathname, junk) i = 1 call ctov (junk, i, vtree, 129) if (index (junk, ">"c) == 0) do_getto } end #HD#: sprot$.r 538 Nov-06-1984 08:48:49 # sprot$ --- set protection attributes for a file integer function sprot$ (name, attr) character name (ARB), attr (ARB) include SWT_COMMON string permissions "twra" integer owner_bits (4), non_owner_bits (4) # 4 = length (permissions) integer i, j, owner, packed_name (16), code, prot (2), junk (3) integer attach, index, getto data owner_bits / :2000, :1000, :400, :3400 / data non_owner_bits / :4, :2, :1, :7 / prot (1) = 0 # default --- no permissions for owner or nonowner prot (2) = 0 sprot$ = ERR # guilty before trial owner = YES for (i = 1; attr (i) ~= EOS; i += 1) if (attr (i) == '/'c) owner = NO else { j = index (permissions, attr (i)) if (j < 1) # illegal protection key return if (owner == YES) prot (1) |= owner_bits (j) else prot (1) |= non_owner_bits (j) } if (getto (name, packed_name, junk, attach) == ERR) return call satr$$ (KPROT, packed_name, 32, prot, Errcod) if (attach ~= NO) call at$hom (code) if (Errcod == 0) sprot$ = OK return end #HD#: st$lu.r 311 Nov-06-1984 08:48:49 # st$lu --- symbol table lookup primitive integer function st$lu (symbol, node, pred, st) character symbol (ARB) pointer node, pred, st integer Mem (1) common /ds$mem/ Mem integer hash, i, nodesize integer equal nodesize = Mem (st) hash = 0 for (i = 1; symbol (i) ~= EOS; i += 1) hash += symbol (i) hash = mod (iabs (hash), ST_HTABSIZE) + 1 pred = st + hash node = Mem (pred) while (node ~= LAMBDA) { if (equal (symbol, Mem (node + ST_DATA + nodesize)) == YES) { st$lu = YES return } pred = node node = Mem (pred + ST_LINK) } st$lu = NO return end #HD#: stake.r 189 Nov-06-1984 08:48:50 # stake --- take characters from a string APL-style integer function stake (from, to, chars) character from (ARB), to (ARB) integer chars integer len integer length, ctoc, scopy len = length (from) if (chars < 0) { len += chars if (len < 0) len = 0 return (scopy (from, len + 1, to, 1)) } else return (ctoc (from, to, chars + 1)) end #HD#: stclos.r 312 Nov-06-1984 08:48:50 # stclos --- insert closure entry at pat (j) integer function stclos (pat, j, lastj, lastcl) character pat (MAXPAT) integer j, lastj, lastcl integer addset integer jp, jt, junk for (jp = j - 1; jp >= lastj; jp -= 1) { # make a hole jt = jp + PAT_CLOSIZE junk = addset (pat (jp), pat, jt, MAXPAT) } j += PAT_CLOSIZE stclos = lastj junk = addset (PAT_CLOSURE, pat, lastj, MAXPAT) # put closure in it junk = addset (0, pat, lastj, MAXPAT) # PAT_COUNT junk = addset (lastcl, pat, lastj, MAXPAT) # PAT_PREVCL junk = addset (0, pat, lastj, MAXPAT) # PAT_START return end #HD#: strbsr.r 251 Nov-06-1984 08:48:50 # strbsr --- perform a binary search of a string table integer function strbsr (pos, tab, offs, object) integer pos (ARB), offs character tab (ARB), object (ARB) integer i, j, k integer strcmp i = 2 j = pos (1) + 1 # length is first entry in position array repeat { k = (i + j) / 2 select (strcmp (tab (pos (k) + offs), object)) when (1) i = k + 1 # LESS when (2) return (k) # EQUALS when (3) j = k - 1 # GREATER } until (i > j) return (EOF) end #HD#: strcmp.r 211 Nov-06-1984 08:48:51 # strcmp --- compare two strings and return 1 2 or 3 for < = or > integer function strcmp (str1, str2) character str1 (ARB), str2 (ARB) integer i for (i = 1; str1 (i) == str2 (i); i += 1) if (str1 (i) == EOS) return (2) select when (str1 (i) == EOS || str1 (i) < str2 (i)) return (1) when (str2 (i) == EOS || str1 (i) > str2 (i)) return (3) return (2) # should never happen end #HD#: strim.r 141 Nov-06-1984 08:48:51 # strim --- trim trailing blanks and tabs from a string integer function strim (str) character str (ARB) integer lnb, i lnb = 0 for (i = 1; str (i) ~= EOS; i += 1) if (str (i) ~= ' 'c && str (i) ~= TAB) lnb = i str (lnb + 1) = EOS return (lnb) end #HD#: strlsr.r 195 Nov-06-1984 08:48:51 # strlsr --- perform a linear search of a string table integer function strlsr (pos, tab, offs, object) integer pos (ARB), offs character tab (ARB), object (ARB) integer i, j integer strcmp j = pos (1) + 1 # length is first entry in position array for (i = 2; i <= j; i += 1) if (strcmp (object, tab (pos (i) + offs)) == 2) return (i) return (EOF) end #HD#: substr.r 256 Nov-06-1984 08:48:51 # substr --- slice a substring from a string integer function substr (from, to, first, chars) character from (ARB), to (ARB) integer first, chars integer len, i, j, k integer length len = length (from) i = first if (i < 1) i += len + 1 if (chars < 0) { i += chars + 1 chars = - chars } j = i + chars - 1 if (i < 1) i = 1 if (j > len) j = len for (k = 0; i <= j; {k += 1; i += 1}) to (k + 1) = from (i) to (k + 1) = EOS return (k) end #HD#: swt.r 60 Nov-06-1984 08:48:51 # swt --- return to the Subsystem command interpreter subroutine swt call rtn$$ # never returns here end #HD#: sys$$.s 1389 Nov-06-1984 08:48:51 * sys$$ --- pass a command string to PRIMOS for execution SUBR SYS$$ SEG RLIT include "=syscom=/errd.ins.pma" include "=incl=/swt_def.s.i" include "=incl=/lib_def.s.i" include "=incl=/swt_com.s.i" LINK SYS$$ ECB SYS0,,CMD,2,189 DATA 5,C'SYS$$' PROC DYNM =38,CMD(3),FD(3) DYNM I,STATUS,F,TEMP,OLD_CU,CODE,DESCR(4),ARGS(6) DYNM COMMAND(128) EXT MKONU$ SYS0 ARGT ENTR SYS$$ LT i = 1 STA I CALL CTOV call ctov (cmd, i, command, 128) AP CMD,*S AP I,S AP COMMAND,S AP =128,SL CRA status = 0 STA STATUS LDA COMUNIT old_cu = Comunit STA OLD_CU CALL BREAK$ Disable breaks AP =DISABLE,SL LDA FD,* if (fd == ERR) # Don't change comi$$ ERA =ERR goto l2 BEQ L2 CALL MAPFD f = mapfd (fd) AP FD,*SL BLE L1 if (f <= 0) STA F goto l1 CALL MAPSU call flush$ (mapsu (fd)) AP FD,*SL STA TEMP CALL FLUSH$ AP TEMP,SL LDA F Comunit = f STA COMUNIT call comi$$ ("CONTIN", 6, f, code) CALL COMI$$ AP =C'CONTIN',S AP =6,S AP F,S AP CODE,SL JMP L2 goto l2 L1 CRA Comunit = 0 LDA COMUNIT call comi$$ ("PAUSE", 5, 0, code) CALL COMI$$ AP =C'PAUSE',S AP =5,S AP =0,S AP CODE,SL L2 EAL CLEANUP_ call mkonu$ to set up CLEANUP$ unit STL DESCR EAL SB% STL DESCR+2 EAL CLEANUP$ STL ARGS EAL DESCR STL ARGS+3 EAL ARGS JSXB MKONU$ CALL BREAK$ OK to reenable breaks now AP =ENABLE,SL CALL CP$ Pass command line to PRIMOS AP COMMAND,S AP I,S AP STATUS,SL LDA OLD_CU Comunit = old_cu STA COMUNIT BEQ L3 If (Comunit == 0) * goto l3 CALL COMI$$ call comi$$ ("CONTIN", 6, old_cu, code) AP =C'CONTIN',S AP =6,S AP OLD_CU,S AP CODE,SL JMP L4 goto l4 L3 CALL COMI$$ call comi$$ ("PAUSE", 5, 0, code) AP =C'PAUSE',S AP =5,S AP =0,S AP CODE,SL L4 LDA I if (i == 0) BEQ L5 goto l5 ERA =E$NCOM if (i == E$NCOM) BNE L6 goto l6 L5 LDA STATUS if (status > 0) BGT L6 goto l6 LDA =OK return (OK) PRTN L6 LDA =ERR return (ERR) PRTN CLEANUP$ DATA 8,C'CLEANUP$' EJCT * cleanup_ --- CLEANUP$ handler for sys$$ LINK CLEANUP_ ECB CLEANUP0,,CP,1,14 PROC DYNM =10,CP(3) DYNM RC CLEANUP0 ARGT STLR PB%+15 Save static link in XB LDA OLD_CU-SB%+XB% Comunit = old_cu STA COMUNIT if (Comunit == 0) BEQ L10 goto l10 CALL COMI$$ call comi$$ ("CONTIN", 6, Comunit, rc) AP =C'CONTIN',S AP =6,S AP COMUNIT,S AP RC,SL PRTN return L10 CALL COMI$$ call comi$$ ("PAUSE", 5, 0, rc) AP =C'PAUSE',S AP =5,S AP =0,S AP RC,SL PRTN return END #HD#: szfil$.r 252 Nov-06-1984 08:48:52 # szfil$ --- find number of records in a file longint function szfil$ (fd) integer fd include LIBRARY_DEFS include SWT_COMMON include PRIMOS_KEYS integer junk longint size define (BIGVALUE, :17777777) repeat call prwf$$ (KPOSN + KPRER, fd, loc (0), 0, BIG_VALUE, junk, Errcod) until (Errcod ~= 0) if (Errcod ~= EEOF) # encountered some error besides EOF return (ERR) call prwf$$ (KRPOS, fd, loc (0), 0, size, junk, Errcod) return (size) end #HD#: szseg$.r 541 Nov-06-1984 08:48:52 # szseg$ --- find number of records in a segment directory subroutine szseg$ (size, fd) longint size integer fd include LIBRARY_DEFS include SWT_COMMON include PRIMOS_KEYS integer entry_a, entry_b, nfd, ntype longint temp longint szfil$ size = ERR call sgdr$$ (KGOND, fd, entry_a, entry_b, Errcod) call sgdr$$ (KSPOS, fd, 0, entry_a, Errcod) if (Errcod ~= 0) return if (entry_b == 0) size = 1 else size = entry_b ### now size the contents of the segment directory: entry_b = -1 repeat { entry_a = entry_b + 1 call sgdr$$ (KFULL, fd, entry_a, entry_b, Errcod) if (entry_b == -1 || Errcod ~= 0) break call srch$$ (KREAD + KGETU + KISEG, fd, 0, nfd, ntype, Errcod) if (Errcod ~= 0) { size = ERR return } select (ntype) when (0, 1) # SAM or DAM file temp = szfil$ (nfd) when (2, 3) # SAM or DAM segment directory call szseg$ (temp, nfd) if (temp == ERR) { size = ERR return } else size += temp call srch$$ (KCLOS, 0, 0, nfd, 0, Errcod) } return end #HD#: t$clup.r 295 Nov-06-1984 08:48:53 # t$clup --- profiling routine called on program exit subroutine t$clup integer numrtn, sp longint record (4, 1), stack (4, 1) common /t$prof/ numrtn, record common /t$stak/ sp, stack integer i, code, fd integer create string profile "_profile" while (sp > 1) call t$exit # clean up in case exit was not from main call at$hom (code) # attach to home directory fd = create (profile, WRITE) if (fd == ERR) call cant (profile) for (i = 1; i <= numrtn; i += 1) call writef (record (1, i), 8, fd) call close (fd) return end #HD#: t$entr.r 419 Nov-06-1984 08:48:53 # t$entr --- profiling routine called on subprogram entry subroutine t$entr (routine) integer routine integer numrtn, sp longint stack (4, 1), record (4, 1) common /t$prof/ numrtn, record common /t$stak/ sp, stack integer i, j longint cpu, diskio, reel if (routine == 1) { # initializing; entering main program for (i = 1; i <= numrtn; i += 1) for (j = 1; j <= 4; j += 1) record (j, i) = 0 sp = 1 } if (sp > numrtn) { call tnou ('Stack overflow in profiler (t$entr)', 35) call swt } call t$time (reel, cpu, diskio) stack (1, sp) = routine # routine number stack (2, sp) = reel # real time clock stack (3, sp) = cpu # CPU time accumulator stack (4, sp) = diskio # diskio time accumulator record (1, routine) += 1 # number of calls sp += 1 return end #HD#: t$exit.r 316 Nov-06-1984 08:48:53 # t$exit --- profiling routine called on subprogram exit subroutine t$exit integer numrtn, sp longint stack (4, 1), record (4, 1) common /t$prof/ numrtn, record common /t$stak/ sp, stack longint reel, cpu, diskio integer routine, i call t$time (reel, cpu, diskio) sp -= 1 reel -= stack (2, sp) cpu -= stack (3, sp) diskio -= stack (4, sp) routine = stack (1, sp) record (2, routine) += reel record (3, routine) += cpu record (4, routine) += diskio for (i = sp - 1; i >= 1; i -= 1) { stack (2, i) += reel stack (3, i) += cpu stack (4, i) += diskio } return end #HD#: t$time.r 222 Nov-06-1984 08:48:53 # t$time --- profiling routine called to obtain current clock readings subroutine t$time (reel, cpu, diskio) longint reel, cpu, diskio integer time (28) call timdat (time, 28) # get various times from system reel = intl (time (4)) * 60 * time (11) + _ intl (time (5)) * time (11) + _ time (6) cpu = intl (time (7)) * time (11) + _ time (8) diskio = intl (time (9)) * time (11) + _ time (10) return end #HD#: t$trac.r 321 Nov-06-1984 08:48:53 # t$trac --- trace subroutine for Ratfor programs subroutine t$trac (mode, name) integer mode character name integer level, i data level / 0 / select (mode) when (1) { for (i = 1; i <= level & level <= 40; i += 1) { call putch ('|'c, ERROUT) call putch (' 'c, ERROUT) call putch (' 'c, ERROUT) } call print (ERROUT, "*p {*n"p, name) level += 1 } when (2) { level -= 1 for (i = 1; i <= level & level <= 40; i += 1) { call putch ('|'c, ERROUT) call putch (' 'c, ERROUT) call putch (' 'c, ERROUT) } call print (ERROUT, "..}*n"p) } when (3) { level = 0 } return end #HD#: tcook$.r 2593 Nov-06-1984 08:48:54 # tcook$ --- read and cook a line from the terminal define(AFLAG,16r100) define(EFLAG,16r200) integer function tcook$ (ubuf, size, tbuf, tptr) character ubuf (ARB), tbuf (MAXTERMBUF) integer size, tptr include SWT_COMMON integer duplx$ character c, t integer uptr procedure fill_term_buf forward procedure get_char forward procedure get_escape forward procedure put_kill_resp forward procedure erase_char forward procedure display_line forward procedure put_char forward for (uptr = 1; uptr < size; {uptr += 1; tptr += 1}) { if (tbuf (tptr) == EOS) fill_term_buf ubuf (uptr) = tbuf (tptr) if (ubuf (uptr) == NEWLINE || ubuf (uptr) == EOS) { if (ubuf (uptr) == NEWLINE) { uptr += 1 tptr += 1 } break } } ubuf (uptr) = EOS for (uptr = 1; ubuf (uptr) ~= EOS; uptr += 1) { if (and (ubuf (uptr), EFLAG) ~= 0) ubuf (uptr) -= EFLAG if (Termattr (TA_UPPER_ONLY) == YES) if (and (ubuf (uptr), AFLAG) ~= 0) { ubuf (uptr) -= AFLAG c = or (ubuf (uptr), 16r80) select when (c == "("c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("{"c, 16r7f)) when (c == ")"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("}"c, 16r7f)) when (c == "!"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("|"c, 16r7f)) when (c == "_"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("~"c, 16r7f)) when (c == "'"c) ubuf (uptr) = or (and (ubuf (uptr), 16r80), and ("`"c, 16r7f)) } else { c = or (ubuf (uptr), 16r80) select when (c >= "a"c && c <= "z"c) ubuf (uptr) = ubuf (uptr) - "a"c + "A"c when (c >= "A"c && c <= "Z"c) ubuf (uptr) = ubuf (uptr) - "A"c + "a"c } } return (uptr - 1) # fill_term_buf --- fill the terminal buffer with cooked input procedure fill_term_buf { local i; integer i tptr = 1 tbuf (tptr) = EOS for (i = 1; i < MAXTERMBUF; i += 1) { get_char if (and (c, AFLAG) ~= 0) t = c - AFLAG else t = c select when (t == Escchar) { get_escape tbuf (i) = c } when (t == Kchar) { put_kill_resp uptr = 1 i = 0 } when (t == Echar) { if (t ~= c) call t1ou (Echar) if (i > 1) { i -= 1 t = tbuf (i) } else if (uptr > 1) { uptr -= 1 t = ubuf (uptr) } else t = 0 erase_char i -= 1 } when (t == Rtchar) { put_kill_resp display_line i -= 1 } when (t == Eofchar) { if (i > 1 || uptr > 1) put_kill_resp uptr = 1 i = 1 tbuf (i) = EOS break } when (t == Nlchar) { if (t ~= NEWLINE) call tonl tbuf (i) = NEWLINE tbuf (i + 1) = EOS break } else tbuf (i) = c tbuf (i + 1) = EOS } } # get_char --- read a character and convert case if necessary procedure get_char { call c1in (c) if (Termattr (TA_UPPER_ONLY) == YES && c == "@"c) { call c1in (c) if (c == Escchar) get_escape c += AFLAG } } # get_escape --- interpret and convert escape sequences procedure get_escape { local duplx; integer duplx duplx = duplx$ (-1) call duplx$ (or (duplx, -8r40000)) if (Escchar < " "c || Escchar > "~"c) call t1ou (NUL) else call t1ou (BS) call t1ou ("^"c) call c1in (c) select when ('0'c <= c && c <= '7'c) { t = ls (c - "0"c, 6) call c1in (c) t += ls (c - "0"c, 3) call c1in (c) c = t + c - "0"c } when (c == "/"c) { call t1ou (c) call c1in (c) c &= 16r7f } c += EFLAG put_char call duplx$ (duplx) } # put_kill_resp --- display the user's personal kill response procedure put_kill_resp { local i; integer i for (i = 1; Kill_resp (i) ~= EOS; i += 1) call t1ou (Kill_resp (i)) } # erase_char --- backspace over one character procedure erase_char { if (and (t, AFLAG) ~= 0) { call t1ou (Echar) t -= AFLAG } if (and (t, EFLAG) ~= 0) { t -= EFLAG if (t < 16r80) { call t1ou (Echar) t += 16r80 } if (t >= NUL && t <= US || t == DEL) call t1ou (Echar) call t1ou (Echar) } } # display_line --- display current terminal buffer procedure display_line { local p; integer p for (p = 1; p < uptr; p += 1) { c = ubuf (p) if (and (c, AFLAG) ~= 0) { call t1ou ("@"c) c -= AFLAG } if (and (c, EFLAG) ~= 0) { call t1ou ("^"c) if (c - EFLAG < 16r80) call t1ou ("/"c) } put_char } for (p = 1; tbuf (p) ~= EOS; p += 1) { c = tbuf (p) if (and (c, AFLAG) ~= 0) { call t1ou ("@"c) c -= AFLAG } if (and (c, EFLAG) ~= 0) { call t1ou ("^"c) if (c - EFLAG < 16r80) call t1ou ("/"c) } put_char } } # put_char --- display a single character procedure put_char { t = c if (and (t, EFLAG) ~= 0) { t -= EFLAG if (t < 16r80) t += 16r80 if (t >= NUL && t <= US || t == DEL) { call t1ou ("="c) if (t ~= DEL) call t1ou (t - NUL + "@"c) else call t1ou ("#"c) } else call t1ou (t) } else call t1ou (t) } end #HD#: tgetl$.r 117 Nov-06-1984 08:48:54 # tgetl$ --- return cooked data from the terminal integer function tgetl$ (buf, size, f) character buf (ARB) integer size, f include SWT_COMMON integer tcook$ return (tcook$ (buf, size, Termbuf, Termcp)) end #HD#: tmark$.r 63 Nov-06-1984 08:48:54 # tmark$ --- return the position of a terminal file (??) filemark function tmark$ (f) filedes f return (0) end #HD#: tputl$.r 890 Nov-06-1984 08:48:54 # tputl$ --- write one line to a cooked tty file integer function tputl$ (line, f) character line (ARB) integer f include SWT_COMMON integer i, bp, buf (MAXLINE) character c procedure putchar (ch) forward procedure outbuf forward bp = 0 for (i = 1; line (i) ~= EOS; i += 1) { c = or (16r80, line (i)) # get the character select (c) when (SET_OF_UPPER_CASE) { if (Term_attr (TA_UPPER_ONLY) == YES) putchar (ESCAPE) putchar (c) } when (SET_OF_LOWER_CASE) { if (Term_attr (TA_UPPER_ONLY) == YES) putchar (c - 'a'c + 'A'c) else putchar (c) } when (ESCAPE) { if (Term_attr (TA_UPPER_ONLY) == YES) putchar (ESCAPE) putchar (ESCAPE) } when ('{'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ('('c) } else putchar ('{'c) when ('}'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar (')'c) } else putchar ('}'c) when ('|'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ('!'c) } else putchar ('|'c) when ('`'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ("'"c) } else putchar ('`'c) when ('~'c) if (Term_attr (TA_UPPER_ONLY) == YES) { putchar (ESCAPE) putchar ('_'c) } else putchar ('~'c) when (NEWLINE) { putchar (CR) putchar (LF) } else putchar (c) } outbuf return (i - 1) # outbuf --- put the buffer out to the terminal procedure outbuf { if (bp > 0) call tnoua (buf, bp) bp = 0 } # putchar --- put a character in the buffer procedure putchar (ch) { integer ch if (bp >= MAXLINE * 2) outbuf spchar (buf, bp, ch) } end #HD#: tquit$.r 130 Nov-06-1984 08:48:55 # tquit$ --- routine to interrogate break flag and dump buffer logical function tquit$ (flag) logical flag integer code call quit$ (flag) if (flag) { call tty$rs (:140000, code) call t1ou (NEWLINE) } tquit$ = flag return end #HD#: tread$.r 157 Nov-06-1984 08:48:55 # tread$ --- read raw words from terminal integer function tread$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer i for (i = 0; i < nw; i += 1) { call c1in (buf (i + 1)) if (buf (i + 1) == NEWLINE || buf (i + 1) == ETX) { i += 1 break } } return (i) end #HD#: trunc.r 296 Nov-06-1984 08:48:55 # trunc --- truncate a file integer function trunc (fd) filedes fd include SWT_COMMON filedes f filedes mapsu integer off f = mapsu (fd) if (f < 1 || f > NFILES) return (ERR) off = fd_offset (f) if (and (Fd_flags (off), FD_WRITE) == 0 || and (Fd_flags (off), FD_ERR) ~= 0) return (ERR) call flush$ (f) select (Fd_dev (off)) when (DEV_TTY) return (OK) when (DEV_DSK) { call prwf$$ (KTRNC, Fd_unit (off), loc (0), 0, intl (0), 0, Errcod) if (Errcod == 0) return (OK) } when (DEV_NULL) return (OK) return (ERR) end #HD#: tscan$.r 2359 Nov-06-1984 08:48:55 # tscan$ --- traverse tree in the file system integer function tscan$ (path, buf, clev, nlev, action) integer buf (MAXDIRENTRY), clev, nlev, action character path (MAXPATH) include SWT_COMMON integer type, code, i, l, pwd (3), opwd (3), npwd (3) integer follow, ctoc, expand, equal, upkfn$ procedure check_postorder forward procedure reattach forward procedure enter_pwd forward procedure enter_info forward procedure fix_path forward Ts_at = NO # no reattach done on this call, yet if (clev == 0) { # first call, initialize everything ### Set up the state vectors if (expand ("=GaTech="s, Ts_path, MAXPATH) == ERR || equal (Ts_path, "yes"s) == NO) Ts_gt = NO else Ts_gt = YES clev = 1 Ts_ps (clev) = ctoc (path, Ts_path, MAXPATH) + 1 if (and (action, REATTACH) ~= 0) reattach ### Open the current directory for reading call srch$$ (KREAD + KGETU, KCURR, 0, Ts_un (clev), type, code) if (code ~= 0) { clev = 0 return (EOF) } call dir$rd (KINIT, Ts_un (clev), loc (buf), MAXDIRENTRY, code) Ts_state = GET_NEXT_ENTRY } repeat { select (Ts_state) when (DESCEND) { # descend to next level if (and (action, REATTACH) ~= 0 && (Ts_at == NO)) reattach if (clev >= nlev) { # are we at the limit? Ts_state = GET_NEXT_ENTRY check_postorder next } ### Attach to the new directory enter_pwd call at$swt (Ts_bf (2, clev), 32, 0, pwd, KICUR, code) if (code ~= 0) { Ts_state = COULDNT_DESCEND return (ERR) } clev += 1 ### Open it for reading call srch$$ (KREAD + KGETU, KCURR, 0, Ts_un (clev), type, code) if (code ~= 0) { Ts_state = ASCEND return (ERR) } Ts_state = GET_NEXT_ENTRY } when (COULDNT_DESCEND) { # couldn't descend into last dir if (Ts_at == NO) reattach Ts_state = GET_NEXT_ENTRY check_postorder } when (GET_NEXT_ENTRY) { # get next entry from this level if (and (action, REATTACH) ~= 0 && (Ts_at == NO)) reattach path (Ts_ps (clev)) = EOS call dir$rd (KREAD, Ts_un (clev), loc (buf), MAXDIRENTRY, code) if (code ~= 0) Ts_state = ATEOD elif (rs(buf(1),8) == 2 || rs(buf(1),8) == 3) { buf (1) = 0 # indicate preorder encounter fix_path if (and (buf (20), 8r10007) == 4) { # a ufd but not mfd enter_info # next time we're called, we will Ts_state = DESCEND # descend another level } if ( ~(and (buf (20), 7) == 4) # file type is NOT ufd || and (action, PREORDER) ~= 0) return (OK) } # else stay in this state } when (ATEOD) { # at end of directory if (and (action, REATTACH) ~= 0 && (Ts_at == NO)) reattach call srch$$ (KCLOS, 0, 0, Ts_un (clev), 0, code) Ts_state = ASCEND if (and (action, EODPAUSE) ~= 0) return (EOD) } when (ASCEND) { # pop up one level clev -= 1 if (clev <= 0) break reattach Ts_state = GET_NEXT_ENTRY check_postorder } else call error ("in tscan$: can't happen"s) } return (EOF) # check_postorder --- return entry on postorder encounter if desired procedure check_postorder { if (and (action, POSTORDER) ~= 0) { call move$ (Ts_bf (1, clev), buf, MAXDIRENTRY) buf (1) = 1 # indicate postorder encounter return (OK) } } # enter_pwd --- get password for next lower directory procedure enter_pwd { local valid_name; bool valid_name local junk; integer junk call gpas$$ (Ts_bf (2, clev), 32, opwd, npwd, code) call texto$ (opwd, 6, junk, valid_name) if (code == ENRIT) { pwd (1) = " " pwd (2) = " " pwd (3) = " " } elif (Ts_gt == YES && valid_name) { pwd (1) = npwd (1) pwd (2) = npwd (2) pwd (3) = npwd (3) } else { pwd (1) = opwd (1) pwd (2) = opwd (2) pwd (3) = opwd (3) } do i = 1, 3 Ts_pw (i, clev) = pwd (i) l = Ts_eos if (pwd (1) ~= " " && pwd (1) ~= 0) { path (l) = ':'c l += 1 + upkfn$ (pwd, 6, path (l + 1), MAXPATH - l) } Ts_ps (clev + 1) = l } # fix_path --- add name of current entry to pathname procedure fix_path { l = Ts_ps (clev) if (l > 1) { path (l) = '/'c l += 1 } l += upkfn$ (buf (2), 32, path (l), MAXPATH - l + 1) Ts_eos = l } # enter_info --- save info in current directory entry procedure enter_info { call move$ (buf, Ts_bf (1, clev), MAXDIRENTRY) } # reattach --- attach back to the same place procedure reattach { Ts_at = YES call at$hom (code) if (follow (Ts_path, 0) == ERR) { Ts_state = ATEOD return (ERR) } for (i = 1; i < clev; i += 1) { call at$swt (Ts_bf (2, i), 32, 0, Ts_pw (1, i), KICUR, code) if (code ~= 0) { Ts_state = ATEOD return (ERR) } } } end #HD#: tseek$.r 163 Nov-06-1984 08:48:55 # tseek$ --- seek on a terminal device (??) integer function tseek$ (pos, f, ra) longint pos integer f, ra include SWT_COMMON integer i character junk if (ra == ABS || pos < 0) return (ERR) # can't do this for a terminal for (i = 1; i <= pos; i += 1) call c1in (junk) return (OK) end #HD#: ttyp$f.r 366 Nov-06-1984 08:48:56 # ttyp$f --- obtain the terminal type from the 'terms' file integer function ttyp$f (ttype) character ttype (ARB) integer fd, pid, i, j integer open, ctoi, getlin, ttyp$v character str (MAXLINE) fd = open ("=termlist="s, READ) if (fd == ERR) { ttype (1) = EOS return (NO) } call date (SYS_PID, pid) # get the user's numeric process id ttype (1) = EOS while (getlin (str, fd) ~= EOF) { i = 1 j = ctoi (str (6), i) if (j == pid) { i = 11 SKIPBL (str, i) for (j = 1; i <= 16 && str (i) ~= EOS && str (i) ~= ' 'c; {i += 1; j += 1}) ttype (j) = str (i) ttype (j) = EOS break } } call close (fd) if (ttype (1) == EOS) return (NO) return (ttyp$v (ttype)) end #HD#: ttyp$l.r 466 Nov-06-1984 08:48:56 # ttyp$l --- list the available terminal types subroutine ttyp$l integer i, col integer input, length character ttype (MAXLINE), desc (MAXLINE) file_des fd file_des open define (MAXDESC, 25) procedure put forward call print (TTY, "Terminal types:*n"s) fd = open ("=ttypes="s, READ) if (fd == ERR) return col = 1 while (input (fd, "*s*,,,s"s, ttype, desc) ~= EOF) { i = 1 SKIPBL (desc, i) put } if (col ~= 1) call print (TTY, "*n"s) call close (fd) return # put --- put a terminal type out procedure put { if (col == 1) { call print (TTY, " *8,,.s.*#s "s, ttype, MAXDESC, desc (i)) if (length (desc (i)) > MAXDESC) call print (TTY, "*n"s) else col = 2 } else { if (length (desc (i)) > MAXDESC) call print (TTY, "*n"s) call print (TTY, " *8,,.s.*s*n"s, ttype, desc (i)) col = 1 } } undefine (MAXDEST) end #HD#: ttyp$q.r 391 Nov-06-1984 08:48:56 # ttyp$q --- obtain the terminal type from the user integer function ttyp$q (ttype, blankok) character ttype (ARB) integer blankok include SWT_COMMON integer i integer equal, input, ttyp$v character str (MAXLINE) while (input (TTY, "Enter terminal type: *s"s, str) ~= EOF) { call mapstr (str, LOWER) if (str (1) == EOS && blankok == YES) { do i = 1, MAXTERMATTR Term_attr (i) = NO Term_type (1) = EOS ttype (1) = EOS return (YES) } else if (equal (str, "?"s) == YES || equal (str, "help"s) == YES) call ttyp$l else if (ttyp$v (str) == YES) { call ctoc (str, ttype, MAXTERMTYPE) return (YES) } else call print (TTY, "Invalid terminal type; enter '?' for help.*n"s) } call print (TTY, "*n"s) return (NO) end #HD#: ttyp$r.r 157 Nov-06-1984 08:48:56 # ttyp$r --- get the terminal type from the common area integer function ttyp$r (ttype) character ttype (ARB) include SWT_COMMON integer chkstr if (chkstr (Termtype, MAXTERMTYPE) == NO) { ttype (1) = EOS return (NO) } call ctoc (Termtype, ttype, MAXTERMTYPE) return (YES) end #HD#: ttyp$v.r 350 Nov-06-1984 08:48:56 # ttyp$v --- check and set terminal type and attributes integer function ttyp$v (ttype) character ttype (ARB) include SWT_COMMON integer i, a (MAXTERMATTR) integer input, equal, ctoc character str (MAXLINE), junk (MAXLINE) file_des fd file_des open fd = open ("=ttypes="s, READ) if (fd == ERR) return (NO) ttyp$v = NO while (input (fd, "*s*,,,s*y*y*y*y*y*y"s, str, junk, a(1), a(2), a(3), a(4), a(5), a(6)) ~= EOF) if (equal (str, ttype) == YES) { call break$ (DISABLE) do i = 1, MAXTERMATTR Term_attr (i) = a (i) call ctoc (ttype, Term_type, MAXTERMTYPE) ttyp$v = YES call break$ (ENABLE) break } call close (fd) return end #HD#: twrit$.r 115 Nov-06-1984 08:48:56 # twrit$ --- write raw words to terminal integer function twrit$ (buf, nw, f) integer buf (ARB), nw, f include SWT_COMMON integer i for (i = 0; i < nw; i += 1) call t1ou (buf (i + 1)) return (i) end #HD#: type.r 284 Nov-06-1984 08:48:57 # type --- returns type of character character function type(c) character c select (c) when ('a'c, 'b'c, 'c'c, 'd'c, 'e'c, 'f'c, 'g'c, 'h'c, 'i'c, 'j'c, 'k'c, 'l'c, 'm'c, 'n'c, 'o'c, 'p'c, 'q'c, 'r'c, 's'c, 't'c, 'u'c, 'v'c, 'w'c, 'x'c, 'y'c, 'z'c, 'A'c, 'B'c, 'C'c, 'D'c, 'E'c, 'F'c, 'G'c, 'H'c, 'I'c, 'J'c, 'K'c, 'L'c, 'M'c, 'N'c, 'O'c, 'P'c, 'Q'c, 'R'c, 'S'c, 'T'c, 'U'c, 'V'c, 'W'c, 'X'c, 'Y'c, 'Z'c) type = LETTER when ('0'c, '1'c, '2'c, '3'c, '4'c, '5'c, '6'c, '7'c, '8'c, '9'c) type = DIGIT else type = c return end #HD#: upkfn$.r 263 Nov-06-1984 08:48:57 # upkfn$ --- unpack a file name; escape slashes integer function upkfn$ (name, len, str, max) integer name (ARB), len, max character str (ARB) integer l, cp character c character mapdn for ({l = 1; cp = 0}; l < max && cp < len; l += 1) { fpchar (name, cp, c) if (c == ' 'c) break if (c == '/'c || c == ESCAPE || c == '='c) { if (c == '='c) str (l) = c else str (l) = ESCAPE l += 1 if (l >= max) break } str (l) = mapdn (c) } str (l) = EOS return (l - 1) end #HD#: vfyusr.r 500 Nov-06-1984 08:48:57 # vfyusr --- function to see if a username really exists integer function vfyusr (user) character user (ARB) character key (MAXUSERNAME), line (MAXLINE) integer len integer ctoc, getlin, length, strcmp filedes fd filedes open if (length (user) >= MAXUSERNAME) # too long... don't bother testing return (ERR) fd = open ("=userlist="s, READ) if (fd == ERR) { call remark ("in vfyusr: can't read user list"p) return (ERR) } for (len = ctoc (user, key, MAXUSERNAME) + 1; len < MAXUSERNAME; len += 1) key (len) = ' 'c # pad with blanks to maximum length key (MAXUSERNAME) = EOS call mapstr (key, UPPER) vfyusr = ERR # assume the worst while (getlin (line, fd) ~= EOF) { line (MAXUSERNAME) = EOS # truncate line after login name select (strcmp (line, key)) when (2) { # name just read equals key vfyusr = OK break } # when (3) # name just read is greater than key # break } call close (fd) return end #HD#: vt$alc.r 209 Nov-06-1984 08:48:57 # vt$alc --- allocate another DFA table integer function vt$alc (tbl, c) integer tbl character c include SWT_COMMON integer i, j for (i = 1; i <= MAXESCAPE && Fn_used (i) == YES; i += 1) ; if (i > MAXESCAPE) # Is there enough room ?? return (ERR) Fn_used (i) = YES do j = 1, CHARSETSIZE Fn_tab (j, i) = EOS Fn_tab (c, tbl) = i + GET_NEXT_TABLE tbl = i return (OK) end #HD#: vt$clr.r 141 Nov-06-1984 08:48:57 # vt$clr --- send clear screen sequence integer function vt$clr (dummy) integer dummy include SWT_COMMON if (Tc_clear_screen (1) == EOS) return (ERR) send_str (Tc_clear_screen) call vt$del(Tc_clear_delay) # delay loop of characters return (OK) end #HD#: vt$db.r 674 Nov-06-1984 08:48:58 # vt$db --- dump terminal characteristics subroutine vt$db include SWT_COMMON character str (MAXLINE) call print (ERROUT, "Maxrow=*i, Maxcol=*i*n"s, Maxrow, Maxcol) call vt$db1 ("clear_screen"s, Tc_clear_screen) call vt$db1 ("clear_to_eol"s, Tc_clear_to_eol) call vt$db1 ("clear_to_eos"s, Tc_clear_to_eos) call vt$db1 ("cursor_home"s, Tc_cursor_home) call vt$db1 ("cursor_left"s, Tc_cursor_left) call vt$db1 ("cursor_right"s, Tc_cursor_right) call vt$db1 ("cursor_up"s, Tc_cursor_up) call vt$db1 ("cursor_down"s, Tc_cursor_down) call vt$db1 ("abs_pos"s, Tc_abs_pos) call vt$db1 ("vert_pos"s, Tc_vert_pos) call vt$db1 ("hor_pos"s, Tc_hor_pos) call ctomn (Tc_coord_char, str) call print (ERROUT, "coord_char=*s*n"s, str) call print (ERROUT, "coord_type=*i*n"s, Tc_coord_type) call print (ERROUT, "seq_type=*i*n"s, Tc_seq_type) call print (ERROUT, "delay_time=*i*n"s, Tc_delay_time) call print (ERROUT, "wrap_around=*y*n"s, Tc_wrap_around) call print (ERROUT, "clr_len=*i*n"s, Tc_clr_len) call print (ERROUT, "ceos_len=*i*n"s, Tc_ceos_len) call print (ERROUT, "ceol_len=*i*n"s, Tc_ceol_len) call print (ERROUT, "abs_len=*i*n"s, Tc_abs_len) call print (ERROUT, "vert_len=*i*n"s, Tc_vert_len) call print (ERROUT, "hor_len=*i*n"s, Tc_hor_len) return end #HD#: vt$db1.r 185 Nov-06-1984 08:48:58 # vt$db1 --- print mnemonics for special character sequence subroutine vt$db1 (title, seq) character title (ARB), seq (ARB) integer i character str (MAXLINE) call print (ERROUT, "*s="s, title) for (i = 1; seq (i) ~= EOS; i += 1) { call ctomn (seq (i), str) call print (ERROUT, "*s "s, str) } call print (ERROUT, "EOS*n"s) return end #HD#: vt$db2.r 423 Nov-06-1984 08:48:58 # vt$db2 --- print the contents of the terminal input tables subroutine vt$db2 include SWT_COMMON integer i, j character str (MAXLINE) for (i = 1; i <= MAXESCAPE; i += 1) if (Fn_used (i) == YES) { call print (ERROUT, "------ Table *i ------*n"s, i) for (j = 1; j <= CHARSETSIZE; j += 1) { if (Fn_tab (j, i) < 0) call print (ERROUT, "*4i"s, Fn_tab (j, i)) else if (Fn_tab (j, i) >= GET_NEXT_TABLE) call print (ERROUT, "*3in"s, Fn_tab (j, i) - GET_NEXT_TABLE) else if (Fn_tab (j, i) >= DEFINITION) call print (ERROUT, "*3id"s, Fn_tab (j, i) - DEFINITION) else if (Fn_tab (j, i) >= 1000) call print (ERROUT, "*3ic"s, Fn_tab (j, i) - 1000) else { call ctomn (Fn_tab (j, i), str) call print (ERROUT, " *3s"s, str) } if (mod (j, 16) == 0) call print (ERROUT, "*n"s) } } return end #HD#: vt$db3.r 209 Nov-06-1984 08:48:58 # vt$db3 --- dump the definitions for debugging subroutine vt$db3 include SWT_COMMON integer i character str (4) call print (ERROUT, "---- Define Table ----*n"s) call print (ERROUT, "Last_def=*i*n"s, Last_def) for (i = 1; i <= Last_def; i += 1) { if (mod (i, 16) == 0) call print (ERROUT, "*n"s) call ctomn (Def_buf (i), str) call print (ERROUT, "*4s"s, str) } return end #HD#: vt$def.r 839 Nov-06-1984 08:48:58 # vt$def --- accept a macro definition from the user integer function vt$def (ch) character ch include SWT_COMMON integer sp, i, cl, tbl integer vt$alc, vt$gsq character delim, c character seq (MAXSEQ) if (Last_def >= MAXDEF) { call vt$err ("No room for definition"s) return (ERR) } call vtmsg ("DEFINE: Enter delimiter"s, CHAR_MSG) call vtupd (NO) call c1in (delim) sp = vt$gsq ("DEFINE: Enter sequence"s, delim, seq, MAXSEQ) if (sp == ERR) return (sp) tbl = 1 for (i = 1; i < sp; i += 1) { c = Fn_tab (seq (i) - CHARSETBASE, tbl) select when (c == EOS) # allocate a new table if (vt$alc (tbl, seq (i) - CHARSETBASE) == ERR) { call vt$err ("Too many sequences"s) return (ERR) } when (c < GET_NEXT_TABLE) {# It's a character or a control seq call vt$err ("Illegal sequence"s) return (ERR) } else tbl = c - GET_NEXT_TABLE } cl = seq (i) - CHARSETBASE c = Fn_tab (cl, tbl) select when (c == DEFINE, c == UNDEFINE) { call vt$err ("Don't try that!"s) return (ERR) } when (c < DEFINITION) # it's some other character ; when (c < GET_NEXT_TABLE) # it's a definition call vt$rdf (cl, tbl) else { # it's another DFA table call vt$err ("Illegal prefix"s) return (ERR) } Last_def += 1 Def_buf (Last_def) = Fn_tab (cl, tbl) # squirrel away the old def Fn_tab (cl, tbl) = Last_def + DEFINITION Last_def += 1 sp = vt$gsq ("DEFINE: Enter definition"s, delim, Def_buf (Last_def), MAXDEF - Last_def + 1) if (sp == ERR) return (ERR) Last_def += sp call vtmsg (EOS, CHAR_MSG) call vtupd (NO) return (OK) end #HD#: vt$del.r 131 Nov-06-1984 08:48:59 # vt$del --- delay with characters subroutine vt$del(count) integer count include SWT_COMMON integer i if (count <= 0) return i = (intl (count) * Tc_speed) / 10000 while (i >= 0) { send_char (NUL) i -= 1 } return end #HD#: vt$dsw.r 332 Nov-06-1984 08:48:59 # vt$dsw --- garbage collect the DFA subroutine vt$dsw include SWT_COMMON integer found, tbl, ent, i, ct ct = 0 repeat { found = NO do tbl = 1, MAXESCAPE if (Fn_used (tbl) == YES) { do ent = 1, CHARSETSIZE if (Fn_tab (ent, tbl) ~= EOS) next 2 found = YES break } if (found == NO) break Fn_used (tbl) = NO # return the table do i = 1, MAXESCAPE # remove all references to the table if (Fn_used (i) == YES) do ent = 1, CHARSETSIZE if (Fn_tab (ent, i) == GET_NEXT_TABLE + tbl) Fn_tab (ent, i) = EOS ct += 1 } DEBUG call vtprt (20, 1, "vt$dsw: *i tables returned"s, ct) return end #HD#: vt$err.r 120 Nov-06-1984 08:48:59 # vt$err --- display an error message and reset pushback pointer subroutine vt$err (msg) character msg (ARB) include SWT_COMMON call vtmsg (msg, CHAR_MSG) call vtupd (NO) Pb_ptr = 0 call t1ou (BEL) return end