Forgot your password?
Document Actions
LEX: Lexical scan phase.
LEX: Lexical scan phase.
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$
31$
32$
33$
34 $ this software is part of the little programming system.
35 $ address queries and comments to
36 $
37 $ little project
38 $ department of computer science
39 $ new york university
40 $ courant institute of mathematical sciences
41 $ 251 mercer street
42 $ new york, ny 10012
43 $
44 $ this is the first phase of the little compiler. it performs
45 $ the lexical scan, and is known as 'lex'.
46 $
47 $ the principal authors of the little compiler are
48 $ robert abes, edith deak, richard kenner, david shields
49 $ and aaron stein.
50 $
51 $
52 $ the following is a list of the routines in the scanner -
53
54
55 $
56 $ name description
57 $ --------------------------------------------------------------- c
58 $ start contains size statements for global variables
59 $ lexini initialisation routine
60 $ setlit define literal strings.
61 $ inslit insert literals in hash table.
62 $ lexdo driver for scanner
63 $ nextw top scanner routine, emits tokens to parser
64 $ dfabsrb absorbs macro definitions
65 $ mcexpnd expands macros
66 $ trulex builds tokens from input characters
67 $ charinr adds character to token
68 $ givecr gets next card from input stream
69 $ hash adds token to symbol table (ha)
70 $ fivdec converts integer to 5 right adjusted characters
71 $ ibigr compare symbols for cross-ref.
72 $ detect detects suspicious variables
73 $ pflshr control routine for puncher
74 $ pncr punches out token
75 $ ermsg lists error messages
76 $ ertlist list recent tokens if error detected
77 $ toklr list characters in token.
78 $ ltoflo report table overflow.
79 $ lexexit exit routine for scanner
80
81
82 $ m a c r o g l o s s a r y .
83 $
84 $ alphabetic (c) = 1 if c is alphabetic character, else 0
85 $ astkget (l) = astk(l) (astk is packed array)
86 $ astklim = length of macro argumet stack astk
87 $ astkput (v) = add v as new top of astk (astk is packed)
88 $ astkset (l,c) = astk(l)=v; (astk is packed array)
89 $ bintok = code for binary token, e.g., '100b'
90 $ buildz (h,n,t) = build token with index n. t is type. h ha-index
91 $ cab = ha-field for conditional assembly bit
92 $ charin (c) = add c to current token (cf. trulex)
93 $ charl (c) = print character c
94 $ countup (i,l,m) = add 1 to i; quit if exceeds l. m is message
95 $ cpstr - characters in short token record
96 $ cpw = characters per word
97 $ cs = character size in bits
98 $ dectok = code for integer token, e.g., '100'
99 $ endl = end current print line, start new one
100 $ ertoksave (h) = add ha-index h to lisf t orecent tokens seen
101 $ geter (a,l) = return a(l) (a is packed array)
102 $ getfromkeep(char) = get character from buffer
103 $ getrefsym (s,w) = get sds string for token, w is cross ref wd.
104 $ getsym (s,h) = get sds string for token with ha-index h
105 $ givec (c) = get next character from input, put in c
106 $ givecstr (c) = get next character, when inside string
107 $ hamax = dims of hash table, or ha. (must be prime)
108 $ hashin (i) = add token to ha, set i to ha-index
109 $ hashtokorg = origin for sds input string hashtok used in hash
110 $ hasz = size of ha-entry in bits
111 $ icdsig = card marking card image record on token file
112 $ intl (i) = print integer i in five columns
114 $ intlp(n,c) = output integer in c columns
115 $ iscachar (c) = 1 if c is one of '. + -' (conditional asm.)
116 $ isublim = max. no. of routines for cross-reference
117 $ isymc (h,i) = i-th character of token with ha-index h
118 $ keepc(char) = character backup macro, limit is keeplimit
119 $ lettercode (c) = ordinal of c if alphabetic, else 0. a=1,b=2,etc.
120 $ leldefault = default lexical error limit.
121 $ lexlen = ha-field giving token length in characters
122 $ lextyp = ha-field giving lexical type
123 $ namesmax = dims of 'names' array; max. no. of words for name str
124 $ listarglim = dims of listarg in nextw, same as max. macro args
125 $ macdef (t) = auxiliary for defining macros in macros
126 $ macdrop (m) = drop macro with ha-index m
127 $ macorg = ha-field giving mtab index of macro def. (0 if not macr
128 $ macstate - ha field, 'is name currently a macro'
129 $ mactlim = max. no. of entries for macro def table mtab
130 $ maxtoklen = max. length of token in characters
131 $ maxlinesz = number of characters in output line
132 $ mccd = last column of input card that scanner processes
133 $ mflshr (h) = punch out token with ha-index h
134 $ mstklim = max. no entries in mstk for macro expansion
135 $ mtset (l,w) = set l-th entry of mtab to w (mtab is packed)
136 $ mtabsize = size in bits of macro def table entry
137 $ mtlim - max. no. of entries in macro definition table
138 $ nameptr = ha-field giving index in 'names' of name of token
139 $ nametok = code for name-type token, e.g., 'little'
140 $ namptrb = length of nameptr field
141 $ nchars = no. of characters in system character set
142 $ no = 1 (used for readability)
143 $ numbugtoks = no. of lexical debugging tokens (cf. trulex)
144 $ nuses = ha-field giving number of times token used
145 $ octaltok = code for octal-type token, e.g. '100b'
146 $ octl (w) = print word in octal form
147 $ optok = code for period delimiter operator token, eg., '.and.'
148 $ ps = pointer size in bits (maximum subscript value)
149 $ ms = size of macro definition item
150 $ q3 (a,b,c) = auxiliary for defining macros inside macros
151 $ readbio (t,a,n) = binary read n words into array a from tape t
152 $ readio (t,a,n) = coded read n words into array a from tape t
153 $ reslim = max. no of tokens in nextw backup buffer
154 $ rztok = code for right alinng, zero-fill token, e.g., 4rabcd.
155 $ sds (n) = size need for sds string of n characters
156 $ sdspack (a,n) = add n characters as start of current token
157 $ sdstl = size in bits needed to hold 20 chars of token in sds foo
158 $ sdstok = code for self-defining-string token, e.g. ' 'string' '.
159 $ seter (a,v,w) = set a(w) = v (a is packed array)
160 $ skipl (n) = skip forward n spaces on print line
161 $ slen = length (in characters) field of self-defining-string
162 $ sorg = origin field for self-defining-string
163 $ spectok = code for special-type token, e.g., '('
164 $ stringtok = generic code for string type token
165 $ suspi = level of usage below which variable becomes suspicious
166 $ tabl (n) = tab print file to column n
167 $ textl (s) = print string s
168 $ tintl (s,i) = print label s, then integer i
169 $ tokch (p,c) = set p-th char of hash input to char. c
170 $ tokl (h) = print token with ha-index h
171 $ tokout (hdr, ara, lo) add hdr, ara(1)...ara(lo) to token file
172 $ tokout1 (w) = add word w to token fiel buffer
173 $ tokpack (pak,unp,n) = pac n chars of ara unp into array pak
174 $ tokrbuflim = no. of entries in token buffer tokrbuf
175 $ tokrcard = code for card-image record in token file
176 $ tokreof = code for end-file record on token flei
177 $ tokrtyp = field in token record giving lexical type
178 $ tokrval = field in token record giving first few chars of token
179 $ torklen = field in token record giving token length in chars.
180 $ ws = word size in bits
181 $ yes = 1 (used for readability)
182 $
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 changes are to insert self-description at -- mods.2 --
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
ldsa 1
ldsa 2 $ ldsa d. shields 20-nov-81 level 81324
ldsa 3 $
ldsa 4 $ increase ha dimension yet again. for s32 unix, it is great help
ldsa 5 $ to be able to compile stlcod by appending text needed from stllib.
ldsa 6 $ this required change in cross-reference fields, so ref needs
ldsa 7 $ updating also.
ldsa 8 $ deck affected - macros
ldsa 9
hab 1
hab 2 $ hab d. shields 01-oct-81 level 81274
hab 3 $
hab 4 $ increase ha dimension so can do full compilation of setl lib v21.
hab 5 $ new value (3929) cannot be increased without redoing table
hab 6 $ layouts due to field sizes of 12 bits.
hab 7 $ deck affected - macros
hab 8
dsz 1
dsz 2 $ dsz d. shields 21-sep-81 level 81264
dsz 3 $
dsz 4 $ 1. make default for suspicious variables list 'susp=0/0' so
dsz 5 $ this list generated only if 'susp=1' specified.
dsz 6 $ 2. do not include 'name with prior usage being designated as
dsz 7 $ macro' warnings in warning count.
dsz 8 $ 3. add error message text for a case where '**' missing.
dsz 9 $ decks affected - lexini, ermsg
dsz 10
dsy 1
dsy 2 $ dsy d. shields 17-jun-81 level 81168
dsy 3 $
dsy 4 $ 1. extend iset option to allow several names separated by
dsy 5 $ plus signs.
dsy 6 $ 2. fix error (fr157) in that illformed conditional assembly
dsy 7 $ names were not detected.
dsy 8 $ decks affected - lexini, lexca, cainit (new)
dsy 9
nama 1
nama 2 $ nama d. shields 28-apr-81 level 81118
nama 3 $
nama 4 $ increase dimension of names array for s10, s32 and s37 to permit
nama 5 $ full compilation of setl lib, v2.20.
nama 6
dsx 1
dsx 2 $ dsx d. shields 12-nov-80 level 80317
dsx 3 $
dsx 4 $ for unix, initially define (set) symbol 'unix'. this avoids having
dsx 5 $ to specify 'iset=unix' for compilations in unix environment.
dsx 6 $ deck affected - lexini.
dsx 7
dsw 1
dsw 2 $ dsw d. shields 21-jul-80 level 80203
dsw 3 $
dsw 4 $ correct problems in case folding.
dsw 5 $ enable trace options for unix checkout.
dsw 6 $ decks affected - macros, trulex, lexdir.
dsw 7
dsv 1
dsv 2 $ dsv d. shields 10-jul-80 level 80192
dsv 3 $
dsv 4 $ 1. fix problem (fr135) in setting of termination code.
dsv 5 $ now issue code 0 if no warnings or errors, code 4 if warnings
dsv 6 $ and no errors, code 8 if any errors detected.
dsv 7 $ 2. add possibility of running with lower-case as primary case
dsv 8 $ used within the compiler. this obtained by setting -mcl-.
dsv 9 $ 3. do not generate 'no errors detected' message.
dsv 10 $ 4. add conditional symbol -unix- for the unix operating system.
dsv 11 $ use iset=unix to obtain unix variant.
dsv 12 $ want listing terse, make lcp=0 and lcs=0 the defaults.
dsv 13 $ for initial checkout, delete special env code (bskp, etc.).
dsv 14 $
dsv 15 $ decks affected - macros, lexini, trulex, lexexit.
dsv 16
dsu 1
dsu 2 $ dsu d. shields 10-jan-80 level 80010
dsu 3 $
dsu 4 $ 1. extend dimension of names and macro arrays to permit
dsu 5 $ full compilation of setl lib phase.
dsu 6 $ this requires changing ha field definitions.
dsu 7 $ 2. redefine format of cross-reference file to permit input
dsu 8 $ file to have more than 32767 lines.
dsu 9 $ decks affected - macros, start.
dsu 10
dst 1
dst 2 $ dst d. shields 03-jan-80 level 80003
dst 3 $
dst 4 $ 1. increase dimension of ha and macro table.
dst 5 $ 2. fix bug in list resume option
dst 6 $ decks affected - macros, start.
dst 7
dss 1
dss 2 $ dss d. shields 04-dec-79 level 79338
dss 3 $
dss 4 $ if lower case supported, convert first character of
dss 5 $ source line to upper case as appropriate (fr2.3.128).
dss 6 $ deck affected - macros
dss 7
dsr 1
dsr 2 $ dsr d. shields 19-nov-79 level 79323
dsr 3 $
dsr 4 $ 1. rewind token file for s66 only.
dsr 5 $ 2. use getapp (new lib procedure provided by mod dsc) to
dsr 6 $ obtain and list actual parameter string specified by user.
dsr 7 $ 3. delete code to read term= parameter and possibly open
dsr 8 $ terminal file, as this now done by lib (mod dsc).
dsr 9 $ decks affected - macros, lexini.
dsr 10
dsq 1
dsq 2 $ dsq d. shields 02-aug-79 level 79214
dsq 3 $
dsq 4 $ 1. convert to use string search primitives (provided by lib
dsq 5 $ level 79200) to support mixed-case source. case significant
dsq 6 $ only within character string constants.
dsq 7 $ 2. modify code to list line to provide tab character if
dsq 8 $ available so as to maintain alignment of source using tabs.
dsq 9 $ 3. add program parameter 'upd=0/1' such that upd=1 indicates
dsq 10 $ that lines in input file have upd sequence information in the
dsq 11 $ first eight columns.
dsq 12 $ 4. for s10, issue standard characters at start of error
dsq 13 $ and warning messages sent to terminal.
dsq 14 $ decks affected - macros, start, and principally trulex.
dsq 15
mgfa 1
mgfa 2 $ mgfa m.g. ford 05-jul-79 level 79186
mgfa 3 $
mgfa 4 $ this mod performs some s10-only changes, to improve dec-10
mgfa 5 $ compatibility slightly. it requires associated mods in all
mgfa 6 $ other programs which are part of the little suite.
mgfa 7 $ 1. revamp default filenames.
mgfa 8 $ 2. have terminal open by default ('term=tty:/').
mgfa 9 $ 3. change from sixbit to 9-bit ascii (cs=9).
mgfa 10 $ decks affected - macros,lexini.
mgfa 11
dsp 1 $ dsp (79052) - adjust dimension of names for s10.
dso 1
dso 2 $ dso d. shields 21 dec 78 level 78355
dso 3 $
dso 4 $ 1. fix error (fr.23.71) in that not all calls to -ermsg-
dso 5 $ specified three arguments.
dso 6 $ 2. delete trace code for s10, as bootstrap complete.
dso 7 $ decks affected - macros, those referencing -ermsg-.
dso 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, start, lexini.
vax 7
dsn 1
dsn 2 $ dsn d. shields 25 sep 78 level 78268
dsn 3 $
dsn 4 $ 1. increase macro table length for setl use.
dsn 5 $ 2. add code for resident s10 compiler.
dsn 6 $ decks affected - macros, start, lexini.
dsn 7
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 $ rbkh r. kenner 01 mar 78 level 78060
13 $ d. shields
14 $
15 $ 1. increase dimension of names for s37.
16 $ 2. correct size error in lexdir.
17 $ 3. avoid sending line twice just after .=list input
18 $ decks affected - macros, lexdir, givecr.
19
20
21 $ rbkg r. kenner 04 jan 78 level 78004
22 $
23 $ 1. correct some errors in s37 conditional code.
24 $ 2. permit use of s-type tokens, which are delimited with
25 $ code s, as in '3sabc'. s-tokens are machine-dependent, and
26 $ are for use on machines such as s10 and s11 with a 'system-
27 $ format' string.
28 $ 3. change 'subr start' to 'prog start' for s37 since no
29 $ overlaying of phases occurs.
30 $ 4. fix code mostly in -lexca- which handles work-to-do on a
31 $ card since the gen 'fix' on taking .not. of a constant makes
32 $ it incorrect as written. (the problem is that ^(^1b'100') is
33 $ ^(1b'11') which yields 1b'0', not the 1b'100' that
34 $ might be expected.)
35 $ 5. slightly clean up exit code in -lexexit- when no token file
36 $ is specified.
37 $ 6. correct bug in processing of -zzy- tokens in open text.
38 $ decks affected - macros, start, lexini, lexdo, trulex, givecr,
39 $ lexca, lexdir, pflshr, lexexit
40
41
42 $ dsm d. shields 08 dec 77 level 77342
43 $
44 $ correct error in real constants with negative exponent.
45 $ deck affected - trulex.
46
47
48 $ rbkf r. kenner 27 oct 77 77300
49 $
50 $ this mod improves the handling of programs with a lot of
51 $ comment lines by not sending lines to gen unless the gen
52 $ list option is on or the lines contain tokens. in order
53 $ for gen to keep the line numbers correct, the number of
54 $ cards that a particular card represents is sent in the
55 $ -toklc- field of the token for the card.
56 $ this mod requires mod rbkk in gen.
57 $ decks affected - start, lexdo, givecr, hash, lexexit
58
59
60 $ rbkee r. kenner 07 oct 77 77280
61 $
62 $ this mod corrects some errors in mod rbke. the most important
63 $ error was one in the routine -hash-.
64 $ decks affected - macros, start, setlit, nextw, trulex, hash,
65 $ pflshr, ermsg
66
67
68 $ rbke r. kenner 07 sep 77 77250
69 $
70 $ this is mostly an internal cleanup mod. the following are the
71 $ major areas of change.
72 $ 1. conditional code is added for s10 (dec system/10).
73 $ 2. lexical punch code has been rewritten to bring it more
74 $ up to date, clean it up, and clean up the format of
75 $ the punched output.
76 $ 3. -nextw-, -defabsrb-, and -mcexpand- are now only called
77 $ when they are actually needed. in most cases, most
78 $ of the work is now done in -lexdo-.
79 $ 4. error messages are now more informative and, in most
80 $ cases, errors do not pass 'junk' to gen.
81 $ 5. -astk- overflow is now not fatal but aborts macro
82 $ expansion.
83 $ 6. table definitions for s37 have been changed.
84 $ 7. the dimension of the -ha- is now larger than the
85 $ prime used to allow the first few clashes to be
86 $ put in a separate area. also, some tests have been
87 $ reordered.
88 $ decks affected - all (source has been resequenced)
89
90
91 $ dsl d. shields 26 jul 77 level 77206.
92 $
93 $ add program parameter 'termlex=0/1' to permit termination of
94 $ compilation at end of lexical scan.
95 $ decks affected - start, lexini, lexexit.
96
97
98 $ dsk d. shields 20 may 77 level 77140.
99 $
100 $ reported bug - macro '+* stk(a,b) = ; **' expands incorrectly.
101 $ cause - special case code for one symbol macros did not check
102 $ to see if macro had arguments.
103 $ moral - special cases need special care.
104 $ deck affected - defabs.
105
106
107 $ dsjj d. shields 05 may 77 level 77125.
108 $
109 $ reported bug - warning message for macro redefinition given twice.
110 $ fix - remove duplicated code (introduced by mod dsj).
111 $ deck affected - defabs.
112
113
114 $ dsj d. shields 08 april 1977 level 77098.
115 $
116 $ 1. improve diagnostic message if mstk overflow.
117 $ 2. accept '.=member' directives in primary input file.
118 $ 3. detect 'immediate', or one symbol macros, and use the macorg
119 $ field to expand the macro, thus saving space in mtab.
120 $ add the ha field 'macimm' which is on if macro is immediate.
121 $ (suggested by art grand.)
122 $ 4. increase dimension of mtab.
123 $ decks affected - nextw, defabs, lexdir.
124
125
126 $ dsi d. shields 03 february 1977 level 77034.
127 $
128 $ 1. redefine origin of zzy and zzz symbols to be zero so first
129 $ generated symbol or integer has index one.
130 $ 2. use different counters for zzy and zzz symbols.
131 $ 3. list active zzy counter values at end of scan.
132 $ 4. increase length of macro table to permit compilation of new
133 $ setl library.
134 $ decks affected - macros, start, defabs, buildz, macexp,
135 $ lexdir and lexexit.
136
137
138 $ dsh d. shields 31 january 1977 level 77031.
139 $
140 $ 1. adapt lex for s66 to support both 63 and 64 character sets.
141 $ do this by accepting both 3b'63' and 3b'00' as valid forms of
142 $ the 'colon' character in little. implement by hashing these
143 $ values in absolute form to initialize in imtoktab and setting
144 $ literal codes of both entries to 70, the literal code for
145 $ 'colon'.
146 $ code must be changed if literal code of colon changed.
147 $ this change applies to s66 only - all code conditional.
148 $ 2. repair error in trulex, which was not detecting real constants
149 $ beginning with decimal point.
150 $ 3. abort scan if input file empty.
151 $ decks affected - lexini, trulex, lexexit.
152
153
154 $ dsg d. shields 07 january 1977 level 77007.
155 $
156 $ 1. repair error in -list- directive, as 'list input' was not
157 $ recognized due to size introduced in prior mod.
158 $ 2. define -zzy- counters to be one-origin, not zero origin.
159 $ 3. at request of setl group, install directive to reset
160 $ -zzy- counters. the directive ' .=zzyorg' has as
161 $ parameter a list of characters indicating the counters
162 $ to be reset to one. for example,
163 $ .=zzyorg csr
164 $ resets the counters zzyc, zzys and zzyr.
165 $ 4. change keyword -debug- to -monitor-.
166 $
167 $ remaining changes adapt lex to new language level and library.
168 $ trulex has been rewritten, and some source cleanup done.
169 $
170 $ 5. use -getipp- and -getspp- to obtain program parameters at
171 $ execution time.
172 $ 6. use new sio for io for token, punch and reference files.
173 $ 7. keep macro argument count, which was ha field -macargs-, as
174 $ first entry in macro text table -mtab-.
175 $ 8. revise hash algorithm to use algorithm 'c' of knuth
176 $ (see comments in procedure -insglor- in -gen-).
177 $ 9. pad -names- entries with blanks, not binary zeros.
178 $ 10. recode trulex to support only new language level.
179 $ salient points are as follows:
180 $ 1. drop support of token types -d-, -h-, -z-, -l- and -b-.
181 $ 2. assign -q- tokens lexical type -stringtok-, as q tokens
182 $ are just another way of writing character strings.
183 $ 3. avoid use of finite state automaton to drive scan.
184 $ large number of special actions makes straight code
185 $ clearer and more efficient.
186 $ 4. distinguish two cases of 'get next character' primitive.
187 $ use -givec(c)- to get character via procedure call.
188 $ use -giveq(c)- to get character via inline code.
189 $ 5. implement -givecstr- primitive as procedure cal.
190 $ 6. code for -ieof- end of file option retained, but is
191 $ probably incorrect if enabled.
192 $
193 $ source has been resequenced.
194 $
195 $ decks affected - all.
196
197
198 $ dsf d. shields 20 november 76 level 76325.
199 $
200 $ convert to use new -sio. drop use of following routines:
201 $ opnpun, putpun, clspun, opntok, puttok, clstok.
202 $ decks affected: macros, start, lexini, pncr, lexexit.
203
204
205 $ rbkd r. kenner 1 november 76 level 76306
206 $
207 $ fix bug in macro processor causing stores into the zero word
208 $ of -astk-.
209 $ deck affected - nextw
210
211
212 $ dse d. shields 8 oct 76 level 76282.
213 $
214 $ add literals: read write prog .seq. .sne.
215 $ literal codes 93 94 95 96 97 .
216 $ deck affected - inslit.
217
218
219 $ rbkc r. kenner 29 july 76 level 76211
220 $
221 $ 1. fix bug causing compilation error if -oldtoks- is set.
222 $ 2. fix bug in -lexca-.
223 $ 3. change -slen- macro to use .len.
224
225 $ rbkb r. kenner 21 july 76 level 76203
226 $
227 $ 1. add conditional option 'oldtoks' to allow usage of old-style
228 $ tokens. in this mode, an error message will be given for
229 $ each such token. if 'oldtoks' is not set, usage of old-style
230 $ tokens is not allowed.
231 $ 2. add literal codes for 'limit', 'debug', and 'rewind'.
232 $ 3. improve error message content and format.
233 $ 4. change parameter used to specify an initial inclusion
234 $ member to 'imem' (it was -incl-).
235 $ 5. support 'term' parameter. it specifies a file name to
236 $ receive copy of error messages.
237 $ 6. add -ejectl- and -stitlr- calls to improve formatting of
238 $ output listing.
239 $ 7. extend listing control by rewriting -givecr- and
240 $ adding -lexca- to handle condition processing. -lexca-
241 $ replaces some code previously in -givecr- and is called
242 $ by -givecr-. changes at the user level are:
243 $ 1. the list parameter -sinput- has been changed to
244 $ -linput- and the corresponding letter in the 'list'
245 $ compilation parameter is now 'l' instead of 's'.
246 $ 2. the following parameters have been added to the -list-
247 $ directive:
248 $ autotitle instructs -gen- to use the
249 $ -subr- or -fnct- statement as
250 $ a subtitle and use 'title'
251 $ directives as main title.
252 $ skip instructs -gen- to list lines
253 $ of text skipped by conditional
254 $ processing.
255 $ qualifiers instructs -gen- to list the
256 $ conditional qualifiers.
257 $ directive instructs -lex- and -gen- to
258 $ list the directive on which
259 $ this parameter appears.
260 $ note that 'no' may preceed each of these to negate the
261 $ effect and that each may be indicated in the compiler
262 $ 'list' parameter by its first letter.
263 $ also, 'dir'/'nodir' may appear on 'punch'.
264 $ 3. default is .=list noaut,nolin,noinp,nocod,ref,noski,noqua
265 $
266
267
268 $ dsd d. shields 28 june 76 level 76180.
269 $
270 $ revise listing control.
271 $ lines with ' .=' in columns 1 through 3 are directives.
272 $
273 $ the ' .=title' directive sets the listing title. the
274 $ directive contains a quoted string which is the title text.
275 $ the first title directive defines the main title which appears
276 $ on the top of each page; remaining directives set the subtitle
277 $ and cause a page eject.
278 $
279 $ the ' .=eject' directive begins a new page of listing.
280 $ an optional integer parameter may be supplied, in which case
281 $ a new page is begun only if less than the indicated number of
282 $ lines remain on the current listing page.
283 $
284 $ the ' .=list' and ' .=punch' directives control listing and
285 $ macro 'punch' control, respectively.
286 $ each of these directives may contain a list of parameters,
287 $ separated by commas.
288 $ an option is disabled by putting the letters 'no' in front.
289 $ only the first three characters of the parameter code are
290 $ examined.
291 $
292 $ the parameters for the punch directive are 'define', to
293 $ punch macro definitions and 'expand' to punch expanded text.
294 $
295 $ the parameters for the list directive are as follows:
296 $ code - list generated code.
297 $ input - list source input in parse (gen) phase.
298 $ ref - collect references if cross reference feature on.
299 $ sinput - list source input in scanner (lex) phase.
300 $
301 $ all options are off by default except for 'ref'.
302 $
303 $ a stack is kept of the most recent twenty or so list
304 $ directives. the parameter 'resume' may be used to restore
305 $ list control to that established by the previous list directiv
306 $
307 $ the list directives may be initialized by the control card
308 $ option 'list' which accepts a list of character codes.
309 $
310 $ c enable 'code' option.
311 $ d enable 'define' option for punch.
312 $ e enable 'expand' option for punch.
313 $ i enable 'input' option.
314 $ s enable 'sinput' option.
315 $ 0 ignore list directives in input.
316 $
317 $ if 'list' alone occurs, 'list=i' is implied.
318 $
319 $ include feature for remote text.
320 $
321 $ directives of the form ' .=include name' indicate that
322 $ the line in the text is to be replaced by member 'name' of
323 $ a text library. the compiler option 'ilib' may be used to
324 $ name a member to be included before the input file is read,
325 $ thus permitting inclusion of a standard text prelude.
326 $
327 $ inclusion processing is contained in the new library routines
328 $ 'opninc', 'getinc' and 'clsinc' which are similar to the
329 $ routines 'opninp', 'getinp' and 'clsinp' previously used to
330 $ read the input file.
331 $
332 $ environment symbol '.compdate.' for compilation date.
333 $
334 $ an instance of the symbol .compdate. is replaced by a
335 $ character string of length 30 which gives the date of
336 $ compilation. the format is that returned by the 'lctime'
337 $ library primitive.
338 $
339 $ use of new library listing features.
340 $
341 $ this version of lex uses the extended version of the standard
342 $ print routines which recognizes pages and permits page titles.
343 $
344 $ decks affected = all.
345
346
347 $ rbka r. kenner 24 may 76 level 76147.
348 $ d. shields
349 $
350 $ 1. use ps for ws whenever possible (better on s37).
351 $ 2. allow 'iset' option to set initial conditional name;
352 $ for example, 'iset=tr' corresponds to insertion of card
353 $ ' .+set tr' before start of input.
354 $ 3. generate initial set for symbol 'snn' where nn is target
355 $ machine as determined by 'tm' option.
356
357
358 $ cra d. shields 04 may 76 level 76125
359 $
360 $ cross-reference processing is now done as follows.
361 $ the individual routine reference list is no longer available, as
362 $ global map obtained by compiling routines of interest provides
363 $ essentially the same information.
364
365 $ the lexical phase writes two files. the reference file contains
366 $ a list of ha indexes and line numbers. the ha file defines the
367 $ ha and includes a count of the total number of references, etc.
368 $ the gen phase writes a third file which indicates the subroutine
369 $ boundaries.
370 $
371 $ the reference list is generated by a separate program, 'ref',
372 $ which reads in the files, sorts the ha and reference list,
373 $ eliminates duplicate references and formats the listing.
374 $
375 $ reference file 1 contains a list of references, each defined by
376 $ three fields:
377 $ 1. line number
378 $ 2. ha index of symbol.
379 $ 3. flag set if name currently is macro.
380 $ the list is terminated with a zero entry.
381 $
382 $ structure of reference file 2 is as follows:
383 $ each entry is word-size.
384 $ 1. total number of references.
385 $ 2. last line number.
386 $ 3. ha dimension.
387 $ 4. number of words required to store names in ha.
388 $ there follow a variable number of entires defining the ha,
389 $ as follows:
390 $ 1. ha index.
391 $ 2. length of name.
392 $ 3. name, packed cpw characters per entry, and
393 $ right adjusted.
394 $
395 $ every ha entry referred to in the reference list must be
396 $ specified.
397 $ the list is terminated by an entry of 0.
398 $
399 $ the files are written using -sio- with fixed-length records. the
400 $ record length is a parameter, -crbuffmax-, whose value must agree
401 $ with that used in -gen- and -ref-.
402 $
403 $ the files are identified internally by number. the parameter
404 $ 'rf' gives a file name skeleton from which the name is generated
405 $ by replacing the last numeric character by the appropriate numeric
406 $ character. the library routine -crfnam- performs this task.
407
408 $ the suspicious variables function is now realized by internal
409 $ sort of ha.
410 $ routines affected - macros, start, hash, detect, lexexit.
411 $ routines deleted - maklinz, mastlis, purger, sorter, mem.
412 $ the source has been resequenced.
413
414
415 $ dsc d. shields 19 april 1976 level 76110
416 $
417 $ support revised form of bit string constants. this form consists
418 $ of a 'width' specifier of 1,2,3 or 4 followed by 'b' and then
419 $ immediately followed by a quoted string containing blanks and bit
420 $ values. the width indicates the number of bits defined by each
421 $ nonblank character. the characters 'a', 'b', 'c', 'd', 'e' and
422 $ 'f' are used for width 4 in the usual hexadecimal sense.
423 $ for example, the integer 13 is equivalent to each of the following
424 $ bit constants: 1b'1101' 2b'31' 3b'15' 4b'd' .
425 $ the 'b' and 'l' format bit constants will soon be dropped.
426 $ decks affected - macros, lexini, trulex, lexexit, ermsg.
427
428
429 $ dsb d. shields 14 april 76 level 76105
430 $
431 $ 1. use .ws., .ps., etc. for machine parameters.
432 $ 2. be more consistent in use of tokch.
433 $ 3. correct errors in generation of 'zzz' type tokens.
434 $ 4. replace 'goby' statements with indexed 'go to'.
435 $ decks affected - macros, lexini.
436
437
438 $ dsa d. shields 25 march 1976 76085
439 $
440 $ continue work on system/370 version, as follows.
441 $ 1. eliminate uses of eqsds, .s. and .e.
442 $ 2. use lctime to obtain time and date.
443 $ 3. change name countupr to ltoflo.
444 $ 4. initialize some previously unitialized variables.
445 $ 5. change fivdec to return array of chars, not string.
446 $
447$ the source has been resequenced.
448
449
450 $ ldsy d. shields 20 january 1976 level 76020
451 $
452 $ 1. allow up to 31 arguments in macros.
453 $ (this has required change in litcod field position.)
454 $ 2. eliminate 'no list dollar' option.
455 $ 3. add options 'lcp' and 'lcs' to allow selection of
456 $ listing of parameters and statistics.
457 $ 'lcp=0' suppresses parameter listing.
458 $ 'lcs=0' supresses statistics listing.
459 $ 4. add option 'lel' to permit selection of maximum allowed
460 $ number of errors.
461 $ 5. change format of parameter listing.
462 $ decks affected - start, lexini, givec, lexexit, ermsg.
463
464
465 $ ldsx d. shields 01 january 1976 level 76001
466 $
467 $ change literal codes to correspond to level 76001 of gen.
468 $ fix error in purger, so duplicate entries eliminated.
469 $ decks affected - setlit, purger
470
471
472 $ ldsw d. shields 06 november 1975 level 75310
473 $
474 $ 1. if a name used as a macro within a routine, insert '+*' on
475 $ first line of reference list for each routine.
476 $ 2. do not collect references to 'subr' or 'fnct'.
477 $ decks affected - macros, hash, maklinz
478
479
480 $ ldsv d. shields 27 october 1975
481 $
482 $ eliminate literal codes for io keywords no longer used:
483 $ 17'readb' 18'read' 19'writb 20'write 22'endfile'
484 $ and define new literal codes as follows:
485 $ 17'elseif' 18'in' 19'.sds. 20'.voapart.'
486 $ (code 22 thus not used now).
487 $ the level is now 75300.
488 $ deck affected - setlit
489
490
491 $ ldsu d. shields 15 september 1975
492 $
493 $ reported bug - not all subroutine boundaries seen by cross-ref opt
494 $ fix - fine tune the automaton in hash to detect case when routine
495 $ ends in 'end' followed by literals followed by 'end subr/fnct'.
496 $ deck affected - hash
497 $ the level is now 75258.
498
499
500 $ ldst d. shields 7 july 75
501 $
502 $ the line numbers in the 'complete' cross-reference map
503 $ (xra=1) are now given relative to the start of the routine.
504 $ the level is now 75188.
505 $ decks affected - purger, mastlis, maklinz
506
507
508 $ ldss d. shields 2 july 75
509 $
510 $ reported bug - routine boundaries not seen during cross-
511 $ reference listing generation.
512 $ fix - -hash- was not passing tokens 'subr' 'fnct' and 'end'
513 $ to cross reference code.
514 $
515 $ the 'tally' option is now expressed as separate options
516 $ 'tallytokens', 'tallycomments' and (new) 'tallyhash', which
517 $ measures symbol table access.
518 $ deck affected - hash
519 $ the level is now 75183.
520
521 $ ldsr d. shields 4 june 75
522 $
523 $ this ident simplifies some of the initializations, particularly
524 $ for the literals. new literals
525 $ .ws. .ps. .cs. .sl. .so.
526 $ have been added, in anticipation of 'machine parameter' option.
527 $ the level is now 75155.
528 $ decks affected - lexini, setlit
529
530
531 $ ldsq d. shields 30 may 75
532 $
533 $ this correction changes the handling of file names to use
534 $ sds format names instead of machine dependent z-format
535 $ previously used.
536 $ file names of up to -filenamelen- chars (currently 20) are
537 $ allowed. default names are given by macros which may be
538 $ adjusted to fit different systems.
539 $ control card parameters are now obtained using
540 $ library routine -reados-.
541 $ the format of error messages has been changed.
542 $ decks affected - macros,lexini,ermsg(resequenced
543 $ the level is now 75150
544
545
546 $ nmchar d. shields 23 may 75
547 $
548 $ this correction extends the language to include n-type tokens.
549 $ n-type tokens are used to define names and are similar in format
550 $ to the -r-, -h-, -z-, and -d- tokens, except the letter -n- is
551 $ used. n-type tokens permit the use of non-standard characters
552 $ in names; possible uses include protection of library
553 $ names to avoid conflict with user names. for example,
554 $ 'call 3nio.(a,b)' is a call to routine with name 'io.'.
555 $ the level is now 75143.
556 $ decks affected - lexini, trulex
557
558
559 $ ldsp d. shields 9 april 75
560 $
561 $ reported bug - string 'zzzz' processed as though were name.
562 $ fix - restrict test for zzz-zzy type tokens to names.
563 $ the level is now 75099.
564 $ decks affected - nextw, dfabsrb
565
566
567 $ astkmsg d. shields 31 march 75
568 $
569 $ this correction provides improved diagnostic support if
570 $ macro argument has unbalanced parenthesies. previously,
571 $ the scanner continued search over input until -astk- overflow
572 $ occurred, causing fatal termination. the resulting messages
573 $ were confusing to users and provided little help, as error
574 $ actually occurred several hundred tokens before point of overflow.
575 $ the new scheme is as follows - when we start to collect a macro
576 $ argument, we save current line number; during argument collection
577 $ we watch for argument overflow, so that we can indicate most likel
578 $ source of problem.
579 $ the level is now 75090.
580 $ decks affected - macros (astkput only), nextw, ermsg.
581
582
583 $ litcod e deak 23 feb 75
584 $
585 $ all keywords and literals are given literal codes.
586 $ a litcod field is set in the ha for them (lexini). the
587 $ literal code is passed to gen in tokhdr in new field tokrlc.
588 $ the mapping of literals onto litcodes must be identical in gen
589 $ and lex.
590 $ decks affected are macros, hash, detect, genini
591
592 $
593 $ ldso d. shields 6 march 75
594 $
595 $ reported bug - unexpected instance of '/ *' within
596 $ pl1 comment observed.
597 $ fix - trulex had incorrect test for termination of pl1
598 $ style comment if even number of * preceded terminal /.
599 $ the level is now 75065.
600 $ deck affected - trulex
601 $
602
603 $ ldsn d. shields 18 february 75
604 $
605 $ to dimensions of -ha- and -names- have been increased to permit
606 $ compilation of -gen- which supports new i/o features.
607 $ the level is now 75049.
608
609 $ ldsm d. shields 6 november 74
610 $
611 $ reported bug - sequence '1. else' converted to '1. lelse'.
612 $ fix - error in detection and backup of real constants
613 $ fixed in trulex.
614 $ reported bug - punch routines punch '1b' as '21b'.
615 $ fix - octal tokens were being handled as though
616 $ they were strings by -pncr-. test of token type fixed.
617 $ the initialization of actab has been adjusted so that names
618 $ always collected in separate loop, and comment just following
619 $ definition of actab in trulex has been brought up to date.
620 $ the level is now 74310.
621 $ decks affected - lexini, trulex, pncr.
622
623 $ ldsl d shields 6 november 74
624 $
625 $ this correction modifies definition of real constants so that
626 $ blanks only allowed inside such constants if they occur between
627 $ two numeric characters. the previous definition, while satis-
628 $ factory for little, caused problems in new setl front end.
629 $ the macros -addtotok-, -retbuf- and -abuf- are no longer needed,
630 $ and so have been eliminated, as have variables
631 $ numflag and expflag within trulex
632 $ decks affected - macros, trulex
633
634
635 $ ldsk d shields 7 october 74
636 $ this correction makes a few changes to ease system/370 bootstrap
637 $ - time and date now expressed by functions -timestr- and
638 $ -datestr- which return array of characters (8)
639 $ - control card parameters and file names changed to not exceed
640 $ four characters in length
641 $ - default for -detect- option changed to -no- for 370 to
642 $ avoid use of random/access routnes in initial bootstrap
643 $ deck affected - macros, start, lexini
644 $ the level is now 74280
645
646 $
647 $ ldsj d. shields 13 august 74
648 $
649 $ this correction set
650 $ 1. fixes two errors in trulex in detection of real constants
651 $ (bug reported and fixed by d. mirante).
652 $ 2. reduces mtab size to 8000 from 12000.
653 $ 3. corrects countup macro (quitting one entry too soon).
654 $ last line listed if abort via countup.
655 $ 4. dayfile message suppressed if no errors.
656 $ the level is now 74225
657 $ decks affected - macros,trulex, users of -countup- macro
658 $
659
660 $ ldsi d shields 29 july 74
661 $
662 $ this correction fixes an error in macro-processor, slightly
663 $ recodes a test which inadvertently was calling off-line
664 $ multi-word routines.
665 $ - the error in detect causing only last line to be listed
666 $ has been fixed.
667 $ decks affected - macros, nextw, detect
668 $ the level is now 74210
669
670 $ ldsh d. shields 18 july 74
671 $
672 $ this correction fixes error in trulex in handling of blanks
673 $ inside numerical constants.
674 $ the level number is now 74199
675 $ deck affected - trulex
676
1 .=member macros
2
3 $ conditional assembly options.
4
5
dsq 16 $ select lc if lower-case characters available.
dsq 17
dsv 17 .+set mc $ assume mixed-case characters available.
dsv 18
dsv 19 $ if mixed-case available, default primary case is upper.
dsv 20 $ obtain lower primary case by defining mcl.
dsq 19
6 $ select mp to include little macroprocessor.
7 .+set mp
8
9 $ select ca to include conditional assembly feature.
10 .+set ca
11
12 $ select cr to include cross-reference function.
13 .+set cr
14
15 $ following options used to collect performance statistics.
16 $ select tallycomments to count number and type of comments.
17 .+set tallycomments
18
19 $ select tallytokens to count number of tokens sent to parser.
20 $-set tallytokens
21
22 $ select tallyhash to monitor hash table probes.
23 .+set tallyhash
24
25 $ select ht to include code supporting .hatr. and .nohatr.
26 $ ha trace tokens.
27 $-set ht
28
29 $ select ct to include code supporting .chtr. and .nochtr.
30 $ character trace tokens.
31 $-set ct
32
33 $ select mt to include code supporting .mactr. and .nomactr.
34 $-set mt
35
36 $ select mtgc to include empty entry at start of each macro
37 $ definition to permit macro garbage collection. as garbage
38 $ collector not expected soon, text usually not included.
39 .-set mtgc
40 $ select bub if scanner runs together with parser which requires
41 $ token back-up (bub stands for b-ack u-p b-uffer). do not
42 $ select if scanner runs as separate parse phase or job step.
43 .-set bub
44
45 $ select sdspack_env if special library code provided to do
46 $ token pack into hashtok.
dsn 8 .+s10.
dsn 9 .+set movea_env
dsn 11 .+set sdspack_env
dsn 16 ..s10
47 .+s66.
48 .+set sdspack_env
dsv 21 .-set mc $ s66 upper-case only
49 ..s66
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
utsc 1
utsb 14 .+s32.
vaxb 1 .+set sdspack_env,bskp_env,movea_env
vax 11 ..s32
50 .+s37.
51 .+set sdspack_env,bskp_env,movea_env
52 ..s37
utsa 8 .+s47.
utsa 9 .+set mcl $ primary case is lower
utsa 10 .-set sdspack_env,bskp_env,movea_env
utsa 11 ..s47
53
54 +* scannerlevel = $ julian date of last scanner change
ldsa 10 'lex(81324)' $ 20-nov-81
56 **
57
58
utsb 15 .+s32u.
dsv 24 $ configure for unix, set primary case lower.
dsv 25 .+set mcl
dsv 26 $ for initial checkout, delete efficiency env options.
dsv 27 .-set sdspack_env,bskp_env,movea_env
utsb 16 ..s32u
59
60
61
62 +* ws = .ws. ** $ machine word size in bits.
63
64 +* ps = .ps. ** $ machine pointer (address) size in bits.
65
66 +* cs = .cs. ** $ character size in bits.
67
68 +* slen = .len. ** $ length field of self-defining string (sds)
69
70 +* sorg = .f. .sl.+1, .so., ** $ origin field of sds.
71
72 +* sds(n) = .sds. (n) ** $ size of n-character sds.
73
74 +* cpw = (ws/cs) ** $ no. of characters in machine word
75
dsv 29 .+mc.
dsv 30 .+mcl. $ if mixed-case to be lower
dsv 31 +* ctpc(x) = ctlc(x) ** $ primary case is lower.
dsv 32 +* stpc(x) = stlc(x) ** $ primary case is lower.
dsv 33 .-mcl.
dsv 34 +* ctpc(x) = ctuc(x) ** $ primary case is upper.
dsv 35 +* stpc(x) = stuc(x) ** $ primary case is upper.
dsv 36 ..mcl
dsv 37 ..mc
82 +* ms = $ size of macro definition item (must divide ws)
83 .+s66 15
vax 14 .+s32 16
84 .+s37 16
utsa 12 .+s47 16
habb 1 .+s10 18
86 **
87
88 +* wpc = $ number of words per card
89 .+s66 9 $ read 9 words (90 columns) for cdc 6600
vax 15 .+s32 20 $ assume 80 columns in input card
90 .+s37 20 $ assume 80 columns in input card
utsa 13 .+s47 20 $ assume 80 columns in input card
mgfa 14 .+s10 20 $ assume 80 columns in input card.
92 **
93
94 +* filenamelen = 20 ** $ maximum file name length in chars
vaxc 1 .+s32 +* filenamelen = 64 ** $ maximum file name length in chars
utsa 14 .+s47 +* filenamelen = 64 ** $ maximum file name length in chars
95
96 +* tokenfile = 3 ** $ token file number.
97
dsr 12 $ getapp_len is length of actual parameter string (cf. lexini).
dsr 13 +* getapp_len = 128 **
dsr 14 .+s32 +* getapp_len = 240 **
utsa 15 .+s47 +* getapp_len = 240 **
98
99 +* punchfile = 6 ** $ punch file number.
100
101 +* crfile = 5 ** $ cross reference file number.
102
103 .+cr.
104 $ fields of cross-reference entry.
dsu 12 +* cref_line = .f. 01, 16, ** $ line number of reference.
ldsa 11 +* cref_ha = .f. 17, 14, ** $ ha index of item.
ldsa 12 +* cref_macro = .f. 31, 01, ** $ 'is name currently macro'.
108
109 +* crbuffmax = 256 **
110
111 +* crefput(i) =
112 crbuffptr = crbuffptr + 1;
113 crbuff(crbuffptr) = i;
114 if crbuffptr = crbuffmax then
115 call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
116 crbuffptr = 0;
117 end if;
118 **
119 ..cr
120 +* lstimelen = 30 ** $ length of lstime time representation.
121 +* mccd = 72 ** $ rightmost column of input processed
122 +* numbugtoks = 9 ** $ number of special period delim toks
123 +* listarglim = 31 ** $ max. no. of macro arguments.
124 $ arguments, is dimension is array listarg in routine nextw
125 +* namesmax = $ dimension of names array.
ldsa 13 .+s32 12000
ldsa 14 .+s37 12000
utsa 16 .+s47 12000
ldsa 15 .+s66 5000
ldsa 16 .+s10 12000
129 **
130
131 +* mtlim = $ max. number of entries in mtab, macro def. table.
dsu 19 10000
133 **
134
135 +* mstklim = 100 ** $ limit of mstk.
136
137 +* lsvtkz = 15 ** $ dims of -lsvtk-, must be 2**k-1
138
139
140 .+bub +* reslim = 20 ** $ limit on reserved token stack in nextw
141
142 +* maxtoklen = 127 ** $ max. token length in characters
143 +* hashtokorg = $ origin for hashtok string, fixed always
144 (1 + .sds. (maxtoklen+cpw)) **
145
146 +* listprevmax = 10 ** $ depth of listing status saved.
147
148 +* tokrbuflim = 256 ** $ no of entries in token buffer
149
150 +* hasz = $ size of ha in bits
dsu 20 .+s66 120
vax 17 .+s32 64
152 .+s37 64
utsa 17 .+s47 64
153 .+s10 72
154 **
155
156 $ note that the dimension of the ha must be a prime
157 $ selection of primes is machine dependent and is discussed in
158 $ 'the art of computer programming', d. e. knuth, vol 3.
159 $ pp 508-509.
160 $ in brief, condition is to find p such that
161 $ r exp k is not congruent to a modulo p, where
162 $ r is radix of character set (64 for 6600),
163 $ k and a are small integers.
164 $ not that if r exp k is congruent to a mod p, then
165 $ hash of 'ab' is close to sume of hash 'a' and hash 'b'.
166
167 $ suggested values for s66 are: 4073, 3613, 3329, 2969.
168
ldsa 17 .+s66 +* haprime = 3929 ** $ keep old value for s66
ldsa 18 .-s66 +* haprime = 4507 **
170
171 +* hadim = (haprime + haprime/25) ** $ leave space at top.
172
173 +* suspi=2 ** $ nuses threshhold used by detect
174
175
176 +* sdstl = $ macro giving needed size for std token string
177 (.sds. 20) **
178
179 $ macros for token types assigned by scanner
180
181 +* nametok = 1 ** $ name
182 +* spectok = 2 ** $ special, eg () + -
183 +* optok = 3 ** $ period delimited operator, eg =
184 +* dectok = 4 ** $ decimal integer, eg 100
185 +* sstok = 5 ** $ 'special' string token
186 +* stringtok = 6 ** $ constant string, eg 'message'
187 +* bittok = 8 ** $ bit string
188 +* rztok = 12 ** $ r-type token, right zero fill
189 +* realtok = 14 ** $ real constant
190
191 +* cpstr = $ characters per short token record
192 .+s66 6
vax 18 .+s32 1
193 .+s37 1
utsa 18 .+s47 1
mgfa 16 .+s10 1
195 **
196
197 +* listcontroltok = 27 ** $ .=list directives.
198 +* listejecttok = 28 ** $ .=eject directive.
199 +* listtitletok = 29 ** $ .=title directive.
200 +* tokrcard = 30 ** $ tyoen-record code for card image
201 +* tokreof = 31 ** $ token file code for end-of-file
202 .-s66. $ new values.
203 +* tokrtyp = .f. 1, 8, ** $ token-record code for lexical type
204 +* tokrlen = .f. 9, 8, ** $ toeen-record code for no of chars
205 +* tokrlc = .f. 17, 8, ** $ token literal code
206 .+s66. $ old values for now.
207 +* tokrtyp = .f. 1, 5, **
208 +* tokrlen = .f. 7, 7, **
209 +* tokrlc = .f. 14, 9, **
210 ..s66
211 +* tokrval = $ value part of header word (first few token chars)
212 $ (holds cpstr characters)
213 .f. ws+1 - cpstr*cs, cpstr*cs, **
214
215 $ the following macros define characters used to identify
216 $ the various character string constants.
217 $ ha fields are as follows:
218
219 $ nameptr - start of name in names array.
220 $ lextyp - token lexical type, one of nametok, bintok, etc.
221 $ lexlen - token length in characters.
222 $ litcod - literal code if literal.
223 $ nuses - number of token occurrences.
224 $ macorg - start of macro definition in mtab.
225 $ cab - conditional assembly state of name.
226 $ halink - ha index of next entry in hash chain.
227
228
ldsa 19 .+s66.
ldsa 20 +* lextyp = .f. 01, 04, ** $ lexical type.
ldsa 21 +* lexlen = .f. 05, 07, ** $ lexical length.
ldsa 22 +* litcod = .f. 12, 07, ** $ literal code number.
ldsa 23 .+ca +* cab = .f. 19, 01, ** $ conditional assembly bit.
ldsa 24 +* nameptr = .f. 20, 13, ** $ names index.
ldsa 25 .+mp +* macorg = .f. 61, 14, ** $ macro origin.
ldsa 26 +* nuses = .f. 46, 02, ** $ number of uses.
ldsa 27 +* halink = .f. 75, 13, ** $ link for hash chain.
ldsa 28 .+mp +* macimm = .f. 60, 01, ** $ 'is this immediate macro'.
ldsa 29 ..s66
ldsa 30 .+s32.
ldsa 31 .+ca +* cab = .f. 1, 1, **
ldsa 32 .+mp +* macimm = .f. 49, 1, **
ldsa 33 +* nameptr = .f. 2, 14, **
ldsa 34 +* lextyp = .f. 16, 4, **
haba 1 .+mp +* macorg = .f. 50, 14, **
ldsa 36 +* lexlen = .f. 33, 7, **
ldsa 37 +* litcod = .f. 40, 7, **
ldsa 38 +* nuses = .f. 47, 2, **
ldsa 39 +* halink = .f. 20, 13, **
ldsa 40 ..s32
ldsa 41 .+s37.
ldsa 42 .+ca +* cab = .f. 1, 1, **
ldsa 43 .+mp +* macimm = .f. 49, 1, **
ldsa 44 +* nameptr = .f. 2, 14, **
ldsa 45 +* lextyp = .f. 16, 4, **
haba 2 .+mp +* macorg = .f. 50, 14, **
ldsa 47 +* lexlen = .f. 33, 7, **
ldsa 48 +* litcod = .f. 40, 7, **
ldsa 49 +* nuses = .f. 47, 2, **
ldsa 50 +* halink = .f. 20, 13, **
ldsa 51 ..s37
utsa 19 .+s47.
utsa 20 .+ca +* cab = .f. 1, 1, **
utsa 21 .+mp +* macimm = .f. 49, 1, **
utsa 22 +* nameptr = .f. 2, 14, **
utsa 23 +* lextyp = .f. 16, 4, **
haba 3 .+mp +* macorg = .f. 50, 14, **
utsa 25 +* lexlen = .f. 33, 7, **
utsa 26 +* litcod = .f. 40, 7, **
utsa 27 +* nuses = .f. 47, 2, **
utsa 28 +* halink = .f. 20, 13, **
utsa 29 ..s47
ldsa 52 .+s10.
ldsa 53 +* nameptr = .f. 1, 18, **
ldsa 54 .+mp +* macorg = .f. 19, 18, **
ldsa 55 +* lexlen = .f. 37, 7, **
ldsa 56 +* nuses = .f. 44, 2, **
ldsa 57 .+ca +* cab = .f. 46, 1, **
ldsa 58 +* litcod = .f. 47, 7, **
ldsa 59 +* lextyp = .f. 54, 4, **
ldsa 60 .+mp +* macimm = .f. 58, 1, **
ldsa 61 +* halink = .f. 59, 13, **
ldsa 62 ..s10
262
263
264
265 $ io access codes.
266 +* access_put = 3 **
267 +* access_write = 6 **
268
269
270 $ macros for output
271
272 $ routines called by these macros are in little run-time
273 $ library.
274 $ macros are to appear where statement may appear; semicolon indicat
275 $ end of statement supplied by macro expansion.
276
277 +* charl(c) = call charlr(c); ** $ output character
278 +* intl(i) = call intlr(i); ** $ output integer (5 digits)
279 +* intlp(n,c) = call intlpr(n,c); ** $ output integer in c colum
280 +* textl(s) = call textlr(s); ** $ output quoted string
281 +* tintl(s,i) = call tintlr(s,i); ** $ output text and integer
282 +* tabl(p) = call contlpr(4,p); ** $ tab to column p
283 +* skipl(i) = call contlpr(3, i); ** $ skip forward i columns
284 +* octl(i) = call octlr(i);** $ output octal word
285 +* tokl(i) = call toklr(i); ** $ list token given hash
286 +* endl = call endlr;** $ end line
287 +* listl(n) = call contlpr(26, n); ** $ set listing flag
288 +* terml(n) = call contlpr(27, n); ** $ set terminal flag
289 +* ejectl = call contlpr(5,0); ** $ eject to new page.
290 $ ejectlp(n) - eject new page if less than n lines left on
291 $ current page.
292 +* ejectlp(n) = call contlpr(5,n); **
293 $ macros to define macros within macros.
294 +* q3(a,b,c) = a b c **
295 +* macdef(text) = q3(+,*text*,*) **
296 +* macdrop(mname) = macdef(mname=) ** $ easy way to drop macr
297
298 $ these macros for -yes- and-no- aid readability of
299 $ expressions involving logical variables
300
301 +* yes = 1 **
302 +* no = 0 **
303
304 +* error_notice = '*****error**** ' **
305 +* system_notice = '*system error* ' **
306 +* warning_notice = '****warning*** ' **
307
dsq 23 .+s10. $ s10 wants special characters at start of error
dsq 24 $ and warning lines.
dsq 25 +* warn_s10 = charl(37) ** $ per cent for warnings.
dsq 26 +* error_s10 = charl(63) ** $ question mark for errors.
dsq 27 ..s10
dsq 28
308 +* hashin(i) = call hash; i = haptr; ** $ hash and get code
309
310
311 $ table top increment macro
312
313 +* countup(index,limit,ermsg) =
314 index = index+1;
315 if (index > limit) call ltoflo(index,limit,ermsg); **
316
317 +* ertoksave(iwd) = $ macro to save token hash code
318 lsvtk(lsvtkp+1) = iwd; $ add to buffer
319 lsvtkp = (lsvtkp+1).a.lsvtkz; $ add 1 to buffer pointer (pow2
320 lsvtk(lsvtkp+1) = 0; $ mark end
321 **
322
dsq 29 $ codes for standard string sets.
dsq 30
dsq 31 +* ss_blank = 1 **
dsq 32 $ ss_separ matches blank and other characters (such as tab and
dsq 33 $ form feed for ascii environments) which are by convention
dsq 34 $ considered equivalent to blanks.
dsq 35 +* ss_separ = 2 **
dsq 36 +* ss_digit = 4 ** $ digits.
dsq 37 +* ss_ucltr = 8 ** $ upper case letters a..z
dsq 38 +* ss_lcltr = 16 ** $ lower case letters a..z
dsq 39 +* ss_break = 32 ** $ underline, break '_'
dsq 40
dsq 41 $ additional string sets.
dsq 42
dsq 43 +* ss_conda = 64 ** $ string set for conditional assembly chara
dsq 44
dsq 45 $ imtoks is string of single-character (immediate) tokens. these
dsq 46 $ tokens are found efficiently by trulex without hashing.
dsq 47
dsq 48 +* imtoks = '(),;=+-*:^!&' **
dsq 49 +* num_imtoks = 14 **
dsq 50 .+s66.
dsq 51 $ on s66 imtoks must be variable so can deal correctly with
dsq 52 $ both 63 and 64 character sets.
dsq 53 macdrop(imtoks)
dsq 54 +* num_imtoks = 15 **
dsq 55 ..s66
dsq 56
dsq 57 +* ss_immed = 128 ** $ string set for immediate token chars.
dsq 58
dsq 59 $ macros for character type (used principally by trulex).
dsq 60
dsq 61 +* alphabetic(c) = anyc(c, ss_ucltr ! ss_lcltr ! ss_break ) **
dsq 62 +* numeric(c) = anyc(c, ss_digit) **
dsq 63 +* alphameric(c) = anyc(c, ss_ucltr ! ss_lcltr ! ss_break !
dsq 64 ss_digit) **
dsq 65 .+ca +* iscachar(c) = anyc(c, ss_conda) ** $ conditional assembly.
dsq 66 $ lettercode macro maps letters in a..z_ to ordinal position and
dsq 67 $ other characters to zero. this macro used mainly to process
dsq 68 $ zzy- and zzz- symbols in macro definitions.
dsq 69 +* lettercode(c) = ((brkc('abcdefghijklmnopqrstuvwxyz_', 1, c)
dsq 70 >= 0) * (1 + brkc('abcdefghijklmnopqrstuvwxyz_', 1, c)) ) **
dsq 71
dsq 72 $ isblank is macro to test if character is blank or equivalent
dsq 73 $ separator. blank is assumed to be only separator in upper-case
dsq 74 $ only systems (true for s37 and s66).
dsq 75
dsv 38 .-mc +* isblank(c) = (c=1r ) **
dsv 39 .+mc +* isblank(c) = anyc(c, ss_separ) ** $ separators.
dsq 78 $ separators.
330 +* tally(i) = i = i+1; ** $ used to count things
331 +* digofchar(c) = $ decimal value of decimal character
332 (c-1r0)
333 **
334 +* charofdig(d) = $ character for decimal digit
335 (d+1r0)
336 **
337
338 +* blankword = $ machine word of blanks (cf. macro givec)
vax 30 .+s32 4r
339 .+s37 4r
utsa 30 .+s47 4r
340 .+s66 10r
mgfa 17 .+s10 4r
342 **
343
dsq 79 $ cc_tab is code for tab character if available,
dsq 80 $ or is code for blank.
dsq 81 +* cc_tab =
dsq 82 .+s10 9
dsq 83 .+s11 9
dsq 84 .+s32 9
dsq 85 .+s37 1r
utsc 2 .+s47 9
dsq 86 .+s66 1r
dsq 87 **
dsq 88
344
347
348 $ isymc(wd,j) - gets j-th char in token with ha-index wd
349 +* isymc(wd, j) = (.f. ws+1-cs - cs*mod((j)-1, cpw), cs,
350 names(nameptr ha(wd) + (j-1)/cpw)) **
351
352
353 +* tokch(p, c) = $ set first character in hashtok
354 .f. hashtokorg -cs*(p), cs, hashtok = c; **
355
356 +* sdspack(ara,count) = $ copy char per elm array into hashtok
357 .-sdspack_env.
358 size zzza(ps);
359 do zzza = 1 to count; $ loop doing each character.
360 tokch(zzza, ara(zzza));
361 end do;
362 slen hashtok = count;
363 .+sdspack_env. $ if special code in library used.
364 call 7nspak$li(hashtok, ara, count);
365 ..sdspack_env
366 **
367
368
369
370 +* getsym(sym, hap) = $ macro to get name as string given hash
371 size zzza(ps); zzza=nameptr ha(hap); $ position word 1 of na
dsn 19 .+s10.
dsn 20 $ move characters from names into global buffer
dsn 21 $ (technique exploiting dec-10 blt byte-move ops would be helpful)
mgfa 18 .f. 5*ws+1, ws, sym = names(zzza);
mgfa 19 .f. 4*ws+1, ws, sym = names(zzza + 1);
mgfa 20 .f. 3*ws+1, ws, sym = names(zzza + 2);
mgfa 21 .f. 2*ws+1, ws, sym = names(zzza + 3);
mgfa 22 .f. 1*ws+1, ws, sym = names(zzza + 4);
dsn 26 ..s10
372 .+s66. $ macro is machine dependent
373 .f. 121, 60, sym = names(zzza); $ first part of token
374 .f. 61, 60, sym = names(zzza+1); $ next ten chars
375 ..s66
vax 31 .+s32.
vax 32 $ move characters from names into global buffer
vax 33 .f. 5*ws+1, ws, sym = names(zzza);
vax 34 .f. 4*ws+1, ws, sym = names(zzza + 1);
vax 35 .f. 3*ws+1, ws, sym = names(zzza + 2);
vax 36 .f. 2*ws+1, ws, sym = names(zzza + 3);
vax 37 .f. 1*ws+1, ws, sym = names(zzza + 4);
vax 38 ..s32
376 .+s37.
377 $ move characters from names into global buffer
378 $ (technique exploiting system/370 byte-move ops would be helpful)
379 .f. 5*ws+1, ws, sym = names(zzza);
380 .f. 4*ws+1, ws, sym = names(zzza + 1);
381 .f. 3*ws+1, ws, sym = names(zzza + 2);
382 .f. 2*ws+1, ws, sym = names(zzza + 3);
383 .f. 1*ws+1, ws, sym = names(zzza + 4);
384 ..s37
utsa 32 .+s47.
utsa 33 $ move characters from names into global buffer
utsa 34 $ (technique exploiting system/370 byte-move ops would be helpful)
utsa 35 .f. 5*ws+1, ws, sym = names(zzza);
utsa 36 .f. 4*ws+1, ws, sym = names(zzza + 1);
utsa 37 .f. 3*ws+1, ws, sym = names(zzza + 2);
utsa 38 .f. 2*ws+1, ws, sym = names(zzza + 3);
utsa 39 .f. 1*ws+1, ws, sym = names(zzza + 4);
utsa 40 ..s47
385 size zzzl(ps); $ for length of token
386 zzzl = lexlen ha(hap); if (zzzl>20) zzzl=20;
387 slen sym = zzzl; sorg sym = sdstl+1;
388 **
389 $ macros used by trulex, the basic lexical scanner
390
391 +* keeplimit = 10 **
392
393
394 +* keepc(char) = $ macro to save char in buffer
395 .+ct countup(keepindex, keeplimit, 'keep');
396 .-ct keepindex = keepindex + 1;
397 keep(keepindex) = char ; **
398
399
400 +* getfromkeep(char) = $ get char from buffer
401 char = keep(keepindex);
402 keepindex = keepindex - 1; **
403 +* givec_text(c) = $ macro to get character
404 if keepindex then $ if prior token kept.
405 getfromkeep(c);
406 elseif nowc > mccd then $ if new card must be read.
407 call givecr(c); $ read next card.
dsv 40 .+mc c = ctpc(c); $ fold first char in line.
408 else
409 if nc10 = 1 then $ if new word needed
410 nowdp = nowdp + 1; nowd = iwds(nowdp);
411 nc10 = ws + 1;
412 if nowd = blankword then $ if blanks, take only one.
413 .+tallytokens tally(tallyblank)
414 nc10 = 1;
415 nowc = nowc + cpw; $ advance to next word.
416 c = 1r ;
417 go to zzza;
418 end if;
419 end if;
420 nc10 = nc10 - cs; $ advance to next character.
dsv 41 .+mc c = ctpc((.f. nc10, cs, nowd));
dsv 42 .-mc c = .f. nc10, cs, nowd;
dsq 91 nowc = nowc + 1;
422 end if;
423 /zzza/
424 .+ct.
425 if chartrace then $ if tracing characters.
426 textl(' ct=<') charl(c) textl('> ')
427 end if;
428 ..ct
429 **
430
431 +* giveq(c) = givec_text(c); ** $ get character inline.
432 +* givec(c) = call givecp(c); ** $ get character offline.
433
434 +* giveqnk(c) = $ get character when not in -keep-.
435 if nowc > mccd then $ if new card must be read.
436 call givecr(c); $ read next card.
dsw 15 .+mc c = ctpc(c); $ convert to primary case.
437 else
438 if nc10 = 1 then $ if new word needed
439 nowdp = nowdp + 1; nowd = iwds(nowdp);
440 nc10 = ws + 1;
441 if nowd = blankword then $ if blanks, take only one.
442 .+tallytokens tally(tallyblank)
443 nc10 = 1;
444 nowc = nowc + cpw; $ advance to next word.
445 c = 1r ;
446 go to zzza;
447 end if;
448 end if;
449 nc10 = nc10 - cs; $ advance to next character.
dsv 43 .+mc c = ctpc((.f. nc10, cs, nowd));
dsv 44 .-mc c = .f. nc10, cs, nowd;
dsq 94 nowc = nowc + 1;
451 end if;
452 /zzza/
453 .+ct.
454 if chartrace then $ if tracing characters.
455 textl(' ct=<') charl(c) textl('> ')
456 end if;
457 ..ct ;
458 **
459 +* givecstr(ic) = $ get character when inside char. string
460 call givesp(ic); **
461
462 +* charin(c) = $ add -c- to token buffer
463 tokptr = tokptr + 1; $ advance index
464 tok(tokptr) = c; $ store in token array.
465 if tokptr > maxtoklen then $ check if in range
dso 10 call ermsg(10, maxtoklen, 0); $ give error.
467 tokptr = maxtoklen/2 + 1; $ set to shorter token.
468 end if;
469 **
470
471 $ macro to set macro-table value
472 .+mp.
473 +* seter(intoarr,value,loc) =
474 .f. ws+1-ms - ms*mod((loc)-1, ws/ms), ms,
475 intoarr(1 + ((loc)-1)/(ws/ms)) = value; **
476 +* mtset(loc,iwd) = seter(mtab,iwd,loc) **
477
478 +* geter(fromarr,loc)=
479 .f. ws+1-ms - ms*mod((loc)-1, ws/ms), ms,
480 fromarr(1 + (loc-1)/(ws/ms)) **
481 $ macro to get parcel from macro dictionary
482 +* mtget(j)=geter(mtab,j) **
483
484 $ macro for load into ms-bit packed vector
485 +* astklim = 100 ** $ dimension of -astk-
486 +* astkget(l) = astk(l); ** $ gets -l- entry in astk
487 +* astkset(l,v) = astk(l) = v;**$ set -l-th entry in astk to v
488
489 $ macro to pass token to puncher routine, with check for zero arg
490
491 +* mflshr(iwd) = call pflshr(iwd); **
492
493 +* mcexpnd(i) = $ get token from -mcexpand-.
494 until iwd; $ loop until got non-zero token.
495 if keepwd then $ see if a token was kept.
496 iwd = keepwd; keepwd = 0; $ get it if so.
497 quit until; $ show got token.
498
499 elseif mstkpt = 0 then $ can call -trulex- directly.
500 call trulex; $ just get token.
501 .+tallytokens tally(tallytrue); $ count true tokens.
502 .+mt.
503 if mactrace then $ if tracing macros.
504 textl('trulex <') tokl(iwd) textl('>') endl
505 end if;
506 ..mt
507
508 ertoksave(iwd); $ save token for token list.
509 quit until; $ show got token.
510
511 else $ we are in a macro expansion.
512 call mcexpand; $ call routine to get from macros.
513 end if;
514 end until;
515
516 i = iwd; $ set result token.
517 .+mt.
518 if mactrace then $ if tracing macros.
519 textl('macexp <') tokl(iwd) textl('>') endl
520 end if;
521 ..mt
522 **
523 ..mp
524
525 +* dfabsrb(i) = $ get token from -defabsrb-.
526 .+mp.
527 until iwd; $ loop until got a token.
528 mcexpnd(iwd); $ first get from -mcexpand-.
529 if iwd = ihpl ! iwd = ihst then $ macro start, end.
530 call defabsrb; $ call routine if it is.
531 end if;
532 end until;
533
534 .+mt.
535 if mactrace then $ if tracing macros.
536 textl('defabsrb <') tokl(iwd) textl('>') endl
537 end if;
538 ..mt
539
540 .-mp call trulex; $ get token if no macros.
541
542 i = iwd; $ copy to output.
543 **
544
545
546 ..mp
547 $ macros for writing token file for generator phase
548
549 +* tokout1(wd) = $ output one word token to token file
550 tokrbufp = tokrbufp + 1; tokrbuf(tokrbufp) = wd;
551 if tokrbufp >= tokrbuflim then $ flush buffer if full
552 call wtrwsio(tokenfile, iorc, tokrbuf, 1, tokrbufp);
553 tokrbufp = 0;
554 end if;
555 **
556
557 +* tokout(hdrwd, ara, lo) = $ output token descriptor
558 size zzzw(ps); $ no of words to output
559 size zzzi(ps); $ do loop index.
560 tokout1(hdrwd);
561 zzzw = (tokrlen hdrwd -1)/cpw + 1;
562 if tokrbufp+zzzw >= tokrbuflim then $ flush buffer if full.
563 do zzzi = 1 to zzzw;
564 tokout1(ara(zzzi+lo-1));
565 end do;
566 else
567 .+movea_env.
568 call 7nmova$li(tokrbuf, tokrbufp+1, ara, lo, zzzw); $ move
569 .-movea_env.
570 do zzzi = 1 to zzzw; $ just copy into buffer.
571 tokrbuf(tokrbufp+zzzi) = ara(lo-1+zzzi); $ copy one word.
572 end do;
573 ..movea_env
574 tokrbufp = tokrbufp+zzzw;
575 end if; **
576
1 .=member start
dsn 27 .+s10 prog start;
vax 39 .+s32 prog start;
dsn 28 .+s37 prog start;
utsa 41 .+s47 prog start;
dsn 29 .+s66 subr start;
4 $ all global variables are defined in this routine.
5 $ the routine lexini is called to perform needed initializations
6 $ and then lexdo, the driver for the scanner, is called.
7 .+s66 nameset blank; $ keep in blank common on s66.
8 size astk(ps); dims astk(astklim); $ stack for macro arguments
9 .+s66 end nameset blank;
10 size astkpt(ps); data astkpt=0; $ top of macro arg. list
11 size bugtoks(ps); dims bugtoks(numbugtoks);
12 size caname(cs); dims caname(mccd-3); $ ca name
13 size cardlisted(1); $ flag set when card listed
14 size cardsent(1); data cardsent = yes; $ 'card sent to gen'
15 size col3char(cs); $ column 3 of card
16 size canamel(ps); $ length of -caname-
17 size cardskip (1); data cardskip=0; $ card'skip flag
19 size chartrace(ps); $ char trace flag
20 size countzzy(ps); dims countzzy(27); data countzzy = 0(27);
21 size countzzz(ps); dims countzzz(27); data countzzz = 0(27);
22 .+cr.
23 size crfilename(sds(filenamelen)); $ name of reference file.
24 size crfileparm(sds(filenamelen)); $ skeleton for ref. file name
25 size crbuffptr(ps); data crbuffptr = 0;
26 .+s66 nameset blank; $ keep in blank common on s66.
27 size crbuff(ws); dims crbuff(crbuffmax);
28 .+s66 end nameset blank;
29 size creftot(ps); data creftot = 0; $ total number of refs.
30 ..cr
31 size dodetect(1); $ on to list suspicious variables.
32 size errecho(1); data errecho = no; $ for error echo of input c
33 size exitcode(1); data exitcode = yes; $ exit code for -lexexit-
34 size fivdecara(cs); dims fivdecara(5); $ fivdec result.
35 .+cr size crefent(ws); $ cross reference entry.
36 size haptr(ps); $ index of current ha entry.
37 .+s66 nameset blank; $ keep in blank common on s66.
38 size ha(hasz);dims ha(hadim); $ symbol table.
39 .+s66 end nameset blank;
40 size hafree(ps); data hafree = hadim+1; $ free pointer for hash
41 size hashca(ps); $ hash-code of -caname-
42 .+ca size hashcaset(ps); $ hash code of -set-
43 size hashlen(ps); $ length in chars of token to hash
44 size hashtok(hashtokorg-1); data hashtok=0; $ global hash input s
45 size hashtrace(ps); $ hashtrace flag
46 size hashtyp(ps); $ lexical typeof hashed token
47 size hashwords(ps); $ no of words in hashed token
48 size haused(ps); data haused=0; $ no of ha-words full
49 size icdno(ps); data icdno=0; $ no. of cards read
50 size icdlast(ps); data icdlast = 0; $ last card no. sent to gen.
51 size ihcm(ps); $ hash-index of symbol ',' (comma)
52 size ihcompdate(ps); $ ha index of compilation date.
53 size iheq(ps); $ hash pointer for symbol -=-
54 size ihlp(ps); $ hash-index of symbol '(' (left paren)
55 size ihpl(ps); $ hash-index of symbol '+' (plus)
56 size ihpr(ps);
57 size ihrp(ps); $ hash-index of symbol ')' (right paren)
58 size ihsemi(ps); $ hash-code of semicolon
59 size ihsl(ps); $ hash-code of slash /
60 size ihst(ps); $ hash-index of symbol '*' (star)
dsq 95 size imtoktab(ps); dims imtoktab(num_imtoks);
dsq 96 .+s66.
dsq 97 $ imtoks is variable so can deal with 63 and 64 sets.
dsq 98 $ see lexini for details.
dsq 99 size imtoks(.sds. num_imtoks);
dsq 100 data imtoks = '(),;=+-*^!&::' ;
dsq 101 ..s66
62 size initializing(1); data initializing=yes;
63 $ -initializing- on while we are initializing the scanner.
64 size initloc(ps); $ used to save -prevloc-
65 .+cr size isonxrf(ps); data isonxrf = no; $ on when doing xref
66 size iorc(ps); $ return code from io operation.
67 size iwd(ps); $ ha-index
68 size iwds(ws); dims iwds(wpc); $ input card image
69 size keep(cs); dims keep(keeplimit);$ character buffer for givec
70 size keepindex(ps); data keepindex = 0; $ index into keep
71 size keepwd(ps); data keepwd=0; $ one-token buffer
72 size lastwd(ps); $ index of last non-blank word on card.
73 size lcp_opt(1); data lcp_opt=yes; $ on to list parameters.
74 size lcs_opt(1); data lcs_opt=yes; $ on to list statistics.
75 size lelvalue(ps); $ error limit.
78 size lexdotrace(ps); data lexdotrace = 0; $ lexdo tok list
79 size listapt(ps); data listapt=0; $ no. of args in current macro
80 size listarg(ps); dims listarg(listarglim);
81 $ listignore is set when .=list directives are to be ignored.
82 size listignore(1); data listignore = no;
83
84 $ listprev is list of prior list control status entries.
85 size listprev(ps); dims listprev(listprevmax);
86 size listprevptr(ps); data listprevptr = 1;
87 size listnow(ps); $ current list status word.
88 size listnew(ps); $ new list status word.
89 size listvals(ps); $ array of list parameters
90 +* list_code = 1 ** $ list generated code in -asm-
91 +* list_input = 2 ** $ list input in -gen-
92 +* list_autotitle = 3 ** $ auto titling in -gen-
93 +* list_skip = 4 ** $ list skipped cards
94 +* list_qualifiers = 5 ** $ list conditional qualifiers
95 +* list_linput = 6 ** $ list input in -lex-
96 +* list_references = 7 ** $ collect references
97 +* list_definitions = 8 ** $ punch macro definitions
98 +* list_expansions = 9 ** $ punch expanded text
99 +* list_resume = 10 ** $ pop listing stack
100 +* list_directive = 11 ** $ list current list directive
101
102 +* listinginput = .f. list_linput, 1, listnow **
103 +* collectingrefs = .f. list_references, 1, listnow **
104 +* listingen = .f. list_input, 1, listnow **
105
106 +* numlistparms = 11 ** $ number of listing options
107 dims listvals(numlistparms);
108
109 $ definitions of fields of -listvals-
110 +* listval_tf = .f. 1, 1, ** $ output data to token file
111 +* listval_ll = .f. 2, 1, ** $ causes directive to list in -lex-
112 +* listval_gl = .f. 3, 1, ** $ causes directive to list in -gen-
113 +* listval_df = .f. 4, 1, ** $ default initial value
114
115 $ array of characters used in 'list' parameter
116 size listchars(cs); dims listchars(numlistparms);
117
118 +* setlist(val, char, tf, ll, gl, df) = $ macro to set option
119 listchars(val) = char:
120 listvals(val) = 8*df + 4*gl + 2*ll + tf **
121
122 data $ initialize list control arrays
123
124 $ value ic tf ll gl df
125 setlist(list_code, 1rc, yes, yes, yes, no):
126 setlist(list_input, 1ri, yes, yes, no, no):
127 setlist(list_autotitle, 1ra, yes, yes, yes, no):
128 setlist(list_skip, 1rs, no, yes, yes, no):
129 setlist(list_qualifiers, 1rq, no, yes, yes, no):
130 setlist(list_linput, 1rl, no, no, yes, no):
131 setlist(list_references, 1rr, no, yes, yes, yes):
132 setlist(list_definitions, 1rd, no, yes, yes, no):
133 setlist(list_expansions, 1re, no, yes, yes, no):
134 setlist(list_resume, 0, no, no, no, no):
135 setlist(list_directive, 0, no, no, no, no);
136
137 macdrop(setlist)
138 size lsvtk(ps); dims lsvtk(lsvtkz+1); data lsvtk = 0(lsvtkz+1);
139 size lsvtkp(ps); data lsvtkp=0; $ current entry in lsvtk
dst 11 .+mdc.
140 size mdclist(ps); data mdclist=no; $ on to list mach. dep. cnst
dst 12 ..mdc
141 size mstk(ws); dims mstk(mstklim); $ macro expansion control
142 .+mp. $ variables used in mcacroprocessor
143 size mactrace(1); data mactrace=no; $ on for macro trace
144 size mname(ps); $ ha index of macro name.
145 size mstkpt(ps); data mstkpt=0; $ top of macro control stack
146 size mtptr(ps); data mtptr=0; $ top of macro def. table
147 .+s66 nameset blank; $ keep in blank common on s66.
148 size mtab(ws); dims mtab(mtlim/(ws/ms)); $ macro table
149 .+s66 end nameset blank;
150 ..mp
151 .+s66 nameset blank; $ keep in blank common on s66.
152 size names(ws); dims names(namesmax);
153 .+s66 end nameset blank;
154 size nc10(ps); $ position in current word nowd
155 size nerrors(ps); data nerrors=0; $ number of detected errors.
156
157 size normwork(5); $ normal work to do for a card
158 $ this is needed by -givecr- to determine what processing
159 $ is needed for each card. the flags in the variable
160 $ indicate the following types of processing:
161 +* proc_work = 1b'10001' ** $ have -lex- process card
162 +* list_work = 1b'10010' ** $ have -lex- list card
163 +* elim_work = 1b'10100' ** $ eliminate qualifiers fro card
164 +* out_work = 1b'11000' ** $ send card to -gen- to list
165
166 data normwork = out_work!proc_work;
167
168 size nowc(ps); data nowc=mccd+1; $ last column of input processed
169 size nowd(ws); $ current word in iwd
170 size nowdp(ps); $ $ idex in iwds of current word
171 size nparen(ps); $ number of parens seen in macro argument
172 size namesptr(ps); data namesptr=1; $ next free word in names
173 size numargs(ps); $ number of macro arguments
174 size nwarnings(ps); data nwarnings=0; $ warning count.
175 $ punchdefine on to punch macro definitions; punchexpand on
176 $ punch expanded text.
177 size punchdefine(1); data punchdefine = no;
178 size punchexpand(1); data punchexpand = no;
179 size punchfilename(sds(filenamelen)); $ name of punch file
180 size punchopened(1); data punchopened=no; $ on when pun file open
181 size punchpos(ps); data punchpos=0; $ position in punch buffer
182 size punchbuf(cs); dims punchbuf(80); $ punch line.
183 size punhold1(ps), punhold2(ps); $ keept tokens.
184 size punlastlt(ps); $ last lexical type for punch.
185 .+bub.
186 size res(ps); dims res(reslim); $ token backup buffer (for pa
187 size resptr(ps); data resptr=0; $ top of (unused) token back
188 ..bub
189 size subtitling(1); data subtitling=no; $ on when doing subtitle
190 .+tallycomments. $ counters for optional comment statistics
191 /* these statistics count the number and type of comments.
192 they are included in the production compiler as they provide
193 a rough measure of documentation quality. */
194 size tallypl1(ps); data tallypl1=0; $ no. of pl/1 comments
195 size tallyeol(ps); data tallyeol=0; $ number of $-style comments
196 ..tallycomments
197 .+tallytokens. $ counters for optional token statistics
198 /* the token statistics count the number of immediate tokens,
199 the number of tokens found by the scanner, and the number of
200 tokens sent to the parser.*/
201 size tallytrue(ps); data tallytrue=0; $ number of true tokens
202 size tallyimtok(ps); data tallyimtok=0; $ immediate tokens
203 size tallyparse(ps); data tallyparse=0; $ tokens to parser
204 size tallyblank(ps); data tallyblank=0; $ blank words seen
205 ..tallytokens
206 .+tallyhash. $ counters for optional hash statistics
207 /* the hash statistics count the number of times the symbol
208 table is searched, and the number of entries examined. */
209 size tally_haprobes(ps); data tally_haprobes=0; $ number of probe
210 size tally_haentries(ps); data tally_haentries=0; $ number of ent
211 size tally_halinks(ps); data tally_halinks = 0; $ number of lin
212 ..tallyhash
213 size termlex(ps); $ on to terminate after lexical phase.
214 size tok(cs); dims tok(maxtoklen+1); $ token array
215 size tokptr(ps); $ current entry in token buffer
216 .+s66 nameset blank; $ keep in blank common on s66.
217 size tokrbuf(ws); dims tokrbuf(tokrbuflim);
218 .+s66 end nameset blank;
219 size tokrbufp(ps); data tokrbufp=0; $ index of last token outpu
220 size tokrwd(ws); $ for outputting token descriptor
221 size toktrace(ps); data toktrace=no; $ on for -trulex- -ha- trace
222 size tokwrt(1); $ switch on when writing token file
223 size tokenfilename(sds(filenamelen)); $ name of token file
224
225 call lexini;
226 call lexdo; $ main driver routine for scanner
227 exitcode = 0; call lexexit; $ terminate scan
228
dsn 30 .+s10 end prog start;
vax 40 .+s32 end prog start;
dsn 31 .+s37 end prog start;
utsa 42 .+s47 end prog start;
dsn 32 .+s66 end subr start;
1 .=member lexini
2 subr lexini; $ initialization
3 $ lexini is initialization routine, called only once from start.
4 $ lexini initializes variables, processes the control-card
5 $ options for the scan, and prints the initial part
6 $ of the header on the scanner output file.
7
8 size c(cs); $ temporary for character table set up
9 size tmparm(sds(filenamelen)); $ target machine parameter.
10 .+ca size inisetparm(sds(filenamelen)); $ initial set request.
11 size lstimestr(.sds. lstimelen);
13 size i(ps), j(ps), l(ps); $ loop indices
14 size inimemname(.sds. filenamelen); $ name of initial member.
15 size ilp(.sds. filenamelen); $ initial list parameter.
16 size tokrwd(ws); $ for writing list control on token file.
17 size liststr(sds(1)); $ used to process -list- parameter
dsq 102 size updseq(ps); $ upd sequence option.
dsq 103 size brkc(ws); $ function to locate character in string.
dsr 15 size appstr(.sds. getapp_len); $ actual parameter string.
18 .+s66 size ha_00b(ps); $ hash code for character 3b'00'.
19 .+s66 size ha_63b(ps); $ hash code for character 3b'63'.
20
21 do i = 1 to hadim; ha(i) = 0; end do; $ clear the ha.
22
dsq 104 call blds('+-.', ss_conda); $ string set for conditional assembly
50
51 sorg hashtok = hashtokorg; $ origin will never be changed
52
53 $ get name in initial member to include.
54 call getspp(inimemname, 'imem=/');
55
vax 41 .+s32 call getspp(tokenfilename,'tokens=tokens.tmp/');
56 .+s37 call getspp(tokenfilename,'tokens=sysut1/');
utsa 43 .+s47 call getspp(tokenfilename,'tokens=sysut1/');
57 .+s66 call getspp(tokenfilename,'tokens=tokens/');
mgfa 23 .+s10 call getspp(tokenfilename, 'tokens=*.tok/');
59
60 tokwrt = (.ch. 1,tokenfilename ^=1r0); $ on if writing tokens
61 $ tokwrt is now zero if not writing token file; otherwise
62 $ is name of token file
63 call opensio(tokenfile, iorc, access_write, tokenfilename,
64 tokrbuflim*cpw, i, 0, 0);
dsr 16 .+s66 call rewisio(tokenfile, iorc, 0);
vax 42 .+s32 call getspp(punchfilename, 'pfn=little.pun/');
66 .+s37 call getspp(punchfilename, 'pfn=syspunch/');
utsa 44 .+s47 call getspp(punchfilename, 'pfn=syspunch/');
67 .+s66 call getspp(punchfilename, 'pfn=lexout/');
68 .+s10 call getspp(punchfilename, 'pfn=*.pun/');
69
74
75 $ param -lt- used to get token list in -lexdo- set initial value
76 call getipp(lexdotrace, 'lt=0/1');
77 .+ct call getipp(chartrace, 'ct=0/1');
78 .+ht call getipp(hashtrace, 'ht=0/1');
79 .+mt call getipp(mactrace, 'mt=0/1');
80
81 .+cr.
vax 44 .+s32 call getspp(crfileparm, 'rf=little.rf0/');
82 .+s37 call getspp(crfileparm, 'rf=sysref(ref0)/');
utsa 45 .+s47 call getspp(crfileparm, 'rf=sysref(ref0)/');
83 .+s66 call getspp(crfileparm, 'rf=ref0/');
dsn 33 .+s10 call getspp(crfileparm, 'rf=*.rf0/');
85 call getipp(isonxrf, 'lcr=0/1');
86 if isonxrf then
87 call crfnam(crfilename, crfileparm, 1);
88 call opensio(crfile, iorc, access_write, crfilename,
89 0, i, 0, 0);
90 creftot = 0;
91 end if;
92 ..cr
93
dsz 12 call getipp(dodetect, 'susp=0/0');
dst 13 .+mdc.
95 call getipp(mdclist, 'mdc=0/1');
dst 14 ..mdc
96
97 call getipp(lelvalue, 'lel=25/');
98 $ scan aborted if more than lelvalue errors detected.
99
100 $ lcp_opt gives parameter list if on; lcs_opt lists statistics.
101 call getipp(lcp_opt, 'lcp=1/0');
102 call getipp(lcs_opt, 'lcs=1/0');
utsb 17 .+s32u. $ minimal listing by default for unix.
dsv 46 call getipp(lcp_opt, 'lcp=0/1');
dsv 47 call getipp(lcs_opt, 'lcs=0/1');
utsb 18 ..s32u
utsb 19 .+s47. $ minimal listing by default for unix.
utsb 20 call getipp(lcp_opt, 'lcp=0/1');
utsb 21 call getipp(lcs_opt, 'lcs=0/1');
utsb 22 ..s47
103
104 listnow = 0; listnew = 0; $ clear values
105
106 call getspp(ilp, 'list=sq/isqa');
107
dsq 105 call getipp(updseq, 'upd=0/1'); $ upd sequence option
dsq 106
108 sorg liststr = sds(1)+1; slen liststr = 1; $ initialize string
109 do i = 1 to numlistparms; $ process each parm
110 .f. i, 1, listnow = listval_df listvals(i); $ set default
111 .f. i, 1, listnew = listval_df listvals(i);
112 c = listchars(i); $ get character
113 if c then $ use value given
114 .ch. 1, liststr = c; $ build into sds
115 if (liststr .in. ilp) .f. i, 1, listnew = yes;
116 end if;
117 end do;
118
119 listprev(1) = listnow; $ set prior options
120 listnow = listnow .ex. listnew; $ flag changed options
121
122 do i = 1 to numlistparms; $ process changes
123 if (.f. i, 1, listnow = no) cont do; $ not changed
124 if listval_tf listvals(i) & tokwrt then $ write to token fil
125 tokrwd = 0;
126 tokrtyp tokrwd = listcontroltok;
127 tokrlen tokrwd = i; $ set list parameter number
128 tokrlc tokrwd = .f. i, 1, listnew; $ set value
129 tokout1(tokrwd);
130 end if;
131 end do;
132
133 listnow = listnew; $ set active listing mode
134 if ('0' .in. ilp) listignore = yes;
135 punchdefine = .f. list_definitions, 1, listnow;
136 punchexpand = .f. list_expansions, 1, listnow;
137 if (listinginput) normwork = normwork ! list_work;
vax 45 .+s32 call getspp(tmparm, 'tm=32/');
138 .+s37 call getspp(tmparm, 'tm=37/');
utsa 46 .+s47 call getspp(tmparm, 'tm=47/');
139 .+s10 call getspp(tmparm, 'tm=10/');
140 .+s66 call getspp(tmparm, 'tm=66/');
141
142 .+ca.
143 call getspp(inisetparm, 'iset=/');
144 ..ca
145
146 call getipp(termlex, 'termlex=0/1');
dsr 17
dsr 18 $ get actual parameters specified.
dsr 19 call getapp(appstr, getapp_len);
dsr 20
147 $ set up listing title, get compilation date.
148 call ltitlr(scannerlevel);
149 call stitlr(0, 'little compilation - lexical scan phase.');
150
151 call lstime(lstimestr);
152
153 if (lcp_opt=0) go to parmslisted;
154
155 call stitlr(1, 'parameters for lexical scan.');
dsr 21
dsr 22 if .len. appstr then $ if any explicitly specified.
dsr 23 textl(appstr) endl endl
dsr 24 end if;
dsr 25
160 if slen inimemname then $ if including initial member.
161 textl('initial member to include: imem = ')
162 textl(inimemname) charl(1r.) endl
163 end if;
164 if slen ilp then $ if list parameters specified
165 textl('initial list options: list = ') textl(ilp)
166 textl('.') endl
167 end if;
168 textl('token file: tokens = ') textl(tokenfilename)
169 textl('. punch file: pfn = ') textl(punchfilename)
170 textl('.') endl
171
172 textl('list statistics: lcs =') intlp(lcs_opt,2)
173 textl('. list suspicious names: susp =') intlp(dodetect, 2)
174 textl('.') endl
175 textl('lexical error limit: lel =') intl(lelvalue)
dsq 107 textl('. upd sequence: upd =') intlp(updseq, 2)
176 textl('.') endl
177 .+cr.
178 textl('lexical cross reference list: lcr =') intlp(isonxrf,2)
179 textl('. reference file: rf = ') textl(crfileparm) textl('.')
180 endl
181 ..cr
182 .+ca.
183 endl textl('conditional inclusion selected for symbol')
184 if slen inisetparm then
185 textl('s: ')
186 textl(inisetparm)
187 else
188 textl(':')
189 end if;
190 textl(' s') textl(tmparm)
utsb 23 .+s32u textl(' s32u')
191 endl
192 ..ca
193 endl endl
194 /parmslisted/
195
196 $ initialize table for detecting special period delim tokens
197 +* lextokstr =
198'chtr nochtr hatr nohatr lextr nolextr mactr nomactr compdate '
199 **
200 hashtyp = optok; $ type remains fixed for all used of bughash
201 tokch(1, 1r.); j = 0; l = 1;
202 do i = 1 to slen lextokstr;
203 c = .ch. i, lextokstr;
204 if c=1r then $ if end of current
205 l = l+1; tokch(l, 1r.);
206 slen hashtok = l;
207 hashin(l); j = j + 1; bugtoks(j) = l;
208 l = 1;
209 else $ add character to current literal
210 l = l+1; tokch(l, c);
211 end if;
212 end do;
213 macdrop(lextokstr)
214
215 $ initialize one-character special token table
217 slen hashtok = 1; $ all immediate tokens are 1 char
218 hashtyp = spectok; $ and are special
219
dsq 108 do i = 1 to num_imtoks;
dsq 109 c = .ch. i, imtoks;
222 tokch(1, c); $ enter into hashtok
223 hashin(haptr);
dsq 110 imtoktab(1+brkc(imtoks, 1, c)) = haptr;
dsq 111 end do;
dsq 112
dsq 113 .+s66.
dsq 114 $ for s66, initialize so both codes 3b'00' and 3b'63' accepted
dsq 115 $ as little colon.
dsq 116 .ch. 14, imtoks = 3b'63';
dsq 117 tokch(1, 3b'63'); hashin(ha_63b); imtoktab(14) = ha_63b;
dsq 118 .ch. 15, imtoks = 3b'00';
dsq 119 tokch(1, 3b'00'); hashin(ha_00b); imtoktab(15) = ha_00b;
dsq 120 ..s66
dsq 121
dsq 122 call blds(imtoks, ss_immed); $ string set for immediate tokens
230 .+ca.
231 $ hash in name -set- for use by conditional-assemblyfeature
232
233 tokch(1,1rs); tokch(2,1re); tokch(3,1rt);
234 slen hashtok = 3; hashtyp = nametok;
235 hashin(hashcaset); $ put hashcode in -hashcaset-
236 $ generate set corresponding to target machine.
237 tokch(2, (.ch. 1, tmparm));
238 tokch(3, (.ch. 2, tmparm));
239 hashin(i);
240 cab ha(i) = yes;
241 nuses ha(i) = suspi+1; $ avoid listing as suspicious.
utsb 24 .+s32u. $ if compiling in s32u, define symbol 's32u'.
utsb 25 tokch(1,1rs); tokch(2,1r3); tokch(3,1r2); tokch(4,1ru);
dsx 13 slen hashtok = 4;
dsx 14 hashin(i); cab ha(i) = yes; nuses ha(i) = suspi+1;
utsb 26 ..s32u
242 ..ca
243
244 $ build string with compilation date for .compdate. value.
245 slen hashtok = lstimelen;
246 do i = 1 to lstimelen;
247 tokch(i, (.ch. i,lstimestr));
248 end do;
249 hashtyp = stringtok;
250 hashin(ihcompdate);
251
252 hashtyp = spectok;
253 +* inihash(var, sym) =
254 slen hashtok = slen sym; $ set length in characters for hash
255 do i = 1 to slen sym; tokch(i, (.ch. i, sym)); end do;
256 .+ht.
257 if hashtrace then
258 textl('inihash -') textl(sym) charl(1r )
259 tintl(' type',hashtyp) endl end if;
260 ..ht
261 hashin(var); **
262
dsq 123 ihlp = imtoktab(1+brkc(imtoks, 1, 1r( ));
dsq 124 ihrp = imtoktab(1+brkc(imtoks, 1, 1r) ));
dsq 125 ihpl = imtoktab(1+brkc(imtoks, 1, 1r+ ));
dsq 126 ihst = imtoktab(1+brkc(imtoks, 1, 1r* ));
dsq 127 ihcm = imtoktab(1+brkc(imtoks, 1, 1r, ));
dsq 128 ihsemi = imtoktab(1+brkc(imtoks, 1, 1r; ));
dsq 129 iheq = imtoktab(1+brkc(imtoks, 1, 1r= ));
267 inihash(ihsl, '/'); inihash(ihpr, '.');
268
269 hashtyp = nametok;
270 call setlit; $ routine to set literal codes
271
272 .+s66 litcod ha(ha_63b) = 70; $ set literal code for colon.
273 .+s66 litcod ha(ha_00b) = 70; $ set literal code for colon.
274 .+ca nuses ha(hashcaset) = suspi + 1;
275 .+ca.
276 $ if initial set requested, set conditional bit for name.
277 if slen inisetparm then
dsy 11 call cainit(inisetparm);
281 end if;
282 ..ca
283 initializing = no; $ indicate termination of initialization
284 call stitlr(1, 'program listing (lexical phase)');
285
dsq 130 call opninc('', inimemname, '', updseq); $ open input file.
287
288 macdrop(inihash); $ drop -inihash- macro
289 end subr lexini;
1 .=member cainit
2 .+ca.
3 subr cainit(iparm);
4
5 $ initialize iset parameter string, which consists of names
6 $ separated by plus sign characters with optional
7 $ plus sign before first name.
8
9 size iparm(.sds. filenamelen);
10 size plen(ps); $ length of parm string
11 size inow(ws); $ current position
12 size ilen(ws); $ length of current part.
13 size cnow(cs); $ current character
14 size i(ws); $ ha index.
15 size anyc(ws), brkc(ws); $ string search functions.
16
17 plen = .len. iparm;
18 if (plen = 0) return; $ quit if null string.
19
20 inow = 1;
21
22 while inow <= plen; $ loop over string
23 cnow = .ch. inow, iparm; $ get current character.
24 if cnow = 1r+ then $ if sign char.
25 inow = inow + 1; $ advance to next character
26 cont while;
27 end if;
28 ilen = brkc(iparm, inow, 1r+); $ look for next plus
29 hashtyp = nametok; $ assume name.
30 if ilen<0 then $ if none, name is rest
31 ilen = plen - inow + 1;
32 end if;
33 if alphabetic(cnow) = no then $ error
34 call ermsg(5,cnow,0); $ check error number
35 else
36 do i = 1 to ilen;
37 cnow = .ch. (inow+i-1), iparm; $ next char.
38 if alphameric(cnow) = no then $ error
39 hashtyp = 0; $ indicate illegal.
40 quit do;
41 end if;
42 tokch(i, cnow);
43 end do;
44 if hashtyp = 0 then $ if illformed token
45 call ermsg(5, cnow, 0);
46 else
47 slen hashtok = ilen;
48 hashin(i);
49 cab ha(i) = yes;
50 end if;
51 end if;
52 inow = inow + ilen;
53 end while;
54 end subr cainit;
55 ..ca
1 .=member setlit
2 subr setlit;
3 +* il(s) = call inslit(s); **
4
5 /* literal strings and their literal numbers are encoded as
6 described below in -inslit-. */
7
8
9 $ note that the following mapping is identical to macro definitions
10 $ in gen and any change or addition must also be made in gen.
11
12 hashtyp = nametok;
13
14 il('1 if + while + until + do + end + else + size + dims + data ')
15
16 il('11 nameset + access + real + call + goby + return + elseif ')
17
18 il('18 in 21 rewind + filestat + go + cont + quit 32 to ')
19
20 il('59 check + trace + assert + nocheck + notrace + subr + fnct ')
21
22 il('66 monitor 71 then + by + index + flow + stores + entry ')
23
24 il('80 file 85 get + put 92 limit + read + write + prog ')
25
26 hashtyp = spectok; $ special symbols
27
28 il('10 ; 36 ! 38 & 46 = 47 < + > + ^ + + + - + * + / ')
29
30 il('67 ( + ) + , + : ')
31
32 hashtyp = optok;
33
34 il('19 .sds. + .voapart. ')
35
36 il('26 .f. + .e. + .s. + .ch. 31 .cc. 33 .or. + .ex. + .exor. ')
37
38 il('37 .and. 39 .a. + .eq. + .ne. + .gt. + .lt. + .ge. + .le. ')
39
40 il('54 .in. + .not. + .n. + .fb. + .nb. ')
41
42 il('77 .voadump. + .len. + .pad. ')
43
44 il('81 .nocontr. + .toktr. + .notoktr. + .contr. ')
45
46 il('87 .ws. + .ps. + .cs. + .sl. + .so. 96 .seq. + .sne. ')
47
48 macdrop(il)
49
50 end subr setlit;
1 .=member inslit
2 subr inslit(s); $ insert literal in hash table
3 $ called by macro -il- to set literal code in ha for all
4 $ keywords and literal
5
6 size s(sds(70)); $ literal to hash
7 size litlc(ps); $ literal code to set
8 size i(ps); $ hash index of lit
9 size l(ps); $ length of literal
10 size c(cs); $ current character
11 size state(ps); $ current state during scan
12
13 /* s is an encoding of literal numbers and corresponding literals.
14 entries alternate between numerics and literals; numerics
15 give the literal numbers (a + indicates that literal
16 number is to be incremented). fields are separated by one or more
17 blanks. the first field is a number, the last character must be
18 blank. */
19
20 state = 1; $ begin with search for numeric
21 litlc = 0; $ literal code to set
22
23 do i = 1 to slen s;
24 c = .ch. i, s; $ current character
25 go to st(state) in 1 to 4;
26 /st(1)/ $ skip blanks to start of numeric field
27 if (c=1r ) cont do;
28 if c = 1r+ then litlc = litlc + 1; state = 3;
29 else
30 litlc = digofchar(c); state = 2; end if;
31 cont do;
32 /st(2)/ $ collect numerics up to blanks
33 if (c=1r ) then state = 3;
34 else litlc = 10*litlc + digofchar(c); end if;
35 cont do;
36 /st(3)/ $ skip blanks to start of literal
37 if (c=1r ) cont do;
38 l = 0; state = 4; $ start literal
39 $ fall through to st(4) to get first character
40 /st(4)/ $ add non-blanks to literal
41 if c=1r then
42 slen hashtok = l; $ set length of literal
43 hashin(l); $ hash in, set hash code to l
44 litcod ha(l) = litlc; $ set literal code
45 state = 1;
46 else
47 l = l+1; tokch(l, c); $ add character to literal
48 end if;
49 end do;
50
51 end subr inslit;
1 .=member lexdo
2 subr lexdo; $ control routine - gets tokens and writes them out
3 $ -lexdo- is main driver routine for scanner
4 $ the initialisation routine -lexini- is called.
5 $ tokens are then obtained from -nextw- and written
6 size i(ps); $ temporary.
dsq 131 size anyc(ws); $ any string search function.
dsq 132 size brkc(ws); $ break string search function.
7
8 while yes; $ loop forever.
9 while yes; $ loop until got a token.
10 .+bub.
11 if rptr < resptr then $ get from backup table.
12 rptr = rptr+1; iwd = res(rptr); $ get token index.
13 quit while; $ show token obtained.
14 end if;
15 ..bub
16
17 dfabsrb(iwd); $ get token from below.
18 while macimm ha(iwd); $ process immediate macros.
19 iwd = macorg ha(iwd); $ get new token.
20 end while;
21
22 $ now see if this token is a normal macro.
23 if macorg ha(iwd) then $ it is a macro.
24 call nextw; $ call routine to start expansion.
25 cont while; $ go get next token.
26 end if;
27
28 until yes; $ now check for zzz or zzy tokens.
29 if (lexlen ha(iwd) ^= 4) quit until; $ not if length 4.
30 if (lextyp ha(iwd) ^= nametok) quit until; $ not name.
31 if (.f. ws+1-2*cs, 2*cs, names(nameptr ha(iwd)) ^= 2rzz)
32 quit until; $ first two characters not zz.
33 i=lettercode((.f. ws+1-4*cs, cs, names(nameptr ha(iwd))));
34 if (i=0) quit until; $ not letter *** assumes cpw>=4 ***
35 if .f. ws+1-3*cs, cs, names(nameptr ha(iwd)) = 1ry !
36 .f. ws+1-3*cs, cs, names(nameptr ha(iwd)) = 1rz then
37 call buildz(iwd, i, nametok + (dectok-nametok) *
38 (.f. ws+1-3*cs,cs,names(nameptr ha(iwd))=1ry));
39 end if;
40 end until;
41
42 quit while; $ show got token.
43 end while;
44
45 .+bub.
46 resptr = resptr+1; res(resptr) = iwd; $ save in backup buffer.
47 rptr = resptr; $ set pointer.
48 if resptr >= reslim then $ this is a full buffer.
49 do i = 1 to reslim/2; $ move down contents.
50 res(i) = res(i + reslim/2); $ move each entry.
51 end do;
52
53 resptr = reslim/2; rptr = resptr; $ set new pointer.
54 end if;
55 ..bub
56
57 if lexdotrace ! punchexpand then $ must output something.
58 if punchexpand then mflshr(iwd); end if;
59 if lexdotrace then $ print out token trace.
60 tintl('lexdo, typ', lextyp ha(iwd)) tintl('hash', iwd)
61 tintl('length', lexlen ha(iwd))
62 tintl('litcod', litcod ha(iwd)) textl(' symbol <')
63 tokl(iwd) textl('>') endl
64 end if;
65 end if;
66
67 if (tokwrt = no) cont while; $ skip if not writing token file.
68
69 $ now check to see if there is a card that has not been sent
70 $ to gen. if so, send it.
71 if cardsent = no then $ if card has not been sent.
72 if lastwd = 0 then $ if last word not determined yet.
73 do lastwd = wpc to 2 by -1; $ scan down card.
74 if (iwds(lastwd) ^= blankword) quit do;
75 end do;
76 end if;
77
78 tokrwd = 0; tokrlen tokrwd = cpw*lastwd; $ set length.
79 tokrtyp tokrwd = tokrcard; $ set token type.
80 tokrlc tokrwd = icdno-icdlast; icdlast = icdno; $ set diff.
81 tokout(tokrwd, iwds, 1); $ write out on token file.
82 cardsent = yes; $ show card written.
83 end if;
84
85 .+tallytokens tally(tallyparse) $ count tokens sent to parser
86
87 tokrtyp tokrwd = lextyp ha(iwd);
88 tokrlen tokrwd = lexlen ha(iwd); $ enter length in characters
89 tokrlc tokrwd = litcod ha(iwd);
90 if lexlen ha(iwd) <= cpstr then $ if short record, write single
91 tokrval tokrwd = tokrval names(nameptr ha(iwd));
92 tokout1(tokrwd);
93 else
94 tokout(tokrwd, names, (nameptr ha(iwd)));
95 end if;
96 end while;
97
98 end subr lexdo;
99 .+mp.
1 .=member nextw
2 subr nextw; $ starts expansion of macros.
3 size astkcardno(ps); $ card no. when start to get macro args.
4 size imacsta(ps); $ holds current place in -mstk-
5 size j(ps); $ do loop index for argument collection
6 size mbeg(ps); $ index in -mtab- of start of mac defn
7 size place(ps); $ position on arg stack
8 size prevloc(ps); $ start of previous argument
9
10 +* astkput(v) = $ add value to arguemt stack.
11 astkpt = astkpt + 1; $ increment pointer.
12 if astkpt > astklim then $ this is an overflow.
13 call ermsg(28, mname, astkcardno); $ print error message.
14 astkpt = initloc; $ back up to last position.
15 astkset(astkpt, 0); $ reset to end of last argument.
16 return; $ done - get next token.
17
18 else $ this entry will fit.
19 astkset(astkpt, v); $ add value to stack.
20 end if;
21 **
22
23 mname = iwd; $ save name of macro.
24 mbeg = macorg ha(mname);
25 numargs = mtget(mbeg);
26 if numargs = 0 then $ no arguments, prepare for expansion
27 $ stack current location of argstack top, macstack top, and stack
28 $ initial dictionary pointer for current macro
29 if mstkpt+3 <= mstklim then $ add 3 entries
30 mstk(mstkpt+1) = astkpt;
31 mstk(mstkpt+2) = mstkpt; $ save current position
32 mstk(mstkpt+3) = mbeg + 1;
33 mstkpt = mstkpt+3;
34 astkput(0);
35 return; $ get next symbol.
36 else $ mstk overflow, force overflow error exit
dso 11 call ermsg(21, 0, 0); call lexexit; $ fatal error.
38 end if;
39 end if;
40
41 dfabsrb(iwd);
42 if iwd ^= ihlp then $ error, called with no arguments
dso 12 call ermsg(1, mname, 0); $ issue diagnostic
44 keepwd = iwd; return;
45 end if;
46
47 astkput(0);
48 prevloc = astkpt;
49 initloc = prevloc;
50 nparen = 0;
51
52 astkcardno = icdno; $ record card no. at start of macro
53 $ so if overflow occurs, we can list this card number.
54 j = 1; $ show processing first argument.
55 while yes; $ loop until exited.
56 dfabsrb(iwd); $ get next token.
57 nparen = nparen + (iwd=ihlp) - (iwd=ihrp); $ new paren level.
58 until yes; $ quit if this token ends argument.
59 if (nparen = 0 & iwd = ihcm) quit until; $ comma.
60 if nparen < 0 then $ this end the argument list.
61 if j < numargs then $ too few arguments.
dso 13 call ermsg(2, mname, 0); $ print error message.
63 astkpt = initloc; astkset(astkpt, 0); $ reset ex
64 return; $ go get next token.
65 end if;
66
67 $ else this is a normal end of argument list.
68 quit until; $ first, it is an end of argument.
69 end if;
70
71 $ this is now an item in the arguments. if this is not
72 $ past the last argument, add to list.
73 if j <= numargs then $ add to stack.
74 astkput(iwd); $ add to stack.
75 end if;
76
77 cont while; $ go around again.
78 end until;
79
80 $ this is argument terminator. unless past last argument,
81 $ add entry to stack.
82 if j <= numargs then $ ok.
83 astkput(0); astkset(prevloc, astkpt); $ chain.
84 prevloc = astkpt; $ set new previous location.
85 end if;
86
87 if (nparen < 0) quit while; $ done if last argument.
88
89 if j = numargs then $ too many arguments.
dso 14 call ermsg(3, mname, 0); $ print error message.
91 end if;
92
93 j = j + 1; $ increment argument count.
94 end while;
95
96 place = initloc;
97 imacsta = mstkpt;
98 do j = 1 to numargs;
99 countup(mstkpt, mstklim,
100 'macro recursion or excessive nesting.');
101 mstk(mstkpt) = place + 1;
102 size ipl(ps); ipl = place;
103 place = astkget(place); $ advance to next arg
104 astkset(ipl, 0);
105 end do;
106
107 if mstkpt+3 <= mstklim then $ add 3 entries
108 mstk(mstkpt+1) = initloc-1;
109 mstk(mstkpt+2) = imacsta;
110 mstk(mstkpt+3) = mbeg + 1;
111 mstkpt = mstkpt+3;
112 astkput(0);
113 return;
114 else $ mstk overflow, force overflow exit
dso 15 call ermsg(21, 0, 0); call lexexit;
116 end if;
117
118 end subr nextw;
1 .=member buildz
2 subr buildz(wd, ndx, typ); $ build zzy or zzz token.
3 size wd(ps); $ ha index of token constructed.
4 size ndx(ps); $ index of counter.
5 size typ(ps); $ lexical type desired.
6
7 if typ = dectok then
8 call fivdec(countzzy(ndx)); $ get trailer part
9 slen hashtok = 5;
10 tokch(1, fivdecara(1)); tokch(2, fivdecara(2));
11 tokch(3, fivdecara(3)); tokch(4, fivdecara(4));
12 tokch(5, fivdecara(5));
13 else
14 tokch(1, 1rz); tokch(2, 1rz); tokch(3,1rz);
15 tokch(4,(.ch. ndx, 'abcdefghijklmnopqrstuvwxyz_'));
16 call fivdec(countzzz(ndx)); $ get numeric trailer
17 tokch(5, fivdecara(1)); tokch(6, fivdecara(2));
18 tokch(7, fivdecara(3)); tokch(8, fivdecara(4));
19 tokch(9, fivdecara(5));
20 slen hashtok = 9;
21 end if;
22
23 hashtyp = typ;
24 hashin(wd);
25
26 end subr buildz;
1 .=member defabsrb
2 subr defabsrb; $ detects macro definitions, and digests them
3 $ this routine collects macro definitions and enters macro text
4 $ in macro dictionary. tokens are obtained from mcexpand and
5 $ are sent on to nextw. the bulk of the code consists of
6 $ tests for a variety of errors in macro definitions.
7 $ the routine also punches out macro definitions if the user
8 $ has requested this feature.
9 size ano(1); $ set if duplicate argument.
10 size cno(ps); $ holds bit position in zzz zzy var search
11 size j(ps); $ do loop index
12 size increm(ps); $ ha-index bias used in -mtab-
13 size startl(ps); $ holds current -mtab- pointer when def begun
14 size ismacimm(1); $ 'is this immediate macro.'
15 size firstsym(ps); $ first token in macro text.
16 $ casezzy and casezzz distinguish first from later instances
17 $ of zzy and zzz symbols, respectively. the new symbol is
18 $ generated on expansion of first instance.
19 size casezzy(27), casezzz(27);
dsq 133 size brkc(ws); $ break string match function.
20
21 /top/
22 j = iwd; $ save + or *.
23 mcexpnd(iwd); $ get next token.
24 if iwd ^= ihst then $ no macro definitions.
25 keepwd = iwd; iwd = j; return; end if; $ return token.
26
27 if j = ihst then $ macro closer in open text.
dso 16 call ermsg(4, 0, 0); iwd = 0; $ give error message.
29 return; $ return ignoring tokens.
30 end if;
31
32 /macname/
33 mcexpnd(mname); $ get macro name
34 listapt = 0; $ set argument list pointer.
35 $ if lexical type is name, go off to continue processing.
36 $ otherwise print diagnostic 'missing macro name'.
37
38 if lextyp ha(mname) ^= nametok then $ error, not name
dso 17 call ermsg(8, mname, 0); $ issue diagnostic
40 go to flush; $ flush macro definition.
41 end if;
42
43 if punchdefine then $ if punching macros, punch + * name
44 mflshr(ihpl); mflshr(ihst);
45 mflshr(mname);
46 end if;
47
48 mcexpnd(iwd);
49 if iwd = iheq then $ this starts the parameters.
50 if punchdefine then mflshr(iheq); end if;
51 elseif iwd = ihlp then $ seen (, must have macro args
52 if punchdefine then mflshr(ihlp); end if;
53 until iwd ^= ihcm; $ loop until end of argument list.
54 mcexpnd(iwd);
55 if lextyp ha(iwd) = nametok then
56 ano = no; $ if non-zero will be argument number
57 do j = 1 to listapt;
58 if iwd=listarg(j) then ano=yes; quit do; end if;
59 end do;
60
61 if ano ! iwd = mname then $ error - duplicate argu
62 call ermsg(17, iwd, mname);
63 else
64 countup(listapt, listarglim, 'listapt'); $ add ne
65 listarg(listapt) = iwd; $ list of macro arguments
66 if punchdefine then mflshr(iwd); end if;
67 end if;
68 end if;
69
70 mcexpnd(iwd); $ get next token.
71
72 if iwd = ihcm then $ this is normal ender.
73 if punchdefine then mflshr(iwd); end if;
74 elseif iwd ^= ihrp then $ this is an error.
dso 18 call ermsg(16, mname,0); keepwd = iwd; $ flag error.
76 end if;
77 end until;
78
79 if punchdefine then mflshr(iwd); end if;
80
81 mcexpnd(iwd);
82 if punchdefine then mflshr(iheq); end if;
83
84 if iwd ^= iheq then
dso 19 call ermsg(15, mname, 0);
86 keepwd = iwd;
87 end if;
88
89 else $ if not (or = after +*name, then have error
90 call ermsg(9, iwd, mname);
91 go to flush; $ go flush macro definition.
92 end if;
93
94 $ here begin to accumulate macro text. get hash table entry, number
95 $ of prior uses
96 $ prior macro flag. if flagged as macro, go off to zero word
97 $ preceeding macro text, allowing eventual garbage collection. if
98 $ used before, go off to give warning message. save location
99 $ in macro-text dictionary for eventual garbage collection.
100 $ note starting macro-text dictionary location
101
102 if macorg ha(mname) = 0 then
103 if nuses ha(mname) > 1 then $ warning - name with prior use
dso 20 call ermsg(10, mname, 0); end if;
105 .+mtgc.
106 else
107 if macorg ha(mname) > 1 then $ clear origin word
108 mtset(macorg ha(mname)-1, 0); end if;
109 ..mtgc
110 end if;
111 .+mtgc countup(mtptr, mtlim, 'macro gc word');
112 $ reserve entry for macro argument count.
113 countup(mtptr, mtlim, 'macro arg. count');
114 startl = mtptr;
115 casezzy = 0; casezzz = 0;
116
117 $ at the 'gettext' label below we
118 $ collect text up to a closing '**',
119 $ reporting on '+*' which is illegal.
120 $ the macro text is transferred into
121 $ mtable.
122
123 /gettext/
124 $ sequence for collection of macro-body text
125 mcexpnd(iwd);
126 if iwd = ihst ! iwd = ihpl then $ this could be opener or closer
127 j = iwd; $ save whichever it was.
128 mcexpnd(iwd); $ get next token.
129 if iwd ^= ihst then $ if not star, then last was not special
130 keepwd = iwd; $ keep last token.
131 if punchdefine then mflshr(j); end if;
132 iwd = j; go to sendback; $ go back to previous and proce
133 end if;
134
135 $ this was now either a '+*' or a '**'. in either case
136 $ terminate the current macro but issue an error message
137 $ in the case of '+*'.
138 if j = ihpl then $ this is an error.
dso 21 call ermsg(22, 0, 0); $ give error message.
140 iwd = 0; $ set flag to loop back.
141 end if;
142
143 if punchdefine then mflshr(ihst); mflshr(ihst); end if;
144
145 else $ not special token.
146 if punchdefine then mflshr(iwd); end if;
147 go to putmaywd; $ now put into table.
148 end if;
149
150 if mtptr <= startl then
151 $ drop macro status of -mname-
152 nuses ha(mname) = 0; $ clear use field
153 .+mtgc.
154 if macorg ha(mname) > 1 then $ clear origin word
155 mtset((macorg ha(mname))-1, 0);
156 end if;
157 ..mtgc
158 macorg ha(mname) = 0;
159 macimm ha(mname) = no;
160 mtptr = mtptr - 1; $ reclaim argument count word.
161 go to trysend; $ try to get next token.
162 end if;
163
164 $ see if macro can be made immediate.
165 ismacimm = no;
166 until 1;
167 if (mtptr > (startl+1)) quit until; $ if more than one symb
168 if (listapt) quit until; $ if arguments.
169 firstsym = mtget(mtptr); $ get symbol.
170 if (firstsym <= 300) quit until; $ if arg or zzz symbol.
171 firstsym = firstsym - 300; $ convert to ha index.
172 $ if symbol is itself macro, cannot make immediate so can
173 $ still detect macro recursion.
174 if (macorg ha(firstsym)) quit until;
175 $ if symbol is +, cannot make immediate because of
176 $ possibility of occurring in a macro definition.
177 if (firstsym = ihpl) quit until;
178
179 ismacimm = yes; $ is immediate macro.
180 end until;
181
dso 22 if (macorg ha(mname)) call ermsg(11, mname,0); $ redefining macro
183
184 macimm ha(mname) = ismacimm;
185 if ismacimm then $ if immediate.
186 macorg ha(mname) = firstsym;
187 mtptr = startl - 1;
188 else
189 countup(mtptr, mtlim, 'mt');
190 mtset(mtptr, 0); $ mark end of macro text
191 .+mtgc mtset(startl, mname); $ record macro name index
192 mtset(startl, listapt); $ enter argument count.
193 macorg ha(mname) = startl;
194 end if;
195
196 /trysend/
197 if (iwd = 0) go to macname; $ loop in error case.
198 mcexpnd(iwd); $ get the next token.
199 if (iwd = ihpl) go to top; $ start again if +.
200 return; $ else return token.
201
202 /putmaywd/
203 if listapt then $ if arguments, see if argument.
204 if lextyp ha(iwd) = nametok then $ check only names.
205 do j = 1 to listapt;
206 if iwd = listarg(j) then
207 countup(mtptr, mtlim, 'mt');
208 mtset(mtptr, j);
209 go to gettext; $ continue definition search.
210 end if iwd;
211 end do j;
212 end if;
213 end if listapt;
214
215 until 1;
216 if (lexlen ha(iwd) ^= 4) quit until; $ not zzz type
217 if (lextyp ha(iwd) ^= nametok) quit until;
218 if (.f. ws+1-2*cs, 2*cs, names(nameptr ha(iwd)) ^= 2rzz) quit;
219 j = .f. ws+1-3*cs, cs, names(nameptr ha(iwd)); $ get third char
220 if (j=1rz) ! (j=1ry) then
221 cno = lettercode((.f. ws+1-4*cs, cs,names(nameptr ha(iwd))));
222 if (cno=0) quit until ;$ must be alphabetic, els skip
223 increm = 100;
224 if j = 1ry then $ if zzy symbol.
225 increm = increm + 50;
226 if .f. cno, 1, casezzy = 0 then $ if first instance.
227 .f. cno, 1, casezzy = 1;
228 increm = increm + 100;
229 end if;
230 else
231 if .f. cno, 1, casezzz = 0 then $ if first instance.
232 .f. cno, 1, casezzz = 1;
233 increm = increm + 100;
234 end if;
235 end if;
236 countup(mtptr, mtlim, 'mt');
237 mtset(mtptr, increm+cno); $ add biased symbol code to text
238 go to gettext;
239 end if;
240 end until;
241
242 $ +* macro = zzza,zzza,zzyc,zzyc,zzyc**
243 $ is put in mtable in the form
244 $ 201,101,253,153,153
245
246 if iwd = mname then $ error - macro occurs in self
dso 23 call ermsg(13, iwd, 0); go to gettext; end if;
248
249 /sendback/
250 countup(mtptr, mtlim, 'mt');
251 mtset(mtptr, iwd+300); $ enter standard token in text
252 go to gettext;
253
254 /flush/ $ flush macro definition because of error.
255 until j = ihst & iwd = ihst; $ until two stars.
256 j = iwd; mcexpnd(iwd);
257 if j = ihpl & iwd = ihst then $ +* found.
dso 24 $ give error and continue.
dso 25 call ermsg(22, 0, 0); go to macname;
259 end if;
260
261 end until;
262
263 iwd = 0; $ show no token gotten.
264
265 end subr defabsrb;
1 .=member mcexpand
2 subr mcexpand; $ expands macros
3 $ this routine expands macros, obtaining next token from trulex
4 $ if no macros to expand.
5
6 size aptr(ps); $ index to part of macro arg list
7 size indx(ps); $ index for zzzy, zzzz.
8
9 $ the encoding used in this section is as follows -
10 $ pointers to the macro-text dictionary are integers not greater
11 $ than the dimension 'mtlim' of the dictionary. pointers
12 $ to the argument stack are offset by a positive increment
13 $ equal to mtlim
14
15 /macnext/
16 aptr = mstk(mstkpt);
17 if aptr > mtlim then $ if expanding macro argument
18 iwd = astkget(aptr - mtlim); $ next word in argument
19 if iwd = 0 then $ have reached end of argument
20 mstkpt = mstkpt - 1; $ move down to next arg
21 mstk(mstkpt) = mstk(mstkpt) + 1; $ move to next mac item
22 if (mstkpt > 1) go to macnext; $ if more to do.
23
24 else $ return word of macro text
25 mstk(mstkpt) = aptr+1;
26 end if;
27
28 else
29 iwd = mtget(aptr); $ get item from macro text
30 if iwd = 0 then $ end of macro,restore state
31 astkpt = mstk(mstkpt-2); $ restore argstak pointer
32 mstkpt = mstk(mstkpt-1); $ restore mstak pointer
33 if (mstkpt) go to macnext; $ continue if more ma
34
35 else
36 if iwd < 100 then $ begin argument copy
37 countup(mstkpt, mstklim, 'mstk');
38 mstk(mstkpt) = mstk(mstk(mstkpt-2) + iwd) + mtlim;
39 go to macnext;
40 else
41 if iwd < 300 then $ zzzy or zzzz case.
42 indx = mod(iwd-100, 50); $ get case index.
43 go to zy((iwd-100)/50) in 0 to 3;
44 /zy(2)/ countzzz(indx) = countzzz(indx)+1;
45 /zy(0)/ call buildz(iwd, indx, nametok);
46 go to zydone;
47 /zy(3)/ countzzy(indx) = countzzy(indx)+1;
48 /zy(1)/ call buildz(iwd, indx, dectok);
49 else
50 iwd = iwd-300;
51 end if;
52
53 /zydone/ mstk(mstkpt) = mstk(mstkpt) + 1;
54 end if;
55 end if;
56 end if;
57
58 end subr mcexpand;
59 ..mp
1 .=member trulex
2 subr trulex; $ gets tokens, eliminates comments
3
4 $ the routine -trulex- collects input characters together
5 $ into tokens.
6
7 size c(cs); $ character scanned
8 size len(ps); $ string length.
9 size delimchar(cs); $ delimiter for 0-type string constants
10 size i(ps); $ while and do loop index
11 size bitmax(ps); $ code for maximum acceptable char in bit con
12 $ need nultyp since lexca may also call hash and so set hashtyp.
13 size nultyp(ps); $ new lexical type.
14 size blankinsidenumeric(1); $ on if numeric contained blank.
dsq 134 size anyc(ws); $ any string match function.
dsv 49 .+mc size ctpc(cs); $ function to convert character to primary case.
dsq 136 size brkc(ws); $ break string match function.
15
16
17 /scanon/
18 tokptr = 0; $ reset token pointer
19
20 giveq(c); $ get a character.
21
22 /newchar/ $ here to process a gotten character.
23 .+bskp_env. $ if assembler blank skip.
dsqa 1 while c=1r ;
25 call 7nbskp$li(iwds, nowdp, nc10, nowc, nowd, c, tallyeol);
dsqc 1 $ if rest of line blank, then read next line
dsqc 2 $ and process here following lines which have
dsqc 3 $ initial $ and hence are comments.
dsqc 4 if nowc>mccd & c=1r then $ if rest blank.
dsqa 3 while 1;
dsqa 4 call givecr(c); $ get next line.
dsv 50 .+mc c = ctpc(c); $ in case first char is other-case.
dsqa 6 if (c^=1r$) quit while;
dsqa 7 .+tallycomments tally(tallyeol);
dsqa 8 end while;
dsqa 9 end if;
dsqa 10 end while;
dsq 137 $ bskp skips only blanks so need check again in case
dsq 138 $ character is now non-blank separator.
dsq 139 ..bskp_env
28 $ we know that blanks cannot be in -keep- so we can use a
29 $ quicker scan.
dsq 140 while isblank(c); giveqnk(c); end while;
32
dsq 141 if anyc(c, ss_immed) then $ if immediate token.
34 .+tallytokens tally(tallyimtok) $ count immediate tokens
35 .+ht.
36 if hashtrace then textl(' imtok=') charl(c) charl(1r ) end if;
37 ..ht
dsq 142 iwd = imtoktab(1+brkc(imtoks, 1, c));
dsq 143 return;
39
40 elseif alphabetic(c) then $ if name.
41 nultyp = nametok;
42 while alphameric(c); charin(c); giveq(c); end while;
43 go to endc;
44
45 elseif numeric(c) then
46
47 nultyp = dectok;
48 blankinsidenumeric = no;
49 while 1;
50 charin(c); giveq(c);
52 if (numeric(c)) cont while; $ continue if numeric.
dsq 144 if isblank(c) then $ look for run of blanks in integer
54 blankinsidenumeric = yes;
dsq 145 while isblank(c); giveqnk(c); end while;
56 if (numeric(c)) cont while;
57 go to endc;
58 elseif c = 1rb then
59 if (tokptr>1) go to endc;
60 i = digofchar(tok(1));
61 if (i<1 ! i>4) go to endc;
62 givec(c);
63 if c=1r' then charin(1rb);
64 else keepc(1rb); go to endc; end if;
65 nultyp = bittok;
dsq 146 bitmax = 0;
67 .f. i+1, 1, bitmax = 1;
68 do i = 1 to maxtoklen-3;
69 tokptr = tokptr+1; tok(tokptr) = c; giveqnk(c);
70 if c = 1r' then $ if end of constant.
71 tokptr=tokptr+1; tok(tokptr)=c; go to endc2;
dsq 147 $ gen requires blanks within constants
dsq 148 elseif isblank(c) then c = 1r ;
dsq 149 $ here to check for valid code.
dsq 150 elseif brkc('0123456789abcdef', 1, c) < 0
dsq 151 ! brkc('0123456789abcdef', 1, c)>=bitmax then
dso 26 call ermsg(32,c,0);
75 c = 1r0;
76 end if;
77 end do;
dso 27 call ermsg(33, 0, 0);
79 elseif c = 1r. then go to periodafterint;
80 elseif c = 1re then $ insert e, go get exponent.
81 charin(1re); givec(c); go to getexpval;
82 elseif alphabetic(c) then quit while;
83 else go to endc;
84 end if;
85 end while;
86
87 if alphabetic(c) then
88 if (tokptr>5) go to endc;
89 if (blankinsidenumeric) go to endc;
90 if c = 1rn then nultyp = nametok;
91 elseif c = 1rq then nultyp = stringtok;
92 elseif c = 1rr then nultyp = rztok;
93 elseif c = 1rs then nultyp = sstok;
94 else go to endc; end if;
95
96 len = 0;
97 do i = 1 to tokptr; len = len*10 + digofchar(tok(i)); end do;
98 tokptr = 0; $ reset token pointer
99 $ see if next char after integer is string type char
100 $ in which case then collect and format string contents
101 if len = 0 then $ contents are delimited
102 givecstr(delimchar);
103 givecstr(c); $ first char in contents
dsv 51 .+mc if (nultyp=sstok ! nultyp=nametok) c = ctpc(c);
dsq 153 while c ^= delimchar;
dsq 154 charin(c);
dsq 155 givecstr(c);
dsv 52 .+mc if (nultyp=sstok ! nultyp=nametok) c = ctpc(c);
dsq 157 end while;
105 len = tokptr; $ save length of delimited string
106 else $ length known, accumulate contents
dsq 158 do i = 1 to len;
dsq 159 givecstr(c);
dsv 53 .+mc if (nultyp=sstok ! nultyp=nametok) c = ctpc(c);
dsq 161 charin(c);
dsq 162 end do;
108 end if;
109 go to endc2; $ current character absorbed
110 else go to endc; end if;
111
112 elseif c = 1r$ then
113
114 call givecr(c); $ read next card
dsw 16 .+mc c = ctpc(c); $ convert to primary case.
115 .+tallycomments tally(tallyeol) $ count eol comments
116 go to newchar;
117
118 elseif c = 1r/ then
119
120 $ we have seen /. if * follows, then collect comment; otherwise
121 $ token is /. we monitor inside of comment for unexpected / * .
122 givec(c);
123 $ reach here after seeing slash asterisk, so check
124 $ for corresponding asterisk slash closure
125 if c ^= 1r* then $ not pl1 comment, end token
126 .+ht. $ if hash trace on, hash in normally to get trace.
127 if hashtrace then
128 charin(1r/); nultyp = spectok; go to endc;
129 end if;
130 ..ht
131 iwd = ihsl; $ token is slash.
132 keepc(c); $ save character after slash.
133 return;
134 end if;
135 $ now absorb pl1 style comment
136 .+tallycomments tally(tallypl1) $ count pl/1 comments
137 while 1; $ collect comment body.
138 givec(c); $ loop while asterisk seen
139 if c=1r/ then $ if / * inside comment, treat as error.
140 givec(c);
dso 28 $ error if see / * inside comment.
dso 29 if (c=1r*) call ermsg(27, 0, 0);
142 end if;
143 if (c ^= 1r*) cont while; $ continue if not -*-
144 givec(c); $ now see if / after *
145 while c=1r*; givec(c); end while; $ look for run of *'s.
146 if (c=1r/) quit while;
147 end while;
148 go to scanon;
149
150 elseif c = 1r' then
151
152 nultyp = stringtok;
153 $ here we collect quoted string, using givecstr to get character
154 $ since inside string
155 while tokptr <= maxtoklen-2; $ at most lnqtmax chars in strin
156 givecstr(c);
157 if (c=1r') then
158 givecstr(c); $ get char after quote
dsq 163 if c ^= 1r' then $ if end of string.
dsv 54 .+mc c = ctpc(c); $ fold following character.
dsq 165 go to endc;
dsq 166 end if;
160 end if;
161 tokptr = tokptr+1; tok(tokptr) = c; $ add to token.
162 end while;
dso 30 call ermsg(18,maxtoklen, 0); go to endc;
164
165 elseif c = 1r. then
166
167 charin(c); $ dot begins token.
168 givec(c);
169 if numeric(c) then go to real3; $ if real constant.
170 elseif alphabetic(c) = no then $ if not start of op.
171 nultyp = spectok; go to endc; $ is special token.
172 end if;
173
174 nultyp = optok;
175 charin(c); givec(c);
176 while alphabetic(c); charin(c); givec(c); end while;
177 if c=1r. then charin(c); else go to endc2; end if;
178 $ end of period-delimited token. check for special operator
179 $ type tokens which have special meaning to scanner
180 $ tokens and actions are
181
182 $ .chtr. trace each character received from -givec-
183 $ .nochtr. end character trace
184 $ .hatr. enable trace of hash routine
185 $ .nohatr. end hash trace
186 $ .lextr. trace tokens sent to parser ,ie from nextw)
187 $ .nolextr. end parser token ttace
188 $ .compdate. return string with compilation date.
189
190
191 $ .mactr. trace macro routines
192 $ .nomactr. disable trace of macro routines
193
194 $ any special tokens detected are absorbed here
195
196 if (tokptr <= 5) go to endc2; $ special at least six character
197 sdspack(tok, tokptr); $ pack into hashtok for hash
198 $ hash in token so can see if special
199 hashtyp = optok;
200 hashin(iwd);
201 do i = 1 to numbugtoks; $ search for special bug token
202 if (bugtoks(i) ^= iwd) cont do;
203 go to bt(i) in 1 to numbugtoks;
204 /bt(1)/ /bt(2)/
205 .+ct chartrace = (i=1);
206 go to scanon;
207
208 /bt(3)/ /bt(4)/
209 .+ht hashtrace = (i=3);
210 go to scanon;
211
212 /bt(5)/ /bt(6)/
213 lexdotrace = (i=5);
214 go to scanon;
215
216 /bt(7)/ /bt(8)/
217 .+mt mactrace = (i=7);
218 go to scanon;
219
220 /bt(9)/ iwd = ihcompdate; return; $ pass on date.
221 end do;
222
223 $ since not special, pass on to parser.
224 return; $ no need to hash again
225
226 else $ if special token.
227 charin(c);
228 nultyp = spectok;
229 go to endc2;
230 end if;
231
232 /periodafterint/
233 $ we have seen '123.' - may have real, or integer followed by dot-op
234 givec(c);
235 if numeric(c) then $ if next char numeric, must have real
236 charin(1r.); go to real3;
237
238 elseif alphabetic(c) & (c^=1re) then
239 $ if letter other than e follows ., have dot-op after int.
240 keepc(c); keepc(1r.);
241 go to endc2;
242
243 elseif c=1re then $ if have 123.e, may be real or operator
244 givec(c);
245 if numeric(c) ! c=1r+ ! c=1r- then $ definitely real
246 charin(1r.); charin(1re); go to getexpval;
247 else $ not exponent, so have integer then dot-op
248 keepc(c); keepc(1re); c = 1r.; go to endc;
249 end if;
250 else $ dot is not part of dot-op, so have simple real
251 charin(1r.); nultyp = realtok; go to endc;
252 end if;
253
254 /real3/
255 $ seen real, collect remaining numeric part, then exponent if pre
256 nultyp = realtok;
257 if numeric(c) then $ collect numbers, watch for internal blanks
258
259 while numeric(c);
260 charin(c); givec(c);
dsq 167 if isblank(c) then $ if blank, watch for run of blanks
dsq 168 while isblank(c); givec(c); end while;
263 if (numeric(c)=no) go to endc; $ at end of run
264 $ must see numeric to remain inside constant
265 end if;
266 end while;
267
268 end if;
269 if c=1re $ if exponent present, digest it.
270 then charin(c); givec(c);
271 else go to endc; end if;
272
273 /getexpval/
274 $ collect exponent value
275 nultyp = realtok;
276 if c=1r+ ! c=1r- then charin(c); givec(c); end if; $ absorb
277 $ sign field, if present.
278
279 if numeric(c) then $ absorb value, watching for internal blanks
280 while numeric(c);
281 charin(c); givec(c);
dsq 169 while isblank(c); givec(c); end while;
283 end while;
284 else $ missing exponent value, take 0
dso 31 call ermsg(26, 0, 0);
286 charin(1r0);
287 end if;
288 go to endc;
289
290 /endc/
291 keepc(c);
292 /endc2/
293 $ pack token into -hashtok-, set length, hash in.
294 sdspack(tok, tokptr); $ pack token into hashtok.
295 hashtyp = nultyp;
296 hashin(iwd); $ hash and set -iwd- to hash-index obtained
297
298 end subr trulex;
1 .=member givesp
2 subr givesp(ic); $ get char. inside string.
3 size ic(ps);
4
5 if keepindex then $ if prior token kept.
6 getfromkeep(ic);
7 elseif nowc > mccd then $ elseif new card needed.
8 call givecr(ic); $ read next card.
9 else
10 if nc10 = 1 then $ if need next word
11 nowdp = nowdp + 1;
12 nowd = iwds(nowdp); $ fetch next word.
13 nc10 = ws + 1;
14 end if;
15 nc10 = nc10 - cs; $ advance to next character position.
16 ic = .f. nc10, cs, nowd; $ extract character.
17 nowc = nowc + 1;
18 end if;
19 .+ct.
20 if chartrace then $ if tracing characters.
21 textl(' ct=<') charl(ic) textl('> ')
22 end if;
23 ..ct
24 return;
25 end subr givesp;
1 .=member givecp
2 subr givecp(c); $ get character
3 size c(cs);
dsv 55 .+mc size ctpc(cs); $ function to convert character to primary case.
4 givec_text(c);
5 return;
6 end subr givecp;
1 .=member givecr
2 subr givecr(ic); $ process card (list, output, ca, .. etc)
3 size ic(cs); $ returned character
4 size work(ps); $ work to do; see -normwork- in -start-
5 .+ca size col(ps); $ no. cols to clear (ca)
6 size i(ps), j(ps); $ do loop indexes
dsq 171 size anyc(ws); $ any string match function.
dsv 56 .+mc size ctpc(cs); $ function to convert to primary case character.
7
8 /reread/
9 work = normwork; $ set to normal options
10 if errecho then $ just want to list
11 work = list_work; $ just set list flag
12 go to l(list_work);
13 end if;
14
15 call getinc(iwds, 1, wpc, iorc); $ read next card
16 if iorc then $ end-of-file
17 exitcode = 0; call lexexit; $ exit at end of file
18 end if;
19
20 icdno = icdno+1; $ increment cards read counter
21
22 $ now check if this could overflow the -tokrlc- field.
23 if icdno-icdlast > 200 then $ could overflow.
24 if tokwrt then $ if writing token file.
25 $ must write out null card.
26 tokrwd = 0; tokrtyp tokrwd = tokrcard; $ set type.
27 tokrlc tokrwd = icdno-icdlast; $ insert value.
28 tokout1(tokrwd); $ write to token file.
29 end if;
30
31 icdlast = icdno; $ set new line number.
32 end if;
33
34 cardlisted = no; $ show card not listed yet
35 lastwd = 0; $ set unknown last word
36
37 $ now check for directive or conditional card
38 until yes; $ start 'maybe' loop
39 if (.f. ws+1-2*cs, cs, iwds(1) ^= 1r.) quit until;
40 if (alphabetic((.f. ws+1-4*cs,cs, iwds(1))) = no) quit until;
41 $ *********note********* above assumes at least 4 chars/word
42 if (.f. ws+1-1*cs, cs, iwds(1) ^= 1r ) quit until;
43 $ may now have card of interest - check column 3
44 col3char = .f. ws+1-3*cs, cs, iwds(1);
45 if col3char = 1r= & cardskip = no then $ may be directive
46 call lexdir(work); $ process if so
47 .+ca.
48 elseif iscachar(col3char) then $ may be ca
49 call lexca(work, col); $ process if so
50 ..ca
51 end if;
52 end until;
53
54 $ the variable -work- has been set to select the work that must
55 $ be done on the current card. the -go to- statement branches
56 $ to labels which select the order in which the work is
57 $ to be done.
58 while work; $ loop until no work to
59 work = work ! 1b'10000'; $ turn on extra bit.
60 go to l(work) in 17 to list_work!elim_work!out_work!proc_work;
61
62 /l(list_work!out_work!elim_work!proc_work)/
63 /l(list_work!out_work!elim_work )/
64 /l(list_work!out_work !proc_work)/
65 /l(list_work!out_work )/
66 /l(list_work !elim_work!proc_work)/
67 /l(list_work !elim_work )/
68 /l(list_work !proc_work)/
69 /l(list_work )/
70 work = work & ^list_work; $ clear list flag
71 if (cardlisted) cont while; $ dont list twice
72 cardlisted = yes; $ show will list card
73 if lastwd = 0 then $ determine last word to list
74 do lastwd = wpc to 2 by -1; $ get blanks off end
75 if (iwds(lastwd) ^= blankword) quit do;
76 end do;
77 end if;
dsq 173 intl(icdno) $ print line number.
dsq 174 $ print tab if available to retain correct tabular alignment.
dsq 175 if cc_tab ^= 1r then $ list tab if available.
dsq 176 charl(cc_tab)
dsq 177 else $ else list two blanks.
dsq 178 skipl(2)
dsq 179 end if;
79 call wordsr(iwds, 1, lastwd); $ list line.
80 endl $ end of line
81 cont while;
82
83 /l(elim_work!out_work!proc_work)/
84 /l(elim_work!out_work )/
85 .+ca if (.f. list_qualifiers, 1, listnow) go to l(out_work);
86
87 /l(elim_work!proc_work)/
88 /l(elim_work )/
89 .+ca.
90 work = work & ^elim_work; $ turn off flag
91 i = col/cpw; $ set no. words to clear
92 do j = 1 to i; $ clear each word
93 iwds(j) = blankword;
94 end do;
95 i = col - i*cpw; $ set no. remaining cols to clear
96 if (i) .f. ws+1-i*cs, i*cs, iwds(j) = blankword; $ clear
97 cont while;
98 ..ca
99
100 /l(out_work!proc_work)/
101 /l(out_work )/
102 work = work & ^out_work; $ reset flag.
103 if tokwrt then $ write to token file
104 $ if gen will not list cards, then it will only
105 $ need a card if there is an error detected. however,
106 $ there cannot be an error on a card without tokens.
107 $ therefore, if gen will not list cards, we should not
108 $ pass the card unless there are tokens on it. so set
109 $ a flag and have -lexdo- send the card.
110 if listingen = no then $ gen will not list.
111 cardsent = no; $ set flag to show not sent.
112 cont while; $ done with this bit of work.
113 end if;
114
115 if lastwd = 0 then $ must check for last word
116 do lastwd = wpc to 2 by -1; $ find last non-blank
117 if (iwds(lastwd) ^= blankword) quit do;;
118 end do;
119 end if;
120 tokrwd = 0; tokrlen tokrwd = cpw*lastwd; $ set length
121 tokrtyp tokrwd = tokrcard; $ code for card
122 tokrlc tokrwd = icdno-icdlast; $ set number of cards.
123 icdlast = icdno; $ reset last card number.
124 tokout(tokrwd, iwds, 1); $ output card image
125 cardsent = yes; $ show card sent to gen.
126 end if;
127 cont while;
128
129 /l(proc_work)/
130 $ now, set to read first char on card
131 nowdp = 1; $ point to first word of card
132 nc10 = ws-cs+1; $ point to next char position
133 nowd = iwds(1); $ first word of card
134 ic = .f. ws-cs+1, cs, nowd; $ get first char
135 nowc = 2; $ next char will be col 2
136 return;
137
138 end while;
139
140 $ done with all work. we now either read another card or,
141 $ if -errecho- is set, return.
142 if (errecho = no) go to reread;
143 errecho = no; $ reset flag
144
145 end subr givecr;
1 .=member lexca
2 subr lexca(work, col); $ process conditional card
3 $ this routine processes the conditional qualifiers that may
4 $ appear on cards. it is responsible for setting -normwork-
5 $ and -cardskip- when a skip is to be done or ends.
6 size work(ps); $ work to be done on card
7 size col(ps); $ output - no. of cols to clear
8 size i(ps); $ do loop index
9 size c(cs); $ character from card
dsq 180 size anyc(ws); $ any string match function.
dsv 57 .+mc size ctpc(cs); $ function to map character to primary case.
10
11 +* getc(ic) = $ macro to get next character from card
12 if nowc > mccd then $ at end of card
13 ic = 1r$; $ pass non-alpha and non-blank
14 else
15 if nc10 = 1 then $ new word needed
16 nowdp = nowdp+1; nowd = iwds(nowdp);
17 nc10 = ws+1; $ reset to start of word
18 end if;
19 nc10 = nc10-cs; $ advance to next character
dsv 58 .+mc ic = ctpc((.f. nc10, cs, nowd));
dsv 59 .-mc ic = .f. nc10, cs, nowd;
dsq 184 nowc = nowc+1;
21 end if;
22 **
23
24 nowc = 4; $ next char is fourth
25 nowdp = 1; $ set to word 1 **** assumes cpw >= 4****
26 nowd = iwds(1); $ get proper word
27 nc10 = ws+1+cs-4*cs; $ set to place to get next char.
28
29 if cardskip then $ must find matching name.
30 do i = 1 to canamel; $ compare each character
31 getc(c); if (c ^= caname(i)) return; $ ignore card if not
32 end do;
33 $ name matches, ensure next character is not part of name.
34 getc(c); if (alphameric(c)) return; $ not matching if so
35 else $ get ca name
dsy 12 getc(c);
dsy 13 if alphabetic(c)=no then $ if first not alphabetic
dsy 14 call ermsg(6,0,0); $ report error.
dsy 15 return;
dsy 16 end if;
dsy 17 caname(1) = c;
dsy 18 do canamel = 2 to mccd; $ collect name - loop will be -quit-
37 getc(c); $ get a character
38 if (alphameric(c) = no) quit do; $ stop at non-alpha
39 caname(canamel) = c; $ insert character
40 end do;
41 canamel = canamel-1; $ reset because last character not in str
42 end if;
43
44 $ we now have conditional name to process. hash in and
45 $ determine new status.
46 sdspack(caname, canamel); $ pack into -hashtok-
47 hashtyp = nametok; hashin(hashca); $ hash in
48
49 if col3char ^= 1r. & hashca = hashcaset then $ this is 'set'
50 while c ^= 1r$; $ loop until end of input
dsy 19 until alphabetic(c) ! c = 1r$; $ skip blanks
52 getc(c); $ get next character
53 end until;
54 canamel = 0; $ reset name length
55 while alphameric(c); $ process name
56 canamel = canamel+1; caname(canamel) = c; $ set char.
57 getc(c); $ get next character
58 end while;
59 if canamel then $ name present
60 sdspack(caname, canamel); $ pack ino -hashtok-
61 hashtyp = nametok; hashin(hashca);
62 cab ha(hashca) = (col3char = 1r+); $ set value
63 end if;
64 end while;
65 work = work & ^proc_work; $ dont scan for tokens
66 if (.f. list_qualifiers, 1, listnow = no) $ dont send to -gen
67 work = work & ^out_work; $ dont write to token file
68 return; $ done in this case
69 end if;
70
71 $ we now have a 'normal' conditional card. see if we should
72 $ skip this card and whether -cardskip- should be set.
73 if col3char = 1r. then $ this always ends skip
74 cardskip = no; $ set no skip
75 else $ test -cab- agreement
76 cardskip = ((col3char = 1r+) ^= cab ha(hashca));
77 work = work ! (out_work!proc_work); $ set default values
78 if cardskip then $ this card will be skiped
79 work = work & ^proc_work; $ -lex- wont process
80 if (.f. list_skip, 1, listnow = no) $ dont give to -gen-
81 work = work & ^out_work; $ dont write to token file
82 cardskip = (c = 1r.); $ only skip if next char is '.'.
83 end if;
84 end if;
85
86 $ finally, set final status according to -cardskip-.
87 if (work & ^list_work) work = work ! elim_work; $ elim if needed
88 col = nowc-1; $ set elimination boundary
89 normwork = normwork ! (out_work!proc_work); $ set to process.
90 if cardskip then $ dont process until further notice.
91 normwork = normwork & ^proc_work; $ dont process
92 if (.f. list_skip, 1, listnow = no) $ dont list in -gen-
93 normwork = normwork & ^out_work; $ dont write to token
94 end if;
95
96
97 macdrop(getc)
98 end subr lexca;
1 .=member lexdir
2 subr lexdir(work); $ parse input directive
3 $ process .=eject .=list .=punch .=title
4
5 $ line is sds form of current line. lorg is macro giving
6 $ string origin.
7 +* lorg = (1 + .sds.(cpw*wpc)) **
8 +* linech(i) = .f. lorg -(i)*cs, cs, line** $ ith character of l
9 $ ara holds words to be written on token file.
10 $ ara will contain several list entries, eject entry or
11 $ title entry.
12 size ara(ws); dims ara(wpc+2);
13 size araptr(ps); $ top of ara list.
14 size c(cs); $ character.
15 size i(ps), j(ps), l(ps); $ counters.
16 size work(ps); $ work value for card
17 size key(.sds.10);
18 size keycode(ps); $ position in directive code list.
19 size line(lorg-1); $ input line as string.
20 size lpos(ps); $ start of parameter list.
21 size parmvalue(1); $ set if parm present.
22 size pgiven(ps); $ bit i set if ith code present.
23 size pl(ps);
24 size prm(.sds. 6); $ parameter from list.
25 size pvalue(ps); $ bit i set if ith code set.
26 $ parmstr gives list of directive codes.
27 size parmstr(.sds. (5 +7*numlistparms));
28 size prmcopy(.sds. 6); $ copy of parm if 'no' given.
29 size resuming(1); $ on when resuming previous list status.
30 size tokrwd(ws); $ word for token file.
31 size lexlist(1); $ on to list card in -lex-
32 size genlist(1); $ on to list card in -gen-
33 size listdir(1); $ value of 'dir' parm
dsq 185 size anyc(ws); $ any string match function.
dsv 60 .+mc size ctpc(cs); $ function to convert character to primary case.
dsq 187 size brkc(ws); $ break string match function.
34
35 l = 0;
36 sorg line = lorg;
37 do i = 1 to wpc;
38 .f. lorg - i*ws, ws, line = iwds(i);
39 end do i;
40 sorg line = lorg;
41 slen line = mccd + 1;
42 linech(mccd+1) = 1r ;
43 lpos = 3;
dsq 188 until isblank(linech(lpos));
45 lpos = lpos + 1;
46 end until;
47 key = .s. 1, 10, line;
48 if (lpos<10) slen key = lpos;
49 parmstr = ' 1 .=eject 2 .=list 3 .=punch 4 .=title '
50 !! ' 5 .=zzyorg 6 .=member ';
dsv 61 .+mc call stpc(key); $ convert to primary case.
51 keycode = key .in. parmstr;
52 if (keycode) keycode = digofchar((.ch. keycode-1, parmstr));
53 if (keycode = 0) return;
54 $ set lpos to index start of parameter string.
dsq 190 while isblank(linech(lpos));
56 lpos = lpos + 1;
57 if (lpos>mccd) quit while;
58 end while;
59 if (lpos>=mccd) lpos = 0;
60
61 slen parmstr = 0;
62 if(keycode=2) parmstr = ' cod=01 inp=02 aut=03 ski=04 qua=05'
63 .cc. ' lin=06 ref=07 res=10 dir=11 ';
64 if(keycode=3) parmstr = ' def=08 exp=09 dir=11 ';
65 if (slen parmstr = 0 ! lpos = 0) go to endparmlist;
66 prm = 6q------; $ set - so will not find in parm code list.
67 pgiven = 0; pvalue = 0;
68 pl = 0;
69 while 1; $ process listed values until blank seen.
70 c = linech(lpos);
71 if alphameric(c) then
72 if pl < 5 then
73 pl = pl + 1; .ch. pl, prm = c;
74 end if;
75 else $ nonalphabetic character ends parameter.
76 slen prm = pl;
77 if ('no' .in. prm) = 1 then $ if disabling, remove 'no'
78 prmcopy = prm;
79 prm = 6q------;
80 do i = 1 to pl-2;
81 .ch. i, prm = .ch. i+2, prmcopy;
82 end do;
83 slen prm = pl-2;
84 parmvalue = 0; $ disable option.
85 else $ else enable option.
86 parmvalue = 1;
87 end if;
88 slen prm = 4;
89 .ch. 4, prm = 1r=; $ use '=' to anchor place in lookup
dsv 62 .+mc call stpc(prm); $ convert to primary case.
90 i = prm .in. parmstr; $ see if valid option.
91 if i then $ if option valid, extract code.
92 i = digofchar((.ch. i+4, parmstr))*10+
93 digofchar((.ch. i+5, parmstr));
94 .f. i, 1, pgiven = yes; $ indicate option present.
95 .f. i, 1, pvalue = parmvalue; $ set option.
96 end if;
97 pl = 0; prm = 6q------;
98 end if;
99
100 lpos = lpos+1;
dsq 192 if (isblank(c)) quit while;
102 end while;
103 /endparmlist/
104 araptr = 0; $ reset tok ara top.
105 lexlist = no; genlist = no; $ default is not to list cards
106 go to l(keycode) in 1 to 6;
107 /l(6)/ $ skip member definition line.
108 go to retara;
109 /l(1)/ $ process eject.
110 l = 0;
111 if lpos then
112 c = 1r0; lpos = lpos-1;
113 while numeric(c); $ collect count.
114 l = l*10 + digofchar(c);
115 lpos = lpos + 1; if (lpos>mccd) quit while;
116 c = .ch. lpos, prm;
117 end while;
118 end if;
119
120 if (listinginput) ejectlp(l);
121 tokrwd = 0; tokrtyp tokrwd = listejecttok;
122 tokrlen tokrwd = l;
123 araptr = 1; ara(1) = tokrwd;
124 go to retara;
125 /l(3)/ $ process punch.
126 if (listignore) go to retara; $ if should ignore, done
127 lexlist = yes; genlist = yes; $ we list punch cards
128 listdir = .f. list_directive, 1, pvalue; $ set directive list valu
129 if .f. list_definitions, 1, pgiven then $ change value
130 punchdefine = .f. list_definitions, 1, pvalue;
131 end if;
132 if .f. list_expansions, 1, pgiven then
133 punchexpand = .f. list_expansions, 1, pvalue;
134 end if;
135 go to dircheck; $ check for dir/nodir
136 /l(2)/ $ process list.
137 if (listignore) go to retara; $ do nothing if ignoring
138 resuming = .f. list_resume, 1, pvalue; $ get resume flag
139 listdir = .f. list_directive, 1, pvalue; $ get directive list flag
140 .f. list_resume, 1, pvalue = no; $ clear these
141 .f. list_directive, 1, pvalue = no;
142 if resuming then $ if resume, pop listing stack
143 listnew = listprev(listprevptr);
dst 15 listprevptr = listprevptr - (listprevptr>1);
145 else
146 listnew = (listnow & ^pgiven) ! pvalue; $ set new list value
147 end if;
148
149 if listnew ^= listnow then $ if change.
150 do i = 1 to numlistparms;
151 j = .f. i, 1, listnew;
152 l = .f. i, 1, listnow;
153 if j ^= l then
154 lexlist = lexlist ! listval_ll listvals(i);
155 genlist = genlist ! listval_gl listvals(i);
156 if listval_tf listvals(i) & tokwrt then
157 tokrwd = 0;
158 tokrtyp tokrwd = listcontroltok;
159 tokrlen tokrwd = i;
160 tokrlc tokrwd = j;
161 araptr = araptr + 1; ara(araptr) = tokrwd;
162 end if;
163 end if;
164 end do;
165 end if;
166
167 if resuming = no then $ if not resume, save list word.
168 if listprevptr = listprevmax then
169 do i = 3 to listprevmax;
170 listprev(i-1) = listprev(i); end do;
171 else
172 listprevptr = listprevptr + 1;
173 end if;
174 listprev(listprevptr) = listnow;
175 end if;
176 listnow = listnew; $ set current value
177
178 /dircheck/ $ check for dir/nodir override
179 if .f. list_directive, 1, pgiven then $ present
180 lexlist = listdir; genlist = listdir;
181 end if;
182
183 go to retara;
184 /l(4)/ $ process title.
185 l = 0; $ title length.
186 if (lpos=0) go to dotitle; $ avoid null title.
187 $ check that first char is quote.
188 c = linech(lpos);
189 if (c^=1r') go to retara;
190 while 1;
191 lpos = lpos + 1; if (lpos>=(mccd-1)) quit while;
192 c = linech(lpos);
193 if c = 1r' then $ if quote, see if interior or terminator.
194 if linech(lpos+1) = 1r' then $ if interior quote,
195 lpos = lpos + 1; $ skip so add one quote to title.
196 else $ if terminator, end title.
197 quit while;
198 end if;
199 end if;
200 l = l + 1; linech(l) = c;
201 end while;
202 /dotitle/
203 $ convert null title to single blank to simplify read in gen.
204 $ avoid null title to simplify gen processing.
205 $ if first char of line could not be blank, would have to reset
206 l = l + (l=0);
207 slen line = l;
208 if (listinginput) call stitlr(subtitling, line);
209 if subtitling & listinginput then $ if subtitle, eject if listi
210 ejectl;
211 end if;
212 subtitling = 1;
213 tokrwd = 0;
214 tokrtyp tokrwd = listtitletok;
215 tokrlen tokrwd = l;
216 ara(1) = tokrwd; araptr = 1;
217 l = (l-1)/cpw + 1; $ convert length to word count.
218 do i = 1 to l;
219 ara(araptr+i) = .f. lorg - i*ws, ws, line;
220 end do;
221 araptr = araptr + l;
222 go to retara;
223 /l(5)/ $ process 'zzyorg' setl library directive.
224 if (lpos=0) go to retara; $ if no parameter.
225 genlist = yes; lexlist = yes; $ list this card.
226 while lpos <= mccd;
227 c = .ch. lpos, line;
dsw 17 .+mc c = ctpc(c); $ convert to primary case.
228 if alphabetic(c) then countzzy(lettercode(c)) = 0;
229 else quit while; end if;
230 lpos = lpos + 1;
231 end while;
232 go to retara;
233 /retara/ $ write entries in ara to token file.
234 do i = 1 to araptr;
235 tokout1(ara(i));
236 end do;
237 work = work & ^proc_work; $ we dont have -lex- process this card
238 work = work ! (list_work*listinginput); $ set if list is now set
239 if (lexlist = no) work = work & ^list_work;
240 if (genlist = no) work = work & ^out_work;
241 normwork = (normwork & ^list_work) ! (list_work*listinginput);
242
243 +* lorg = ** $ drop lorg macro.
244 end subr lexdir;
1 .=member hash
2 subr hash; $ adds token to scanner symbol table
3
4 $ the routine -hash- adds a token to the symbol table (ha).
5 $ we then compute hash-code for token and see if it has already
6 $ been entered in the symbol table. if not, a new entry in the tabl
7 $ table is build, and the symbolic name stored in the -names- ar
8 $ array.
9 $ hash performs the additional function of posting
10 $ references to symbols if the cross-reference option has
11 $ been raised. in this case, references to names are collected.
12
13
14 size hashcode(ws); $ hash-code computed
15 size i(ps); $ do-loop index
16 size hashtokara(ws); dims hashtokara(1+maxtoklen/cpw); $
17 size haent(hasz); $ ha(haptr)
18 size l(ps);
19 size rem(ps); $ characters remaining in last word.
20
21 .+tallyhash tally(tally_haprobes) $ count ha searches
22 hashlen = slen hashtok; $ get length in characters
23 if (hashlen>maxtoklen) hashlen = maxtoklen;
24 .+ht.
25 if hashtrace then
26 tintl('hatrace len',hashlen) tintl('type',hashtyp)
27 textl('symbol = ') textl(hashtok)
28 end if;
29 ..ht
30 hashwords = (hashlen-1) / cpw; $ number of extra words in item
31 if (hashlen=0) hashwords = 0;
32 $ blank fill last word in hashtok if necessary
33 rem = cpw - (hashlen - hashwords*cpw); $ no. of trailing chracter
34 if rem then $ if need blank fill.
35 .f. hashtokorg -(hashwords+1)*ws, rem*cs, hashtok
36 = blankword;
37 end if;
38 $ now copy words from sds-input hashtok into array of words.
39 $ compute hash-code as exclusive-or of all input words, followed
40 $ by exclusive-or of left and right halves, an
41 $ take remainder modulo hash-table length.
42 hashcode = .f. hashtokorg - ws, ws, hashtok;
43 hashtokara(1) = .f. hashtokorg - ws, ws, hashtok; $ word 1
44 do i = 1 to hashwords;
45 hashtokara(i+1) = .f. hashtokorg - (i+1)*ws, ws, hashtok;
46 hashcode = hashcode .ex. .f. hashtokorg-(i+1)*ws, ws, hashtok;
47 end do;
48
49 hashcode = .f. 1, ws/2, hashcode .exor. .f. ws/2+1,ws/2,hashcode;
50 haptr = mod(hashcode, haprime) + 1;
51 $ examine table until find matching or unused entry
52
53 /probe/
54 .+tallyhash tally(tally_haentries) $ count entries seen
55 if (lexlen ha(haptr) ^= hashlen ! lextyp ha(haptr) ^= hashtyp)
56 go to nomatch;
57 if (names(nameptr ha(haptr)) ^= hashtokara(1)) go to nomatch;
58
59 if hashwords then $ if something to check.
60 l = nameptr ha(haptr) - 1; $ set starting name pointer - 1.
61 do i = 2 to hashwords+1; $ check the extra words.
62 if (names(l+i) ^= hashtokara(i)) go to nomatch;
63 end do;
64 end if;
65 go to found;
66
67 /nomatch/
68 if halink ha(haptr) then $ if more in chain.
69 haptr = halink ha(haptr);
70 go to probe;
71 end if;
72
73 if (lextyp ha(haptr) = 0) go to addnew; $ this is free.
74
75 do hafree = hafree-1 to 1 by -1; $ scan down from top.
76 if lextyp ha(hafree) = 0 then $ found free entry.
77 halink ha(haptr) = hafree; $ link this one in.
78 .+tallyhash tally(tally_halinks) $ count the link.
79 haptr = hafree; go to addnew; $ go build entry.
80 end if;
81 end do;
82
dso 32 call ermsg(20, 0, 0); call lexexit; $ ha is full.
84
85 /addnew/
86 haused = haused + 1; $ increment entries used count.
87 haent = 0; $ set ha entry to zero.
88 lexlen haent = hashlen; $ set length.
89 lextyp haent = hashtyp; $ set lexical type.
90 nameptr haent = namesptr; $ set pointer to -names-.
91 ha(haptr) = haent; $ set entry into table.
92 namesptr = namesptr + hashwords; $ set to new position - 1;
93 countup(namesptr, namesmax, 'names');
94 do i = 1 to hashwords+1; $ move in all words.
95 names(namesptr+i-hashwords-2) = hashtokara(i); $ move a word.
96 end do;
97
98 /found/
99 .+ht.
100 if (hashtrace=yes) then
101 tintl('hash code', haptr) endl
102 end if;
103 ..ht
104 $ if just hashed name, update useage count, for subsequent use by
105 $ detect.
106 if (hashtyp ^= nametok) return; $ done if not name.
107 if litcod ha(haptr) = 0 then $ have something more to do.
108 if (nuses ha(haptr) < suspi)
109 nuses ha(haptr) = nuses ha(haptr) + 1; $ count uses.
110 .+cr. $ cross reference.
111 if (isonxrf=no) return;
112 if (collectingrefs = no) return;
113 if (initializing) return; $ dont write ref for init.
114 creftot = creftot + 1;
115 crefent = 0;
116 cref_ha crefent = haptr;
117 cref_line crefent = icdno; $ set line number.
118 cref_macro crefent = (macorg ha(haptr) ^= 0); $ macro state
119 crefput(crefent);
120 ..cr
121 end if;
122
123 end subr hash;
124 subr fivdec(n); $ integer to sds converter
1 .=member fivdec
2 size i(ps); $ do-loop index
3 size j(ps); $ remaining value to convert
4 size n(ps);
5
6 j = n;
7 do i = 5 to 1 by -1;
8 fivdecara(i) = charofdig(mod(j, 10));
9 j = j/10;
10 end do;
11
12 end subr fivdec;
1 .=member ibigr
2 fnct ibigr(jarg, karg); $ compare two symbols.
3 size jarg(ps), karg(ps); $ ha indices of symbols.
4 size ibigr(1);
5 size jsym(sdstl), ksym(sdstl); $ symbol strings to compare
6 size jlen(ps), klen(ps); size minlen(ps);
7 size jch(cs), kch(cs); $ characters.
8 size i(ps); $ loop index.
9
10 jch = .f. ws+1-cs, cs, names(nameptr ha(jarg));
11 kch = .f. ws+1-cs, cs, names(nameptr ha(karg));
12 if jch ^= kch then $ if initial characters differ,
13 ibigr = (jch > kch); $ compare to get result.
14 return;
15 end if;
16
17 $ must examine rest of symbols, retrieve as sds and compare.
18 getsym(jsym, jarg); getsym(ksym, karg);
19 jlen = slen jsym; klen = slen ksym;
20 minlen = jlen; if (klen < minlen) then minlen = klen; end if;
21 ibigr=1; $ assume j bigger
22 do i = 1 to minlen;
23 jch = .ch. i, jsym; kch = .ch. i, ksym;
24 if jch ^= kch then
25 ibigr = (jch > kch);
26 return;
27 end if;
28 end do;
29
30 ibigr = (jlen > klen); $
31
32 end fnct ibigr;
1 .=member detect
2 subr detect; $ finds and lists suspicious variables
3 $ detect lists 'suspicious' names, i.e., names which
4 $ have been used less than 'suspi' times in the program.
5 size i(ps); $ do-loop index
6 size ksym(sdstl); $ string for name.
7 size lines(ps); $ number of lines for list.
8 size m(ps); $loop index.
9 size hapack(ps); $ size of packed ha.
10 size top(ps); $ loop indices
11 size targ(ps);
12 size temp(hasz); $ temporary for swapping
13 size ibigr(1); $ function to compare symbols.
14
15 hapack = 0;
16 if (dodetect=no) return; $ check is sus vars list off
17 do i = 1 to hadim;
18 if (nameptr ha(i) = 0) cont do;
19 if ((litcod ha(i))
20 !(nuses ha(i) >= suspi)
21 !(nuses ha(i) = 0)
22 !(lextyp ha(i) ^= nametok)) cont do;
23 hapack = hapack + 1; ha(hapack) = ha(i);
24 end do;
25
26 $ if no suspicious names, return
27 if (hapack = 0) return; $ if no suspicious names.
28
29 +* swap(a,b) = $ macro for swapping, common sort operation
30 temp = ha(a); ha(a) = ha(b); ha(b) = temp; **
31
32 do i = 2 to hapack; $ make into heap, i is parent.
33 m = i;
34 while m>1; $ examine parents in turn
35 if ibigr(m/2, m) quit while; $ if parent no smaller,
36 swap(m,m/2); $ promote large child
37 m = m/2;
38 end while;
39 end do i;
40
41 do top = hapack to 2 by -1; $ sort subtrees in turn
42 swap(1,top); $ extract largest element
43 m = 1; $$ force remaining subtree to be heap
44 while m*2 < top;
45 if ibigr(m*2+1, m*2) & (m*2+1 < top)
46 then targ = m*2+1;
47 else targ = m*2; end if;
48 if ibigr(targ,m) then
49 swap(m, targ); $ child too big, so exchange
50 else quit while; end if;
51 m = targ; $ move to subtree of largest child
52 end while m;
53 end do top;
54
55 macdrop(swap)
56 textl(' ') endl $ blank line
57 textl(' * * * suspicious names used ')
58 if suspi = 2 then $ print shorter message.
59 textl('only once:')
60 else $ print long message.
61 textl('less than') intl(suspi) textl(' times:')
62 end if;
63 endl
64 lines = (hapack+5)/6; $ number of lines.
65 do m = 1 to lines;
66 i = m;
67 while i <= hapack;
68 getsym(ksym, i);
69 textl(ksym); $ print symbol
70 skipl(21-slen ksym)
71 i = i + lines;
72 end while;
73 endl
74 end do;
75 endl $ flushing last few names
76
77 end subr detect;
1 .=member pflshr
2 subr pflshr(wd); $ lexical punch routine.
3 size wd(ws); $ ha index of token to punch.
4 size i(ps), j(ps); $ temporaries and counters.
5
6 +* puncha(c) = $ macro to punch a character.
7 punchpos = punchpos+1; $ advance column pointer.
8 if (punchpos > mccd) call pncr; $ flush card if too long.
9 punchbuf(punchpos) = c; $ insert character.
10 **
11
12 $ first, open the punch file if not previously opened.
13 if punchopened = no then $ must open punch file.
14 call opensio(punchfile, iorc, access_put, punchfilename, 80,j,
15 0, 0); $ open the punch file.
16 punchopened = yes; $ show file is opened.
17 punhold1 = 0; punhold2 = 0; punlastlt = 0;
18 do i = 1 to 80; punchbuf(i) = 1r ; end do; $ clear buffer.
19 punchpos = 6; $ start punching at column 7.
20 end if;
21
22 $ now see if this is an end-of-job call.
23 if wd < 0 then $ this is end-of-job call.
24 $ see if anything is in our 'hold' buffers. if so, flush th
25 if punhold1 = ihpl then $ flush this.
26 puncha(1r+)
27 elseif punhold1 = ihst then
28 puncha(1r*)
29 elseif punhold1 = ihsl then
30 puncha(1r/)
31 if punhold2 then $ second token held.
32 if punchpos+lexlen ha(punhold2) > 70 then
33 call pncr; punchpos = 10;
34 end if;
35
36 do i = 1 to lexlen ha(punhold2); $ punch symbol.
37 puncha(isymc(punhold2, i))
38 end do;
39 end if;
40 end if;
41
42 call pncr; $ flush card.
43 call clossio(punchfile, iorc); $ close punch file.
44 return; $ done in end case.
45 end if;
46
47
48 $ this is the normal case where we have a symbol to punch.
49 $ first see if this will cause a special case.
50 if punhold1 = ihpl then $ last was +.
51 if wd = ihst then $ makes this +*
52 call pncr; $ this starts new card.
53 punchpos = 6; $ start at column 7.
54 puncha(1r+) puncha(1r*) puncha(1r ) puncha(1r )
55 punhold1 = 0; punlastlt = 0; $ reset.
56 return; $ done with this case.
57 end if;
58
59 $ we are here if we have a + that if not followed by
60 $ a *. in this case we must flush the +.
61 puncha(1r+) punhold1 = 0; punlastlt= 0;
62
63 elseif punhold1 = ihst then $ last token was *.
64 if wd = ihst then $ this was **.
65 if (punchpos < 9) punchpos = 9; $ move to offset.
66 puncha(1r ) puncha(1r*) puncha(1r*)
67 call pncr; punchpos = 6; $ this ends card.
68 punhold1 = 0; punlastlt = 0; $ reset.
69 return; $ done in this case.
70 end if;
71
72 $ we are here if we have a * that is not followed by
73 $ another *. in this case we must flush the *.
74 puncha(1r*) punhold1 = 0; punlastlt = 0;
75
76 elseif punhold1 = ihsl then $ last token was /.
77 if punhold2 then $ there was a name held also.
78 if wd = ihsl then $ this was label definition.
79 call pncr; $ start new card.
80 punchpos = 0; $ reset position.
81 puncha(1r ) puncha(1r/)
82 do i = 1 to lexlen ha(punhold2); $ output name.
83 puncha(isymc(punhold2, i))
84 end do;
85
86 puncha(1r/)
87 call pncr; $ this is alone on a card.
88 punchpos = 0; $ reset position.
89 punhold1 = 0; punhold2 = 0; punlastlt = 0;
90 return; $ done in this case.
91 end if;
92
93 $ in this case we have /name and no /.
94 puncha(1r/) $ punch out the /.
95 if lexlen ha(punhold2)+punchpos > 70 then
96 call pncr; punchpos = 10;
97 end if;
98
99 do i = 1 to lexlen ha(punhold2); $ punch name.
100 puncha(isymc(punhold2, i))
101 end do;
102
103 punhold1 = 0; punhold2 = 0; punlastlt = nametok;
104
105 else $ this is / and nothing else held.
106 if lextyp ha(wd) = nametok then $ /name
107 punhold2 = wd; $ hold this token.
108 return; $ done in this case.
109 end if;
110
111 $ else we must flush the /.
112 puncha(1r/) punhold1 = 0; punlastlt = 0;
113 end if;
114 end if;
115
116
117 $ now see if this symbol should be held.
118 if wd = ihpl ! wd = ihst ! wd = ihsl then $ hold +*/.
119 punhold1 = wd; return; $ hold and return.
120 end if;
121
122 $ now we will punch symbol. first ensure it will fit on card.
123 if lexlen ha(wd)+punchpos > 70 then $ will not fit.
124 call pncr; punchpos = 10; punlastlt = 0;
125 end if;
126
127 $ now if this token and last token were names or integers,
128 $ insert a blank.
129 if (punlastlt = nametok ! punlastlt = dectok) & (lextyp ha(wd) =
130 nametok ! lextyp ha(wd) = dectok) then
131 puncha(1r )
132 end if;
133
134 punlastlt = lextyp ha(wd); $ now set lexical type.
135
136 $ now actually punch token.
137 if punlastlt = rztok ! punlastlt = sstok then $ punch length.
138 call fivdec(lexlen ha(wd)); $ get length.
139 do i = 1 to 5; $ output length.
140 if fivdecara(i)^=1r0 then puncha(fivdecara(i)); end if;
141 end do;
142
143 if punlastlt = rztok then puncha(1rr) else puncha(1rs) end if;
144
145 elseif punlastlt = stringtok then $ this is string.
146 puncha(1r')
147 end if;
148
149 do i = 1 to lexlen ha(wd); $ output actual token.
150 puncha(isymc(wd, i)) $ punch a character.
151 if punlastlt = stringtok & isymc(wd, i) = 1r' then
152 puncha(1r') $ double the quotes.
153 end if;
154 end do;
155
156 if punlastlt = stringtok then puncha(1r') end if;
157
158 $ if this token is a semicolon or a 'then', flush this card
159 $ unless it is almost empty.
160 if wd = ihsemi ! litcod ha(wd) = 71 then
161 if punchpos > 35 then
162 call pncr; punchpos = 6; $ start a new card.
163 else $ a fairly empty card.
164 puncha(1r ) puncha(1r )
165 end if;
166
167 punlastlt = 0; $ no space needed next time.
168 end if;
169
170 macdrop(puncha)
171 end subr pflshr;
1 .=member pncr
2 subr pncr; $ actually punch the card.
3 size i(ps); $ temporary.
4
5 until yes; $ quit if must punch the card.
6 if (punchpos > 6) quit until;
7 do i = 1 to punchpos;
8 if (punchbuf(i) ^= 1r ) quit until;
9 end do;
10
11 return; $ else this would be a blank card.
12 end until;
13
14 call fivdec(icdno); $ convert card number.
15 punchbuf(75) = 1rp; $ set id flag.
16 do i = 1 to 5; punchbuf(75+i) = fivdecara(i); end do;
17 call putcsio(punchfile, iorc, punchbuf, 1, 0); $ punch card.
18 do i = 1 to 80; punchbuf(i) = 1r ; end do;
19 punchpos = 0; $ start at start of next card.
20
21 end subr pncr;
1 .=member ermsg
2 subr ermsg(ernum, par1, par2); $ error message printer
3 $ ermsg is called to list warning or error message.
4 $ ernum is error number, and par1 and par2 are optional
5 $ parameters whose meaning depends on ernum; typically
6 $ they are ha indices to tokens related to error.
7 $ a special call to givecr is made to list the current line
8 $ if it has not yet been listed, and ertlist is called to
9 $ list the last few tokens seen before the error.
10
11 +* ermsgmax = 33 ** $ max. number of error messages
12 size ermsgwarn(ermsgmax); $ flags warnings
13 data ermsgwarn = 1b'000 00010 00000 00000 00001 10000 00000';
dso 33 size ernum(10), par1(ws), par2(ws);
15 size dummyarg(ps); $ dummy argument for givecr
16
17 ejectlp(4); $ ensure whole message on one page
18
19 terml((.f. ernum, 1, ermsgwarn) = no)
20 errecho = yes; $ list current card if not yet listed
21 call givecr(dummyarg);
22 skipl(7+nowc) charl(1r$) endl
23
24 if .f. ernum, 1, ermsgwarn then $ if warning
dsq 193 .+s10 warn_s10; $ flag warning message for s10.
25 textl(warning_notice)
26 nwarnings = nwarnings + 1;
27 else
dsq 194 .+s10 error_s10; $ flag error message for s10.
28 textl(error_notice)
29 nerrors = nerrors +1;
30 end if;
31
32 go to e(ernum) in 1 to 33;
33 /e(1)/
34 textl('macro ''') tokl(par1)
35 textl(''' called with no arguments.') go to errtn;
36 /e(2)/
37 textl('macro ''') tokl(par1)
38 textl(''' called with too few arguments.') go to errtn;
39 /e(3)/
40 textl('macro ''') tokl(par1)
41 textl(''' called with too many arguments') go to errtn;
42 /e(4)/
43 textl('macro close occurs outside macro definition.') go to errtn;
44 /e(5)/
dsy 20 $ error 5 - illformed iset parameter
dsy 21 textl('illegal iset character ''')
dsy 22 charl(par1) charl(1r') go to errtn;
45 /e(6)/
dsy 23 $ error 6 - illformed name after .+set
dsy 24 textl('expect name after .+set ') go to errtn;
46 /e(7)/
47 go to notext;
48 /e(8)/
49 textl('illegal symbol ''') tokl(par1)
50 textl(''' follows macro opening.') go to errtn;
51 /e(9)/
52 textl('illegal symbol ''') tokl(par1)
53 textl(''' follows macro name ''') tokl(par2) textl('''.')
54 go to errtn;
55 /e(10)/
dsz 13 nwarnings = nwarnings - 1; $ do not include this in warning count.
56 textl('name ''') tokl(par1)
57 textl(''' with prior usage is being designated as a macro.')
58 endl return;
59 /e(11)/
60 textl('macro ''') tokl(par1)
61 textl(''' has been redefined.') endl return;
62 /e(12)/
63 textl('macro definition opened before required close. ')
64 textl('possibly missed earlier termination.') go to errtn;
65 /e(13)/
66 textl('macro ''') tokl(par1) textl(''' occurs within itself.')
67 go to errtn;
68 /e(14)/
69 go to notext;
70 /e(15)/
71 textl('no ''='' after argument list for macro ''') tokl(par1)
72 textl('''.') go to errtn;
73 /e(16)/
74 textl('parameter list for macro ''') tokl(par1)
75 textl(''' mispunctuated..') go to errtn;
76 /e(17)/
77 textl('illegal repetition of name ''') tokl(par1) textl(''' ')
78 textl('in argument for macro ''') tokl(par2) textl('''.')
79 go to errtn;
80 /e(18)/
81 textl('maximum length of') intl(par1)
82 textl(' characters in string exceeded.') go to errtn;
83 /e(19)/
84 textl('token longer than') intl(par1) textl(' characters.')
85 go to errtn;
86 /e(20)/
87 textl('hash table overflow.') go to errtn;
88 /e(21)/
89 textl('excessive macro nesting or recursion.') go to errtn;
90 /e(22)/
dsz 14 textl(' expect ** ending prior macro definition')
dsz 15 go to errtn;
91 /e(23)/
92 /e(24)/
93 /e(25)/
94 go to notext;
95 /e(26)/
96 textl('missing or illegal real exponent') go to errtn;
97 /e(27)/
98 textl('/* occurs inside /* ... */ comment') endl return;
99 /e(28)/
100 textl('excessively long macro argument list. probably missing ')
101 textl(''')'' in arguments to ''') tokl(par1) textl(''' at line ')
102 intl(par2) textl('.') go to errtn;
103 /e(29)/
104 /e(30)/
105 /e(31)/
106 go to notext;
107 /e(32)/
108 textl('illegal character''') charl(par1)
109 textl(''' in bit constant.'); go to errtn;
110 /e(33)/
111 textl('bit constant too long.'); go to errtn;
112 /notext/ $ error without identifying text.
113 textl('error number ') intl(ernum) endl
114 textl(' no text supplied, traceback follows.') endl
115 call ltlxtr;
116 /errtn/
117 call ertlist; $ list last few tokens
118 if ernum = 28 then $ special text for this error.
dsq 195 .+s10 warn_s10; $ flag warning message for s10.
119 textl(warning_notice) textl('compilation continuing but ')
120 textl('tokens from ''') tokl(par1) textl(''' at line ')
121 intl(par2) textl(' to last token listed have been skipped.')
122 endl
123 end if;
124
125 if nerrors>lelvalue then $ if error limit exceeded.
dsq 196 .+s10 error_s10; $ flag error message for s10.
126 textl('**** lexical error limit of') intl(lelvalue)
127 textl(' exceeded, scan aborted.') endl
128 terml(no); call lexexit;
129 end if;
130 terml(no); $ end of terminal file output
131
132 end subr ermsg;
1 .=member ertlist
2 subr ertlist; $ list tokens if error detected
3 size inp(ps);
4
5 inp = lsvtkp + 1; $ position of last 0 word put in lsvtk
6 endl skipl(15) textl('last few tokens: ')
7 while lsvtk(inp+1); $ loop until next zero found
8 tokl(lsvtk(inp+1)); charl(1r ); $ write out token
9 inp = (inp+1) & lsvtkz; $ step to next
10 end while;
11 endl endl
12
13 end subr ertlist;
1 .=member toklr
2 subr toklr(hap); $ list token given hash code
3 size hap(ps); $ hash code of token to ljst
4 size np(ps); $ pointer to names array for token
5 size cp(ps); $ character position during list
6 size i(ps); $ do loop index
7
8 np = nameptr ha(hap);
9 cp = ws+1; $ starting character pos
10 do i = 1 to lexlen ha(hap); $ list characters in turn
11 cp = cp - cs; $ move to next character
12 charl((.f. cp, cs, names(np))) $ list character
13 if cp = 1 then cp=ws+1; np=np+1; end if;
14 end do;
15
16 end subr toklr;
17
1 .=member ltoflo
2 subr ltoflo(pt, lim, msg); $ called if scanner array overflow
3 size pt(ps); $ var to increment
4 size lim(ps); $ maximum allowed value for -pt-
5 size msg(ws+1); $ diagnostic test passed if overflow occurs
6 size dummyarg(ps);
7
8 terml(yes); $ send this to terminal file
9 endl endl
dsq 197 .+s10 error_s10; $ flag error message for s10.
10 textl(error_notice)
11 textl('overflow of scanner array ') textl(msg)
12 tintl(' ptr',pt) tintl('limit',lim) endl
13 $ echo last input line seen.
14 textl(' next line is last line processed before overflow.')endl
15 errecho = yes; call givecr(dummyarg);
16 call ltlxtr; $ give trace back chain
17 terml(no); call lexexit;
18 end subr ltoflo;
1 .=member lexexit
2 subr lexexit; $ exit routine - prints statistics
3 $ lexexit is called to end the scan, and proceeds as follows -
4 $ 1. the cross-reference name buffer isbuf is flushed
5 $ if cross-reference list being generated, and final
6 $ action is taken.
7 $ 2. the token file buffer is flushed if any tokens remain,
8 $ and the end-file token is sent out.
9 $ 3. scanner statistics are collected and listed, giving the
10 $ structure of ha-table, macro usage, etc.
11 $ 4. optionally, a list of machine-dependent constants is
12 $ listed, to aid in production of portable software.
13 $ 5. error count is output, and abort is generated
14 $ if user so requests abort on errors.
15 $ 6. finally, lexexit exits to the routine ltlterm,
16 $ which initiates the generator phase.
17
18 size hats(ps); dims hats(20); data hats = 0(20); $ token types.
19 size hat(ps); $ ha index.
20 size hatzz(ps); data hatzz=0; $ number of zz-type names.
21 size hap(ps); $ ha pointer
22 size halt(ps); $ lex type of ha entry
23 size haln(ps); $ lex length of ha entry
24 size i(ps); $ do loop index
dsv 63 size termcode(ws); $ termination code.
25 .+s66. $ to pass count to root.
26 nameset lexcard;
27 size cardtot(ps); $ no of cards read, used by driver routine
28 end nameset lexcard;
29 cardtot = icdno; $ pass total number of cards to driver routine
30 ..s66
31 skipl(1) endl $ blank line
32 call clsinc; $ close the input file
33
34 $ now close the punch file it was opened, first call pflshr
35 $ with special end of job code, and then close file
36 if punchopened then
37 call pflshr(-1);
38 call clossio(punchfile, iorc);
39 end if;
40
41 if tokwrt then
42 tokrwd = 0;
43 tokrtyp tokrwd = tokreof; $ build eof token
44 tokrlen tokrwd = 0;
45 tokout1(tokrwd);
46 if tokrbufp then $ flush token buffer
47 call wtrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
48 $ write entire buffer, gen phase will detect special eof t
49 $ token code to determine true end of data
50 end if;
51 call clossio(tokenfile, iorc); $ close token file.
52 end if;
53
54 endl
55 if (lcs_opt=no) go to endofstatistics;
56 $ list lexical scan statistics.
57 call stitlr(1, 'statistics for lexical scan.'); ejectlp(20);
58 textl('statistics for lexical scan.') endl
59 .+tallycomments. $ if requested, give comment statistics
60 textl('source has ') intl(icdno) textl(' lines, with ')
61 intl(tallypl1) textl(' pl/1 comments, and ') intl(tallyeol)
62 textl(' $-style comments.') endl
63 ..tallycomments
64 .+tallytokens. $ if requested, give token statistics
65 textl('scanner detected ') intlp(tallytrue, 8)
66 textl(' tokens (') intlp(tallyimtok, 8) textl(' immediate).')
67 intlp(tallyparse, 8) textl(' tokens sent to parser.') endl
68 textl('source contains ') intlp(tallyblank,8)
69 textl(' words of blanks.') endl
70 ..tallytokens
71 .+tallyhash. $ if requested, list hash statistics
72 textl('symbol table searched') intlp(tally_haprobes, 8)
73 textl(' times;') intlp(tally_haentries,8)
74 textl(' entries examined. ')
75 if tally_halinks then intl(tally_halinks)textl(' links.') end if;
76 endl
77 ..tallyhash
100 if mtptr then
101 textl('used ') intl(mtptr) textl(' of ') intl(mtlim)
102 textl(' entries in macro definition table.') endl
106 end if;
107
108 textl('used ') intl(haused) textl(' of ') intl(hadim)
109 textl(' entries in symbol table.') endl
110 textl('used ') intl(namesptr) textl(' of ') intl(namesmax)
111 textl(' entries in names array.') endl
112 $ list ha entries by tpye
113 do i = 1 to hadim;
114 if (nameptr ha(i)=0) cont do;
115 hat = lextyp ha(i);
116 hats(hat) = hats(hat) + 1;
117 if (hat ^= nametok) cont do;
118 $ count names beginning with -zz-
119 if (isymc(i, 1) ^= 1rz) cont do;
120 if (isymc(i,2) ^= 1rz) cont do;
121 hatzz = hatzz + 1;
122 end do;
123 endl textl('symbol table composition') endl
124 skipl(5)
125 textl(' name zz-name special dot op decimal ')
126 textl('real bit string r s')
127 endl
128 intlp(hats(nametok),10) intlp(hatzz,10)
129 intlp(hats(spectok),10) intlp(hats(optok),10)
130 intlp(hats(dectok), 10) intlp(hats(realtok), 10)
131 intlp(hats(bittok), 10)
132 intlp(hats(stringtok),10) intlp(hats(rztok),10)
133 intlp(hats(sstok),10)
134 endl endl endl
135
136
dst 16 .+mdc.
137 if (mdclist = 0) go to endmdclist;
138 textl('machine dependent constants:') endl
139 do hap = 1 to hadim; $ look at ha
140 $ long r or any s constant.s are machine-dependant
141 if (nameptr ha(hap) = 0) cont do; $ ignore empty entries
142 halt = lextyp ha(hap); haln = lexlen ha(hap); $ get type and l
143 if (halt=rztok & haln > 1) ! halt = sstok then
144 intl(haln)
145 if halt=rztok then charl(1rr) else charl(1rs) end if;
146 do i = 1 to haln; charl(isymc(hap,i)); end do; $ output
147 textl(' ')
148 end if;
149 end do;
150 endl
151 /endmdclist/
dst 17 ..mdc
152
153 .+mp. $ here to list values of active zzy counters.
154 size nzzy(ps); $ counter.
155 nzzy = 0;
156 do i = 1 to 27; $ find active zzy counters.
157 if countzzy(i) then nzzy = i; quit do; end if;
158 end do;
159 if nzzy then $ if any active, list values.
160 endl textl('final values of active zzy counters: ')
161 do i = nzzy to 27;
162 nzzy = countzzy(i);
163 if nzzy then $ if active.
164 textl('zzy')
165 charl((.ch. i, 'abcdefghijklmnopqrstuvwxyz_'))
166 textl(' = ') intl(nzzy) textl(' ')
167 end if;
168 end do;
169 endl
170 end if;
171 ..mp
172
173 /endofstatistics/
174
175 .+cr.
176 size nametot(ps); $ number of names
177 size nptr(ps), nc(ps), j(ps);
178 if isonxrf then $ if cross reference on, complete ref. file.
179 crefput(0); $ mark end of references.
180 if crbuffptr then $ flush buffer if not empty
181 call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
182 end if;
183 call clossio(crfile, iorc); $ close reference file 1.
184 call crfnam(crfilename, crfileparm, 2);
185 call opensio(crfile, iorc, access_write, crfilename,
186 0, i, 0, 0);
187 crbuffptr = 0;
188 crefput(creftot);
189 crefput(icdno); $ last card number.
190 crefput(hadim);
191 $ determine space needed for names.
192 nametot = 0;
193 do i = 1 to hadim;
194 if (lextyp ha(i) ^= nametok) cont do;
195 nptr = nameptr ha(i);
196 if nptr then $ if name, get length
197 nc = lexlen ha(i);
198 nametot = nametot + (nc + (cpw-1))/cpw;
199 end if;
200 end do;
201 crefput(nametot); $ indicate space needed for names.
202
203 do i = 1 to hadim;
204 if (lextyp ha(i) ^= nametok) cont do;
205 crefput(i);
206 nc = lexlen ha(i);
207 crefput(nc);
208 nptr = nameptr ha(i) - 1;
209 $ write out name, packing chars into ref. size.
210 do j = 1 to (nc + (cpw-1))/cpw;
211 crefput(names(nptr+j));
212 end do;
213 end do;
214 crefput(0); $ indicate end of ha.
215
216 if crbuffptr then
217 call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
218 end if;
219 call clossio(crfile, iorc); $ close reference file 2.
220 end if;
221 ..cr
222 call detect;
223
224 if nwarnings then $ if warnings encountered.
dsq 198 .+s10 warn_s10; $ flag warning message for s10.
225 intl(nwarnings) textl(' warnings issued.') endl
226 end if;
227 if nerrors then $ if errors detected.
228 terml(yes)
dsq 199 .+s10 error_s10; $ flag error message for s10.
229 textl('scan detected') intl(nerrors)
230 textl(' lexical errors.') endl
234 end if;
235
236 $ fatal if no input lines read.
237 if icdno = 0 then
dsq 200 terml(yes)
dsq 201 .+s10 error_s10; $ flag error message for s10.
dsq 202 textl('no input lines - fatal error.') endl
239 terml(no)
240 exitcode = yes; $ force fatal termination.
241 end if;
242
243 if exitcode then $ if abnormal termination
dsq 203 terml(yes)
dsq 204 .+s10 error_s10; $ flag error message for s10.
dsq 205 textl('abnormal scanner termination') endl
245 terml(no); call clsterm;
246 call ltlfin(1, 1); $ abnormal termination.
247 end if;
248
249 if tokwrt = no then
250 textl('no token file.')
251 termlex = yes; $ end compilation.
252 end if;
253
254 endl endl
255 call clsterm;
dsv 64
dsv 65 $ determine termination code.
dsv 66
dsv 67 termcode = 0;
dsv 68 if (nwarnings) termcode = 4;
dsv 69 if (nerrors) termcode = 8;
dsv 70
256 if termlex then $ if lex phase terminates compilation.
257 textl('end of compilation.') endl
dsv 71 call ltlfin(0, termcode);
259 else $ if continuing to gen phase.
dsv 72 call ltlterm(1, termcode);
261 end if;
262
263 end subr lexexit;