Forgot your password?
Document Actions
LIB: Run-time library for the LITTLE system (compile time and run time).
LIB: Run-time library for the LITTLE system (compile time and run time).
1 .=member intro
2 $ !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
3 $ the above line contains, in order of ascii codes, the 56
4 $ characters of the little language, starting in column 7.
5 $
6 $ $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$
7 $ $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$
8 $ $$ $$ $$ $$ $$ $$
9 $ $$ $$ $$ $$ $$ $$
10 $ $$ $$ $$ $$ $$ $$$$$$
11 $ $$ $$ $$ $$ $$ $$$$$$
12 $ $$ $$ $$ $$ $$ $$
13 $ $$ $$ $$ $$ $$ $$
14 $ $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$
15 $ $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$
16 $
17 $ $$ $$$$$$$$$$ $$$$$$$$$$
18 $ $$ $$$$$$$$$$ $$$$$$$$$$
19 $ $$ $$ $$ $$
20 $ $$ $$ $$ $$
21 $ $$ $$ $$$$$$$$$
22 $ $$ $$ $$$$$$$$$
23 $ $$ $$ $$ $$
24 $ $$ $$ $$ $$
25 $ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$
26 $ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$
27
28
29
30 $ this software is part of the little programming system.
31 $ address queries and comments to
32 $
33 $ little project
34 $ department of computer science
35 $ new york university
36 $ courant institute of mathematical sciences
37 $ 251 mercer street
38 $ new york, ny 10012
39 $
40 $ this is the run-time library for the little system, and
41 $ is known as 'lib'.
42 $
43 $ the principal authors of the little compiler are
44 $ robert abes, edith deak, richard kenner, david shields
45 $ and aaron stein.
46 $
47 $
1 .=member chars
2 /* little character set and ascii representation
3
4 !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
5 the above line contains, in order of ascii codes, the 56
6 characters of the little language, starting in column 7.
7
8 the little language requires 56 distinct characters.
9 these include the 26 upper case letters, the 10 digits,
10 and the following special characters:
11
12 blank
13 = equal sign, assignment symbol
14 + plus
15 - minus
16 * times, asterisk
17 / divide, slash
18 ( left parenthesis
19 ) right parenthesis
20 , comma
21 . period, point
22 ; semicolon
23 : colon
24 $ dollar sign, comment character
25 ^ not
26 & and
27 ! or
28 < less than
29 > greater than
30 ' apostrophe, string delimiter
31 _ underline, break character
32
33 the following table gives the standard ascii encoding
34 for the little character set.
35
36 little character ascii ascii ascii ascii character
37 (hex) (oct) (dec)
38
39 space 20 40 32 space
40 ! or 21 41 33 exclamation mark
41 $ dollar sign 24 44 36 dollar sign
42 & and 26 46 38 ampersand
43 ' apostrophe 27 47 39 apostrophe
44 ( left parenthesis 28 50 40 left parenthesis
45 ) right parenthesis 29 51 41 right parenthesis
46 * asterisk 2a 52 42 asterisk
47 + plus 2b 53 43 plus
48 , comma 2c 54 44 comma
49 - minus 2d 55 45 minus
50 . period 2e 56 46 period
51 / slash 2f 57 47 slant
52 0 digit 0 30 60 48 digit 0
53 1 digit 1 31 61 49 digit 1
54 2 digit 2 32 62 50 digit 2
55 3 digit 3 33 63 51 digit 3
56 4 digit 4 34 64 52 digit 4
57 5 digit 5 35 65 53 digit 5
58 6 digit 6 36 66 54 digit 6
59 7 digit 7 37 67 55 digit 7
60 8 digit 8 38 70 56 digit 8
61 9 digit 9 39 71 57 digit 9
62 : colon 3a 72 58 colon
63 ; semicolon 3b 73 59 semicolon
64 < less than 3c 74 60 less than
65 = equals 3d 75 61 equals
66 > greater than 3e 76 62 greater than
67 a letter a 41 101 65 letter a
68 b letter b 42 102 66 letter b
69 c letter c 43 103 67 letter c
70 d letter d 44 104 68 letter d
71 e letter e 45 105 69 letter e
72 f letter f 46 106 70 letter f
73 g letter g 47 107 71 letter g
74 h letter h 48 110 72 letter h
75 i letter i 49 111 73 letter i
76 j letter j 4a 112 74 letter j
77 k letter k 4b 113 75 letter k
78 l letter l 4c 114 76 letter l
79 m letter m 4d 115 77 letter m
80 n letter n 4e 116 78 letter n
81 o letter o 4f 117 79 letter o
82 p letter p 50 120 80 letter p
83 q letter q 51 121 81 letter q
84 r letter r 52 122 82 letter r
85 s letter s 53 123 83 letter s
86 t letter t 54 124 84 letter t
87 u letter u 55 125 85 letter u
88 v letter v 56 126 86 letter v
89 w letter w 57 127 87 letter w
90 x letter x 58 130 88 letter x
91 y letter y 59 131 89 letter y
92 z letter z 5a 132 90 letter z
93 ^ not 5e 136 94 circumflex
94 _ underline 5f 137 95 underline
95
96 */
97
1 .=member mods
2 $ -- all corrections are to insert mod notice after -- mods.2 --
ldsd 1
ldsd 2 $ ldsd d. shields 20-jun-83
ldsd 3 $
ldsd 4 $ 1. increase oscmax to 512 fo s32.
ldsd 5 $ 2. extend incio to permit tabs, not just blanks, to be used
ldsd 6 $ to delimit keywords for .=member, .=include, except that
ldsd 7 $ directive must start with blank.
ldsd 8 $ decks affected - macros, incio
ldsd 9
ldsc 1
ldsc 2 $ ldsc d. shields 23-jul-82
ldsc 3 $
ldsc 4 $ for s37, allow longer program parameter strings and also change
ldsc 5 $ specification for print file from 'l=sysprint/sysout' to just
ldsc 6 $ 'l=sysprint/'.
ldsc 7 $
ldsc 8 $ decks affected - macros, ltlini
ldsc 9
dso 1
dso 2 $ ldsb d. shields 15-jan-82
dso 3 $
dso 4 $ revise ltlfin to put etim output on standard output not terminal.
dso 5 $ write etim output only if normal termination. writing the output
dso 6 $ to terminal was confusing, especially for unix.
dso 7 $ deck affected - ltlfin (resequenced).
dso 8
dsnc 1
dsnc 2 $ dsnc d. shields 15-dec-81
dsnc 3 $
dsnc 4 $ make the default for 'termp=' be system dependent.
dsnc 5 $ deck affected - ltlini
dsnc 6
dsn 1
dsn 2 $ dsn d. shields 09-dec-81
dsn 3 $
dsn 4 $ 1. support termp=>/> to indicate terminal prompt to be given
dsn 5 $ for interactive input.
dsn 6 $ termp=0 gives no prompting.
dsn 7 $ termp requires new sio procedure promsio(fn,rc,string) to
dsn 8 $ set prompt for file fn to string. provide dummy promsio if
dsn 9 $ this feature not to be supported on a particular implementatio
dsn 10 $ 2. extend plf1 parameter option so that parameter values
dsn 11 $ containing commas can be enclosed in parentheses.
dsn 12 $ decks affected - ltlini, beglio, makf, reados
dsn 13
utsa 1
utsa 2 $ utsa d. shields 29-nov-81 level 81333
utsa 3 $
utsa 4 $ support s47: amdahl uts (universal timesharing system).
utsa 5 $ this implementation runs on s37 architecture using an operating
utsa 6 $ system very close to unix (v7), and uses the ascii character set.
utsa 7 $ note that new decks s47xtr1 and s47errs will need revision for uts
utsa 8
dsm 1
dsm 2 $ dsm d. shields 04-nov-81
dsm 3 $
dsm 4 $ for systems other than s66, have etim write its output to
dsm 5 $ terminal file. also, limit use of remarkl within this library
dsm 6 $ to very serious errors such as 'unable to open listing file'.
dsm 7 $ remarkl is based on s66, and semantics elsewhere not always clear.
dsm 8 $ also, slightly adjust ltlini so all globals in single nameset,
dsm 9 $ hence no need to have nameset with created name ($tlini, etc.).
dsm 10 $ decks affected - ltlini, ltlced, incio, ltlfin.
dsm 11
dsl 1
dsl 2 $ dsl d. shields 21-sep-81
dsl 3 $
dsl 4 $ report fatal error (1010) if unable to open inclusion file.
dsl 5 $ deck affected - incio
dsl 6
dsua 1
dsua 2 $ dsua d. shields 27-jan-81
dsua 3 $
dsua 4 $ adjust iolbamax for s10.
dsua 5 $ deck affected - beglio
dsua 6
dsk 1
dsk 2 $ dsk d. shields 27-oct-80
dsk 3 $
dsk 4 $ 1. fix case folding in conditional assembly processing.
dsk 5 $ 2. add program parameter 'termh' such that title line generated
dsk 6 $ by ltitlr echoed to terminal only if termh=1. make default
dsk 7 $ 'termh=1/0', except for s32, where want 'termh=0/1'.
dsk 8 $ new contlpr entries permit reading and changing termh.
dsk 9 $ contlpr(28, arg) sets arg to termh value
dsk 10 $ contlpr(29, arg) sets termh value to arg
dsk 11 $ 3. permit specification of number of characters in standard
dsk 12 $ output file (unit 2). new program parameter
dsk 13 $ pfcl=0/80 permits specification of characters per line in
dsk 14 $ standard output file (including carriage control column).
dsk 15 $ 'pfcl=0' yields default line length.
dsk 16 $ alternate '80' chosen to assist output to terminal.
dsk 17 $ new contlpr entry permits finding line length
dsk 18 $ contlpr(30,arg) sets arg to line length of standard
dsk 19 $ output file
dsk 20 $ decks affected - macros, ltlini, lcp, incio, makf
dsk 21
plf 1
plf 2 $ plf d. shields 10-oct-80
plf 3 $
plf 4 $ add conditional assembly options to permit varying
plf 5 $ program parameter list formats, as follows
plf 6 $ plf0 comma is separator (default)
plf 7 $ plf1 comma is separator, except when between brackets
plf 8 $ ([ or < at left, ] or > at right). this format
plf 9 $ used for s10, s11 and s32, to permit passing
plf 10 $ fully-qualified file names.
plf 11 $ deck affected - reados
plf 12
dsj 1
dsj 2 $ dsj d. shields 24-sep-80
dsj 3 $
dsj 4 $ add procedure -ltlced- (c-heck e-xpiration d-ate) to check
dsj 5 $ expiration date. expiration causes abnormal termination with
dsj 6 $ code 1009. execution within a month of expiration causes
dsj 7 $ generation of warning message. expiration only checked if
dsj 8 $ -expire- option in ltlgen used when compiling program.
dsj 9 $ deck affected - ltlced (new).
dsj 10
dsi 1
dsi 2 $ dsi d. shields 30-jul-80
dsi 3 $ r. kenner
dsi 4 $
dsi 5 $ 1. fix problem (fr143) in multi-word extraction.
dsi 6 $ 2. correct spelling error in message in prhd.
dsi 7 $ 3. accept mixed case input in ilst (fixing fr137), iget
dsi 8 $ and vnum.
dsi 9 $ 4. fix macro definition for addrl for s37.
dsi 10 $ 5. support up to 20 files for s37.
dsi 11 $ 6. make page limit infinite for s37.
dsi 12 $ 7. change default for term= to 'term=systerm/' for s37.
dsi 13 $
dsi 14 $ * * * new sio procedures - eretsio, ecodsio * * *
dsi 15 $
dsi 16 $ add eretsio(fn, rc, lev) to permit recovery from sio errors.
dsi 17 $ lev is 0 for no return if sio error (prior practice)
dsi 18 $ 1 for terse return
dsi 19 $ 2 for verbose return (issue error messages, etc.)
dsi 20 $ the setting persits across file closes. rc is set zero unless
dsi 21 $ fn is not a valid file number.
dsi 22 $
dsi 23 $ add ecodsio(fn, rc, src) to report system error code.
dsi 24 $ after a call to an sio procedure, ecodsio may be called.
dsi 25 $ rc is set to the value returned in the last sio call, and,
dsi 26 $ if an error has occurred, src is set to a system-dependent
dsi 27 $ value describing which error occurred.
dsi 28 $
dsi 29 $ the standard input and output files are opened with eretsio level
dsi 30 $ 1 (terse return) and 2 (verbose return) respectively.
dsi 31 $
dsi 32 $ decks affected - macros, eexmw, prhd, ilst, iget, vnum, termio,
dsi 33 $ ltlini, makf.
dsi 34
dsh 1
dsh 2 $ dsh d. shields 21-jul-80
dsh 3 $
dsh 4 $ 1. force load of blds if defenv_ss not set.
dsh 5 $ 2. for s32 vms, have getipp and getspp fold arguments.
dsh 6 $ decks affected - ltlini, getipp, getspp.
dsh 7
dsg 1
dsg 2 $ dsg d. shields 11-jul-80
dsg 3 $
dsg 4 $ fix error (fr138) that caused extra blank line at end of
dsg 5 $ standard output file.
dsg 6 $ deck affected - rlse.
dsg 7
dsf 1
dsf 2 $ dsf d. shields 10-jul-80
dsf 3 $ 1. add conditional symbol -unix- for the unix operating system.
dsf 4 $ use iset=unix to obtain unix variant.
dsf 5 $ delete all special env code for initial unix checkout.
dsf 6 $ 2. provide up to 20 files for s32.
dsf 7 $ 3. improve ltlfin, especially for s32.
dsf 8 $ 4. watch for possible sio error on file open. if cannot
dsf 9 $ open standard output (unit 2), issue error message using
dsj 11 $ -remarkl- and terminate with code 1007.
dsf 11 $ decks affected - macros, ltlfin, beglio, ltllio, makf.
dsf 12
dse 1
dse 2 $ dse d. shields 21-apr-80
dse 3 $
dse 4 $ 1. allow up to 16 files for s32 and s37.
dse 5 $ 2. increase line buffer array for s32 and s37.
dse 6 $ 3. add option extime_off to permit support of timing feature,
dse 7 $ but not have times given by default.
dse 8 $ 4. fix error (fr132) that caused null lines to not be written.
dse 9 $ decks affected - macros, ltlini, beglio, flsh.
dse 10
dsd 1
dsd 2 $ dsd d. shields 21-nov-79
dsd 3 $
dsd 4 $ support mixed case in specifying .=include and .=member
dsd 5 $ directives and also for member names.
dsd 6 $ deck affected - incio
dsd 7
dsc 1
dsc 2 $ dsc d. shields 19-nov-79
dsc 3 $
dsc 4 $ 1. change default site name to 'nyu'. also adjust ltitlr
dsc 5 $ to work with names of differing lengths.
dsc 6 $ 2. have ltlini process 'term=' terminal option. this avoids user
dsc 7 $ programs having to open terminal file. this change compatible
dsc 8 $ with existing use of opnterm.
dsc 9 $ 3. change page limit default to 'pfpl=100/0' so that
dsc 10 $ 'pfpl' alone suppresses page limit check.
dsc 11 $ 4. do some initialization in opninc using data statements
dsc 12 $ instead of code.
dsc 13 $ 5. fix bug (fr2.3.124) in detecting conversion errors due
dsc 14 $ to misplaced test in vnum.
dsc 15 $ 6. add code for s10 to ctlc, ctuc.
dsc 16 $ 7. convert sstab in blds for s10 from sixbit to 9 bit.
dsc 17 $ 8. add parameter 'ilib=' to permit explicit naming of inclusion
dsc 18 $ text library. null value selects default library name.
dsc 19 $ 9. if extime enabled to permit timing execution, support
dsc 20 $ program parameter 'etim=1/0' so that time not reported
dsc 21 $ if etim=0.
dsc 22 $ 10. add procedure getapp(s, sl) which returns in string s of max.
dsc 23 $ length sl the full parameter string that invoked the program.
dsc 24 $ the maximum length of this string is getapp_len, which has
dsc 25 $ default length of 128 (240 for s32).
dsc 26 $ decks affected - ltlini, ltitlr, opnterm, incio, ltlfin, blds,
dsc 27 $ ctlc, ctuc, getapp (new).
dsc 28
dsb 1
dsb 2 $ dsb d. shields 10-sep-79
dsb 3 $
dsb 4 $ 1. for s32, support parameter strings up to 300 characters, and
dsb 5 $ individual string parameters up to 64 characters.
dsb 6 $ 2. ignore non-digits in integer parameter strings to avoid
dsb 7 $ generating spurious values during integer conversion.
dsb 8 $ 3. for little i/o, recognize only error levels 1 and 2.
dsb 9 $ level 1 error indicates conversion/truncation error, level 2
dsb 10 $ indicates bad parameters or error on attempting operation.
dsb 11 $ 4. detect sio failure when opening, closing or rewinding file.
dsb 12 $ 5. permit io procedure pcsa to be defined in environment.
dsb 13 $ 6. correct confusion in conditional assembly of ltlterm.
dsb 14 $ decks affected - macros, getipp, getspp, reados, makf, rlse,
dsb 15 $ rwnd, pfin, istr, uinp, uout, ioer, ltlterm.
dsb 16
ldsa 1
ldsa 2 $ ldsa d. shields 02-aug-79
ldsa 3 $
ldsa 4 $ 1. revise text inclusion routines to accept 'upd' argument to
ldsa 5 $ permit direct reading of little source from upd library files
ldsa 6 $ which have sequence information in first eight columns.
ldsa 7 $ 2. revise s10 configuration parameters to reflect use of
ldsa 8 $ 9-bit ascii.
ldsa 9 $ 3. add string search functions as follows.
ldsa 10 $ anyc, anys, blds, brkc, brks, ctlc, ctuc, nayc, nays, rbrc
ldsa 11 $ rbrs, rpld, rple, rspc, rsps, spnc, spns, stlc, stuc
ldsa 12 $ decks affected - incio, new decks for anyc...stuc
ldsa 13
dsz 1
dsz 2 $ dsz d. shields 05 jun 79
dsz 3 $
dsz 4 $ add special entry for subn in monitor package to permit setl
dsz 5 $ system to reset procedure table pointer.
dsz 6 $ deck affected - subn.
dsz 7
dsy 1
dsy 2 $ dsy d. shields 11 apr 79
dsy 3 $
dsy 4 $ fix error (fr2.3.109) that had line pointer wrongly initialized
dsy 5 $ for access get.
dsy 6 $ deck affected - makf.
dsy 7
dsx 1
dsx 2 $ dsx d. shields 01 feb 79
dsx 3 $
dsx 4 $ 1. add check for overflow in floating input (fr2.3.81).
dsx 5 $ 2. correct typos in correction dsw.
dsx 6 $ 3. add deck 'bneqmw' to provide multi word not-equal
dsx 7 $ needed by some asm's.
dsx 8 $ 4. fix getfmt macro to see if operation done (fr2.3.90).
dsx 9 $ 5. fix monitor package to have namesets in right place
dsx 10 $ (fr2.3.91) and have name length correct (fr2.3.92).
dsx 11 $ decks affected - lhdr, setx, subn, beglio, bneqmw.
dsx 12
dsw 1
dsw 2 $ dsw d. shields 30 jan 79
dsw 3 $ 1. correct sizing error in monitor routine setx. this fixes
dsw 4 $ fr2.3.76 and requires mod -dss- in gen be applied also.
dsw 5 $ 2. drop support for s16.
dsw 6 $ 3. add fields for s40 (prime 400).
dsw 7 $ decks affected - macros, beglio, setx.
dsw 8
vax 1
vax 2 $ vax d. shields 21 nov 78 level 78325
vax 3 $ r. kenner
vax 4 $
vax 5 $ add configuration values for s32: dec vax-11/780.
vax 6 $ decks affected - macros, ltlini, ltlregl, begmon, beglio.
vax 7
dsv 1
dsv 2 $ dsv d. shields 25 sep 78
dsv 3 $
dsv 4 $ 1. add code for resident s10 system.
dsv 5 $ 2. redo some standard macros to assume standard values,
dsv 6 $ and then add exceptions for particular implementations.
dsv 7 $ 3. fix reported bug in ltlxtr for s66.
dsv 8 $ decks affected - macros, beglio, ltlxtr.
dsv 9
dsu 1
dsu 2 $ dsu d. shields 20 jun 78
dsu 3 $
dsu 4 $ 1. adjust dimension of iolb for s11.
dsu 5 $ 2. fix bug in lstime so argument initialized.
dsu 6 $ 3. fix size error in vcsmw.
dsu 7 $ 4. fix error in putf.
dsu 8 $ 5. add 'dmp=0/1' option for s66, to permit full memory
dsu 9 $ dump if system forces termination.
dsu 10 $ decks affected - ltlini, lstime, putf, beglio, vcsmw.
dsu 11
dst 1
dst 2 $ dst d. shields 06 jun 78
dst 3 $
dst 4 $ 1. fix grouping problem in ofmi.
dst 5 $ 2. add code to ltlregl for s10.
dst 6 $ 3. change fatrasz for s10.
dst 7 $ decks affected - ltlregl (resequenced), beglio, ofmi.
dst 8
3
4 $ chars d. shields 30 may 78 level 78150
5 $
6 $ include deck chars to describe character set to assist in
7 $ correct translation of source text for new machines.
8 $ correct error in use of cdc character set so that apostrophe
9 $ represented by cdc display code 3b'70' (up arrow).
10 $ decks affected - all (source resequenced).
11
12
13 $ dss d. shields 01 mar 78
14 $ r. kenner
15 $
16 $ 1. fix traceback listing for s37.
17 $ 2. fix error in multi-word not (last word was not left filled).
18 $ 3. keep track of line number of formatted files. on error
19 $ list line number and recent line. line number is number
20 $ of sio operations done since file last positioned at start.
21 $ 4. assign abnormal termination code 1008 for attempt to use
22 $ function not defined/supported by an implementation.
23 $ 5. add conditional assembly option fp to select support
24 $ of floating point (real) operations.
25 $ modify ifme, ofme and ofmf to recognize fp, and report
26 $ error 1008 if called and floating point not supported.
27 $ decks affected - ltlxtr, ioer, notmw, (misc.) io
28
29
30 $ rgb r. gezelter 25 jan 78
31 $
32 $ fix errors in mod rga.
33 $ decks affected - macros, ltlregl, errmw.
34
35
36 $ rga r. gezelter 16 jan 78
37 $
38 $ fix conditional text for s11.
39 $ decks affected - macros, ltlini, gobyerm, ltlregl, ltlterm.
40
41
42 $ dsr d. shields 18 jan 78
43 $
44 $ provide standard for handling previously 'undefined' array
45 $ slices as follows, letting 'ara(lo) to ara(hi)' be model:
46 $
47 $ if lo<=1, there is an error which should be reported.
48 $ if hi>=lo, a slice is to be transmitted as before.
49 $ if hi<(lo-1), there is an error which should be reported.
50 $ if hi=(lo-1), the slice is said to be 'null', and
51 $ no data is to be transmitted.
52 $
53 $ the null slice is consistent with zero-width fields and
54 $ zero-trip do loops, and permits such constructs as
55 $ write f, ptr, ara(1) to ara(ptr);
56 $ where ptr has value zero.
57 $
58 $ the above changes are reflected by making the word count
59 $ parameter to uinp and uout be signed. word count of
60 $ zero is to result for null slice, and a negative word
61 $ count indicates an invalid slice, resulting from lo<=1
62 $ or hi<(lo-1).
63 $ add error message to ioer for invalid array slice.
64 $ decks affected - uinp, uout, ioer.
65
66
67 $ dsq d. shields 05 jan 78
68 $
69 $ 1. fix reported bug in support of -column- and
70 $ -x(negative)- control formats by adding field -lbmax-
71 $ to record true length of coded line.
72 $ 2. slightly improve efficiency for s37 by redefining
73 $ some file attribute fields as byte fields.
74 $ decks affected - beglio, lpin, flsh, putf, gcfp.
75
76
77 $ rke r. kenner 02 jan 78
78 $
79 $ 1. fix errors in conditional text for s37 and selection
80 $ of which routines should be compiled for various machines.
81 $ 2. have -stitlr- clear title before it sets new one.
82 $ 3. add third parameter to -rewisio- calls.
83 $ 4. correct formatting problem in -ltlregl- for s37.
84 $ 5. add -prs3-, -prs4-, and -prs5- to call -prst- with fewer
85 $ parameters.
86 $ 6. fix bug in -trfl- which causes labels not to be printed
87 $ in flow trace and improve format of labels that get printed.
88 $ 7. add missing 'access' statements in the multi-word routines.
89 $ 8. add a -ltlterm- for the s37.
90 $ 9. add new -ltlxtr- and some error routines for s37.
91 $ decks affected - macros, lcp, incio, ltlregl, begmon, trfl,
92 $ prfl, deci, ltlterm, ltlxtr1, ltlfin,
93 $ s37xtr1 (new), s37errs (new)
94
95
96 $ dsp d. shields 08 nov 77
97 $
98 $ revise .e. procedures to handle zero length extracts correctly.
99 $ decks affected - easmw, eexmw.
100
101
102 $ dso d. shields 31 oct 77
103 $ r. kenner
104 $
105 $ 1. add conditional text for s10 (dec 10).
106 $ 2. clean up program initialization (cf ltlini).
107 $ 3. clean up makf, in particular to permit sio to return
108 $ line size.
109 $ 4. clean up lcp, and do more argument checking in contlpr.
110 $ 5. clean up monitor package, recognize program procedure.
111 $ 6. assign an encoding for abnormal termination codes passed
112 $ to ltlfin, for use on s37.
113 $ decks affected - most (source has been resequenced).
114
115
116 $ dsn d. shields 18 oct 77
117 $
118 $ make several fixes and changes to io, as follows.
119 $ 1. do not permit read past end without filestat(,end) check.
120 $ 2. improve error handling.
121 $ 3. do conversion using negative arithmetic to avoid problems
122 $ on twos complement machines.
123 $ 4. simplify makf by having gen do some tests that can be done
124 $ at compile time.
125 $ 5. do not require column for sign position in integer output.
126 $ 6. on s66, no longer attempt to convert integers of more than
127 $ 48 bits (they can only be added and subtracted, anyway.)
128 $ decks affected - almost all from beglio thru endlio, lpin (new
129
130
131 $ rkd r. kenner 31 may 77
132 $
133 $ detected bug - grouping is done before field is blank filled.
134 $ this causes unexpected results.
135 $ fix - move call to -ogrp- in -pfin- to after the filling code.
136 $ deck affected - pfin
137
138
139 $ rkc r. kenner 27 may 77.
140 $
141 $ 1. correct some macros for s16.
142 $ 2. fix slighly conservative test in getipp.
143 $ 3. change data statements in ltllio for ions to executable
144 $ initialization to allow for space saving on s16.
145 $ decks affected - macros, getipp, ltllio.
146
147
148 $ rkb r. kenner 26 may 77.
149 $
150 $ correctly report an error in makf using ioer instead of lcp,
151 $ as s16 does not have lcp.
152 $ decks affected - makf, ioer.
153
154
155 $ dsm d. shields 24 may 77.
156 $
157 $ reported bug - 'writing' flag not reset for reading.
158 $ cause - an elseif in vali should be else.
159 $ deck affected - vali.
160
161
162 $ dsl d. shields 13 may 77
163 $
164 $ 1. make -ignore- level of string access files one, so conversion
165 $ and truncation errors on such files not fatal by default.
166 $ 2. add procedure 7nsigl$io(f,ilev) to set ignore level of file f
167 $ to ilev, to permit user to override default settings.
168 $ decks affected - makf, ioer, sigl(new).
169
170
171 $ dsk d. shields 06 may 77
172 $
173 $ 1. reported bug - on s16, format 'b(7,3)' gives occasional
174 $ erroneous high order bits.
175 $ cause - ofmb was not resetting for high order byte.
176 $ 2. reported bug - -a- input format not working on string file.
177 $ cause - s66 special case did not check for string file.
178 $ 3. reported bug - list input mode bombing on end of file.
179 $ 4. correct code for -b- conversion in case byte width three and
180 $ word size not multiple of three.
181 $ cause - debug trace code inadvertently left in.
182 $ decks affected - ofmb, ifma, ifmb, ilst, pcsa.
183
184
185 $ dsj d. shields 21 apr 77
186 $
187 $ install revised semantics for string access files.
188 $ decks affected - makf, rwnd, istr, ostr, gcfp, pcsa(new), ioer,
189 $ grem (deleted), prem (deleted).
190
191
192 $ dsi d. shields 14 apr 77.
193 $
194 $ 1. make 'line limit exceeded' force abnormal termination.
195 $ 2. support 'erexit' option, conditioned by name erexit, if
196 $ operating system permits processing after adress exception,
197 $ time limit, etc. this involves two procedures. procedure
198 $ 7nerxi$si is called by ltlini to initialize for recovery.
199 $ the recovery is nominally named '7nerxp$si' but is not
200 $ directly referenced. erxp$si should call ltlfin(1,0) to
201 $ indicate abnormal termination.
202 $ 3. ltlfin now calls procedure usratp (user a-bnormal
203 $ t-ermination p-rocedure) in case of abnormal
204 $ termination. usratp should not attempt to continue
205 $ execution.
206 $ decks affected - linelr, ltlini, ltlfin.
207
208
209 $ dsh d. shields 14 mar 77.
210 $
211 $ correct some problems in ofmf in handling of small quantities.
212 $ deck affected - ofmf.
213
214 $ sys16 t. stuart 5 april 1977
215
216 $ 1. redefine numerous constants for the s16 implementation
217 $ 2. correct an extractor macro in deck begmon
218 $ 3. add deck io16 which contains system 16 replacements for some
219 $ i/o procedures
220
221
222
223 $ rka r. kenner 6 april 1977
224 $
225 $ correct two bugs in lio:
226 $ 1. when error 12 (cannot allocate line buffer) occurs, the access
227 $ value for the file must be cleared. otherwise the program
228 $ will not terminate cleanly because -ltllio- will attempt to
229 $ disconnect a file which was not connected.
230 $ 2. there is a bug in -rlse- where the line buffers are moved
231 $ down. this causes spurious error 12's.
232 $ decks affected - makf, rlse.
233
234
235 $ dsg d. shields 14 mar 77.
236 $
237 $ reset -endseenv- before call to getw in istr so can read past
238 $ end marks in file.
239 $ deck affected - istr.
240
241
242 $ dsf d. shields 25 february 1977.
243 $
244 $ 1. fix size error of -printsw- in -flsh-.
245 $ 2. correct retrieval of io parameters in some put procedures
246 $ which inadvertently accessed input parameter list.
247 $ 3. install width parameters for -bl-, -el-, -fl- and -rl-
248 $ formats.
249 $ decks affected - flsh, ofmb, ofme, ofmf, ofmi, ofmr.
250
251
252 $ dse d. shields 31 january 1977.
253 $
254 $ 1. correct error in computation of point position by vnum.
255 $ 2. initialize variable deci_nsd in ltllio.
256 $ decks affected - ltllio, vnum.
257
258
259 $ dsd d. shields 27 january 77.
260 $
261 $ 1. insert missing assignment of -gw- in ofmi.
262 $ 2. use .s. instead of .ch. in some -lcp- string operations.
263
264
265 $ dsc d. shields 26 january 77.
266 $
267 $ 1. make linesize 90 for std. input file for s66.
268 $ 2. correct misplaced test in gcfp.
269 $ 3. correct error processing in makf to use ioer.
270 $ 4. move misplaced declaration in ifma.
271 $ decks affected - gcfp, ltllio, makf, ioer, ifma.
272
273
274 $ dsb d.shields 24 january 77.
275 $
276 $ 1. reported bug - coded line not flushed on rewind.
277 $ fix - include code to write last line in rwnd.
278 $ deck affected - rwnd.
279
280
281 $ dsa d. shields 20 jan 77
282 $
283 $ 1. clear line buffer after -put-, so -column- format works
284 $ correctly.
285 $ 2. install code in ltlfin to time execution.
286 $ 3. drop procedure -exitl- (ltlfin is to be used).
287 $ decks affected - macros, ltllib, ltlfin, exitl(dropped),
288 $ flsh, gcfp.
289
1 .=member begltl
2 $ begin little portion of ltllib
1 .=member macros
2
dsi 35
dsi 36 $ select mc if lower-case characters available.
dsi 37
dsi 38 .+set mc $ assume mixed-case characters available.
dsi 39
dsi 40 .+s66.
dsi 41 .-set mc $ upper case only on s66
dsi 42 ..s66
dsi 43
plf 13 .+set plf0 $ assume commas in parm lists always separators
dsi 44 $ if mixed-case available, default primary case is upper.
dsi 45 $ obtain lower primary case by defining mcl.
dsi 46
3 $ indicate procedures implemented by environment.
4
5 $ since multiword arithmetic temporarily dropped,
6 $ indicate that defined in environment so little
7 $ multiword arithmetic procedueres not compiled.
8 .+set defenv_addmw
9 .+set defenv_submw
10 .+set defenv_mulmw
11 .+set defenv_divmw
12 .+s11.
13 .+set defenv_readsos
plf 14 .-set plf0
plf 15 .+set plf1
14 ..s11
15
dsv 10 .+s10.
dsv 11 .+set defenv_linepack
dsv 12 +* linepack(pa, ua, nc) =
dsv 13 call 6npack$l(pa, 1, ua, 1, nc); **
dsv 14 .+set defenv_readsos
plf 16 .-set plf0
plf 17 .+set plf1
dsv 15 ..s10
utsb 1
utsb 2 .+s32.
utsb 3 .+set s32v $ assume vms.
utsb 4 ..s32
utsb 5
utsb 6 .+s32u.
utsb 7 .+s32.
utsb 8 .-set s32v $ do not want vms.
utsb 9 .+set s32u $ want unix os.
utsb 10 ..s32
utsb 11 .+set mcl $ want primary case to be lower.
utsb 12 ..s32u
vax 8 .+s32.
plf 18 .-set plf0
plf 19 .+set plf1
vax 9 .+set defenv_readsos
vaxa 1 .+set defenv_linepak
utsb 13 .+s32v.
vaxa 2 +* linepak(pa, ua, nc) = $ use interface procedure.
vaxa 3 7npack$li(pa, 1, ua, 1, nc) **
utsb 14 ..s32v
vaxa 4 .+set defenv_ss $ string search procedures defined in environment
vaxb 1 .+set defenv_casmw
vaxb 2 .+set defenv_catmw
vaxb 3 .+set defenv_cexmw
vaxb 4 .+set defenv_ceqmw
vaxb 5 .+set defenv_cinmw
vaxb 6 .+set defenv_vcsmw
vax 10 ..s32
16 .+s37.
mtsa 1 .+set s37cms $ assume cms operating system
mtsa 2
mtsa 3 .+s37mts $ if mts operating system
mtsa 4 .-set s37cms $ reset cms flag
mtsa 5 .+set s37mts $ set mts flag (redundant)
mtsa 6 ..s37mts
mtsa 7
17 .+set defenv_linepak
18 +* linepak(pa, ua, nc) = $ use interface procedure.
19 7npack$li(pa, 1, ua, 1, nc) **
20 .+set defenv_readsos
21 .+set defenv_lstime $ lstime defined by environment.
22 .+set defenv_fbtmw
23 .+set defenv_nbtmw
24 .+set defenv_casmw
25 .+set defenv_catmw
26 .+set defenv_cexmw
27 .+set defenv_ceqmw
28 .+set defenv_cinmw
29 .+set defenv_vcsmw
30 .+set defenv_ersmw
31 ..s37
utsa 9
utsa 10 .+s47.
utsa 11 .-set defenv_linepak
utsa 12 .+set defenv_readsos
utsa 13 .-set defenv_lstime $ lstime defined by environment.
utsa 14 .-set defenv_fbtmw
utsa 15 .-set defenv_nbtmw
utsa 16 .-set defenv_casmw
utsa 17 .-set defenv_catmw
utsa 18 .-set defenv_cexmw
utsa 19 .-set defenv_ceqmw
utsa 20 .-set defenv_cinmw
utsa 21 .-set defenv_vcsmw
utsa 22 .-set defenv_ersmw
utsa 23 ..s47
32
33 .+s66.
34 .+set defenv_linepak
35 +* linepak(pa, ua, nc) = $ use interface procedure.
36 7npack$li(pa, 1, ua, 1, nc) **
37 .+set defenv_lctime
38 .+set defenv_lstime $ lstime defined by environment.
ssa 1 .+set defenv_ss $ string search procedures defined in environment
39 .+set defenv_andmw
40 .+set defenv_iormw
41 .+set defenv_xormw
42 .+set defenv_notmw
43 .+set defenv_fbtmw
44 .+set defenv_nbtmw
45 .+set defenv_casmw
46 .+set defenv_cexmw
47 .+set defenv_catmw
48 .+set defenv_ceqmw
49 .+set defenv_cinmw
50 .+set defenv_vcsmw
51 .+set defenv_ersmw
52 ..s66
53
utsb 15 .+s32u.
dsf 16 $ disable defenv options for initial unix checkout.
dsf 17 .+set defenv_readsos
dsf 18 .-set defenv_linepak
dsf 19$ +* linepak(pa, ua, nc) = $ use interface procedure.
dsf 20$ 7npack$li(pa, 1, ua, 1, nc) **
dsf 21 .-set defenv_ss $ string search procedures defined in environment
dsf 22 .-set defenv_casmw
dsf 23 .-set defenv_catmw
dsf 24 .-set defenv_cexmw
dsf 25 .-set defenv_ceqmw
dsf 26 .-set defenv_cinmw
dsf 27 .-set defenv_vcsmw
utsb 16 ..s32u
dsf 29
54
55 $ end of environment-defined procedure list.
56
57 $ select those procedures which only exist in the environment
58 $ and select which ones exists for each machine.
dsv 16 .+s10.
dsv 17 .+set txtl_env
dsv 18 .+set unpk_env
dsv 19 .+set pack_env
dsv 20 .+set spak_env
dsv 21 ..s10
vaxa 5 .+s32.
vaxa 6 .+set txtl_env,unpk_env,pack_env,spak_env
vaxa 7 ..s32
59 .+s66.
60 .+set txtl_env,unpk_env,pack_env,spak_env
61 ..s66
62 .+s37.
63 .+set txtl_env,unpk_env,pack_env,spak_env
64 ..s37
utsa 24 .+s47.
utsa 25 .-set txtl_env,unpk_env,pack_env,spak_env
utsa 26 ..s47
65
utsb 17 .+s32u.
dsf 31 $ delete special env code for unix checkout.
dsf 32 .-set txtl_env,unpk_env,pack_env,spak_env
utsb 18 ..s32u
dsh 17
utsa 27 .+s47.
utsa 28 .+set mcl $ primary case lower
utsa 29 ..s47
utsa 30
dsi 48
dsi 49 .+mc.
dsi 50 .+mcl. $ if mixed-case to be lower
dsi 51 +* ctpc(x) = ctlc(x) ** $ primary case is lower.
dsi 52 +* stpc(x) = stlc(x) ** $ primary case is lower.
dsi 53 .-mcl.
dsi 54 +* ctpc(x) = ctuc(x) ** $ primary case is upper.
dsi 55 +* stpc(x) = stuc(x) ** $ primary case is upper.
dsi 56 ..mcl
dsi 57 ..mc
dsi 58
66 /*
67 abnormal termination codes.
68 the following codes are used as the second argument to
69 -ltlfin- to indicate type of abnormal termination.
70
71 some implementations may report these codes to the user as
72 and abend or completion code.
73
74 1001 line limit exceeded.
75 1002 bad go to index.
76 1003 inclusion depth too great or inclusion recursion.
77 1004 bad name for cross-reference file.
78 1005 array index out of range.
79 1006 assertion failed.
80 1007 unable to open standard print file.
81 1008 request for undefined/unsupported function
dsj 12 1009 expiration date passed
dsl 7 1010 unable to open inclusion file.
82 1101-1199 math library error n-1100.
83 1201-1299 multiword error n-1200.
84 1301-1399 little input/output error n-1300
85 2000+ reserved for use by machine-dependant environment
86 */
87
90 $ conditional assembly options.
91
92 $ select extime to have ltlfin display execution time.
dse 11 $ extime causes inclusion of code to support execution timing.
dse 12 $ the etim program parameter determines if timings listed.
dse 13 $ select extime_off to have times not listed by default.
vaxa 9 .+set extime
dse 14 .+set extime_off
93 .+s66.
94 .+set extime
exta 1 .-set extime_off
95 ..s66
96
97 $ select wsm3 if word size is multiple of three.
dsv 22 .+s10.
dsv 23 .+set wsm3
dsv 24 ..s10
98 .+s66.
99 .+set wsm3
100 ..s66
101
102 $ select erexit if error exit processing available.
106 .+s66.
107 .+set erexit
smp 1 $ select -smps66- to enable nos support of -smp- execution
smp 2 $ profile.
smp 3 .+set smps66
108 ..s66
109
110 $ select inclseq to use sequencial model of inclusion.
111 $ since all we have now is sequencial model, this is set.
112 .+set inclseq
113
114 +* slen = .len. ** $ length field of sds
115
116 +* sorg = .f. .sl.+1, .so., ** $ origin field of sds
117
118 +* ldcs = (.sl.+.so.) ** $ combined length of sds origin, leng
119
120 +* ws = .ws. ** $ number of bits in machine word
121
122 +* ps = .ps. ** $ number of bits in machine pointer (address)
123
124 +* cs = .cs. ** $ number of bits in character
125
126 +* yes = 1 **
127 +* no = 0 **
128
129 +* cpw = (.ws./.cs.) ** $ characters per machine_word
130
131 +* blankword = $ word of blanks
ldsa 14 .+s10 4r $ 9-bit ascii version
133 .+s11 2r
vax 11 .+s32 4r
135 .+s37 4r
utsa 31 .+s47 4r
dsw 9 .+s40 2r
136 .+s66 10r
137 **
138
139 +* charofdig(d) = $ maps digit to character code
140 (d+1r0) $ if characters in order
141 **
142
143 +* digofchar(c) = $ maps decimal character onto value
144 (c-1r0) $ if characters for digits in order
145 **
146
147 +* sds(n) = .sds. (n) ** $ size of n character string
148
dsv 25 +* letimesz = ws ** $ size of -letime- result.
dsv 26 .+s11 +* letimesz = 32 **
156
157
dsv 27 +* filenamelen = 20 ** $ default maximum file name length.
dsb 17 .+s32 +* filenamelen = 64 **
utsa 32 .+s47 +* filenamelen = 64 **
165
dsv 28 +* filenamelenblanks = 20q **
dsb 18 .+s32.
dsb 19 +* filenamelenblanks =
dsb 20 64q
dsb 21 **
dsb 22 ..s32
utsa 33 .+s47.
utsa 34 +* filenamelenblanks =
utsa 35 64q
utsa 36 **
utsa 37 ..s47
173
174 $ spplen is string program parameter maximum length.
175 +* spplen = 20 **
dsb 23 .+s32 +* spplen = 64 **
utsa 38 .+s47 +* spplen = 64 **
176 $ macros related to user option string processing
177 $ see procedures reados and readsos.
178
179 +* oscmax = 80 ** $ maximum length of option string
ldsd 10 .+s32 +* oscmax = 512 ** $ accept long parameter strings for s32.
ldsc 10 .+s37 +* oscmax = 300 ** $ accept long parameter strings for s37.
utsc 1 .+s47 +* oscmax = 300 ** $ accept long param. strings. uts
dsb 25 +* ospmax = filenamelen ** $ maximum length of strings used for
dsc 29 $ getapp_len is maximum length of string returned by getapp.
dsc 30 $ this cannot exceed maximum length of sds.
dsc 31 +* getapp_len = 128 **
dsc 32 .+s32 +* getapp_len = 240 **
utsa 40 .+s47 +* getapp_len = 240 **
dsc 33
181 $ string parameter codes and values.
183
184
185 +* q3(a,b,c) = a b c**
186 +* macdef(text) = q3(+,*text*,*)**
187 +* macdrop(mname) = macdef(mname=)**
188
dsv 29 +* szmax = 2047 ** $ maximum item size.
198
199 +* wordi(i,arg) = .f. 1+(i-1)*ws, ws, arg **
200 +* lcpns = $ name of lcp nameset.
201 6nlcp$ns
202 **
203
204 $ the output functions to be used in generating print lines
dsw 10 .+s40.
dsw 11 $ change names on s40 to create 4 character unique names
207 +* wordsr = wrdsr ** +* wordlfr = wrdfr **
208 +* intlpr = intpr ** +* octlpr = octpr **
209 +* readsos =rdsos **
dsw 12 ..s40
211 $
212 +* endl = call endlr; ** $ end current line
213 +* textl(s) = call textlr(s); ** $ add string to current line
214 +* intl(i) = call intlr(i);** $ add integer (5 cols) to line
215 +* intlp(i,c) = call intlpr(i,c);** $ add c column integer to li
216 +* octl(i) = call octlr(i); ** $ add octal value to line
217 +* octlp(v,c) = call octlpr(v,c);**$ output v in octal,
218 +* octlv(v) = call octlpr(v,((.fb.v-1)/3+1)); **
219 $ output v as octal, leadnng zeros suppressed
220 +* hexlp(v, c) = call hexlpr(v, c); ** $ output in hex
221 +* wordl(i) = call wordlr(i);** $ add word (00 ends) to line
222 +* wordlf(i) = call wordlfr(i);** $ add full word to line
223 +* charl(c) = call charlr(c); ** $ add chaacter to line
224 +* tintl(s,i) = call tintlr(s,i); ** $ output text and integer
225 +* getlpos(p) = call contlpr(1,p);** $ get currnt line position
226 +* setlpos(p) = call contlpr(2,p);** $ set current line position
227 +* skipl(p) = call contlpr(3,p); ** $
228 +* tabl(p) = call contlpr(4,p); ** $ tab to column -p-
229
230 $ pflen is the length of a print line, including the carriage
231 $ control character. the value of 133 is suggested as this is
232 $ value for s37.
dsk 23 +* pflenmax =
234 133
235 **
236
dsv 30 $ print file parameter initial values.
dsv 31
dsv 32 +* pfdefaultlinelimit = 'pfll=0/' **
dsv 33
dsc 34 +* pfdefaultpagelimit = 'pfpl=100/0' **
vaxc 1 $ for s32, make page limit infinite by default.
vaxc 2 .+s32 +* pfdefaultpagelimit = 'pfpl=0/0' **
dsi 59 $ for s37, make page limit infinite by default.
dsi 60 .+s37 +* pfdefaultpagelimit = 'pfpl=0/0' **
utsa 41 .+s47 +* pfdefaultpagelimit = 'pfpl=0/0' **
dsv 35
dsv 36 +* pfdefaultlinesperpage = 'pflp=60/' **
dsv 37
dsv 38 $ sitename appears as part of standard title line.
dsc 35
dsc 36 +* sitename = 'nyu' **
dsc 37 +* sitenamelen = 3 ** $ length of sitename (cf. ltitlr)
270
271 +* lstimelen = 30 **
272
273 $ memory access procedure names (use with caution).
274 +* memget = 7nmget$li **
275 +* memptr = 7nmptr$li **
276 +* memput = 7nmput$li **
277
338
339 +* wpc = $ words per card
ldsa 15 .+s10 20 $ 80 columns (4*20)
341 .+s11 40 $ 80 column (2*40)
vax 12 .+s32 20 $ 80 columns (4*20)
343 .+s37 20 $ 80 columns (4*20)
utsa 42 .+s47 20 $ 80 columns (4*20)
dsw 13 .+s40 40 $ 80 column (2*40)
344 .+s66 10 $ 90 columns (10*9) 90 for update compile files.
345 **
dsv 41 $ mradix is default machine radix (assume octal).
dsv 42
dsv 43 +* mradix = 3 **
vax 13 .+s32 +* mradix = 4 ** $ use hexadecimal for s32
dsv 44 .+s37 +* mradix = 4 ** $ use hexadecimal for s37
utsa 43 .+s47 +* mradix = 4 ** $ use hexadecimal for s37
dsv 45
dsv 46 $ bwordl lists machine word in appropriate format.
dsv 47 $ bwordlen is number of characters for bwordl.
dsv 48 $ addrl lists machine address in appropriate format.
dsv 49 $ addrlen is length of addrl result.
dsv 50
dsv 51 +* bwordl(w) = octl(w); **
vax 14 .+s32 +* bwordl(w) = hexlp(w, 8); ** $ s32 is hex.
dsv 52 .+s37 +* bwordl(w) = hexlp(w, 8); ** $ s37 is hex.
utsa 44 .+s47 +* bwordl(w) = hexlp(w, 8); ** $ s37 is hex.
dsv 53
dsv 54 +* bwordlen = (ws/3) **
vax 15 .+s32 +* bwordlen = 8 **
dsv 55 .+s37 +* bwordlen = 8 **
utsa 45 .+s47 +* bwordlen = 8 **
dsv 56
dsv 57 +* addrl(w) = octlp(w, 6); **
vax 16 .+s32 +* addrl(w) = hexlp(w, 8); **
dsi 61 .+s37 +* addrl(w) = hexlp(w, 6); **
utsa 46 .+s47 +* addrl(w) = hexlp(w, 6); **
dsv 59
vax 17 +* addrlen = ((ps + mradix - 1) / mradix) **
dsv 62
dsv 63 $ inclusion processing.
dsv 64 $ memnamelenmax is maximum length of member name.
dsv 65 $ inclevmax is maximum depth of inclusion.
dsv 66 $ inclibname is name of standard inclusion library.
dsv 67
dsv 68 +* memnamelenmax = 20 **
dsv 69
dsv 70 +* inclevmax = 6 **
349
350 .-set makfprfi $ print file status in makf (debug).
351
352 $ set fp if floating arithmetic is supported, default is on.
353 .+set fp
354 .+s11.
355 .-set fp
356 ..s11
357
358 +* deciaralen = 40 ** $ length of integer conversion array.
359 +* deci_lsd = 40 **
360
361 $ macros for -little- i/o procedures - mostly, fields of status words
362
dsv 74 $ maxfiles is maximum number of simultaneously open files.
dsv 75
dsv 76 +* maxfiles = 10 **
dsv 77 .+s11 +* maxfiles = 15 **
dsf 36 .+s32 +* maxfiles = 20 **
dsi 62 .+s37 +* maxfiles = 20 **
utsa 47 .+s47 +* maxfiles = 20 **
dse 17
dse 18 $ termfilenumber is unit number for terminal file. since this
dse 19 $ file possibly open on all runs, it is allocated as largest
dse 20 $ possible number.
dse 21 $ incfilenumber is unit number for text inclusion library.
dse 22 $ it is not always needed, and so is allocated in same way as
dse 23 $ term file. note that termfile and include file were added after
dse 24 $ standard input and output file numbers established. they are
dse 25 $ allocated 'at the end' to avoid conflicts with old programs.
dse 26
dse 27 +* termfilenumber = maxfiles **
dse 28 +* incfilenumber = (maxfiles-1) ** $ inclusion file number.
370
371 $ since two's complement machines have a negative value whose
372 $ absolute value is one greater than the value of the largest
373 $ positive integer, integer conversion is done using negative
374 $ values. maxnegint is the value of the smallest negative
375 $ integer.
376
377 +* maxnegint = $ value of smallest negative integer.
378 $ give as bit constants to avoid conversion problems.
379 .+s10 4b'8 0000 0000'
380 .+s11 3b'100000'
vax 18 .+s32 4b'8000 0000'
382 .+s37 4b'8000 0000'
utsa 48 .+s47 4b'8000 0000'
dsw 14 .+s40 4b'8000'
383 .+s66 3b'7777 0000 0000 0000 0000'
384 **
385
386
dsv 78 $ gotoem gives name of error proc for indexed go to error.
dsv 79 +* gotoem = 7ngoto$em **
dsv 80 .+s11 +* gotoem = 6ngoto$m **
goa 1 .+s10 +* gotoem = 6ngoto$m **
394
395 $ codes used for accessv values.
396 +* access_get = 1 **
397 +* access_print = 2 **
398 +* access_put = 3 **
399 +* access_read = 4 **
400 +* access_string = 5 **
401 +* access_write = 6 **
402 +* access_release = 7 **
1 .=member ltlini
2 subr ltlini(c); $ initiate little system.
3 $ initialize little library. c is zero if little alone,
4 $ nonzero if running in presence of host.
5 $ for now, assume little alone.
6 size c(ps); $ case.
7
8 $
9 $ all global variables used by the little library procedures
10 $ not otherwise explicitly defined in their own nameset are
11 $ to be defined here in nameset -lcpns-.
12
dsm 12 nameset lcpns;
13 .+extime size timeon(letimesz);
dsc 38 .+extime size etim(ps); $ on if want execution time reported
15 size inputfilename(.sds. filenamelen); $ input file name.
16 size printfilename(.sds. filenamelen); $ print file name.
dsc 39 size termfilename(.sds. filenamelen); $ terminal file name.
dsc 40 size inclibname(.sds. filenamelen); $ include file name.
dsk 24 size pfl(cs); dims pfl(pflenmax); $ print file line.
18 size pfcol(ps); $ print line column (of next character)
19 data pfcol = 2;
20 size pfline(ps); $ print line number (last line completed)
21 data pfline = 0;
22 size pfpage(ps); $ print file page number.
23 size pflinetotal(ps); $ total lines written on print file.
24 data pflinetotal = 0; $ no lines written at start
25 size pflinelimit(ps); $ print file line limit.
26 size pfpagelimit(ps); $ print file page limit.
27 size pfcarriage(1); $ on to allow carriage control in col. 1.
28 size pflinesperpage(ps); $ lines per print file page.
dsk 25 size pftitle(.sds. pflenmax); $ main print title.
dsk 26 size pfstitle(.sds. pflenmax); $ print file subtitle.
31 size pftitling(1); $ on if titline print file.
32 data pftitling = no;
33 size pfpaging(1); $ on if forming print file pages.
34 data pfpaging = no;
35 size pfpagefield(ps); $ field in title for page number.
36 size pfdatefield(ps); $ field in title for date.
37 size pftermflag(1); $ on to write to terminal file
38 data pftermflag = no; $ default is not to write to term file
39 size pflistflag(1); $ on to write to listing file
40 data pflistflag = yes; $ default is to write to list file
41 size pftermopen(1); $ on if terminal file open
42 data pftermopen = no; $ terminal file is initially closed
43 size dblinelim(ps); $ monitor line limit
44 size dblinect(ps); data dblinect=1; $ line counter
45 size dbstoplist(1); data dbstoplist = no; $ on to stop prin
46 size dblinenum(ps); data dblinenum = 0; $ used to space lines
47 data pfl(1) = 1r ; $ carriage control is initially blank
dsk 27 size pflen(ps); $ length of print line.
dsk 28 data pflen = pflenmax;
dsk 29 size termh(ps); $ on for terminal header.
dsk 30 data termh=yes;
dsn 14 size termprompt(.sds. filenamelen);
dsn 15 data termprompt = '>';
48 end nameset;
49
50 call sysini(0); $ perform necessary system initialization.
51
52 .+extime call letime(timeon); $ get starting time.
smp 4 .+smps66 call 7nsmpi$li; $ to check for -smp- run.
53 call ltlsio(0);
54
dsc 41 .+extime.
dsc 42 $ etim=0 permits suppressing reporting elapsed time if
dsc 43 $ execution time being noted.
dse 29 .-extime_off call getipp(etim, 'etim=1/0'); $ get option
dse 30 .+extime_off call getipp(etim, 'etim=0/1'); $ get option
dsc 45 ..extime
dsc 46
55 $ get names of standard input and print files.
56
57 .+s10.
58 call getspp(inputfilename, 'i=*.ltl/');
59 call getspp(printfilename, 'l=*.lst/');
dsc 47 call getspp(termfilename, 'term=tty:/');
dsc 48 call getspp(inclibname, 'ilib=syslib/');
60 ..s10
61 .+s11.
62 call getspp(inputfilename, 'i=ti:/');
63 call getspp(printfilename, 'l=ti:/');
dsc 49 call getspp(termfilename, 'term=ti:/');
dsc 50 call getspp(inclibname, 'ilib=syslib/');
64 ..s11
utsb 19 .+s32u.
utsb 20 call getspp(inputfilename, 'i=stdin/');
utsb 21 call getspp(printfilename, 'l=stdout/');
utsb 22 call getspp(termfilename, 'term=stderr/');
dsc 52 call getspp(inclibname, 'ilib=syslib/');
utsb 23 ..s32u
utsb 24 .+s32v.
utsb 25 call getspp(inputfilename, 'i=sys$input/');
utsb 26 call getspp(printfilename, 'l=sys$output/');
utsb 27 call getspp(termfilename, 'term=sys$error/');
utsb 28 call getspp(inclibname, 'ilib=syslib/');
utsb 29 ..s32v
mtsa 8 .+s37cms.
66 call getspp(inputfilename, 'i=sysin/');
ldsc 11 call getspp(printfilename, 'l=sysprint/');
dsi 63 call getspp(termfilename, 'term=systerm/');
dsc 54 call getspp(inclibname, 'ilib=syslib/');
mtsa 9 ..s37cms
mtsa 10 .+s37mts.
mtsa 11 call getspp(inputfilename, 'i=*source*/');
mtsa 12 call getspp(printfilename, 'l=*sink*/');
mtsa 13 call getspp(termfilename, 'term=*msink*/');
mtsa 14 call getspp(inclibname, 'ilib=syslib/');
mtsa 15 ..s37mts
utsa 49 .+s47.
utsb 30 call getspp(inputfilename, 'i=stdin/');
utsb 31 call getspp(printfilename, 'l=stdout/');
utsb 32 call getspp(termfilename, 'term=stderr/');
utsa 53 call getspp(inclibname, 'ilib=syslib/');
utsa 54 ..s47
69 .+s66.
dsu 12 nameset 7nerxd$ns; $ for abnormal termination dump.
dsu 13 size atdopt(ws); $ adnormal termination dump option.
dsu 14 data atdopt = 0; $ no dump by default.
dsu 15 end nameset;
dsu 16
dsu 17 call getipp(atdopt, 'dmp=0/1'); $ get termination dump option.
70 call getspp(inputfilename, 'i=input/compile');
71 call getspp(printfilename, 'l=output/list');
dsc 55 call getspp(termfilename, 'term=/term');
dsc 56 call getspp(inclibname, 'ilib=inclib/');
72 ..s66
73
74 $ get parameters of standard print file.
75
76 call getipp(pflinelimit, pfdefaultlinelimit);
77 call getipp(pfpagelimit, pfdefaultpagelimit);
78 call getipp(pflinesperpage, pfdefaultlinesperpage);
dsk 31 call getipp(pflen, 'pfcl=0/80');
dsk 32 if (pflen=0) pflen = pflenmax;
dsk 33 if (pflen>pflenmax) pflen=pflenmax;
79 call getipp(pfcarriage, 'pfcc=1/0');
80 if pflinelimit=0 & pfpagelimit>0 then
81 pflinelimit = pfpagelimit * pflinesperpage;
82 end if;
83
84 dblinelim = pflinelimit*9/10; $ set monitor line limit.
85
dsnc 7 $ get prompting character. the default value is system dependent.
dsnc 8 .+s10 call getspp(termprompt,'termp=*/');
dsnc 9 .+s11 call getspp(termprompt,'termp=>/');
dsnc 10 .+s32u call getspp(termprompt,'termp=:/');
dsnc 11 .+s32v call getspp(termprompt,'termp=>/');
dsnc 12 .+s37 call getspp(termprompt,'termp=>/');
dsnc 13 .+s47 call getspp(termprompt,'termp=:/');
dsnc 14 .+s66 call getspp(termprompt,'termp=>/');
dsna 2 if (termprompt.seq.'0') .len. termprompt=0;
dsna 3
86 call ltllio(0); $ initialize little io.
dsc 57
dsc 58 $ open terminal file if one desired.
dsc 59 if (.len. termfilename) call opnterm(termfilename);
dsk 34 call getipp(termh, 'termh=1/0');
dsk 35 .+s32 call getipp(termh, 'termh=0/1');
dsna 4 .+s47 call getipp(termh, 'termh=0/1');
87
dsh 18 .-defenv_ss.
dsh 19 $ if using library-defined string search primitives, call
dsh 20 $ blds to guarantee that ss namesets initialized.
dsh 21 $ do this by redundant, and harmless, construction of a string set.
dsh 22 call blds(' ', 1);
dsh 23 ..defenv_ss
88 end subr ltlini;
smp 5 .+smps66.
smp 6 subr 7nsmpi$li; $ smp execution initiator.
smp 7 $ retrieve program parameters 'smplo=0/0' and 'smphi=0/0'.
smp 8 $ if either nonzero, initiate smp request to generate
smp 9 $ execution profile. as system will only accept request
smp 10 $ if job origin is 'system origin', issue dayfile
smp 11 $ messages before and after system request.
smp 12 $ smplo is first word address of area to monitor,
smp 13 $ smphi is last word address.
smp 14 size memget(ws);
smp 15 size smplo(ws), smphi(ws);
smp 16 size wd(ws);
smp 17
smp 18 call getipp(smplo, 'smplo=0/0');
smp 19 call getipp(smphi, 'smphi=0/0');
smp 20
smp 21 if (smphi>0) & (smplo(ynow+1)) return; $ if expiration far in the future.
14 $ expiration possible, find common origin for days, then determine
15 $ days left until expiration.
16 yorg = ynow; if (yorg>yexp) yorg = yexp; $ set origin.
17 left = ((yexp-yorg)*365 + dexp) - ((ynow-yorg)*365+dnow);
18 if left <= 0 then $ if expired
19 textl('expired, obtain new copy.'); endl;
21 call ltlfin(1, 1009); $ abnormally terminate.
22 elseif left<30 then $ if expiration approaching, warn user
23 intl(left) textl(' days to expiration.') endl
24 end if;
25 end subr;
1 .=member lcp
2 $ lcp ( l-ittle c-ompiler p-rint -procedures)
3 $
4 $ define the procedures used to generate the compiler list
5 $ file. these procedures perform needed conversions, building up a
6 $ line as array of characters.
7 $
8 +* putcn(c) = $ add character to print line - no check
9 pfl(pfcol) = c; pfcol = pfcol+1;
10 **
11
12 +* addc(c) = $ add character to print line
13 putcn(c); $ add character
14 if (pfcol > pflen) call endlr;
15 **
16
17 subr pagelr; $ begin print file page.
18 access lcpns;
19 size i(ps); $ loop index.
20 size j(ps); $ loop index.
dsk 36 size pflsave(.sds. pflenmax); $ saved print line (for titles).
22 size pflensave(ps); $ saved length of pfl.
23 size pftermsave(1); $ save -pftermflag-
24 size v(ps); $ for converting page number.
25
26 pfpage = pfpage + 1;
27 if (pfpaging = 0) return;
28 pftermsave = pftermflag; pftermflag = no; $ dont write title on t
29 $ if page limit exceeded, suppress further carriage control.
30 if pfpagelimit then
31 if (pfpage > pfpagelimit) pfcarriage = 0;
32 end if;
33 if pftitling then $ if title desired.
34 pflensave = pfcol - 1;
35 slen pflsave = pflensave; sorg pflsave = 1 + .sds. pflensave;
36 do i = 1 to pflensave; .ch. i, pflsave = pfl(i); end do;
37 do i = 1 to slen pftitle; pfl(i) = .ch. i, pftitle; end do;
38 if pfpagefield then $ if page number desired.
39 if (pfpage<0) pfpage = 0;
40 if (pfpage>9999) pfpage = 0;
41 do i = 0 to 4; pfl(pfpagefield+i) = 1r ; end do;
42 j = pfpagefield + 5;
43 v = pfpage;
44 until v = 0;
45 j = j - 1;
46 pfl(j) = charofdig( (v - 10*(v/10)) );
47 v = v / 10;
48 end until;
49 end if;
50 pfcol = slen pftitle+1; call linelr; $ print main title.
51 do i = 1 to slen pfstitle; pfl(i) = .ch. i, pfstitle; end do;
52 pfcol = slen pfstitle + 1; call linelr; $ print sub title.
53 call linelr; $ print blank line after title.
54 do i = 1 to pflensave; pfl(i) = .ch. i, pflsave; end do;
55 pfcol = pflensave + 1;
56 pfl(1) = 1r ;
57 pfline = 3;
58 else
59 pfl(1) = 1r1; $ force start of new page.
60 pfline = 0;
61 end if;
62 pftermflag = pftermsave; $ save terminal flag
63 end subr pagelr;
64 subr etitlr(lin, str, posarg, lenarg); $ enter string into title.
65 $ enter string str in title line beginning at column pos.
66 $ enter len characters, padding with blanks if str if shorter.
67 $ use main title if lin is zero, else use subtitle.
68 access lcpns;
69 size lin(ps); $ line designator.
dsk 37 size posarg(ws); $ specified position to begin insert.
dsk 38 size pos(ws); $ position to insert.
72 size lenarg(ps); $ number of positions to define.
73 size len(ps); $ adjusted length.
dsk 39 size str(.sds. pflenmax); $ string to insert.
75 size lc(ps); $ last column index.
76
77 len = lenarg; if (len = 0) len = slen str;
78 pos = posarg; if (pos<2) pos = 2;
79 lc = pos + len - 1; $ index of last column.
80 if (lc > pflen) return;
81 if lin then $ if subtitle.
82 if (lc > slen pfstitle) slen pfstitle = lc;
83 .s. pos, len, pfstitle = str;
84 else $ if main title.
85 if (lc > slen pftitle) slen pftitle = lc;
86 .s. pos, len, pftitle = str;
87 end if;
88 end subr etitlr;
89 subr ltitlr(tlabel); $ prepare standard little title.
90 access lcpns;
dsk 40 size tlabel(.sds. pflenmax); $ title string.
92 size lstimestr(.sds. lstimelen);
93 size i(ps); $ do loop index
94
95 call contlpr(6, 1); $ set paging on.
96 call contlpr(7, 1); $ enable titling.
dsc 60 call etitlr(0, sitename, pflen-(63+sitenamelen), 0);
98 call etitlr(0, '.little.', pflen-63, 0);
99 $ copy at most first fifteen chars of supplied label.
100 call etitlr(0, tlabel, pflen-55, 15);
101 call etitlr(0, 'page', pflen-8, 0);
102 call contlpr(8, pflen-4); $ set page field.
103 call contlpr(9, pflen-40); $ set date field.
104 pfpage = 0; pfline = pflinesperpage; $ at end of zero page.
105 pfcol = 2; pfl(1) = 1r ;
106 pflinetotal = 0;
dsk 41 if pftermopen & termh then $ write header to terminal file
108 pflistflag = no; pftermflag = yes; $ this goes to terminal fi
109 textl('start ') textl(sitename) textl('.little.')
110 textl(tlabel)
111 call lstime(lstimestr);
una 2 textl(lstimestr) endl
113 pflistflag = yes; pftermflag = no; $ reset to normal
114 end if;
115 end subr ltitlr;
116 subr stitlr(lin, titl); $ enter title or subtitle.
117 size lin(ps); $ zero for main title, else subtitle.
dsk 42 size titl(.sds. pflenmax); $ title string.
119 call etitlr(lin, titl, 2, 60);
120 end subr stitlr;
121 subr linelr; $ end print line.
122 access lcpns;
123 size lastline(1); $ on when limit exceeded.
124 size i(ps); $ loop index.
125 size iocc(ws); $ io completion code.
126
127 if (pfcol<2) pfcol = 2;
128 if (pfcol > (pflen+1)) pfcol = pflen + 1;
129 $ put blank in col 1 if no want carriage control.
130 if (pfcarriage = 0) pfl(1) = 1r ;
131 lastline = no;
132 if pflinelimit ^= 0 & pflistflag then $ check for line limit
133 pflinetotal = pflinetotal + 1;
134 if pflinetotal > pflinelimit then
135 lastline = yes;
136 do i = 1 to 20;
137 pfl(i+1) = .ch. i, 20qline limit exceeded. ;
138 end do;
139 pfcol = 22;
140 end if;
141 end if;
142
143 pfcol = pfcol - 1; $ make true number of columns.
144 if (pflistflag) call putcsio(2, iocc, pfl, 1, pfcol);
145
146 if (pftermflag & pftermopen) $ write line to terminal fil
147 call putcsio(termfilenumber, iocc, pfl, 1, pfcol);
148 pfcol = 2;
149 pfl(1) = 1r ;
150 if lastline then $ note limit exceeded, and abort.
151 call remarkl(' line limit exceeded.');
152 call ltlfin(1, 1001); $ line limit exceeded.
153 end if;
154 end subr linelr;
155 subr endlr; $ end print line.
156 $ end print line. if paging, see if must begin new page.
157 access lcpns;
158 size newpage(1); $ on to begin new page.
159 if (pfpaging = no) then call linelr; return; end if;
160 newpage = no;
161
162 $ if no ouput to list file, dont count lines
163 if pflistflag = no then call linelr; return; end if;
164
165 if pfl(1) = 1r then
166 if (pfline = pflinesperpage) newpage = yes;
167 elseif pfl(1) = 1r1 then newpage = yes;
168 elseif pfl(1) = 1r0 then
169 if pfline >= (pflinesperpage-1) then
170 newpage = yes; pfl(1) = 1r ;
171 else pfline = pfline + 1; end if;
172 elseif pfl(1) = 1r+ then pfline = pfline - 1;
173 end if;
174 if (newpage) call pagelr; $ begin new page
175 call linelr;
176 pfline = pfline+1;
177 end subr endlr;
178 subr contlpr(act, arg); $ control actions for print file.
179 access lcpns;
180 size act(ps); $ action to take.
181 size arg(ws); $ parameter or result.
182 size i(ps); $ loop index.
183 size lstimestr(.sds. lstimelen); $ time-date string.
184
185 $ actions as follows.
186 $ 1 get current position in line.
187 $ 2 set current position in line.
188 $ 3 skip forward pos columns, inserting blanks on way.
189 $ 4 tab to column pos (add blanks on forward tab).
190 $ 5 new page action:
191 $ if pos zero, begin new page.
192 $ if pos not zero, begin new page if less than pos lines
193 $ remain on current page.
194
195 $ 6 set paging mode (if on, pages formed)
196 $ 7 set titling mode (if on, titles cleared).
197 $ 8 set page number field in title line.
198 $ 9 set date field in title line.
199 $ 10 get lines per page.
200 $ 11 set lines per page.
201 $ 12 get page number.
202 $ 13 set page number.
203 $ 14 get line number (within page).
204 $ 15 set line number (within page).
205 $ 16 get number of lines written.
206 $ 17 set number of lines written.
207 $ 18 get line limit.
208 $ 19 set line limit.
209 $ 20 get page limit.
210 $ 21 set page limit.
211 $ 22 get carriage control status.
212 $ 23 set carriage control status.
213 $ 24 get carriage control character.
214 $ 25 set carriage control character.
215 $ 26 set list output control flag.
216 $ 27 set terminal output control flag.
dsk 43 $ 28 get terminal header flag.
dsk 44 $ 29 set terminal header flag.
dsk 45 $ 30 get characters per line.
217
dsk 46 go to l(act) in 1 to 30;
219
220 /l(01)/
221 arg = pfcol; go to ret;
222 /l(02)/
dsk 47 if (arg<1 ! arg>pflen) go to ret;
223 pfcol = arg; go to ret;
224 /l(03)/ $ skip action
225 if (arg<1 ! arg>(pflen-1)) return;
226 if (arg+pfcol >= pflen) then call endlr; return; end if;
227 pfcol = pfcol + arg;
228 do i = 1 to arg; pfl(pfcol-i) = 1r ; end do;
229 go to ret;
230 /l(04)/ $ tab action.
231 if (arg=0) go to ret;
232 if (pfcol >= arg) then
233 pfcol = arg;
234 else
235 while pfcol < arg;
236 pfl(pfcol) = 1r ; pfcol = pfcol + 1;
237 end while;
238 end if;
239 go to ret;
240 /l(05)/ $ page action.
241 if pfpaging then
242 if (arg=0) ! ((arg>0)&((arg+pfline)>pflinesperpage)) then
243 call pagelr;
244 end if;
245 end if;
246 go to ret;
247 /l(06)/
248 pfpaging = (arg ^= 0); go to ret;
249 /l(07)/
250 pftitling = (arg ^= 0);
251 if pftitling then $ if titling, clear titles.
252 sorg pftitle = 1 + .sds. pflen ;
253 slen pftitle = pflen;
254 .s. 1, pflen, pftitle = ' ';
255 pfstitle = pftitle;
256 slen pftitle = 1;
257 .ch. 1, pftitle = 1r1;
258 end if;
259 go to ret;
260 /l(08)/
dsk 48 if (arg<2) go to ret;
261 i = arg + 4; $ index of last column.
262 if (i > pflen) return; $ if out of bounds.
263 pfpagefield = arg; $ set page field.
264 if (slen pftitle < i) slen pftitle = i;
265 go to ret;
266 /l(09)/
dsk 49 if (arg<2) go to ret;
267 i = arg + lstimelen - 1; $ last column index.
268 if (i > pflen) go to ret; $ if out of bounds.
269 pfdatefield = arg;
270 if pfdatefield then $ if date field, get date.
271 call lstime(lstimestr);
272 if (slen pftitle < i) slen pftitle = i;
273 .s. pfdatefield, lstimelen, pftitle = lstimestr;
274 end if;
275 go to ret; $ set date field in title line.
276 /l(10)/
277 arg = pflinesperpage; go to ret;
278 /l(11)/
279 if (arg < 10) go to ret; $ avoid very small pages.
280 pflinesperpage = arg; go to ret;
281 /l(12)/
282 arg = pfpage;
283 if (pfline = pflinesperpage) arg = arg + 1; $ if at end of page
284 go to ret;
285 /l(13)/
286 if (arg > 9999) go to ret; $ avoid too large page number.
287 pfpage = arg; go to ret;
288 /l(14)/ $ get line number of last line completed.
289 arg = pfline; go to ret;
290 /l(15)/ $ set line number of last line completed.
291 pfline = arg; go to ret;
292 /l(16)/ $ get number of lines written.
293 arg = pflinetotal; go to ret;
294 /l(17)/ $ set number of lines written.
295 pflinetotal = arg; go to ret;
296 /l(18)/ $ get line limit.
297 arg = pflinelimit; go to ret;
298 /l(19)/ $ set line limit (zero to suppress limit check).
299 pflinelimit = arg; go to ret;
300 /l(20)/ $ get page limit.
301 arg = pfpagelimit; go to ret;
302 /l(21)/ $ set page limit.
303 pfpagelimit = arg; go to ret;
304 /l(22)/ $ get carriage control condition.
305 arg = pfcarriage; go to ret;
306 /l(23)/ $ set carriage control condition.
307 pfcarriage = (arg ^= 0); go to ret;
308 /l(24)/ $ get carriage control character.
309 arg = pfl(1); go to ret;
310 /l(25)/ $ set carriage control character.
311 pfl(1) = arg; go to ret;
312 /l(26)/ $ set list output control flag.
313 pflistflag = (arg ^= 0); go to ret;
314 /l(27)/ $ set terminal output control flag.
315 pftermflag = (arg ^= 0); go to ret;
dsk 50 /l(28)/ $ get terminal header flag.
dsk 51 arg = termh; go to ret;
dsk 52 /l(29)/ $ set terminal header flag.
dsk 53 termh = (arg ^= 0); go to ret;
dsk 54 /l(30)/ $ get characters per line.
dsk 55 arg = pflen; go to ret;
316 /ret/
317 end subr contlpr;
318 subr textlr(t); $ print string.
319 access lcpns;
dsk 56 size t(.sds. pflenmax); $ string to add.
321 size torg(ps); $ origin of string.
322 size tlen(ps); $ length in characters of string
323 size tpos(ps); $ current position in string
324 size i(ps); $ do loop index
325 tlen = slen t;
326 .+txtl_env.
327 $ if possible, unpack string directly into pfl.
328 if pfcol+tlen <= pflen+1 then $ if can unpack directly.
329 call 7ntxtl$li(pfl, pfcol, t);
330 pfcol = pfcol + tlen;
331 if (pfcol>pflen) call endlr;
332 return;
333 end if;
334 ..txtl_env
335 tpos = sorg t;
336 do i = 1 to tlen; $ print characters in turn
337 tpos = tpos - cs; $ position to next character
338 addc( (.f. tpos, cs, t))
339 end do;
340 end subr textlr;
341 subr charlr(c); $ print character.
342 access lcpns;
343 size c(cs); $ character to add
344 addc(c);
345 end subr charlr;
346 subr octlr(o); $ print octal value
347 access lcpns;
348 size o(ws); $ argument to output
349
350 call octlpr(o, (ws+2)/3);
351 end subr octlr;
352 subr wordlr(wordlarg); $ print word
353 access lcpns;
354 size wordlarg(ws); $ word to output
355 size wordlch(cs); $ character to output
356 size wordlpos(ps); $ position in word
357 size i(ps); $ do loop index
358 $ adds characters in input word-size argument to output line
359 .+unpk_env. $ if possible, unpack directly into pfl.
360 if pfcol+cpw <= pflen+1 then
361 call 7nunpk$li(pfl, pfcol, wordlarg, 1, cpw);
362 pfcol = pfcol + cpw;
363 if (pfcol>pflen) call endlr;
364 return;
365 end if;
366 ..unpk_env
367 wordlpos = (ws+1);
368 while (wordlpos>cs); $ process characters in turn
369 wordlpos = wordlpos - cs;
370 wordlch = .f. wordlpos, cs, wordlarg;
371 addc(wordlch)
372 end while;
373 end subr wordlr;
374 subr wordsr(ara, lo, hi); $ print ara(lo) to ara(hi).
375 size ara(ws); dims ara(2);
376 size lo(ps); $ starting index.
377 size hi(ps); $ ending index.
378 size i(ps); $ loop index.
379 .+unpk_env. $ if possible, unpack directly into pfl.
380 size nc(ps); $ number of characters.
381 nc = (hi-lo+1) * cpw;
382 if pfcol+nc <= pflen+1 then $ if can unpack.
383 call 7nunpk$li(pfl, pfcol, ara, lo, nc);
384 pfcol = pfcol + nc;
385 if (pfcol>pflen) call endlr;
386 return;
387 end if;
388 ..unpk_env
389 do i = lo to hi;
390 call wordlr(ara(i));
391 end do;
392 return;
393 end subr wordsr;
394 subr intlr(intarg); $ print integer value (5 digits).
395 access lcpns;
396 size intarg(ws);
397 call intlpr(intarg, 5);
398 end subr intlr;
399 subr tintlr(s, i); $ print text and integer.
400 $ put blanks before start and after end
401 access lcpns;
402 size s(ws); $ string to label integer
403 size i(ws); $ integer to output
404 addc(1r ) textl(s) textl(' = ') intl(i) addc(1r )
405 end subr tintlr;
406 subr intlpr(vin, cols); $ print integer vin in cols columns.
407 $ intlpr outputs a -cols- column integer value for input integer
408 $ -vin-. a new line is begun if less than -p- columns remain
409 $ on the current line. negative and large numbers are handled
410 $ correctly, as is the integer -0 (peculiar to one's complements
411 $ machines).
412 $
413 access lcpns;
414 size v(ws-1); $ value to print, is nonnegative.
415 size vin (ws); $ value to print
416 size colnow (ps); $ current column being output
417 size ifminus(1); $ set to 'yes' if negative input
418 size cols(ps); $ columns to output
419
420 $ end current line if not room for integer.
421 if (cols < 1 ! cols > pflen) return; $ bad call.
422 if (pfcol+cols > pflen+1) call endlr;
423 colnow = pfcol + cols; $ index of last column defined.
424 ifminus = (vin<0); v = iabs(vin);
425
426 if v<10 then $ if only one digit.
427 colnow = colnow - 1;
428 pfl(colnow) = charofdig(v);
429 v = 0; $ indicate conversion complete.
430 else
431 while v > 0 & colnow > pfcol;
432 colnow = colnow - 1;
433 pfl(colnow) = charofdig(mod(v,10));
434 v = v / 10;
435 end while;
436 end if;
437
438 if ifminus then $ if negative, insert minus sign.
439 if colnow > pfcol then $ if room for minus sign.
440 colnow = colnow - 1; pfl(colnow) = 1r-;
441 else v = 1; end if; $ if not room, force truncation error.
442 end if;
443
444 if (v) pfl(pfcol) = 1r*; $ if truncation.
445
446 do colnow = colnow-1 to pfcol by -1;
447 pfl(colnow) = 1r ; end do;
448
449 pfcol = pfcol + cols; $ set ending position.
450 if pfcol>pflen then $ if defined last char in line, write it.
451 call endlr;
452 end if;
453 end subr intlpr;
454 subr octlpr(w, c); $ print -w- in -c- columns in octal.
455 $ print word -w- in octal in no more than -c- columns.
456 access lcpns;
457 size w(ws); $ word to list
458 size c(ps); $ no. of columns to output
459 size p(ps); $ position in -w- during actual output
460
461 if (c+pfcol > pflen+1) call endlr; $ if need new line.
462 p = c*3 + 1;
463 while p > 1;
464 p = p - 3; $ advance to next digit
465 .+wsm3 putcn(charofdig((.f. p, 3, w)));
466 .-wsm3.
467 if p = (ws/3)*3 + 1
468 then putcn(charofdig((.f. p, ws-(ws/3)*3,w)));
469 else putcn(charofdig((.f. p, 3, w)));
470 end if;
471 ..wsm3
472 end while;
473 end subr octlpr;
474 subr hexlpr(hexarg, c); $ print hexarg in hex using c columns.
475 $ list c hexadecimal digits of hexarg
476
477 access lcpns;
478 size hexarg(ws); $ value to list
479 size i(ps); $ do loop index
480 size c(ps); $ number of digits to list
481 size hextab(ps); dims hextab(16); $ conversion table
482 data hextab = 1r0,1r1,1r2,1r3,1r4,1r5,1r6,1r7,1r8,1r9,1ra,1rb,1rc
483 ,1rd,1re,1rf;
484
485 $ start new line if no room for constant.
486 if (pfcol+c > pflen+1) call endlr;
487 do i = 1 to c;
488 putcn(hextab(.f. (c-i)*4 + 1, 4,hexarg + 1));
489 end do;
490 end subr hexlpr;
491
492 macdrop(addc)
493 macdrop(putcn)
494 $ end of lcp procedures.
1 .=member getapp
2 subr getapp(s, sl); $ get actual parameter string.
3 size s(.sds. getapp_len);
4 size sl(ps); $ maximum length of s.
5 size key(ps), code(ps), ifpres(ps), ifval(ps);
6
7 call reados(5, code, ifpres, ifval, sl, s);
8
9 end subr getapp;
1 .=member getipp
2 subr getipp(pvar, pstr); $ get i-nteger p-rogram p-arameter.
3 size pvar(ws); $ variable to receive value.
4 size pstr(.sds. (2*spplen));
5 size eqpos(ps); $ index of '='.
6 size slpos(ps); $ index of '/'.
7 size p1pos(ps); $ index of start of value field.
8 size p2pos(ps); $ index of end of value field.
9 size ifpres(1); $ set if parameter present.
10 size ifval(1); $ set if value specified.
11 size inval(ws); $ set to numeric value if given.
12 size isval(.sds. spplen); $ set to string value if given.
13 size i(ps); $ loop index.
14 size val(ws); $ numeric value.
15 size plen(ps); $ length of parameter code string.
dsb 26 size d(ws); $ digit during conversion.
16
17 plen = slen pstr;
18 eqpos = '=' .in. pstr; slpos = '/' .in. pstr;
19 if (slpos=0) return;
20 if (eqpos<=1 ! eqpos>=spplen) return;
21
22 call reados(1,(.s. 1, eqpos-1, pstr), ifpres, ifval, inval,isval);
dsh 24 .+s32v.
dsh 25 $ for vax vms, copy arg string and fold to upper case.
dsh 26 size ustr(.sds. (2*spplen));
dsi 64 ustr = .s. 1, eqpos-1, pstr;
dsi 65 call stpc(ustr); $ convert to primary case.
dsi 66 call reados(1,ustr, ifpres, ifval, inval,isval);
dsh 30 ..s32v
23
24 val = 0;
25
26 if ifpres then $ if present.
27 if ifval then $ if value given, use it.
28 pvar = inval;
29 return;
30 else $ if present, no value, take alternate.
31 if (slpos = plen) go to getstandard;
32 p1pos = slpos+1; p2pos = plen;
33 end if;
34 else $ if not given, take standard default.
35 /getstandard/
36 p1pos = eqpos+1; p2pos = slpos-1;
37 end if;
38
39 do i = p1pos to p2pos;
dsb 27 d = digofchar((.ch. i, pstr)); $ get value assuming digit.
dsb 28 if (d<0 ! d>9) cont do; $ ignore if not digit.
dsb 29 val = 10*val + d;
41 end do;
42 pvar = val;
43 return;
44 end subr getipp;
1 .=member getspp
2 subr getspp(pvar, pstr); $ get s-tring p-rogram p-arameter.
3 size pvar(.sds. spplen); $ variable to receive value.
4 size pstr(.sds. (2*spplen));
5 size eqpos(ps); $ index of '='.
6 size slpos(ps); $ index of '/'.
7 size p1pos(ps); $ index of start of value field.
8 size p2pos(ps); $ index of end of value field.
9 size ifpres(1); $ set if parameter present.
10 size ifval(1); $ set if value specified.
11 size inval(ws); $ set to numeric value if given.
12 size isval(.sds. spplen); $ set to string value if given.
13 size i(ps); $ loop index.
14 size val(ws); $ numeric value.
15 size plen(ps); $ length of parameter code string.
16
17 plen = slen pstr;
18 eqpos = '=' .in. pstr; slpos = '/' .in. pstr;
19 if (slpos=0) return;
20 if (eqpos<=1 ! eqpos>=spplen) return;
21
22 isval = '' .pad. spplen;
23
24
25 call reados(3,(.s. 1, eqpos-1, pstr), ifpres, ifval, inval,isval);
dsh 31 .+s32v.
dsh 32 $ for vax vms, copy arg string and fold to upper case.
dsh 33 size ustr(.sds. (2*spplen));
dsi 67 ustr = .s. 1, eqpos-1, pstr;
dsi 68 call stpc(ustr); $ convert to primary case.
dsi 69 call reados(3,ustr, ifpres, ifval, inval,isval);
dsh 37 ..s32v
26
27 val = 0;
28
29 if ifpres then $ if present.
30 if ifval then $ if value given, use it.
dsb 30 i = slen isval;
dsb 31 slen pvar = i;
dsb 32 if i then $ copy value.
dsb 33 sorg pvar = .sds. i + 1;
dsb 34 .s. 1, i, pvar = .s. 1, i, isval;
dsb 35 end if;
32 return;
33 else $ if present, no value, take alternate.
34 if (slpos = plen) go to getstandard;
35 p1pos = slpos+1; p2pos = plen;
36 end if;
37 else $ if not given, take standard default.
38 /getstandard/
39 p1pos = eqpos+1; p2pos = slpos-1;
40 end if;
41
dsb 36 if p2pos >= p1pos then
dsb 37 i = p2pos - p1pos + 1; $ length to set.
dsb 38 slen pvar = i; $ set length.
dsb 39 if i then $ if value to copy.
dsb 40 sorg pvar = .sds. i + 1;
dsb 41 .s. 1, i, pvar = .s. p1pos, i, pstr;
dsb 42 end if;
dsb 43 else
dsb 44 slen pvar = 0;
45 end if;
46 return;
47 end subr getspp;
1 .=member lstime
2 .-defenv_lstime.
3 subr lstime(lst); $ get character time.
4 $ lstime determines characters representing current time.
5 $ for example, the next to last second of 23 march 1976
6 $ is represented as follows:
7 $
8 $ ' tue 23 mar 76 23.59.58 '
9 $
10 $ (123456789a123456789b123456789c) .
11 $
12 size ca(cs); dims ca(2); $ user array of characters.
13 size nca(cs); $ number of characters to enter in ca.
14 size ta(ps); dims ta(8); $ lntime array.
15 size i(cs); $ loop index
16 size lst(.sds. lstimelen); $ time string.
17 size names(sds((12+7)*3)); data names = $ day,month names
18 'sunmontuewedthufrisatjanfebmaraprmayjunjulaugsepoctnovdec';
19 size mpos(ps), dpos(ps); $ month, day positions in names.
20 size n(ps), ndiv10(ps); $ for conversion.
21
22 call lntime(ta); $ get numeric times.
dsu 18 lst = '' .pad. lstimelen; $ intialize string.
24 $ convert desired integers in lca.
25 mpos = 3*ta(2) + 18; $ names index of start of month name.
26 ta(2) = ta(1) - 1900; $ get last two digits of year.
27 do i = 14 to 26 by 3; $ convert needed integers.
28 n = ta(i/3-2); ndiv10 = n/10;
29 .ch. i, lst = charofdig(ndiv10);
30 .ch. i+1, lst = charofdig((n - 10*ndiv10));
31 end do;
32 dpos = (ta(8)-1)*3; $ position for day of week.
33 do i = 1 to 3;
34 .ch. i+8, lst = .ch. i+16, lst; $ move day.
35 .ch. i+15, lst = .ch. i+13, lst; $ move year.
36 .ch. i+3, lst = .ch. dpos+i, names;
37 .ch. i+11, lst = .ch. mpos+i, names;
38 end do;
39 .ch. 15, lst = 1r ; .ch. 18, lst = 1r ;
40 .ch. 22, lst = 1r: ; .ch. 25, lst = 1r: ;
41 end subr lstime;
42 ..defenv_lstime
1 .=member lctime
2 .-defenv_lctime.
3 subr lctime(lca, lcalen); $ get string time as array of chars.
4 size lca(cs); dims lca(2); $ array of characters.
5 size lcalen(ps); $ number of characters to receive.
6 size lststr(.sds. lstimelen); $ time-date string.
7 size i(ps); $ loop index.
8 call lstime(lststr); $ get string time.
9 do i = 1 to lcalen;
10 if (i>lcalen) quit do;
11 lca(i) = .ch. i, lststr;
12 end do;
13 do i = lstimelen+1 to lcalen; lca(i) = 1r ; end do;
14 return;
15 end subr lctime;
16 ..defenv_lctime
1 .=member dumpaq
2 subr dumpaq(text, array, low, high);
3
4 $ this procedure dumps 'array' from index 'low' to 'high',
5 $ four elements per line. the first line is blank, the next is
6 $ 'dump of array ' !! text, and the remaining contain the array
7 $ elements. each array element is preceded by its index in
8 $ decimal. the element is dumped in machine form.
9 size text(ws+1); $ parameter, array name
10 size array(ws); $ parameter, array to dump.
11 size low(ps); $ parameter, starting index of array.
12 size high(ps); $ parameter, ending index of array.
13 size l(ps); $ current line number.
14 size index(ps); $ current index being dumped.
15 size nlines(ps); $ number of lines needed.
16 +* dumpentpl = $ number of entries per line.
17 ((pflen-1)/(bwordlen+8)) **
18 dims array(1); $ dummy dimension.
19
20 endl $ blank line
21 textl(' dump of array ') textl(text) endl
22
23 nlines = (high-low+dumpentpl)/dumpentpl; $ set number of line
24
25 do l = 1 to nlines; $ loop for printing lines.
26 index = l + low - 1; $ initialize index.
27
28 while index <= high; $ place dumpentpl items in a line.
29 charl(1r ); $ skip one space.
30 intl(index); $ output index in decimal.
31 textl('. ');
32 bwordl(array(index)); $ dump array element.
33 index = index + nlines; $ set index for next element.
34 end while;
35
36 endl; $ print a line
37 end do;
38
39 return;
40 macdrop(dumpentpl)
41 end subr dumpaq; $ dumpa
1 .=member termio
dsc 61 subr opnterm(filename); $ open terminal file
3 $ this procedure opens the terminal file used by the
4 $ compiler, via -lcp-, to isolate error messages.
dsc 62 size filename(sds(filenamelen)); $ file name
6 size iocc(ws); $ io completion code.
7 size lenopn(ps); $ line size obtained.
8
9 if (pftermopen) return; $ do nothing if already open.
dsi 70 call eretsio(termfilenumber, iocc, yes); $ set to return error.
10 call opensio(termfilenumber, iocc, access_print,
dsc 63 filename, pflen, lenopn, 0, 0);
dsi 71 pftermopen = (iocc = 0); $ show term file open if ok.
dsi 72 call eretsio(termfilenumber, iocc, no); $ set to quit on error.
13 end subr opnterm;
14 subr clsterm; $ close term file if open.
15 access lcpns;
16 size iorc(ps); $ io return code.
17 if (pftermopen) call clossio(termfilenumber, iorc);
18 pftermopen = no;
19 end subr clsterm;
1 .=member linepak
2 .-defenv_linepak.
3 subr linepak(pa, ua, lchars);
4 $ linepak takes the -nchars- characters in array ua which are
5 $ unpacked (one char word) and packs theminto array -pa-
6 $ the last wordof -pa- is filled with blanks, if appropriate.
7
8 size pa(ws); $ array into which we pack
9 size ua(cs); $ input array of input chars
10 size lchars(ps); $ num of chars to pack
11 size paword(ws); $ packed word temporary
12 size paptr(ps); $ pointer to pa
13 size papos(ps); $ last position in paword being build
14 size i(ps); $ do-loop temporary
15 dims pa(2), ua(2); $ dummy dims for parameters
16
17 paptr = 1;
18 papos = (ws+1); $ current position in pa
19 paword = blankword;
20 pa(1) = paword;
21 do i = 1 to lchars; $ pack charactrs in turn
22 papos = papos-cs;
23 .f. papos, cs, paword = ua(i);
24 if ( papos > 1) cont do;
25 $ finished current word
26 pa(paptr) = paword;
27 paword = blankword;
28 paptr = paptr+1;
29 papos = (ws+1);
30 end do;
31 $ if not packing integral no of words, store last word
32 if (papos ^= ws+1) pa(paptr) = paword;
33 end subr linepak;
34 ..defenv_linepak
1 .=member gobyerm
2 subr gotoem(index); $ prints diagnostic for bad goby index
3
4 $ this procedure is called from 7ngoto$er to print out diagnostic
5 $ information after bad goby argument detected.
6
7 size index(ws); $ bad index value
8
9 endl textl(' execution terminated - bad go to index ')
10 intlp(mradix, 1) textl('b''') bwordl(index) charl(1r') endl
11 call ltlfin(1, 1002); $ bad go to index.
12 end subr gotoem;
1 .=member incio
2 subr opninc(inputname, inimemname, includecode, updarg);
3 /*
4 open input file with included text processing.
5 inputname is name of input file; if null, use standard
6 input file. if inimemname is not null, it is name of
7 member to be included before reading input file.
8 if includecode is not null, it gives the initial pattern
9 which defines an include directive.
10 updarg is nonzero if input lines from standard input file
11 contain 8 characters of upd sequence information at the
12 start of a line which is to be removed.
13 */
14
15 $ inputname and inimemname are null to access default
16 $ input and library files, respectively.
17 size inputname(.sds. filenamelen); $ name of input file.
18 size inimemname(.sds. filenamelen); $ name of initial member.
19 size includecode(.sds. filenamelen); $ code for include.
20 size updarg(ps); $ upd sequence option.
21
22 size iname(.sds. filenamelen);
23 size i(ps), l(ps); $ loop indexes.
24
25 nameset inclio; $ globals for include processing.
26 $ inclev is the inclusion level. inclev is one when reading
27 $ the standard input file.
28 size inclev(ps); $ depth of inclusion.
dsc 64 data inclev = 1;
29
30 $ filenow is sio file value for the current file.
31 $ inpfile is the sio file value for the input file.
32 $ incfile is the sio file value for the include library.
33 $ incfile is initially zero, indicating that the include
34 $ library is not yet open. in this way opening the include
35 $ library and allocation of buffers can be deferred until
36 $ first include request seen.
37 size incfilenow(ps); $ current file.
38 size incfile(ps); size inpfile(ps);
dsc 65 data incfile = 0; $ indicate file not open.
dsc 66 data inpfile = 1; $ standard input file.
39
40 $ lastpos(i) is the number of lines read at inclusion level i.
41 $ lastpos is used to reposition within library when includes
42 $ are nested.
43 size lastpos(.ps.); dims lastpos(inclevmax);
44
45 $ curpos is number of lines read since inclusion library
46 $ opened or rewound.
dsc 67 size curpos(ws); data curpos = 0;
48
49 size updseq(ps); $ nonzero if upd sequence field.
50 $ the string idcode contains the codes for the include and
51 $ member directives. idcodelen gives the lengths of the
52 $ directives.
53 size idcode(.sds. 21); $ codes for include and member
54 data idcode = ' .=include .=member ';
55 size idcodelen(ps); dims idcodelen(2); data idcodelen = 11, 10 ;
56
57 $ memname is set by isidir to the member name if a directive
58 $ seen. a length of zero indicates directive not present.
59 size memname(.sds. filenamelen);
60 data memname = '';
61 $ memnext is set to name of next member when a member line is
62 $ encountered during text inclusion.
63 size memnext(.sds. filenamelen); data memnext = '';
64 end nameset;
65
68 updseq =updarg;
69
70 $ copy code for include, at most 11 characters.
71 l = slen includecode;
72 if (l < 3) l = 0; $ require at least three chars.
73 if (l > 11) l = 11;
74 do i = 1 to l;
75 .ch. i, idcode = .ch. i, includecode;
76 end do;
77 if (l) idcodelen(1) = l;
dsk 57 .+mc call stpc(idcode); $ convert to primary case.
78
79 incfilenow = inpfile; $ begin with input file.
82 if slen inimemname then $ if initial include, start it.
83 memname = inimemname;
dsk 58 .+mc call stpc(memname); $ convert to primary case.
84 call posinc(0);
85 incfilenow = incfile;
86 end if;
87
88 end subr opninc;
89 subr clsinc; $ close input (inclusion) file.
90 access inclio;
91 size iorc(ps); $ io return code.
92 if (incfile > 0) call clossio(incfile, iorc);
93 end subr clsinc;
94 subr isidir(code,uara,ulo,uhi); $ look for include or member.
95 access inclio;
96 $ code is 1 for include, 2 for member.
97 $ build line.
98 size code(ps); $ type of directive sought.
99 size uara(ws), ulo(ps), uhi(ps); $ line is uara(lo) to uara(hi).
100 dims uara(2);
101 size uaralo(ws); $ uara(ulo)
102 size c(cs); $ character.
103 size line(.sds. (cpw*wpc)); $ sds form of line.
104 size linewds(ps); $ words in line.
105 size ld(ps); $ length of desired directive.
106 size i(ps); $ loop indexes.
107 size porg(ps); $ start of parameter.
108 size pend(ps); $ end of parameter.
109 size plen(ps); $ length of parameter.
110 size corg(ps); $ origin of directive code in idcode.
111 size linemax(ps);
ldsd 11 size anyc(ps),nayc(ps); $ string search functions
dsk 59 .+mc size ctpc(cs); $ converts to primary case
112
113 +* lorg = (.sds. (cpw*wpc) + 1) **
114
115 $ look at first two characters in turn. if they match,
116 $ convert line to string and compare rest of characters.
117 .len. memname = 0; $ clear memname.
118 corg = (code-1) * 11;
119 uaralo = uara(ulo);
120 c = .f. ws+1 - cs, cs, uaralo; $ first char.
121 if (c ^= .ch. corg+1,idcode) return;
122 c = .f. ws+1 - 2*cs, cs, uaralo; $ second char.
123 if (c ^= .ch. corg+2,idcode) return;
124 $ first two chars match, take the long route.
125 linewds = (uhi-ulo+1);
126 if (linewds > wpc) linewds = wpc;
127 linemax = linewds * cpw;
128 do i = 1 to linewds;
129 .f. lorg - i*ws, ws, line = uara(ulo+i-1);
130 end do;
131 sorg line = lorg;
132 slen line = cpw * linewds;
133 .ch. (cpw*linewds-1), line = 1r); $ in case all blanks.
134 .ch. (cpw*linewds), line = 1r ;
dsk 60 .+mc call stpc(line); $ convert to primary case.
135 ld = idcodelen(code); if (ld = 2) go to found;
136 do i = 1 to ld;
dsd 10 $ fail by returning if no match.
dsk 61 if (.f. lorg - i*cs, cs, line)
dsk 62 ^= (.ch.corg+i,idcode) then return; end if;
139 end do;
140 $ is desired card, get member name.
141 /found/
142 porg = 2;
ldsd 12 while nayc((.ch. porg, line) ,2); $ skip to end of directive.
144 porg = porg + 1;
145 end while;
ldsd 13 while anyc((.ch. porg, line), 2); $ skip to start of member name
147 porg = porg + 1;
148 if (porg > linemax) return; $ if no name present, quit.
149 end while;
150 pend = porg;
ldsd 14 while nayc((.ch. pend, line), 2);
152 if (pend > linemax) return; $ if no name present, quit.
153 pend = pend + 1;
154 end while;
155 pend = pend - 1;
156 $ remove enclosing quotes or parentheses.
157 porg = porg + ((.ch. porg, line) = 1r');
158 porg = porg + ((.ch. porg, line) = 1r();
159 pend = pend - ((.ch. pend, line) = 1r');
160 pend = pend - (.ch. pend, line = 1r));
161 if (porg > pend) return; $ if param is only quotes and parens,
162 porg = porg - 1;
163 plen = pend - porg;
164 $ copy parameter name into member name, truncating long name.
165 if (plen > memnamelenmax) plen = memnamelenmax;
166 memname = .s. porg+1, plen, line;
167 return;
168 +* lorg = **
169 end subr isidir;
170 subr getinc(uara, ulo, uhi, udone); $ read with include processin
171 access inclio;
172 size uara(ws); dims uara(2); $ array to read.
173 size ulo(ps), uhi(ps); $ read uara(lo) to uara(hi).
174 size udone(1); $ set when end of input.
175 size endseen(ws); $ end of data indicator.
176 size i(ps);
177 size iwd(ws); $ dummy for read during skip.
178
179 $ read until line emerges or input exhausted.
180 while 1;
181 call getwsio(incfilenow,endseen,uara, ulo, (uhi-ulo+1)*cpw);
182 $ see if need to move upd sequence information.
183 if endseen=no & updseq=1 & incfilenow=inpfile then
184 call updinc(uara, ulo, (uhi-ulo+1));
185 end if;
186 if inclev > 1 then $ if including, member is end.
187 if endseen = no then
188 call isidir(2, uara, ulo, uhi);
189 endseen = (slen memname) > 0;
190 $ save name if including at first level.
191 if endseen & inclev=2 then
192 memnext = memname;
193 end if;
194 curpos = curpos + 1;
195 else .len. memnext = 0; $ if no next member.
196 end if;
197 end if inclev;
198 if endseen then $ if end, terminate if including, else done
199 if inclev = 1 then
200 udone = yes;
201 return;
202 else
203 call posinc(1); $ terminate include.
204 cont while;
205 end if inclev;
206 end if endseen;
207
208 $ line read, look for include.
209 call isidir(1, uara, ulo, uhi);
210 if slen memname then $ if include, save place, start includ
211 call posinc(0);
212 cont while;
213 else
214 quit while;
215 end if;
216 end while;
217
218 $ line available, return it.
219
220 udone = no;
221 end subr getinc;
222 subr posinc(ending); $ position inclusion file.
223 access inclio;
224 $ begin inclusion. increment inclusion level, locate desired
225 $ member. if member not found, issue warning and restore.
226 $ ending is zero to begin include, one to terminate include.
227 size ending(ps); $ nonzero to terminate.
228 size done(ws); $ end of data indicator.
229 size i(ps); $ loop index.
230
231 $ incline is the current line image.
232 size incline(ws); dims incline(wpc); $ line read in.
233 size iwd(ws); $ dummy for read during skip.
234 $ memwant is the desired member name when include begins.
235 size memwant(.sds. filenamelen);
236 size iorc(ps); $ io return code.
237 size startsearch(ws); $ starting position for search.
238 size eofok(ps); $ flag for search.
239
240 if (ending) go to restoreit;
241 memwant = memname; $ save desired member name.
242 if incfile = 0 then $ if include file not opened, open it.
243 call opensio(incfilenumber, iorc, access_get,
244 inclibname, cpw*wpc, i, 0, 0);
dsl 8 if iorc then $ if unable to open.
dsla 2 call remarkl(inclibname);
dsl 9 textl('error - unable to open inclusion file ')
dsl 10 textl(inclibname) endl
dsl 11 call ltlfin(1,1010);
dsl 12 end if;
245 incfile = incfilenumber;
246 end if;
247
248 lastpos(inclev) = curpos; $ save position within library.
249 inclev = inclev + 1;
250 incfilenow = incfile;
251 if inclev > inclevmax then $ if depth too great, abort.
252 textl('maximum include depth exceeded.') endl
253 call ltlfin(1, 1003); $ inclusion depth too great.
254 end if;
255
256 $ if prior include terminated by encountering member line for
257 $ member now desired, can just continue reading.
258 if (memwant .seq. memnext) return;
259 .len. memnext = 0; $ else reset memnext.
260 eofok = yes; $ ok to search past eof.
261 startsearch = curpos; $ starting point for end-around search.
262
263 while 1;
264 call getwsio(incfile, done, incline, 1, wpc*cpw);
265 if done then
dsd 14 if (eofok=no) quit while;
267 eofok = no; $ indicate part 1.
268 call rewisio(incfile, iorc, 0);
269 curpos = 0; $ indicate at start of file.
270 cont while;
271 end if;
272 curpos = curpos + 1;
dsd 15 if (eofok=no & curpos>startsearch) quit while;
274 call isidir(2, incline, 1, wpc); $ look for member line.
dsd 16 if (memwant .seq. memname) return;
276 end while;
dsd 17 $ member not present, print warning and restore.
280 textl(' ***error*** member ') textl(memwant)
281 textl(' not found, include ignored.') endl
282 /restoreit/
283 inclev = inclev - 1;
284 if inclev > 1 then $ if still including, restore pl
285 if lastpos(inclev)<= 0) ! (crfnum > 9) then $ if bad num. param.
14 textl('crfnam - bad file number ') intl(crfnum) endl
15 go to crfabt;
16 end if;
17 crfname = crfparm;
18 do l = slen crfparm to 1 by -1;
19 c = .ch. l, crfname;
20 do i = 1 to 10;
21 if .ch. i, '0123456789' = c then
22 .ch. l, crfname = charofdig(crfnum);
23 return;
24 end if;
25 end do;
26 end do;
27 $ error numeric to substitute not found.
28 textl('crfnam - missing numeric character in file name ')
29 textl(crfname) endl
30 /crfabt/
31 call ltlfin(1, 1004); $ bad reference file name.
32 end subr crfnam;
1 .=member reados
2 subr reados(key, code ,ifpres, ifval, inval, isval);$ read options
3 /*
4 obtain the user-supplied option string.
5 parameters are as follops:
6 key - desired action
7 1 - integer valued parameter
8 2 - octal valued parameter
9 3 - string valued parameter
10 4 - set inval to number of parameters and return
11 -i - set ifpres if i-th parameter available; if so, set
12 code to parameter, isval to value.
13 code - string giving parameter code
14 ifpres - switch indicating if parameter present
15 ifval - switch indicating if value supplied.
16 inval - numeric value given (key = 1,2)
17 isval - string value given (key=3)
18
19 the parameter string is obtained by the procedure -readsos-
20 which returns the parameter string as an array of characters.
21 the parameter string may not contain internal instances of , or );
22 blanks are ignored.
23 */
24
25 size key(ws); $ option desired
26 size code(sds(ospmax)); $ parameter code
27 size ifpres(1); $ set on if parameter supplied
28 size ifval(1); $ set if value supplied
29 size inval(ps); $ supplied numeric value
30 size isval(sds(ospmax)); $ supplied string value
31 size cc(ps); dims cc(oscmax); $ character array holding string
32 size cclen(ps); data cclen = oscmax-1; $ length of supplied str.
33 size nparms(ps); data nparms=0; $ number of supplied parameters
34 size ip(ps); $ parameter index
35 size i(ps), l(ps); $ loop indices, lengths
36 size c(ps); $ current character
37 size firstcall(1); data firstcall=1; $ to trap first call
38 size porg(ps); $ index of start of parameter, 0 if no proaram
39 size vorg(ps); $ index of start of value, 0 if no value
40 size plen(ps); $ number of characters in parameter
41 size vlen(ps); $ number of characters in value portion
42 size inc(ps); $ 1 when inside parameter, 0 when in value part
43 size ccp(ps); $ position in cc
44 size base(ps); $ arithmetic base for numeric conversion
dsb 45 size d(ws); $ digit value during numeric conversion.
plf 20 .+plf1 size passcom(1); $ on to pass commas to argument
45
46 if firstcall then $ if first time, get param string
47 firstcall = 0;
48 call readsos(cc, cclen); $ cclen set to length of string
49 $ on entry gives maximum allowed.
dsf 51
50 cclen = cclen+1; cc(cclen) = 1r, ;
51 /* terminal , simplifies scan */
plf 21 .+plf0.
52 do i = 1 to cclen; nparms = nparms + (cc(i)=1r,); end do;
plf 22 ..plf0
plf 23 .+plf1.
plf 24 $ take comma as separator, unless between [ (or <) and ] (or>).
plf 25 passcom = no;
plf 26 do i = 1 to cclen;
plf 27 c = cc(i);
dsn 18 if (c=1r[ ! c=1r< ! c=1r() & passcom=no then
dsn 19 passcom = yes;
dsn 20 elseif (c=1r] ! c=1r> ! c=1r)) & passcom=yes then
dsn 21 passcom = no;
plf 30 elseif (c=1r,) & passcom = no then nparms = nparms+1;
plf 31 end if;
plf 32 end do;
plf 33 ..plf1
53 end if;
54
55 if key=4 then $ if want number of parameters available
56 inval = nparms; return; end if;
57
dsc 68 if key=5 then $ if want full parameter string.
dsc 69 l = cclen-1; $ determine number of chars to copy.
dsc 70 if (l > inval) l = inval; $ if actual string too long.
dsc 71 .len. isval = l; $ set length of result.
dsc 72 sorg isval = 1 + (.sds. l);
dsc 73 do i = 1 to l; $ copy into isval.
dsc 74 .ch. i, isval = cc(i);
dsc 75 end do;
dsc 76 return;
dsc 77 end if;
dsc 78
58 ifpres = 0; ifval = 0; inval = 0; ccp = 0;
59
plf 34 .+plf1 passcom=no;
60 do ip = 1 to nparms;
61 porg = ccp; vorg = 0; plen = 0; vlen = 0;
62 inc = 1; $ 1 when inside parameter, 0 when inside val
63 while 1; $ scan parameter
64 ccp = ccp + 1;
plf 35 .+plf0.
65 if (cc(ccp)=1r,) quit while; $ end seen
plf 36 ..plf0
plf 37 .+plf1.
plf 38 $ take comma as separator, unless between [ (or <) and ] (or>).
plf 39 c = cc(ccp);
dsn 22 if (c=1r[ ! c=1r< ! c=1r() & passcom=no then
dsn 23 passcom = yes;
dsn 24 elseif (c=1r] ! c=1r> ! c=1r)) & passcom=yes then
dsn 25 passcom=no;
plf 42 elseif (c=1r,)&(passcom=no) then quit while;
plf 43 end if;
plf 44 ..plf1
66 if (cc(ccp) = 1r= ) then $ switch to value part
67 vorg = ccp; inc = 0; cont while; end if;
68 plen = plen + inc; vlen = vlen + (1-inc);
69 end while;
70
71 if key = -ip then $ if want this parameter
72 ifpres = 1; ifval = (vlen ^=0);
73 l = slen code; if (l>plen) l=plen;
74 do i = 1 to l;
75 .ch. i, code = cc(porg+i); end do;
76 slen code = l;
77 l = slen isval; if (l>vlen) l=vlen;
78 do i = 1 to l;
79 .ch. i, isval = cc(vorg+i); end do;
80 slen isval = l;
81 return;
82 end if;
83
84 if key>0 then $ if looking for param, this may be it
85 if slen code ^= plen then cont do; end if;
86 do i = 1 to plen;
87 if (.ch. i, code ^= cc(porg+i)) cont do ip;
88 end do;
89 $ parameter found, process value
90 ifpres = 1;
91 ifval = (vlen ^= 0);
92 go to l(key) in 1 to 3;
93 /l(1)/ base = 10; go to conv;
94 /l(2)/ base = 8;
95 /conv/ $ convert numeric value
96 do i = 1 to vlen;
dsb 46 d = digofchar(cc(vorg+i)); $ get value if digit.
dsb 47 if (d<0 ! d>9) cont do; $ ignore if not digit.
dsb 48 inval = inval*base + d;
98 end do;
99 return;
100 /l(3)/
101 l = vlen;
102 if (l>slen isval) l = slen isval;
103 do i = 1 to l;
104 .ch. i, isval = cc(vorg + i); end do;
105 slen isval = l;
106 return;
107 end if;
108
109 end do ip;
110 /* if reach here, parameter not found */
111 end subr reados;
1 .=member ltlxtr1
dsv 81 .+s10.
dsv 82 subr ltlxt1; $ dummy ltlxt1 for completion by mccann.
dsv 83 end subr ltlxt1;
dsv 84 ..s10
dsv 85 .+s11.
dsv 86 subr ltlxt1(cursp, initsp); $ produce trace back chain.
dsv 87 $ this procedure is invoked by -ltlxtr- when a listing of
dsv 88 $ the current trace back chain is desired.
dsv 89 size cursp(ws); $ stack pointer at time of call.
dsv 90 size initsp(ws); $ stack pointer at program init.
dsv 91
dsv 92 size 7nmget$li(ws); $ memory read routine.
dsv 93 size scanptr(ps); $ current scanning position in stack.
dsv 94 size endscan(ps); $ highest address in stack.
dsv 95 size tempadr(ps); $ temporary.
dsv 96 size i(ps); $ temporary.
dsv 97 size calladr(ps); $ address of -call-.
dsv 98 size ascii(cs); $ array to hold routine names.
dsv 99 dims ascii(9); $ number of chars in routine name.
dsv 100
dsv 101 scanptr = .f. 2, ps, cursp; $ get word value of stack pointer.
dsv 102 endscan = .f. 2, ps, initsp; $ get initial word initial stack ptr
dsv 103 endl; endl; $ leave two blank lines.
dsv 104 textl('trace back chain') endl endl $ print heading.
dsv 105
dsv 106 $ now scan the programs stack looking for the address of calls.
dsv 107 until scanptr = endscan; $ until scan completed.
dsv 108 tempadr = 7nmget$li(scanptr); $ get contents of stack.
dsv 109 tempadr = .f. 2, ps, tempadr; $ get word address value.
dsv 110 if 7nmget$li(tempadr-2) = 3b'4767' then $ could be -call-.
dsv 111 calladr = tempadr - 2; $ get address of call statement.
dsv 112 $ now get address of called routine.
dsv 113 tempadr = tempadr - 3 + .f. 2, ps, (7nmget$li(tempadr-1));
dsv 114 if 7nmget$li(tempadr+3) = 3b'4567' then $ is call.
dsv 115 call 6nrad$li(tempadr, ascii); $ convert rad50 -> as
dsv 116 do i = 1 to 9; $ write out routine name.
dsv 117 if (ascii(i) = 1r ) quit do; $ if end of name -
dsv 118 charl(ascii(i)) $ write out this part of name.
dsv 119 end do i;
dsv 120
dsv 121 textl(' called from location ')
dsv 122 octlp(calladr, 6) endl $ end line.
dsv 123 end if;
dsv 124 end if;
dsv 125
dsv 126 scanptr = scanptr + 1; $ back up stack.
dsv 127 end until;
dsv 128
dsv 129 end subr ltlxt1;
dsv 130 ..s11
2 .+s66.
3 subr ltlxtr1(locfrom); $ print part of trace back package
4 $ this procedure prints subroutine trace back chain as diagnostic ai
5 $ is it called from ltlxtr, which sets up argument locfrom as
6 $ location of most recent call.
7 $ implementation is necessarily system-dependent.
8
9 $ this cdc version assumes ftn calling conventions have been used,
10 $ and traces back at most 20 levels.
11
12 size locfrom(ws); $ location of most recent call
13 size memget(ws); $ returns contents in indicated memory wd.
14 size loc(ws); $ current location
15 size levels(ws); $ number of procedures traced back
16 size lineno(ws); $ line number withing procedure
17 size name(ws); $ entry word
18 size memname(ws); $ memget(name)
19 size ientry(ws); $ header word for procedure
20 size mentry(ws); $ memget(ientry)
21 size lname(ws); $ display code name of procedure
22 size memloc(ws); $ value of current loc
23
24 loc = locfrom; levels = 0;
25 endl textl(' trace back chain') endl
26 /next/
27 memloc = memget(loc); $ word with call
28 if .f. 49, 12, memloc ^= 3b'0100' then
29 $ quit if not subroutine call (return jump)
30 return; end if;
31 levels = levels + 1; if (levels >20) return;
32 $ avoid tracing too much, or infinite loop if core clobberec
33 lineno = .f. 19, 12, memloc; $ line number of call
34 name = .f. 1, 18, memloc; $ addr of header word for procedure
35 memname = memget(name); $ header word for procedure
36 ientry = .f. 1, 18, memname; $ true entry word
dsv 131 if (ientry=0) ientry = name+1; $ if cdc quirk.
38 mentry = memget(ientry);
39 lname = memname; .f. 1, 18, lname = 3r ; $ display code name
40
41 textl(' called by ') wordl(lname) textl(' at line ')
42 intl(lineno) textl(', location ') addrl(loc) endl
43
44 if .f. 49, 12, mentry ^= 3b'0400' then
45 $ quit if no further calls to process
46 return; end if;
47 loc = .f. 31, 18, mentry-1; $ address of previuus call
48 go to next;
49
50 end subr ltlxtr1;
51 ..s66
1 .=member ltlregl
2 subr ltlregl(regs); $ list machine register contents
3
4 $ this system-dependent procedure lists contents of machine register
5 $ contents, and is used for diagnostic purposes.
6 $ called from ltlregs, which sets up -regs- in system-dependent way.
7
8 .+s10.
9 size regs(ws); dims regs(16); $ general registers.
10 size i(ps); $ loop index.
11
12 endl textl('register contents') endl
13 do i = 1 to 16;
14 if i > 10 then textl(' r') intlp(i-1,2)
15 else textl(' r') intlp(i-1,1) end if;
16 textl(' ')
17 bwordl(regs(i))
18 if (mod(i, 4) = 0) endl $ four registers per line.
19 end do;
20 ..s10
21 .+s11.
22 size regs(ws); $ define register array.
23 dims regs(8);
24 size i(ps); $ temporary.
25
26 endl
27 textl('contents of registers') endl $ title output.
28 do i = 1 to 6; $ loop until registers are done.
29 textl(' r') intlp(i-1, 1) textl(' ') $ identify register.
30 bwordl(regs(i)) $ print contents of register.
31 if (mod(i, 4)=0) endl $ 4 registers per line
32 end do;
33
34 textl(' sp ') bwordl(regs(6)) endl
35 ..s11
vax 23 .+s32.
vax 24 size regs(ws); dims regs(16); $ general registers.
vax 25 size i(ps); $ loop index.
vax 26
vax 27 endl textl('contents of general purpose registers.') endl
vax 28 do i = 1 to 16;
vax 29 if i > 10 then textl(' r') intlp(i-1,2)
vax 30 else textl(' r') intlp(i-1,1) end if;
vax 31 textl(' ')
vax 32 bwordl(regs(i))
vax 33 if (mod(i, 4) = 0) endl $ four registers per line.
vax 34 end do;
vax 35 ..s32
36 .+s37.
37 size regs(ws); dims regs(16); $ general registers.
38 size i(ps); $ loop index.
39
40 endl textl('contents of general purpose registers.') endl
41 do i = 1 to 16;
42 if i > 10 then textl(' r') intlp(i-1,2)
43 else textl(' r') intlp(i-1,1) end if;
44 textl(' ')
45 bwordl(regs(i))
46 if (mod(i, 4) = 0) endl $ four registers per line.
47 end do;
48 ..s37
utsa 62 .+s47.
utsa 63 size regs(ws); dims regs(16); $ general registers.
utsa 64 size i(ps); $ loop index.
utsa 65
utsa 66 endl textl('contents of general purpose registers.') endl
utsa 67 do i = 1 to 16;
utsa 68 if i > 10 then textl(' r') intlp(i-1,2)
utsa 69 else textl(' r') intlp(i-1,1) end if;
utsa 70 textl(' ')
utsa 71 bwordl(regs(i))
utsa 72 if (mod(i, 4) = 0) endl $ four registers per line.
utsa 73 end do;
utsa 74 ..s47
49 .+s66. $ cdc 6000 series...
50 $ -regs- contains registers in order a0-a7, b0-b7, x0-x7.
51 size regs(ws); dims regs(24);
dsv 132 .+s10.
dsv 133 size regs(ws); dims regs(16); $ general registers.
dsv 134 size i(ps); $ loop index.
dsv 135
dsv 136 endl textl('contents of general purpose registers.') endl
dsv 137 do i = 1 to 16;
dsv 138 if i > 10 then textl(' r') intlp(i-1,2)
dsv 139 else textl(' r') intlp(i-1,1) end if;
dsv 140 textl(' ')
dsv 141 bwordl(regs(i))
dsv 142 if (mod(i, 4) = 0) endl $ four registers per line.
dsv 143 end do;
dsv 144 ..s10
52 size i(ps); $ do loop index
53
54 endl textl(' contents of machine registers ') endl
55 do i = 1 to 8;
56 textl(' a') intlp(i-1,1) skipl(2)
57 addrl(regs(i))
58 textl(' b') intlp(i-1,1) skipl(2)
59 addrl(regs(i+8))
60 textl(' x') intlp(i-1,1) skipl(2)
61 bwordl(regs(i+16))
62 endl
63 end do;
64 ..s66
65
66 end subr ltlregl;
1 .=member readsos
2 .-defenv_readsos.
3 subr readsos(cc, cclen); $ obtain option string from system
4
5 /* this system-dependent procedure obtains the option string.
6 the string is entered as an array of characters in -cc-.
7 on entry, cclen gives maximum characters that may be set;
8 on exit, cclen is the number of characters in the string.
9 */
10
11 size cc(ws); dims cc(2); $ array of option characters
12 size p(ws); $ length of option string
13 size cclen(ws); $ max. length of option string on entry,
14 $ true length on exit.
15
16 p = 0; $ assume no option string supplied.
17
18 .+s66.
19 /* for cdc 6000 systems, we require that the user supply the
20 string enclosed in parentheses after the standard execution
21 header, as in 'little(in,out) (optionstring)'.
22 the system places the string in absolute locations 70-77b,
23 marking the end of string with a 00 byte. our job here
24 is to skip past the prefix, which is terminated by . or ),
25 then to locate the ( marking the start of the list, and
26 finally accumulate options until ) seen.
27 we use a simple automaton to record our status.
28
29 memget is a library procedure which reads absolute core.
30
31 */
32 size i(ps), j(ps); $ loop indices
33 size memget(ws); $ system function to read core
34 size iwd(ws); $ last value returned by memget
35 size c(ws); $ current character
36 size state(ws); $ current state
37
38 /* states are encoded as follows :
39 1 - looking for . or ) at end of prefix
40 2 - looking for ( at start of list
41 3 - looking for ) ending list */
42
43 state = 1; $ begin looking for end of prefix
44 p = 0; $ no characters yet in cc
45
46 do i = 1 to 8;
47 iwd = memget(3b'67'+i); $ next word from low core
48 do j = ws-cs+1 to 1 by -cs; $ get characters
49 c = .f. j, cs, iwd;
50 if (c=0) quit do i; $ if end.
51 if state=1 then
52 if (c=1r. ! c=1r)) state=2;
53 elseif state=2 then
54 if (c=1r() state = 3;
55 else $ if state=3.
56 if (c=1r)) quit do i;
57 if p < cclen then $ if room for character.
58 p = p + 1; cc(p) = c;
59 end if;
60 end if;
61 end do j;
62
63 end do i;
64
65 ..s66
66
67 cclen = p;
68
69 end subr readsos;
70 ..defenv_readsos
1 .=member ltlfin
2 subr ltlfin(abnormal, completioncode);
3 $ terminate execution, abnormally if -abnormal- not zero.
4 $ completion code is passed on to host terminator.
5 size abnormal(ws); $ nonzero if abnormal termination.
6 size completioncode(ws); $ completion code.
7 $ sflev and sfcod are completion values passed to sysfin.
8 $ sflev is the largest (most severe) value encountered during
9 $ execution of ltlfin, and sfcod is code passed first time that
10 $ level encountered.
11 size sflev(ws), sfcod(ws);
12 data sflev=0;
13 data sfcod=0;
14 size i(ps); $ index, current line limit.
15
16 .+s10 size ncalls(ps); data ncalls = 0; $ number of -ltlfin- calls.
17 .+s11 size ncalls(ps); data ncalls = 0; $ number of -ltlfin- calls.
18 .+s32 size ncalls(ps); data ncalls = 0; $ number of -ltlfin- calls.
19 .+s66 size ncalls(ps); data ncalls = 0; $ number of -ltlfin- calls.
20 .+s37.
21 $ on s37, put termination variables in a nameset.
22 +* exitns = 7nexit$ns **
23 nameset exitns; $ start the nameset.
24 size ncalls(ps); data ncalls = 0; $ number of -ltlfin- calls.
25 size pgmckflg(1); data pgmckflg = no; $ recursion preventor.
26 size sioerflg(1); data sioerflg = no; $ ditto
27 end nameset;
28 ..s37
29 .+s47.
30 $ on s47, put termination variables in a nameset.
31 +* exitns = 7nexit$ns **
32 nameset exitns; $ start the nameset.
33 size ncalls(ps); data ncalls = 0; $ number of -ltlfin- calls.
34 size pgmckflg(1); data pgmckflg = no; $ recursion preventor.
35 size sioerflg(1); data sioerflg = no; $ ditto
36 end nameset;
37 ..s47
38
39 ncalls = ncalls + 1;
40
41 .+erexit if (ncalls<4) call 7nerxi$si;
42
43 if ncalls = 1 then $ if first call, try to terminate.
44 sflev = abnormal;
45 sfcod = completioncode;
46 if abnormal then
47 call contlpr(21, 0); $ set page limit to zero.
48
49 call contlpr(18, i); $ get current line limit.
50 if i then $ if line limit set, extend by 2000 lines.
51 call contlpr(19, i+2000);
52 end if;
53
54 .+s32 if abnormal=1 then $ traceback only if little error.
55 call ltlxtr; $ list trace back chain.
56 .+s32 end if;
57
58 $ increment ncalls so can close files.
59 ncalls = ncalls + 1;
60 call usratp; $ call user abnormal termination procedure.
61 else $ if normal, increment ncalls so can close.
62 ncalls = ncalls + 1;
63
64 .+extime. $ following text computes and writes elapsed time.
65
66 size timeoff(letimesz); $ end of job time.
67
68 if etim then $ if want elapsed time.
69 call letime(timeoff); timeoff = timeoff - timeon;
70 .+s11 timeoff = (timeon*1000)/60;
71 size msg(sds(38)); $ sds for execution time message
72 data msg = ' 0.000 cpu seconds execution time.';
73 size t10(letimesz); $ temporary for time output.
74 size pos(ps); $ position in output message
75
76 pos = 10;
77 while timeoff;
78 t10 = timeoff/10;
79 .ch. pos, msg = charofdig( timeoff - 10*t10);
80 pos = pos-1;
81 if (pos=7) pos = 6; $ skip across decimal point
82 timeoff = t10;
83 end while;
84 .+s66 call remarkl(msg); $ put etim in dayfile
85 .-s66.
86 $ put elapsed time on listing file.
87 call textlr(msg); call endlr; $ write to listing.
88 ..s66
89 end if etim;
90 ..extime
91 end if abnormal;
92
93 else
94 $ if not first call, reset level if
95 $ level of greater severity than any yet seen.
96 if abnormal > sflev then
97 sflev = abnormal;
98 sfcod = completioncode;
99 end if;
100 end if ncalls;
101
102 if ncalls=2 then $ if can try to close files.
103 call ltllio(1); $ terminate little io.
104 ncalls = ncalls + 1;
105 end if;
106
107 if ncalls = 3 then
108 call ltlsio(1); $ terminate sio.
109 end if;
110
111 while 1; $ sysfin must not return.
112 call sysfin(sflev, sfcod);
113 end while;
114 end subr ltlfin;
115 subr usratp;
116 $ null version of user abnormal termination procedure called if
117 $abnormal termination.
118 end subr usratp;
1 .=member s37xtr1
2 .+s37.
3 $ macros for s37 error routines.
4 +* badaddr = 7nbadr$li ** $ function to check for bad address.
5
6 +* addrp(n) = (.f. 1, 24, (n)) ** $ address value.
7
8
9 subr ltlxtr1(saveloc, parm); $ handle trace-back chain.
10 $ this routine processes trace-back chains. -saveloc- is set by
11 $ an assembler routine to point to the address of the last save
12 $ area. -parm- is 1 to just scan the trace-back chain and save
13 $ it in storage and 0 to print the trace-back chain. if -parm-
14 $ is zero and no trace-back chain has been saved, the current
15 $ trace-back chain is listed.
16 size saveloc(ps); $ location of highest save area.
17 size parm(1); $ set to 1 to print chain.
18 size backptrs(ps); data backptrs = 0; $ number of back pointers
19 size addrs(ws); dims addrs(15); $ calling addresses.
20 size rnames(.sds. 9); dims rnames(9); $ routine names.
21 size i(ps); $ loop variable.
22 size curaddr(ps); $ current save area address.
23 size entry(ps); $ possible routine entry address.
24 size namelen(ps); $ get name length.
25 size memget(ws); $ function to get a word from memory.
26 size badaddr(1); $ function to validity check an address.
27
28 +* byte(n) = $ fetch byte -n- from memory.
29 (.f. 25 - (.f. 1, 2, (n))*8, 8, memget((n)/cpw)) **
30
31 $ check for a trace-back chain already set and go print it if so
32 if (backptrs) go to print; $ go print chain.
33
34 /store/ $ here to store trace-back chain.
35 $ now store chain in local storage. first get initial save area
36 $ pointer.
37 curaddr = saveloc/cpw; $ set to word address.
38 do backptrs = 1 to 15; $ now process each save area.
39 if curaddr = 0 then $ this is the end of the chain.
40 addrs(backptrs) = 0; $ flag it as such.
41 quit do; $ done with this loop.
42
43 elseif badaddr(curaddr) then $ check for bad save-area addre
44 addrs(backptrs) = -1; $ flag as bad address.
45 quit do; $ done with loop.
46
47 else $ save area is valid - get calling address.
48 addrs(backptrs) = addrp(memget(curaddr+3)); $ get r14.
49 end if;
50
51 $ now see if can determine name of routine.
52 entry = addrp(memget(curaddr+4)); $ get contents of r15.
53 rnames(backptrs) = ''; $ set initially to null name.
54 until yes; $ quit if -entry- is not routine entry point.
55 if (badaddr(entry/cpw)) quit until; $ if invalid, not en
56 if (byte(entry) ^= 4b'47') quit until; $ not branch.
57 if (byte(entry+1) ^= 4b'f0') quit until;
58 if (byte(entry+2) ^= 4b'f0') quit until;
59 namelen = byte(entry+4); $ get name length.
60 if (namelen > 30) quit until; $ not valid if this long.
61 if (namelen > 9) namelen = 9; $ set to max. we will prin
62 rnames(backptrs) = '' .pad. 9; $ set to all blanks.
63 .len. rnames(backptrs) = namelen; $ set length.
64 do i = 1 to namelen; $ move in each character.
65 .ch. i, rnames(backptrs) = byte(entry+4+i);
66 end do;
67 end until;
68
69 curaddr = addrp(memget(curaddr+1))/cpw; $ next save area.
70 end do;
71
72 $ now, if -parm- is one, we are done and should return.
73 if (parm) return; $ done if just saving trace-back chain.
74
75 /print/ $ here to print trace-back chain.
76 $ now print the trace-back information stored from above or from
77 $ an earlier call.
78 endl textl(' trace-back chain:') endl endl
79
80 do i = 1 to backptrs; $ scan all back pointers.
81 if addrs(i) <= 0 then $ this is end of chain.
82 if addrs(i) < 0 then $ this is an error.
83 textl(' **** invalid trace-back chain ****') endl
84 end if;
85
86 quit do; $ done printing chain.
87 end if;
88
89 if .len. rnames(i) then $ print routine name.
90 textl('routine ''') textl(rnames(i)) textl(''' ')
91 end if;
92
93 $ now print calling address.
94 textl('called from ') addrl(addrs(i))
95 if (badaddr(addrs(i)/cpw)) textl(' (address invalid)')
96 endl
97 end do;
98
99 endl
100 backptrs = 0; $ show nothing saved to be printed.
101
102 $ now, if this was call to set trace-back chain, we must have ha
103 $ had one in the buffers already and have just printed it so
104 $ we must go back and set the current chain. note that this
105 $ will very often cause the set chain to be incorrect but it
106 $ is more important to get the initial chain correct since
107 $ it is the first error that the user is probably the most
108 $ interested in
109 if (parm = 1) go to store; $ go store trace-back chain.
110
111 end subr ltlxtr1;
1 .=member s37errs
2 subr ltlintr(psw, gpr);
3 access exitns; $ access termination nameset.
4 $ this routine is entered when osint detects a program
5 $ check.
6 size psw(2*ws); $ program status word at interrupt
7 size gpr(ws); dims gpr(16); $ machine registers at interrupt
8 size inttyp(ps); $ program check type
9 size intaddr(ps); $ interrupt address
10 size badaddr(1); $ checks for bad address.
11
12 size pgmmsg(sds(20)); $ program check messages
13 +* numchecks = 19 ** $ number of program check types
14 dims pgmmsg(numchecks);
15 data pgmmsg = 'operation',
16 'priv. operation',
17 'execute',
18 'protection',
19 'addressing',
20 'specification',
21 'data',
22 'fixed overflow',
23 'fixed divide',
24 'decimal overflow',
25 'decimal divide',
26 'exponent overflow',
27 'exponent underflow',
28 'significance',
29 'floating divide',
30 'segment translation',
31 'page translation',
32 'trans. specification',
33 'special operation';
34
35
36 if pgmckflg then $ this is recursive
37 call ltlfin(1, 4000); $ exit quickly.
38 else
39 pgmckflg = yes; $ show in program check routine
40 call ltlxtrs; $ set trace-back chain.
41 inttyp = .f. 33, 16, psw; $ set interrupt type
42 intaddr = .f. 1, 24, psw; $ set interrupt address
43 endl endl textl(' program check type')
44 intlp(inttyp, 3) $ write header message
45 if inttyp <= numchecks then $ value is valid
46 textl(' (') textl(pgmmsg(inttyp)) textl(' exception)')
47 end if;
48
49 textl(' occurred at ') addrl(intaddr)
50 if badaddr(intaddr/cpw) then $ write additional message
51 textl(' (psw address invalid)')
52 end if;
53
54 endl
55 call ltlregl(gpr); $ now list registers at time of error
56 psw = 0; $ show prgram check processed
57 pgmckflg = no; $ show out of routine.
58 call ltlfin(1, 2000+inttyp); $ terminate program.
59 end if;
60
61 end subr ltlintr;
62 subr ltlovtm; $ entered when time runs out
63 call ltlfin(1, 3220); $ abort program.
64
65 end subr ltlovtm;
66 subr ltlsioer(n, fn, iddname); $ print -sio- error message.
67 access exitns; $ access termination nameset.
68 $ this routine is called by -sio- to print error messages.
69 size n(ws); $ error number.
70 size fn(ps); $ file number.
71 size iddname(.sds. 18); $ ddname.
72 size ddname(.sds. 18); $ copy of -iddname-.
73 size i(ps); $ temporary.
74
75 size erntab(ps); dims erntab(40); $ error number table.
76
77 data erntab =
78
79 1, 2, 3, 3, 4, 4, 5, 5, 6, 6,
80 7, 8, 4, 5, 4, 4, 3, 3, 9, 10,
81 11, 12, 9, 9, 9, 9, 9, 9, 9, 11,
82 13, 0, 8, 14, 12, 12, 14, 15, 15, 9;
83
84 if sioerflg then $ this is recursive.
85 call ltlfin(1, 4001); $ get out.
86 end if;
87
88 sioerflg = yes; $ now set flag to indicate possible recursion.
89 call ltlxtrs; $ set trace-back chain.
90
91 endl textl(' error') intl(n) textl(' on file')
92 intl(fn) textl('. ') $ print header text.
93
94 if n = 32 then $ illegal file number.
95 textl('illegal file number')
96 go to ret;
97
98 elseif n > 40 ! n < 1 then $ bad error number.
99 textl('invalid error number')
100 go to ret;
101
102 else
103 ddname = iddname; $ copy input ddname parameter.
104 do i = 18 to 1 by -1; $ scan down ddname.
105 if (.ch. i, ddname = 1r ) .len. ddname = i-1; $ shorten
106 end do;
107
108 if .len. ddname then $ name is known.
109 textl('(ddname=''') textl(ddname) textl('''.) ')
110 else $ ddname is not known.
dsi 73 textl('(ddname=unknown.)')
112 end if;
113
114 go to e(erntab(n)) in 1 to 15; $ select code.
115 end if;
116
117 +* er(n, msg) = /e(n)/ textl(msg) go to ret; **
118
119 er(1, 'invalid file name')
120 er(2, 'missing dd card')
121 er(3, 'physical i/o error')
122 er(4, 'i/o sequence error')
123 er(5, 'file cannot be opened')
124 er(6, 'pds or tape already opened')
125 er(7, 'insufficient memory')
126 er(8, 'cannot close file')
127 er(9, 'unexpected error')
128 er(10, 'cannot rewind file')
129 er(11, 'file not connected')
130 er(12, 'bad record length on i/o operation')
131 er(13, 'formatted/unformatted conflict')
132 er(14, 'bad access code specified')
133 er(15, 'bad unformatted block length')
134
135 /ret/
136 textl('.') endl endl endl
137
138 sioerflg = no; $ show error processing done.
139
140 call ltlfin(1, 2100+n); $ terminate program.
141
142 end subr ltlsioer;
143 ..s37
1 .=member s47xtr1
2 .+s47.
3
4 $ the first version of these procedures obtained by copying s37
5 $ code. much of the traceback should be the same for s47, though
6 $ need to review interface with c, i.e., caller of little main
7 $ program.
8 $ s47errs contains ltlintr which for s37 is called by procedure
9 $ sysintr in little env (cms env assemble). some conversion to
10 $ error codes and conventions used by uts is needed; for example,
11 $ uts certainly doesn't have 'missing dd card' error, etc.
12 $ macros for s47 error routines.
13 +* badaddr = 7nbadr$li ** $ function to check for bad address.
14
15 +* addrp(n) = (.f. 1, 24, (n)) ** $ address value.
16
17
18 subr ltlxtr1(saveloc, parm); $ handle trace-back chain.
19 $ this routine processes trace-back chains. -saveloc- is set by
20 $ an assembler routine to point to the address of the last save
21 $ area. -parm- is 1 to just scan the trace-back chain and save
22 $ it in storage and 0 to print the trace-back chain. if -parm-
23 $ is zero and no trace-back chain has been saved, the current
24 $ trace-back chain is listed.
25 size saveloc(ps); $ location of highest save area.
26 size parm(1); $ set to 1 to print chain.
27 size backptrs(ps); data backptrs = 0; $ number of back pointers
28 size addrs(ws); dims addrs(15); $ calling addresses.
29 size rnames(.sds. 9); dims rnames(9); $ routine names.
30 size i(ps); $ loop variable.
31 size curaddr(ps); $ current save area address.
32 size entry(ps); $ possible routine entry address.
33 size namelen(ps); $ get name length.
34 size memget(ws); $ function to get a word from memory.
35 size badaddr(1); $ function to validity check an address.
36
37 +* byte(n) = $ fetch byte -n- from memory.
38 (.f. 25 - (.f. 1, 2, (n))*8, 8, memget((n)/cpw)) **
39
40 $ check for a trace-back chain already set and go print it if so
41 if (backptrs) go to print; $ go print chain.
42
43 /store/ $ here to store trace-back chain.
44 $ now store chain in local storage. first get initial save area
45 $ pointer.
46 curaddr = saveloc/cpw; $ set to word address.
47 do backptrs = 1 to 15; $ now process each save area.
48 if curaddr = 0 then $ this is the end of the chain.
49 addrs(backptrs) = 0; $ flag it as such.
50 quit do; $ done with this loop.
51
52 elseif badaddr(curaddr) then $ check for bad save-area addre
53 addrs(backptrs) = -1; $ flag as bad address.
54 quit do; $ done with loop.
55
56 else $ save area is valid - get calling address.
57 addrs(backptrs) = addrp(memget(curaddr+3)); $ get r14.
58 end if;
59
60 $ now see if can determine name of routine.
61 entry = addrp(memget(curaddr+4)); $ get contents of r15.
62 rnames(backptrs) = ''; $ set initially to null name.
63 until yes; $ quit if -entry- is not routine entry point.
64 if (badaddr(entry/cpw)) quit until; $ if invalid, not en
65 if (byte(entry) ^= 4b'47') quit until; $ not branch.
66 if (byte(entry+1) ^= 4b'f0') quit until;
67 if (byte(entry+2) ^= 4b'f0') quit until;
68 namelen = byte(entry+4); $ get name length.
69 if (namelen > 30) quit until; $ not valid if this long.
70 if (namelen > 9) namelen = 9; $ set to max. we will prin
71 rnames(backptrs) = '' .pad. 9; $ set to all blanks.
72 .len. rnames(backptrs) = namelen; $ set length.
73 do i = 1 to namelen; $ move in each character.
74 .ch. i, rnames(backptrs) = byte(entry+4+i);
75 end do;
76 end until;
77
78 curaddr = addrp(memget(curaddr+1))/cpw; $ next save area.
79 end do;
80
81 $ now, if -parm- is one, we are done and should return.
82 if (parm) return; $ done if just saving trace-back chain.
83
84 /print/ $ here to print trace-back chain.
85 $ now print the trace-back information stored from above or from
86 $ an earlier call.
87 endl textl(' trace-back chain:') endl endl
88
89 do i = 1 to backptrs; $ scan all back pointers.
90 if addrs(i) <= 0 then $ this is end of chain.
91 if addrs(i) < 0 then $ this is an error.
92 textl(' **** invalid trace-back chain ****') endl
93 end if;
94
95 quit do; $ done printing chain.
96 end if;
97
98 if .len. rnames(i) then $ print routine name.
99 textl('routine ''') textl(rnames(i)) textl(''' ')
100 end if;
101
102 $ now print calling address.
103 textl('called from ') addrl(addrs(i))
104 if (badaddr(addrs(i)/cpw)) textl(' (address invalid)')
105 endl
106 end do;
107
108 endl
109 backptrs = 0; $ show nothing saved to be printed.
110
111 $ now, if this was call to set trace-back chain, we must have ha
112 $ had one in the buffers already and have just printed it so
113 $ we must go back and set the current chain. note that this
114 $ will very often cause the set chain to be incorrect but it
115 $ is more important to get the initial chain correct since
116 $ it is the first error that the user is probably the most
117 $ interested in
118 if (parm = 1) go to store; $ go store trace-back chain.
119
120 end subr ltlxtr1;
1 .=member s47errs
2 subr ltlintr(psw, gpr);
3 access exitns; $ access termination nameset.
4 $ this routine is entered when osint detects a program
5 $ check.
6 size psw(2*ws); $ program status word at interrupt
7 size gpr(ws); dims gpr(16); $ machine registers at interrupt
8 size inttyp(ps); $ program check type
9 size intaddr(ps); $ interrupt address
10 size badaddr(1); $ checks for bad address.
11
12 size pgmmsg(sds(20)); $ program check messages
13 +* numchecks = 19 ** $ number of program check types
14 dims pgmmsg(numchecks);
15 data pgmmsg = 'operation',
16 'priv. operation',
17 'execute',
18 'protection',
19 'addressing',
20 'specification',
21 'data',
22 'fixed overflow',
23 'fixed divide',
24 'decimal overflow',
25 'decimal divide',
26 'exponent overflow',
27 'exponent underflow',
28 'significance',
29 'floating divide',
30 'segment translation',
31 'page translation',
32 'trans. specification',
33 'special operation';
34
35
36 if pgmckflg then $ this is recursive
37 call ltlfin(1, 4000); $ exit quickly.
38 else
39 pgmckflg = yes; $ show in program check routine
40 call ltlxtrs; $ set trace-back chain.
41 inttyp = .f. 33, 16, psw; $ set interrupt type
42 intaddr = .f. 1, 24, psw; $ set interrupt address
43 endl endl textl(' program check type')
44 intlp(inttyp, 3) $ write header message
45 if inttyp <= numchecks then $ value is valid
46 textl(' (') textl(pgmmsg(inttyp)) textl(' exception)')
47 end if;
48
49 textl(' occurred at ') addrl(intaddr)
50 if badaddr(intaddr/cpw) then $ write additional message
51 textl(' (psw address invalid)')
52 end if;
53
54 endl
55 call ltlregl(gpr); $ now list registers at time of error
56 psw = 0; $ show prgram check processed
57 pgmckflg = no; $ show out of routine.
58 call ltlfin(1, 2000+inttyp); $ terminate program.
59 end if;
60
61 end subr ltlintr;
62 subr ltlovtm; $ entered when time runs out
63 call ltlfin(1, 3220); $ abort program.
64
65 end subr ltlovtm;
66 subr ltlsioer(n, fn, iddname); $ print -sio- error message.
67 access exitns; $ access termination nameset.
68 $ this routine is called by -sio- to print error messages.
69 size n(ws); $ error number.
70 size fn(ps); $ file number.
71 size iddname(.sds. 18); $ ddname.
72 size ddname(.sds. 18); $ copy of -iddname-.
73 size i(ps); $ temporary.
74
75 size erntab(ps); dims erntab(40); $ error number table.
76
77 data erntab =
78
79 1, 2, 3, 3, 4, 4, 5, 5, 6, 6,
80 7, 8, 4, 5, 4, 4, 3, 3, 9, 10,
81 11, 12, 9, 9, 9, 9, 9, 9, 9, 11,
82 13, 0, 8, 14, 12, 12, 14, 15, 15, 9;
83
84 if sioerflg then $ this is recursive.
85 call ltlfin(1, 4001); $ get out.
86 end if;
87
88 sioerflg = yes; $ now set flag to indicate possible recursion.
89 call ltlxtrs; $ set trace-back chain.
90
91 endl textl(' error') intl(n) textl(' on file')
92 intl(fn) textl('. ') $ print header text.
93
94 if n = 32 then $ illegal file number.
95 textl('illegal file number')
96 go to ret;
97
98 elseif n > 40 ! n < 1 then $ bad error number.
99 textl('invalid error number')
100 go to ret;
101
102 else
103 ddname = iddname; $ copy input ddname parameter.
104 do i = 18 to 1 by -1; $ scan down ddname.
105 if (.ch. i, ddname = 1r ) .len. ddname = i-1; $ shorten
106 end do;
107
108 if .len. ddname then $ name is known.
109 textl('(ddname=''') textl(ddname) textl('''.) ')
110 else $ ddname is not known.
111 textl('(ddname=unknown.)')
112 end if;
113
114 go to e(erntab(n)) in 1 to 15; $ select code.
115 end if;
116
117 +* er(n, msg) = /e(n)/ textl(msg) go to ret; **
118
119 er(1, 'invalid file name')
120 er(2, 'missing dd card')
121 er(3, 'physical i/o error')
122 er(4, 'i/o sequence error')
123 er(5, 'file cannot be opened')
124 er(6, 'pds or tape already opened')
125 er(7, 'insufficient memory')
126 er(8, 'cannot close file')
127 er(9, 'unexpected error')
128 er(10, 'cannot rewind file')
129 er(11, 'file not connected')
130 er(12, 'bad record length on i/o operation')
131 er(13, 'formatted/unformatted conflict')
132 er(14, 'bad access code specified')
133 er(15, 'bad unformatted block length')
134
135 /ret/
136 textl('.') endl endl endl
137
138 sioerflg = no; $ show error processing done.
139
140 call ltlfin(1, 2100+n); $ terminate program.
141
142 end subr ltlsioer;
143 ..s47
1 .=member failml
2 subr 7nfal2$ml(enum,len, msg); $ failure in math library.
3 size enum(ps); $ error number.
4 size len(ps); $ number of words in message.
5 size msg(ws); dims msg(2); $ message text.
6 size i(ps); $ loop index.
7 endl textl('error number ')
8 intl(enum) textl(' in mathematical library: ')
9 do i = 1 to len; wordl(msg(i)); end do;
10 endl
11 call ltlfin(1, 1100+enum); $ math library error.
12 end subr;
1 .=member begmon
2 $ macro section for run time monitor aids procedures
3 +* subtabdim = 30 ** $ procedure stack limit
4 +* namelen = 15 ** $ length of significant part of name
5 +* subtabsiz = sds(namelen) ** $ length of subroutine stack
6 +* dbcursubn = dbsubtab(dbsubtabp) ** $ access top of stack
7 +* dbcurfsw = dbfswtab(dbsubtabp) ** $ access switch
8
9 $ to avoid conflicts with user procedures, the names of monitor procedu
10 $ begin with a four character code followed by '$mp'.
11
12 +* prst = 7nprst$mp ** $ print stores
13 +* prs3 = 7nprs3$mp ** $ print stores (3 parameters)
14 +* prs4 = 7nprs4$mp ** $ print stores (4 parameters)
15 +* prs5 = 7nprs5$mp ** $ print stores (5 parameters)
16 +* pren = 7npren$mp ** $ print entry
17 +* prex = 7nprex$mp ** $ print exit
18 +* prar = 7nprar$mp ** $ print argument
19 +* prfl = 7nprfl$mp ** $ print flow trace
20 +* trfl = 7ntrfl$mp ** $ trace flow
21 +* cinx = 7ncinx$mp ** $ check index on store
22 +* prhd = 7nprhd$mp ** $ print assert header
23 +* prvr = 7nprvr$mp ** $ print assert variable
24 +* asfl = 7nasfl$mp ** $ simple assertion failure
25 +* subn = 7nsubn$mp ** $ establish subprocedure name and type
26 +* subx = 7nsubx$mp ** $ show exit from procedure
27 +* setx = 7nsetx$mp ** $ set monitor parameters
28 +* cntu = 7ncntu$mp ** $ countup overflow
29 +* llex = 7nllex$mp ** $ monitor line limit exceeded
30 +* lhdr = 7nlhdr$mp ** $ print line header
31 +* varo = 7nvaro$mp ** $ output a variable
32
33 $ the names of namesets used by monitor are also protected.
34
35 +* bugns = 7ndbgn$mp ** $ monitor nameset
36 +* flown = 7nflwn$mp ** $ flow globals
37 +* storen = 7nstrn$mp ** $ store trace globals
38 +* entryn = 7nentn$mp ** $ entry trace globals
39 +* asertn = 7nastn$mp ** $ assert globals
40
41 $ macro -countup- increments ptr and checks for array overflow
42 +* countup(ptr, lim, msg) =
43 ptr = ptr + 1;
44 if (ptr > lim) then
45 call cntu(msg, lim); $ call error procedure
46 return;
47 end if; **
48
49 $ macro -endld- calls endl and increments line count to check for
50 $ line limit overflow.
51 +* endld = endl
52 dblinect = dblinect + 1;
53 if dblinect > dblinelim & dblinelim > 0 then
54 call llex; $ call error procedure
55 return;
56 end if;
57 **
58
59 +* newlin = $ this macro begins a new line
60 if pfcol > 2 then endld end if; $ start new line if needed
61 **
62
63 +* monitorhead(line, type) = $ print header - line is line no.
64 $ type is 1 for 'entry', 2 for 'exit', 3 for 'store', and 4 for 'error'
65 call lhdr(line, type); $ print header
66 **
67
68 +* monitorvarout(name, flag, index, nwds, val) =
69 $ this macro is used to print a value. -name- is the name of the
70 $ variable being printed, -nwds- is the number of words in the
71 $ variable, -val- is the value, -flag- is non-zero if the variable
72 $ is indexed, in which case -index- is the index.
73 call varo(name, flag, index, nwds, val); $ output variable
74 **
75
76 $ dimensions of arrays
77 +* flowtabdim = 200 ** $ table for flow trace counters
78 +* flroutsdim = 40 ** $ table for flow trace - ptrs to flowtab
79 +* labtabdim = 40 ** $ table for flow trace - label table
80
81 $ fields of flow table
82 $ fid is the id of the code block. fftyp is a subfield of
83 $ giving gross type. ffblock is unique identification number.
84 $ fdone is flag for when entry done. flino is line number.
85 $ flabnam is label name pointer. fcount is executions counter.
86
87 .+s10.
88 +* fid = .f. 01, 18, **
89 +* fftyp = .f. 01, 03, **
90 +* ffblock = .f. 04, 15, **
91 +* flabnam = .f. 19, 18, **
92 +* fdone = .f. 37, 01, **
93 +* flino = .f. 38, 17, **
94 +* fcount = .f. 55, 18, **
95 ..s10
96 .+s11.
97 +* fid = .f. 01, 16, **
98 +* fftyp = .f. 01, 03, **
99 +* ffblock = .f. 04, 13, **
100 +* flabnam = .f. 17, 16, **
101 +* fdone = .f. 33, 01, **
102 +* flino = .f. 34, 15, **
103 +* fcount = .f. 49, 16, **
104 ..s11
vax 36 .+s32.
vax 37 +* fid = .f. 01, 16, **
vax 38 +* fftyp = .f. 01, 03, **
vax 39 +* ffblock = .f. 04, 13, **
vax 40 +* flabnam = .f. 17, 16, **
vax 41 +* fdone = .f. 33, 1, **
vax 42 +* flino = .f. 34, 15, **
vax 43 +* fcount = .f. 49, 16, **
vax 44 ..s32
114 .+s37.
115 +* fid = .f. 01, 16, **
116 +* fftyp = .f. 01, 03, **
117 +* ffblock = .f. 04, 13, **
118 +* flabnam = .f. 17, 16, **
119 +* fdone = .f. 33, 1, **
120 +* flino = .f. 34, 15, **
121 +* fcount = .f. 49, 16, **
122 ..s37
utsa 98 .+s47.
utsa 99 +* fid = .f. 01, 16, **
utsa 100 +* fftyp = .f. 01, 03, **
utsa 101 +* ffblock = .f. 04, 13, **
utsa 102 +* flabnam = .f. 17, 16, **
utsa 103 +* fdone = .f. 33, 1, **
utsa 104 +* flino = .f. 34, 15, **
utsa 105 +* fcount = .f. 49, 16, **
utsa 106 ..s47
dsw 15 .+s40.
dsw 16 +* fid = .f. 01, 16, **
dsw 17 +* fftyp = .f. 01, 03, **
dsw 18 +* ffblock = .f. 04, 13, **
dsw 19 +* flabnam = .f. 17, 16, **
dsw 20 +* fdone = .f. 33, 01, **
dsw 21 +* flino = .f. 34, 15, **
dsw 22 +* fcount = .f. 49, 16, **
dsw 23 ..s40
123 .+s66.
124 +* fid = .f. 01, 13, **
125 +* fftyp = .f. 01, 03, **
126 +* ffblock = .f. 04, 10, **
127 +* fdone = .f. 14, 01, **
128 +* flino = .f. 17, 16, **
129 +* flabnam = .f. 33, 07, **
130 +* fcount = .f. 40, 17, **
131 ..s66
132
133 $ fields for flowrouts
134 +* fbeg = .f. 1, 8, ** $ ptr to flowtab - beginning of procedure
135 +* lbeg = .f. 9, 8, ** $ ptr to labtab - beginning of procedure
136
137 $ sizes of monitor tables
138
139 +* labtabsiz = sds(namelen) ** $ length of label table
140 +* flroutssiz = ws ** $ can fit in word for all machines
141 +* flowtabsiz = $ size of flow table
142 .+s10 2*ws
143 .+s11 4*ws
vax 45 .+s32 2*ws
145 .+s37 2*ws
utsa 107 .+s47 2*ws
dsw 24 .+s40 4*ws
146 .+s66 ws
147 **
148
149 +* dbgwordsz = $ size of 'word' passed as descriptor
150 .+s10 ws
151 .+s11 2*ws
vax 46 .+s32 ws
153 .+s37 ws
utsa 108 .+s47 ws
dsw 25 .+s40 2*ws
154 .+s66 ws
155 **
156
1 .=member subn
2 subr subn(name, fsw);
3 $ this procedure sets the global values for subroutine name
4 $ and switch at the start of a procedure.
dsx 13 nameset bugns;
dsx 14 $ globals for monitor package
dsx 15 size dbbytefg(1); data dbbytefg = no; $ set to print bit in all
dsx 16 size dbsubtab(subtabsiz); dims dbsubtab(subtabdim); $ procedure
dsx 17 size dbfswtab(ps); dims dbfswtab(subtabdim); $ switch value tab
dsx 18 size dbsubtabp(ps); data dbsubtabp = 0; $ pointer to -dbsubtab-
dsx 19 size dbnewsubfg(1); $ 'new subroutine' flag
dsx 20 end nameset bugns;
dsx 21 access lcpns;
6 size name(subtabsiz); $ procedure name
7 size fsw(ps); $ funct/subr/prog switch.
dsx 22 size i(ps); $ name length.
8
dsx 23 i = namelen;
dsx 24 if (slen name <= namelen) i = slen name;
dsz 8 $ accept null string as argument, and treat this as request
dsz 9 $ to reset dbsubtabp, as special service to setl system.
dsz 10 if i = 0 then $ if reset request.
dsz 11 dbsubtabp = 0;
dsz 12 return;
dsz 13 end if;
dsz 14 countup(dbsubtabp, subtabdim, 'dsubtab');
dsx 25 dbcursubn = .s. 1, i, name; $ extract part
15 dbcurfsw = fsw; $ set fnct/subr flag
16 dbnewsubfg = yes; $ set flag for flow trace
17 end subr subn;
1 .=member subx
2 subr subx;
3 access lcpns,bugns;;
4 $ this procedure pops the subroutine stack
5
6 if (dbsubtabp = 0) return; $ error
7 dbsubtabp = dbsubtabp-1; $ pop stack
8 end subr subx;
1 .=member lhdr
2 subr lhdr(line, type); $ print monitor header
dsx 26 access bugns, lcpns;
12 size line(ps); $ line number
13 size type(ps); $ type: 1=entry, 2=exit, 3=store, 4=error
14 size dbfswtxt(.sds. 5); dims dbfswtxt(3); $ name of proc type.
15 data dbfswtxt = 'subr ', 'fnct ', 'prog ';
16
17 newlin; $ start new line
18 dblinenum = dblinenum+1; $ count line
19 if dblinenum = 10 then $ must skip a line
20 dblinenum = 0; $ reset
21 endld $ leave blank line
22 end if;
23 tabl(dbsubtabp*4-2) textl('--> ') $ indent
24 if type = 1 then
25 textl('entry ')
26 elseif type = 2 then
27 textl('exit ')
28 elseif type = 3 then
29 textl('store ')
30 else
31 textl('error ')
32 end if;
33 textl('at line ') intl(line) textl(' in ')
34 textl(dbfswtxt(dbcurfsw+1))
35 textl(dbcursubn)
36 if (type > 2) textl(': ')
37
38 end subr lhdr;
1 .=member trfl
2 subr trfl(word, label);
3 $ procedure which counts number of times labeled blocks of code
4 $ are executed.
5 access lcpns,bugns;
6 size word(dbgwordsz); $ parameter 'word'
7 +* flowid = .f. 1, 13, ** $ block id
8 +* flowtyp = .f. 1, 3, ** $ block type
9 +* while_type = 1 ** $ type of 'while' statement
10 +* until_type = 2 ** $ type of 'until' statement
11 +* do_type = 3 ** $ type of 'do' statement
12 +* iftru_type = 4 ** $ 'if' - true
13 +* iffls_type = 5 ** $ 'if' - false
14 +* label_type = 6 ** $ label
15 +* flowblock = .f. 4, 10, ** $ block no.
16 +* flowlino = .f. 17, 16, ** $ line no.
17 size label(ws+1); $ label
18 size fent(flowtabsiz); $ flowtab entry
19 size i(ps); $ do loop var
20 size flowtabb(ps); $ bottom ptr to start of procedure
21
22 nameset flown; $ nameset for flow trace
23 size flowfg(1); data flowfg = 1; $ flow flag
24 size flowtab(flowtabsiz); dims flowtab(flowtabdim); $ table for
25 size flrouts(flroutssiz); dims flrouts(flroutsdim); $ procedures
26 size flowlab(labtabsiz); dims flowlab(labtabdim); $ label nam
27 size flowtabp(ps); data flowtabp = 0; $ ptr to flowtab
28 size flroutsp(ps); data flroutsp = 0; $ ptr to flrouts
29 size flowlabp(ps); data flowlabp = 0; $ ptr to flowlab
30 end nameset flown;
31
32 if (dbstoplist) return; $ excede line limit
33 if (flowfg = no) return; $ dynamic flag not on
34 if (flroutsp = 0) go to newrout;
35 if (dbnewsubfg) go to newrout;
36 $ in same procedure. search for entry in flowtab. if none exist,
37 $ start new entry.
38 flowtabb = fbeg flrouts(flroutsp); $ beginning of procedure
39 do i = flowtabb to flowtabp;
40 if (flowid word ^= fid flowtab(i)) cont do ;
41 $ found block
42 fcount flowtab(i) = fcount flowtab(i) + 1;
43 return;
44 end do;
45 $ block not found - add new entry to flowtab
46 go to addlab;
47
48 /newrout/ $ entered new procedure
49 dbnewsubfg = no;
50 countup(flroutsp, flroutsdim, 'flrouts');
51 fbeg flrouts(flroutsp) = flowtabp + 1; $ beg of rout in flowtab
52 lbeg flrouts(flroutsp) = flowlabp + 1; $ beg of rout in flowlab
53 /addlab/ $ add new entry to flowtab and flowlab if applicable
54 countup(flowtabp, flowtabdim, 'flowtab');
55 fent = 0; $ clear entry
56 fid fent = flowid word;
57 flino fent = flowlino word;
58 if flowtyp word = label_type then
59 countup(flowlabp, labtabdim, 'flowlab')
60 flabnam fent = flowlabp; $ ptr to label name
61 if slen label <= namelen then
62 flowlab(flowlabp) = label; $ just copy
63 else
64 flowlab(flowlabp) = .s. 1, namelen, label; $ else extract
65 end if;
66 end if;
67 fcount fent = 1;
68 flowtab(flowtabp ) = fent;
69 end subr trfl;
1 .=member prfl
2 subr prfl;
3 $ procedure to print flow statistic at exit from procedure
4 access lcpns,bugns;
5 size fent(flowtabsiz); $ entry in flowtab
6 size i(ps); $ do loop variables
7 size j(ps);
8 access flown;
9
10 if (dbstoplist) return; $ excede line limit
11 if (flroutsp = 0) return;
12 if (dbnewsubfg) return; $ nothing traced
13 if (flowfg = no) return;
14 newlin; endld textl('*** flow trace for ')
15 if dbcurfsw then textl('fnct ') else textl('subr ') end if;
16 textl(dbcursubn) textl(' ***') endld
17 textl('codeblock line executions') endld $ header
18 do i = fbeg flrouts(flroutsp) to flowtabp;
19 fent = flowtab(i);
20 go to l(fftyp fent) in while_type to label_type;
21 /l(while_type)/ textl('while') go to rest;
22 /l(until_type)/ textl('until') go to rest;
23 /l(do_type)/ textl('do') go to rest;
24 /l(label_type)/ charl(1r/) textl(flowlab(flabnam fent)) charl(1r/)
25 /rest/ tabl(namelen+3) intl(flino fent) skipl(12)
26 intl(fcount fent) endld
27 cont do i; $ go to next item
28 /l(iftru_type)/ $ number of times a condition is true
29 textl('if') tabl(namelen+3) intl(flino fent) skipl(5)
30 textl('true: ') intl(fcount fent)
31 do j = i + 1 to flowtabp; $ search for a matching false if
32 if (ffblock flowtab(j) ^= ffblock fent) cont do j;
33 $ found a match
34 textl(' false: ') intl(fcount flowtab(j))
35 fdone flowtab(j) = 1; $ flag entry as done
36 quit do j;
37 end do j;
38 endld
39 cont do i;
40 /l(iffls_type)/ $ number of times a condition was false
41 if (fdone fent) cont do i;
42 textl('if') tabl(namelen+3) intl(flino fent) skipl(5)
43 textl('false: ') intl(fcount fent) endld
44 end do i;
45 textl('*********************************') endld endld
46 $ update tables by popping top procedure from stacks
47 flowtabp = fbeg flrouts(flroutsp) - 1;
48 flowlabp = lbeg flrouts(flroutsp) - 1;
49 flroutsp = flroutsp - 1;
50 end subr prfl;
1 .=member prst
2 subr prst(varn, word, val, par1, par2, par3);
3 access lcpns,bugns;
4 size varn(ws+1); $ variable name
5 size word(dbgwordsz); $ parameter 'word'
6 +* vsize = .f. 01, 08, ** $ no. of words in var
7 +* vopcod = .f. 09, 03, ** $ store type
8 +* simp_type = 1 ** $ simple assignment
9 +* f_type = 2 ** $ .f. assignment
10 +* e_type = 3 ** $ .e. assignment
11 +* s_type = 4 ** $ .s. assignment
12 +* ch_type = 5 ** $ .ch. assignment
13 +* len_type = 6 ** $ .len. assignment
14 +* vindx = .f. 12, 01, ** $ flag for indexed assignment
15 +* vlino = .f. 17, 16, ** $ line no.
16 size val(ws+1); $ value to be listed
17 size par1(ps), par2(ps), par3(ps); $ these are parameters
18 $ for index, first bit, and length. if any of these if not
19 $ applicable it is skipped. i.e., in most cases at least one
20 $ of these variables is undefined.
21
22 size fbit(ps); $ first bit position
23 size flen(ps); $ field length
24 size nwd(ps); $ number of words of target
25 size vcod(ps); $ type of store
26 size fexts(sds(6)); dims fexts(len_type);
27 size i(ps); $ do loop var
28 data $ define values for store types
29 fexts(simp_type) = ' ': fexts(f_type) = '.f.':
30 fexts(e_type) = '.e.': fexts(s_type) = '.s.':
31 fexts(ch_type) = '.ch.': fexts(len_type) = '.len. ';
32
33 nameset storen; $ nameset for store trace
34 size storfg(1); data storfg = 1; $ store flag
35 end nameset storen;
36
37 if (dbstoplist) return; $ line limit exceded
38 if (storfg = no) return;
39 $ print trace
40 monitorhead(vlino word, 3); $ print header info
41 vcod = vopcod word;
42 nwd = vsize word;
43 textl(fexts(vcod)) $ print type of store
44 go to l(vcod) in simp_type to len_type; $ select type
45
46 /l(simp_type)/ /l(len_type)/ $ simple store or .len.
47 monitorvarout(varn, vindx word, par1, nwd, val); endld $ print va
48 return;
49
50 /l(f_type)/ /l(e_type)/ $ .f. or .e.
51 if vindx word then $ var. is indexed
52 fbit = par2; flen = par3; $ set values
53 else
54 fbit = par1; flen = par2; $ set values for non-indexed
55 end if;
56 intl(fbit) charl(1r,) intl(flen) textl(', ') $ write positions
57 monitorvarout(varn, vindx word, par1,
58 (flen+ws-1)/ws, (.e. 1, flen, val)); endld $ output value
59 return;
60
61 /l(s_type)/ $ .s. assignment
62 if vindx word then $ indexed
63 fbit = par2; flen = par3; $ get positions
64 else
65 fbit = par1; flen = par2; $ get positions if not indexed
66 end if;
67 intl(fbit) charl(1r,) intl(flen) textl(', ')
68 monitorvarout(varn, vindx word, par1, vsize word, val); endld
69 return;
70
71 /l(ch_type)/ $ .ch. type
72 if vindx word then fbit = par2; else fbit = par1; end if;
73 intl(fbit) textl(', ') textl(varn) $ start line
74 if vindx word then charl(1r() intl(par1) charl(1r)) end if;
75 textl(' = 1r') charl(val)
76 if dbbytefg then $ byte value wanted
77 textl(' = ') intlp(mradix, 1) textl('b''') bwordl(val)
78 charl(1r')
79 end if;
80 endld
81 end subr prst;
82 subr prs3(varn, word, val); $ print stores (3 parms)
83 size varn(ws+1), word(dbgwordsz), val(ws+1);
84 call prst(varn, word, val, 0, 0, 0);
85 end subr prs3;
86 subr prs4(varn, word, val, p1); $ print stores (4 parms)
87 size varn(ws+1), word(dbgwordsz), val(ws+1), p1(ps);
88 call prst(varn, word, val, p1, 0, 0);
89 end subr prs4;
90 subr prs5(varn, word, val, p1, p2); $ print stores (5 parms)
91 size varn(ws+1), word(dbgwordsz), val(ws+1), p1(ps), p2(ps);
92 call prst(varn, word, val, p1, p2, 0);
93 end subr prs5;
1 .=member pren
2 subr pren;
3 $ prints trace of entry to procedures if entry flag is on.
4
5 access lcpns,bugns;
6 nameset entryn;
7 size entrfg(1); data entrfg = 1; $ entry flag
8 end nameset entryn;
9
10 if (dbstoplist) return; $ excede line limit
11 if (entrfg = no) return;
12 monitorhead(1, 1); endld
13 end subr pren;
1 .=member prex
2 subr prex(lineno, nwds, val);
3 $ prints trace of exit from functions
4 access lcpns,bugns;
5 size lineno(ps); $ line no.
6 size nwds(ps); $ no. of words of return value (if present)
7 size val(ws+1); $ return value
8 access entryn;
9
10 if (dbstoplist) return; $ excede line limit
11 if (entrfg = no) return; $ runtime flag check
12 monitorhead(lineno, 2);
13 if dbcurfsw = 1 then $ this is a function.
14 textl(' with ') monitorvarout(dbcursubn, no, 0, nwds, val);
15 end if;
16 endld
17 end subr prex;
1 .=member prar
2 subr prar(varn, nwds, val);
3 access lcpns,bugns;
4 size varn(ws+1); $ variable name
5 size nwds(ps); $ no. of words in value
6 size val(ws+1); $ value of variable
7 size i(ps); $ do loop index
8 access entryn;
9
10 if (dbstoplist) return; $ excede line limit
11 if (entrfg = 0) return;
12 monitorhead(1, 1); $ say at line 1
13 textl(' with ') monitorvarout(varn, no, 0, nwds, val); endld
14 end subr prar;
1 .=member cinx
2 subr cinx(varn, val, dim, lineno);
3 $ this procedure checks the range of an indexed store to make sure
4 $ that no word outside the array boundary is being clobbered.
5 $ if the check fails, the program aborts.
6 access lcpns,bugns;;
7 size varn(ws+1); $ variable name
8 size val(ws); $ subscript value
9 size dim(ps); $ array dimension
10 size lineno(ps); $ line no.
11
12 if (val <= dim) & (val > 0) return;
13 $ print error message and abort
14 monitorhead(lineno, 4);
15 textl('*** index out of range. array = ') textl(varn)
16 tintl(' value of index', val) textl(' ***') endld
17 call ltlfin(1, 1005); $ $ array index out of range..
18 end subr cinx;
1 .=member prhd
2 subr prhd(lineno);
3 $ prints header of assertion list. streamlines output
4 access lcpns,bugns;
5 size lineno(ps); $ line no.
6 nameset asertn;
7 size assertno(ps); $ line no. of last assert failure
8 end nameset;
9
10 if (dbstoplist) return; $ excede line limit
11 assertno = lineno; $ set line no.
dsi 74 monitorhead(lineno, 4); textl('*** assertion failed ***') endld
13 end subr prhd;
1 .=member prvr
2 subr prvr(varn, nwds, val);
3 $ prints values of variables in assertion statement
4 access lcpns,bugns;
5 size varn(ws+1); $ variable name
6 size nwds(ps); $ number of words
7 size val(ws+1); $ value of variable
8 access asertn;
9
10 if (dbstoplist) return; $ excede line limit
11 monitorhead(assertno, 4); monitorvarout(varn, no, 0, nwds, val);
12 endld
13 end subr prvr;
1 .=member asfl
2 subr asfl;
3 $ print simple message for assertion faliure
4
5 endl textl('******** assertion failed ********') endl
6 call ltlfin(1, 1006); $ assertion failure.
7 end subr asfl;
1 .=member setx
2 subr setx(parm, change);
3 $ this procedure sets dynamic parameters
4
5 $ fields of -parm- and -change-
dsw 26 +* slct = .f. 1, ws-4, ** $ line limit
dsw 27 +* spbit = .f. ws-3, 1, ** $ 'print byte'
dsw 28 +* sflow = .f. ws-2, 1, ** $ 'set flow'
dsx 27 +* sstor = .f. ws-1, 1, ** $ 'set store'
dsw 30 +* sentr = .f. ws, 1, ** $ 'set entry'
11 access lcpns,bugns;
dsw 31 size parm(ws), change(ws); $ parameters
13 +* mod(val, fld) = if (fld change) val = fld parm **
14 access flown, storen, entryn; $ access namesets
15
16 mod(dblinelim, slct); mod(dbbytefg, spbit);
17 mod(flowfg, sflow); mod(storfg, sstor);
18 mod(entrfg, sentr);
19 macdrop(mod)
20
21 end subr setx;
1 .=member cntu
2 subr cntu(msg, lim); $ print countup overflow message
3 access lcpns,bugns;;
4 size msg(ws+1); $ message
5 size lim(ps); $ array limit
6
7 textl('***** monitor array ') textl(msg)
8 textl(' overflowed: limit is') intl(lim)
9 textl('. some monitor data lost *****') endld
10 end subr cntu;
1 .=member llex
2 subr llex; $ print monitor line limit exceeded
3 access lcpns,bugns;;
4
5 textl('***** monitor line limit of ') intl(dblinelim)
6 textl(' exceeded. further monitor output suppressed *****') endl
7 dbstoplist = yes; $ set flag to stop further output
8 end subr llex;
1 .=member varo
2 subr varo(name, flag, index, nwds, val); $ output variable - debu
3 access lcpns,bugns;;
4 size name(ws+1); $ variable name
5 size flag(1); $ set if variable is indexed
6 size index(ps); $ index if it is
7 size nwds(ps); $ number of words in vaariable
8 size val(ws+1); $ value of variable
9 size i(ps); $ define do loop variable
10 size flg(1); $ set if byte val must be printed
11
12 if (dbstoplist) return;
13 textl(name) $ output variable name
14 if flag then $ var. is indexed
15 charl(1r() intl(index) charl(1r)) $ print subscript
16 end if;
17 flg = yes; $ show should print bit value
18 if nwds = 1 then $ see if should print as integer
19 if .fb. .f.1, ws, val <= 16 !
20 .fb. (-(.f. 1, ws, val)) <= 11 then
21 $ value will fit in five digits printed by -intl-
22 textl(' = ') intl(val)
23 flg = no; $ need not print
24 end if;
25 end if;
26 if sorg val > cs & nwds*ws >= (sorg val)-1 then $ maybe sds
27 if ((sorg val)-1)/cs*cs = (sorg val)-1 &
28 sds(slen val) <= sorg val then $ if it is, it is well
29 if pfcol > pflen-(slen val)-5 then $ too long
30 endld tabl(10) $ start new line
31 end if;
32 textl(' = ''') textl(val) charl(1r')
33 flg = no;
34 end if;
35 end if;
36 if flg ! dbbytefg then $ print bit value
37 textl(' = ') intlp(mradix, 1) textl('b''')
38 do i = nwds to 2 by -1; $ print each word except last
39 if pfcol > pflen-bwordlen-5 then $ line too long
40 endld tabl(10)
41 end if;
42 bwordl(wordi(i, val)) charl(1r )
43 end do;
44 bwordl(wordi(1, val)) $ print last word
45 charl(1r')
46 end if;
47
48 end subr varo;
1 .=member endmon
1 .=member beglio
dsv 145 $ ifsa and ofsa are suggested optimizations that move
dsv 146 $ data directly from line buffer to user area where possible,
dsv 147 $ avoiding use of -gcb-.
dsv 148
dsv 149 .+s10.
dsv 150 .+set ifsa_env
dsv 151 .+set ofsa_env
dsv 152 .+set prfi $ set for debugging
dsv 153 ..s10
vaxa 11 .+s32.
vaxa 12 .+set ifsa_env
vaxa 13 .+set ofsa_env
dsb 49 .+set pcsa_env
vaxa 14 ..s32
vax 47 .+s37.
vax 48 .+set ifsa_env
vax 49 .+set ofsa_env
vax 50 ..s37
utsa 109 .+s47.
utsa 110 $ improved ifsa and ofsa not available (yet) for s47.
utsa 111 .-set ifsa_env
utsa 112 .-set ofsa_env
utsa 113 ..s47
2 .+s66.
3 .+set ofsa_env,ifsa_env
4 ..s66
dsf 74
utsb 33 .+s32u.
dsf 76 $ delete special env code for unix checkout.
dsf 77 .-set ifsa_env
dsf 78 .-set ofsa_env
dsf 79 .-set pcsa_env
utsb 34 ..s32u
dsf 81
utsa 114 .+s47.
utsa 115 $ delete special env code for unix checkout.
utsa 116 .-set ifsa_env
utsa 117 .-set ofsa_env
utsa 118 .-set pcsa_env
utsa 119 ..s47
utsa 120
5 $ fields of io status area.
6 $ title - characters of external name.
7 $ donotbit - 'should we ignore this io request.'
8 $ sfbit - 'has streaming been forced.'
9 $ ignorev - current 'ignore' value.
10 $ accessv - current 'access' value.
11 $ endseenv - used for 'mark' in 'filestat'.
12 $ errorv - associated with 'error' in 'filestat'.
13 $ binaryv - 'is this binary file'.
14 $ linesizev - 'linesize' value.
15 $ lbptr - current position in line buffer.
16 $ writing - 'are we writing to file' (0 if reading)
17 $ endack - 'must user acknowledge end of file.'
18 $ strorgv - address of lsw of string for access string.
19 $ lbmax - if lbptr decremented while forming line then
20 $ is largest value of lbptr, else is zero.
21 $ linenum - line number (number of sio ops)
22
23 +* donotbit(f) = .f. 01, 01, fatra(f) **
24 +* sfbit(f) = .f. 02, 01, fatra(f) **
25 +* ignorev(f) = .f. 04, 02, fatra(f) **
26 +* endack(f) = .f. 06, 01, fatra(f) **
27 +* accessv(f) = .f. 07, 03, fatra(f) **
28 +* endseenv(f) = .f. 10, 01, fatra(f) **
29 +* canput(f) = .f. 11, 01, fatra(f) **
30 +* canget(f) = .f. 12, 01, fatra(f) **
31 +* writing(f) = .f. 13, 01, fatra(f) **
32 +* errorv(f) = .f. 17, 05, fatra(f) **
33 +* binaryv(f) = .f. 22, 01, fatra(f) **
34 +* linesizev(f) = .f. 25, 08, fatra(f) **
35 .+s10.
36 +* lbptr(f) = .f. 37, 18, fatra(f) **
37 +* strorgv(f) = .f. 55, 18, fatra(f) **
38 +* lbmax(f) = .f. 73, 18, fatra(f) **
39 +* linenum(f) = .f. 91, 18, fatra(f) **
40 ..s10
41 .+s11.
42 +* strorgv(f) = .f. 33, 16, fatra(f) **
43 +* lbptr(f) = .f. 49, 08, fatra(f) **
44 +* lbmax(f) = .f. 57, 08, fatra(f) **
45 +* linenum(f) = .f. 65, 16, fatra(f) **
46 ..s11
vax 51 .+s32.
vax 52 +* strorgv(f) = .f. 33, 24, fatra(f) **
vax 53 +* lbptr(f) = .f. 57, 08, fatra(f) **
vax 54 +* lbmax(f) = .f. 65, 08, fatra(f) **
vax 55 $ for s32 redefine ignorev, accessv and errorv to
vax 56 $ improve code efficiency.
vax 57 +* ignorev(f) = .f. 73, 08, fatra(f) **
vax 58 +* accessv(f) = .f. 81, 08, fatra(f) **
vax 59 +* errorv(f) = .f. 89, 08, fatra(f) **
vax 60 +* linenum(f) = .f. 97, 24, fatra(f) **
vax 61 ..s32
53 .+s37.
54 +* strorgv(f) = .f. 33, 24, fatra(f) **
55 +* lbptr(f) = .f. 57, 08, fatra(f) **
56 +* lbmax(f) = .f. 65, 08, fatra(f) **
57 $ for s37 redefine ignorev, accessv and errorv to
58 $ improve code efficiency.
59 +* ignorev(f) = .f. 73, 08, fatra(f) **
60 +* accessv(f) = .f. 81, 08, fatra(f) **
61 +* errorv(f) = .f. 89, 08, fatra(f) **
62 +* linenum(f) = .f. 97, 24, fatra(f) **
63 ..s37
utsa 121 .+s47.
utsa 122 +* strorgv(f) = .f. 33, 24, fatra(f) **
utsa 123 +* lbptr(f) = .f. 57, 08, fatra(f) **
utsa 124 +* lbmax(f) = .f. 65, 08, fatra(f) **
utsa 125 $ for s47 redefine ignorev, accessv and errorv to
utsa 126 $ improve code efficiency.
utsa 127 +* ignorev(f) = .f. 73, 08, fatra(f) **
utsa 128 +* accessv(f) = .f. 81, 08, fatra(f) **
utsa 129 +* errorv(f) = .f. 89, 08, fatra(f) **
utsa 130 +* linenum(f) = .f. 97, 24, fatra(f) **
utsa 131 ..s47
dsw 32 .+s40.
dsw 33 +* strorgv(f) = .f. 33, 16, fatra(f) **
dsw 34 +* lbptr(f) = .f. 49, 08, fatra(f) **
dsw 35 +* lbmax(f) = .f. 57, 08, fatra(f) **
dsw 36 +* linenum(f) = .f. 65, 16, fatra(f) **
dsw 37 ..s40
64 .+s66.
65 +* strorgv(f) = .f. 33, 17, fatra(f) **
66 +* lbptr(f) = .f. 50, 08, fatra(f) **
67 +* lbmax(f) = .f. 61, 08, fatra(f) **
68 +* linenum(f) = .f. 69, 17, fatra(f) **
69 ..s66
70
71 +* fatrasz = $ size of fatra.
dst 74 .+s10 144
73 .+s11 80
vax 62 .+s32 128
75 .+s37 128
utsa 132 .+s47 128
dsw 38 .+s40 80
76 .+s66 120
77 **
78
79 +* titlev(f) = titlevara(f) **
80
81 $ line buffers for little io are allocated in iolba. iolbamax
82 $ gives upper bound on sum of line lengths of simultaneously
83 $ active formatted files.
84 +* iolbamax =
dsua 7 .+s10 1000
dsu 19 .+s11 400
dsf 82 .+s32 1000
dse 32 .+s37 500
utsa 133 .+s47 1000
dsw 39 .+s40 300
89 .+s66 80
90 **
91
92
93 +* iolb(c, f) = $ reference c-th char in line buffer of file -f-.
94 .f. 1 + cs*(cpw - c + cpw*((c-1)/cpw)), cs,
95 iolba(iolborg(f) + (c-1)/cpw) **
96
97
98 +* ifcanput(t) = .f. t, 1, 1b'110110' ** $ can we put to type f.
99 +* ifcanget(t) = .f. t, 1, 1b'011001' ** $ can we get from type f.
100 +* isbinary(t) = .f. t, 1, 1b'101000' ** $ if type t is binary
101 +* isoutput(t) = .f. t, 1, 1b'100110' ** $ if type t output.
102 +* isputorprint(t) = .f. t, 1, 1b'000110' **
103
104 /* all conversions take place in the global conversion
105 buffer, of length -gcblim- characters. the worst
106 case is conversion of a binary octal string of length
107 -szmax- which requires at least -szmax- characters.
108 most implementations will undoubtedly limit the length
109 of a single conversion. */
110 +* gcblim =
dsv 154 .+s10 200
112 .+s11 135
dse 33 .+s32 240
dse 34 .+s37 240
utsa 134 .+s47 240
dsw 40 .+s40 135
115 .+s66 240
116 **
117
118
119
120 $ to avoid conflicts with names of user procedures, the names of io
121 $ procedures begin with a four character code followed by a string
122 $ not usually found in names, but acceptable to the loader.
123 $ if possible, the trailer string should be '$io', as we expect
124 $ most loaders accept the character '$'.
125 $ if this string must be changed, consult use and definition of
126 $ -iorts- option in parser source.
127
dsw 41 .-s40. $ no trailer string for s40
129 +* cefr = 7ncefr$io ** $ convert exponent, fraction to real.
130 +* cref = 7ncref$io ** $ convert real for output.
131 +* deci = 7ndeci$io ** $ convert integer for output.
132 +* flsh = 7nflsh$io ** $ flush formatted output file
133 +* frew = 7nfrew$io ** $ rewind file (sys)
134 +* fwef = 7nfwef$io ** $ write eof (sys)
135 +* fwer = 7nfwer$io ** $ write record mark (sys)
136 +* gcfp = 7ngcfp$io ** $ control format processor
137 +* ifma = 7nifma$io ** $ -a- input format
138 +* ifmb = 7nifmb$io ** $ -b- input format
139 +* ifme = 7nifme$io ** $ -e- input format
140 +* ifmf = 7nifmf$io ** $ -f- input format
141 +* ifmi = 7nifmi$io ** $ -i- input format
142 +* ifmr = 7nifmr$io ** $ -r- input format
143 +* iget = 7niget$io ** $ get main procedure.
144 +* ilst = 7nilst$io ** $ get list mode.
145 +* ioer = 7nioer$io ** $ error processor
146 +* ions = 7nions$io ** $ io nameset.
147 +* ioqu = 7nioqu$io ** $ io query
148 +* iore = 7niore$io ** $ io request
149 +* iost = 7niost$io ** $ create and open std. get, put files
150 +* istr = 7nistr$io ** $ input streaming procedure
151 +* lpin = 7nlpin$io ** $ set initial position values.
152 +* makf = 7nmakf$io ** $ make system tables for file
153 +* pfin = 7npfin$io ** $ complete formatted put.
154 +* ogrp = 7nogrp$io ** $ put group constructor.
155 +* pdec = 7npdec$io ** $ put integer digits.
156 +* ofma = 7nofma$io ** $ -a- output format
157 +* ofmb = 7nofmb$io ** $ -b- output format
158 +* ofme = 7nofme$io ** $ -e- output format
159 +* ofmf = 7nofmf$io ** $ -f- output format
160 +* ofmi = 7nofmi$io ** $ -i- output format
161 +* ofmr = 7nofmr$io ** $ -r- output format
162 +* onma = 7nonma$io ** $ -n- array element name
163 +* onmv = 7nonmv$io ** $ -n- simple name list
164 +* ostr = 7nostr$io ** $ output streaming procedure
165 +* pcsa = 7npcsa$io ** $ process character for string access.
166 +* putf = 7nputf$io ** $ write print line through host io
167 +* pter = 7npter$io ** $ io error processor
168 +* prfi = 7nprfi$io ** $ print file (s66)
169 +* rdrb = 7nrdrb$io ** $ read binary slice (sys)
170 +* rlse = 7nrlse$io ** $ release file.
171 +* rwnd = 7nrwnd$io ** $ rewind file.
172 +* sigl = 7nsigl$io ** $ set ignore level.
173 +* uinp = 7nuinp$io ** $ unformatted input
174 +* unna = 7nunna$io ** $ io internal
175 +* uout = 7nuout$io ** $ unformatted output
176 +* vali = 7nvali$io ** $ validate io.
177 +* vnum = 7nvnum$io ** $ verify numeric constant.
178 +* wtrb = 7nwtrb$io ** $ write binary (sys)
dsw 42 ..s40
180
181 /* macros for standard io prologues and functions. */
182
183 $ fields of io paramter string.
184 +* iop_lm = .f. 01, 01, ** $ on if listing mode.
185 +* iop_fw = .f. 02, 08, ** $ field width.
186 +* iop_dw = .f. 10, 05, ** $ decimal (or byte) width.
187 +* iop_sz = .f. 17, 11, ** $ size of datum.
188 +* iop_gw = .f. 28, 04, ** $ group width.
189
190 +* iopsz = 32 ** $ size of io parameter string.
191
192 +* putg(c) = $ add character to gcb.
193 gcbptr = gcbptr+(gcbptr<1 ! fileid>maxfiles then $ if out of range.
237 ioerror(fileid, 2, 2);
238 end if;
239 **
240
241 +* chklioconn(f) = $ check that file f connected.
242 if accessv(f) = 0 then
243 ioerror(f, 2, 3);
244 end if;
245 **
246
1 .=member ltllio
2 subr ltllio(c); $ io executive.
3
4 size c(ps); $ action (1=start, 2=finis).
5 nameset ions; $ global conversion buffer.
6 $ printfileopen is set to one when standard print file opened.
7 size printfileopen(1); data printfileopen = no;
8 size titlevara(.sds. filenamelen); dims titlevara(maxfiles);
9 size ostr_rc(ws); $ return code from ostr.
10 size get_fc(ps); $ get format code.
11 size get_iop(iopsz); $ copy of get io parm string.
12 size ilst_rc(ws); $ get return code.
13 size istr_rc(ws); $ istr return code.
14 size get_not(ps); $ get 'global' do not bit.
15 size deci_arg(ws); $ binary integer input for conversion.
16 $ deci_lzero is nonzero if want at least deci_lzero digits
17 $ in integer conversion. leading zeros added if needed.
18 size deci_lzero(ps);
19
20 size deci_msd(ps); $ index in deciara of most significant dig.
21 $ deci_nsd is zero if all digits are to converted. if nonzero
22 $ then only first deci_nsd digits are converted.
23 size deci_nsd(ps);
24
25 $ deci_sign is zero if positive sign is not to be represented.
26 $ 1 - negative sign represented by minus.
27 $ 2 - positive sign represented by plus.
28 size deci_sign(ps);
29
30 size deci_unit(ps); $ index in deciara of 'units' digit.
31 size deciara(ws); dims deciara(deciaralen); $ integer conversio
32 size gcbptr(ps); $ on output, index of last char avail.
33 size get_mode(1); $ on if list mode input.
34 size get_bw(ps); $ byte width of l mode byte constant.
35 size get_char(cs); $ character for list mode input.
36 size get_fw(ps); $ number of characters istr is to get.
37 size get_expval(ws); $ value of exponent.
38 size gcb(ws);
39 dims gcb(gcblim);
40 size istr_file(ps); $ istr file.
41 size ostr_file(ps); $ osrt (and flsh) file.
42 size filenow(ps); $ current file.
43 size fatra(fatrasz); dims fatra(maxfiles);
44 size iolblistptr(ps);
45 size iolblist(ps); dims iolblist(maxfiles);
46 size iolborg(ps); dims iolborg(maxfiles);
47 size iolblen(ps); dims iolblen(maxfiles);
48 size iolbaptr(ps);
49 size iolba(ws); dims iolba(iolbamax);
50 end nameset ions;
51 size fi(ps);
dsi 75 size iorc(ws); $ io return code.
52
53
54 if c then $ if termination desired.
55 do fi = maxfiles to 3 by -1; $ inverse order.
56 if (accessv(fi)) call rlse(fi);
57 end do;
58 call rlse(1); call rlse(2); $ print file last.
59 return;
60 end if;
61
62 deci_lzero = 0; deci_nsd = 0; deci_sign = 0;
63 iolblistptr = 0; iolbaptr = 1;
64
65 do fi = 1 to maxfiles; $ initialize for each file.
66 fatra(fi) = 0; titlev(fi) = ''; $ set file status.
67 iolblen(fi) = 0; iolborg(fi) = 0;
68 end do;
69
dsi 76 call eretsio(2, iorc, 2); $ set verbose return if open fails.
70 call makf(2, 1b'1111', printfilename, access_print, pflen-1, 1);
dsf 83$ if cannot open standard output, terminate immediately.
dsf 84 if accessv(2)=0 then $ if could not open
dsf 85 call remarkl('cannot open standard output.');
dsf 86 $ call sysfin directly, as standard output not available.
dsj 13 call sysfin(1, 1007);
dsf 88 end if;
dsi 77 call eretsio(2, iorc, 0); $ set to quit if errors.
dsi 78
dsi 79 call eretsio(1, iorc, 1); $ set terse return if open fails.
71 call makf(1, 1b'1111', inputfilename, access_get, 0, 0);
dsi 80 call eretsio(1, iorc, 0); $ set to quit if errors.
72 end subr ltllio;
1 .=member makf
2 subr makf(farg, givarg, namearg, accarg, lnsarg, ignarg); $ make f
3 size farg(ps); $ file number.
4 $ givarg has bit -i- set if i-th attribute specified.
5 size givarg(ps);
6 size givens(ps); $ local copy of givarg.
7 size namearg(.sds.filenamelen); $ external name.
8 size accarg(ws); $ type of access.
9 size lnsarg(ws); $ line size.
10 size ignarg(ws); $ ignore level.
11 size lnsval(ps); $ copy of lnsarg.
12 size ignval(ps); $ copy of ignarg.
13 $ namearg, accarg, lnsarg and ignarg are -1 if not given in
14 $ file statement, in which case prior values are to be
15 $ inherited if possible.
16 size fileid(ps); $ file number.
17 size newname(.sds. filenamelen); $ new external name.
18 size i(ps); $ loop index.
19 size ret(ps); $ return code from oensio.
20 size ln(ps); $ name length.
21 size memptr(ps); $ returns address of argument.
22 size lnsret(ps); $ open returned linesize.
23 size accold(ps), accnew(ps); $ prior, new access codes.
24 access ions;
25
26 $ establish file correspondence.
27
28 fileid = farg;
29 chkliorange(fileid);
30 .+makfprfi call prfi(fileid,'entry to makf');
31
32 givens = givarg; $ find parameters actually specified.
33
34 .+ignoreinfilestatement.
35 if .f. 4, 1, givens then $ if ignore specified.
36 ignorev(fileid) = ignarg;
37 $ if ignore and access only specified, now pretend
38 $ that only access specified.
39 if (givens = 1b'1010') givens = 1b'0010';
40 if givens = 1b'1000' then $ if only ignore specified.
41 go to ret; end if;
42 end if;
43 ..ignoreinfilestatement
44
45 $ only can refer to file 2 once to open it (cf. ltllio).
46 if fileid=2 then
47 if (printfileopen) then ioerror(2, 2, 18); end if;
48 printfileopen = yes;
49 end if;
50
51 accnew = accarg; accold = accessv(fileid);
52
53 if givens = 1b'0010' then $ if access alone specified.
54 if accnew = access_release then $ if releasing.
55 call rlse(fileid); go to ret;
56 end if;
57 if ((accold=access_put ! accold=access_print) &
58 accnew=access_get)
59 ! (accold=access_write & accnew=access_read) then
60 $ here if changing from output to input.
61 call rwnd(fileid, accnew);
62 writing(fileid) = no;
63 errorv(fileid) = no;
64 canget(fileid) = yes; canput(fileid) = no;
65 accessv(fileid) = accnew;
66 go to ret;
67 else $ illegal case.
68 ioerror(fileid, 2, 4); go to ret;
69 end if;
70 end if;
71
72 $ here to terminate existing connection and prepare to set up
73 $ new one.
74
75 if accold then $ if existing connection.
76 call rlse(fileid);
77 end if;
78
79 .+ignoreinfilestatement.
80 $ if ignore not specified, pick default.
81 if .f. 4, 1, givens then
82 ignval = ignarg;
83 else $ pick default.
84 ignval = (accnew = access_print) ! (accnew = access_string);
85 end if;
86 .-ignoreinfilestatement.
87 ignval = (accnew = access_print) ! (accnew = access_string);
88 ..ignoreinfilestatement.
89
90 ignorev(fileid) = ignval;
91 accessv(fileid) = accnew;
92 canput(fileid) = ifcanput(accnew);
93 canget(fileid) = ifcanget(accnew);
94 binaryv(fileid)= isbinary(accnew);
95 lnsval = lnsarg * (.f. 3, 1,givens); $ set linesize if given.
96 if (lnsval^=0 & accnew=access_print) lnsval = lnsval+1;
97 iolblen(fileid) = 0;
99
100 if accnew = access_string then $ if string
101 strorgv(fileid) = memptr(namearg);
102 titlev(fileid) = '';
103 lnsret = lnsval;
104 go to allobuf;
105 end if;
106 newname = filenamelenblanks;
107 ln = slen namearg;
108 if (ln>filenamelen) ln = filenamelen;
109 do i = 1 to ln;
110 .ch. i, newname = .ch. i, namearg;
111 end do;
112 slen newname = ln;
113
dsb 50 titlev(fileid) = newname;
114 call opensio(fileid, ret, accnew, newname, lnsval, lnsret, 0, 0);
dsf 89 if ret then $ if cannot open, set access type to zero.
dsf 90 accessv(fileid) = 0;
dsf 91 go to ret;
dsf 92 end if;
dsnb 1 if accnew=access_get then $ if can get, set prompt
dsna 5 call promsio(fileid,ret,termprompt);
dsn 28 end if;
116 /allobuf/ $ here to allocate line buffer if need one.
117
118 linesizev(fileid) = lnsret;
dsy 8 call lpin(fileid); $ initialize line pointer.
119 if (lnsret) iolblen(fileid) = (lnsret-1)/cpw + 1;
120
121 if iolblen(fileid) then $ if need buffer
122 if iolblen(fileid) + iolbaptr <= iolbamax then
123 iolborg(fileid) = iolbaptr;
124 do i = 0 to iolblen(fileid)-1; $ clear buffer.
125 iolba(iolbaptr+i) = blankword;
126 end do;
127 iolbaptr = iolbaptr + iolblen(fileid);
128 iolblistptr = iolblistptr+1;
129 iolblist(iolblistptr) = fileid;
130 else
131 ioerror(fileid, 2, 7); $ if cannot allocate buffer.
132 end if;
133 end if;
134 /ret/
135 .+makfprfi call prfi(fileid,'exit from makf');
136 end subr makf;
1 .=member lpin
2 subr lpin(farg); $ initialize line pointer.
3 $ lpin contains code common to makf and rewi, which sets initial
4 $ line position for coded files and clears various fields.
5 access ions;
6 size farg(ps); $ file number.
7 size fileid(ps); $ working copy of file number.
8 size accnow(ps); $ file access.
9 size lbp(ps); $ new value of lbptr.
10
11 fileid = farg;
12 chkliorange(fileid);
13 chklioconn(fileid);
14
15 endseenv(fileid) = no;
16 endack(fileid) = no;
17 errorv(fileid) = 0;
18 $ initialize lbptr if get, put, print or string.
19 lbp = 0;
20 accnow = accessv(fileid);
21 if accnow = access_string then
22 lbp = 1;
23 elseif accnow = access_print then
24 lbp = 2; iolb(1, fileid) = 1r ;
25 elseif accnow = access_put then
26 lbp = 1;
27 elseif accnow = access_get then
28 lbp = 1 + linesizev(fileid);
29 end if;
30
31 lbmax(fileid) = 0; $ reset lbmax.
32 lbptr(fileid) = lbp;
33 linenum(fileid) = 0; $ reset line number.
34 end subr lpin;
1 .=member sigl
2 subr sigl(farg, iglev); $ set ignore level for file.
3 $ set ignore level for file. accept even if file not connected,
4 $ although value set will be lost when file opened.
5 size farg(ps); $ file number.
6 size iglev(ps); $ new ignore level.
7 size fileid(ps); $ local copy of farg.
8 access ions;
9
10 fileid = farg;
11 chkliorange(fileid);
12 ignorev(fileid) = iglev;
13 end subr sigl;
1 .=member rlse
2 subr rlse(farg); $ release file.
3 size farg(ps); $ file number.
4 access ions;
5 size fileid(ps); $ copy of file number.
6 size accnow(ps); $ type of file.
7 size j(ps), w(ps), fi(ps); $ loop indexes.
8 size oldorg(ps), neworg(ps); $ old, new line buffer origins.
9 size rc(ws); $ return code.
10
11 fileid = farg;
12 accnow = accessv(fileid);
13 if (accnow=0) return; $ if no file association.
14 if errorv(fileid)=0 & isoutput(accnow) then
dsg 8 if (accnow=access_put & lbptr(fileid)>1)
dsg 9 ! (accnow=access_print & lbptr(fileid)>2) then
17 ostr_file = fileid; call flsh;
18 end if;
19 end if;
20
21 $ if file has line buffer allocated, free it.
22 if iolborg(fileid) then
23 if iolblist(iolblistptr) = fileid then $ if last, just get s
24 iolbaptr = iolbaptr - iolblen(fileid);
25 else $ if not last, compact buffers above.
26 do j = 1 to iolblistptr;
27 if (iolblist(j)=fileid) quit do;
28 end do;
29 neworg = iolborg(fileid);
30 do fi = j+1 to iolblistptr;
31 oldorg = iolborg(iolblist(fi));
32 do w = 0 to iolblen(iolblist(fi))-1;
33 iolba(neworg+w) = iolba(oldorg+w);
34 end do w;
35 iolborg(iolblist(fi)) = neworg;
36 neworg = neworg + iolblen(iolblist(fi));
37 iolblist(fi-1) = iolblist(fi);
38 end do;
39 iolbaptr = neworg;
40 end if;
41 iolblistptr = iolblistptr - 1;
42 iolborg(fileid) = 0;
43 iolblen(fileid) = 0;
44 end if;
45
46 $ if actual file, close using sio.
47 $ if not print, or string file.
48 if accnow^=access_string then
49 call clossio(fileid, rc);
dsb 52 if rc then $ if cannot close file.
dsb 53 ioerror(fileid, 2, 21);
dsb 54 end if;
50 end if;
51 accessv(fileid) = 0; $ clear file association.
52 end subr rlse;
53 subr rwnd(farg, accnew); $ rewind file.
1 .=member rwnd
2 access ions;
3 size farg(ps); $ file number.
4 size accnew(ps); $ new access mode.
5 size fileid(ps); $ local copy of farg.
6 size ret(ws); $ return code.
7 size iot(ps); $ access of file.
8
9 fileid = farg;
10 chkliorange(fileid);
11 chklioconn(fileid);
12 iot = accessv(fileid);
13 if (iot=0) return; $ cannot rewind undefined file.
14 if errorv(fileid)=0 & isoutput(iot) then
15 if isputorprint(iot) &
16 lbptr(fileid)>1 then
17 ostr_file = fileid; call flsh;
18 end if;
19 end if;
20 if iot ^= access_string then $ if not string, can rewind.
21 $ the third argument for rewisio is nonzero if rewind is
22 $ to change access, or zero to keep current access and
23 $ rewisio is just to position file at start.
24 call rewisio(fileid, ret, accnew);
dsb 55 if ret then $ if cannot rewind file.
dsb 56 ioerror(fileid, 2, 22);
dsb 57 end if;
25 end if;
26 call lpin(fileid); $ set initial position values.
27 end subr rwnd;
1 .=member prfi
2 .+prfi.
3 $
4 $ purge this deck after debugging.
5 $
6 subr prfi(fileid,msg);
7 access ions;
8 size fileid(ps), msg(20*cs);
9 size i(ps);
10 endl; textl(msg); endl
11 tintl('file number',fileid) endl
12 textl('title=') textl(titlev(fileid)) endl
13 tintl('donotbit', donotbit(fileid)) endl
14 tintl('sfbit', sfbit(fileid)) endl
15 tintl('ignorev', ignorev(fileid)) endl
16 tintl('io access', accessv(fileid)) endl
17 tintl('end seen', endseenv(fileid)) endl
18 tintl('end acknowledge', endack(fileid)) endl
19 tintl('error', errorv(fileid)) endl
20 tintl('linesize', linesizev(fileid)) endl
21 tintl('lbptr', lbptr(fileid)) endl
22 tintl('canget',canget(fileid)) endl
23 tintl('canput',canput(fileid)) endl
24 tintl('writing', writing(fileid)) endl
25 tintl('line buff org',iolborg(fileid))
26 tintl('line buff len',iolblen(fileid)) endl
27 textl('end of file attribute list.') endl;
28 end subr prfi;
29 ..prfi
1 .=member vali
2 subr vali(farg, act); $ validation procedure.
3 access ions;
4 $ set =writing= value for file.
5 size farg(ps); $ file number.
6 size fileid(ps), what(ps);
7 size wb(1); $ on if want to write (output) to file.
8 $ verify that file fileid attributes consistent with desired
9 $ operation expressed in io parm string iop. if not, issue
10 $ error message and set donotbit. if ok, clear donotbit and
11 $ error fields, and set writing flag if writing to file.
12 size act(ps); $ type of validation.
13 $ .f. 1, 1, act on for read, .f. 2, 1, on for binary.
14
15 fileid = farg;
16 chkliorange(fileid);
17 chklioconn(fileid); $ verify connection.
18 filenow = fileid; $ set file for this op.
19 donotbit(fileid)= 0; $turn donotbit off
20 $ clear all error flags
21 errorv(fileid)= 0;
22 sfbit(fileid)= 0;
23
24 wb = .f. 1, 1, act; $ on if want to write to file.
25 if wb then $ if want to write.
26 if (canput(fileid) = no) go to valierr;
27 else
28 if (canget(fileid) = no) go to valierr;
29 end if;
30 writing(fileid) = wb;
31 if (binaryv(fileid) ^= .f. 2, 1, act) go to valierr;
32 return;
33 /valierr/ $ here if validation fails.
34 ioerror(fileid, 2, 8);
35 end subr vali;
1 .=member ioqu
2 fnct ioqu(farg, c); $ filestat function.
3 access ions;
4 $ return file attribute in response to filestat inquiry.
5 $ 1. cursor
6 $ 2. end
7 $ 3. err
8 $ 4. ignore
9 $ 5. access
10 $ 6. linesize
11 $ 7. stream
12 size ioqu (ws);
13 size farg(ps); $ file id as argument.
14 size fileid(ps), c(ps);
15
16 fileid = farg;
17 chkliorange(fileid);
18 $ require file connection unless query for access.
19 if c^=5 then
20 chklioconn(fileid);
21 end if;
22 go to l(c) in 1 to 7;
23 /l(1)/ $ return cursor position.
24 ioqu = lbptr(fileid)- (accessv(fileid) = access_print);
25 go to ret;
26 /l(2)/ $ return nonzero if at end of file.
27 endack(fileid) = 0; $ acknowledge end checked.
28 ioqu = endseenv(fileid); go to ret;
29 /l(3)/ $ return error state.
30 ioqu = errorv(fileid);
31 go to ret;
32 /l(4)/ $ return ignore level.
33 ioqu = ignorev(fileid); go to ret;
34 /l(5)/ $ return access.
35 ioqu = accessv(fileid); go to ret;
36 /l(6)/ $ return linesize.
37 ioqu = linesizev(fileid) - (accessv(fileid)=access_print);
38 go to ret;
39 /l(7)/ $ return nonzero if streaming forced.
40 ioqu = sfbit(fileid); go to ret;
41 /ret/ $ return.
42 end fnct ioqu;
1 .=member pcsa
dsb 58 .-pcsa_env.
2 subr pcsa(rc, putting, saddr, cpos, cval); $ process string access
3 /* process character for string access. saddr is the address of a
4 character string. if this string is not correctly formed, set rc
5 to one and return. cpos is an index in the string. if cpos is
6 not a valid index for the string, set rc to two and return.
7 if putting is nonzero, set the cpos-th character of the string to
8 be cval. if putting is zero, set cval to be the cpos-th character
9 of the string. */
10
11 size rc(ps); $ return code.
12 size putting(ps); $ nonzero to insert character.
13 size saddr(ps); $ address of string.
14 size cpos(ps); $ character index.
15 size cval(cs); $ character to get or put.
16 size strorg(ps); $ string origin.
17 size strlen(ps); $ current length of string.
18 size strwords(ps); $ words in string.
19 size fword(ps); $ word in string to process.
20 size fpos(ps); $ starting position of character.
21 size wd(ws); $ memory word.
22
23 size memget(ws); $ absolute memory reader.
24
25 $ sorg extraction complicated by possibility sorg and slen in
26 $ different words (code assumes if so, slen is full word).
27 wd = memget(saddr - (.sl./ws));
28 strorg = .e. (1+.sl.) - ws*(.sl./ws), .so., wd;
29 strlen = slen (memget(saddr));
30 if (strorg <= (.sl.+.so.)) go to giverr(1); $ if org too small.
31 strwords = strorg / ws;
32 if (strorg ^= (strwords*ws+1)) go to giverr(1);
33 if ((cpos<1) ! (cpos>strlen)) go to giverr(2);
34 fpos = strorg - cpos*cs;
35 if (fpos <= (.sl.+.so.)) go to giverr(2);
36 fword = fpos / ws;
37 fpos = fpos - fword*ws;
38 wd = memget(saddr-fword);
39 if putting then $ if inserting character.
40 .f. fpos, cs, wd = cval;
41 call memput(saddr-fword, wd); $ store new word.
42 else $ if extracting character.
43 cval = .f. fpos, cs, wd;
44 end if;
45 rc = 0;
46 return;
47 /giverr(1)/ $ here if string not well formed.
48 rc = 1; return;
49 /giverr(2)/ $ here if cpos not valid index.
50 rc = 2; return;
51 end subr pcsa;
dsb 59 ..pcsa_env
1 .=member ostr
2 subr ostr; $ output with streaming.
3 access ions;
4 size fw(ps); $ total external field width or nbr lines flus
5 size lbp(ps); $ entry value of lbptr for file.
6 $ 2 if physical output or system error
7 access ions;
8 size strfile(1); $ 1 if string file, 0 if external file
9 size saddr(ps); $ string address if string file.
10 size sarc(ps); $ pcsa return code.
11 size lpmax(ps); $ line buffer (or storage buffer) ptr maximum
12 size i(ps); $ loop index
13 size j(ps); $ loop index.
14 $ initialization, buffer flushing, and truncation action
15 ostr_rc = 0;
16 if gcbptr < 1 then
17 return; end if; $ useless to do anything more.
18 strfile = (accessv(ostr_file) = access_string);
19
20 lpmax = linesizev(ostr_file);
21 lbp = lbptr(ostr_file);
22
23 if strfile then $ string vs. external
24 saddr = strorgv(ostr_file);
25 end if;
26
27
28 do i = 1 to gcbptr;
29 if lbp > lpmax then $ first, write out the
30 $ line if it is full
31
32 lbptr(ostr_file) = lpmax+1; $ restore lbptr.
33 call flsh;
34 sfbit(ostr_file) = 1;
35 lbp = lbptr(ostr_file);
36 if (ostr_rc) go to error;
37 end if lbp;
38
39
40 if strfile then $ now, put -gcb(i)- into the line.
41 call pcsa(sarc, 1, saddr, lbp, gcb(i)); $ put character.
42 if sarc then
43 ioerror(ostr_file, 2, (13+sarc)); $ bad string.
44 end if;
45 else
46 iolb(lbp, ostr_file) = gcb(i);
47 end if;
48 lbp = lbp + 1;
49 end do;
50
51 lbptr(ostr_file) = lbp;
52 return;
53 /error/
54 lbptr(ostr_file) = lbp;
55 end subr ostr;
1 .=member flsh
2 subr flsh; $ flush formatted output buffer
3 access ions;
4 size strfile(1); $ 'is file of type string'
5 size lpmax(ps); $ line buffer pointer maximum
6 size qsa(ps); $ quoted string address (string file
7 size i(ps); $ counter
8 size printsw(ps); $ on for printer type files
9 size lborg(ps); $ origin position for line blanking.
10 size lbp(ps); $ copy of line buffer pointer.
11 size lbm(ps); $ copy of lbmax value.
12
13 ostr_rc = 0;
14 lpmax = linesizev(ostr_file);
15 strfile = (accessv(ostr_file) = access_string);
16 printsw = (accessv(ostr_file) = access_print);
17 lbp = lbptr(ostr_file);
18 lbm = lbmax(ostr_file);
19 if (lbm > lbp) lbp = lbm; $ set to last col if needed.
20
21 $ if string file, just reset; otherwise write line.
22 if strfile = no then $ if not string file.
23 if ostr_file = 2 then
24 call putf;
dse 35 else
26 call putwsio(ostr_file, ostr_rc, iolba,
27 iolborg(ostr_file), lbp-1);
28 linenum(ostr_file) = linenum(ostr_file)+1;
29 end if;
30 lborg = iolborg(ostr_file) - 1;
31 do i = 1 to iolblen(ostr_file);
32 iolba(lborg+i) = blankword;
33 end do;
34 end if strfile;
35 lbptr(ostr_file) = 1 + printsw;
36 lbmax(ostr_file) = 0; $ reset lbmax.
37 $ clear ostr buffer may be needed.
38 if (printsw) iolb(1, ostr_file) =1r ;
39 if (ostr_rc) go to error; $ for external fil
40 return;
41
42 /error/ $ physical or system error exit
43 ostr_rc = 3;
44 end subr flsh;
1 .=member putf
2 subr putf; $ put line to standard print file.
3 access ions;
4 access lcpns;
5
6 size lbp(ps); $ copy of line buffer pointer.
7 size lbm(ps); $ copy of lbmax value.
8
9 lbp = lbptr(2); lbm = lbmax(2) + 1;
10 if (lbm > lbp) lbp = lbm; $ set to last column if needed.
11 lbp = lbp - 1;
12 .+unpk_env.
13 $ pack line directly into lcp buffer.
14 call 7nunpk$li(pfl, 1, iolba, iolborg(2), lbp);
15 .-unpk_env.
16 size j(ps); $ loop counter
dsu 20 j = iolborg(2);
18 do pfcol = 1 to lbp;
19 pfl(pfcol) = .f. ws+1 - cs - cs*mod(pfcol-1,cpw), cs,
20 iolba(j+(pfcol-1)/cpw);
21 end do;
22 ..unpk_env
23
24 pfcol = lbp + 1;
25 call endlr; $ terminate line.
26 end subr putf;
1 .=member gcfp
2 subr_putfmt(gcfp); $ control format processor.
3 $ process control format.
4 size j(ps); $ loop index.
5 size n(ws); $ count, may be negative (x item).
6 size c(ps); $ type of control item.
7 size iot(ps); $ access of file.
8 size lbp(ps); $ entry value of lbptr.
9 size lbm(ps); $ entry value of max.
10 size writecase(1); $ on if writing to file.
11 size ret(ws); $ return code.
12
13 n = .f. 1, ws, datum;
14 c = iop;
15 lbp = lbptr(filenow);
16 lbm = lbmax(filenow);
17 writecase = writing(filenow);
18 iot = accessv(filenow);
19
20 go to l(c) in 1 to 4;
21 /l(1)/ $ column control format item
22
23 n = n + (iot = access_print);
24 if n <= 0 ! (n > linesizev(filenow)) then
25 go to parmerr;
26 else
27 if (lbp > lbm) lbmax(filenow) = lbp;
28 lbptr(filenow) = n;
29 endseenv(filenow) = 0;
30 end if;
31
32 return;
33
34 /l(2)/ $ skip (some number of lines) control format item
35 if (n = 0) return;
36
37 if iot = access_string then $ reset on skip or page.
38 lbptr(filenow) = 1; lbmax(filenow) = 0;
39 return;
40 end if;
41
42 if n < 0 ! n > 100 then
43 go to parmerr;
44 else
45 do i = 1 to n;
46 if writecase then
47 ostr_file = filenow;
48 call flsh;
49 if (ostr_rc) go to ostrerr;
50 else
51 $ force istr to read new line.
52 get_fw = 1; get_mode = 0;
53 istr_file = filenow;
54 lbptr(istr_file) = linesizev(istr_file)+1;
55 call istr;
56 ret = istr_rc;
57 if (istr_rc) go to istrerr;
58 end if;
59 end do;
60 if writecase = no then lbptr(filenow) = 1; end if;
61 end if;
62
63 return;
64 /l(3)/ $ page control format item
65
66 $ storage output -p- item becomes -j(1)- item.
67 if ((iot = access_string) & writecase) go to l(2);
68
69 if iot = access_print then
70 ostr_file = filenow;
71 call flsh;
72 if (ostr_rc) go to ostrerr;
73 iolb(1, filenow) = 1r1;
74 else
75 go to parmerr;
76 end if;
77
78 return;
79 /l(4)/ $ space control format item
80 if (n = 0) return;
81
82 if n < 0 then $ take back item
83 n = (lbp) + n;
84 $ permit retrieval of carriage control of print file.
85 if n < (1 - (iot=access_print)) then
86 go to parmerr;
87 else
88 if (lbp > lbm) lbmax(filenow) = lbp;
89 lbptr(filenow) = n + (iot=access_print);
90 end if;
91
92 else $ positive value in -x- item
93 if n > gcblim then
94 go to parmerr;
95 else
96 if writecase then
97 do i = 1 to n;
98 gcb(i) = 1r ;
99 end do;
100 gcbptr = n;
101 call pfin(iop, 0); $ write out gcb.
102 else
dsda 1 i = n + lbptr(filenow); $ desired position.
104 if i < linesizev(filenow) then
105 lbptr(filenow) = i; $ if stay in current line.
106 ret = 0;
107 else $ if x forces streaming, call istr.
108 get_fw = n; get_mode = 0;
109 istr_file = filenow; call istr;
110 if (istr_rc) go to istrerr;
111 end if;
112 end if;
113 end if;
114 end if;
115
116 return;
117
118 /istrerr/
119 /ostrerr/
120 $ here if transmission error or end seen.
121 return;
122 /parmerr/ $ here if bad parameter in control request.
123 ioerror(filenow, 2, 16);
124 return;
125 end subr gcfp;
1 .=member pfin
2 subr pfin(ioparg, c); $ complete formatted put.
3 access ions;
4 ostr_file = filenow;
5 size ioparg(iopsz); $ io parameter list.
6 $ c is termination type, as follows.
7 $ 0 - just call ostr (called from onma, onmv).
8 $ 1 - a, r formats. left align field.
9 $ 2 - b format. right align field.
10 $ 3 - e, f, i formats. groups already formed.
11 size c(ps);
12 size fw(ps); $ field width.
13 size gw(ps); $ group width.
14 size i(ps); $ loop index.
15 size nb(ps); $ number of blanks to insert.
16 size truncerr(ps); $ on if truncation error.
17
18 truncerr = no;
19 if (c=0) go to ostrdo;
20 if iop_lm ioparg then $ if list mode.
21 putg(1r ); $ terminate list field.
22 else $ if edit mode.
23 gw = iop_gw ioparg;
24 fw = iop_fw ioparg;
25 if fw >= gcblim then $ if fw too large, is truncation.
26 fw = gcblim;
27 truncerr = yes;
28 end if;
29 if ((gw>0)&(c>0)&(c<3)) call ogrp(gw, c); $ if groups.
30 if (fw > gcbptr) then
31 nb = (fw - gcbptr);
32 if c=1 then $ if left aligned, add trailing blanks.
33 do i = 1 to nb;
34 gcb(gcbptr+i) = 1r ;
35 end do;
36 else $ if right aligned, move and add leading blanks.
37 do i = gcbptr to 1 by -1; $ move data
38 gcb(i+nb) = gcb(i);
39 end do;
40 do i = 1 to nb;
41 gcb(i) = 1r ;
42 end do;
43 end if;
44 gcbptr = gcbptr + nb;
45 elseif fw < gcbptr then $ if possible truncation.
46 if (c=3) & (fw>0) then
47 truncerr = yes;
48 end if;
49 end if;
50 end if;
51
52 if (gcbptr >= gcblim) truncerr = yes;
53 /ostrdo/
54 if truncerr then $ if truncation, fill field with *.
55 do i = 1 to fw; gcb(i) = 1r*; end do;
56 gcbptr = fw;
57 end if;
58 call ostr;
59 if ostr_rc then $ if ostr transmission error.
dsb 60 ioerror(filenow, 2, 17);
61 end if;
62 if truncerr then $ if truncation error.
63 ioerror(filenow, 1, 1);
64 end if;
65 end subr pfin;
1 .=member ogrp
2 subr ogrp(gw, c); $ output group formation.
3 access ions;
4 $ form groups of gw characters each. c gives type of group:
5 $ c is one for groups formed from the left (a,r formats).
6 $ c is two for -b- format groups formed from the right.
7 size gw(ps); $ group width.
8 size c(ps); $ type of grouping desired.
9 size i(ps); $ loop index.
10 size inthis(ps); $ characters inserted in current group.
11 size nc(ps); $ number of data characters.
12 size ng(ps); $ number of groups to form.
13 size np(ps); $ position during grouping.
14 size gs(60); $ bit i on if group in numeric case.
15
16 if (gw<=0) return;
17 if c < 3 then
18 if (gcbptr<=gw) return;
19 ng = (gcbptr-1) / gw;
20 nc = gcbptr;
21 inthis = 0;
22 end if;
23 if c = 1 then $ if groups from left.
24 $ move data to right, then copy inserting group separating
25 $ blanks.
26 if ((gcbptr+ng) > gcblim) ng = gcblim - gcbptr;
27 do i = gcbptr to 1 by -1;
28 gcb(i+ng) = gcb(i);
29 end do;
30 gcbptr = gcbptr + ng;
31 np = 0;
32 do i = gcbptr-nc+1 to gcbptr;
33 np = np + 1;
34 gcb(np) = gcb(i);
35 inthis = inthis + 1;
36 if inthis=gw & (i1) then $ if group complete.
50 np = np - 1;
51 gcb(np) = 1r ;
52 inthis = 0;
53 end if inthis;
54 end do i;
55 elseif c = 3 then $ if numeric grouping, do in deciara.
56 gs = 0;
57 do i = deci_unit - gw to deci_msd by -gw;
58 .f. i, 1, gs = 1;
59 end do;
60 do i = deci_unit + gw to deci_lsd-1 by gw;
61 .f. i, 1, gs = 1;
62 end do;
63 ng = .nb. gs; $ number of groups.
64 if (ng = 0) return;
65 np = deci_msd - ng - 1;
66 do i = deci_msd to deci_lsd;
67 np = np + 1;
68 deciara(np) = deciara(i);
69 if .f. i, 1, gs then $ if end of group, add blank.
70 np = np + 1;
71 deciara(np) = 1r ;
72 end if;
73 if (i = deci_unit) deci_unit = np; $ adjust unit pos.
74 end do;
75 deci_msd = deci_msd - ng;
76 end if c;
77 end subr ogrp;
1 .=member deci
2 subr deci; $ convert integer to digit sequence.
3 access ions;
4 $ convert binary integer in deci_arg into sequence of numberic
5 $ character codes in deciara. deci_lsd gives index of least
6 $ significant digit, deci_msd gives index of most significant
7 $ digit. if deci_nsd is nonzero on entry, then only deck_nsd
8 $ digits are converted. deci_lzero is nonzero on entry to
9 $ indicate that leading zeros are to be added if necessary
10 $ to obtain deci_lzero digits.
11
12 $ the code will work correctly on two's complement machines,
13 $ which have a smallest negative integer whose absolute value is
14 $ one more than the absolute value of the largest postive
15 $ integer.
16
17 size n(ps); $ index.
18 size v(ws); $ value to convert.
19 size i(ps); $ loop indexes.
20 size d(ps); $ current digit.
21 size di(ps); $ index in ara to receive next digit.
22 size msdwant(ps); $ desired value of msd if deci_nsd given.
23
24 v = deci_arg;
25 .+itoc_env. $ if environment conversion procedure.
26 size itocara(ws); dims itocara((deciaralen/cpw)+1);
27 call itoc(v, itocara, di); $ convert.
28 deci_msd = (deci_lsd+1) - di;
29 call 7nunpk$li(deciara, deci_msd, itocara, 1, di);
30 .-itoc_env. $ if not done in environment.
31 di = deci_lsd + 1;
32 if v >= 0 then $ if nonnegative
33 until v = 0;
34 di = di - 1; $ move to next position.
35 deciara(di) = charofdig((v-(v/10)*10));
36 v = v/10;
37 end until;
38 else $ if negative.
39 until v = 0;
40 di = di - 1; $ move to next position.
41 deciara(di) = charofdig((10*(v/10)-v));
42 v = v/10;
43 end until;
44 end if;
45 deci_msd = di;
46 ..itoc_env
47 deci_msd = di; $ store position of msd.
48 deci_unit = 0; $ reset.
49 $ if exactly deci_nsd digits desired, see if more obtained.
50 $ if so, remove extra digits.
51 if deci_nsd then
52 msdwant = deci_lsd + 1 - deci_nsd; $ desired msd value.
53 if deci_msd < msdwant then $ if too many digits, drop exces
54 n = deci_msd + deci_nsd - 1;
55 do i = 0 to deci_nsd-1;
56 deciara(deci_lsd-i) = deciara(n-i);
57 end do;
58 elseif deci_msd > msdwant then $ if too few, add zeros.
59 n = deci_msd - msdwant;
60 do i = deci_msd to deci_lsd;
61 deciara(i-n) = deciara(i);
62 end do;
63 do i = 0 to n-1;
64 deciara(deci_lsd-i) = 1r0;
65 end do;
66 end if;
67 deci_msd = msdwant;
68 end if;
69 deci_nsd = 0; $ reset.
70
71 if deci_lzero then $ if want at least deci_lzero digits.
72 msdwant = deci_lsd + 1 - deci_lzero;
73 if msdwant < deci_msd then $ add leading zeros.
74 do i = msdwant to deci_msd-1;
75 deciara(i) = 1r0;
76 end do;
77 deci_msd = msdwant;
78 end if;
79 deci_lzero = 0;
80 end if;
81
82 end subr deci;
1 .=member pdec
2 subr pdec; $ copy deciara contents to gcb.
3 access ions;
4 size i(ps); $ loop index.
5 size c(cs); $ character for sign (if needed).
6
7 if deci_sign then $ if need sign character.
8 c = 1r+; if (deci_sign=1) c = 1r-;
9 putg(c);
10 deci_sign = 0; $ clear sign request.
11 end if;
12
13 do i = deci_msd to deci_lsd;
14 putg(deciara(i));
15 if i = deci_unit then putg(1r.); end if;
16 end do;
17 end subr pdec;
1 .=member ofma
2 subr_putfmt(ofma); $ -a- output format.
3 $ output character string.
4 size mode(ps); $ conversion type.
5 size sl(ps), so(ps); $ string length and origin.
6 size efw(ps); $ effective field width.
7 size c(cs); $ character in string
8 size fw(ps); $ field width.
9 size lm(1); $ on if list mode.
10
11 $ determine mode: 0=edit 1=list 2=list print.
12 lm = iop_lm iop; $ retrieve list mode.
13 fw = iop_fw iop; $ retrieve field width.
14 mode = (lm ) * (1 + (accessv(filenow) = access_print));
15 $ determine effective field width.
16 sl = .len. datum; so = sorg datum;
17 if (fw > gcblim) fw = gcblim;
18 if (fw = 0) fw = sl;
19 efw = sl; if (efw > fw) efw = fw;
20 .+ofsa_env. $ avoid use of gcb if no streaming occurs.
21 size lbp(ps); $ line buffer position.
22 size lsv(ps); $ linesize value.
23 size gw(ps); $ group width.
24
25 if mode=0 then $ can only zip through in edit mode.
26 lbp = lbptr(filenow); lsv = linesizev(filenow);
27 gw = iop_gw iop;
28 if accessv(filenow)^=access_string
29 & (lbp+fw <= lsv+1) & (gw=0) then
30 call 7nofsa$li(iolba, iolborg(filenow), lbp,
31 datum, efw, fw-efw);
32 lbptr(filenow) = lbp + fw;
33 return;
34 end if;
35 end if;
36 ..ofsa_env
37 $ verify sds structure.
38 gcbptr = 0;
39 if (mode = 1) then putg(1r'); end if;
40 do i = 1 to efw;
41 c = .f. so - i*cs, cs, datum;
42 if c = 1r' then $ if quote, see if should double.
43 if (mode = 1) then putg(1r'); end if;
44 end if;
45 putg(c);
46 end do;
47
48 if (mode = 1) then putg(1r'); end if;
49 call pfin(iop, 1);
50 end subr ofma;
1 .=member ofmb
2 subr_putfmt(ofmb); $ -b- output format.
3 size c(cs); $ character.
4 size efw(ps); $ effective field width.
5 size bw(ps); $ byte width.
6 size sz(ps); $ datum size.
7 size msb(ps); $ most significant bit to convert.
8 size j(ps); $ loop index.
9 size bv(4); $ byte from datum.
10 size lm(1); $ on if list mode.
11 size fw(ps); $ field width.
12 $ verify bw.
13 lm = iop_lm iop; $ retrieve list mode.
14 fw = iop_fw iop; $ retrieve field width.
15 bw = iop_dw iop;
16 if lm & (fw>0) then $ if list mode, fw is actually bw.
17 bw = fw;
18 fw = 0;
19 end if;
20 if (bw<1 ! bw>4) bw = mradix; $ for valid bw if not in range.
21 gcbptr = 0;
22 sz = iop_sz iop;
23 if lm then $ if list mode, put bfw and apostrophe.
24 putg(charofdig(bw)); putg(1rb); putg(1r');
25 end if;
26 if fw then $ if fw given, use fw to determine msd to convert.
27 msb = fw * bw;
28 else
29 msb = sz + 1;
30 end if;
31 if (msb > sz) msb = sz;
32
33 $ correct approximation to msb by examining data.
34 while (.f. msb, 1, datum) = 0;
35 if (msb=1) quit while;
36 msb = msb - 1;
37 end while;
38
39 do i = ((msb+bw-1)/bw -1)*bw to 0 by -bw;
40 $ can do full byte unless near end or would cross word boundary.
41 .+wsm3 if (i+bw <= sz) then
42 .-wsm3 if (i+bw<=sz) & ((i+bw-1)/ws = i/ws) then
43 bv = .f. i+1, bw, datum;
44 else $ if near end of datum, get bit by bit.
45 bv = 0; $ clear byte.
46 do j = 1 to bw;
47 .f. j, 1, bv = .f. i+j, 1, datum;
48 if ((i+j)=sz) quit do;
49 end do;
50 end if;
51 putg((.ch. bv+1, '0123456789abcdef'));
52 end do;
53
54 if (lm) then putg(1r'); end if;
55
56 call pfin(iop, 2);
57 end subr ofmb;
1 .=member ofme
2 .-fp. $ error exit if floating point not supported.
3 subr ofme(datum, ioparg); $ ofme fatal if fp not supported.
4 size datum(szmax), ioparg(iopsz);
5 call ltlfin(1, 1008); $ floating point not supported.
6 end subr ofme;
7 .+fp.
8 subr_putfmt(ofme); $ -e- output format.
9 size nsd(ps); $ number of significant digits.
10 size eint(ws); $ signed exponent value.
11 size fint(ws); $ signed fraction value.
12 size signed(1); $ on if negative value.
13 size fw(ps); $ field width.
14 size dw(ps); $ decimal (or byte) width.
15 size gw(ps); $ group width.
16 size lm(ps); $ list mode.
17
18 fw = iop_fw iop; $ retrieve field width.
19 dw = iop_dw iop; $ retrieve digit width.
20 gw = iop_gw iop; $ retrieve group width.
21 lm = iop_lm iop; $ get list mode.
22 if lm & (fw>1) then $ if list mode, fw is nsd.
23 dw = fw - 1;
24 fw = 0;
25 end if;
26 if (dw=0) dw = 5;
27 nsd = dw + 1;
28 gcbptr = 0;
29 call cref(datum, nsd, eint, fint);
30 signed = (fint<0);
31
32 if fint = 0 then $ if 0.0.
33 putg(1r0); putg(1r.);
34 else
35 deci_arg = fint; $ convert to decimal digits.
36 deci_nsd = nsd;
37 call deci;
38 deci_unit = deci_msd;
39 if gw then call ogrp(gw,3); end if;
40 deci_sign = signed; $ sign only if negative.
41 call pdec;
42 putg(1re);
43 deci_lzero = 2; $ at least two digits in exponent.
44 deci_arg = eint; call deci;
45 deci_sign = 2 - (eint<0); $ sign required for exponent.
46 call pdec;
47 end if;
48
49 call pfin(iop, 3);
50 end subr ofme;
51 ..fp
1 .=member ofmf
2 .-fp. $ error exit if floating point not supported.
3 subr ofmf(datum, ioparg); $ ofmf fatal if fp not supported.
4 size datum(szmax), ioparg(iopsz);
5 call ltlfin(1, 1008); $ floating point not supported.
6 end subr ofmf;
7 .+fp.
8 subr_putfmt(ofmf); $ -f- output conversion.
9 size n(ps); $ number of spaces to move.
10 size unitwant(ps); $ desired position of unit digit.
11 size e(ws); $ signed exponent.
12 size fint(ws); $ signed fraction value integer.
13 size nsd(ps); $ number of significant digits.
14 size signed(1); $ on if value negative.
15 size lm(1); $ on if list mode.
16 size fw(ps); $ field width.
17 size dw(ps); $ decimal (or byte) width.
18 size gw(ps); $ group width.
19
20 gcbptr = 0;
21 lm = iop_lm iop; $ get list mode.
22 if lm & (fw>0) then $ if list mode, fw is dw.
23 dw = fw;
24 fw = 0;
25 end if;
26 fw = iop_fw iop; $ retrieve field width.
27 dw = iop_dw iop; $ retrieve digit width.
28 gw = iop_gw iop; $ retrieve group width.
29 if (fw=0) fw = 8; $ 6 digits, sign and point.
30 if (fw<3) go to truncerr; $ at least one digit, sign and point.
31 nsd = 2;
32 call cref(datum, nsd, e, fint);
33 signed = (fint < 0);
34 if fint = 0 then $ 0.0 is special case.
35 e = 0; $ clear exponent, since result zero.
36 nsd = 1; go to zerocase;
37 end if;
38 if e >= 0 then $ if positive exponent, add leading dig count.
39 if (fw>0) & (e > (fw-dw-2)) then $ if overflow.
40 go to truncerr;
41 end if;
42 nsd = e + dw + 1;
43 else $ no leading digits, determine nsd.
44 e = 0 - e;
45 if (e > dw+1) then
46 e = 0; $ clear exponent, since result zero.
47 fint = 0; nsd = 1; go to zerocase; $ rounds to zero.
48 else nsd = (dw+1) - e; end if;
49 end if;
50 call cref(datum, nsd, e, fint);
51 /zerocase/
52 if (nsd = 0) nsd = 1;
53 deci_arg = fint; deci_nsd = nsd;
54 call deci;
55 deci_unit = deci_msd + e;
56
57 if deci_unit < deci_msd then $ if need leading zeros.
58 n = deci_msd - deci_unit;
59 do i = 1 to n; deciara(deci_msd-i) = 1r0; end do;
60 deci_msd = deci_msd - n;
61 end if;
62
63 unitwant = deci_lsd - dw; $ desired position of units digit.
64 if deci_unit > unitwant then $ move left, add trailing zeros.
65 n = deci_unit - unitwant;
66 do i = deci_msd to deci_lsd;
67 deciara(i-n) = deciara(i);
68 end do;
69 do i = 0 to n-1; deciara(deci_lsd-i) = 1r0; end do;
70 deci_msd = deci_msd - n;
71 elseif deci_unit < unitwant then $ move right, drop trailing di
72 n = unitwant - deci_unit;
73 do i = deci_lsd-n to deci_msd by -1;
74 deciara(i+n) = deciara(i);
75 end do;
76 deci_msd = deci_msd + n;
77 end if;
78
79 deci_unit = unitwant;
80
81 if gw then call ogrp(gw, 3); end if;
82 deci_sign = signed; $ give sign only if negative.
83 call pdec; $ add digits.
84
85 /ofmfdone/
86 call pfin(iop, 3);
87 return;
88
89 /truncerr/ $ here if truncation
90 gcbptr = fw + 1;
91 go to ofmfdone;
92 end subr ofmf;
93 ..fp
1 .=member ofmi
2 subr_putfmt(ofmi); $ -i- output format.
3 size v(ws); $ conversion value.
4 size signed(1); $ on if value negative.
5 size nsd(ps); $ number of significant digits in value.
6 size lm(1); $ on if list mode.
7 size fw(ps); $ field width.
8 size dw(ps); $ decimal (or byte) width.
9 size gw(ps); $ group width.
10 gcbptr = 0;
11 lm = iop_lm iop; $ get list mode.
12 fw = iop_fw iop; $ get field width.
13 dw = iop_dw iop; $ get digit width.
dst 75 gw = iop_gw iop;
15 v = .f. 1, ws, datum; $ is single word integer.
16 deci_arg = v;
17 deci_lzero = dw; $ if want leading zeros.
18 call deci; $ convert integer.
19 signed = (v<0);
20 nsd = deci_lsd - deci_msd + 1;
21
22 if gw then $ if groups desired.
23 deci_unit = deci_lsd;
24 call ogrp(gw, 3);
25 deci_unit = 0;
26 end if;
27
28 deci_sign = signed; $ sign only if negative.
29 call pdec;
30
31 call pfin(iop, 3);
32 return;
33 end subr ofmi;
1 .=member ofmr
2 subr_putfmt(ofmr); $ -r- output format.
3 size gi(ps); $ position in gcb
4 size di(ps); $ position in datum
5 size tw(ps); $ transmission width
6 size efw(ps); $ effective field width.
7 size sz(ps); $ datum size.
8 size lm(1); $ on if list mode.
9 size fw(ps); $ field width.
10 size dw(ps); $ decimal (or byte) width.
11
12
13 gcbptr = 0;
14 lm = iop_lm iop; $ get list mode.
15 fw = iop_fw iop; $ get field width.
16 sz = iop_sz iop;
17 dw = sz / cs;
18 efw = fw;
19 if (efw > dw) efw = dw;
20 if (efw = 0) efw = 1;
21 if lm then $ if list mode, generate prefix.
22 deci_arg = efw; $ convert to decimal.
23 call deci;
24 call pdec;
25 putg(1rr);
26 end if;
27 $ write member characters.
28 do i = (efw-1)*cs+1 to 1 by -cs;
29 putg((.f. i, cs, datum));
30 end do;
31
32 call pfin(iop, 1);
33 return;
34 end subr ofmr;
1 .=member onmv
2 subr onmv(datum); $ output variable name
3 /* output datum which is sds string generated by compiler
4 giving name of variable mentioned in -n- format. */
5 size datum(ws+1); $ sds naming variable
6 size sl(ws); $ length of name
7 size i(ps); $ do loop index for name copy to gcb
8 access ions;
9
10 if (donotbit(filenow)) return;
11 sl = slen datum;
12 gcbptr = 0;
13 putg(1r );
14 do i = 1 to sl;
15 putg((.ch. i, datum));
16 end do;
17 putg(1r=);
18 call pfin( 0, 0); $ put out gcb.
19 end subr onmv;
1 .=member onma
2 subr onma(datum, indexarg); $ print array name and inde
3 $ print name of array and value of index - 'datum(index) ='
4
5 size datum(szmax); $ contains name of array
6 size indexarg(ws); $ subscript value
7 size ret(ws); $ return value from -ostr-
8 size sl(ps); $ length of array name
9 size n(ps); $ do loop index
10 size i(ps); $ loop index.
11 access ions;
12
13 if (donotbit(filenow)) return;
14 gcbptr = 0;
15 putg(1r );
16 sl = slen datum;
17 do i = 1 to sl;
18 putg((.ch. i, datum));
19 end do;
20 putg(1r();
21 deci_arg = indexarg;
22 deci_lzero = 2;
23 call deci;
24 call pdec;
25
26 putg(1r)); putg(1r=);
27 call pfin(0, 0); $ put out gcb.
28 end subr onma;
1 .=member iget
2 subr iget(datum); $ get execu
3 access ions;
4 size datum(szmax); $ datum to convert.
5 size lm(1); $ list mode flag.
6 size fw(ps); $ field width.
7 size gw(ps); $ group width.
8 size sz(ps); $ datum size.
9 size dw(ps); $ decimal width.
10 size np(ps); $ position during group removal.
11 size i(ps); $ loop index.
12 size inthis(ps); $ number characters in current group.
13 size j(ps); $ loop index.
14 size dmax(ps); $ maximum acceptable digit for given bw.
15 size c(cs); $ current character.
16 size d(ws); $ value if character is digit.
17 size expgiven(ps); $ index of -e- in numeric constant.
18 size esign(ps); $ exponent sign (0=none, 1=+, 2=-).
19 size fsign(ps); $ fraction sign (0=none, 1=+, 2=-).
20 size fdigits(ps); $ position of decimal point.
21 access ions;
22 size eval(ws); $ absolute value of exponent.
dsi 81 .+mc size ctpc(cs); $ function to get primary case.
23
24 gcbptr = 0;
25 if (donotbit(filenow)) return;
26 ilst_rc = 0;
27 lm = iop_lm get_iop; $ get list mode.
28 fw = iop_fw get_iop; $ get field width.
29 gw = iop_gw get_iop; $ get group width.
30 sz = iop_sz get_iop; $ get datum size.
31 dw = iop_dw get_iop; $ get decimal width.
32 istr_file = filenow;
33
34 get_mode = lm; $ set input mode.
35 $ preset datum to zero.
36 do i = 1 to sz by ws;
37 .f. i, ws, datum = 0;
38 end do;
39 if lm then $ if list mode, call ilst to find field.
40 get_fw = 1;
41 call ilst;
42 if (ilst_rc) go to vererr;
43 else $ if edit mode, call istr to read in field.
44 get_fw = fw;
45 if (get_fc = get_fcb) get_bw = dw;
46 if (fw=0) go to vererr;
47 gcbptr = fw;
48 call istr;
49 end if;
50 if (istr_rc) go to istr_fail;
51 if gcbptr = gcblim then $ if truncation error
52 go to vererr;
53 end if;
54
55 if lm = 0 then $ if edit mode, process groups.
56 if gw then $ if groups, extract if -a- or -r- format.
57 if get_fc = get_fca ! get_fc = get_fcr then $ only a,r
58 inthis = 0;
59 np = 0;
60 do i = 1 to gcbptr;
61 inthis = inthis + 1;
62 if inthis <= gw then $ if datum.
63 np = np + 1;
64 gcb(np) = gcb(i);
65 else $ if end of group, skip char.
66 inthis = 0;
67 end if;
68 end do;
69 end if get_fc;
70 gcbptr = np;
71 end if gw;
72 end if;
73 $ verification required for b, e, f, i formats.
74 if get_fc = get_fcb then $ if b format,verify.
75 if (get_bw<1 ! get_bw>4) go to vererr;
76 dmax = .f. 1, get_bw, 15; $ maximum allowed digit.
77 np = 0;
78 do i = 1 to gcbptr;
79 c = gcb(i); $ get current character.
dsi 82 .+mc c = ctpc(c); $ convert to primary case.
80 if (c = 1r ) cont do; $ skip blanks.
81 d = digofchar(c); $ convert assuming decimal digit.
82 if get_bw < 4 then $ if constant takes only digits.
83 if (d<0 ! d > dmax) go to vererr;
84 else
85 if d<0 ! d>9 then $ see if hex char.
86 do j = 1 to 6;
87 if .ch. j, 'abcdef' = c then
88 quit do;
89 else
90 if (j=6) go to vererr;
91 end if;
92 end do;
93 d = j + 9;
94 end if;
95 end if;
96 np = np + 1;
97 gcb(np) = d;
98 end do;
99 gcbptr = np;
100 elseif get_fc = get_fce ! get_fc = get_fcf ! get_fc = get_fci
101 then call vnum(gcb, gcbptr, get_expval);
102 if (gcb(gcbptr+2)) go to vererr;
103 $ verify that if integer wanted, not floating point.
104 if get_fc = get_fci then $ if integer.
105 if (gcb(gcbptr+4) ! gcb(gcbptr+3)) go to vererr;
106 end if;
107 end if get_fc;
108 return;
109 /vererr/
110 gcbptr = 0; $ clear gcb, so no conversion done.
111 ioerror(filenow, 1, 1);
112 return;
113 /istr_fail/
114 donotbit(filenow) = 1;
115 return;
116 end subr iget;
1 .=member istr
2 subr istr; $ input with streaming.
3 access ions;
4 size i(ps); $ loop index.
5 access ions;
6 size strfile(1); $ 1 string file, zero if external file
7 size lbp(ps); $ working copy of lbptr(istr_file).
8 size lsv(ps); $ working copy of linesizev(istr_file).
9 size what(ps); $ return parameter from -getc-
10 size memget(ps); $ library function
11 size pfc(cs); $ place for character
12 size saddr(ps); $ string address if string file.
13 size sarc(ps); $ pcsa return code.
14 $ initialization and buffer flushing
15 istr_rc = 0;
16 lsv = linesizev(istr_file);
17 lbp = lbptr(istr_file);
18
19 strfile = (accessv(istr_file) = access_string);
20 if strfile then
21 saddr = strorgv(istr_file);
22 else
23 $ if prior end just seen, user must acknowledge it.
24 if endack(istr_file) then $ if outstanding request.
25 ioerror(istr_file, 2, 9); $ unacknowledged end.
26 end if;
27 end if;
28
29
30 if get_fw > gcblim then $ if field too large.
31 ioerror(istr_file, 2, 10); $ fw too large.
32 get_fw = gcblim; $ take acceptable value.
33 end if;
34
35 do i = 1 to get_fw;
36
37 if strfile then
38 if lbp <= slen(memget(saddr)) then
39 call pcsa(sarc, 0, saddr, lbp, pfc); $ get character.
40 if sarc then
41 ioerror(istr_file, 2, (10+sarc)); $ bad string.
42 end if;
43 lbp = 1 + lbp;
44 else
45 lbp = 1;
46 what = 1;
47 go to error;
48 end if lbp; $ end string case
49 else
50 if lbp > lsv then
51 sfbit(istr_file) = 1; $ a new line is needed
52 endseenv(istr_file) = no;
53 call getwsio(istr_file, what, iolba,iolborg(istr_file),
54 lsv);
55 linenum(istr_file) = linenum(istr_file)+1;
56 if (what) go to error;
57 lbp = 1;
58 end if;
59 pfc = iolb(lbp, istr_file);
60 lbp = 1 + lbp;
61 end if; $ character has been obtained
62
63 if get_mode then $ if list mode, return single char.
64 lbptr(istr_file) = lbp;
65 get_char = pfc;
66 return;
67 end if;
68
69
70 gcb(i) = pfc; $ put the character in pfc into
71
72 end do i;
73
74 /istrret/
75 lbptr(istr_file) = lbp;
76 return;
77 /error/
78 if what = 1 then $ if end seen.
79 endseenv(istr_file) = yes;
80 $ require user acknowledge end seen unless string file.
81 if strfile = no then
82 endack(istr_file) = yes;
83 donotbit(istr_file) = yes;
84 end if;
85 elseif what > 1 then $ if transmission error.
dsb 61 ioerror(istr_file, 2, 13);
87 end if;
88 go to istrret;
89 end subr istr;
1 .=member ilst
2 subr ilst; $ get -l- field.
3 access ions;
4 $ this procedure implements the 'free form' list mode input
5 $ as an interpreter for a special machine. the interpretive
6 $ method is used to reduce code size. the operations of the
7 $ machine are as follows:
8
9 $ act - perform action p.
10 $ add - add character, jmp to p.
11 $ cmp - compare current character with creg(p), skip on match.
12 $ dec - decrement numeric register, skip if result not zero.
13 $ err - abnormal termination.
14 $ fin - normal termination.
15 $ get - get next character.
16 $ int - collect integer, store value in numeric register.
17 $ jmp - jump to location p.
18 $ stc - store current character in character register p.
19 $ tnr - test numeric register, skip if not zero.
20 $ gnl - get next line (for skip during comments).
21
22 $ array lst is the machine memory. array creg contains
23 $ character code constants. the first entry in creg is used to
24 $ save the delimiting character of q and r constants. the
25 $ numeric register nreg contains the length prefix value for
26 $ b, q and r constants.
27
28 size creg(cs); dims creg(10); $ character registers.
29 data creg = 1r , 1r , 1r,, 1rr, 1r', 1rq, 1rb, 1r$, 1r/, 1r*;
30 size nreg(ws); $ numeric register.
31 size d(ws); $ value of decimal character.
32 size i(ps); $ loop index.
33 size holdchar(1); $ on to retain current character.
34 size lsp(ps); $ position in scan table.
35
36 size p(ps); $ parmeter value of ls op.
37 size cnow(cs); $ current character.
38 size ret(ws); $ return code.
39 size lst(16); dims lst(91); $ scan machine memory.
dsi 83 .+mc size ctpc(cs); $ function to get primary case.
40
41 $ the little macroprocessor is used to assemble the program.
42 $ the assembly is necessarily one-pass, so that labels used
43 $ in the program must be defined before use, as follows.
44 $ macros resolve labels in scan table.
45 +* l01 = 01 **
46 +* l02 = 05 **
47 +* l03 = 08 **
48 +* l04 = 15 **
49 +* l05 = 17 **
50 +* l06 = 24 **
51 +* l07 = 29 **
52 +* l08 = 37 **
53 +* l09 = 41 **
54 +* l10 = 45 **
55 +* l11 = 48 **
56 +* l12 = 52 **
57 +* l13 = 54 **
58 +* l14 = 56 **
59 +* l15 = 59 **
60 +* l16 = 61 **
61 +* l17 = 65 **
62 +* l18 = 66 **
63 +* l19 = 69 **
64 +* l20 = 72 **
65 +* l21 = 76 **
66 +* l22 = 81 **
67 +* l23 = 84 **
68 +* l24 = 88 **
69
70 $ macros for lscan opcodes.
71 +* ls_act = 01 ** +* ls_add = 02 **
72 +* ls_cmp = 03 ** +* ls_dec = 04 **
73 +* ls_err = 05 ** +* ls_fin = 06 **
74 +* ls_get = 07 ** +* ls_int = 08 **
75 +* ls_jmp = 09 ** +* ls_stc = 10 **
76 +* ls_tnr = 11 ** +* ls_gnl = 12 **
77
78 +* lsop(o,p) = o*256 + p , **
79 data lst = $ data for scan table.
80
81 $ begin by skip over sequence of blanks and commas.
82 lsop(ls_get, 0) $ l01 get
83 lsop(ls_cmp, 2) $ cmp 2 compare with blank
84 lsop(ls_jmp, l02) $ jmp l02 if not blank.
85 lsop(ls_jmp, l01) $ jmp l01 if blank.
86 lsop(ls_cmp, 3) $ l02 cmp 3 comma
87 lsop(ls_jmp, l20) $ jmp l20 if not comma.
88 lsop(ls_jmp, l01) $ jmp l01 if comma.
89
90 $ here to branch according to format type.
91 lsop(ls_act, 1) $ l03 act 1 branch on format type.
92 lsop(ls_jmp, l04) $ jmp l04 -a- format.
93 lsop(ls_jmp, l07) $ jmp l07 -b- format.
94 lsop(ls_add, l09) $ add l09 -e- format (numeric).
95 lsop(ls_add, l09) $ add l09 -f- format (numeric).
96 lsop(ls_add, l09) $ add l09 -i- format (numeric).
97 lsop(ls_jmp, l11) $ jmp l11 -r- format.
98
99 $ here for -a- format, see if quoted string or -q- constant.
100 lsop(ls_cmp, 5) $ l04 cmp 5 compare with quote.
101 lsop(ls_jmp, l06) $ jmp l06 if not quote.
102
103 $ here if quoted string, get text, watching for double apostrophe
104 lsop(ls_get, 0) $ l05 get
105 lsop(ls_cmp, 5) $ cmp 5 compare with quote.
106 lsop(ls_add, l05) $ add l05 if not quote, add.
107 lsop(ls_get, 0) $ get
108 lsop(ls_cmp, 5) $ cmp 5 compare with quote.
109 lsop(ls_jmp, l18) $ jmp l18 if not quote, done.
110 lsop(ls_add, l05) $ add l05 if (double) quote, add
111
112 $ here if -q- constant.
113 lsop(ls_int, 0) $ l06 int
114 lsop(ls_get, 0) $ get
115 lsop(ls_cmp, 6) $ cmp 6 compare with letter -q-
116 lsop(ls_err, 0) $ err if not -q-.
117 lsop(ls_jmp, l12) $ jmp l12 get delimited text.
118
119 $ here for -b- constant, get width, verify in range.
120 lsop(ls_int, 0) $ l07 int get byte width.
121 lsop(ls_act, 2) $ act 2 verify byte width.
122 lsop(ls_get, 0) $ get
123 lsop(ls_cmp, 7) $ cmp 7 compare with letter -b-
124 lsop(ls_err, 0) $ err if not -b-.
125 lsop(ls_get, 0) $ get
126 lsop(ls_cmp, 5) $ cmp 5 compare with quote.
127 lsop(ls_err, 0) $ err if not quote.
128 lsop(ls_get, 0) $ l08 get get until quote termina
129 lsop(ls_cmp, 5) $ cmp 5 compare with quote.
130 lsop(ls_add, l08) $ add l08 if not quote.
131 lsop(ls_jmp, l17) $ jmp l17 done if quote.
132
133 $ here for numeric, skip to blank or comma.
134 lsop(ls_get, 0) $ l09 get collect until blank or
135 lsop(ls_cmp, 2) $ cmp 2 compare with blank.
136 lsop(ls_jmp, l10) $ jmp l10 if not blank.
137 lsop(ls_fin, 0) $ fin if blank.
138 lsop(ls_cmp, 3) $ l10 cmp 3 comma.
139 lsop(ls_add, l09) $ add l09 if not comma.
140 lsop(ls_fin, 0) $ fin if comma.
141
142 $ here for -r- constant, get count, check for -r-.
143 lsop(ls_int, 0) $ l11 int
144 lsop(ls_get, 0) $ get
145 lsop(ls_cmp, 4) $ cmp 4 compare with letter -r-
146 lsop(ls_err, 0) $ err if not -r-.
147
148 $ here for body of -q- or -r- constant.
149 lsop(ls_tnr, 1) $ l12 tnr 1 see if count zero.
150 lsop(ls_jmp, l15) $ jmp l15 if count zero.
151
152 $ here if explicit count.
153 lsop(ls_get, 0) $ l13 get
154 lsop(ls_add, l14) $ add l14 add character.
155 lsop(ls_dec, 1) $ l14 dec 1 decrement count.
156 lsop(ls_jmp, l17) $ jmp l17 if count zero.
157 lsop(ls_jmp, l13) $ jmp l13 if chars remain.
158
159 $ here to get delimited text.
160 lsop(ls_get, 0) $ l15 get get delimiter.
161 lsop(ls_stc, 1) $ stc 1 save delimiter.
162 lsop(ls_get, 0) $ l16 get
163 lsop(ls_cmp, 1) $ cmp 1 compare with if delimit
164 lsop(ls_add, l16) $ add l16 if not delimiter.
165 lsop(ls_jmp, l17) $ jmp l17 if delimiter, done.
166
167 $ here to verify comma or blank follows constant.
168 lsop(ls_get, 0) $ l17 get
169 lsop(ls_cmp, 2) $ l18 cmp 2 compare with blank.
170 lsop(ls_jmp, l19) $ jmp l19 if not blank.
171 lsop(ls_fin, 0) $ fin
172 lsop(ls_cmp, 3) $ l19 cmp 3 compare with comma.
173 lsop(ls_err, 0) $ err
174 lsop(ls_fin, 0) $ fin if comma.
175
176 $ here to seek comment at start.
177 lsop(ls_cmp, 8) $ l20 cmp 8 compare with dollar.
178 lsop(ls_jmp, l21) $ jmp l21 if not dollar.
179 lsop(ls_gnl, 0) $ gnl get next line.
180 lsop(ls_jmp, l01) $ jmp l01 continue initial scan.
181 lsop(ls_cmp, 9) $ l21 cmp 9 compare with slash.
182 lsop(ls_jmp, l03) $ jmp l03 if not slash.
183 lsop(ls_get, 0) $ get get next character.
184 lsop(ls_cmp, 10) $ cmp 10 compare with star.
185 lsop(ls_err, 0) $ err if not * after /.
186 lsop(ls_get, 0) $ l22 get seek */ ending.
187 lsop(ls_cmp, 10) $ cmp 10 compare with star.
188 lsop(ls_jmp, l22) $ jmp l22 if not star.
189 lsop(ls_get, 0) $ l23 get seen *, seek /.
190 lsop(ls_cmp, 10) $ cmp 10 compare with star.
191 lsop(ls_jmp, l24) $ jmp l24 if not star.
192 lsop(ls_jmp, l23) $ jmp l23 seen *, seek /.
193 lsop(ls_cmp, 09) $ l24 cmp 9 compare with slash.
194 lsop(ls_jmp, l22) $ jmp l22 if not slash.
195 lsop(ls_jmp, l01) $ jmp l01 continue scan.
196 0;
197 macdrop(lsop)
198 macdrop(l01) macdrop(l02) macdrop(l03)
199 macdrop(l04) macdrop(l05) macdrop(l06)
200 macdrop(l07) macdrop(l08) macdrop(l09)
201 macdrop(l10) macdrop(l11) macdrop(l12)
202 macdrop(l13) macdrop(l14) macdrop(l15)
203 macdrop(l16) macdrop(l17) macdrop(l18)
204 macdrop(l19) macdrop(l20) macdrop(l21)
205 macdrop(l22) macdrop(l23) macdrop(l24)
206
207 holdchar = no; $ holdchar set by -int- action to retain char.
208 get_mode = yes; $ indicate that getting in l mode.
209 nreg = 0;
210 lsp = 1; $ start at first entry in scan table.
211 ilst_rc = 0; $ clear return code.
212
213 /next/
214 p = .f. 01, 08, lst(lsp); $ get parameter value.
215 go to l(.f. 09, 08, lst(lsp)) in 1 to 12; $ branch on opcode.
216
217 /l(ls_act)/ $ perform action -p-.
218 if p = 1 then $ jump according to format type.
219 lsp = lsp + get_fc; go to next;
220 elseif p = 2 then $ verify byte width.
221 get_bw = nreg;
222 if ((nreg<1) ! (nreg>4)) go to l(ls_err);
223 lsp = lsp + 1; go to next;
224 end if;
225
226 /l(ls_add)/ $ add cnow to gcb.
227 putg(cnow);
228 lsp = p; go to next;
229
230 /l(ls_cmp)/ $ compare cnow with creg(p), skip if match.
dsi 84 .+mc cnow = ctpc(cnow); $ convert to primary case.
231 lsp = lsp + 1 + (cnow = creg(p)); go to next;
232
233 /l(ls_dec)/ $ decrement nreg, skip if new value not zero.
234 if (nreg) nreg = nreg - 1;
235 lsp = lsp + 1 + (nreg ^= 0); go to next;
236
237 /l(ls_err)/ $ error, force abnormal termination.
238 ilst_rc = 1;
239 return;
240
241 /l(ls_fin)/ $ normal termination.
242 return;
243
244 /l(ls_get)/ $ get next character, end file gives error.
245 if holdchar then $ if holding char, return it.
246 holdchar = no;
247 else
248 call istr;
249 if (istr_rc) return;
250 cnow = get_char;
251 end if;
252 lsp = lsp + 1; go to next;
253
254 /l(ls_jmp)/ $ jump to position -p-.
255 lsp = p; go to next;
256
257 /l(ls_stc)/ $ store cnow in creg(p).
258 creg(p) = cnow;
259 lsp = lsp + 1; go to next;
260
261 /l(ls_tnr)/ $ test numeric register, skip if not zero.
262 lsp = lsp + 1 + (nreg ^= 0); go to next;
263
264 /l(ls_int)/ $ collect integer, error if not present.
265 nreg = 0;
266 d = digofchar(cnow);
267 if ((d < 0) ! (d > 9)) go to l(ls_err);
268 while 1;
269 nreg = nreg*10 + d;
270 istr_file = filenow; call istr;
271 if (istr_rc) return;
272 cnow = get_char;
273 d = digofchar(cnow);
274 if ((d < 0) ! (d > 9)) quit while;
275 end while;
276 holdchar = yes;
277 lsp = lsp + 1; go to next;
278
279 /l(ls_gnl)/ $ get new line (after $ comment header seen).
280 lbptr(istr_file) = linesizev(istr_file) + 1;
281 holdchar = no;
282 go to l(ls_get);
283
284 macdrop(ls_act) macdrop(ls_add) macdrop(ls_cmp)
285 macdrop(ls_dec) macdrop(ls_err) macdrop(ls_fin)
286 macdrop(ls_get) macdrop(ls_int) macdrop(ls_jmp)
287 macdrop(ls_stc) macdrop(ls_tnr) macdrop(ls_gnl)
288 end subr ilst;
1 .=member ifma
2 subr ifma(datum, ioparg); $ -a- input format.
3 size datum(szmax); $ datum.
4 size ioparg(iopsz); $ io parameter string.
5 size i(ps); $ loop index.
6 size n(ps); $ string capacity of datum.
7 size sz(ps); $ datum size.
8
9 access ions;
10
11 get_iop = ioparg;
12 get_fc = 1;
13 sz = iop_sz ioparg;
14
15 .+ifsa_env. $ bypass use of gcb if no streaming, edit mode.
16 if (donotbit(filenow)) return;
17 size lm(ps); $ on if list mode.
18 size gw(ps); $ group width.
19 size fw(ps); $ field width.
20 size efw(ps); $ effective field width.
21 size lbp(ps); $ line buffer pointer.
22 size lpb(ps); $ line position.
23 size lsv(ps); $ linesize value.
24
25 $ cannot special case string file, as data not in line buffer.
26 if (accessv(filenow) = access_string) go to notspecial;
27
28 lm = iop_lm get_iop; if (lm) go to notspecial;
29 gw = iop_gw get_iop; if (gw) go to notspecial;
30 fw = iop_fw get_iop;
31 if ((fw=0) ! ((.sds. fw) > sz)) go to notspecial;
32 lsv = linesizev(filenow);
33 lbp = lbptr(filenow);
34 if lbp+fw <= lsv+1 then
35 call 7nifsa$li(iolba, iolborg(filenow), lbp, datum, fw);
36 lbptr(filenow) = lbp + fw;
37 return;
38 end if;
39 /notspecial/
40 ..ifsa_env
41
42 sz = iop_sz get_iop;
43 call iget(datum);
44
45 if sz <= (.sl.+.so.) then $ if no room for str, get null.
46 n = 0;
47 else
48 n = (sz - (.sl.+.so.)) / cs;
49 end if;
50 if (n > gcbptr) n = gcbptr;
51 slen datum = n;
52 sorg datum = (.sds. n) + 1;
53 do i = 1 to n;
54 .ch. i, datum = gcb(i);
55 end do;
56 end subr ifma;
1 .=member ifmb
2 subr_getfmt(ifmb, 2); $ -b- output format.
3 size c(cs); $ character.
4 size efw(ps); $ effective field width.
5 size bw(ps); $ byte width.
6 size msb(ps); $ most significant bit to convert.
7 size j(ps); $ loop index.
8 size bv(4); $ byte from datum.
9 bw = get_bw;
10 msb = gcbptr * bw;
11 if (msb > sz) msb = sz;
12
13 do i = 1 to msb by bw;
14 bv = gcb(gcbptr - i/bw);
15 $ can do full byte unless near end or would cross word boundary.
16 .+wsm3 if (i+bw-1) <= sz then
17 .-wsm3 if ((i+bw-1)<=sz) & ((i+bw-2)/ws = (i-1)/ws) then
18 .f. i, bw, datum = bv;
19 else $ if near end of datum, get bit by bit.
20 do j = 0 to bw-1;
21 .f. i+j, 1, datum = .f. j+1, 1, bv ;
22 if ((i+j)=sz) quit do i;
23 end do;
24 end if;
25 end do;
26
27 end subr ifmb;
1 .=member ifme
2 .-fp.
3 subr ifme(datum, ioparg); $ ifme fatal if fp not supported.
4 size datum(szmax), ioparg(iopsz);
5 call ltlfin(1, 1008); $ floating point not supported.
6 end subr ifme;
7 .+fp.
8 subr_getfmt(ifme, 3); $ -e- and -f- input formats.
9 $ get floating point constant. iget verifies correct structure.
10 size dw(ps); $ decimal width.
11 real rv; $ real value.
12
13 dw = iop_dw ioparg; $ get decimal width.
14 $ if field given and no point or exponent in field, adjust expone
15 if gcb(gcbptr+3) > 0 then $ if point given, scale value if need
16 get_expval = get_expval - (gcb(gcbptr+3) -1);
17 elseif ((dw > 0) & (gcb(gcbptr+4)=0)) then $ if no point, and
18 get_expval = get_expval - dw;
19 end if;
20 call cefr(rv, gcb, gcbptr, get_expval);
dsx 29 if gcb(gcbptr+2) then $ if overflow or conversion error.
dsx 30 ioerror(filenow, 1, 1);
dsx 31 return;
dsx 32 end if;
21 .f. 1, ws, datum = rv;
22 end subr ifme;
23 ..fp
1 .=member ifmi
2 subr_getfmt(ifmi, 5); $ -i- input format.
3 size v(ws); $ value to convert.
4 size fnz(ps); $ index of first nonzero character.
5
6 $ use negative arithmetic to convert in case have two's
7 $ complement arithmetic.
8 v = 0;
9 do i = 1 to gcbptr; $ seek nonzero character.
10 if gcb(i) then $ if nonzero character.
11 fnz = i; go to haveval; end if;
12 end do;
13 go to retval; $ go to return zero value.
14 /haveval/
15 v = - gcb(fnz);
16 do i = fnz+1 to gcbptr; $ convert remaining digits.
17 if (v < maxnegint/10) go to oflow;
18 v = 10 * v;
19 if (((v-maxnegint)-gcb(i)) < 0) go to oflow;
20 v = v - gcb(i);
21 end do;
22 if (gcb(gcbptr+1) = 0) v = 0 - v; $ if positive result.
23 /retval/
24 .f. 1, ws, datum = v;
25 return;
26 /oflow/ $ if overflow during conversion.
27 ioerror(filenow, 1, 1); $ conversion error.
28 return;
29 end subr ifmi;
1 .=member ifmr
2 subr_getfmt(ifmr, 6); $ input -r- format
3 size n(ps); $ number of characters to convert.
4
5 n = sz / cs;
6 if (gcbptr < n) n = gcbptr;
7
8 do i = n-1 to 0 by -1;
9 .f. i*cs +1, cs, datum = gcb(gcbptr-i);
10 end do;
11 end subr ifmr;
1 .=member vnum
2 subr vnum(ara, araptr, expval);
3 $ verify structure of numeric constant.
4 $ on entry:
5 $ ara(1) to ara(araptr) contains character codes.
6 $ on exit:
7 $ ara(1) to ara(araptr) contain integers in range 0 to 9.
8 $ ara(araptr+1) is zero if value positive, one if negative.
9 $ ara(araptr+2) is zero if verification ok.
10 $ ara(araptr+2) is one if ara does not contain valid
11 $ constant.
12 $ ara(araptr+3) indicates presence of decimal point.
13 $ if ara(araptr+3) is zero, constant does not contain poin
14 $ otherwise, ara(araptr+3) is one more than the number of
15 $ digits which follow the decimal point.
16 $ of digits following the point.
17 $ ara(araptr+4) is zero if no exponent field, one if
18 $ exponent field.
19 $ if ara(araptr+4) is one, expval is a signed integer giving
20 $ the exponent value.
21
22 size ara(cs); dims ara(2); $ character list.
23 size araptr(ps); $ position in ara.
24 size np(ps); $ new value for araptr.
25 size expval(ws); $ exponent value.
26 size i(ps); $ loop index.
27 size c(cs); $ character code.
28 size d(ws); $ converted code.
29 size epos(ps); $ index of -e- in numeric constant.
30 size esign(ps); $ exponent sign (0=none, 1=+, 2=-).
31 size fsign(ps); $ fraction sign (0=none, 1=+, 2=-).
32 size pointpos(ps); $ position of decimal point.
dsi 85 .+mc size ctpc(cs); $ function to get primary case.
33 np =0;
34 epos = 0; esign = 0; fsign = 0; expval = 0;
35 pointpos = 0;
36 do i = 1 to araptr;
37 c = ara(i);
38 if (c = 1r ) cont do;
39 d = digofchar(c);
40 if d >= 0 & d <= 9 then $ if digit.
41 if epos then $ if in exponent, convert.
42 expval = expval*10 + d;
43 epos = epos + 1;
44 else $ if part of fraction, add to ara.
45 np = np + 1;
46 ara(np) = d;
47 end if;
48 elseif c = 1r. then
49 if (epos) go to vererr;
50 pointpos = np + 1;
dsi 86 .-mc elseif c = 1re then
dsi 87 .+mc elseif ctpc(c) = 1re then
52 if (epos) go to vererr; $ if duplicate -e-.
53 epos = 1;
54 elseif c = 1r+ ! c = 1r- then $ if sign.
55 if fsign=0 & np=0 then $ if first sign.
56 fsign = 1 + (c = 1r-);
57 elseif esign = 0 then $ if second sign.
58 if epos = 0 then $ if e not seen, pretend it wa
59 epos = 1;
60 esign = 1 + (c = 1r-);
61 else $ second sign, check that e came just before
62 if (epos>1) go to vererr;
63 esign = 1 + (c = 1r-);
64 end if;
66 end if fsign;
dsc 81 else go to vererr;
67 end if d;
68 end do i;
69 araptr = np;
70 if (np=0) go to vererr; $ if no digits in constant.
71 if pointpos
72 then ara(araptr+3) = np + 2 - pointpos;
73 else ara(araptr+3) = 0; end if;
74 ara(araptr+4)= (epos ^= 0);
75 if (esign=2) expval = 0 - expval;
76 ara(araptr+1) = (fsign = 2); $ restore sign code.
77 ara(araptr+2) = 0; $ indicate wellformed constant.
78 return;
79 /vererr/ $ illformed constant.
80 ara(araptr+2) = 1; $ indicate illformed constant.
81 end subr vnum;
1 .=member uinp
2 subr uinp(ara, nwords); $ unformatted input.
3 access ions;
4 size ara(ws); dims ara(2);
5 size nwords(ws); $ words to transmit
6 size ret(ws); $ return value from -rdrb- primitive -
7 $ e-o-f hit, -3 is e-o-i hit.
8 if (donotbit(filenow)) return; $ previous error, so do nothing.
9
10 if nwords < 0 then $ if bad slice spec.
11 ioerror(filenow, 2, 19);
12 elseif nwords = 0 then $ if null slice.
13 return;
14 end if;
15
16 $ if user has not acknowledged end encountered, give error.
17 if endack(filenow) then $ if outstanding request.
18 ioerror(filenow, 2, 9);
19 end if;
20
21 call rdrwsio(filenow, ret, ara, 1, nwords);
22
23 endseenv(filenow) = 0;
24 if (ret = 0) return; $ normal return
25 donotbit(filenow) = 1;
26
27 if ret > 1 then
dsb 62 ioerror(filenow, 2, 7); $ unformatted input transmission failu
29 elseif ret = 1 then $ end of file.
30 endseenv(filenow) = yes;
31 end if;
32
33 end subr uinp;
1 .=member uout
2 subr uout(ara, nwords); $ unformatted output.
3 access ions;
4 size ara(ws); dims ara(2); $ array to write.
5 size nwords(ws); $ words to transmit
6 size ret(ws); $ return value from -wtrb- primitive -
7 $ 0 is o.k., anything else is system failure.
8 if (donotbit(filenow)) return; $ previous error, so do nothing.
9 if nwords < 0 then $ if bad slice spec.
10 ioerror(filenow, 2, 19);
11 elseif nwords = 0 then $ if null slice.
12 return;
13 end if;
14 call wtrwsio(filenow, ret, ara, 1, nwords);
15 if ret then
dsb 63 ioerror(filenow, 2, 17);
17 end if;
18 end subr uout;
1 .=member ioer
2 subr ioer(farg, ernov); $ process io error.
3 access ions;
4 size farg(ps); $ file number.
5 size fileid(ps);
6 size lsv(ps); $ linesize value.
7 size lbp(ps); $ buffer pointer.
8 size lbo(ps); $ buffer origin.
9 size i(ps); $ loop index.
10 size ernov(ws); $ errorv setting + 16*error no.
11 size errno(ps); $ error number
12 size erlev(ps); $ error level.
13 $ erlev=1 for truncation/conversin, 2 for specification, and 3
14 $ if op.sys. reported transmission failure.
15 size ertab(.sds. 36); $ error message text table.
dsb 64 +* ioertot = 22 ** $ number of errors with messages.
17 +* ioert(n, t) = data ertab(n) = t; **
18 dims ertab(ioertot);
19 ioert(01, 'conversion or truncation error.')
20 ioert(02, 'invalid file number.')
21 ioert(03, 'file not connected.')
22 ioert(04, 'access alone given, not valid.')
23 ioert(05, 'linesize given, require title.')
24 ioert(06, 'require title specification.')
25 ioert(07, 'cannot allocate line buffer.')
26 ioert(08, 'file not connected for this access.')
27 ioert(09, 'attempt to read past end.')
28 ioert(10, 'field width too large.')
29 ioert(11, 'string access, get from nonstring.')
30 ioert(12, 'string access, get with bad index.')
31 ioert(13, 'input transmission failure.')
32 ioert(14, 'string access, put to nonstring.')
33 ioert(15, 'string access, put with bad index.')
34 ioert(16, 'bad control format specification.')
35 ioert(17, 'output transmission failure.')
36 ioert(18, 'cannot redefine standard print file.')
37 ioert(19, 'invalid array slice.')
dsb 65 ioert(20, 'cannot open file.')
dsb 66 ioert(21, 'cannot close file.')
dsb 67 ioert(22, 'cannot rewind file.')
38
39
40 $ must copy file argumennt in case is ostr_file.
41 fileid = farg;
42
43 if fileid<1 ! fileid>maxfiles then $ if invalid file.
44 endl textl('fatal error - invalid file number') intl(fileid)
45 endl
46 call ltlfin(1,0);
47 end if;
48
49 errno = ernov / 16;
50 erlev = ernov - 16*errno;
51
52 donotbit(fileid) = (errno^=1);
53 errorv(fileid) = erlev;
54 $ if conversion or truncation, accept only if ignore level>0.
55 $ return if error of this level acceptable.
56 if (ignorev(fileid) >= erlev) return;
57
58 if printfileopen = no then $ if cannot print message.
59 call remarkl('cannot open print file.');
60 call ltlfin(1, 1007); $ cannot open print file.
61 end if;
62
63 textl('i/o error - program fileid is ');
dsb 68 intl(fileid);
dsb 69 textl(', title is <') textl(titlev(fileid)) textl('>.')
65 endl textl(ertab(errno)) endl
66
67 $ if file has line buffer, print it and record number.
68 lbo = iolborg(fileid); $ see if origin.
69 if lbo then $ if origin, print line
70 textl('near line') intlp((linenum(fileid)),7)
71 textl(' in file') intl(fileid) endl
72 lsv = linesizev(fileid);
73 do i = 1 to iolblen(fileid);
74 wordl(iolba(lbo+i-1)); end do;
75 endl
76 lbp = lbptr(fileid);
77 if lbp>1 & lbp<=lsv then $ mark position of line pointer.
78 do i = 1 to lbp-1; charl(1r-); end do;
79 charl(1r$); $ mark line pointer position.
80 endl
81 end if;
82 end if;
83
84 $ debug printout trace if error detected
85 .+prfi call prfi(fileid,'io error detected');
86 endl
87 $ here if fatal error.
88 call ltlfin(1, 1300+errno); $ fatal io error.
89 end subr ioer;
1 .=member endlio
1 .=member blds
2 .-defenv_ss.
3 /*
4 string primitives
5
6 author - d. shields (nyu-cims) 02-aug-79
7
8 this code describes and provides an initial implementation of a
9 set of string search primitives based in part on those of snobol4
10 and using the implementation method of various spitbol implementations.
11 the basic idea is to build 'string sets' which are represented as
12 one-bit fields in a table indexed by character code. the operation
13 to determine if a character is in a set involves indexing the table
14 by the code and then anding with the appropriate mask.
15 the primitives should admit an implementation substantially more
16 efficient than the provided little implementation on most machines.
17
18 anyc(c, ss) match any character in string set ss
19 anys(s, sp, ss) match any character in string set ss
20 blds(s, ss) build string set from string s
21 brkc(s, sp, c) break to character
22 brks(s, sp, ss) break to character in string set ss
23 ctlc(s) convert character to lower case
24 ctuc(s) convert character to upper case
25 nayc(c, ss) match any character not in character set ss
26 nays(s, sp, ss) match any character not in character set ss
27 rbrc(s, sp, c) right break to character c
28 rbrs(s, sp, ss) right break to character in string set ss
29 rpld(s1, s2) define replacement string for rple
30 rple(s) execute replacement
31 rspc(s, sp, c) right span character
32 rsps(s, sp, ss) right span to character in string set ss
33 spnc(s, sp, c) span character
34 spns(s, sp, ss) span characters in string set ss
35 stlc(s) convert string to lower case
36 stuc(s) convert string to upper case
37
38 pre-assigned string sets
39 1 1b'000001' ss_blank blank
40 2 1b'000010' ss_separ separators (blank, tab, form feed)
41 4 1b'000100' ss_digit digits 0..9
42 8 1b'001000' ss_ucltr upper case letters a..z
43 16 1b'010000' ss_lcltr lower case letters a..z (if available)
44 32 1b'100000' ss_break break (underline) character '_'
45
46 ss_separ includes blank as well as any other characters which
47 by usual practice are considered equivalent to blank for separating
48 symbols. for ascii environments, the separators include horizontal
49 tab and form feed.
50
51 support up to 16 string sets
52
53
54 */
55
56 $ ss_sz is number of string sets supported. this need be no more
57 $ 16 for assembly language implementations, but is ws for the li
58 $ implementation.
59 +* ss_sz = ws ** $ number of string sets supported.
60
61 +* nchars = $ number of characters in character set.
62 $ assume cs=6 or cs=8 or cs=9
63 ((cs=8)*256 + (cs=6)*64 + (cs=9)*512)
64 **
65
66 $ codes for pre-defined string sets.
67
68 +* ss_blank = 1b'000001' **
69 +* ss_separ = 1b'000010' **
70 +* ss_digit = 1b'000100' **
71 +* ss_ucltr = 1b'001000' **
72 +* ss_lcltr = 1b'010000' **
73 +* ss_break = 1b'100000' **
74
75 subr blds(s, sma); $ build string set.
76 $ build string set for string s
77 $ which can be accessed by string mask sma.
78 nameset ssns; $ nameset for string search functions
79 size rpltab(cs); $ translate table
80 dims rpltab(nchars);
81 size sstab(ss_sz); $ string search table.
82 dims sstab(nchars);
dsc 82 .+s10. $ initialize sstab for s10 (9 bit ascii)
84 data sstab =
dsc 83 0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
dsc 84 0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
dsc 85 ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(384);
87 ..s10
88 .+s11. $ initialize sstab for s11 (8 bit ascii)
89 data sstab =
90 0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
91 0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
92 ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(128);
93 ..s11
94 .+s32. $ initialize sstab for s32 (8 bit ascii)
95 data sstab =
96 0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
97 0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
98 ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(128);
99 ..s32
100 .+s37. $ initialize sstab for s37 (8 bit ebcdic)
101 data sstab =
dsbb 2 0(5), ss_separ /* tab */, 0(6), ss_separ /* form feed */,
103 0(51), ss_blank ! ss_separ, 0(44), ss_break, 0(18),
dsbb 3 0(1), ss_lcltr(9), 0(7), ss_lcltr(9), 0(8), ss_lcltr(8),
105 0(22), 0, ss_ucltr(9), 0(7), ss_ucltr(9), 0(8), ss_ucltr(8),
106 0(6), ss_digit(10), 0(6);
107 ..s37
utsa 135 .+s47. $ initialize sstab for s47 (8 bit ascii)
utsa 136 data sstab =
utsa 137 0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
utsa 138 0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
utsa 139 ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(128);
utsa 140 ..s47
108 .+s66. $ initialize sstab for s66
109 data sstab =
110 0,
111 ss_ucltr(26), $ alphabetics
112 ss_digit(10), $ numerics
113 0(8),
114 ss_blank ! ss_separ, $ blank (the only separator)
115 0(7),
116 ss_break, $ break (underline)
117 0(10); $ remaining characters.
118 ..s66
119 end nameset;
120
121 size s(.sds. 72); $ string
122 size sma(ss_sz); $ string mask argument.
123 size sm(ss_sz); $ copy of argument.
124 size c(cs); $ character
125 size v(ps); $ temporary.
126 size i(ps); $ loop index.
127
128 $ initialize if sm is zero.
129 sm = sma; $ copy argument.
130
131 $ clear existing definition.
132
133 do i = 1 to nchars;
134 sstab(i) = sstab(i) & (.not.sm);
135 end do;
136
137 do i = 1 to (.len. s); $ enter set.
138 c = .ch. i, s;
139 sstab(1+c) = sstab(1+c) ! sm;
140 end do;
141 end subr blds;
1 .=member anyc
2 fnct anyc(c, sm); $ look for character in string set
3 $ return one if character c is in string set sm;
4 $ otherwise return zero.
5
6 access ssns; $ access ss globals.
7 size c(cs); $ character to check.
8 size anyc(ws); $ result.
9 size sm(ss_sz); $ string set mask
10
11 anyc = (sm & sstab(1+c)) ^= 0;
12 end fnct anyc;
1 .=member anys
2 fnct anys(s, sp, sm); $ look for character in string set
3 $ return one if sp-th character of string s is in string set sm;
4 $ otherwise return zero.
5
6 access ssns; $ access ss globals.
7 size s(.sds. 10); $ string to search.
8 size sp(ps); $ starting position.
9 size anys(ws); $ result.
10 size sm(ss_sz); $ string set mask
11
12 if (sp<1 ! (sp>(.len.s))) then anys = -1; return; end if;
13 anys = (sm & sstab(1+(.ch.sp,s))) ^= 0;
14 end fnct anys;
1 .=member brkc
2 fnct brkc(s, sp, ch); $ break character.
3 $ return length of longest string of s, starting at sp-th
4 $ character, which is followed by character ch.
5 $ the function must find an instance of the break character
6 $ if a nonnegative result is returned. the result is the number
7 $ of characters matched not including the break character.
8 size s(.sds. 10); $ string to search.
9 size sp(ps); $ starting position.
10 size sm(cs); $ break character.
11 size brkc(ws); $ result.
12 size i(ps); $ loop index.
13 size si(ps); $ string index.
14 size ch(cs); $ character argument..
15 size c(cs); $ character temporary.
16
17 brkc = -1;
18 if (sp<1 ! (sp>(.len.s))) return;
19 si = sp;
20 while si <= .len. s;
21 c = .ch. si, s;
22 if c=ch then $ if break character found.
23 brkc = si - sp;
24 quit while;
25 end if;
26 si = si + 1;
27 end while;
28 end fnct brkc;
1 .=member brks
2 fnct brks(s, sp, sm); $ break string set.
3 $ return length of longest string of s, starting at sp-th
4 $ character, which is followed by character in char set sm.
5 $ the function must find an instance of the break character
6 $ if a nonnegative result is returned. the result is the number
7 $ of characters matched not including the break character.
8 size s(.sds. 10); $ string to search.
9
10 access ssns; $ access ss globals.
11 size sp(ps); $ starting position.
12 size sm(ss_sz); $ string set mask
13 size brks(ws); $ result.
14 size i(ps); $ loop index.
15 size si(ps); $ string index.
16 size c(cs); $ character temporary.
17
18 brks = -1;
19 if (sp<1 ! (sp>(.len.s))) return;
20 si = sp;
21 while si <= .len. s;
22 c = .ch. si, s;
23 if sstab(1+(c)) & sm then $ if break character found.
24 brks = si - sp;
25 quit while;
26 end if;
27 si = si + 1;
28 end while;
29 end fnct brks;
1 .=member ctlc
2 fnct ctlc(c); $ convert character to lower case
3 access ssns;
4 size c(cs); $ string to translate
5 size ctlc(cs); $ translated character.
6
7 $ just copy argument if not upper case letter.
8 ctlc = c;
9 if ((sstab(1+ctlc) & ss_ucltr) = 0) return;
10 $ here to convert known upper case to lower case.
dsc 86 .+s10 ctlc = ctlc + 32;
11 .+s11 ctlc = ctlc + 32;
12 .+s32 ctlc = ctlc + 32;
13 .+s37 ctlc = ctlc - 64;
utsa 141 .+s47 ctlc = ctlc + 32;
14 end fnct ctlc;
1 .=member ctuc
2 fnct ctuc(c); $ convert character to upper case
3 access ssns;
4 size c(cs); $ string to translate
5 size ctuc(cs); $ translated character.
6
7 $ just copy argument if not lower case letter.
8 ctuc = c;
9 if ((sstab(1+ctuc) & ss_lcltr) = 0) return;
10 $ here to convert known lower case to upper case.
dsc 87 .+s10 ctuc = ctuc - 32;
11 .+s11 ctuc = ctuc - 32;
12 .+s32 ctuc = ctuc - 32;
13 .+s37 ctuc = ctuc + 64;
utsa 142 .+s47 ctuc = ctuc - 32;
14 end fnct ctuc;
1 .=member nayc
2 fnct nayc(c, sm); $ look for character not in string set
3 $ return one if character c is not in string set sm;
4 $ otherwise return zero.
5
6 access ssns; $ access ss globals.
7 size c(cs); $ character to check.
8 size nayc(ws); $ result.
9 size sm(ss_sz); $ string set mask
10
11 nayc = (sm & sstab(1+c)) = 0;
12 end fnct nayc;
1 .=member nays
2 fnct nays(s, sp, sm); $ look for character not in string set
3 $ return one if sp-th character of string s is not in string set sm;
4 $ otherwise return zero.
5
6 access ssns; $ access ss globals.
7 size s(.sds. 10); $ string to search.
8 size sp(ps); $ starting position.
9 size nays(ws); $ result.
10 size sm(ss_sz); $ string set mask
11
12 nays = -1;
13 if (sp<1 ! (sp>(.len.s))) return;
14 nays = (sm & sstab(1+(.ch.sp,s))) = 0;
15 end fnct nays;
1 .=member rbrc
2 fnct rbrc(s, sp, ch); $ right break character
3 $ return length of longest string of s, starting at sp-th
4 $ character, which is preceded by character ch.
5 $ the function must find an instance of the break character
6 $ if a nonnegative result is returned. the result is the number
7 $ of characters matched not including the break character.
8 size s(.sds. 72); $ string to search.
9 size sp(ps); $ starting position.
10 size ch(cs); $ character argument..
11 size rbrc(ws); $ result.
12 size i(ps); $ loop index.
13 size si(ps); $ string index.
14 size c(cs); $ character temporary.
15
16 rbrc = -1;
17 if (sp<1 ! (sp>(.len. s))) return;
18 si = sp;
19 while si >= 1;
20 c = .ch. si, s;
21 if c=ch then $ if break character found.
22 rbrc = sp - si;
23 quit while;
24 end if;
25 si = si - 1;
26 end while;
27 end fnct rbrc;
1 .=member rbrs
2 fnct rbrs(s, sp, sm); $ right break string set.
3 $ return length of longest string of s, starting at sp-th
4 $ character, which is preceded by character in char set sm.
5 $ search from right to left.
6 $ the function must find an instance of the break character
7 $ if a nonnegative result is returned. the result is the number
8 $ of characters matched not including the break character.
9
10 access ssns; $ access ss globals.
11 size s(.sds. 72); $ string to search.
12 size sp(ps); $ starting position.
13 size sm(ss_sz); $ string set mask
14 size rbrs(ws); $ result.
15 size i(ps); $ loop index.
16 size si(ps); $ string index.
17 size c(cs); $ character temporary.
18
19 rbrs = -1;
20 if (sp<1 ! (sp>(.len. s))) return;
21 si = sp;
22 while si >= 1;
23 c = .ch. si, s;
24 if sstab(1+(c)) & sm then $ if break character found.
25 rbrs = sp - si;
26 quit while;
27 end if;
28 si = si - 1;
29 end while;
30 end fnct rbrs;
1 .=member rpld
2 fnct rpld(s1, s2); $ define replacement string
3 $ define replacement string for subsequent use by rple.
4 $ strings s1 and s2 must have the same nonzero length, else
5 $ rpld returns failure. otherwise, the i-th character or
6 $ s1 is to be translated to the i-th character of s2.
7 size s1(.sds. 72); $ source string.
8 size s2(.sds. 72); $ target string.
9 size rpld(ws); $ function value.
10 size i(ps); $ loop index.
11 size l(ps); $ string length.
12 access ssns;
13 l = .len. s1;
14 rpld = -1;
15 if (l ^= .len. s2) return; $ if lengths differ.
16 do i = 1 to nchars; $ default is identity transformation.
17 rpltab(i-1) = i;
18 end do;
19 if (l=0) return; $ if lengths zero.
20 do i = 1 to l;
21 rpltab(1+(.ch. i, s1)) = .ch. i, s2;
22 end do;
23 rpld = 0;
24 end fnct rpld;
1 .=member rple
2 subr rple(s); $ translate string
3 $ translate string s according to translation table last
4 $ established by rpld.
vaxa 15 access ssns; $ access ss globals.
5 size s(.sds. 72);
6 size i(ps); $ loop index.
7 do i = 1 to .len. s;
8 .ch. i, s = rpltab(1+(.ch. i, s));
9 end do;
10 end subr rple;
1 .=member rspc
2 fnct rspc(s, sp, ch); $ right span character
3 $ return length of longest string of s, starting at sp-th
4 $ character, which consists of character ch.
5 $ search from right to left.
6 $ the search must find at least one instance of the character
7 $ if a nonnegative result is returned.
8 size s(.sds. 10); $ string to search
9 size sp(ps); $ starting index
10 size ch(cs); $ span character.
11 size rspc(ws); $ result.
12 size i(ps); $ loop index.
13 size si(ps); $ string index.
14 size c(cs); $ character temporary.
15
16 if (sp<1 ! sp>(.len. s)) then rspc = -1; return; end if;
17 si = sp;
18 while si >= 1;
19 c = .ch. si, s;
20 if (c^=ch) quit while; $ if end of span.
21 si = si - 1;
22 end while;
23 rspc = sp - si; $ return length.
24 if (rspc=0) rspc = -1; $ fail if no characters matched.
25 end fnct rspc;
1 .=member rsps
2 fnct rsps(s, sp, sm); $ right span string set
3 $ return length of longest string of s, starting at sp-th
4 $ character, which consists of characters in string mask sm.
5 $ search from right to left.
6 $ the search must find at least one instance of a character
7 $ in the specified string set if a nonnegative result is returned.
8
9 access ssns; $ access ss globals.
10 size s(.sds. 10); $ string to search
11 size sp(ps); $ starting index
12 size sm(16); $ string set.
13 size rsps(ws); $ result.
14 size i(ps); $ loop index.
15 size si(ps); $ string index.
16 size c(cs); $ character temporary.
17
18 if (sp<1 ! sp>(.len. s)) then rsps = -1; return; end if;
19 si = sp;
20 while si >= 1;
21 c = .ch. si, s;
22 if ((sstab(1+(c))&sm)=0) quit while; $ if end of span.
23 si = si - 1;
24 end while;
25 rsps = sp - si; $ return length.
26 if (rsps=0) rsps = -1; $ fail if no characters matched.
27 end fnct rsps;
1 .=member spnc
2 fnct spnc(s, sp, ch); $ span character
3 $ return length of longest string of s, starting at sp-th
4 $ character, which consists of character ch.
5 $ the search must find at least one instance of the character
6 $ if a nonnegative result is returned.
7 size s(.sds. 10); $ string to search
8 size sp(ps); $ starting index
9 size ch(cs); $ span character.
10 size spnc(ws); $ result.
11 size i(ps); $ loop index.
12 size si(ps); $ string index.
13 size c(cs); $ character temporary.
14
15 if (sp<1 ! sp>(.len. s)) then spnc = -1; return; end if;
16 si = sp;
17 while si <= .len. s;
18 c = .ch. si, s;
19 if (c^=ch) quit while; $ if end of span.
20 si = si + 1;
21 end while;
22 spnc = si - sp; $ return length.
23 if (spnc=0) spnc = -1; $ fail if no characters matched.
24 end fnct spnc;
1 .=member spns
2 fnct spns(s, sp, sm); $ span string set
3 $ return length of longest string of s, starting at sp-th
4 $ character, which consists of character in string set sm.
5 $ the search must find at least one instance of a character
6 $ in the specified string set if a nonnegative result is returned.
7
8 access ssns; $ access ss globals.
9 size s(.sds. 10); $ string to search
10 size sp(ps); $ starting index
11 size sm(16); $ string set.
12 size spns(ws); $ result.
13 size i(ps); $ loop index.
14 size si(ps); $ string index.
15 size c(cs); $ character temporary.
16
17 if (sp<1 ! sp>(.len. s)) then spns = -1; return; end if;
18 si = sp;
19 while si <= .len. s;
20 c = .ch. si, s;
21 if ((sstab(1+(c))&sm)=0) quit while; $ if end of span.
22 si = si + 1;
23 end while;
24 spns = si - sp; $ return length.
25 if (spns=0) spns = -1; $ fail if no characters matched.
26 end fnct spns;
1 .=member stlc
2 subr stlc(s); $ convert string to lower case.
3 size s(.sds. 72); $ string to convert
4 size ctlc(cs); $ convert character to lower case.
5 size i(ps); $ loop index.
6
7 do i = 1 to .len. s;
8 .ch. i, s = ctlc((.ch. i, s));
9 end do;
10 end subr stlc;
1 .=member stuc
2 subr stuc(s); $ convert string to upper case.
3 size s(.sds. 72); $ string to convert
4 size ctuc(cs); $ convert character to upper case.
5 size i(ps); $ loop index.
6
7 do i = 1 to .len. s;
8 .ch. i, s = ctuc((.ch. i, s));
9 end do;
10 end subr stuc;
11 ..defenv_ss
1 .=member endltl
1 .=member io16
dsx 33 .+s40.
3 subr ltlini( dummy ) ;
4 $ initialize the little system
5
6 size dummy( ws ) ;
7 call ltlsio ; $ intialize lower level
8 call ltllio( 0 ) ;
9 return ;
10 end subr ltlini;
11
12
13
14 subr ltlfin( a , b ) ;
15 size a(ws), b(ws);
16
17 call ltllio(1) ; $ terminate i/o, flush buffers
18
19 end subr ltlfin;
20
21
22
23 subr putf;
24 $ honeywell procedure to output file 2
25
26 access ions ;
27
28 call putwsio( 2 , ostr_rc , iolba , iolborg(2) , lbptr(2)-1 ) ;
29
30 end subr putf ;
31
32
33
34 subr ioer(fileid, ernov); $ error processor 1
35 access ions;
36 /* process io error -errno-. error is fatal unless -ignorev-
37 of fileid is 2. */
38 size fileid(ps);
39 size ernov(ws); $ errorv setting + 16*error no.
40 size errno(ps); $ error number
41
42 errno = ernov / 16;
43
44 donotbit(fileid) = (errno^=10);
45 errorv(fileid) = ernov - 16*errno;
46 if (errno = 10) return; $ no message if conv, trunc.
47
48 size m(.sds. 24);
49 data m = 'i/o error on file ' ;
50 .ch. 11 , m = errno/10 + 1r0 ;
51 .ch. 12 , m = mod(errno , 10) + 1r0 ;
52 .ch. 22 , m = fileid/10 + 1r0 ;
53 .ch. 23 , m = mod(fileid , 10) + 1r0 ;
54 call crlf ; call twch( m ) ; call crlf ;
55 $ error printed
56
57 end subr ioer;
dsw 44 ..s40
1 .=member begmul
2 $ we now define the multi-word support procedures.
3 $
4 $ protected names of multiword procedures.
5 +* addmw = 7niadd$mw **
6 +* andmw = 7nband$mw **
7 +* beqmw = 7nbequ$mw **
dsx 34 +* bnemw = 7nbneq$mw **
8 +* bgemw = 7nbgeq$mw **
blea 1 +* bltmw = 7nbles$mw **
9 +* casmw = 7ncasi$mw **
10 +* catmw = 7nccat$mw **
11 +* ceqmw = 7ncequ$mw **
12 +* cexmw = 7ncext$mw **
13 +* cinmw = 7ncind$mw **
14 +* divmw = 7nidiv$mw **
15 +* easmw = 7neasi$mw **
16 +* eexmw = 7neext$mw **
17 +* ermwns = 7nermw$ns ** $ nameset for multiword errors.
18 +* errmw = 7neror$mw **
19 +* ersmw = 7neros$mw **
20 +* fbtmw = 7nbfir$mw **
21 +* iormw = 7nbior$mw **
22 +* mulmw = 7nimul$mw **
23 +* notmw = 7nbnot$mw **
24 +* nbtmw = 7nbnum$mw **
25 +* submw = 7nisub$mw **
26 +* vcsmw = 7nvstr$mw **
27 +* xormw = 7nbxor$mw **
28 +* emagn = .f.1,(ws-2),** $ extract magnitude of arith item
29 +* erest = .f.(ws-1),2, ** $ extract rest of arithmetic item
30 +* ehichunk = $ extracts high order chunk of word
31 .f. ws/2, ws/2-1, **
32
33 +* elochunk = $ extract low order chunk of word
34 $ (used by multiword procedures)
35 .f. 1, ws/2-1, **
36
37 +* ehibint = $ extracts high order bits of integer
38 .f. ws/2, ws/2, **
39
1 .=member errmw
2 subr errmw(n); $ error procedure for multi-word procedures
3 $ process error detected by multiword procedures.
4 nameset ermwns;
5 size xopern(ws); $ error number.
6 size xopsorg(ws); $ sorg value if trouble with string.
7 size xopslen(ws); $ slen value if trouble with string.
8 end nameset;
9 size n(ws);
10 .+mwcc.
11 size k(ps);
12 ..mwcc
13 $
14 $ this procedure is called when multi-word procedures detect error.
15 $ negative argument indicates error in compiler, which generated
16 $ bad call; postiive argument values indicate error in user-
17 $ supplied values.
18 .+mwcc.
19 if n < 0 then
20 k = - n;
21 endl
22 textl(' system error - compiler generated bad call')
23 textl(' to multi-word procedure.')
24 go to errproc;
25 end if;
26 ..mwcc
27 endl textl('error in multi-word calculation') endl
28 textl('in construct ')
29 +* pmr(txt) = textl(txt); go to errproc; **
30 go to u(n) in 1 to 31;
31
32
33 /u( 1)/textl('=.e.p,n,x: p<=0 ! p>(size x)'); go to ernproc;
34 /u( 2)/textl('=.e.p,n,x: n<=0 ! n>(size x)'); go to ernproc;
35 /u( 3)/textl('=.e.p,n,x: p and n define field not in x.');
36 go to ernproc;
37 /u( 4)/pmr('x+y: x illformed.');
38 /u( 5)/pmr('x+y: y illformed.');
39 /u( 6)/pmr('x+y: overflow.');
40 /u( 7)/pmr('x-y: x illformed.');
41 /u( 8)/pmr('x-y: y illformed.');
42 /u( 9)/pmr('x-y: underflow');
43 /u(10)/pmr('x*y: x illformed.');
44 /u(11)/pmr('x*y: y illformed.');
45 /u(12)/pmr('x/y: x illformed.');
46 /u(13)/pmr('x/y: y illformed.');
47 /u(14)/pmr('x/y: y = 0');
48 $ 15 is standard error for illformed character string.
49 /u(15)/textl('argument not in form of string.'); go to ersproc;
50 /u(16)/textl('x.cc.y: y not in sds format.'); go to ersproc;
51 /u(17)/textl('x.in.y: x not in sds format.'); go to ersproc;
52 /u(18)/textl('x.in.y: y not in sds format.'); go to ersproc;
53 /u(19)/textl('=.s.p,n,s: p<=0 '); go to ernproc;
54 /u(20)/textl('=.s.p,n,s: n<0 '); go to ernproc;
55 /u(21)/pmr('=.s.p,n,s: p and n define substring not in s.');
56 /u(22)/textl('=.s.p,n,s: s is not in sds format.'); go to ersproc;
57 /u(23)/textl('.s.p,n,t=s: p<=0 '); go to ernproc;
58 /u(24)/textl('.s.p,n,t=s: n<0 '); go to ernproc;
59 /u(25)/textl('.s.p,n,t=s: s is not in sds format.'); go to ersproc;
60 /u(26)/textl('.s.p,n,t=s: t is not in sds format.'); go to ersproc;
61 /u(27)/pmr('.s.p,n,t=s: (p+n-1)>(slen t) (invalid position)');
62 /u(28)/textl('.e.p,n,t=s: p<=0 ! p>(size t)'); go to ernproc;
63 /u(29)/textl('.e.p,n,t=s: n<=0 ! n>(size t)'); go to ernproc;
64 /u(30)/textl('.e.p,n,t=s: (p+n-1)>(size t) (invalid position)');
65 /u(31)/textl('argument to .seq. or .sne. not char. string.')
66 go to ersproc;
67 go to ernproc;
68 /ernproc/ $ print troublesome value
69 textl(' unacceptable value =') intl(xopern);
70 go to errproc;
71 /ersproc/ $ indicate string parameters
72 textl(' unacceptable string ') endl
73 tintl('origin',xopsorg); tintl(' current length',xopslen);
74 size cap(ws); $ capacity (maximmum slen allowed by sorg)
75 cap = (xopsorg - ldcs - 1) / cs;
76 tintl(' capacity',cap) endl
77 if (cap*cs+ldcs+1)^= xopsorg then
78 textl(' string not aligned on character boundary.'); endl
79 end if;
80 if cap<= 0) ! (wy <= 0))
15 then call errmw(-1); $ bad argument to land
16 end if;
17 ..mwcc
18 $ set minof and maxof
19
20 if wx < wy then minof = wx; maxof = wy;
21 else minof = wy; maxof = wx; end if;
22
23 $ compute low order portion of result
24
25 do i = 1 to minof;
26 wordi(i, at) = (wordi(i, ax)) & (wordi(i, ay));
27 end do;
28 $
29 $ zero out high order portion of result
30 $
31 do i = 1+minof to maxof;
32 wordi(i, at) = 0;
33 end do;
34 $
35 return;
36 end subr andmw;
37 ..defenv_andmw
38
1 .=member iormw
2 .-defenv_iormw.
3 subr iormw(ax, wxarg, ay, wyarg, at); $ x ! y
4 access ermwns;
5 access ermwns;
6 size ax(szmax), ay(szmax), at(szmax); $ t = x + y.
7 size wxarg(ps), wyarg(ps); $ words in x, y.
8 size wx(ps), wy(ps); $ words in x, y (working copy).
9 size i(ps); $ loop index.
10 size minof(ps); $ min of wx, wy.
11
12 wx = wxarg; wy = wyarg;
13 .+mwcc. $ check for compiler error
14 if ((wx <= 0) ! (wy <= 0))
15 then call errmw(-2); $ bad argument to iormw
16 end if;
17 ..mwcc
18 $ set high order words of result to those of longer argument.
19 if wx < wy then
20 minof = wx;
21 do i = 1+minof to wy; wordi(i, at) = wordi(i, ay); end do;
22 else
23 minof = wy;
24 do i = 1+minof to wx; wordi(i, at) = wordi(i, ax); end do;
25 end if;
26
27 do i = 1 to minof;
28 wordi(i, at) = (wordi(i,ax)) ! (wordi(i, ay));
29 end do;
30 end subr iormw;
31 ..defenv_iormw
32
1 .=member xormw
2 .-defenv_xormw.
3 subr xormw(ax, wxarg, ay, wyarg, at); $ x .exor. y
4 access ermwns;
5 size ax(szmax), ay(szmax), at(szmax); $ t = x .exor. y.
6 size wxarg(ps), wyarg(ps); $ words in x, y.
7 size wx(ps), wy(ps); $ words in x, y (working copy).
8 size i(ps); $ loop index.
9 size minof(ps); $ min of wx, wy.
10
11 wx = wxarg; wy = wyarg;
12 .+mwcc. $ check for compiler error
13 if ((wx <= 0) ! (wy <= 0))
14 then call errmw(-3); $ bad argument to exor
15 end if;
16 ..mwcc
17 $ set high order words of result to those of longer argument.
18 if wx < wy then
19 minof = wx;
20 do i = 1+minof to wy; wordi(i, at) = wordi(i, ay); end do;
21 else
22 minof = wy;
23 do i = 1+minof to wx; wordi(i, at) = wordi(i, ax); end do;
24 end if;
25
26 do i = 1 to minof;
27 wordi(i, at) = (wordi(i,ax)) .exor. (wordi(i, ay));
28 end do;
29 end subr xormw;
30 ..defenv_xormw
31
1 .=member notmw
2 .-defenv_notmw.
3 subr notmw(ax, bxarg, at); $ ^ x
4 access ermwns;
5 size ax(szmax); $ argument.
6 size bxarg(ps), bx(ps); $ number of bits in x, and local copy.
7 size at(szmax); $ result.
8 size i(ps); $ loop index.
9 size wx(ps); $ words in argument.
10
11 bx = bxarg;
12 wx = (bx -1 ) / ws + 1;
13 .+mwcc. $ check for compiler error
14 if (wx <= 0)
15 then call errmw(-4); $ bad argument to notmw
16 end if;
17 ..mwcc
18 $ compute the result
19
20 do i = 1 to wx;
21 wordi(i, at) = .not. wordi(i, ax);
22 end do;
23
24 $ clear high order part of last word.
25 .f. bx+1, wx*ws-bx, at = 0;
26
27 end subr notmw;
28 ..defenv_notmw
1 .=member eexmw
2 subr eexmw(axarg, ayarg, az, bzarg, at, btarg); $ t = .e. x, y, z
3 access ermwns;
4 $
5 $
6 size axarg(ps), ax(ps); $ starting position, and copy.
7 size ayarg(ps), ay(ps); $ field length, and copy.
8 size bzarg(ps), bz(ps); $ size of input string.
9 size btarg(ps), bt(ps); $ size of temporary.
10 size az(szmax); $ input.
11 size at(szmax); $ output.
12 size lastbit(ps); $ number of last bit to be moved
13 size over(ps); $ number of bits left over in word
14 size wsmover(ps); $ wordsize minus over
15 size overp1(ps); $ over plus one
16 size wsmoverp1(ps); $ wsmover plus one
17 size nwtm(ps); $ number of words to move
18 size swtm(ps); $ starting word to move
19 size temp(ws); $ temporary
20 size i(ps); $ counter
21 size wint(ps); $ number of words in t
22 size nbnm(ps); $ number of bits not moved
23 ax = axarg; ay = ayarg; bz = bzarg; bt = btarg;
24 .+mwcc. $ check for compiler and user errors
25 if ((bz <= 0) ! (bt <= 0))
26 then call errmw(-6); $ bad argument to eexmw
27 end if;
28 ..mwcc
29 if ((ax <= 0) ! (ax > bz))
30 then xopern =ax; call errmw(1); $ bad lbe
31 end if;
32 if ((ay < 0) ! (ay > bz))
33 then xopern=ay; call errmw(2); $ bad eexmw user arg two
34 end if;
35 if ay then lastbit = ax + ay - 1;
36 else lastbit = ax; end if;
37 if (lastbit > bz)
38 then xopern=lastbit; call errmw(3); $ bad eexmw user arg
39 end if;
40 .+mwcc. if (ay > bt)
41 then call errmw(-6);
42 $ bad argument to eexmw
43 end if;
44 ..mwcc
45 $ move z (the data) into t (the result)
46 $
dsi 88 wint = (bt + (ws-1)) / ws;
48 nwtm = ay / ws;
49 swtm = (ax - 1) / ws;
50 wsmover = ax - (1 + swtm * ws);
51 if wsmover = 0 $ if field starts in bit 1 of a word
52 then $ the fast special case
53 do i = 1 to nwtm;
54 wordi(i, at) = wordi(i + swtm, az);
55 end do;
56 do i = nwtm + 1 to wint;
57 wordi(i, at) = 0;
58 end do;
59 over = ay - nwtm * ws;
60 if (over > 0) then
61 temp = .f. 1, over, (wordi(swtm + nwtm + 1, az));
62 wordi(nwtm + 1, at) = temp;
63 end if;
64 else $ the general case
65 over = ws - wsmover;
66 overp1 = over + 1;
67 wsmoverp1 = wsmover + 1;
68 do i = 1 to nwtm;
69 temp = .f. wsmoverp1, over, (wordi(swtm + i, az));
70 .f. overp1, wsmover, temp = wordi(swtm + i + 1, az);
71 wordi(i, at) = temp;
72 end do;
73 do i = 1+nwtm to wint;
74 wordi(i, at) = 0;
75 end do;
76 nbnm = ay - nwtm * ws;
77 if (nbnm ^= 0) then
78 if (nbnm < over) then
79 wordi(nwtm + 1, at) = .f. wsmoverp1, nbnm,
80 (wordi(swtm + nwtm + 1, az));
81 else
82 wordi(nwtm + 1, at) = .f. wsmoverp1, over,
83 (wordi(swtm + nwtm + 1, az));
84 nbnm = nbnm - over;
85 if (nbnm ^= 0) then
86 temp = 0;
87 .f. overp1, nbnm, temp = wordi(swtm + nwtm + 2, az);
88 wordi(nwtm + 1, at) = wordi(nwtm + 1, at) ! temp;
89 end if;
90 end if;
91 end if;
92 end if;
93 $
94 end subr eexmw;
1 .=member easmw
2 subr easmw(axarg, ayarg, az, bzarg, at, btarg); $ .e. x,y,t = z
3 access ermwns;
4 $
5 $
6 size axarg(ps), ax(ps); $ starting position, and copy.
7 size ayarg(ps), ay(ps); $ field length, and copy.
8 size bzarg(ps), bz(ps); $ size of input string.
9 size btarg(ps), bt(ps); $ size of temporary.
10 size az(szmax); $ input.
11 size at(szmax); $ output.
12 size lastbit(ps); $ number of last bit to be moved
13 size sworg(ps); $ source word bit origin in z
14 size nba(ps); $ number of bits available in source wo
15 size tworg(ps); $ target word bit origin in t
16 size twd(ws); $ target word (will be replaced in t)
17 size fbtbr(ps); $ first bit to be replaced in twd
18 size lbtbr(ps); $ last bit to be replaced in twd
19 size nbtbr(ps); $ number of bits to be replaced in twd
20 size swd(ws); $ source word (from z, or perhaps zero)
21 size width(ps); $ number of zero pad bits in source wor
22 size nbufsw(ps); $ number of bits used from source word
23
24 ax = axarg; ay = ayarg;
25 bz = bzarg; bt = btarg;
26 .+mwcc. $ check for compiler error
27 if ((bz <= 0) ! (bt <= 0))
28 then call errmw(-17); $ bad argument to easmw
29 end if;
30 ..mwcc
31 if ((ax <= 0) ! (ax > bt)) then
32 xopern=ax; call errmw(28); $ bad easmw user arg one
33 end if;
34 if ((ay < 0) ! (ay > bt)) then
35 xopern=ay; call errmw(29); $ bad easmw user arg two
36 end if;
37 if (ay = 0) return;
38 lastbit = ax + ay - 1;
39 if (lastbit > bt) then
40 xopern=lastbit; call errmw(30);
41 $ bad combination of arguments
42 end if; $ arguments to easmw
43
44 $ move z (the data) into t (the target field)
45
46 sworg = 1; $ initialize delimiters
47 nba = 0;
48 tworg = ((ax - 1) / ws) * ws + 1;
49 $
50 while (tworg <= lastbit);
51 twd = .f. tworg, ws, at;
52 if (tworg < ax)
53 then fbtbr = 1 + ax - tworg;
54 else fbtbr = 1;
55 end if;
56 if (lastbit < (tworg + ws))
57 then lbtbr = lastbit + 1 - tworg;
58 else lbtbr = ws;
59 end if;
60 nbtbr = lbtbr + 1 - fbtbr;
61 while (nbtbr);
62 if (nba = 0) then $ fetch ws source bits
63 if (sworg) then $ from z (or some zero
64 swd = .f. sworg, ws, az; $ bits if z has already
65 sworg = sworg + ws; $ been exhausted)
66 if (sworg > bz) then
67 width = sworg - (1 + bz);
68 if (width) then
69 .f. ws + 1 - width, width, swd = 0;
70 end if;
71 sworg = 0;
72 end if;
73 else swd = 0;
74 end if;
75 nba = ws;
76 end if; $ end bit fetch from z
77 if (nba < nbtbr)
78 then nbufsw = nba;
79 else nbufsw = nbtbr;
80 end if;
81 .f. fbtbr, nbufsw, twd = .f. ws + 1 - nba, nbufsw, swd;
82 nba = nba - nbufsw;
83 nbtbr = nbtbr - nbufsw;
84 fbtbr = fbtbr + nbufsw;
85 end while;
86 .f. tworg, ws, at = twd; $ replace twd in t
87 tworg = tworg + ws;
88 end while;
89
90 end subr easmw;
91
1 .=member fbtmw
2 .-defenv_fbtmw.
3 fnct fbtmw(ax, wxarg); $ .fb. x
4 size ax(szmax); $ argument.
5 size wxarg(ps), wx(ps); $ words in argument, and copy.
6 size fbtmw(ps); $ function value.
7 size i(ps); $ index.
8
9 wx = wxarg;
10 .+mwcc. $ check for compiler error
11 if (wx <= 0)
12 then call errmw(-7); $ bad argument to fbtmw
13 end if;
14 ..mwcc
15 fbtmw = 0;
16 do i = wx to 1 by -1;
17 if wordi(i,ax) then fbtmw = i; quit do; end if;
18 end do;
19 if fbtmw then
20 fbtmw = ws * (fbtmw - 1) + .fb. (wordi(fbtmw, ax));
21 end if;
22
23 end fnct fbtmw;
24 ..defenv_fbtmw
25
1 .=member nbtmw
2 .-defenv_nbtmw.
3 fnct nbtmw(ax, wxarg); $ .nb. x
4
5
6 size nbtmw(ps); $ function value.
7 size ax(szmax); $ argument.
8 size wxarg(ps), wx(ps); $ words in argument, and copy.
9 size i(ps); $ index.
10
11 wx = wxarg;
12 .+mwcc. $ check for compiler error
13 if (wx <= 0)
14 then call errmw(-8); $ bad argument to nbtmw
15 end if;
16 ..mwcc
17 nbtmw = 0;
18 do i = 1 to wx;
19 nbtmw = nbtmw + .nb. (wordi(i, ax));
20 end do;
21 end fnct nbtmw;
22 ..defenv_nbtmw
23
1 .=member beqmw
2 fnct beqmw(ax, wxarg, ay, wyarg); $ x = y
3
4
5 size ax(szmax), ay(szmax); $ arguments.
6 size wxarg(ps), wyarg(ps); $ words in arguments.
7 size wx(ps), wy(ps); $ words in arguments, working copy.
8 size beqmw(1); $ function value.
9 size minof(ps); $ min of wx, wy.
10 size i(ps); $ loop index.
11
12 wx = wxarg; wy = wyarg;
13 .+mwcc. $ check for compiler error
14 if ((wx <= 0) ! (wy <= 0)) then
15 call errmw(-9); $ bad argument to beqmw
16 end if;
17 ..mwcc
18 beqmw = 1;
19 if (wx < wy)
20 then minof = wx;
21 else minof = wy;
22 end if;
23
24 $ one or two of the following three loops will be executed
25
26 do i = 1 to minof;
27 if (wordi(i, ax) .ex. wordi(i, ay)) then
28 beqmw = 0;
29 return;
30 end if;
31 end do;
32 do i = 1 + minof to wx;
33 if (wordi(i, ax)) then
34 beqmw = 0;
35 return;
36 end if;
37 end do;
38 do i = 1 + minof to wy;
39 if (wordi(i, ay)) then
40 beqmw = 0;
41 return;
42 end if;
43 end do;
44
45 end fnct beqmw;
1 .=member bnemw
2 fnct bnemw(ax, wxarg, ay, wyarg); $ x .ne. y
3
4
5 size ax(szmax), ay(szmax); $ arguments.
6 size wxarg(ps), wyarg(ps); $ words in arguments.
7 size wx(ps), wy(ps); $ words in arguments, working copy.
8 size bnemw(1); $ function value.
9 size minof(ps); $ min of wx, wy.
10 size i(ps); $ loop index.
11
12 wx = wxarg; wy = wyarg;
13 .+mwcc. $ check for compiler error
14 if ((wx <= 0) ! (wy <= 0)) then
15 call errmw(-9); $ bad argument to bnemw
16 end if;
17 ..mwcc
18 bnemw = 0;
19 if (wx < wy)
20 then minof = wx;
21 else minof = wy;
22 end if;
23
24 $ one or two of the following three loops will be executed
25
26 do i = 1 to minof;
27 if (wordi(i, ax) .ex. wordi(i, ay)) then
28 bnemw = 1;
29 return;
30 end if;
31 end do;
32 do i = 1 + minof to wx;
33 if (wordi(i, ax)) then
34 bnemw = 1;
35 return;
36 end if;
37 end do;
38 do i = 1 + minof to wy;
39 if (wordi(i, ay)) then
40 bnemw = 1;
41 return;
42 end if;
43 end do;
44
45 end fnct bnemw;
1 .=member bgemw
2 fnct bgemw(ax, wxarg, ay, wyarg); $ x >= y
3 size ax(szmax), ay(szmax); $ arguments.
4 size wxarg(ps), wyarg(ps); $ words in arguments.
5 size wx(ps), wy(ps); $ words in arguments, working copy.
6 size bgemw(1); $ function value.
7 size minof(ps); $ min of wx, wy.
8 size i(ps); $ loop index.
9 size tempx(ws), tempy(ws); $ temporaries.
10
11 wx = wxarg; wy = wyarg;
12 .+mwcc. $ check for compiler error
13 if ((wx <= 0) ! (wy <= 0)) then
14 call errmw(-11); $ bad argument to bgemw
15 end if;
16 ..mwcc
17 if (wx < wy)
18 then minof = wx;
19 else minof = wy;
20 end if;
21
22 $ one or two of the following three loops will be executed
23
24 do i = 1 + minof to wx;
25 if (wordi(i, ax)) then
26 bgemw = 1;
27 return;
28 end if;
29 end do;
30 do i = 1 + minof to wy;
31 if (wordi(i, ay)) then
32 bgemw = 0;
33 return;
34 end if;
35 end do;
36 bgemw = 1;
37 do i = minof to 1 by -1;
38 tempx = wordi(i, ax);
39 tempy = wordi(i, ay);
40 if tempx ^= tempy then
41 bgemw = (tempx >= tempy);
42 return;
43 end if;
44 end do;
45 $ here if items agree, return true.
46
47 end fnct bgemw;
1 .=member bltmw
2 fnct bltmw(ax, wxarg, ay, wyarg); $ x < y
3 size ax(szmax), ay(szmax); $ arguments.
4 size wxarg(ps), wyarg(ps); $ words in arguments.
5 size wx(ps), wy(ps); $ words in arguments, working copy.
6 size bltmw(1); $ function value.
7 size minof(ps); $ min of wx, wy.
8 size i(ps); $ loop index.
9 size tempx(ws), tempy(ws); $ temporaries.
10
11 wx = wxarg; wy = wyarg;
12 .+mwcc. $ check for compiler error
13 if ((wx <= 0) ! (wy <= 0)) then
14 call errmw(-11); $ bad argument to bltmw
15 end if;
16 ..mwcc
17 if (wx < wy)
18 then minof = wx;
19 else minof = wy;
20 end if;
21
22 $ one or two of the following three loops will be executed
23
24 do i = 1 + minof to wx;
25 if (wordi(i, ax)) then
26 bltmw = 0;
27 return;
28 end if;
29 end do;
30 do i = 1 + minof to wy;
31 if (wordi(i, ay)) then
32 bltmw = 1;
33 return;
34 end if;
35 end do;
36 bltmw = 0;
37 do i = minof to 1 by -1;
38 tempx = wordi(i, ax);
39 tempy = wordi(i, ay);
40 if tempx ^= tempy then
41 bltmw = (tempx < tempy);
42 return;
43 end if;
44 end do;
45 $ here if items agree, return false.
46
47 end fnct bltmw;
1 .=member addmw
2 .-defenv_addmw.
3 subr addmw(ax, wxarg, ay, wyarg, at); $ x + y
4 access ermwns;
5 size ax(szmax), ay(szmax), at(szmax); $ t = x + y.
6 size wxarg(ps), wyarg(ps); $ words in x, y.
7 size wx(ps), wy(ps); $ words in x, y (working copy).
8 size i(ps); $ loop index.
9 size minof(ps); $ min of wx, wy.
10 size maxof(ps); $ max of wx, wy.
11 size tempx(ws), tempy(ws); $ temporaries.
12 size carry(1); $ carry bit.
13
14 wx = wxarg; wy = wyarg;
15 .+mwcc. $ check for compiler error
16 if ((wx <= 0) ! (wy <= 0))
17 then call errmw(-12); $ bad argument to addmw
18 end if;
19 ..mwcc
20 carry = 0;
21 if (wx < wy)
22 then minof = wx;
23 else minof = wy;
24 end if;
25
26 $ one or two of the following three loops will be executed
27
28 do i = 1 to minof;
29 tempx = wordi(i, ax);
30 tempy = wordi(i, ay);
31 if (erest tempx ^= 0) then
32 call errmw(4); $ bad user arg one to addm
33 end if;
34 if (erest tempy ^= 0) then
35 call errmw(5); $ bad user arg two to addm
36 end if;
37 tempy = tempx + tempy + carry;
38 carry = erest tempy;
39 wordi(i, at) = emagn tempy;
40 end do;
41
42 do i = 1 + minof to wx;
43 tempx = wordi(i, ax);
44 if (erest tempx ^= 0) then
45 call errmw(4); $ bad user arg one to addm
46 end if;
47 tempx = tempx + carry;
48 carry = erest tempx;
49 wordi(i, at)= emagn tempx;
50 end do;
51
52 do i = 1 + minof to wy;
53 tempy = wordi(i, ay);
54 if (erest tempy ^= 0) then
55 call errmw(5); $ bad user arg two to addm
56 end if;
57 tempy = tempy + carry;
58 carry = erest tempy;
59 wordi(i, at) = emagn tempy;
60 end do;
61
62 if (carry ^= 0) then
63 call errmw(6); $ overflow in addmw
64 end if;
65
66 end subr addmw;
67 ..defenv_addmw
1 .=member submw
2 .-defenv_submw.
3 subr submw(ax, wxarg, ay, wyarg, at); $ x - y
4 access ermwns;
5 size ax(szmax), ay(szmax), at(szmax); $ t = x + y.
6 size wxarg(ps), wyarg(ps); $ words in x, y.
7 size wx(ps), wy(ps); $ words in x, y (working copy).
8 size i(ps); $ loop index.
9 size minof(ps); $ min of wx, wy.
10 size tempx(ws), tempy(ws); $ temporaries.
11 size borrow(1); $ borrow bit.
12
13 wx = wxarg; wy = wyarg;
14
15 .+mwcc. $ check for compiler error
16 if ((wx <= 0) ! (wy <= 0))
17 then call errmw(-13); $ bad argument to lsub
18 end if;
19 ..mwcc
20 $ check for certain underflow - the loop may not be executed
21
22 do i = 1 + wx to wy;
23 if (wordi(i, ay) ^= 0) then
24 call errmw(9); $ underflow in lsub
25 end if;
26 end do;
27
28 $ try subtracting - we may still underflow
29
30 borrow = 0;
31 do i = 1 to wx;
32 tempx = wordi(i, ax);
33 if (erest tempx ^= 0) then
34 call errmw(7); $ bad user arg one to lsub
35 end if;
36 if (i > wy)
37 then tempy = 0;
38 else tempy = wordi(i, ay);
39 if (erest tempy ^= 0) then
40 call errmw(8); $ bad user arg two to lsub
41 end if;
42 end if;
43 tempy = tempy + borrow;
44 if (tempx >= tempy)
45 then borrow = 0;
46 else borrow = 1;
47 erest tempx = 1;
48 end if;
49 wordi(i, at) = tempx - tempy;
50 end do;
51
52 if (borrow = 1) then
53 call errmw(9); $ underflow in lsub
54 end if;
55
56 end subr submw;
57 ..defenv_submw
1 .=member mulmw
2 .-defenv_mulmw.
3 subr mulmw(ax, wxarg, ay, wyarg, at); $ x * y
4 access ermwns;
5 size ax(szmax), ay(szmax), at(szmax); $ t = x + y.
6 size wxarg(ps), wyarg(ps); $ words in x, y.
7 size wx(ps), wy(ps); $ words in x, y (working copy).
8 size minof(ps); $ min of wx, wy.
9 size tempx(ws), tempy(ws); $ temporaries.
10 size borrow(1); $ borrow bit.
11 size dig1(ws); $ low order digit of multiplicand word
12 size dig2(ws); $ high order digit of multiplicand word
13 size dig3(ws); $ low order digit of multiplier word
14 size dig4(ws); $ high order digit of multiplier word
15 size pp1(ws); $ partial product (dig1 * dig3)
16 size pp2(ws); $ partial product (dig1*dig4 + dig2*dig3)
17 size pp3(ws); $ partial product (dig2 * dig4)
18 size i(ps); $ counter for multiplicand words
19 size j(ps); $ counter for multiplier words
20 size k(ws); $ counter for product words
21 size twd(ws); $ temporary
22
23 wx = wxarg; wy = wyarg;
24 $ check for compiler and user errors, then initialize
25
26 .+mwcc. if ((wx <= 0) ! (wy <= 0))
27 then call errmw(-14); $ bad argument to lmul
28 end if;
29 ..mwcc
30 do i = 1 to wx;
31 if (erest(wordi(i, ax)))
32 then call errmw(10); $ bad user arg one to lmul
33 end if;
34 end do;
35 do j = 1 to wy;
36 if (erest(wordi(j, ay)))
37 then call errmw(11); $ bad user arg two to lmul
38 end if;
39 end do;
40 twd = wx + wy;
41 do k = 1 to twd;
42 wordi(k, at) = 0; $ zero the product field
43 end do;
44
45 $ perform multiplication
46
47 do i = 1 to wx; $ begin multiplicand loop
48 twd = wordi(i, ax);
49 if (twd) then
50 dig1 = elochunk twd;
51 dig2 = ehichunk twd;
52 do j = 1 to wy; $ begin multiplier loop
53 twd = wordi(j, ay);
54 if (twd) then
55 dig3 = elochunk twd;
56 dig4 = ehichunk twd;
57 pp1 = dig1 * dig3;
58 pp2 = dig1 * dig4 + dig2 * dig3;
59 pp3 = dig2 * dig4;
60 ehibint pp1 = (ehibint pp1) + (elochunk pp2);
61 pp3 = pp3 + (ehibint pp2) + (erest pp1);
62 erest pp1 = 0;
63 k = i + j;
64 wordi(k-1, at) = pp1 + wordi(k-1, at);
65 wordi(k, at) = erest(wordi(k-1, at)) + pp3 + wordi(k, at);
66 wordi(k-1, at) = emagn(wordi(k-1, at));
67 wordi(k+1, at) = erest(wordi(k, at)) + wordi(k+1, at);
68 wordi(k, at) = emagn(wordi(k, at));
69 end if;
70 end do; $ end multiplier loop
71 end if;
72 end do; $ end multiplicand loop
73
74 end subr mulmw;
75 ..defenv_mulmw
1 .=member divmw
2 .-defenv_divmw.
3 subr divmw(ax, wxarg, ay, wyarg, at); $ x / y
4 access ermwns;
5 size ax(szmax), ay(szmax), at(szmax); $ t = x / y.
6 size wxarg(ps), wyarg(ps); $ words in x, y.
7 size wx(ps), wy(ps); $ words in x, y (working copy).
8 size i(ps); $ loop index.
9 size middend(ps); $ start of remainder portion of dividend
10 size nswsor(ps); $ number of significant words in divisor
11 size nswdend(ps); $ number of significant words in dividend
12 size fbsor(ps); $ .fb. wordi(nswsor, divisor)
13 size fbdend(ps); $ .fb. wordi(nswdend, dividend)
14 size nsbsor(ws); $ number of significant bits in divisor
15 size nsbdend(ws); $ number of significant bits in dividend
16 size ntshsor(ps); $ number of times to shift divisor
17 size ntshdend(ps); $ number of times to shift dividend
18 size nttl(ps); $ number of times through division loop
19 size yeswedid(ws); $ subtract before shifting dividend
20 size j(ps); $ counter
21 size t1(ws); $ temporary
22 size t2(ws); $ temporary
23 size t3(ws); $ temporary
24
25 $ the algorithm used here is a software simulation of the division
26 $ process common to most computer hardware registers. the divisor
27 $ or dividend is shifted left to align their first significant bits.
28 $ then iteratively: the divisor is subtracted from the high order
29 $ end of the dividend if it is not greater than that end of the
30 $ dividend; the dividend is shifted left by one bit, and a one bit
31 $ or a zero bit is appended to its low order end according to whe-
32 $ ther subtraction was or was not performed. when this process has
33 $ been done a number of times (equal to one plus the difference be-
34 $ tween the number of significant bits in the original divisor and
35 $ dividend) then the quotient appears in the low order end of what
36 $ was the dividend and the remainder (which we do not use in this
37 $ particular application) appears in the high order end.
38
39 $ macro for left shift of long integer by one bit. yeswedid is the
40 $ bit appended to the low order end. this macro is always nested
41 $ in a loop of the form do i = - to -; .... end do;
42
43 +*ldshift(nbrofwds, whereitis) =
44 do j = 1 to nbrofwds;
45 .f. 2, (ws-1), yeswedid = wordi(j, whereitis);
46 if (j = nbrofwds)
47 then wordi(j, whereitis) = yeswedid;
48 else wordi(j, whereitis) = .f. 1, (ws-2), yeswedid;
49 yeswedid = .f. (ws-1), 1, yeswedid;
50 end if;
51 end do **
52
53 $ macro for end-off right shift of long integer by one bit. this
54 $ macro is always nested in a loop of form
55 $ do i = - to -; .... end do;
56
57 +*rdshift(nbrofwds, whereitis) =
58 t1 = .f. 2, (ws-1), whereitis;
59 do j = 2 to nbrofwds;
60 t2 = wordi(j, whereitis);
61 .f. (ws-2), 1, t1 = .f. 1, 1, t2;
62 wordi(j - 1, whereitis) = t1;
63 t1 = .f. 2, (ws-1), t2;
64 end do;
65 wordi(nbrofwds, whereitis) = t1**
66
67 $ check for bad arguments, move dividend to quotient, initialize
68 $ some of the delimiters as defined in the size statements.
69 .+mwcc. if ((wx <= 0) ! (wy <= 0))
70 then call errmw(-15); $ bad argument to ldiv
71 end if;
72 ..mwcc
73 nswdend = 0;
74 fbdend = 0;
75 do i = 1 to wx;
76 t1 = wordi(i, ax);
77 wordi(i, at) = t1; $ initialize quotient
78 if (t1) then
79 nswdend = i;
80 fbdend = t1;
81 if (erest t1) then
82 call errmw(12); $ bad user arg one to ldiv
83 end if;
84 end if;
85 end do;
86
87 fbdend = .fb. fbdend;
88 nswsor = 0;
89 fbsor = 0;
90 do i = 1 to wy;
91 t1 = wordi(i, ay);
92 if (t1) then
93 nswsor = i;
94 fbsor = t1;
95 if (erest t1) then
96 call errmw(13); $ bad user arg two to ldiv
97 end if;
98 end if;
99 end do;
100
101 fbsor = .fb. fbsor;
102 if (nswsor)
103 then nsbsor = fbsor + (nswsor - 1) * (ws-2);
104 else call errmw(14); $ zero divisor to ldiv
105 end if;
106
107 $ test for trivial cases and complete the initialization
108
109 if (nsbsor = 1) $ divisor = one
110 then return;
111 end if;
112 if (nswdend >= nswsor)
113 then nsbdend = fbdend + (nswdend - 1) * (ws-2);
114 else nsbdend = 0;
115 end if;
116
117 if (nsbdend = nsbsor) then $ compare divisor:dividend
118 do i = 1 to nswsor;
119 t2 = wordi(i, ax);
120 t3 = wordi(i, ay);
121 if (t2 > t3) then
122 nsbdend = 1;
123 end if;
124 if (t2 < t3) then
125 nsbdend = 0;
126 end if;
127 end do;
128 end if;
129
130 if (nsbdend <= nsbsor) then $ quotient = zero or one
131 do i = 1 to nswdend;
132 wordi(i, at) = 0;
133 end do;
134 if (nsbdend) then
135 wordi(1,at) = 1;
136 end if;
137 return;
138 end if;
139
140 middend = nswdend - nswsor;
141 if (fbdend > fbsor)
142 then ntshdend = 0;
143 ntshsor = fbdend - fbsor;
144 else ntshsor = 0;
145 ntshdend = fbsor - fbdend;
146 end if;
147 nttl = 1 + nsbdend - nsbsor;
148 yeswedid = 0;
149
150 do i = 1 to ntshdend; $ shift dividend left
151 ldshift(nswdend, at); $ (at most one of these
152 end do; $ two loops is executed)
153 do i = 1 to ntshsor; $ shift divisor left
154 ldshift(nswsor, ay);
155 end do;
156
157 $ initialization is complete - begin division loop
158
159 do i = 1 to nttl;
160 yeswedid = 1; $ see whether to subtract
161 do j = 1 to nswsor; $ and set yeswedid to one
162 t1 = wordi(nswdend + 1 - j, at); $ or zero accordingly
163 t2 = wordi(nswsor + 1 - j, ay);
164 if (t1 < t2) then
165 yeswedid = 0;
166 quit do;
167 end if;
168 if (t1 > t2) then
169 quit do;
170 end if;
171 end do;
172
173 if (yeswedid) then $ subtract divisor from
174 t3 = 0; $ high order end of result
175 do j = 1 to nswsor; $ (use t3 as a borrow bit)
176 t1 = wordi(middend + j, at);
177 t2 = wordi(j, ay) + t3;
178 if (t2 > t1)
179 then t3 = 1;
180 erest t1 = 1;
181 else t3 = 0;
182 end if;
183 wordi(middend + j, at) = t1 - t2;
184 end do; $ end subtract loop
185 end if;
186
187 ldshift(nswdend, at); $ shift left one bit and
188 end do; $ append yeswedid
189
190 $ division has been accomplished in that the quotient resides in
191 $ the nttl low order bits of at (exclusive of sign and carry bits).
192 $ for future reference, we note that the remainder (which we will
193 $ summarily zero out) has nsbsor bits, and that its high order bit
194 $ is the carry bit of word nswdend of at. the remainder proceeds
195 $ from this peculiar origin to the right, skipping all sign (i.e.
196 $ leftmost) bits of its component words, and skipping all other
197 $ carry (i.e. next to leftmost) bits of its component words. thus
198 $ the quotient and remainder portions of the result never overlap,
199 $ but will have ntshdend superfluous zero bits between them. to
200 $ avoid messing up our inputs, we start the termination process by
201 $ executing ntshsor end-off one bit right shifts of the divisor. we
202 $ have made the one bit right shift into a macro (even though we use
203 $ it only once in this procedure) because it will be useful in deali
204 $ with the remainder if little ever gets a mod operator.
205
206 do i = 1 to ntshsor; $ shift divisor right to
207 rdshift(nswsor, ay); $ restore it - this loop
208 end do; $ may not be executed
209 t1 = nttl / (ws-2);
210 t2 = nttl - t1 * (ws-2);
211 if (t2) then
212 t1 = t1 + 1;
213 wordi(t1, at) = .f. 1, t2, (wordi(t1, at));
214 end if;
215 do i = t1 + 1 to nswdend; $ zero out the remainder
216 wordi(i, at) = 0;
217 end do;
218
219 macdrop(ldshift) macdrop(rdshift)
220 end subr divmw;
221 ..defenv_divmw
1 .=member catmw
2 .-defenv_catmw.
3 subr catmw(ax, ay, at); $ x .cc. y
4 access ermwns;
5
6
7 size ax(szmax), ay(szmax), at(szmax); $ arguments.
8 size ncinx(ps), nciny(ps), ncint(ps); $ lengths of arguments.
9 size orgofx(ps), orgofy(ps), orgoft(ps); $ origin values.
10 size i(ps); $ loop index.
11
12 $ initialize some of the quantities defined in the size statement
13 $ and check for well formed inputs x and y. we permit an input
14 $ string to have its leftmost character in the middle of a word.
15 $ the output string will always be left adjusted to a word boundary.
16 $ we assume that the compiler has sized t correctly (see little
17 $ newsletter 27, page 13). this takes great faith.
18
19 call vcsmw(ax, 15); call vcsmw(ay, 16);
20
21 ncinx = slen ax;
22 nciny = slen ay;
23 ncint = ncinx + nciny;
24 orgofx = sorg ax;
25 orgofy = sorg ay;
26
27 $ create a descriptor for t (the result)
28
29 orgoft = .sds. ncint + 1;
30 slen at = ncint;
31 sorg at = orgoft;
32
33 $ move the characters from x to t, then from y to t
34
35 do i = 1 to ncinx;
36 orgofx = orgofx - cs;
37 orgoft = orgoft - cs;
38 .f. orgoft, cs, at = .f. orgofx, cs, ax;
39 end do;
40 do i = 1 to nciny;
41 orgofy = orgofy - cs;
42 orgoft = orgoft - cs;
43 .f. orgoft, cs, at = .f. orgofy, cs, ay;
44 end do;
45
46 end subr catmw;
47 ..defenv_catmw
48
1 .=member cinmw
2 .-defenv_cinmw.
3 fnct cinmw(ax, ay); $ x .in. y
4
5
6 size ax(szmax), ay(szmax); $ arguments.
7 size ncinx(ps), nciny(ps); $ lengths of arguments.
8 size orgofx(ps), orgofy(ps); $ origin values.
9 size i(ps); $ loop index.
10 size howfar(ps); $ max. character number for success.
11 size j(ps); $ loop index.
12 size cinmw(ps); $ function value.
13 size frstchar(cs); $ first character of x.
14
15 $ initialize some of the quantities defined in the size statement
16 $ and check for well formed inputs x and y. we permit an input
17 $ string to have its leftmost character in the middle of a word.
18
19 call vcsmw(ax, 17); call vcsmw(ay, 18);
20 ncinx = slen ax;
21 nciny = slen ay;
22 orgofx = sorg ax;
23 orgofy = sorg ay;
24
25 $ initialize and check trivial case
26
27 cinmw = 0;
28 if (ncinx > nciny) then
29 return;
30 end if;
31
32 if ( (ncinx*nciny) = 0) return; $ quit if either null.
33 orgofx = orgofx - cs;
34 frstchar = .f. orgofx, cs, ax;
35 ncinx = ncinx - 1;
36 howfar = nciny - ncinx;
37
38 do i = 1 to howfar;
39 orgofy = orgofy - cs;
40 if (frstchar = .f. orgofy, cs, ay) then
41 do j = 1 to ncinx;
42 if (.f. orgofx-j*cs, cs, ax ^= .f. orgofy-j*cs, cs, ay)
43 cont do i;
44 end do;
45 cinmw = i;
46 return;
47 end if;
48 end do;
49
50 end fnct cinmw;
51 ..defenv_cinmw
1 .=member cexmw
2 .-defenv_cexmw.
3 subr cexmw(axarg, ayarg, az, at); $ t = .s. x, y, z
4 access ermwns;
5
6 size axarg(ps), ax(ps); $ starting position, and working copy.
7 size ayarg(ps), ay(ps); $ length, and working copy.
8 size az(szmax), at(szmax); $ source and target.
9 size ncinz(ps); $ length of z.
10 size orgofz(ps); $ origin of z.
11 size orgoft(ps); $ origin of t.
12 size i(ps); $ index.
13 .+mwcc. $ check for compiler error
14 if (wt <= 0)
15 then call errmw(-16); $ bad argument to cexmw
16 end if;
17 ..mwcc
18 $ initialize some of the quantities defined in the size statement
19 $ and check for well formed input z. we permit the first character
20 $ of z to be in the middle of a word, but the output string t will
21 $ always be left aligned on a word boundary. we also check to be
22 $ certain that t is big enough to hold the output string.
23
24 ncinz = slen az;
25 orgofz = sorg az;
26 ax = axarg; ay = ayarg;
27 call vcsmw(az, 22);
28 if ax <= 0 then
29 xopern=ax; call errmw(19); $ bad user arg 1 to cexmw
30 end if;
31 if ay < 0 then
32 xopern=ay; call errmw(20); $ bad user arg 2 to cexmw
33 end if;
34 if ax+ay-1 > ncinz then
35 xopern = ax+ay-1; call errmw(21); $ bad position
36 end if;
37 orgoft = .sds. ay + 1;
38 sorg at = orgoft;
39 slen at = ay;
40
41 $ move the characters from z to t
42
43 orgofz = orgofz - (ax - 1) * cs;
44 do i = 1 to ay;
45 orgofz = orgofz - cs;
46 orgoft = orgoft - cs;
47 .f. orgoft, cs, at = .f. orgofz, cs, az;
48 end do;
49
50 end subr cexmw;
51 ..defenv_cexmw
1 .=member casmw
2 .-defenv_casmw.
3 subr casmw(axarg, ayarg, az, at); $ .s. x, y, t = z
4 access ermwns;
5
6 size axarg(ps), ax(ps); $ starting position, and working copy.
7 size ayarg(ps), ay(ps); $ length, and working copy.
8 size az(szmax), at(szmax); $ source and target.
9 size ncint(ps); $ length of t.
10 size ncinz(ps); $ length of z.
11 size orgofz(ps); $ origin of z.
12 size orgoft(ps); $ origin of t.
13 size i(ps); $ index.
14
15 ax = axarg; ay = ayarg;
16
17 $ initialize some of the quantities defined in the size statement
18 $ and check for well formed strings z and t. we permit a string to
19 $ have its first (leftmost) character in the middle of a word.
20
21 call vcsmw(az, 25);
22 call vcsmw(at, 26);
23 ncinz = slen az;
24 ncint = slen at;
25 orgofz = sorg az;
26 orgoft = sorg at;
27
28 $ check user arguments x and y for consistency with target string t
29
30 if ax <= 0 then
31 xopern=ax; call errmw(23); $ bad user arg 1 to casmw
32 end if;
33 if ay < 0 then
34 xopern=ay; call errmw(24); $ bad user arg 2 to casmw
35 end if;
36 if ax+ay-1 > ncint then
37 xopern = ax+ay-1; call errmw(27); $ bad position
38 end if; $ of arguments to casmw
39
40 $ move characters one through y of string z into characters x
41 $ through x + y - 1 of string t. if string z is shorter than
42 $ y characters, move blanks as needed into t.
43
44 orgoft = orgoft - (ax - 1) * cs;
45 do i = 1 to ay;
46 orgoft = orgoft - cs;
47 if (i <= ncinz)
48 then orgofz = orgofz - cs;
49 .f. orgoft, cs, at = .f. orgofz, cs, az;
50 else .f. orgoft, cs, at = 1r ;
51 end if;
52 end do;
53
54 end subr casmw;
55 ..defenv_casmw
1 .=member ceqmw
2 .-defenv_ceqmw.
3 fnct ceqmw(ax, ay); $ test strings for equality
4 size ax(ws+1), ay(ws+1); $ strings to compare
5 size ceqmw(1); $ result.
6 size px(ps), py(ps), lx(ps), ly(ps), seqmw(1);
7 size i(ps);
8 ceqmw = 0; $ assume unequal
9 call vcsmw(ax, 31); call vcsmw(ay, 31);
10 lx = slen ax; ly = slen ay; $ get lengths
11 if(lx ^= ly) return; $ quit if lengths differ
12 px = sorg ax; py = sorg ay; $ and origins
13 do i = 1 to lx; $ compare characters in turn
14 px = px-cs; py = py-cs; $ advance to next char
15 if( .f. px,cs,ax ^= .f. py, cs, ay) return;
16 end do;
17 ceqmw = 1; $ they agree
18 end fnct ceqmw;
19 ..defenv_ceqmw
20 .-defenv_vcsmw.
1 .=member vcsmw
2 subr vcsmw(ax, ernum); $ verify character string structure.
3 access ermwns;
4 $ verify that argument has form of character string.
dsu 21 size ax(ws+1); $ character string.
6 size ernum(ps); $ error number.
7 size ncinx(ps); $ length.
8 size orgofx(ps); $ origin.
9 size remofx(ps); $ remaining characters.
10
11 ncinx = slen ax;
12 if (ncinx=0) return; $ null string always ok.
13 orgofx = sorg ax;
14 remofx = orgofx - (ncinx * cs + ldcs + 1);
15 if orgofx < ldcs ! remofx < 0
16 ! (((remofx/cs) * cs) ^= remofx) then
17 call ersmw(ax); call errmw(ernum);
18 end if;
19 end subr vcsmw;
20 ..defenv_vcsmw
1 .=member endmul
1 .=member ltlterm
3 +* phasemax = 3 ** $ number phases.
4
dsb 70 .+s66.
6
7 subr ltlterm; $ terminate compiler overlay phase.
8 nameset lexcard; $ lex reports line total here.
9 size lines(ps); $ total input lines.
10 end nameset;
11 size phase(ps); data phase=0; $ compilation phase.
12 real timetot, phasetime; dims phasetime(phasemax+1);
13 size etime(ws); $ elapsed time in milliseconds.
14 size lcs(ps); $ nonzero to list compilation statistics.
15 size i(ps); $ loop index.
16
17 phase = phase + 1;
18 call letime(etime);
19 phasetime(phase) = float(etime) / 1000.0;
20 if (phase<=phasemax) go to ret;
21 call getipp(lcs, 'lcs=1/0');
22 if (lcs=0) go to ret;
23 $ convert times to elapsed times in phases.
24 timetot = phasetime(phasemax+1) - phasetime(1);
25 do i = phasemax+1 to 2 by -1;
26 phasetime(i) = phasetime(i) - phasetime(i-1);
27 end do;
28 if (timetot<=0.0) go to ret; $ if timer failure.
29
dsb 71 $ use lcp to avoid loading most of io.
45 endl endl textl('compilation statistics: ')
46 intlp(lines,7) textl(' lines in ')
47 intlp(ifix(timetot*1000.0),9)
48 textl(' milliseconds at rate of ')
49 intlp( ifix( 60.0 * float(lines) / timetot) , 7)
50 textl(' lines per minute.')
51 endl textl('phase times:')
52 do i = 1 to phasemax;
53 intlp(ifix( 1000.0*phasetime(i+1) ),7)
54 end do;
55 endl textl('end of compilation.') endl
57 /ret/
58 call ltlovl; $ invoke overlay executive.
59 end subr ltlterm;
dsba 1 ..s66
60 .+s37.
61 subr ltlterm(phase, rc); $ terminate a compiler phase.
62 size phase(ps); $ phase just completed.
63 size rc(ps); $ return code from that phase.
64
65 call ltlfin(0, phase*4b'1000000'+rc); $ success with 'funny' rc.
66
67 end subr ltlterm;
68 ..s37
utsa 143 .+s47.
utsa 144 subr ltlterm(phase, rc); $ terminate a compiler phase.
utsa 145 size phase(ps); $ phase just completed.
utsa 146 size rc(ps); $ return code from that phase.
utsa 147
utsa 148 call ltlfin(0, phase*4b'1000000'+rc); $ success with 'funny' rc.
utsa 149
utsa 150 end subr ltlterm;
utsa 151 ..s47
dsb 73 .+s10.
dsb 74 subr ltlterm(phase, rc); $ end compiler phase.
dsb 75 size phase(ps); $ phase terminated.
dsb 76 size rc(ps); $ return code.
dsb 77
dsb 78 call ltlfin(0, rc); $ end phase.
dsb 79
dsb 80 end subr ltlterm;
dsb 81 ..s10
vax 67 .+s32.
vax 68 subr ltlterm(phase, rc); $ end compiler phase.
vax 69 size phase(ps); $ phase terminated.
vax 70 size rc(ps); $ return code.
vax 71
vax 72 call ltlfin(0, rc); $ end phase.
vax 73
vax 74 end subr ltlterm;
vax 75 ..s32
1 .=member sier11
2 .+s11.
3
4 subr ltlsierr(n, fn); $ error printing routine for -sio-.
5 $ this routine prints the error messages generated by the little
6 $ io interface.
7 size n(ps); $ error message number.
8 size fn(ps); $ current file number at time of err
9 size i(ps); $ temporary.
10
11
12 $ if this is a recursive error, just terminate the program.
13 if sioerflg then $ this is a recursive call.
14 call ltlfin(1, 4001); $ abnormally end this program.
15 end if;
16
17 sioerflg = yes; $ indicate that program is being terminated.
18 $ call ltlxtrs; $ set trace back chain.
19 endl textl('error ') intl(n) textl(' file') intl(fn) textl('
20 if n=32 ^ n>8 ^ n<1 then $ bad error.
21 textl('invalid error number #')
22 go to ret; $ go to common end processing.
23 else $ error is ok.
24 go to e(n) in 1 to 8;
25 end if;
26
27 +* er(n, msg) = /e(n)/ textl(msg) go to ret; **
28
29 er(1, 'file already connected')
30 er(2, 'unformatted request to formatted file')
31 er(3, 'formatted request to unformatted file')
32 er(4, 'wrong access type')
33 er(5, 'file already opened')
34 er(6, 'out of buffers')
35 er(7, 'unsupported function')
36 er(8, 'illegal filename')
37
38 /ret/ $ common return processing.
39 textl('.') endl endl endl
40 sioerflg = no; $ show processing done.
41 call ltlfin(1, 2100+n); $ call termination routine.
42 end subr ltlsierr;
43 ..s11