Views
Document Actions
SYN: Syntax generator for the LITTLE system. By Edith Deak and David Shields.
by
Paul McJones
—
last modified
2021-03-17 18:38
- History
-
Action Performed by Date and Time Comment Publish Paul McJones 2021-03-17 18:38 No comments.
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 >');