Forgot your password?
Document Actions
SYN: Syntax generator for the LITTLE system. By Edith Deak and David Shields.
SYN: Syntax generator for the LITTLE system. By Edith Deak and David Shields.
1 .=member intro
2 /*
3
4 $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$$
5 $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$$
6 $$ $$ $$ $$ $$ $$
7 $$ $$ $$ $$ $$ $$
8 $$ $$ $$ $$ $$ $$$$$$
9 $$ $$ $$ $$ $$ $$$$$$
10 $$ $$ $$ $$ $$ $$
11 $$ $$ $$ $$ $$ $$
12 $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$$
13 $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$$
14
15 $$$$$$$$ $$ $$ $$ $$
16 $$$$$$$$$$ $$ $$ $$$ $$
17 $$ $ $$ $$ $$ $ $$
18 $$ $$$$ $$ $$ $$
19 $$$$$$$$$ $$ $$ $$ $$
20 $$$$$$$$$ $$ $$ $$ $$
21 $$ $$ $$ $$ $$
22 $ $$ $$ $$ $ $$
23 $$$$$$$$$$ $$ $$ $$$
24 $$$$$$$$ $$ $$ $$
25
26
27 syntax generator for the little system
28
29
30 by
31
32 edith deak
33 david shields
34
35
36 direct inquiries, comments and criticisms to
37
38 little project coordinator
39 computer science department
40 courant institute of mathematical sciences
41 251 mercer street
42 new york, new york 10012
43 u. s. a.
44
45
46
47 this program translates an annotated bnf-like description of a
48 programming language grammar into tables and text fragments
49 which form the central part of a parser for the language which
50 consists of an interpreter for an abstract parsing machine.
51
52 */
1 .=member mods
2 $ --- all mods are to include self description after mods.2 ---
dsk 2
dsk 3 $ dsk d. shields 15-dec-81 level 81349
dsk 4 $
dsk 5 $ 1. fix filename length for s32 and s47.
dsk 6 $ 2. make program parameter 'synbin=0/synbin' for all machines.
dsk 7 $ thus by default synbin file written only if name given. this
dsk 8 $ file not needed by any current production compiler using
dsk 9 $ syn and generally needed only during bootstrap.
dsk 10
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
dsj 1
dsj 2 $ dsj d. shields 08-sep-81 level 81251
dsj 3 $
dsj 4 $ for s37, change default name for synout file to 'synout' and
dsj 5 $ change line length for synout file from 72 to 80. this is helpful
dsj 6 $ for s37 and causes no harm in other systems.
dsj 7 $ deck affected - synini
dsj 8
dsi 1
dsi 2 $ dsi d. shields 03-sep-80 level 80247
dsi 3 $
dsi 4 $ 1. fix problem (fr153) for s37 in that some initial asm macros
dsi 5 $ had extraneous bits set.
dsi 6 $ 2. make record length of asm file 80. this needed for s37, and
dsi 7 $ causes no harm for other implementations.
dsi 8 $ 3. permit bin and asm files to be named with 'synbin=/' and
dsi 9 $ 'synasm=/' respectively. this maintains compatibility with
dsi 10 $ prior practice. for s37, defaults are 'synasm=assemble/'
dsi 11 $ and 'synbin=synbin/'.
dsi 12 $ decks affected - start, synini, ptasm.
dsi 13
dsh 1
dsh 2 $ dsh d. shields 30-jun-80 level 80182
dsh 3 $
dsh 4 $ add new feature for setl. if setl option and implicit macros
dsh 5 $ used, then report number of implicit entries. for example,
dsh 6 $ generate macro for -impmax- if im=p selected.
dsh 7 $ deck affected - ptout.
dsh 8
dsg 1
dsg 2 $ dsg d. shields 05-may-79 level 79127
dsg 3 $ correct to generate 'search pt10' and not 'universal pt10' for
dsg 4 $ s10, and also add code for pt10 macros to s10.
dsg 5 $ decks affected - ptasm, pt10.
dsg 6
dsf 1
dsf 2 $ dsf d. shields 13-apr-79 level 79103
dsf 3 $
dsf 4 $ a problem in using syn is that large grammars, notably setl,
dsf 5 $ require parse tables which are so large that the data
dsf 6 $ statements to initialize them cannot be compiled by the
dsf 7 $ little compiler. prior practice has been to read in the
dsf 8 $ parse table from a file. this correction adds option
dsf 9 $ asm= to direct syn to write assembler macro calls to unit 6
dsf 10 $ so that required data statements can be assembled by
dsf 11 $ machine assembler. this done in new procedure ptasm.
dsf 12 $ macro definitions provided in new decks pt10, pt32, pt37 and pt66.
dsf 13 $ decks affected - start, synini, ptout; new decks ptasm, pt10
dsf 14 $ pt32, pt37 and pt66.
dsf 15
dse 1 $ dse d. shields 26-mar-79 79085 - fix bugs in setl option.
dsd 1
dsd 2 $ dsd d. shields 19 feb 79 level 79050
dsd 3 $
dsd 4 $ add feature if setl option enabled to write out location
dsd 5 $ of definer for symbol.
dsd 6 $ decks affected - start, synini, gnam, ptout.
dsd 7
dsc 1
dsc 2 $ dsc d. shields 06 feb 79 level 79037
dsc 3 $
dsc 4 $ add program option 'setl=0/1' to support setl system.
dsc 5 $ this involves generation of two additional members and
dsc 6 $ writing of parse table in binary form to unit 5.
dsc 7 $ decks affected - start, synini, res4, ptout.
dsc 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, synini, nextok.
vax 7
3
4 $ rbkc r. kenner 01 mar 78 level 78060
5 $
6 $ 1. correct miscellaneous bugs detected on porting to s37.
7 $ 2. insert conditional code for s10.
8 $ 3. delete unused token types and add sstok.
9 $ decks affected - macros, start, synini, nextok, res4, putmem,
10 $ synexit
11
12
13 $ rbkb r. kenner 17 feb 78
14 $
15 $ fix error in little grammar causing miscompilations of
16 $ certain nested assignments and extractors. this
17 $ update goes with mod rbkm in gen.
18 $ deck affected - ltlgrmr
19
20
21 $ dsb d. shields 17 oct 77 level 77290.
22 $
23 $ add implicit macros to assist in encodings needed in grammar.
24 $ an implicit macro is a name which begins with a letter followed
25 $ by the break (underline) character, where the letter is
26 $ among those selected by the -im- program parameter.
27 $ each such group of names is assigned an integer code, starting
28 $ from one, in the order the names occur. the names are replaced
29 $ by the code, so that implicit macro names can occur where syn
30 $ accepts, or requires, an integer to appear. syn reports the
31 $ codes assigned for implicit macro with code -l- by writing
32 $ a member -syniml-. there can be up to four implicit macro groups.
33 $ implicit macros can be used to name group of constants used
34 $ by user-defined opcode, to name error messages, etc.
35 $ decks affected - start, nextok, ptout, listha.
36
37
38 $ rbka r. kenner 14 oct 77
39 $
40 $ revise little grammar according to mod rbkj in gen.
41 $ deck affected - ltlgrmr (resequenced).
42
43
44 $ dsa d. shields 03 oct 77 level 77276.
45 $
46 $ fix reported bug in handling of errors in grammar.
47 $ deck affected - parse
48
49
50 $ (none) d. shields 08 aug 77 77220.
51 $
52 $ release as version 1.0 of syn. show form of mod notice.
53
1 .=member macros
2
3 +* synlevel = $ date of last program change.
dsk 11 'syn(81349)' $ 15-dec-81
5 **
6
7 $ q3 and macdef are used to define macros in macros. macdrop
8 $ releases macro from macro status
9
10 +* q3(a,b,c) = a b c **
11 +* macdef(text) = q3(+,*text*,*) **
12 +* macdrop(mname) = macdef(mname=) **
13
14 +* defc(nam) = $ define constant identifier
15 macdef(nam = zzyz) **
16
17 +* locofer = parseerrloc **
18 +* pt_dim = parsearamax **
19
20 $ syn run on thu 28 jul 77 11:00:00
21 +* parsearamax = 178 **
22 +* parselitaramax = 0 **
23 +* parselexaramax = 0 **
24 +* parseactmax = 23 **
25 +* parseerrloc = 167 **
26 +* parseerrmax = 24 **
27 $ end member synmac
28
29 $ target machine parameters
30 +* ws = .ws. ** $ machine word size.
31 +* ps = .ps. ** $ machine pointer (address) size.
32 +* cs = .cs. ** $ machine character size.
33 +* cpw = (ws/cs) ** $ characters per machine word
34
35
36 +* wpc = $ number of words in line image
37 .+s66 09
vax 9 .+s32 20 $ 80 columns
38 .+s37 20 $ 80 columns
utsa 8 .+s47 20 $ 80 columns
mgfa 1 .+s10 20
40 **
41
42 +* blankword = $ word of blank chars (see insnam).
vax 10 .+s32 4r
43 .+s37 4r
utsa 9 .+s47 4r
44 .+s66 10r
mgfa 2 .+s10 4r
46 **
47
48 $ macros related to file names
49 +* filenamelen = 20 ** $ max. length of file name in chars.
dsk 12 .+s32 +* filenamelen = 64 ** $ max. length of file name in chars.
dsk 13 .+s47 +* filenamelen = 64 ** $ max. length of file name in chars.
utsa 10 .+s32 +* filenamelen = 64 **
utsa 11 .+s47 +* filenamelen = 64 **
50 +* lctimelen = 30 ** $ length of lctime time representation.
51
52 +* tokenfile = 3 ** $ token file number.
53
54 +* parsefile = 4 ** $ voa file number.
55
56 $ io access codes.
57 +* access_read = 4 **
58
59
60 $ macros for listing generation (procedures in run-time library)
61
62 +* listl(n) = call contlpr(26,n);** $ set listing flag
63 +* terml(n) = call contlpr(27,n);** $ set terminal flag
64 $ if less than n lines remain on current page.
65
66 +* digofchar(c) = $ value of character digit.
67 (c-1r0) $ use if codes for numbers in order.
68 **
69 +* charofdig(c) = $ maps digit into character code
70 (c+1r0) $ use if codes for numbers in order.
71 **
72
73
74 +* hexcharofdig(c) = .ch. (c)+1, '0123456789abcdef' **
75
76 $ countup macro for incrementing and testing variable
77 +* countup(var,lim,msg) =
78 var = var+1;
79 if (var>lim) call gtoflo(var,lim); **
80
81 +* alphabet = 'abcdefghijklmnopqrstuvwxyz' **
82
83
84 $ yes and no macros used for logical expressions to clarify
85 $ logical intent.
86 +* yes = 1 ** +* no = 0 **
87
88 +* toklenmax = 60 ** $ maximum length of token in characters
89
90
91
92 $ macros related to parser and lexical token processing
93
94
95 $ (codes must agree with those assigned by lex phase.)
96 $ the codes used in token reader procedure -nextok-
97 $ codes for lexical types assigned in lexical scan
98 +* toktypes = 14 ** $ no. of token types below
99 +* nametok = 1 ** $ name
100 +* spectok = 2 ** $ special token, e.g. (
101 +* pdotok = 3 ** $ type of period delimited operators
102 +* dectok = 4 ** $ type of decimal integers, e.g. 100
103 +* sstok = 5 ** $ s-type strings
104 +* strtok = 6 **
105 +* bittok = 8 **
106 +* qstok = 9 ** $ q type string constant
107 +* rztok = 12 ** $ right-zero type string constant (r)
108 +* realtok = 14 ** $ real token
109 +* listcontroltok = 27 ** $ '.=list' directive.
110 +* listejecttok = 28 ** $ '.=eject' list directive.
111 +* listtitletok = 29 ** $ '.=title' directive.
112 +* tokrline = 30 ** $ code for line image
113 +* tokreof = 31 ** $ code for end-token-file
114
115 .+s66.
116 +* tokrtyp = .f. 1, 5, ** $ token type (lex type or code)
117 +* tokrlen = .f. 7, 7, ** $ length of token in chars
118 +* tokrlc = .f. 14, 9, ** $ token literal code
119 .-s66.
120 +* tokrtyp = .f. 1, 8, **
121 +* tokrlen = .f. 9, 8, **
122 +* tokrlc = .f. 17, 8, **
123 ..s66
124
125 +* tokrval = $ first few characters of short token.
126 .+s66 .f. 25, 36,
vax 11 .+s32 .f. 25, 8,
127 .+s37 .f. 25, 8,
utsa 12 .+s47 .f. 25, 8,
mgfa 3 .+s10 .f. 28, 9,
129 **
130 +* cpstr = $ character per short token record
131 .+s66 6
vax 12 .+s32 1
132 .+s37 1
utsa 13 .+s47 1
mgfa 4 .+s10 1
134 **
135
136 +* naml(hap) = $ print name of ha item
137 call sdsnamr(hap);
138 put :sdsnamstr,a; ** $ sdsnamr puts charstring in
139 $ sdsnamstr
140
141
142 $ p a r s e t a b l e o p c o d e s
143
144 $ the following opcodes comprise the operations of the
145 $ parse interpreter. these drive the interpreter in this
146 $ program, and are also the opcodes of the parse table
147 $ generated by this program
148
149 defc(op_act) $ perform action.
150 defc(op_bak) $ restore parse.
151 defc(op_err) $ report error if failure.
152 defc(op_jif) $ jump if failure.
153 defc(op_jmp) $ jump.
154 defc(op_lex) $ test for token of given lexical type.
155 defc(op_lit) $ test for literal.
156 defc(op_set) $ set parse register.
157 defc(op_sev) $ seek zero or more instances of subpart.
158 defc(op_sub) $ seek subpart.
159 defc(op_op1) $ user operation 1.
160 defc(op_op2) $ user operation 2.
161 defc(op_op3) $ user operation 3.
162 defc(op_op4) $ user operation 4.
163 defc(op_op5) $ user operation 5.
164
165 .=zzyorg z $ reset zzyz to origin
166
167 +* op_max = op_op5 ** $ maximum valid operator value.
168
169 $ l e x i c a l c o d e s
170
171 $ lexical codes for the lexical classes of the self-defining
172 $ grammar which drives this program.
173
174 defc(lexc_name)
175 defc(lexc_string) $ quoted string
176 defc(lexc_int) $ integer
177 defc(lexc_nonslash) $ not a slash '/'
178 defc(lexc_noneq) $ not an arrow '='
179 defc(lexc_brlitdir) $ psuedo class for literal branch.
180
181 .=zzyorg z
182 +* lexc_max = lexc_brlitdir **
183
184
185 $ literal codes used to parse grammar.
186 defc(lc_ltsym) $ '<'
187 defc(lc_gtsym) $ '>'
188 defc(lc_eqsym) $ '='
189 defc(lc_divide) $ '/'
190 defc(lc_times) $ '*'
191 defc(lc_lparen) $ '('
192 defc(lc_rparen) $ ')'
193 defc(lc_minus) $ '-'
194 defc(lc_plus) $ '+'
195 defc(lc_set) $ 'set'
196 defc(lc_comma) $ '
197 defc(lc_ok) $ 'ok'
198 defc(lc_b) $ 'b'
199 defc(lc_option) $ 'option'
200 defc(lc_litmap) $ 'litmap'
201 defc(lc_lexmap) $ 'lexmap'
202 defc(lc_epc) $ 'epc'
203 defc(lc_mode) $ 'mode'
204 defc(lc_end) $ 'end'
205 defc(lc_op1) $ 'op1'
206 defc(lc_op2) $ 'op2'
207 defc(lc_op3) $ 'op3'
208 defc(lc_op4) $ 'op4'
209 defc(lc_op5) $ 'op5'
210
211 defc(lc_error) $ for name error, so can find 'error' index.
dse 3 defc(lc_errmp) $ for name errmp, so can find 'errmp' index.
212 defc(lc_synhalist) $ .synhalist. - dump syn ha.
213 defc(lc_synptlist) $ .synptlist. - dump syn pt.
214 defc(lc_synoptrace) $ .synoptrace. - turn on syn pt trace.
215 defc(lc_synnooptrace) $ .synnooptrace. - turn off syn pt trace.
216 defc(lc_syntoktrace) $ .syntoktrace. - turn on token trace.
217 defc(lc_synnotoktrace) $ .synnotoktrace. - turn off token trace.
218
219 .=zzyorg z
220
221 $ p a r s e t a b f i e l d s
222
223 +* parse_op = .f. 1, 4, ** $ parse item opcode
224 +* parse_parm = .f. 5, 12, ** $ parse item parameter
225 $ parse_parm is divided into 2 subfields for the set operation
226 $ which has 2 parameters
227 +* parse_parm1 = .f. 5, 3, ** $ stores register number(1-4)
228 +* parse_parm2 = .f. 8, 9, ** $ stores integer value
229 +* parsesz = 16 ** $ size of parse item
230
231 +* maxint = 511 ** $ maximum value for parse_parm2
232
233 $ p a r s e t a b m a c r o s
234
235 +* emitop(o, a) = $ create a ptab entry and push in on
236 $ deftab
237 parse_op parseskel = o;
238 parse_parm parseskel = a;
239 countup(defptr, deftabdim, 'deftab');
240 deftab(defptr) = parseskel;
241 **
242
243 $ map type codes for ha symbols.
244 .=zzyorg z
245 defc(mtyp_lex) $ resolve to lexical code.
246 defc(mtyp_lit) $ resolve to literal code.
247 defc(mtyp_act) $ resolve action sequence to label index.
248 defc(mtyp_im1) $ implicit macro 1
249 defc(mtyp_im2) $ implicit macro 2
250 defc(mtyp_im3) $ implicit macro 3
251 defc(mtyp_im4) $ implicit macro 4
252
253
254 $ h a m a c r o s
255
256 $ ha fields
257
258 +* ha_names = .f. 01, 11, ** $ names index.
259 +* ha_len = .f. 12, 06, ** $ length of name.
260 +* ha_islbl = .f. 18, 01, ** $ is label in pt.
261 +* ha_mtyp = .f. 19, 03, ** $ map type.
262 +* ha_mval = .f. 22, 11, ** $ map value.
263 .-s10 +* ha_pt = .f. 33, 11, ** $ pt index if pt symbol.
dsd 10 +* ha_synlc = .f. 44, 06, ** $ literal code if grammar symbo
dsd 11 +* ha_next = .f. 50, 11, ** $ next ha index in chain.
dsd 12 .+s10 +* ha_pt = .f. 61, 11, ** $ pt index if pt synbol.
267
268 +* hamvalsafe = 511 ** $ maximum safe mval.
dsd 13 +* hasynlcsafe = 63 ** $ maximum safe synlc value.
270
271 $ define headers for message classes
272 +* error_notice = '*****error**** ' **
273 +* system_notice = '*system error* ' **
274 +* warning_notice = '****warning*** ' **
275
1 .=member start
2
3 prog start; $ main program.
4
5 $ define global variables and structures.
6 $ it is assumed that this text compiled with 'default access'
7 $ option so that every procedure may refer to globals defined in
8 $ this procedure.
9
10
11 size arg(ps); $ saves ha index of literal, lexical, name, etc
12 size int1(ps); $ saves lexical integer item
13 size ival(ps); $ saves lexical integer item value
14
15 size errmax(ps); $ maximum error number used in grammar.
16 data errmax = 0;
17 size ermsgarg(ps); $ pass optional arg to ermsg.
18
19 size linelisted(ps); data linelisted = 0; $ on when line listed
20
21 +* hasz = $ size of ha in bits
22 .+s66 60
vax 13 .+s32 64
23 .+s37 64
utsa 14 .+s47 64
24 .+s10 72
25 **
26
27 $ the hash algorithm requires that hamax be a prime.
28 $ possible values include 509, 599, 701, 787 and 907.
29 +* hamax = 907 ** $ ha dims / must be prime.
30 +* haxtra = 200 ** $ number of additional ha entries for
31 $ internally generated labels
32 .+s66 nameset blank; $ keep in blank common on s66
33 size ha(hasz); dims ha(hamax + haxtra);
34 .+s66 end nameset;
35 size haused(ps); data haused=0; $ number of ha entries used.
36 size haxtrap(ps); data haxtrap = 0;
37
38 size errloc(ps); data errloc = 0; $ location in ptab
39 $ of error recovery
40
dse 4 size errmploc(ps); data errmploc = 0; $ location in ptab
dse 5 $ of symbol (for setl).
dsd 16
41
42 $ imara tracks implicit macros. if imara(i) is nonzero, then
43 $ the i-th letter of the alphabet is used for implicit macros,
44 $ and imara(i) gives the mtyp code used.
45
46 size imara(ps); dims imara(26); $ implicit macro code array.
47 data imara = 0(26);
48 size insnamstr(.sds. toklenmax);
49 data insnamstr = '' .pad. toklenmax;
50
51 $ lexlenmax is maximum length of lexical name in grammar.
52 $ litlenmax is maximum length of literal in grammar.
53 size lexlenmax(ps); data lexlenmax = 0;
54 size litlenmax(ps); data litlenmax = 0;
55
dsc 10 +* binfile = 5 ** $ binary file for setl option.
dsf 17 +* asmfile = 6 ** $ assembler text to unit 6 (see ptasm).
dsc 11
dsi 15 size asmfilename(.sds. filenamelen); $ asm file name.
dsi 16 size binfilename(.sds. filenamelen); $ bin file name.
56 size macroprefix(.sds. filenamelen); $ macro prefix string.
57 size memberprefix(.sds. filenamelen); $ start of member names.
58 size mtyporg(ps); dims mtyporg(7);
59 data mtyporg = 0(7);
60 size mtyplast(ps); dims mtyplast(7); data mtyplast = 0(7);
61 size mtyptot(ps); dims mtyptot(7); data mtyptot = 0(7);
62 size mtypnum(ps); dims mtypnum(7); data mtypnum = 0(7);
63
64 $ characters in symbolic names are kept in -names- array.
65 +* namesmax = $ dimension of -names- array
66 .+s66 800
vax 14 .+s32 1600
67 .+s37 1600
utsa 15 .+s47 1600
mgfa 5 .+s10 1600
69 **
70
71 size namesptr(ps); data namesptr = 0; $ ptr to names array
72 .+s66 nameset blank; $ keep in blank common on s66.
73 size names(ws); dims names(namesmax); $ names array
74 .+s66 end nameset;
75
76 size nextokha(ps); $ ha index of last token from nextok.
77 data nextokha = 0;
78
79 size linenumber(ps); data linenumber = 0; $ number of lines read
80 size jumpnext(ps); $ head of list of unresolved references
81 $ in ptab
82 data jumpnext = 0;
83
84 size nerrors(ps); data nerrors = 0; $ no of errors
85 size nwarnings(ps); data nwarnings=0; $ num. of warnings.
86 size halistflag(ps); $ flag to dump ha
87 data halistflag = 0;
88 size opnames(.sds. 3); $ array of opcode names
89 dims opnames(16);
90
91 size lastcol(ps); $ last column on file 2 to use.
92
93 size lcs_opt(ps); $ list parse statistics flag
94 size listpt(1); data listpt = no; $ list pt flag
95 size listsw(1); data listsw = yes; $ list input flag
96
97 size definertot(ps); $ number of definers
98 +* errnummax = 256 ** $ maximum error number.
99 size errbit(errnummax * 2); $ table of error numbers used
100 data errbit = 0;
101 +* errbits(i) = $ macro to access errbit
102 .f. (i-1)*2 + 1, 2, errbit **
103
104
105 size parsetrace(ws); $ on to trace parser
106 data parsetrace = no; $ trace parser action
107
108 $ p a r s e t a b stores grammar produced by syn
109
110 +* ptabmax = 2000 **
111 .+s66 nameset blank;
112 size ptab(ws); dims ptab(ptabmax);
113 .+s66 end nameset;
114 size keeptok(ps); $ lexical scanner keep tokenflag
115 data keeptok = no;
116 size parseskel(ws); $ ptab entry
117 size ptablim(ps); $ ptab pointer
118 data ptablim = 0;
119 $ ptablimout is ptablim written to member file. ptablimout is
120 $ ptablim rounded up to nearest multiple of epc.
121 size ptablimout(ps); data ptablimout = 0;
122
123 $ d e f t a b stores primary and secondary parse items
124 $ after a definer is found, the primaries and secondaries
125 $ are merged into ptab.
126
127 +* deftabdim = 50 **
128 size deftab(ws); dims deftab(deftabdim);
129 size defptr(ps); data defptr = 0;
130 size secptr(ps); $ beginning of secondary items in deftab
131
132 $ p t stores parse table of self-defining syn grammar
133
134 nameset pt;
135 size pt(ws); $ parse table
136 dims pt(pt_dim);
137 end nameset;
138 data pt =
139 $ member syntab
140 4b'0799 0035', 4b'0137 0075', 4b'0011 0002', 4b'00aa 0013', $ 1
141 4b'0035 0017', 4b'0023 0016', 4b'0033 0027', 4b'0043 0021', $ 2
142 4b'0139 0002', 4b'0037 0002', 4b'018a 0053', 4b'0002 0031', $ 3
143 4b'0209 0047', 4b'0063 0041', 4b'0689 0051', 4b'0002 0026', $ 4
144 4b'0245 0061', 4b'0002 0066', 4b'0002 02d5', 4b'0415 0455', $ 5
145 4b'04d5 0515', 4b'05e5 0605', 4b'0057 0355', 4b'0016 0073', $ 6
146 4b'0027 0083', 4b'0071 0002', 4b'0016 0093', 4b'0057 03d5', $ 7
147 4b'0027 00a3', 4b'0081 0002', 4b'0027 00b3', 4b'0091 0002', $ 8
148 4b'00a1 0077', 4b'00c3 0002', 4b'0016 0495', 4b'00b1 0002', $ 9
149 4b'0036 0163', 4b'00c1 0002', 4b'0016 00d3', 4b'00d1 0002', $ 10
150 4b'0067 00e3', 4b'0036 00f3', 4b'00e1 00b7', 4b'0103 0036', $ 11
151 4b'0113 0077', 4b'0123 00f1', 4b'0002 0101', 4b'0002 0067', $ 12
152 4b'0133 0036', 4b'0143 0077', 4b'0153 0111', 4b'0002 0087', $ 13
153 4b'0002 00d7', 4b'06e5 0121', 4b'0002 0036', 4b'0725 00c1', $ 14
154 4b'0002 0016', 4b'0765 00d1', 4b'0002 0131', 4b'0088 0002', $ 15
155 4b'00e7 07d5', 4b'0879 0002', 4b'0107 0825', 4b'00a8 0979', $ 16
156 4b'0002 00f7', 4b'0002 00b8', 4b'09f9 0002', 4b'0127 08f5', $ 17
157 4b'0037 0173', 4b'0036 0183', 4b'0141 0002', 4b'0117 0002', $ 18
158 4b'0037 0173', 4b'0036 0183', 4b'0151 0002', 4b'0026 0002', $ 19
159 4b'0037 0173', 4b'0036 0183', 4b'0161 0002', 4b'0026 0002', $ 20
160 4b'0037 0173', 4b'0036 0183', 4b'0171 0002', 4b'0ad9 0047', $ 21
161 4b'0002 0b09', 4b'0139 0035', 4b'0046 0002', 4b'0002 0056', $ 22
162 4b'0002 0002' ; $ 23
163 $ end member syntab
164
165 $ globals used by -parse- as parameters
166 size parsereg(ps); dims parsereg(8); $ parse registers.
167 data parsereg = 0(8);
168
169 +* parseok = parsereg(1) ** $ the parseflab is reg1
170 +* ermsgno = parsereg(2) ** $ the -ermsgno- is reg2
171 +* litmapflag = parsereg(3) ** $ user supplies literal number ma
172 +* lexmapflag = parsereg(4) ** $ user supplies lexical number ma
173
174
175 size epc(ps); $ number of parse items to pack
176 $ into word of ptab
177
178 +* peldefault = 50 ** $ default error limit.
179 size pelvalue(ps); data pelvalue = peldefault; $ error limit
180
181
182 size sdsnamstr(.sds. toklenmax);
183 data sdsnamstr= '' .pad. toklenmax; $ parameter to
184
185
186 $ as part of error report, syn lists the most recent
187 $ lexlistmax tokens. lexlistmax must be a power of two.
188
189 +* lexlistmax = 16 **
190
191 size lexlist(ps); dims lexlist(lexlistmax);
192 data lexlist = 0(lexlistmax);
193 size lexlistptr(ps); data lexlistptr = 0;
194 size listwds(ws); dims listwds(wpc); $ line read in
195 size listwdsp(ps); $ last non-blank word
196
dsc 12 size res4ent(ws); $ binary result of last res4 result.
dsc 13 size setlopt(ps); $ setl option.
dsc 14
dsf 18 size asmtype(ps); $ target machine for assembler text.
197 size timestr(.sds. lctimelen); $ stores time/date string
198
199 +* tokrbuflim = 256 **
200 +* tokarasz = ws ** $ size of tokara
201 +* tokaradims = ((toklenmax+cpw)/cpw) **
202 $ review tokaradims carefully when building cross compiler
203 $ where character sizes differ
204 size toklen(ps); $ token length in characters
205 size toklt(ps); $ token lexical type
206 size toklc(ps); $ token hash table index
207 .+s66 nameset blank; $ keep in blank common on s66.
208 size tokrbuf(ws); dims tokrbuf(tokrbuflim); $ token buffer
209 .+s66 end nameset;
210 size tokrbufp(ps); data tokrbufp=0; $ ptr to tokrbuf
211
212 call synini; $ to initialize program and print title
213 call parse;
214 call synexit(0);
215 end prog start;
1 .=member synini
2 subr synini; $ initialization.
3
4 size parm1(ws); $ to store params for op_set
5 size i(ps); $ do loop variable
6 size imchars(.sds. filenamelen); $ im code chars
7 size mt(ps); $ map type
8 size imtot(ps); $ number of implicit macros
9 size s1(.sds. 1); $ one character temporary string
10 size n(ps); $ temporary
11 size iorc(ps); $ io return code
12 size parsefilename(.sds. filenamelen); $ name of parse file
13 size tokenfilename(.sds. filenamelen); $ name of token file
15 size hap(ps); $ ha index.
16
17 do i = 1 to hamax; $ clear ha
18 ha(i) = 0; end do;
19
20 $ initialize opnames, setting to '**n' if n not an op.
21
22 do i = 0 to 15;
23 opnames(i+1) = '***';
24 .ch. 3, opnames(i+1) = hexcharofdig(i);
25 end do;
26 opnames(op_lit+1) = 'lit';
27 opnames(op_lex+1) = 'lex';
28 opnames(op_sev+1) = 'sev';
29 opnames(op_sub+1) = 'sub';
30 opnames(op_err+1) = 'err';
31 opnames(op_bak+1) = 'bak';
32 opnames(op_jif+1) = 'jif';
33 opnames(op_jmp+1) = 'jmp';
34 opnames(op_act+1) = 'act';
35 opnames(op_set+1) = 'set';
36 opnames(op_op1+1) = 'op1';
37 opnames(op_op2+1) = 'op2';
38 opnames(op_op3+1) = 'op3';
39 opnames(op_op4+1) = 'op4';
40 opnames(op_op5+1) = 'op5';
41
42
43 $ hash into ha literals of syn sgrammar
44 +* hashin(s, lc) = call haini(s, lc); **
45 hashin('<', lc_ltsym)
46 hashin('>', lc_gtsym)
47 hashin('=', lc_eqsym)
48 hashin('/', lc_divide)
49 hashin('*', lc_times)
50 hashin('(', lc_lparen)
51 hashin(')', lc_rparen)
52 hashin('-', lc_minus)
53 hashin('+', lc_plus)
54 hashin('set', lc_set)
55 hashin(',', lc_comma)
56 hashin('ok', lc_ok)
57 hashin('b', lc_b)
58 hashin('option', lc_option)
59 hashin('litmap', lc_litmap)
60 hashin('lexmap', lc_lexmap)
61 hashin('epc', lc_epc)
62 hashin('mode', lc_mode)
63 hashin('end', lc_end)
64
65 hashin('op1', lc_op1)
66 hashin('op2', lc_op2)
67 hashin('op3', lc_op3)
68 hashin('op4', lc_op4)
69 hashin('op5', lc_op5)
70 hashin('error', lc_error) $ ha index of symbol 'error'
71 hashin('.synhalist.' ,lc_synhalist);
72 hashin('.synptlist.', lc_synptlist);
73 hashin('.synoptrace.', lc_synoptrace);
74 hashin('.synnooptrace.', lc_synnooptrace);
75 hashin('.syntoktrace.', lc_syntoktrace);
76 hashin('.synnotoktrace.', lc_synnotoktrace);
77
79
80 call getspp(memberprefix, 'memp=syn/');
81 call getspp(macroprefix, 'macp=parse/');
82
83 call getipp(parsetrace, 'pt=0/1');
dsc 15 call getipp(setlopt,'setl=0/1'); $ setl option.
dsc 16
dse 6 if setlopt then $ in setl mode, look for name .
dse 7 hashin('errmp', lc_errmp) $ ha index of symbol 'errmp'
dsd 19 end if;
dsd 20 macdrop(hashin)
84 call getipp(epc, 'epc=2/3'); $ number of parseitems/word
85 call getipp(lcs_opt, 'lcs=1/0');
86 call getipp(halistflag, 'ha=0/1');
87
dsf 19 $ read asm= option, default is off or machine at hand if asm
dsf 20 $ alone specified.
dsf 21 .+s10 call getipp(asmtype, 'asm=0/10');
dsf 22 .+s32 call getipp(asmtype, 'asm=0/32');
dsf 23 .+s37 call getipp(asmtype, 'asm=0/37');
utsa 16 .+s47 call getipp(asmtype, 'asm=0/47');
dsf 24 .+s66 call getipp(asmtype, 'asm=0/66');
vax 15 .+s32 call getspp(tokenfilename, 'tokens=tokens.tmp/');
88 .+s37 call getspp(tokenfilename, 'tokens=sysut1/');
utsa 17 .+s47 call getspp(tokenfilename, 'tokens=sysut1/');
89 .+s66 call getspp(tokenfilename, 'tokens=tokens/');
mgfa 6 .+s10 call getspp(tokenfilename, 'tokens=*.tok/');
91 call opensio(tokenfile, iorc, access_read, tokenfilename,
92 0, i, 0, 0);
dsia 1 .+s66 call rewisio(tokenfile, iorc, 0);
94 call dropsio(tokenfile, iorc); $ this is terminal use of tokenfil
95 call rdrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
vax 16 .+s32 call getspp(parsefilename, 'synout=synout.dat/');
dsj 10 .+s37 call getspp(parsefilename, 'synout=synout/');
utsa 18 .+s47 call getspp(parsefilename, 'synout=synout/');
97 .+s66 call getspp(parsefilename, 'synout=synout/');
98 .+s10 call getspp(parsefilename, 'synout=synout.dat/');
dsj 11 file parsefile access = put, linesize = 80, title = parsefilename;
dsj 12 .+s66 rewind parsefile;
101
dsi 17 .+s32 call getspp(asmfilename, 'synasm=/');
dsi 18 .+s37 call getspp(asmfilename, 'synasm=assemble/');
utsa 19 .+s47 call getspp(asmfilename, 'synasm=assemble/');
dsi 19 .+s66 call getspp(asmfilename, 'synasm=/');
dsi 20 .+s10 call getspp(asmfilename, 'synasm=/');
dsi 21
dsk 14 call getspp(binfilename, 'synbin=0/synbin');
106
107 call getspp(imchars, 'im=/');
108 if (.len. imchars > 4) .len. imchars = 4; $ at most four.
109 imtot = 0;
110 do i = 1 to .len. imchars;
111 s1 = .s. i, 1, imchars; $ get code character
112 n = s1 .in. alphabet;
113 if (n=0) cont do; $ if not a letter.
114 if (imara(n)) cont do; $ if already specified.
115 imtot = imtot + 1;
116 imara(n) = mtyp_im1 + (imtot-1); $ set map type.
117 end do;
118
119 lastcol = filestat(2,linesize)-6;
120 call ltitlr(synlevel);
121 call stitlr(0, 'syn - syntax generator.');
122 call stitlr(1, 'program parameters.');
123
124 timestr = ' ' .pad. 30;
125 call lstime(timestr); $ get time/date
126
127 put ,'token file: tokens = ' :tokenfilename,a
128 ,'. output file: synout = ' :parsefilename,a ,'.' ,skip;
dsi 26 put ,'asm file: synasm = ' :asmfilename,a
dsi 27 ,'. binary file: synbin = ' :binfilename,a ,'.' ,skip;
129
130 put ,'entries per constant: epc = ' :epc,i
131 ,'. parse trace: pt = ':parsetrace,i ,'.' ,skip;
132 put ,'ha dump: ha = ' :halistflag,i ,'.' ,skip;
133 put ,'macro prefix: macp = ' :macroprefix,a
134 ,'. member prefix: memp = ' :memberprefix,a ,'.' ,skip;
135 put ,'implicit macros: im = ' :imchars,a ,'.' ,skip;
dsc 17 put ,'setl: setl = ' :setlopt,i ,'.' ,skip;
dsf 25 put ,'assembler text type: asm = ' :asmtype,i ,'.' ,skip;
136 call stitlr(1, 'grammar listing.');
137 put ,skip(2);
138 end subr synini;
1 .=member haini
2 subr haini(s, lc); $ initialize synlc for string s.
3 size s(.sds. 20);
4 size lc(ps); $ syn literal code.
5 size l(ps); $ string length.
6 size hap(ps); $ ha index.
7
8 l = .len. s; assert l <= toklenmax;
9 .len. insnamstr = l;
10 .s. 1, l, insnamstr = s;
11 call insnam(hap);
12 assert lc <= hasynlcsafe; $ avoid field overflow.
13 ha_synlc ha(hap) = lc;
14 end subr haini;
1 .=member parse
2 subr parse; $ parse grammar.
3
4 $ parser stack -pca- macros
5
6
7 size parsenow(ps); $ ptable -pt- pointer
8 size parseop(ps); $ current parse operation
9 size parseparm(ps); $ current parse parameter
10 size lc(ps); $ literal ha code
11 size i(ps); $ do loop variable
12 size tot(ps); $ sum of objects found
13 size p1(ps); $ parameter1
14 size p2(ps); $ parameter2
15
16 +* pcamax = 50 **
17 +* pcaret(i) = .f. 01, 11, pca(i) ** $ return address
18 +* pcaprm(i) = .f. 12, 11, pca(i) ** $ seek several branch target
19 +* pcatot(i) = .f. 23, 10, pca(i) ** $ totol no of items found
20 size pca(32); $ parse stack
21 dims pca(pcamax);
22 size pcaptr(ps); $ pointer to pca
23 pcaptr = 0; tot = 0;
24
25
26 $ unpack parse table, two entries per constant.
27 do i = pt_dim/2 to 1 by -1;
28 pt(i*2) = .f. 01, 16, pt(i);
29 pt(i*2-1) = .f. 17, 16, pt(i);
30 end do;
31
32 parsenow = 1;
33 go to parseon;
34
35 /parseoncond/ $ advance parse according to parseok state.
36 keeptok = 1 - parseok;
37 parsenow = parsenow + 1 + parseok;
38 go to parseon;
39
40 /parsenext/ $ advance to next parse op.
41
42 parsenow = parsenow + 1;
43
44 /parseon/ $ interprep next parse item
45
46 parseop = parse_op pt(parsenow);
47 parseparm = parse_parm pt(parsenow);
48
49 if parsetrace then $ if tracing parse.
50 put ,x(4) ,'parsetrace ' :parseok :parsenow
51 :parseop :parseparm,nil ,x :opnames(parseop+1),al ,skip;
52 end if;
53
54 go to po(parseop) in 1 to op_max;
55
56
57 /po(op_lit)/ $ seek literal.
58
59 call nextok; $ get next token
60 parseok = (parseparm = toklc);
61 go to parseoncond;
62
63 /po(op_lex)/ $ seek lexical.
64
65 call nextok; $ get next token
66 go to lexc(parseparm) in 1 to lexc_max;
67
68 /lexc(lexc_name)/ $ seek <*name>.
69
70 parseok = (toklt = nametok);
71 if (parseok) arg = nextokha;
72 go to parseoncond;
73
74 /lexc(lexc_string)/ $ seek <*string>.
75
76 parseok = (toklt = strtok);
77 if (parseok) arg = nextokha; $ save ha index if found.
78 go to parseoncond;
79
80 /lexc(lexc_int)/ $ seek <*int>.
81
82 parseok = (toklt = dectok);
83 if parseok then $ if integer found, convert it.
84 ival = 0; $ result stored in -ival-
85 do i = 1 to (.len. insnamstr);
86 ival = ival * 10 + digofchar((.ch. i, insnamstr));
87 end do;
88 end if;
89 go to parseoncond;
90
91 /lexc(lexc_nonslash)/ $ seek any token but '/'.
92
93 parseok = (toklc ^= lc_divide);
94 go to parseoncond;
95
96 /lexc(lexc_noneq)/ $ seek any token but '='.
97
98 parseok = (toklc ^= lc_eqsym);
99 go to parseoncond;
100
101 /lexc(lexc_brlitdir)/ $ branch on literal for direct part.
102 $ here to start direct part, check next token, and
103 $ branch according to literal case.
104 i = 0;
105 if toklc = lc_ltsym then i = 1;
106 elseif toklc = lc_lparen then i = 2;
107 elseif toklc = lc_minus then i = 3;
108 elseif toklc = lc_plus then i = 4;
109 elseif toklc = lc_set then i = 5;
110 elseif toklc = lc_ok then i = 6;
111 elseif toklc = lc_op1 then i = 7; int1 = 1;
112 elseif toklc = lc_op2 then i = 7; int1 = 2;
113 elseif toklc = lc_op3 then i = 7; int1 = 3;
114 elseif toklc = lc_op4 then i = 7; int1 = 4;
115 elseif toklc = lc_op5 then i = 7; int1 = 5;
116 end if;
117 parseok = (i > 0);
118 keeptok = 1 - parseok;
119 parsenow = parsenow + 1 + i;
120 go to parseon;
121
122 /po(op_sev)/ $ seek several subparts.
123
124 countup(pcaptr, pcamax, 'ptab');
125 pca(pcaptr) = 0;
126 pcaret(pcaptr) = parsenow; $ save return place
127 pcaprm(pcaptr) = parseparm; $ save place branching to
128 parsenow = parseparm;
129 go to parseon;
130
131 /po(op_sub)/ $ seek subpart.
132
133 countup(pcaptr, pcamax, 'ptab');
134 pca(pcaptr) = 0;
135 pcaret(pcaptr) = parsenow;
136 parsenow = parseparm;
137 go to parseon;
138
139 /po(op_err)/ $ process error
140
141 if parseok then
142 parsenow = parsenow + 1;
143 go to parseon;
144 end if;
145 ermsgno = parseparm;
146 call ermet;
147 pcaptr = 0; $ clear parse stack for error recover
148 parsenow = locofer; $ location in pt of error processing
149 go to parseon;
150
151
152 /po(op_bak)/ $ restore parse state
153
154 $ return from find subpart or find repeated instances of subpart.
155
156 if pcaprm(pcaptr) = 0 then $ seek one instance case.
157 parsenow = pcaret(pcaptr) + parseok + 1;
158 pcaptr = pcaptr - 1;
159 if (pcaptr >= 0) go to parseon;
160 call ermey(2); $ fatal pca underflow.
161
162 else $ seek several instances.
163
164 if parseok then $ continue search
165 pcatot(pcaptr) = pcatot(pcaptr) + 1; $ increment count
166 $ of items found
167 parsenow = pcaprm(pcaptr);
168 go to parseon;
169 else $ subpart not found. return to point of call.
170 parsenow = pcaret(pcaptr) + 1;
171 parseok = yes; $ 0 instances valid
172 tot = pcatot(pcaptr); $ total subparts found
173 pcaptr = pcaptr - 1;
174 if (pcaptr >= 0) go to parseon;
175 call ermey(2); $ fatal pca underflow.
176 end if;
177 end if;
178
179 /po(op_jif)/ $ conditional transfer -lab
180
181 if parseok then
182 parsenow = parsenow + 1; go to parseon;
183 end if;
184 parsenow = parseparm;
185 go to parseon;
186
187 /po(op_jmp)/ $ transfer +lab
188
189 parsenow = parseparm;
190 go to parseon;
191
192 /po(op_set)/ $ set register set(r, iv)
193
194 p1 = parse_parm1 pt(parsenow) + 1;
195 p2 = parse_parm2 pt(parsenow);
196
197 parsereg(p1) = p2;
198 go to parsenext;
199
200 /po(op_op1)/ /po(op_op2)/ /po(op_op3)/
201 /po(op_op4)/ /po(op_op5)/
202 put ,'error - attempt to use user op operation.' ,skip;
203 put :parsenow,nil ,skip;
204 call synexit(1);
205 go to parsenext;
206
207 /po(op_act)/ $ execute code
208
209 go to pa(parseparm) in 1 to parseactmax;
210
211 +* pac = go to parsenext; **
212
213 $ member synact
214 / pa( 1) / call synexit ( 0 ); pac;
215 / pa( 2) / call gnam; pac;
216 / pa( 3) / call gdir; pac;
217 / pa( 4) / go to g_alt;
218 / pa( 5) / call galt; pac;
219 / pa( 6) / call glit; pac;
220 / pa( 7) / call glex; pac;
221 / pa( 8) / go to g_sev;
222 / pa( 9) / go to g_sub;
223 / pa( 10) / call gact; pac;
224 / pa( 11) / go to g_jif;
225 / pa( 12) / go to g_err;
226 / pa( 13) / go to g_jmp;
227 / pa( 14) / go to g_saveint;
228 / pa( 15) / call gset; pac;
229 / pa( 16) / go to g_ok;
230 / pa( 17) / go to g_opn;
231 / pa( 18) / go to g_bak;
232 / pa( 19) / go to g_next;
233 / pa( 20) / go to g_mode;
234 / pa( 21) / go to g_epc;
235 / pa( 22) / go to g_lexmap;
236 / pa( 23) / go to g_litmap;
237 $ end member synact
238
239 macdrop(pac)
240
241 /g_epc/ $ set entries per constant.
242 epc = ival;
243 go to parsenext;
244
245 /g_lexmap/ $ assigns lexical code to name.
246
247 call setmtyp(arg, mtyp_lex);
248
249 if ha_mtyp ha(arg) ^= mtyp_lex then $ if wrong type.
250 ermsgarg = arg; call ermsg(12); $ name in use.
251 ival = ha_mval ha(arg); $ get current value.
252 elseif ha_mval ha(arg) then $ if value already set.
253 ermsgarg = arg; call ermsg(13);
254 ival = ha_mval ha(arg);
255 else $ if first encounter, adjust lexlenmax.
256 if (ha_len ha(arg) > lexlenmax) lexlenmax = ha_len ha(arg);
257 end if;
258
259 ha_mval ha(arg) = ival; assert ival <= hamvalsafe;
260 go to parsenext;
261
262 /g_litmap/ $ assign literal code to literal.
263
264 call setmtyp(arg, mtyp_lit);
265
266 if ha_mtyp ha(arg) ^= mtyp_lit then $ if wrong type.
267 ermsgarg = arg; call ermsg(12); $ name in use.
268 ival = ha_mval ha(arg); $ get current value.
269 elseif ha_mval ha(arg) then $ if value already set.
270 ermsgarg = arg; call ermsg(13);
271 ival = ha_mval ha(arg);
272 else $ if first encounter, adjust litlenmax.
273 if (ha_len ha(arg) > litlenmax) litlenmax = ha_len ha(arg);
274 end if;
275
276 ha_mval ha(arg) = ival; assert ival <= hamvalsafe;
277 go to parsenext;
278
279 /g_alt/ $ beginning of secondary items
280
281 secptr = defptr + 1; $ mark beginning of secondary definer items
282 go to parsenext;
283
284 /g_sev/ $ seek several.
285
286 emitop(op_sev, arg);
287 ha_islbl ha(arg) = yes; $ flag as name used.
288 go to parsenext;
289
290 /g_sub/ $ seek syntactic subpart.
291
292 emitop(op_sub, arg);
293 ha_islbl ha(arg) = yes;
294 go to parsenext;
295
296
297 /g_err/ $ error if ok = false
298
299 emitop(op_err, ival); $ emit op_err item
300 if (errbits(ival) < 2) $ note use if errno -ival-
301 errbits(ival) = errbits(ival) + 1;
302 go to parsenext;
303
304 /g_saveint/
305
306 int1 = ival; $ save value of ival
307 go to parsenext;
308
309 /g_ok/
310
311 $ the primitive -ok- becomes set(1, 1)
312 int1 = 1; ival = 1;
313 call gset;
314 go to parsenext;
315
316
317 /g_opn/ $ emit opn operation.
318
319 emitop((op_op1+int1-1), ival);
320 go to parsenext;
321
322 /g_bak/
323
324 emitop(op_bak, 0);
325 go to parsenext;
326
327 /g_jmp/ $ unconditional transfer
328
329 emitop(op_jmp, arg);
330 ha_islbl ha(arg) = yes;
331 go to parsenext;
332
333 /g_jif/ $ conditional transfer if ok = false
334
335 $ primary.
336 emitop(op_jif, arg);
337 ha_islbl ha(arg) = yes;
338 go to parsenext;
339
340 /g_next/ $ conditional transfer to next definer
341 $ internally generated labels
342 if jumpnext = 0 then $ allocate new ha entry
343 countup(haxtrap, haxtra, 'haxtra');
344 jumpnext = haxtrap + hamax;
345 end if;
346 arg = jumpnext;
347 emitop(op_jmp, arg);
348 go to parsenext;
349
350 /g_mode/ $ process mode option.
351 go to parsenext;
352 end subr parse;
1 .=member setmtyp
2 subr setmtyp(hap, mt); $ set mtyp of ha(hap), chain if new.
3 size hap(ps); $ ha index.
4 size mt(ps); $ desired mtyp value.
5
6 if (ha_mtyp ha(hap)) return; $ if type already set.
7 ha_mtyp ha(hap) = mt; $ set type.
8 if mtyporg(mt)=0 then $ if first instance of type.
9 mtyporg(mt) = hap;
10 else
11 ha_next ha(mtyplast(mt)) = hap;
12 end if;
13 mtyplast(mt) = hap;
14 mtypnum(mt) = mtypnum(mt) + 1;
15 end subr setmtyp;
1 .=member gtoflo
2 subr gtoflo(ipoin, lim); $ increment counter
3 $ increment -ipoin-, fatal error if -ipoin- >= -lim-.
4 size ipoin(ps);
5 size lim(ps);
6 size iword(ws+1); $ name of array which overflowed
7
8 terml(yes); $ write this to terminal file
9 put ,error_notice ,' array overflow with index '
10 :ipoin,i ,', with limit ' :lim,i ,skip;
11 terml(no); $ done with terminal file output
12 call synexit(1); $ terminate
13 end subr gtoflo;
1 .=member nextok
2 subr nextok(hap); $ get next token
3 $ obtain next token from input stream, unless -keeptok- is on,
4 $ in which case return prior token.
5 $ check for 'special' period-delimited tokens,
6 $ such as '.voadump.' which requests symbol table dump, etc.
7 $ set -toklc- to literal code, -toklt- to lexical type,
8 $ -toklen- to length of token in characters,
9 $ -tokwords- to number of words in
10 $ token, and insert token in array -tokara-.
11 size i(ps); $ do loop index
12 size tokhdr(ws); $ token descriptor word
13 size toktrace(1); data toktrace=0; $ on to trace tokens read
14 size tokwords(ps); $ no of words in token value
15 size toklclex(ps); $ literal code from lex.
16 size fsd(ps); $ index of first nonzero char in integer.
17 size nl(ps); $ new length if eliminating leading zeros.
18 size v(ps); $ value of implicit macro.
19 size c(ps); $ character temporary.
20 size mt(ps); $ implicit macro type.
21 size tokara(tokarasz); dims tokara(tokaradims); $ token array
22
23 +* tokread1(wd) = $ get one word from token buffer/file
24 if tokrbufp >= tokrbuflim then
25 size zzzv(ps); $ io return code.
26 call rdrwsio(tokenfile, zzzv, tokrbuf, 1, tokrbuflim);
27 tokrbufp=0;
28 end if;
29 tokrbufp = tokrbufp + 1; wd = tokrbuf(tokrbufp);
30 **
31
32 +* tokread(ara, wds) = $ read wds words into ara(1) to ara(wds).
33 size zzzi(ps); $ do loop index.
34 if (wds+tokrbufp) >= tokrbuflim then $ if would empty buf,
35 do zzzi = 1 to wds;
36 tokread1(ara(zzzi)); end do;
37 else
38 do zzzi = 1 to wds;
39 ara(zzzi) = tokrbuf(tokrbufp + zzzi); end do;
40 tokrbufp = tokrbufp + wds;
41 end if;
42 **
43 $ do not read token till -find- clears -keeptok-
44
45 if (keeptok) return;
46 keeptok = yes;
47 /rdtok/
48 tokread1(tokhdr); $ read token descriptor
49 toklt =tokrtyp tokhdr; $ get lexical type/code
50 toklclex = tokrlc tokhdr;
51 toklen = tokrlen tokhdr; $ no ov chars
52 if toktrace then
53 put ,'token trace ' :toklt :toklen :toklc,nil ,skip;
54 end if;
55 tokwords = (toklen-1)/cpw + 1; $ no of words
56 if (toklen = 0) tokwords = 0;
57 go to t(toklt) in 1 to tokreof;
58 /t(listcontroltok)/ $ .=list directive or change.
59 if toklen = 2 then $ if list input directive change.
60 listsw = toklclex;
61 elseif toklen = 1 then $ if list code directive.
62 listpt = toklclex;
63 end if;
64 go to rdtok;
65 /t(listejecttok)/ $ .=eject
66 put ,page;
67 go to rdtok;
68 /t(listtitletok)/ $ .=title
69 go to rdtok;
70
71 /t(15)/ /t(16)/ /t(17)/ /t(18)/ /t(19)/ /t(20)/ /t(7)/ /t(10)/
72 /t(21)/ /t(22)/ /t(23)/ /t(24)/ /t(25)/ /t(26)/ /t(11)/ /t(13)/
73 call ermey(9);
74
75 /t(nametok)/
76 /t(spectok)/
77 /t(pdotok)/
78 /t(dectok)/
79 /t(sstok)/
80 /t(strtok)/
81 /t(bittok)/
82 /t(qstok)/
83 /t(rztok)/
84 /t(realtok)/
85
86 assert toklen < (toklenmax-cpw);
87
vax 18 .+s32 tokara(2) = blankword;
88 .+s37 tokara(2) = blankword;
utsa 21 .+s47 tokara(2) = blankword;
89 if toklen <= cpstr then
90 tokara(1) = blankword;
91 tokrval tokara(1) = tokrval tokhdr;
92 else
93 tokread(tokara, tokwords);
94 end if;
95 if toktrace then
96 put,'token = ';
97 do i = 1 to tokwords;
98 put :tokara(i),r(cpw);
99 end do;
100 put ,skip;
101 end if;
102 do i = 1 to tokwords; $ copy into insnamstr.
103 .f. (1+.sds. toklenmax)-i*ws, ws, insnamstr = tokara(i);
104 end do;
105 .len. insnamstr = toklen;
106 $ eliminate leading zeros if integer.
107 if toklt = dectok then
108 fsd = 1;
109 while fsd1 then $ if leading zeros.
114 nl = toklen - fsd + 1;
115 toklen = nl;
116 do i = 1 to nl;
117 .ch. i, insnamstr = .ch. fsd+i-1, insnamstr;
118 end do;
119 .len. insnamstr = nl;
120 end if fsd;
121 end if toklt;
122 call insnam(nextokha); $ hash token into ha
123 $ check for possible implicit macro.
124 until 1;
125 if (toklt^=nametok ! toklen<2) quit until;
126 c = .ch. 2, insnamstr;
127 if (c^=1r_) quit until;
128 i = (.s. 1, 1, insnamstr) .in. alphabet;
129 if (i=0) quit until;
130 if (imara(i)=0) quit until; $ if not implicit macro code.
131 mt = imara(i); $ get macro type.
132 call setmtyp(nextokha, mt); $ see if correct type.
133 if (ha_mtyp ha(nextokha) ^= mt) quit until;
134 if ha_mval ha(nextokha) = 0 then $ if defining case.
135 mtyptot(mt) = mtyptot(mt) + 1;
136 ha_mval ha(nextokha) = mtyptot(mt);
137 end if;
138 v = ha_mval ha(nextokha); $ get value.
139 $ now hash in value as integer token, and use it.
140 toklen = 1 + (v>9) + (v>99);
141 .len. insnamstr = toklen;
142 do i = toklen to 1 by -1;
143 .ch. i, insnamstr = charofdig(mod(v,10));
144 v = v / 10;
145 end do;
146 toklt = dectok;
147 call insnam(nextokha);
148 end until;
149
150 toklc = ha_synlc ha(nextokha);
151 lexlist(lexlistptr+1) = nextokha; $ save token
152 lexlistptr = (lexlistptr+1) & (lexlistmax-1);
153 /dotok/
154 if(toklt ^= pdotok) return;
155 $ search for special syn directives.
156 if (toklc=0) return;
157 if toklc = lc_synhalist then $ if .synhalist.
158 call lstlin;
159 call halist;
160 go to rdtok;
161 elseif toklc = lc_synptlist then $ if .synptlist.
162 call lstlin;
163 call ptlist;
164 go to rdtok;
165 elseif toklc = lc_synoptrace then $ if .synoptrace.
166 parsetrace = yes;
167 go to rdtok;
168 elseif toklc = lc_synnooptrace then $ if .synnooptrace.
169 parsetrace = no;
170 go to rdtok;
171 elseif toklc = lc_syntoktrace then $ if .syntoktrace.
172 toktrace = yes;
173 go to rdtok;
174 elseif toklc = lc_synnotoktrace then $ if .synnotoktrace.
175 toktrace = no;
176 go to rdtok;
177 end if;
178 return;
179 /t(tokrline)/ $ line image being transmitted
180 tokread(listwds, tokwords); $ read line image
181 linelisted = no; $ new line read, not yet listed
182 linenumber = linenumber + 1; $ updating line count
183 listwdsp = tokwords; $ save length
184 if listsw then $ list last line
185 call lstlin;
186 end if;
187 go to rdtok; $ get next token
188 /t(tokreof)/ $ end-of-file token
189 call ermsg(19); call galt;
190 call synexit(0);
191 end subr nextok;
1 .=member lstlin
2 subr lstlin; $ list input line.
3 size i(ps); $ loop index.
4 if linelisted = no then $ must list last line
5 put :linenumber,i(5) ,x(2);
6 do i = 1 to listwdsp; $ list line image
7 put :listwds(i),r(cpw);
8 end do;
9 put ,skip;
10 linelisted = yes; $ show line now listed
11 end if;
12 end subr lstlin;
1 .=member toklist
2 subr toklist; $ list recent tokens
3 size i(ps); $ index in lexlist
4 size n(ps); $ number listed
5
6 put ,x(15),'last few tokens: ';
7 i = lexlistptr-1; $ set to start
8 n = 0;
9 while 1;
10 i = (i+1) & (lexlistmax-1); $ bump i, modulo lexlistmax
11 n = n+1; if (n>lexlistmax) quit while;
12 if (lexlist(i+1) = 0) cont while; $ ignore if not set
13 call sdsnamr(lexlist(i+1)); $ get string form of token.
14 put ,x :sdsnamstr,a;
15 end while;
16 put ,skip;
17 listl(listsw=no) put ,skip; listl(yes)
18 end subr toklist;
1 .=member sdsnamr
2 subr sdsnamr(hap); $ get string form of ha entry
3 $ convert name in names array to self defined string and
4 $ return it in global variable sdsnamstr.
5 size hap(ps); $ ha ptr
6 size i(ps); $ do loop index
7
8 .len. sdsnamstr = 0;
9 if (hap<1 ! hap>hamax) return;
10 .len. sdsnamstr = ha_len ha(hap); $ set length field
11 if (.len. sdsnamstr = 0) return;
12 do i = 1 to (ha_len ha(hap) -1) / cpw+1;
13 .f.(1+.sds. toklenmax)-ws*i,ws,sdsnamstr
14 = names(ha_names ha(hap)+i-1);
15 end do;
16
17 end subr sdsnamr;
1 .=member insnam
2 subr insnam(hap); $ insert name into ha.
3
4
5 $ return the ha-index of an item, inserting it in the ha if
6 $ necessary.
7
8 size hcode(ws); $ hash code of name
9 size j(ps); $ ha-index of entry benng probed
10 size tokwords(ps); $ words in token.
11 size hap(ps); $ ha-index returned
12 size i(ps); $ do look index
13 size l(ps); $ token length in characters.
14 size ara(ws); dims ara((toklenmax+2*cpw)/cpw);
15 size probes(ps); $ probes this search.
16
17 l = .len. insnamstr;
18 tokwords = (l+(cpw-1)) / cpw;
19 if (l = 0) tokwords = 0;
20 do i = 1 to tokwords;
21 ara(i) = .f. (1+.sds. toklenmax)-i*ws, ws, insnamstr;
22 end do;
23 i = tokwords*cpw - l; $ get number of chars to clear
24 if (i) .f. 1, i*cs, ara(tokwords) = blankword;
25 hcode = ara(1);
26 do i = 2 to tokwords; $ compute hash code
27 hcode = hcode .ex. ara(i);
28 end do;
29 hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
30 if (hcode >= hamax) hcode = hcode-hamax*(hcode/hamax);
31 if hcode = 0 then hcode = hamax-2; end if; $ 0 code forbidden
32 probes = 0; j = 1;
33
34 while 1;
35 if (probes > hamax) call ermey(3); $ ha is full-
36 probes = probes + 1;
37 j = j + hcode; $ add original hashcode for next probe loc
38 if (j>hamax) j = j - hamax;
39 if (ha_names ha(j) = 0) quit while; $ empty slot found
40 if (ha_len ha(j) ^= l) cont while;
41 do i = 1 to tokwords; $ compare names
42 if (names(ha_names ha(j)+i-1) ^= ara(i)) cont while;
43 end do;
44 hap = j;
45 return;
46 end while;
47
48 $ add new name to ha.
49 haused = haused + 1;
50 ha_len ha(j) = l; $ number of chars in name
51 ha_names ha(j) = namesptr + 1;
52 do i = 1 to tokwords ; $ enter name in names array
53 countup(namesptr, namesmax, 'insert name');
54 names(namesptr) = ara(i);
55 end do;
56 hap = j;
57 end subr insnam;
1 .=member ermet
2 subr ermet; $ syntactic error message output procedure
3
4 $ report error number given by global ermsgno. list current
5 $ line, increment count, and terminate if error limit exceeded.
6
7 terml(yes); $ give output to terminal too
8 call lstlin; $ list current line.
9 nerrors = nerrors + 1; $ update error count
10 put ,error_notice;
11
12 if ermsgno<1 ! ermsgno>parseerrmax then
13 go to e(0);
14 else
15 go to e(ermsgno) in 1 to parseerrmax;
16 end if;
17
18 +* et (erform, ertext) =
19 call ermlst(erform, ertext); go to return; **
20 / e( 0) /
21 put ,'syntactic error number ' :ermsgno,i ,skip;
22 go to return;
23 / e( 1) /
24 et('$definer', 'valid definer');
25 / e( 2) /
26 et('$<', '< before definer name');
27 / e( 3) /
28 et('< $name', 'definer name');
29 / e( 4) /
30 et('', '> after definer name');
31 / e( 5) /
32 et('= $definer', '');
33 / e( 6) /
34 et('=direct $/', '/ after direct part');
35 / e( 7) /
36 et('<* $name', 'name of lexical item');
37 / e( 8) /
38 et('<*name $>', '> after lexical name');
39 / e( 9) /
40 et('< $name', 'expect name after >');
41 / e(10) /
42 et('', '> after subpart name');
43 / e(11) /
44 et('', '> after subpart name');
45 / e(12) /
46 et('( act $)', 'parenthesis after action');
47 / e(13) /
48 et('+ $name', 'definer name');
49 / e(14) /
50 et('set $(', 'parenthesis after set');
51 / e(15) /
52 et('set( $int', 'register number');
53 / e(16) /
54 et('set(int $,', 'comma after register number');
55 / e(17) /
56 et('set(int , $int', 'integer');
57 / e(18) /
58 et('set(int , int $)', 'parenthesis to end set');
59 / e(19) /
60 et('m $(', 'parenthesis after m');
61 / e(20) /
62 et('m ( $int', 'integer for mark');
63 / e(21) /
64 et('m ( int $)', 'parenthesis to end mark op');
65 / e(22) /
66 et('- $int', 'error number');
67 / e(23) /
68 et('string $=', 'equal sign after string');
69 / e(24) /
70 et('string = $int','integer for option, lexmap or litmap');
71 /return/;
72 call toklist; $ list recent tokens
73
74 if nerrors>pelvalue then $ quit if too many errors.
75 put ,skip ,error_notice;
76 put ,'error limit of ':pelvalue,i;
77 put ,' exceeded. compilation aborted.' ,skip(2);
78 call synexit(1);
79 end if;
80
81 terml(no); $ done with terminal output
82 return;
83 macdrop(parseerrmax)
84 end subr ermet; $ of syntactic error printer
85
86 subr ermlst(erform,ertext); $ list error message fragment
87
88 $ this procedure, called only from ermes, lists part of syntacti
89 $ error message.
90 size erform(ws+1); $ text giving position in parse
91 size ertext(ws+1); $ text for diagnostic
92 if .len. erform then put,'syntax '''; put:erform,a; put,''' ';
93 end if;
94 if .len. ertext then $ if text.
95 put, ' expect ': ertext, a;
96 end if;
97 put ,skip;
98 end subr ermlst;
1 .=member ermsg
2 subr ermsg(n); $ semantic error message procedure
3 +* ender = go to return;**
4 +* ernam = go to endwithname; ** $ end message with name.
5 $ error message subprocedure
6
7 size n(ps); $ error number
8
9 terml(yes); $ write error message to terminal file
10 call lstlin; $ list current line.
11 if n = 15 then $ this is a warning
12 put ,warning_notice;
13 nwarnings = nwarnings + 1;
14 else
15 put,error_notice;
16 nerrors = nerrors + 1;
17 end if;
18 +* maxerrors = 20 ** $ maximum number of errors
19 if (n < 1 ! n > maxerrors) go to l(1);
20 go to l(n) in 1 to maxerrors;
21 $ we allow room for up to maxerrors error messages
22 $ unused slots branch to l(1), to list short text and number.
23 / l( 1) /
24 put ,'ermsg error number ':n,i; ender;
25 / l( 2) /
26 put ,'conditional branch to nonexistent next definer.'; ender;
27 / l( 3) /
28 put ,'redefining variable'; ernam;;
29 / l( 4) /
30 put ,'missing secondary item in definer.'; ender;
31 / l( 5) /
32 put ,'too many secondary items in definer.'; ender;
33 / l( 6) /
34 put ,'invalid register number.': ermsgarg,i; ender;
35 / l( 7) /
36 put ,'integer value out of range.': ermsgarg,i; ender;
37 / l( 8) /
38 put ,'undefined symbol used.'; ernam;;
39 / l( 9) /
40 put ,'undefined lexical item. '; ernam;;
41 / l(10) /
42 put ,'undefined literal. '; ernam;;
43 / l(11) / put ,'action string truncated.'; ender;
44 / l(12) /
45 put ,'name in use, cannot use for lexical '; ernam
46 / l(13) /
47 put ,'lexical code already assigned '; ernam;;
48 / l(14) /
49 put ,'name in use, cannot use for literal '; naml(ermsgarg);
50 ender;
51 / l(15) /
52 put ,'literal code already assigned '; ernam;;
53 / l(16) /
54 put ,'name in use, cannot use for action. '; naml(ermsgarg);
55 ender;
56 / l(17) /
57 put ,'lexical map not given for '; ernam;;
58 / l(18) /
59 put ,'literal map not given for '; ernam;;
60 / l(19) /
61 put ,'premature end of input forces termination.' ;ender;
62 / l(20) /
63 go to l(1);
64 /endwithname/ $ put name of ha(ermsgarg).
65 naml(ermsgarg); ender;
66 /return/
67 put ,skip;
68 call toklist; $ list recent tokens
69 if nerrors>pelvalue then $ quit if too many errors.
70 put ,skip, error_notice;
71 put ,'error limit of ': pelvalue, i;
72 put ,' exceeded. run aborted.' ,skip(2);
73 call synexit(1);
74 end if;
75 terml(no); $ done with terminal output
76 macdrop(maxerrors) macdrop(ernam)
77 end subr ermsg;
1 .=member ermey
2 subr ermey(n); $ terminal error message procedure
3 size n(ps); $ error number
4
5 terml(yes); $ write output to terminal
6 put ,system_notice;
7 +* maxerrors = 9 **
8 if (n < 1 ! n > maxerrors) go to l(1);
9 go to l(n) in 1 to maxerrors;
10 +* em = go to exit; **
11 / l(1) / put ,'fatal error number ' :n,i; em;
12 / l(2) / put ,'parse control stack underflow'; em
13 / l(3) / put ,'symbol table full.'; em
14 / l(4) /
15 / l(5) /
16 / l(6) /
17 / l(7) /
18 / l(8) /
19 go to l(1);
20 / l(9) / put ,'bad token lexical type'; em
21 macdrop(em) macdrop(maxerrors)
22 /exit/
23 put ,skip; call toklist;
24 terml(no); $ done with output to terminal
25 call synexit(1); $ abort - fatal error
26 end subr ermey;
27
1 .=member gnam
2 subr gnam; $ process definer name, start definer.
3
4 if jumpnext then $ there is a missing next direct item
5 jumpnext = 0;
6 call ermsg(2);
7 end if;
8
9 if ha_pt ha(arg) then $ name already defined
10 ermsgarg = arg;
11 call ermsg(3);
12 return;
13 end if;
14
15 ha_pt ha(arg) = ptablim + 1;
16
17 $ see if 'error' clause which is target of error check.
18 if (ha_synlc ha(arg) = lc_error) errloc = ptablim + 1;
dsd 21 if setlopt then
dse 8 if (ha_synlc ha(arg) = lc_errmp) errmploc = ptablim + 1;
dsd 23 end if;
19 end subr gnam;
1 .=member gdir
2 subr gdir; $ begin direct part.
3 $ if there are forward references to this rule, indicated
4 $ by nonzero jumpnext, set ha_pt to current ptab entry
5
6
7 defptr = 0; $ reset deftab pointer.
8
9 if jumpnext then
10 ha_pt ha(jumpnext) = ptablim + 1;
11 jumpnext = 0;
12 end if;
13 end subr gdir;
1 .=member galt
2 subr galt; $ process alternate part.
3
4 $ merge primtab and sectab into ptab.
5 $ check that there are the correct number of secondary items.
6
7 size pp(ps); $ primtab temp pointer
8 size sp(ps); $ sectab temp pointer
9 size op(ps); $ parse opcode
10 size sop(ps); $ secodary item opcode
11
12 definertot = definertot + 1; $ number of definers
13 pp = 1; $ primary pointer
14 sp = secptr; $ secondary pointer
15 while pp < secptr;
16 op = parse_op deftab(pp); $ check to see if op requires sec
17 countup(ptablim, ptabmax, 'ptab');
18 ptab(ptablim) = deftab(pp);
19 if op=op_lex ! op=op_lit ! op=op_sub then
20 if sp > defptr then
21 call ermsg(4); $ no more secondary
22 return;
23 end if;
24 sop = parse_op deftab(sp); $ check for op_set operation,
25 $ in which case the secondary
26 $ consists of two items
27
28 countup(ptablim, ptabmax, 'ptab');
29 ptab(ptablim) = deftab(sp);
30 sp = sp + 1;
31 if sop = op_set then
32 countup(ptablim, ptabmax, 'ptab');
33 ptab(ptablim) = deftab(sp);
34 sp = sp + 1;
35 end if;
36 end if;
37 pp = pp + 1; $ prim tab pointer
38 end while;
39
40 if (sp <= defptr) call ermsg(5); $ too many secondaries
41
42 $ if direct part ends with jmp, can omit bak after direct part.
43 if secptr>1 then $ if direct part not empty.
44 if (parse_op deftab(secptr-1) = op_jmp) return;
45 end if;
46
47 parseskel = 0;
48 parse_op parseskel = op_bak;
49 countup(ptablim, ptabmax, 'ptab');
50 ptab(ptablim) = parseskel;
51 end subr galt;
1 .=member glex
2 subr glex; $ process <*name> - lexical.
3 size hap(ps); $ ha index.
4
5 hap = arg;
6 call setmtyp(hap, mtyp_lex);
7
8 if ha_mtyp ha(hap) ^= mtyp_lex then $ if wrong type.
9 ermsgarg = hap; call ermsg(12);
10 end if;
11
12 if ha_mval ha(hap) = 0 then $ if need new count.
13 if lexmapflag then $ if missing map value.
14 ermsgarg = hap; call ermsg(17);
15 else $ if syn is to assign.
16 mtyptot(mtyp_lex) = mtyptot(mtyp_lex) + 1;
17 ha_mval ha(hap) = mtyptot(mtyp_lex);
18 if (ha_len ha(hap)>lexlenmax) lexlenmax = ha_len ha(hap);
19 end if;
20 end if;
21
22 emitop(op_lex, hap);
23 end subr glex;
1 .=member glit
2 subr glit; $ process literal.'
3
4 size hap(ps); $ ha index.
5
6 hap = arg;
7 call setmtyp(hap, mtyp_lit);
8
9 if ha_mtyp ha(hap) ^= mtyp_lit then $ if wrong type.
10 ermsgarg = hap; call ermsg(12);
11 end if;
12
13 if ha_mval ha(hap) = 0 then $ if need new count.
14 if litmapflag then $ if missing map value.
15 ermsgarg = hap; call ermsg(17);
16 else $ if syn is to assign..
17 mtyptot(mtyp_lit) = mtyptot(mtyp_lit) + 1;
18 ha_mval ha(hap) = mtyptot(mtyp_lit);
19 if (ha_len ha(hap)>litlenmax) litlenmax = ha_len ha(hap);
20 end if;
21 end if;
22
23 emitop(op_lit, hap);
24 end subr glit;
1 .=member gact
2 subr gact; $ process action.
3
4 size parenct(ps); $ parenthesis counter
5 size i(ps);
6 size lcnow(ps); $ current length of code string.
7 size lcnew(ps); $ new length of code string.
8 size hap(ps); $ ha index of generated item.
9 size codestr(.sds. toklenmax); $ code string.
10 size ln(ps); $ length of current token.
11
12 codestr = '' .pad. toklenmax;
13 .len. codestr = 0;
14 parenct = 1; $ have parsed one left paren
15
16 while 1;
17 call nextok; $ get next token
18 if (toklc = lc_lparen) parenct = parenct + 1;
19 if (toklc = lc_rparen) parenct = parenct - 1;
20 if (parenct = 0) quit while;
21 keeptok = no; $ accept token.
22 $ append current token and blank to codestr.
23 lcnow = .len. codestr;
24 ln = .len. insnamstr;
25 lcnew = lcnow + ln + 1;
26 assert lcnew <= toklenmax;
27 .len. codestr = lcnew;
28 .s. 1+lcnow, ln+1, codestr = insnamstr;
29 end while;
30
31 keeptok = yes; $ reject token.
32 .len. codestr = (.len. codestr) - 1; $ eliminate last blank.
33 .len. insnamstr = .len. codestr;
34 .s. 1, (.len. codestr), insnamstr = codestr;
35 call insnam(hap);
36 call setmtyp(hap, mtyp_act); $ set to action type.
37 if ha_mtyp ha(hap) ^= mtyp_act then $ if wrong type.
38 ermsgarg = hap; call ermsg(16);
39 return;
40 end if;
41
42 if ha_mval ha(hap) = 0 then $ if need new code.
43 mtyptot(mtyp_act) = mtyptot(mtyp_act) + 1;
44 ha_mval ha(hap) = mtyptot(mtyp_act);
45 end if;
46 emitop(op_act, hap); $ emit op_act item
47 end subr gact;
1 .=member gset
2 subr gset; $ process set operation.
3
4 $ emit a set_op. int1 stores register number
5 $ and -ival- stores value
6
7 if int1 > 8 ! int1<1 then
8 ermsgarg = int1; call ermsg(6);
9 return;
10 end if;
11 if ival > maxint then
12 ermsgarg = ival; call ermsg(7);
13 return;
14 end if;
15
16 parseskel = 0;
17 parse_op parseskel = op_set;
18 parse_parm1 parseskel = int1 - 1;
19 parse_parm2 parseskel = ival;
20 countup(defptr, deftabdim, 'deftab');
21 deftab(defptr) = parseskel;
22 end subr gset;
1 .=member ptlist
2 subr ptlist; $ list pt.
3
4
5 size i(ps); $ do loop variable
6 size op(ps); $ opcode
7 size prm(ps); $ parse parameter
8 size pti(ps); $ loop index.
9 size oper(ps); $ op value.
10 size parm(ps); $ parm value.
11 size isalab(ptabmax); $ bit i on if ptab(i) defines label.
12 size isxlab(ptabmax); $ to record extra label definitions.
13
14
15 +* lamax = 200 ** $ maximum label count for list.
16 size laha(ps); dims laha(lamax);
17 size lapt(ps); dims lapt(lamax);
18 size laptr(ps); $ la index.
19 size hex4(.sds. 4); $ convert to 4 hex digits.
20 size name8(.sds. 8); $ give first 8 chars of name.
21 size lai(ps), li(ps); $ la indexes.
22 size res4(.sds. 4); $ resolves pt entry into string.
23 size ent(ps); $ copy of ptab entry.
24
25 call stitlr(1, 'parse table list.');
26 put ,page;
27
28 $ mark label points.
29 laptr = 0;
30 isalab = 0;
31
32 do i = 1 to hamax;
33 if ha_pt ha(i) then $ if label.
34 .f. ha_pt ha(i), 1, isalab = yes;
35 countup(laptr, lamax, 'la');
36 laha(laptr) = i;
37 lapt(laptr) = ha_pt ha(i);
38 end if;
39 end do;
40
41 isxlab = 0;
42 do i = 1 to haxtrap;
43 if ha_pt ha(i+hamax) then $ if extra label.
44 .f. ha_pt ha(i+hamax), 1, isxlab = 1;
45 end if;
46 end do;
47
48 put ,skip;
49
50 do i = 1 to ptablim;
51 op = parse_op ptab(i);
52 prm = parse_parm ptab(i);
53 ent = ptab(i);
54 put ,x(2) :hex4(i),a(4), x(2); $ pt index in hex.
55 put :res4(i),a(4);
56 put ,x(2) :i,i(5) ,x(2);
57 lai = 0; $ set nonzero if is label definition.
58 if .f. i, 1, isalab then $ if label.
59 do li = 1 to laptr;
60 if lapt(li) = i then $ if found.
61 lai = li;
62 quit do;
63 end if;
64 end do;
65 end if;
66 if lai then $ if label.
67 put :name8(laha(lai)),a(8);
68 elseif .f. i, 1, isxlab then $ if extra label.
69 put ,'-' ,x(7);
70 else
71 put ,x(8);
72 end if;
73
74 put ,x(2) :opnames(op+1),a(3);
75
76 go to l(op) in 1 to 15;
77 /l(op_bak)/
78 go to el;
79 /l(op_set)/
80 put :(parse_parm1 ptab(i)+1),i(5) ,' ='
81 :(parse_parm2 ptab(i)),i;
82 go to el;
83 /l(op_err)/ /l(op_op1)/ /l(op_op2)/ /l(op_op3)/
84 /l(op_op4)/ /l(op_op5)/
85 put :prm,i(5) ,x(3);
86 go to el;
87 /l(op_act)/ /l(op_lex)/ /l(op_lit)/
88 $ if need to list mval.
89 put :(ha_mval ha(prm)),i(5) ,x(3);
90 naml(prm);
91 go to el;
92 /l(op_jif)/ /l(op_jmp)/ /l(op_sev)/ /l(op_sub)/
93 $ if need parse table index.
94 put :(ha_pt ha(prm)),i(5) ,x(3);
95 if (prm<=hamax) then naml(prm); end if;
96 /el/;
97
98 put ,skip;
99 end do;
100 call stitlr(1, ' '); $ clear subtitle.
101 put ,skip;
102 end subr ptlist;
1 .=member res4
2 fnct res4(pti); $ resolve ptab entry.
3
4 size pti(ps); $ ptab index.
5 size op(ps); $ parse op.
6 size prm(ps); $ parameter field.
7 size ent(ps); $ resolved value.
8 size res4(.sds. 4); $ function value.
9 size hex4(.sds. 4); $ converts entry to hex string.
10
11
12 op = parse_op ptab(pti);
13 prm = parse_parm ptab(pti);
14 ent = ptab(pti);
15 go to l(op) in 1 to 15;
16 /l(op_bak)/ /l(op_err)/ /l(op_op1)/ /l(op_op2)/
17 /l(op_op3)/ /l(op_op4)/ /l(op_op5)/ /l(op_set)/
18 res4 = hex4(ent);
dsc 18 go to ret;
20
21 /l(op_act)/ /l(op_lex)/ /l(op_lit)/
22 parse_parm ent = ha_mval ha(prm);
23 res4 = hex4(ent);
dsc 19 go to ret;
25
26 /l(op_jif)/ /l(op_jmp)/ /l(op_sev)/ /l(op_sub)/
27 $ resolve pt label.
28 if ha_pt ha(prm) then $ if resolved.
29 parse_parm ent = ha_pt ha(prm);
30 res4 = hex4(ent);
31 else $ if unresolved.
32 res4 = hex4(ent); .s. 1, 3, res4 = '***';
33 end if;
dsc 20 /ret/ $ here to return, set res4ent to binary value.
dsc 21 res4ent = ent;
34 end fnct res4;
1 .=member name8
2 fnct name8(hap); $ put first 8 chars of name.
3
4 size name8(.sds. 8);
5 size hap(ps); $ ha index.
6 size l(ps); $ name length.
7
8 name8 = ''.pad.8;
9 if (hap=0) return;
10 call sdsnamr(hap);
11 l = ha_len ha(hap);
12 if (l>8) l=8;
13 .s. 1, l, name8 = sdsnamstr;
14 end fnct name8;
1 .=member ptout
2 subr ptout; $ write out parse table.
3
4 size i(ps);
5 size j(ps);
6 size nl(ps); $ number of items per line printed.
7 size cpl(ps); $ constants per line.
8 size pti(ps); $ parse table index.
9 size li(ps); $ line index.
10 size ci(ps); $ constant index.
11 size ei(ps); $ entry index.
12 size hex4(.sds. 4); $ hex conversion function.
13 size res4(.sds. 4); $ converts pt entry to string.
14 size hap(ps); $ ha index.
15 size s3(.sds. 3); $ implicit macro string.
dsc 22 size s4(.sds.4); $ work string.
16
17 +* pup = put parsefile **
18
19 call putmem(0, 'tab');
20
21 $ write out parse table as series of byte constants. put a
22 $ comma or blank after each constant so can read using l
23 $ mode format, and put a semicolon after last constant so can
24 $ use as body of data statement. put a sequence field on each
25 $ line.
26
27 assert (epc>=1) & (epc<=10);
28 cpl = 60 / (10 + 5*(epc-1));
29 if (cpl=0) cpl = 1;
30 $ round up ptablim to be multiple of epc.
31 ptablimout = epc * ((ptablim + epc-1) / epc);
32
33 do i = ptablim+1 to ptablimout; ptab(i) = 0; end do;
34
35 pti = 0; $ index in ptab of entry.
36
37 do li = 1 to ptablimout/(epc*cpl) + 1;
38 pup ,x(5); $ start line.
39 do ci = 1 to cpl; $ for each constant.
40 pup ,' 4b'''; $ begin constant.
41 do ei = 1 to epc; $ for each entry in constant.
42 pti = pti + 1; $ next ptab entry.
43 if pti <= ptablim then $ if actual parse op.
44 pup :res4(pti),a(4);
45 else $ if rounding out table.
46 pup ,'0000';
47 end if;
48 if ei < epc then $ if need blank after constant.
49 pup ,x;
50 end if;
51 end do ei;
52 if pti = ptablimout then $ if last constant.
53 pup ,''' ;'; quit do ci;
54 end if;
55 pup ,''',';
56 end do ci;
57 pup ,column(67) ,'$' :li,i(4) ,skip; $ sequence field.
58 if (pti=ptablimout) quit do;
59 end do li;
60
61 pup ,skip;
62
63 call putmem(1, 'tab');
64
65 call putmem(0, 'mac');
66
67 pup ,' $ syn run on ' :timestr,a ,skip(2);
68 call putmac('aramax', ptablimout);
69 call putmac('litaramax', mtyptot(mtyp_lit));
70 call putmac('lexaramax', mtyptot(mtyp_lex));
71 call putmac('actmax', mtyptot(mtyp_act));
72 if errloc then $ write location of error recovery
73 call putmac('errloc', errloc);
74 end if;
dse 9 if setlopt>0 & errmploc>0 then $ write location of errmp symbol
dse 10 call putmac('errmploc', errmploc);
dsd 26 end if;
75 call putmac('errmax', errmax);
dsh 10 if setlopt then $ if want count of implicit macros.
dsh 11 do i = 1 to 26;
dsh 12 if (imara(i) = 0) cont do;
dsh 13 j = imara(i); $ get map type.
dsh 14 s3 = 'im '; .ch. 3, s3 = .ch. i, alphabet; $ find name.
dsh 15 li = 0; $ li counts number of entries.
dsh 16 hap = mtyporg(j);
dsh 17 while hap;
dsh 18 li = li + 1;
dsh 19 hap = ha_next ha(hap);
dsh 20 end while;
dsh 21 call putmac(s3.cc.'max', li);
dsh 22 end do;
dsh 23 end if;
76 call putmem(1, 'mac');
77
78 call putmem(0, 'lex');
79
80 hap = mtyporg(mtyp_lex);
81 while hap;
82 call sdsnamr(hap); $ get name of lexical item.
83 pup ,x(6) ,'synlexmap(' :sdsnamstr,al;
84 if filestat(parsefile,column) < 30 then
85 pup ,column(30);
86 end if;
87 pup ,',' :(ha_mval ha(hap)),i(4) ,')' ,skip;
88 hap = ha_next ha(hap);
89 end while;
90
91 call putmem(1, 'lex');
92
dse 11 if setlopt then $ if want member giving number of literals.
dse 12 call putmem(0, 'max');
dse 13 i = 0;
dse 14 hap = mtyporg(mtyp_lit);
dse 15 while hap;
dse 16 i = i + 1;
dse 17 hap = ha_next ha(hap);
dse 18 end while;
dse 19 call putmac('litmax', i);
dse 20 call putmem(1, 'max');
dse 21 end if;
dse 22
93 call putmem(0, 'lit');
94
95 hap = mtyporg(mtyp_lit);
96 while hap;
97 call sdsnamr(hap); $ get name of lexical item.
98 pup ,x(6) ,'synlitmap(' :sdsnamstr,al;
99 if filestat(parsefile,column) < 30 then
100 pup ,column(30);
101 end if;
102 pup ,',' :(ha_mval ha(hap)),i(4) ,')' ,skip;
103 hap = ha_next ha(hap);
104 end while;
105
106 call putmem(1, 'lit');
107
108 $ write out actions.
109
110 call putmem(0, 'act');
111
112 hap = mtyporg(mtyp_act);
113 while hap;
114 pup ,' / pa(' :(ha_mval ha(hap)),i(4), ') / ';
115 call sdsnamr(hap);
116 if .ch. 1, sdsnamstr = 1r- then $ if no want call
117 pup :(.s. 2, .len. sdsnamstr-1, sdsnamstr),a ,';';
118 else
119 pup ,' call ' :sdsnamstr,a ,';';
120 end if;
121 if ('- go to ' .in. sdsnamstr) = 1 then $ if go to.
122 pup ,skip;
123 else $ if need pac macro after generator.
124 if filestat(parsefile,column) < 65 then
125 pup ,column(65);
126 end if;
127 pup ,' pac;' ,skip;;
128 end if;
129 hap = ha_next ha(hap);
130 end while;
131
132 call putmem(1, 'act');
133
134 $put out members for any implicit macros.
135 do i = 1 to 26;
136 if (imara(i) = 0) cont do;
137 j = imara(i); $ get map type.
138 s3 = 'im '; .ch. 3, s3 = .ch. i, alphabet; $ find name.
139 call putmem(0, s3); $ start member.
140 hap = mtyporg(j);
141 while hap;
142 call sdsnamr(hap); $ get name.
143 pup ,x(6) ,'syn' :s3,a(3) ,'map(' :sdsnamstr,a;
144 if filestat(parsefile, column) < 30 then
145 pup ,column(30);
146 end if;
147 pup ,',' :(ha_mval ha(hap)),i(4) ,')' ,skip;
148 hap = ha_next ha(hap);
149 end while;
150 call putmem(1, s3); $ end member.
dsc 23 if setlopt then $ if setl option, write 'mark' map.
dsc 24 call putmem(0, 'mark'); $ start member.
dsc 25 hap = mtyporg(j);
dsc 26 while hap;
dsc 27 call sdsnamr(hap); $ get name.
dsc 28 pup ,x(6) ,'syn' :'mark',a(4) ,'map(' :sdsnamstr,a;
dsc 29 if filestat(parsefile, column) < 30 then
dsc 30 pup ,column(30);
dsc 31 end if;
dsc 32 pup ,', ''' :.s.3,(.len.sdsnamstr-2),sdsnamstr,a
dsc 33 ,''')' ,skip;
dsc 34 hap = ha_next ha(hap);
dsc 35 end while;
dsc 36 call putmem(1, 'mark'); $ end member.
dsc 37 end if setlopt;
dsc 38
dsc 39 if setlopt then $ if setl option, write 'sem' map.
dsc 40 call putmem(0, 'sem'); $ start member.
dsc 41 hap = mtyporg(j);
dsc 42 while hap;
dsc 43 call sdsnamr(hap); $ get name.
dsc 44 pup ,x(6) ,'syn' :'sem',a(3) ,'map(' :sdsnamstr,a;
dsc 45 if filestat(parsefile, column) < 30 then
dsc 46 pup ,column(30);
dsc 47 end if;
dse 23 pup ,', g' :.s.3,(.len.sdsnamstr-2),sdsnamstr,a
dsc 49 ,')' ,skip;
dsc 50 hap = ha_next ha(hap);
dsc 51 end while;
dsc 52 call putmem(1, 'sem'); $ end member.
dsc 53 end if setlopt;
dsc 54
151 end do;
152
dsf 26 if (asmtype^=0) call ptasm; $ if want assembler text.
dsc 55 $ if setl option and no errors, write binary file.
dsc 56 if setlopt & (nerrors=0) then
dsi 28 file binfile access=write ,title=binfilename;
dsc 58 do i = 1 to ptablimout;
dse 24 if (i>ptablim) cont do;
dsc 59 s4 = res4(i); $ resolve entry.
dsc 60 ptab(i) = res4ent; $ convert to resolved binary.
dsc 61 end do;
dsc 62 write binfile, ptab(1) to ptab(ptablimout);
dsf 27 file binfile access=release;
dsc 63 end if;
153 macdrop(pup)
154 end subr ptout;
1 .=member ptasm
2 subr ptasm; $ write parse table data in assembler format.
3 $ write parse table to unit 6 in form appropriate for target
4 $ machine, according to machine used or value of tm= program
5 $ parameter. write the parse table as follows
6 $ 1. initial line (machine-dependent)
7 $ 2. ptbeg macro call, operand is dimension
8 $ 3. series of ptval macro calls
9 $ 4. ptend macro call
10 $ 5. final line (machine-dependent)
11 $ for example, for cdc 6600 (s66), little code corresponding to
12 $
13 $ subr ptinit;
14 $ nameset nsptab;
15 $ size pt(.ws.); dims pt(3); data pt = 10, 20, 30;
16 $ end nameset;
17 $ end subr;
18 $
19 $ yields
20 $
21 $ ident ptinit
22 $ ptbeg 3
23 $ ptval 10
24 $ ptval 20
25 $ ptval 30
26 $ ptend
27 $ end
28 $
29 $ operators begin in column 9 and operands in column 17 if possible.
30
31 size i(.ps.); $ loop index.
32 size res4(.sds. 4); $ function value.
33 size s4(.sds. 4); $ holds string resul of res4 call.
34 size ptv(ws); $ binary value of parse table entry.
35
dsi 29 file asmfile access=put, title=asmfilename, linesize=80;
37
38 if asmtype = 10 then $ if s10.
dsg 8 put asmfile ,column(9) ,'search synmac' ,skip;
40 elseif asmtype = 32 then $ if s32
41 put asmfile ,column(9) ,'.title' ,column(17) ,'ptinit' ,skip;
42 elseif asmtype = 37 then $ if s37
43 ; $ no initial line required for s37.
44 elseif asmtype = 66 then $ if s66
45 put asmfile ,column(9) ,'ident' ,column(17) ,'ptinit' ,skip;
46 end if;
47 put asmfile ,column(9) ,'ptbeg'
48 ,column(17) :ptablimout,i ,skip;
49 do i = 1 to ptablimout;
50 if i<=ptablim then $ if nonzero entry.
51 s4 = res4(i); $ resolve entry.
52 ptv = res4ent; $ get binary value.
53 else ptv = 0; end if;
dsi 30 put asmfile ,column(9) ,'ptval' ,column(17)
dsi 31 :(.f. 1, parsesz, ptv),i ,skip;
55 end do;
56 put asmfile ,column(9) ,'ptend' ,skip;
57
58 $ write terminal line according to target machine.
59 if asmtype = 10 then $ if s10.
60 put asmfile ,column(9) ,'end' ,skip;
61 elseif asmtype = 32 then $ if s32.
62 put asmfile ,column(9) ,'.end' ,skip;
63 elseif asmtype = 37 then $ if s37.
64 put asmfile ,column(9) ,'end' ,skip;
65 elseif asmtype = 66 then $ if s66.
66 put asmfile ,column(9) ,'end' ,skip;
67 end if;
68 file asmfile access=release;
69 end subr ptasm;
1 .=member putmac
2 subr putmac(lab, val); $ put macro definition to parse file.
3 size lab(.sds. 10); $ macro name.
4 size val(ws); $ value to put.
5
6 put parsefile ,x(6) ,'+* ' :macroprefix,a :lab,a
7 ,' = ' :val,i ,' **' ,skip;
8 end subr putmac;
1 .=member putmem
2 subr putmem(c, str); $ put member descriptor to parse file.
3 size c(1); $ zero for start, one for end.
4 size str(.sds.3); $ member suffix.
5
6 if c = 0 then $ if starting member.
7 put parsefile ,' .=member ' :memberprefix,a :str,a ,skip
8 ,' $ member ' :memberprefix,a :str,a ,skip;
9 elseif c = 1 then $ if ending member.
10 put parsefile ,' $ end member ' :memberprefix,a :str,a ,skip;
11 else assert 0=1; $ if invalid case.
12 end if;
13 end subr putmem;
14 fnct hex4(v); $ convert to four hex digits.
15
16 size v(ws);
17 size hex4(.sds. 4);
18 size i(ps); $ byte index.
19 size j(ps); $ temporary.
20
21 hex4 = ''.pad.4;
22 do i = 1 to 4;
23 j = .f. 17-i*4, 4, v;
24 .ch. i, hex4 = hexcharofdig(j);
25 end do;
26 end fnct hex4;
1 .=member halist
2 subr halist; $ list ha.
3
4 size i(ps);
5
6 call stitlr(1, ''); $ clear subtitle.
7 call etitlr(1, '-ha-', 2, 4);
8 call etitlr(1,
9 'mtyp mval next islbl synlc len names pt symbol',
10 10,65);
11 put ,page;
12
13 do i = 1 to hamax;
14 if (ha_names ha(i) = 0) cont do;
15 put :i :ha_mtyp ha(i) :ha_mval ha(i) :ha_next ha(i)
16 :ha_islbl ha(i) :ha_synlc ha(i)
17 :ha_len ha(i) :ha_names ha(i) :ha_pt ha(i) ,i(6) ,x(2);
18 call sdsnamr(i);
19 put :sdsnamstr,a(40);
20 put ,skip;
21 end do;
22
23 put ,skip ,'ha chain origins: '
24 :mtyporg(mtyp_act),i(6) ,' act'
25 :mtyporg(mtyp_lex),i(6) ,' lex'
26 :mtyporg(mtyp_im1),i(6) ,' im1'
27 :mtyporg(mtyp_im2),i(6) ,' im2'
28 :mtyporg(mtyp_im3),i(6) ,' im3'
29 :mtyporg(mtyp_im4),i(6) ,' im4' ,skip(4);
30 call stitlr(1, ''); $ clear subtitle.
31 call etitlr(1, '', 10, 65); $ clear subtitle.
32 end subr halist;
1 .=member synexit
2 subr synexit(exitcode); $ generator phase exit procedure
3 $ if -exitcode- is non-zero, abnormal end is indicated,
4 $ 0 indicates normal exit.
5 $ collects statistics, signs off, etc.
6
7 size exitcode(ps); $ exit code
8 size i(ps); $ do loop index
9 size iorc(ps); $ io return code.
10 size p(ps); $ ptab pointer
11 size ploc(ps); $ relocation address
12 size hdr(ps); $ header printed flag
13 size j(ps); $ do loop index
14 size op(ps); $ parse tab op.
15 size hap(ps); $ ha index.
16
17 call clossio(tokenfile, iorc);
18
19
20 $ check that labels defined.
21 hdr = no;
22 do i = 1 to ptablim;
23 op = parse_op ptab(i);
24 if op=op_jif ! op=op_jmp ! op=op_sev ! op=op_sub then
25 ploc = ha_pt ha(parse_parm ptab(i));
26 if ploc = 0 then $ if undefined label.
27 nerrors = nerrors + 1;
28 j = parse_parm ptab(i);
29 if hdr = no then $ if need header.
30 hdr = yes;
31 put ,'error - undefined labels: ';
32 end if;
33 if j<=hamax then naml(j); put ,x; end if;
34 if filestat(2, column) > lastcol then
35 put ,skip ,x(6);
36 end if;
37 end if;
38 end if;
39 end do;
40
41 if (hdr) put ,skip;
42
43 $ check for label defined but not used (possible error)
44 do i = 1 to hamax;
45 if ha_islbl ha(i) = 0 & ha_pt ha(i)
46 & ha_synlc ha(i) ^= lc_error then
47 put ,skip ,'label defined and not used: ';
48 naml(i); put ,skip;
49 end if;
50 end do;
51
52 call stitlr(1, 'statistics for syn run.');
53
54 put ,page;
55 put ,'number of lexicals is' :mtypnum(mtyp_lex),i(5) ,'.' ,skip
56 ,'number of literals is' :mtypnum(mtyp_lit),i(5) ,'.' ,skip
57 ,'number of actions is' :mtypnum(mtyp_act),i(5) ,'.' ,skip
58 ,'length of generated parse table is' :ptablim,i(5)
59 ,'.' ,skip;
60
61 errmax = (.fb. errbit - 1)/2 + 1; $ maximum
62 $ error number used.
63 put ,'largest error message number is' :errmax,i(5) ,'.' ,skip;
64
65
66 $ check error numbers
67 hdr = no; $ print header
68 do i = 1 to errmax;
69 if errbits(i) = 0 then
70 if hdr = no then $ print header
71 hdr = yes; $ only print header once
72 put ,'error numbers not used:';
73 end if;
74 if filestat(2, column) > lastcol then
75 put ,skip ,x(10);
76 end if;
77 put :i,i(4);
78 end if;
79 end do;
80
81 if (hdr) put ,skip;
82
83 put ,skip;
84
85 $ check for error numbers reused
86 hdr = no;
87 do i = 1 to errmax;
88 if errbits(i) = 2 then
89 if hdr = no then
90 put ,'multiple use of error numbers:' ,x(2);
91 hdr = yes;
92 end if;
93 if filestat(2, column)>60 then
94 put ,skip ,x(10);
95 end if;
96 put :i,i(4);
97 end if;
98 end do;
99 put ,skip;
100
101 $ print lexical and literal maps
102 put ,skip ,'lexical map used in parse table.' ,skip(2);
103 hap = mtyporg(mtyp_lex);
104
105 while hap;
106 put ,x(6) :(ha_mval ha(hap)),i(5) ,x(2);
107 naml(hap);
108 put ,skip;
109 hap = ha_next ha(hap);
110 end while;
111
112 put ,skip;
113 put ,skip ,'literal map used in parse table.' ,skip(2);
114 hap = mtyporg(mtyp_lit);
115
116 while hap;
117 put ,x(6) :(ha_mval ha(hap)),i(5) ,x(2);
118 naml(hap);
119 put ,skip;
120 hap = ha_next ha(hap);
121 end while;
122
123 put ,skip;
124 terml(yes); $ this goes to terminal
125 if nerrors then
126 put :nerrors,i ,' errors detected by syn.' ,skip;
127 else
128 listl(no); put ,'no detected errors.';
129 put ,skip; listl(yes);
130 end if;
131 terml(no); $ end of terminal listing
132
133 if (halistflag) call halist;
134
135 if (listpt) call ptlist;
136
137 call ptout;
138
139 if exitcode then $ if abnormal termination.
140 terml(yes);
141 put ,error_notice;
142 put ,'abnormal program termination.' ,skip;
143 else $ if normal terminatinon.
144 put ,skip ,'end of syn run.' ,skip(2);
145 end if;
146 terml(no); call clsterm; $ close terminal file
147 call ltlfin(exitcode, (nwarnings^=0) *4 + (nerrors^=0) * 8);
148 end subr synexit;