Views
Document Actions
GEN: Parse and semantic analysis phase.
by
Paul McJones
—
last modified
2021-03-17 18:30
- History
-
Action Performed by Date and Time Comment Publish Paul McJones 2021-03-17 18:30 No comments.
GEN: Parse and semantic analysis phase.
1 .=member intro
2 $ !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
3 $ the above line contains, in order of ascii codes, the 56
4 $ characters of the little language, starting in column 7.
5
6
7
8
9 /*
10
11 $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$
12 $$ $$$$$$$$$$ $$$$$$$$$$ $$$$$$$$$$ $$ $$$$$$$$$
13 $$ $$ $$ $$ $$ $$
14 $$ $$ $$ $$ $$ $$
15 $$ $$ $$ $$ $$ $$$$$$
16 $$ $$ $$ $$ $$ $$$$$$
17 $$ $$ $$ $$ $$ $$
18 $$ $$ $$ $$ $$ $$
19 $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$
20 $$$$$$$$$$ $$$$$$$$$$ $$ $$ $$$$$$$$$$ $$$$$$$$$
21
22 $$$$$$$$ $$$$$$$$$$ $$ $$
23 $$$$$$$$$$ $$$$$$$$$$ $$$ $$
24 $$ $$ $$ $ $$
25 $$ $$ $$ $$ $$
26 $$ $$$$$ $$$$$$ $$ $$ $$
27 $$ $$$$$ $$$$$$ $$ $$ $$
28 $$ $$ $$ $$ $$ $$
29 $$ $$ $$ $$ $ $$
30 $$$$$$$$$$ $$$$$$$$$$ $$ $$$
31 $$$$$$$$$ $$$$$$$$$$ $$ $$
32
33
34 this software is part of the little programming system.
35 address queries and comments to
36
37 little project
38 department of computer science
39 new york university
40 courant institute of mathematical sciences
41 251 mercer street
42 new york, ny 10012
43
44 this is the second phase of the little compiler. it performs
45 the parse and semantic analysis, and is known as 'gen'.
46
47 the principal authors of the little compiler are
48 robert abes, edith deak, richard kenner, david shields
49 and aaron stein.
50
51
52
53 */
54
55
56
57
1 .=member chars
2 /* little character set and ascii representation
3
4 !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
5 the above line contains, in order of ascii codes, the 56
6 characters of the little language, starting in column 7.
7
8 the little language requires 56 distinct characters.
9 these include the 26 upper case letters, the 10 digits,
10 and the following special characters:
11
12 blank
13 = equal sign, assignment symbol
14 + plus
15 - minus
16 * times, asterisk
17 / divide, slash
18 ( left parenthesis
19 ) right parenthesis
20 , comma
21 . period, point
22 ; semicolon
23 : colon
24 $ dollar sign, comment character
25 ^ not
26 & and
27 ! or
28 < less than
29 > greater than
30 ' apostrophe, string delimiter
31 _ underline, break character
32
33 the following table gives the standard ascii encoding
34 for the little character set.
35
36 little character ascii ascii ascii ascii character
37 (hex) (oct) (dec)
38
39 space 20 40 32 space
40 ! or 21 41 33 exclamation mark
41 $ dollar sign 24 44 36 dollar sign
42 & and 26 46 38 ampersand
43 ' apostrophe 27 47 39 apostrophe
44 ( left parenthesis 28 50 40 left parenthesis
45 ) right parenthesis 29 51 41 right parenthesis
46 * asterisk 2a 52 42 asterisk
47 + plus 2b 53 43 plus
48 , comma 2c 54 44 comma
49 - minus 2d 55 45 minus
50 . period 2e 56 46 period
51 / slash 2f 57 47 slant
52 0 digit 0 30 60 48 digit 0
53 1 digit 1 31 61 49 digit 1
54 2 digit 2 32 62 50 digit 2
55 3 digit 3 33 63 51 digit 3
56 4 digit 4 34 64 52 digit 4
57 5 digit 5 35 65 53 digit 5
58 6 digit 6 36 66 54 digit 6
59 7 digit 7 37 67 55 digit 7
60 8 digit 8 38 70 56 digit 8
61 9 digit 9 39 71 57 digit 9
62 : colon 3a 72 58 colon
63 ; semicolon 3b 73 59 semicolon
64 < less than 3c 74 60 less than
65 = equals 3d 75 61 equals
66 > greater than 3e 76 62 greater than
67 a letter a 41 101 65 letter a
68 b letter b 42 102 66 letter b
69 c letter c 43 103 67 letter c
70 d letter d 44 104 68 letter d
71 e letter e 45 105 69 letter e
72 f letter f 46 106 70 letter f
73 g letter g 47 107 71 letter g
74 h letter h 48 110 72 letter h
75 i letter i 49 111 73 letter i
76 j letter j 4a 112 74 letter j
77 k letter k 4b 113 75 letter k
78 l letter l 4c 114 76 letter l
79 m letter m 4d 115 77 letter m
80 n letter n 4e 116 78 letter n
81 o letter o 4f 117 79 letter o
82 p letter p 50 120 80 letter p
83 q letter q 51 121 81 letter q
84 r letter r 52 122 82 letter r
85 s letter s 53 123 83 letter s
86 t letter t 54 124 84 letter t
87 u letter u 55 125 85 letter u
88 v letter v 56 126 86 letter v
89 w letter w 57 127 87 letter w
90 x letter x 58 130 88 letter x
91 y letter y 59 131 89 letter y
92 z letter z 5a 132 90 letter z
93 ^ not 5e 136 94 circumflex
94 _ underline 5f 137 95 underline
95
96 */
97
1 .=member modform
2 $ every change is to include a description after the card mods.2 in
3 $ the mods deck below.
4 $ mod description is to contain name starting in column 7, author
5 $ name starting in column 17, date starting in column 37, and
6 $ new level established starting in column 57, as follows.
7 $ 1 2 3 4 5 6
8 $ 7890123456789012345678901234567890123456789012345678901234567
9 $ modname author name 10 february 1976 level 76041
10 $
11 $ the 'level' is the julian date of the change and the macro
12 $ 'compilerlevel' should be changed whenever level is changed, so
13 $ that level printed on listing (cf routine genini) will be correct.
14 $ the title is followed by blank line (with $ in column 2), then
15 $ description of purpose of change, and finally list of code
16 $ affected, in following form.
17 $ decks affected - list of decks(routines) affected by this mod.
18
19
20
1 .=member mods
2 $ - - - all changes are to include self-description after mods.2
rbko 1$
rbko 2$ rbko r. kenner 6 june 1982 level 82158
rbko 3$
rbko 4$ print three blanks instead of four in -lstlin- so that tabs imbedd
rbko 5$ in lines being listed come out correctly.
rbko 6$
rbko 7$ decks affected: lstlin
rbko 8$
utsc 1
utsc 2 $ utsc d. shields 18-dec-81 level 81352
utsc 3 $
utsc 4 $ extend ebcasc option so ebcasc=2 folds input to lower case.
utsc 5 $ deck affected - cnvcon.
utsc 6
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 $
utsa 8 $ 1. add option 'ebcasc=0/1' to s37 such that ebcasc=1 causes
utsa 9 $ character string to be converted from ebcdic to ascii.
utsa 10 $ this is needed for uts bootstrap from s37, and would be needed
utsa 11 $ to bootstrap nyu ada/ed to s37.
utsa 12 $ 2. change layout of strings for s37 so same structure for s32,
utsa 13 $ s37 and s47 (.sl.=16, .so.=16).
utsa 14 $ deck added - ebcasc (s37)
utsa 15
eaa 1
eaa 2 $ eaa d. shields 31-aug-81 level 81243
eaa 3 $
eaa 4 $ support new target machine s20 (s10 with extended addressing)
eaa 5 $ by recognizing 'tm=20'. this is s10 except pointer size is 30.
eaa 6 $ decks affected - macros, genini
eaa 7
ldse 1
ldse 2 $ ldse d. shields 24-sep-80 level 80268
ldse 3 $
ldse 4 $ add program parameter 'expire=0/366' such that if expire has
ldse 5 $ non-zero value, then program is to expire (cease execution)
ldse 6 $ the given number of days after compilation. expiration check
ldse 7 $ done by ltllib procedure 'ltlced', parameterized as 'proc_expire'.
ldse 8 $ decks affected - macros, start, genini, gensub.
ldse 9
ldsd 1
ldsd 2 $ ldsd d. shields 30-jul-80 level 80212
ldsd 3 $
ldsd 4 $ 1. do dim offline for s32 to avoid asm problem.
ldsd 5 $ this adds new library function 'mth$dim' for s32.
ldsd 6 $ 2. do aint and amod offline for s32 to avoid problems
ldsd 7 $ in unsupported rtr and rmo t32 operations.
ldsd 8 $ this adds new library functions 'mth$aint' and
ldsd 9 $ 'mth$amod' for s32.
ldsd 10 $ 3. identify s32 dialect in listing header.
ldsd 11 $ 4. increase tlistmax so can compile s32 asm.
ldsd 12 $ 5. check for invalid or out-of-range real constant.
ldsd 13 $ decks affected - macros, start, genini, cnvcon, ermes.
ldsd 14
ldsc 1
ldsc 2 $ ldsc d. shields 21-jul-80 level 80203
ldsc 3 $
ldsc 4 $ 1. fix error (fr139) that caused problems if lcp=0 specified.
ldsc 5 $ 2. avoid needless copy to terminal.
ldsc 6 $ 3. enable pt parse trace for unix checkout.
ldsc 7 $ decks affected - macros, genini, genexit.
ldsc 8
ldsb 1
ldsb 2 $ ldsb d. shields 10-jul-80 level 80192
ldsb 3 $
ldsb 4 $ 1. fix problem (fr135) in setting of termination code.
ldsb 5 $ now issue code 0 if no warnings or errors, code 4 if warnings
ldsb 6 $ and no errors, code 8 if any errors detected.
ldsb 7 $ 2. do not generate 'no errors detected' message.
ldsb 8 $ 4. add conditional symbol -unix- for the unix operating system.
ldsb 9 $ use iset=unix to obtain unix variant.
ldsb 10 $ want listing terse, make lcp=0 and lcs=0 the defaults.
ldsb 11 $ for initial checkout, delete special env code (mova, etc.).
ldsb 12 $
ldsb 13 $ decks affected - macros, genini, genexit.
ldsb 14
ldsa 1
ldsa 2 $ ldsa d. shields 25-mar-80 level 80085
ldsa 3 $
ldsa 4 $ add option 'rep=0/pg' to permit generation of 'report' file on
ldsa 5 $ unit 6. each line on the file is in a format acceptable to
ldsa 6 $ most macro assemblers - columns 1-8 are blank, column 9
ldsa 7 $ contains a one character opcode and the operands, separated
ldsa 8 $ by commas, begin in column 17. opcodes and operands are
ldsa 9 $ c caller_name,called_name,number_args
ldsa 10 $ g var_name,size,dimension,nameset_name,address_offset
ldsa 11 $ n nameset_name,nameset_length
ldsa 12 $ p proc_name,proc_type,proc_args
ldsa 13 $ (type is 1 for subr, 2 for fnct, 3 for prog)
ldsa 14 $ the rep= parameter string may contain letters c, g or p.
ldsa 15 $ if -g- appears in rep parameter string, both -n- and -g- opcodes
ldsa 16 $ are written.
ldsa 17 $ this feature replaces (and extends) the previous pcr feature.
ldsa 18 $ text conditioned by -rep-.
ldsa 19 $ decks affected - macros, start, gensub, sortvars, emcall,
ldsa 20 $ genexit, putrep (new).
ldsa 21
dsz 1
dsz 2 $ dsz d. shields 29-feb-80 level 80060
dsz 3 $
dsz 4 $ report error if function name is unsized in function definition.
dsz 5 $ deck affected - closer.
dsz 6
dsy 1
dsy 2 $ dsy d. shields 29-jan-80 level 80029
dsy 3 $
dsy 4 $ fix error (fr2.3.129) that caused problems if function call
dsy 5 $ and unary operator hashed to same location in basic block.
dsy 6 $ deck affected - emcall.
dsy 7
dsx 1
dsx 2 $ dsx d. shields 10-jan-80 level 80010
dsx 3 $
dsx 4 $ 1. increase hamax from 787 to 937. this requires corresponding
dsx 5 $ change to asm, as ha written to voa file.
dsx 6 $ 2. add (experimental) option pcr (procedure call report) such
dsx 7 $ that pcr=1 causes creation of report on unit 6. each call of
dsx 8 $ subroutine or function is indicated by line with name of
dsx 9 $ caller, a blank and name of procedure called.
dsx 10 $ use conditional assembly option pcr for this.
dsx 11 $ decks affected - macros, start, genini, emcall.
dsx 12
dsw 1
dsw 2 $ dsw d. shields 14-dec-79 level 79348
dsw 3 $
dsw 4 $ extend maximum permitted dimension for s10, s32 and s37 up
dsw 5 $ to 2**n-1 with n=17, 30 and 22, respectively. this involves
dsw 6 $ change to voa, nl, mba and xha, so that voa file format changed.
dsw 7 $ decks affected - macros, start.
dsw 8
dsv 1
dsv 2 $ dsv d. shields 19-nov-79 level 79323
dsv 3 $
dsv 4 $ 1. rewind token file and voa file for s66 only.
dsv 5 $ 2. use getapp (new lib procedure provided by mod dsc) to
dsv 6 $ obtain and list actual parameter string specified by user.
dsv 7 $ 3. delete code to read term= parameter and possibly open
dsv 8 $ terminal file, as this now done by lib (mod dsc).
dsv 9 $ decks affected - macros, genini.
dsv 10
dsu 1
dsu 2 $ dsu d. shields 10-sep-79 level 79253
dsu 3 $
dsu 4 $ fix bug that caused pdir option to work only if lcr option
dsu 5 $ selected (fr2.3.120).
dsu 6 $ deck affected - genini.
dsu 7
mgfc 1
mgfc 2 $ mgfc m.g. ford 15-aug-79 level 79227
mgfc 3 $
mgfc 4 $ issue standard warning and error characters for s10.
mgfc 5 $ decks affected - macros, gtoflo, ermet, ermes, closer, genexit.
mgfc 6
mgfb 1
mgfb 2 $ mgfb m.g. ford 05-jul-79 level 79186
mgfb 3 $
mgfb 4 $ revise s10 to use 9-bit ascii. this mod affects s10 version only.
mgfb 5 $ decks affected - macros, start, genini
mgfb 6
dst 1
dst 2 $ dst d. shields 29 mar 79 level 79088
dst 3 $
dst 4 $ 1. fix errors in mbchain, vbegl fields for s10, s32 (fr2.3.100).
dst 5 $ 2. report error if operand to arithmetic comparison multi-word.
dst 6 $ decks affected - macros, start, ermes, emit2, sortvars.
dst 7
dss 1
dss 2 $ dss d. shields 30 jan 79 level 79030
dss 3 $ r. kenner
dss 4 $
dss 5 $ 1. make data structures for -monitor- features more
dss 6 $ machine-independent (fr2.3.75).
dss 7 $ 2. add -isuse- calls in genioit (fr2.3.78).
dss 8 $ 3. move warning message processing for overlong temporaries
dss 9 $ from -blkend- to -ermes-.
dss 10 $ 4. add program parameter 'cis=0/n' to check index size. if
dss 11 $ option value is nonzero, then any instance of a(e) where size
dss 12 $ of e is greater than option value is reported as warning.
dss 13 $ the default value n is chosen according to pointer size.
dss 14 $ this option added to assist in setl debugging.
dss 15 $ 5. adjust some field definitions for s32.
dss 16 $ decks affected - start, genini, blkend, ermes, genioit,
dss 17 $ emit2, emass, gendebug.
dss 18
dsr 1
dsr 2 $ dsr d. shields 27 dec 78 level 78361
dsr 3 $
dsr 4 $ 1. fix error (fr2.3.72) in unpacking tokens in -parse- if
dsr 5 $ -unpk_env- not enabled.
dsr 6 $ 2. fix error (fr2.3.74) in arith in that comparisons
dsr 7 $ of multi-word items with constants wrongly folded by
dsr 8 $ arith in some cases.
dsr 9 $ 3. expand functions aint, amod, float, ifix and int in-line
dsr 10 $ for s10 and s32.
dsr 11 $ decks affected - genini, parse, arith.
dsr 12
dsq 1
dsq 2 $ dsq d. shields 18 dec 78 level 78352
dsq 3 $
dsq 4 $ correct error (fr2.3.66) reported in -gencfi- in that
dsq 5 $ call to -gendfi- did not specify argument zero.
dsq 6 $ deck affected - gencfi
dsq 7
meal 1
meal 2 $ dsp d. shields 27 nov 78 level 78331
meal 3 $
meal 4 $ add program option 'meal=1/0' (m-onitor e-ntry a-rgument l-ist)
meal 5 $ such that zero value causes monitor procedure entry code not
meal 6 $ to include print of argument values. this effected by adding
meal 7 $ new global vlariable -trentrargs- which must be nonzero if gensiz
meal 8 $ is to emit trace code to print argument values.
meal 9 $ this feature requested by setl group.
meal 10 $ decks affected - start, genini, gensiz.
meal 11
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.
vax 6 $ decks affected - macros, start, genini, parse, squeeze, sortvars.
vax 7
dso 1
dso 2 $ dso d. shields 25 sep 78 level 78268
dso 3 $
dso 4 $ 1. add code for resident s10 compiler.
dso 5 $ 2. add tm=40 (prime 400) target machine.
dso 6 $ decks affected - macros, start, genini.
dso 7
rbkn 1
rbkn 2 $ rbkn r. kenner 19 jun 78 level 78170
rbkn 3 $
rbkn 4 $ reported bug - .len. = causes compilation error if option
rbkn 5 $ help selected.
rbkn 6 $ fix - missing data entry in trstorr.
rbkn 7 $ deck affected - trstorr.
rbkn 8
3
4 $ chars d. shields 30 may 78 level 78150
5 $
6 $ include deck chars to describe character set to assist in
7 $ correct translation of source text for new machines.
8 $ correct error in use of cdc character set so that apostrophe
9 $ represented by cdc display code 3b'70' (up arrow).
10 $ decks affected - all (source resequenced).
11
12
13 $ dsn d. shields 15 may 78 level 78135
14 $
15 $ 1. correct target machine parameters for s10.
16 $ 2. fix error message for negative dimension.
17 $ 3. list current procedure name if abnormal termination.
18 $ decks affected - genini, gendim, genexit.
19
20
21 $ rbkm r. kenner 01 mar 78 level 78060
22 $ d. shields
23 $
24 $ 1. correct error in haprobe macro.
25 $ 2. correct -fidtab- entry for .sne.
26 $ 3. fix bug if .ch. and .f. in same statement.
27 $ 4. fix listing control.
28 $ 5. fix sizing of r-tokens in cnvcon.
29 $ 6. correct field definitions for s37.
30 $ decks affected - start, parse, ptdata, cnvcon, nextok, arith.
31
32
33 $ dsm d. shields 04 jan 78 level 78004
34 $
35 $ give error message if size of zero specified.
36 $ decks affected - gensiz, ermes.
37
38
39 $ rbkl r. kenner 29 dec 77 level 77363
40 $
41 $ 1. fix errors in s37 conditional text.
42 $ 2. install s-type tokens. see lex mod rbkg.
43 $ 3. change 'subr start' to 'prog start' on s37 since phases
44 $ are not part of one large overlay.
45 $ 4. fix bug in flow trace which causes if-true and if-false not
46 $ to be paired at run-time.
47 $ 5. have store trace call different routine depending on how many
48 $ parameters it must pass.
49 $ 6. have size of internally generated variables for -do- be mws if
50 $ the value being assigned to them has size greater than mps.
51 $ 7. fix dimension of -fidtab- in -arith-.
52 $ 8. fix bug in -marith- folding of .not. which caused constants
53 $ of size zero to be generated.
54 $ 9. fix error which caused -setq- to loop printing error messages
55 $ if it detected an item of size zero.
56 $ 10. do not have -ha- dump attempt to print -names- array for strin
57 $ 11. test for -arglist- overflow in -gengosl-.
58 $ 12. -syntab- was replaced because at least one -pt- entry differs
59 $ from what assembly of -ltlgrmr- should be.
60 $ decks affected - macros, start, genini, ptdata, gtoflo, nextok,
61 $ cnvcon, ermes, arith, marith, gendo, gengosl,
62 $ gensiz, getdovar, sortvars, trflowr, trstorr,
63 $ hadump, voadump, genexit
64
65
66 $ dsl d. shields 08 dec 77 level 77342
67 $
68 $ 1. assign correct (integer) arithmetic mode to -idim-.
69 $ 2. fix error in flow trace for compound if with no else part.
70 $ 3. do not collect function names for assert statement list.
71 $ 4. compile no code for assert with nonzero constant expression.
72 $ 5. make operator precedence levels consistent with guide.
73 $ 6. fix error so truncate if .pad. string longer than desired
74 $ length.
75 $ 7. compute size of .not. of constant correctly.
76 $ decks affected - start, trflowr, gensert, genpad, marith.
77
78
79 $ dsk d. shields 08 nov 77 level 77312
80 $
81 $ detect zero length .e. and .f. extracts, returning zero on
82 $ extraction, and treating as no-op on assignment.
83 $ decks affected - genextr, emass.
84
85
86 $ dsj d. shields 03 nov 77 level 77307
87 $
88 $ 1. add conditional option pack_env, and modify cnvcon to call
89 $ pack$li directly if environment pack procedure available.
90 $ 2. reported bug - unable to compile real function invocations
91 $ with expression arguments.
92 $ cause - emcall incorrectly setting amode (bug uncovered by mod
93 $ rbkj).
94 $ 3. give better message for mixed-mode expressions.
95 $ 4. delete code in emit2 made dead by mod rbkj.
96 $ decks affected - macros, cnvcon, ermes, emcall, emit2.
97
98
99 $ rbkk r. kenner 28 oct 77 level 77301
100 $
101 $ this mod is needed for lex mod rbkf to keep the line counts
102 $ correct.
103 $ deck affected - nextok
104
105
106 $ rbkj r. kenner 11 oct 77 level 77284
107 $
108 $ this mod is an mostly an internal cleanup of gen. the
109 $ major areas of change are listed below.
110 $ 1. conditional text has been added for s10.
111 $ 2. field definitions have changed, especially for s37.
112 $ 3. the parser has been speed up by putting in a bit
113 $ more special cases and by slightly recoding certain
114 $ statements and reordering some tests.
115 $ 4. the handling of -end- statements has been changed
116 $ in the case of errors. if the next token does not
117 $ match any opener, the -end- is ignored and only if
118 $ the next token matches will it be processed. if the
119 $ next few tokens exactly match an opener but not the last
120 $ opener, the previous ones will be closed with an error
121 $ message. this sould reduce the number of 'runaway' error
122 $ cases.
123 $ 5. the scan for next semicolon in the case of error has been
124 $ fine-tuned to also check for a 'then' in the case of an 'if'.
125 $ 6. the text, format, and content of the syntactic error
126 $ messages have been redone and the error message numbers have
127 $ been re-ordered.
128 $ 7. a bug which caused gen to loop if the current routine was a
129 $ function and the function name was unsized has been fixed.
130 $ 8. the drop bits for variables are now set when it is the last
131 $ use before a (simple) assignment even if it is not the last
132 $ use in the basic block. the same goes for a variable or
133 $ constant referenced in a subroutine or function call.
134 $ 9. the usage count for constants are not incremented in cases
135 $ where asm would normally not use the values (like .f. indices)
136 $ 10. gen will ensure that enough space exists in the machine
137 $ block for element zero of an array. (370 asm and maybe some
138 $ others in the future need this).
139 $ 11. namesets are now openers and entered in the -csa-. this
140 $ allows other openers in namesets and allows nameset statements
141 $ to be nested.
142 $ 12. detection of when something is a function has been redone.
143 $ something is now concidered a function only when it is not
144 $ dimensioned, has never been used as a simple variable, and
145 $ does not have the same name as a built-in function. error
146 $ messages are issued in the cases in which something which was
147 $ probably erroneous would have previously been treated as a
148 $ function. also, a global variable can be treated as a functio
149 $ so that functions which are used a lot can be sized in start
150 $ and need not be sized in every other routine which calls it.
151 $
152 $ decks affected - (most) source has been resequenced.
153 $ decks added - findcsa, closer, pfind (also some routines have been
154 $ put in their own decks)
155 $ decks deleted - findloop, comptok, pushr
156
157
158 $ dsi d. shields 02 aug 77 level 77214.
159 $
160 $ this mod fixes a few minor problems and installs a new parser.
161 $
162 $ 1. reported bug - arithmetic mode not set for real temporaries.
163 $ fix - set type field of temporaries.
164 $ (this only caused problems on s37 implementation.)
165 $ 2. reported bug - real constants incorrectly folded on s16.
166 $ fix - gen will no longer attempt to fold real constant
167 $ expressions if the host and target machines differ.
168 $ 3. reported bug - notrace monitor directive not working correctly
169 $ fix - error in grammar in setting of codes to pass to gentrace
170 $ has been fixed.
171 $
172 $ this mod also modifies the parse procedure -parse- to use
173 $ the parsing strategy supported by the program -syn-. the
174 $ parse now detects expressions which consist of a single name
175 $ or constant more efficiently, and also does a more efficient
176 $ job parsing terms in expressions.
177 $
178 $ the new procedure lstlin is used to list input lines.
179 $
180 $ decks affected - parse, nextok, ermet, arith, blkend,
181 $ lstlin (new), and procedures which formerly called nextok to
182 $ list input lines.
183
184
185 $ dsh d. shields 20 may 77 level 77140.
186 $
187 $ 1. support unary plus.
188 $ 2. permit use of 'err' as synonym for 'error' in filestat query.
189 $ 3. do not print trailer strings (io, monitor) in parameter
190 $ list as user cannot alter them.
191 $ 4. make size of integer multiply ws on s16.
192 $ decks affected - start, genini, parse, arith, marith, emit2.
193
194
195 $ rbki r. kenner 30 apr 77 level 77120
196 $
197 $ fix a bug in the handling of 'monitor' statements which caused
198 $ all such statements which did not have an explicit 'limit'
199 $ paramater to set the monitor line limit to infinite.
200 $ deck affected - gendebug
201
202
203 $ dsg d. shields 22 apr 77 level 77112.
204 $
205 $ 1. change -cursor- to -column- in filestat inquiry, so now use
206 $ filestat(fileexpr, column) to get current column.
207 $ 2. avoid reference to zero-th element of littab in nextok.
208 $ decks affected - parse, nextok.
209
210
211 $ dsf d. shields 14 mar 77 level 77073.
212 $
213 $ 1. avoid popping csa if error seen.
214 $ 2. declare negative constants to be 'safe' and give them size
215 $ word size.
216 $ decks affected - inscon, ermet, arith.
217
218
219 $ dse d. shields 04 february 1977 level 77035.
220 $
221 $ 1. fix error in conversion of real constants in cnvcon.
222 $ 2. fix computation of subtitle in gensub so strings aligned
223 $ on word boundaries.
224 $ 3. move misplaced test in gensize that caused problems in trace
225 $ stores list processing in gensize.
226 $ 4. correct gencall and emcall to manipulate arglist pointer
227 $ correctly, so that unsized variable in argument list does
228 $ 5. remove duplicate data statement for prhd in monitor setup.
229 $ not cause problems.
230 $ 6. correct calculation of size of string concatenation.
231 $ decks affected - cnvcon, gencall, gensize, gensub, emcall, emit2.
232
233
234 $ dsd d. shields 7 january 77 level 77007.
235 $
236 $ convert to use new library and support only new language level.
237 $
238 $ 1. drop support of 'old' tokens: h, z, d, l and octal b.
239 $ 2. use 'monitor' instead of 'debug'.
240 $ 3. drop support of multiword arithmetic.
241 $ (new definition and implementation due soon.)
242 $ 4. use -getipp- and -getspp- to get program parameters.
243 $ 5. on s66, place certain arrays in blank common to
244 $ reduce size of absolute overlay.
245
246 $ the source has been resequenced.
247 $ decks affected - all.
248
249 $ dsc d. shields 15 november 76 level 76320.
250 $ 1. support new language level, indicated by 'lev' compiler
251 $ option. the new level renames math library functions for
252 $ s66, does not support .c., and supports .pad. operator.
253 $ the new level also sorts namesets so storage allocated in
254 $ order of declaration, not in 'reverse' order of old level.
255 $ 2. add '.pad.' operator, of form 'str .pad. int' where -str-
256 $ is a character string constant and -int- is integer constant.
257 $ the result is the string padded to right with blanks to have
258 $ length -int-.
259 $ 3. fix debugging package reported by brooklyn college, as a
260 $ test was out of place in gensiz.
261 $ 4. support main program unit, or -prog- statement.
262 $ 5. do not require 'return' at end of procedure, and
263 $ compile 'end subr' or 'end fnct' statement into 'return'.
264 $ a return from main program terminates execution.
265 $ 6. support character string comparison operators .seq. and .sne.
266 $ decks affected - most (source has been resequenced).
267
268
269 $ dsb d. shields 6 october 1976 level 76280.
270 $
271 $ 1. enable 'ncfopt' by default.
272 $ 2. eliminate references to file name strings and buffer lengths
273 $ since files now represented by unit numbers.
274 $ 3. add 'read' and 'write' literals and process binary io.
275 $ 4. revise processing of io.
276 $ decks affected - start, parse, io routines.
277
278
279 $ rbkh r. kenner 10 august 76 level 76223
280 $
281 $ 1. remove input format -f- from list of i/o routine because
282 $ it is the same as input format -e-.
283 $ 2. add a field to the -voa- to count the number of uses of
284 $ a variable or constant within a routine.
285 $ 3. set drop bits for variables and constants in addition to
286 $ temporaries.
287 $ 4. for all machines other than s66, have -cont do- compile
288 $ as a -go to- test label rather than as an increment
289 $ and test at the site of the -cont-.
290 $ 5. special case -if (e) cont- and -if (e) quit- so as not
291 $ to end a basic block and to use the -ifgo- operation.
292 $ this is not done in the case of a -cont do- on s66.
293 $ 6. defer allocation of address for variables until end of
294 $ a routine and sort each nameset in order to have the smaller
295 $ variables at the start of the nameset. this aids in base
296 $ register allocation on s37 and will help on machines which
297 $ use paged virtual storage.
298 $ 7. change the name of the default nameset to have a dollar sign
299 $ in column one followed by the rest of the routine name instead
300 $ of using the routine name. this change is needed for machines
301 $ (like s37 and s11) for which a common block and routine may
302 $ not have the same name.
303 $ 8. set up a mechanism to re-use internal variables defined for
304 $ -do- statements in the same manner as is done for itterators
305 $ in i/o statements.
306 $ 9. fix bug in freeing internal variables in i/o statements.
307 $ 10. dont end basic block on some i/o calls.
308 $ 11. give error message on assignment to function parameter.
309 $ 12. give error message on indexed assignment to variable that
310 $ is not an array. (no -dims- statement for it)
311 $ 13. change text of some more error messages.
312 $ 14. add -seblk- field to -voa- to indicate which subroutine
313 $ calls end a basic block.
314 $ 15. add -bytaln- field to -voa- to indicate which extractions
315 $ or assignments are done on character-aligned data.
316 $ 16. install new -voa- field layout for s37.
317 $ 17. make dimension of some arrays dependent on machine and
318 $ install dimensions for s37.
319 $ 18. remove code in -emit2- to bypass common multi-word indexed
320 $ loads on s66 because bug fixed in s66 -asm-.
321
322 $ rbkg r. kenner 30 july 76 level 76212
323 $
324 $ fix miscellaneous bugs detected upon s37 bootstrap of
325 $ last level. also, fix two bugs in parsing new i/o.
326
327 $ rbkf r. kenner 22 july 76 level 76204
328 $
329 $ 1. fix reported bugs.
330 $ 1. 'notrace'/'nocheck' do not work - error in grammar.
331 $ 2. 'debug entry' is not recognized as valid due to error in
332 $ -keycode- call.
333 $ 3. some error messages do not appear in terminal file.
334 $ 4. bad formatting of listing if 'pdir' set.
335 $ 5. last few token list does not intialize correctly.
336 $ 6. trace or check statements for global variables occuring
337 $ after the -size- statements for those variables, do not
338 $ work correctly.
339 $ 2. change iotype=storage to iotype=string
340 $ decks affected - parse, genend, gensub, squeeze, geniost, pdsort
341 $ gentrace
342
343 $ rbke r. kenner 16 july 76 level 76198
344 $ d. shields
345 $
346 $ 1. insert blank lines around error notices to make them more
347 $ noticable.
348 $ 2. have 'possibly illnested loop..' message be an error rather
349 $ than a warning and change the text.
350 $ 3. correctly process 'voa=0'.
351 $ 4. change handling of constant expression to just check if
352 $ the final result is a safe constant (i.e., 'i-i+1' is a safe
353 $ constant). remove -cexpress- and -cexperr- and change grammar.
354 $ 5. have -genexit- recieve its parameter globally to avoid problem
355 $ in s37 when overlaying compiler.
356 $ 6. allow 'term' option to have error messages written to a
357 $ separate file for use in some interactive systems.
358 $ 7. install code to parse and process new 'little i/o'.
359 $ 8. miscellaneous code changes.
360
361
362 $ rbkd r. kenner 09 july 76 level 76191
363 $
364 $ 1. allow .len. as abbreviation for '.f. 1, .sl.,'.
365 $ 2. the -quit- and -cont- statements are no longer restricted
366 $ to the innermost loop; the tokens following the quit and
367 $ cont determine the loop.
368 $ 3. unary operations on constants are done at compile time, if
369 $ possible.
370 $ 4. continue work on error handling.
371 $ 5. require constant expressions use only 'safe' constants.
372 $ 6. value in data statement must be constant, but not necessarily
373 $ constant expression.
374 $ 7. begin implementation of revised (yet again) little io. drop
375 $ support of io as defined in little newsletter 34.
376 $ 8. the -debug- statement is used for run time control of
377 $ debug package. the statement consists of -debug- followed
378 $ by a list of parameters, separated by commas. parameters are
379 $ as follows:
380 $ limit = expr set line limit to expr.
381 $ nolimit suppress debug line limit check.
382 $ flow (noflow) enable (disable) print for -flow-.
383 $ stores (nostores) enable (disable) print for -stores-.
384 $ entry (noentry) enable (disable) print for -entry-.
385 $ byte (nobyte) include (suppress) print of value as
386 $ byte constant.
387 $
388 $ default is 'debug flow, stores, entry, nobyte;' .
389 $ the debug line limit is initially 9/10 of print line limit.
390 $ 9. implement new rules for scope of debugging statements.
391 $ 10. support 'autotitle' option in list directive which uses
392 $ 11. have first line of proceedure list as line 1 by defering
393 $ the listing of a card until the next is read.
394 $ first line of each procedure as subtitle text.
395
396
397 $ rbkc r. kenner 02 july 76 level 76184
398 $ d. shields
399 $
400 $ 1. improve error handling by rewording some error messages
401 $ and attempting to avoid the 'runaway' errors that occured
402 $ previously.
403 $ 2. add a field -hainuse- to the -ha- to avoid multi-word
404 $ comparisons on s37.
405 $ 3. rename -labintern- to -namintern- and set for internal
406 $ variables also instead of just labels.
407 $ 4. remove old format octal and bit constants and convert
408 $ to new format byte constants.
409 $ 5. insert conditional text -oldtoks- to continue support
410 $ of old token types. this is set on for s66 because of
411 $ the large number of existing programs which would have to
412 $ be converted, but is set off for s37.
413 $ 6. generate labels of the form 'l(n)' instead of 'l.nnn'
414 $ for subscripted labels.
415 $ 7. if .cc. is done on constants, do at compile time.
416 $ 8. allow '!!' in place of '.cc.' (as in pl/1)
417 $ 9. implement .voapart. to give dump of just voa, xarg, and csa.
418 $ 10. increase dimensions of -xarg- and -lablist-.
419 $ 11. miscellaneous changes to code style and come size statments
420 $ to improve (hopefully) efficiency and improve readability
421 $ and machine-independance.
422
423
424 $ rbkb r. kenner 28 jun 76 level 76180.
425 $ d. shields
426 $
427 $ 1. modify identification of builtin functions to allow module
428 $ names which differ from names in source.
429 $ select functions to be done inline accodring to target
430 $ machine.
431 $ 2. support paged, titled listing and new directives for
432 $ list control.
433 $ 3. eliminate 'version number' approach to identifying voa file
434 $ and use only julian date of last change to voa file structure.
435 $ 4. require label subscripts l to be in range 0 <= l <= 999.
436 $ 5. extend lablistlen from 300 to 400.
437 $ 6. support option 'pdir' which produces list of procedures sorted
438 $ by name and with page number of first line if input listing on
439 $ when first line seen.
440 $ implementation: raise cross reference option and write page
441 $ number in ref entry. at end of input, read ref file and sort
442 $ using routines pdsort and pdcomp modelled on detect and ibigr
443 $ in the lex phase.
444 $ 7. redo debugging package in more machine-independent fashion.
445 $ this change includes a revision of the run-time interface.
446 $ at user level, effect of change is as follows:
447 $ 1. -help- parameter is now list of codes which correspond
448 $ to initial debug statements; the codes are as follows:
449 $ c - check index;
450 $ e - trace entry;
451 $ f - trace flow;
452 $ s - trace stores;
453 $
454 $ the default is 'help=0' which gives no initial debug options.
455 $ if a code list is given but includes '0', the codes are
456 $ ignored. 'help' alone is the same as 'help=cefs'.
457 $
458 $ 2. the -debug- parameter selects the level of debug support:
459 $ 0 - ignore all debug statements.
460 $ 1 - process only assert statements; terminate if assert
461 $ fails.
462 $ 2 - process all debug statements; do not terminate if
463 $ assert fails.
464 $ if -help- is specified, the debug level is set to two
465 $ and the -debug- parameter is ignored.
466 $ 3. debug statements in the -prelude- (before start of first
467 $ procedure) are global; other debug statements are local to
468 $ the routine in which they occur.
469
470
471 $ cra d. shields 04 may 76 level 76125
472 $
473 $ support revised cross-reference generation as follows.
474 $ if cross reference option 'lcr' on, then write reference file
475 $ 3 which contains line numbers and names of subroutine definition
476 $ lines. use library procedure -crfnam- and parameter 'rf' to
477 $ determine name of reference file.
478 $ each routine is represented by several entries, as follows.
479 $ 1. line number of start of routine (0 ends file).
480 $ 2. number of characters in routine name.
481 $ 3. variable number of entries, containing routine name,
482 $ right adjusted with cpw characters per entry.
483 $
484 $ also, change ps to 24 for s37, and initialize littab using arglist
485 $ to avoid multi-word data values for ha.
486 $ decks affected - start, genini, gensub, genexit.
487
488
489 $ dsa d. shields 19 apr 76 level 76110
490 $ r. kenner
491 $
492 $ 1. allow reals to occupy more than one machine word (needed for
493 $ s16) by defining global variable -rlsz- which gives size of
494 $ real quantity.
495 $ 2. define size of real comparisons to be 1.
496 $ 3. include csadump in standare table dump (tabdump).
497 $ 4. avoid negative division in sdsnamr.
498 $ 5. initialize nstouse to localblock in case unsized variables.
499 $ encountered at start of program.
500 $ 6. replace macro 'notrealcomp' with 'realcomparison' to avoid
501 $ 'negative' logic and to increase readability.
502 $ 7. correct mispunched apostrophes in glossary.
503 $ decks affected - gloss, start, genini, arith, gencall, genreal,
504 $ cnvcon, emit1, emit2, sdsnamr
505
506
507 $ rbka r. kenner 24 march 1976 level 76085085
508 $
509 $ continue work on system/370 version, as follows:
510 $ 1. use lctime to get time and date.
511 $ 2. restructure table dumps to permit overlaying. main table
512 $ dump is now -tabdump-, which calls voadump, etc.
513 $ 3. add variable nwarnings to count warnings, and call setcc
514 $ to report condition code on gen termination.
515 $ 4. clean up some of error-message handling.
516 $ 5. give initial values for some previously uninitialized vars.
517 $ ( the source has been resequenced )
518
519
520 $ (none) d. shields 10 february 1976 level 76041
521 $
522 $ the source has been cleaned up and some variables have been
523 $ renamed. the parser and code formerly in deck -blocken- have been
524 $ extensively rewritten.
525 $ this version supports all language features, including the
526 $ recent extensions to support subscripted labels and an
527 $ elseif clause in if statements.
528 $ the voa layout is basically the same except that the field
529 $ -dboup- has been added for drop bit for those operations in
530 $ which oup field is used to hold input.
531 $ the field 'free' is no longer used by gen.
532 $
533 $ the entire source has been resequenced, so this mod has no
534 $ name. future mods should have a name based on logical function
535 $ if the mod adds or repairs a feature, or a name based on author
536 $ initials for miscellaneous corrections not related to any
537 $ one feature.
538 $ decks affected - (all)
539
1 .=member gloss
2 $ glossary (m denotes macro, v variable, r routine)
3 $ ':name' indicates item is field of structure named.
4
5 $v accesstab. bit vector of mba-indexes of accessed namesets.
6 $r advstr. advance string in lexicograhic order:'aa','ab',...'az',etc.
7 $m amode_real. code for amode of real (floating point) item.
8 $m amode. arithmetic mode (/=normal,1=real) :voa
9 $r arastar. collect and list array usage statistics.(cf. genexit)
10 $m arb. 'is this argument of current routine' :voa(var)
11 $m argbeg. starting index in -xarg- of extra values. :voa(op)
12 $v argct. number of formal arguments of current routine.
13 $m arglen. number of -xarg- entries used. :voa(op)
14 $v arglist. parser /generator common stack, codes and ha indices.
15 $m argmax. dims of arglist.
16 $m argno. if arb set, then argument index. :voa(var)
17 $v argptr. top of arglist.
18 $r arith. process binary operation.
19 $m asmhdr_vn. (voa file) version number of header block
20 $v asmvoadupmp. flag set by 'ad' option to get voa dump of each proc.
21 $r assembl. write tables for assembler use.
22 $m assertdim. dims of assert stack ('assert' debug request)
23 $v assertfg. flag, on when inside 'assert' statement expression.
24 $v assertst. stack of names seen in 'assert' expression.
25 $v assertstp. top of assertst.
26 $v bifatrtab. array giving names and attributes of builtin functions.
27 $m bifofop(op). maps opcode of builtin op into bifatrtab index
28 $m bifresmode(op). arithmetic mode of result of builtin function
29 $v bifxhasearch. flag, on to indicate xha search for function name,n.
30 $m bintok. lexical type of binary constant.
31 $r blkend. terminate basic block.
32 $v blkendreset. number of times blkend reset deflev field.
33 $m blockmax. maximum number of voa entries in basic block
34 $m bodylbl. -ha- index of 'body' label. :csa
35 $v buildreal. flag, on when constructing real variable.
36 $m builtin(op). is op a builtin function.
37 $m call_noparms. -gencall- code for call with no parameter list.
38 $m call_parms. -gencall- code for subroutine call with parameters.
39 $m call_value. -gencall- code for function call or indexed load.
40 $m calldebug(routnam). call offline debug routine.
41 $v cca. array of characters of constant to convert (cf. cnvcon)
42 $v ccaptr. position of last character in cca.
43 $v cclt. lexical type for constant conversion.
44 $v ccnchars. number of characters if inserting string const.
45 $v ccsyze. number of bits in converted constant value. (cf. cnvcon)
46 $v ccval. array containing converted constant value. (cf. cnvcon)
47 $v ccvalptr. number of words used in ccval. (cf. cnvcon)
48 $v cexpress. flag, on when parse must obtain constant expression.
49 $m charl(c). print character.
50 $r charpak(pa,ua,n). (library) pack n chars in ua into pa.
51 $m charofdig(d). map digit into character code.
52 $m chinxf. is 'check index' debug request in effect. :ha
53 $v chinxfg. debug, type of check index trace in effect.
54 $r chinxr. process debug indexed stores check statement.
55 $v chinxrp. debug, global parameter to routine chinxr.
56 $r cnvcon. convert constants.
57 $m commutes(op). 'does this operator commute'
58 $r comptok. compare opening and closing tokens in compound statement.
59 $m const. is this item a constant. :voa
60 $m constok. code of lowest constant.
61 $m conval(hap). first word of constant value with ha index hap
62 $m countup(var,lim,msg). set var=var+1. fatal error if var.gt.lim
63 $m cpw. (ws/cs). number of characters in word.
64 $m cs. number of bits in character.
65 $v csa. c-ompound s-statement a-rray, tracks compound statements.
66 $m csacountup(msg). increment csa top pointer.
67 $r csadump. list contents of csa.
68 $m csamax. dims of csa (c-ompound s-tatement a-rray)
69 $v csaptr. top of csa.
70 $m csasz. size of csa entry.
71 $v csatok. stack of opening tokens of pending compount statements.
72 $m csatokmax. dims of array used for saving tokens for csa
73 $v csatokptr. top of csatok.
74 $m csiftype_else. csa cstype code for else clause.
75 $m csiftype_sif. csa cstype code for simple if statement
76 $m csiftype_then. csa cstype code for then clause.
77 $m csiftype. type of -if- clause. :csa
78 $m cstype_do. csa cstype code for do statemett group.
79 $m cstype_fnct. csa cstype code for function.
80 $m cstype_if. csa cstype code for if statement group.
81 $m cstype_subr. csa cstype code for subroutine.
82 $m cstype_while. csa cstype code for while statement group
83 $m cstype. compound statement type. :csa
84 $v curblock. voa index of first entry in current basic block.
85 $v currsubrname. name of current routine in sds format.
86 $v daopt. flag, set by 'da' option, to grant 'default access'.
87 $m db1. 'is this last use of first operand (inp1)' :voa(op)
88 $m db2. 'is this last use of second input (inp2)' :voa(op)
89 $m db3. 'is this last use of third input (inp3)' :voa(op)
90 $v debugfg. flag, on when debug option(s) in effect.
91 $v debugsttus. flag, on if any debug option seen.
92 $v debugtab. stack used to communicate with rum-time debugging procs.
93 $m dectok. lexical type of decimal integer.
94 $m defaulttokenfilename. default name for token file.
95 $m defaultvoafilename. default name for voa file.
96 $m deflev. definition level of item. :voa
97 $v defnstouse. mba index of nameset to be used.
98 $v deind. index in debugtab.
99 $v denwd. number of words in debugtab entry.
100 $v deparm. global for macro 'callrout'.
101 $m digofchar(c). map character codefor digit into numeric value
102 $m dims. dimension value (0 if no dimension) :voa(var)
103 $m dimsmax. maximum allowed value for dims.
104 $v docontrace. flag, on when constant values to be listed.
105 $m dohip. -ha- index of -hi- exprssion in -do- :csa
106 $m doincp. -ha- index of 'increment' expression for 'do' :csa
107 $m dolop. -ha- index of 'lo' variable in -do- :csa
108 $m dosignp. 'is this descending do loop (by -)' :csa
109 $m dovarp. -ha- index of -do- loop variable. :csa
110 $m dsetoconst(i,c). debugtab(i) = c (c a constant)
111 $m dsetolvar(i,hap,nw). debugtab(i) = hap, ww words in hap
112 $m dsetovar(i,hap). set debuttab(i) = hap.
113 $v echoline. flag, on when nextok is to list line only.
114 $m elseiftype. csa cstype code for elseif clause.
115 $r emass. construct assignment representation.
116 $v emassrest. number of times emass reset deflev field.
117 $r emcall. construct call representation.
118 $r emit1. construct unary operation representation.
119 $r emit2. construct binary operation representation.
120 $r emit3. construct extractor representation.
121 $v endblock. flag, on if next call seen is to end basic block.
122 $m endl. end current print line, start new one.
123 $m endlbl. -ha- index of 'end' label ending group. :csa
124 $m entrend. code for return trace.
125 $m entrrout. code for entry traee.
126 $v entrrouts. debug, stack of routines to have entry traced.
127 $v entrroutsp. top of entrrouts.
128 $m eos_code. (voa file) code for end of routine.
129 $m ep. index of corresponding boa entry. :ha
130 $r ermes. report semantic error.
131 $v ermesarg. auxiliary argument to ermes, usually ha index.
132 $r ermet. report syntactic error.
133 $v ermflag. flag, on to suppress 'unsized external' diagnostic.
134 $r ermlst. list boilerplate of syntactic error message.
135 $v ermsgno. syntactic error number.
136 $v everdebug. flag, set when debugging routines initialized.
137 $m filenamelen. maximum length of file names used by compiler
138 $m firstbuiltin. opcode of first intrinsic (builtin) function
139 $m firstst. line number of first statement in group. :csa
140 $v fivtoks. flag, on if opener tokens in compount statement must match
141 $m flowdo. flowp code for do.
142 $m flowend. flowp code for return statemett processing
143 $v flowgen. debug, flow number generator.
144 $m flowgenlim. maximum number of blocks traced by 'flow' debug option
145 $m flowhil. flowp code for while.
146 $m flowiff. flowp code for -f - false.
147 $m flowifgt. flowp code for if...go - true.
148 $m flowifnsf. flowp code for if...then...edd - if - false
149 $m flowifsf. flowp code for if - simple case - false.
150 $m flowift. flowp code fo it - true.
151 $m flowiftyp. trflowp field giving if typ.
152 $m flowlab. flowp code for label.
153 $m flowp. type of flow call.
154 $v flowrouts. debug, stack of routines to have flow traced.
155 $v flowroutsp. debug, top of flowrouts.
156 $m flowtil. flowp code for while.
157 $v fswitch. flag, on when compiling 'fnct', not 'subr'.
158 $m functyp. code for ha type 'function'
159 $r genacc. process access declaration.
160 $r genarg. process argument in routine declaration.
161 $r genasin. process assignment statement.
162 $r gencall. process call (or indexed load)
163 $r gencfi. process control format specification.
164 $r gencont. process continue statement.
165 $r gendat. process data declaration.
166 $r gendfi. process data format specification.
167 $r gendim. process dimension declaration.
168 $r gendo. process do statement.
169 $r genend. process end statement.
170 $r genexit. terminate gen compilation phase.
171 $r genextr. process extractor (.e., .f., .s., .ch.)
172 $r genfile. process file declaration.
173 $r genfnm. generate file name.
174 $r gengdi. process -get- data transmission request.
175 $r gengoby. process goby statement.
176 $r gengol. process go to or label definition (not subscripted).
177 $r gengosl. process subscripted label (go to or definition).
178 $r genif. process if statement clauses.
179 $r genifgo. process 'if(a1) go to a2'.
180 $r genini. initialize.
181 $r genioar. process implicit array transmission request.
182 $r genioit. process io data item specification.
183 $r geniost. process various clauses of io statements.
184 $r geniotr. process item for io transmission.
185 $r genns. process nameset declaration.
186 $r genpdi. process -pup- data transmission request.
187 $r genquit. process quit statement.
188 $r genreal. process real declaration.
189 $r genret. process return statement.
190 $r gensert. process debug assert statement.
191 $r gensiz. process size declaration.
192 $r gensub. process subroutine delaration (subr/fnct).
193 $r gentrac. process debug trace statement.
194 $r genuntl. process until statement.
195 $r genwhil. process while statement.
196 $r getdebug. initialize for debug package use.
197 $r getiov. get local variable for use in io.
198 $m getlpos(p). store current print line position in p.
199 $r getxsds. get execution time form of sds object (dense form)
200 $m globalblock. index in mba of first global variable block
201 $v gsopt. 'gs' option flag, on for globals in start.
202 $r gtoflo. increment pointer, abort on overflow.
203 $m ha_code. (voa file) code for ha block.
204 $m ha_vn. (voa file) version number of ha.
205 $v ha. common hashed array, symbols known by ha index.
206 $m hacont. continue ha search.
207 $r hadump. list contents of ha.
208 $m haend $ end of ha search.
209 $r haerr(a). print contents of ha(a) as diagnostic aid
210 $m hamax. dims of ha (must be prime)
211 $v ha_0. ha index of constant '0'.
212 $v ha_1. ha index of constant '1'.
213 $m haprobe(j, hcode). start ha search. j is index, hcode is hash.
214 $m haquit $ terminate ha search.
215 $m hascon. 'is this ha entry that of safe (short) constant'. :ha
216 $m hasz. size of ha.
217 $m hermax. maximum acceptable level for deflev check.
218 $m hostmachine. index of host machine.
219 $m ifaglob(xhap,nam). if ha(nam) corresponds to global,set xhap to xha
220 $r ifaglor. implement ifaglob macro, see if name in xha (with access).
221 $v ifaglorname. global parameter for macro 'ifaglob'.
222 $v ifcongoto. number of 'if' statements converted to 'go to'.
223 $v ifcontot. number of 'if' statements with constant expression.
224 $m ifnum. block number (used by debug) :csa
225 $m indebug. $ see if debug requests in effect.
226 $m inloc. 'register containing item address' (asm use) :voa(var)
227 $m inp1. voa index of first input. :voa(op)
228 $m inp2. voa index of second input. :voa(op)
229 $m inp3. voa index of third input. :voa(op)
230 $m inreg. register holding item value (asm use) :voa(var)
231 $r inscon. insert converted constant into ha.
232 $m insglob(glohc, namea). insert name from ha(namea) into xha, setting
233 $r insglor. implement insglob macro, put name into xha.
234 $r insname. locate name in ha (insnarg, insnchars global args).
235 $v insnarg. array containing name used by macro insname.
236 $m intl(i). print integer in five columns.
237 $m intlp(i,p). list integer i in p columns.
238 $v iobufforgm1. size of status block needed for io on file.
239 $v iodfitems. array of parameters for formatted transmission.
240 $v ioerror. flag, set when error in io to skip rest of statement.
241 $v iofilekeys. array of attributes given in file statement.
242 $v iofilename. ha index of filename for io statement.
243 $m ioformats. number of io formats.
244 $v ioformatted. flag, on when generating formatted io fragment.
245 $v iofts. string appended to file names to isolate them.
246 $v iohi. ha index of last, or high, subrscript ot array for io.
247 $v iokey. code of io keyword, (cf. parse)
248 $v iokonst. length of generated array for io file nameset.
249 $v iolo. ha index of first, or low, subscript of array for io.
250 $v ionameflag. flag, on in 'namelist' io item transmission.
251 $v ionames. array of names of run-time io support routines.
252 $m ionamesptr. number of io routines , dims of ionames
253 $m ior_adrf:ior_vfmt. internal codes for io library functions
254 $v iorts. string appended to io run-time routine names to isolate them
255 $v iota. stack of items that io is to transmit.
256 $m iotahi. (iota field) ha index of last array element to transmit
257 $m iotalo. (iota field) ha index of first array element to transmit
258 $m iotamax. dims of iota.
259 $v iotaptr. top of iota.
260 $m iotavar. (iota field) ha index of item to transmit.
261 $v iova. stack of local variables used by io.
262 $v iovabusy. string of iova indices of variables currently 'busy'.
263 $m iovaha. (iova field) ha index of variable.
264 $m iovamax. dims of iova.
265 $v iovaptr. top of iova.
266 $v iovar. ha index of item io is to transmit.
267 $m iovasize. (iova field) variab.
268 $m iovasize. (iova field) voa index of entry giving vraiable size
269 $m iovasz. size of iova array (io v-ariable a-rray)
270 $v iowriting. flag, on if compiling 'put' type statement.
271 $m isafnct. 'is this name used as external functon' :voa(var)
272 $m isareal(x). 'is this real item', just 'amode x = amode_real'
273 $v isnchars. global parameter used by macro insname.
274 $r isusep. implement isuse macro, note use of input.
275 $m keeb. 'must this temporary be kept till end of block :voa
276 $v keeptok. flag, set to force nextok to return current token again.
277 $r keycode. get io code of current token.
278 $m labdef(l). indicate definition point of label.
279 $v labgen. string giving name of last generated label.
280 $m labget(l). generate new label name, return lablist index in l
281 $m labha. index in ha of label name. :lablist
282 $m labintern. 'is this compiler generated label' :ha
283 $m labldef(v, labnum). note label definition.
284 $v lablist. stack of label information.
285 $m lablistlen. maximum number of allowed labels (dims of lablist)
286 $v lablistptr. top of lablist.
287 $m labluse(labnum). note use of label in lablist(labnum)
288 $m labno. lablist index if name used as label. :ha
289 $m labsz. size of lablist entry.
290 $m labuses. number of label uses. :lablist
291 $m labvoa. voa index of label definition. :lablist
292 $m lastbuiltin. opcode of last intrinsic (builtin) function
293 $m lastuse. 'offset of last op in block to use this value':voa(op)
294 $m lbtok. lexical type of h-format string constant.
295 $v lcp_opt. list compilation parameters option value.
296 $v lcs_opt. list compilation statistics option value.
297 $m lc_. this prefix indicates literal code value used for keywords
298 $m lenmax. maximum number of temporaries watched by gettemp
299 $m levmax. maximum definition level.
300 $v levmin. level used in redundant expression optimization.
301 $v levnow. minimum acceptable definition level for redundant comps.
302 $v lexlist. circular array of recent tokens seen.
303 $m lexlistfew. number of recent tokens listed after error
304 $m lexlistmax. number of recent tokens saved (must be power of 2)
305 $v lexlistptr. current position in lexlist.
306 $m lextype. lexical type of constant. :voa(var)
307 $v listsw. flag, on to list input text.
308 $m litclassz. size of entry in littab.
309 $m litcodes. number of literal codes.
310 $m lithasz. size of literal hash table.
311 $m litmax. dims of littab and litha (must be prime)
312 $m litsz. maximum size of literals (as sds)
313 $v littab. array of literal attributes (cf. macro littabl)
314 $m littabl(class,indx) -bronlit- codeing for ...
315 $m littabsz. size of littab.
316 $m littokorg. origin of sds littok used to hold literals as sds
317 $v loadha...loadxha. max. no. of entries used in arrays.
318 $v loadrha...loadrxha. routines with max. usage.
319 $m localblock. mblk code for local variable block.
320 $v localforce. flag, on to force allocation in local block.
321 $v lvgen. sds naming last generated local variable.
322 $m lztok. lexical type of l-format string constant.
323 $m macdef(text). define inner macro with body text.
324 $m macdrop(name). drop macro status of name.
325 $m madr. machine address, offset in machine block. :voa(var)
326 $r marith. process unary operation.
327 $m maxxam. max. number of repetitions of syntactic construct allowed
328 $m mba_vn. (voa file) version number of mba.
329 $v mba. m-achine b-lock a-rray with nameset attributes.
330 $m mbacode. (voa file) code for mba block.
331 $m mbalen. length of machine block in words. :mba
332 $v mbaptr. top of mba.
333 $m mbdef. 'is this nameset being defined in this routine' :mba
334 $m mbha. ha index of nameset name. :mba
335 $m mblk. machine block (mba index) of item. :voa(var)
336 $m mbused. 'is this nameset used in current routine' :mba
337 $m mbxha. -xha- index of nameset name. :mba
338 $m mcs. number of bits in target machine character.
339 $m minus. csa dosignp code for downward loop (by - ...)
340 $m modesize. length of amode field in voa.
341 $m mps. number of bits in target machine pointer or address
342 $m msl. length of length field for sds on target machine
343 $m mso. length of origin field on target machine sds.
344 $m mws. number of bits in target machine word.
345 $m m16. code for machine honeywell series 16 minicomputers
346 $m m37. code for machine ibm system/370.
347 $m m66. code for machine cdc 6600.
348 $m nameblockorg. origin of name block.
349 $m nameorg. sorg value for nam.
350 $m names_code. (voa file) code for names block.
351 $m names_vn. (voa file) version number of names.
352 $v names. stack giving characters of names.
353 $m namesmax. dims of names array.
354 $v namesptr. next available location in names.
355 $m nametok. code for lexical type of 'name' token.
356 $m nametok. lexical type of name.
357 $m naml(hap). print name of item in ha(hap)
358 $m namsz. size of strings used to hold sds names built internally
359 $m naym. ha index for this item. :voa
360 $m nayme. index in -names- of characters in name. :ha
361 $m nblocks. maximum number of machine blocks.
362 $v ncards. number of source cards processed so far.
363 $v ncfopt. option flag, on if can fold to get negative constants.
364 $v ncftot. number of constant foldings that gave negative result.
365 $m nchars. number of characters in name or constant. :ha
366 $v nerrors. number of detected errors.
367 $r nextok. get next token.
368 $v nl. n-ames l-ist stack giving attributes of global vars.
369 $m nlamode. saves 'amode' :nl
370 $m nlblk. saves 'mblk' value. :nl
371 $m nlchinx. saves 'check/nocheck' state. :nl
372 $m nldimn. holds 'dims' value. :nl
373 $r nldump. list contents of nl.
374 $m nlha. xha index for this variable. :nl
375 $m nlmadr. saves 'madr' value. :nl
376 $m nlmax. dims of nl.
377 $m nlno. -nl- index of variable. :xha
378 $m nlsize. saves 'syze' value. :nl
379 $m nlsz. size of nl entry.
380 $m nltrac. saves 'trace/notrace' status. :nl
381 $m no. 0 (for readability)
382 $m noopb. 'is this operation to be suppressed' :voa(op)
383 $m nopcodes. number of opcodes (in voa)
384 $m notraceall. code for 'o.
385 $m notracesome. code for 'no trace some' debug request
386 $v nsflag. flag, set when inside nameset definition block.
387 $v nstouse. mba index of nameset to use for next size statement.
388 $v nsubrs. number of routines compiled.
389 $m numfncts. total number of library and builtin functions
390 $v nwarnings. number of warnings.
391 $m octl(i). list contents of i in octal.
392 $m octtok. lexical type of octal constant.
393 $m opb. 'is this an operation' :voa
394 $m opcode. operation code (names by macros of form 'op_') :voa(op)
395 $v opkind. table of operator attributes.
396 $m oplev. operation level for precedence parse. :opstack
397 $m opofbif(op). maps bifatrtab index into opcode of builtin function
398 $m opstackmax. dims of opstack ,max. allowed nesting in expressions)
399 $v opstackp. depth of operator precedence parse.
400 $m optyp. operation type. :opstack
401 $m oup. voa index of item holding result. :voa(op)
402 $r parse. the parser proper.
403 $v parseok. flag, on when parse automaton in 'success' state.
404 $v parsetrace. flag, on to trace parser in action.
405 $m pdotok. lexical code for period delimited operator.
406 $m plus. csa dosignp code for upward do loop (by +...)
407 $m pop(a). retrieve a from arglist.
408 $v proclineno. line number relative to start of current routine.
409 $m ps. number of bits in address or pointer.
410 $r psdstok. get sds form of current token.
411 $r pshnamr. implement pushname macro to hash name, put on arglist.
412 $r ptdata. data statements for parse table pt.
413 $r purge. cleanse tables, prepare for next routine.
414 $m push(hap) $ push hap onto arglist.
415 $r pshintr. implement pushint macro, hash const, put on arglist.
416 $m pushint(pcon). push short integer onto arglist
417 $m pushname(hc, r). push name on arglist.
418 $r pushr. implement push macro, push item onto arglist.
419 $r putvofa. put array slice onto voa file.
420 $m qstok. lexical type of q-format string constant.
421 $m quant. code for ha type 'quantity'
422 $m q3(a,b,c). used to define macros in macros.
423 $m rbtok. lexical type of d-format string constant.
424 $m realopcd(x). 'is opcdde that of real operation'
425 $m realcomparison(op). 'is this real comparison.'
426 $m realtok. lexical type of floating point constant.
427 $m rztok. lexical type of r-format string constant.
428 $v safeconst(a). 'is ha(a) a safe(short) constant.'
429 $v savetoks. number of tokens to be saved in compound statement opener
430 $m sds(n). size of sds item of n characters.
431 $m sdslit. convert token into sds form in littok.
432 $m sdsname(sdsnam, hap). convert ha(hap) item into sds form in sdsnamr
433 $r sdsnamr. implement macro sdsname, used to get sds format.
434 $v sdsnamstr. global scratch area for constructing strings(cf sdsname)
435 $r setcall. debug auxiliary, generate call to run-time debug routine.
436 $r setcons. debug auxiliary, set 'debugtab(deind)=deparm'.(constant)
437 $r setlabl. implement macro setlab, note use of label.
438 $m setlpos(p). set current line position to p.
439 $r setlvar. debug auxiliary, set 'debugtab(deind)=deparm'.(multi-word)
440 $r setq. verify acceptability as value-returning item.
441 $r setvar. debug auxiliary, set 'debugtab(deind)=deparm'.
442 $v sfp_opt. option flag, if on then first routine not put on voa file.
443 $m signbit. 'is this negatibe constant' :voa(var)
444 $v signofcon. flag, on when processing negative constant.
445 $m skipl(i). skip i columns on print line.
446 $m slabbias. upper bound on absolute value of label subscripts
447 $m slen. length field of sds.
448 $m sorg. origin field of sds.
449 $m spectok. code for lexical token of type special.
450 $r squeeze. list most recent tokens seen.
451 $r start. define global variables, initiate execution.
452 $m strtok. lexical type of sds format token.
453 $v subinfo. array of miscellaneous attributes passed to asm.
454 $m subrtyp. code for ha type 'subroutine'
455 $m syze. item size in bits. :voa
456 $m szmax. largest acceptable value in size specification
457 $m tabl(i). move to column i on print line.
458 $v targetmachine. integer code for target machine.
459 $m temb. 'is this a temporary' :voa(var)
460 $m tent. size of temporary. :tlist
461 $m testlbl. -ha- index of 'test' label. :csa
462 $m textl(s). print string.
463 $m tintl(s,i). print string s and integer i.
464 $v tlist. stack of temporary attributes. (cf. blkend)
465 $m tlistmax. dims of tlist.
466 $v tlistptr. top of tlist.
467 $v tmara. array of target machine parameters.
468 $m tmparams. number of parameters in target machine specification
469 $v tmtokara. array of values for converting target machine attributes.
470 $m tmvardef. string giving machine parameters.
471 $m tnext. tlist index of next temporary of same size. :tlist
472 $v tokara. array with token as received from scanner.
473 $m tokaradims. dims of tokara.
474 $m tokarasz. size of tokara.
475 $v toklc. literal code value of current token.
476 $v toklen. token length in characters.
477 $m toklenmax. maximum token length in characters.
478 $v toklt. lexical type of current token.
479 $m toknum. number of tokens saved from opener. :csa
480 $m tokorg. starting token in token list. :csa
481 $v tokrbuf. buffer for reading token file produced by scanner.
482 $m tokrbuflim. dims of tokrbuf (buffer used to read token file)
483 $v tokrbufp. current position in tokrbuf.
484 $m tokrcard. code for card image record on token file.
485 $m tokreof. code for end-of-data on token file.
486 $m tokrlc. token file field giving literal code of token
487 $m tokrlen. token file field giving token length in characters
488 $m tokrtyp. token file field giving token lexical type
489 $m tokrval. token file field giving first few hharacters of token
490 $v tokwords. number of tokara entries used for token.
491 $v tothaexam. number of ha entries examined.
492 $v tothaprobe. number of times ha search initiated.
493 $m totmachines. number of known host, target machines.
494 $v totwaste. number of unused machine words in tables.(cf. genexit)
495 $m traceall. code for 'trace all' debug reqest.
496 $m tracef. is 'trace stores' request in effect. :ha
497 $m tracesome. code for 'trace some' debug reques.
498 $v trentrfg. debug, type of trace entry in effect.
499 $v trentrp. global for macro trentry.
500 $r trentrr. process debug trace entry statement.
501 $m trentry(t). callto debugging generator.
502 $m trflow(t). call to debuggigg generator.
503 $v trflowfg. debug, type of flow trace in effect.
504 $v trflowl. debug, point to ha index of label.
505 $v trflowp. global for macro trflow.
506 $r trflowr. process debug flow trace statement.
507 $m trroutsdim. array dims of array used to coollect subr names
508 $v trstorfg. debug, type of store trace in effect.
509 $v trstori. debug flag, on for indexing.
510 $v trstorp. global argument for routine trstorr.
511 $r trstorr. process debug assignment trace statement.
512 $v trstors. debug, ptr to assignment source.
513 $v trstor1...trstor5. globals for debug assignment trace.
514 $m type. quantity type. :voa(var)
515 $m untiltyp. csa cstype code for until statemett group
516 $m val_code. (voa file) code for val block.
517 $v val. stack of converted constant values.
518 $v valptr. next free position in val.
519 $m val_vn. (voa file) version number of val.
520 $m valmax. dims of val.
521 $m var. 'is this not an operation' :ha
522 $m varpos(i). 'mblen mba(i)', current position in i-th machine block
523 $m vbeg. first word of constant value in -val- :voa(var)
524 $m vlen. number of -val- entries used for constant value :voa(var)
525 $v voa. v-ariable and o-perations a-rray. ha and voa form symbol table
526 $m voa_code. (voa file) code for voa block.
527 $m voa_vn. ,voa file) version number of voa.
528 $m voaasm_code. (voa file) code for routine header block
529 $r voadump. list contents of voa.
530 $m voaeof_code. (voa file) code for end of file.
531 $m voahdr_code. (voa file) code for header block.
532 $m voasz. size of voa.
533 $m voaup. increment voptr (top of voa)
534 $v vof. scratch area used to build frames for voa file.
535 $m vof_asmarg. (voa file header field) asmarg values.
536 $m vof_code. (voa header field) item code.
537 $m vof_debugtab. (voa file header field) value of -debugtab-
538 $m vof_es. (voa file header field) entry size in bits.
539 $m vof_hamax. (voa file header field) -hamax- (ha dims) known to gen
540 $m vof_ha0. (voa file header field). ha_0 value.
541 $m vof_ha1. (voa file header field). ha_1 value.
542 $m vof_hi. (voa file header field) -hi- index of array to transmit
543 $m vof_init. (voa file header field) -init- value.
544 $m vof_lablistptr. (voa file header field) vluue of lablistptr
545 $m vof_lo. (voa file header field) -lo- index for array
546 $m vof_subrargs. (voa file header field) no. of arguments of routine
547 $m vof_sub1. (voa file header field) subinfo(1)
548 $m vof_sub2. (voa file header field) subinfo(2)
549 $m vof_sub3. (voa file header field) subinfo(3)
550 $m vof_tf. (voa file header field) number of trailing data frames
551 $m vof_vn. (voa file header field) - version number.
552 $m vofsz. size of frame on voa file.
553 $m vomax. dims of voa.
554 $v voptr. next free position in voa.
555 $m wordl(w). print all characters in machine word w.
556 $m wpc. number of words for card image.
557 $m ws. number of bits in machine word.
558 $m xarg_code. (voa file) code for xarg block.
559 $m xarg_db. drop bit for this entry in xarg. :xarg
560 $m xarg_rep. replication value for 'data' value. :xarg
561 $m xarg_vn. (voa file) version number of xarg.
562 $m xarg_voa. voa index of item. :xarg
563 $v xarg. extra arguments array used for voa items with many inputs.
564 $m xargmax. dims of xarg.
565 $v xargptr. next free position in xarg.
566 $m xargsz. size of xarg.
567 $v xha. ha for global symbols.
568 $m xhabif. 'is this name of builtin function' :xha
569 $r xhadump. list contents of xha.
570 $m xhasz. size of xha.
571 $m xlink. next -xha- entry with same hash code. :xha
572 $m xnameptr. -xnames- index of characters in name. :xha
573 $v xnames. names array for xha, holds names of globals.
574 $m xnamesmax. dims of xnames.
575 $v xnamesptr. next free position in xha.
576 $m xnchars. length of name in characters. :xha
577 $m xnsblk. machine block (-mba- index) of nameset. :xha
578 $m yes. 1 (for readability)
579 $m zerents. number of zero ha entries before this one. :ha
580
581
1 .=member macros
2
3 $ compilerlevel is the date of last compiler change,
4 $ and must be updated when compiler changed.
5 +* compilerlevel =
rbko 9 'gen(82158)' $ 6 jun 1982
7 **
8
9 +* voafilelevel = $ julian date of last change which alters
10 $ structure of voa file.
11 $ subtract 76000 from date to permit representation in 16 bits
12 76289 $ 15 october 1976.
13 -76000 **
14 $ conditional text options.
15
16 $ the conditional fragments which collect statistics may be of
17 $ interest when bootstrapping the compiler and to periodically
18 $ monitor compiler performance. these fragments are usually
19 $ omitted in a production compiler as users may be confused by
20 $ statistics.
21
22 $ select haprobes to compute statistics on ha searches.
23 .-set haprobes
24
25 $ select ifconstat to compute and list statistics of number
26 $ of -if- statements with constant inputs.
27 .-set ifconstat
28
29 $ select ncfstat to print number of negative constants seen.
30 .-set ncfstat
31
32 $ select realsc to obtain constant folding of expressions in
33 $ real constants (cf. arith). if realsc is enabled, the
34 $ compiler must process real constants and expressions.
35 $ at present, code contained in realsc text is the only use
36 $ of real contants and operations in this program.
37 .+set realsc
38
ldsa 23 $ select rep to enable option to produce report file.
ldsa 24 $ report written to unit repfile (nominally 6).
ldsa 25
ldsa 26 .+set rep
ldsa 27
dso 9 .+s10.
dso 10 .+set movea_env
dso 11 .+set movw_env
dso 12 .+set unpk_env
dso 13 .+set pack_env
dso 14 ..s10
utse 1 .+s32.
utse 2 .+set s32v $ assume vms.
utse 3 ..s32
utse 4
utse 5 .+s32u.
utse 6 .+s32.
utse 7 .-set s32v $ do not want vms.
utse 8 .+set s32u $ want unix os.
utse 9 ..s32
utse 10 .+set mcl $ want primary case to be lower.
utse 11 ..s32u
vax 9 .+s32.
mgfc 8 .+set movea_env,movw_env,unpk_env,pack_env
vax 11 ..s32
39 .+s37.
40 .+set movea_env,movw_env,unpk_env,pack_env
41 ..s37
utsa 16 .+s47.
utsa 17 .-set movea_env,movw_env,unpk_env,pack_env
utsa 18 ..s47
42 .+s66.
43 .+set movw_env,unpk_env,pack_env
44 ..s66
45
utse 12 .+s32u. $ delete env special code for checkout.
ldsb 18 .-set movea_env,movw_env,unpk_env,pack_env
utse 13 ..s32u
46
47 $ define macros giving machine parameters, codes, and oft-used
48 $ code sequences not related to any particular data structure.
49 $ (information relevant to a particular data structure is
50 $ given alphabetically by structure/variable name in the
51 $ routine -start- that immediately follows the macros.)
52
53 $ target machine parameters
54 +* ws = .ws. ** $ machine word size.
55 +* ps = .ps. ** $ machine pointer (address) size.
56 +* cs = .cs. ** $ machine character size.
57 +* cpw = (ws/cs) ** $ characters per machine word
58
59
60 $ fields of self-defining strings
61 +* sorg = .e. (.sl.+1), .so., ** $ origin field of sds.
62 +* slen = .len. ** $ length field of sds.
63
64 +* wpc = $ number of words in card image
65 .+s66 09
vax 12 .+s32 20 $ 80 columns
66 .+s37 20 $ 80 columns
utsa 19 .+s47 20 $ 80 columns
mgfb 8 .+s10 20
68 **
69
70 $ target machine specification and identification.
71
72 +* tmparams = 5 ** $ number of parameters in machine specificatio
73 $ the previous variables -mws-, -mps-, and -mcs-
74 $ are equated to elements in tmara to simplify initialization a
75 $ and to ease addition of new parameters.
76 +* mws = tmara(1) ** $ target machine word size
77 +* mps = tmara(2) ** $ target machine pointer size
78 +* mcs = tmara(3) ** $ target machine character size
79 +* msl = tmara(4) ** $ target machine length of slen field
80 +* mso = tmara(5) ** $ length of target machine sorg field
81
82 +* tmvardef = $ default tm specification taken by compiler
83 .+s66 '6017061113'
dso 15 .+s40 '1615081616'
vax 13 .+s32 '3230081616'
utsa 20 .+s37 '3224081616'
utsa 21 .+s47 '3224081616'
mgfb 9 .+s10 '3618091818'
86 **
87
88 $ macros for machine encodings
utsa 22 +* totmachines = 8 ** $ number of known host, target machines
90 +* m66 = 1 ** $ cdc 6600
91 +* m37 = 2 ** $ ibm system/370
92 +* m16 = 3 ** $ honeywell series 16
93 +* m11 = 4 ** $ pdp-11.
94 +* m10 = 5 ** $ dec system/10
dso 18 +* m40 = 6 ** $ prime 400
vax 15 +* m32 = 7 ** $ dec vax-11
utsa 23 +* m47 = 8 ** $ amdahl uts
95
96 +* hostmachine = $ machine on which compiler runs
97 .+s66 m66
dso 19 .+s40 m40
vax 16 .+s32 m32
98 .+s37 m37
utsa 24 .+s47 m47
99 .+s10 m10
100 **
101
102 +* blankword = $ word of blank chars (see insname).
vax 17 .+s32 4r
103 .+s37 4r
utsa 25 .+s47 4r
dso 20 .+s40 2r
104 .+s66 10r
mgfb 10 .+s10 4r
106 **
107
108
109 $ macros related to file names
110 +* filenamelen = 20 ** $ max. length of file name in chars.
dsu 9 .+s32 +* filenamelen = 64 **
utsa 26 .+s47 +* filenamelen = 64 **
111
dsv 12 $ getapp_len is length of actual parameter string (cf. lexini).
dsv 13 +* getapp_len = 128 **
dsv 14 .+s32 +* getapp_len = 240 **
utsa 27 .+s47 +* getapp_len = 240 **
dsv 15
112 +* tokenfile = 3 ** $ token file number.
113
114 +* voafile = 4 ** $ voa file number.
115
116 +* crfile = 5 ** $ cross reference file number.
117
ldsa 28 .+rep +* repfile = 6 ** $ file if rep option enabled.
dsx 22
118 $ io access codes.
119 +* access_read = 4 **
120 +* access_write = 6 **
121
122 $ macros for listing generation (routines in run-time library).
123
124 +* textl(s) = call textlr(s); ** $ output text
125 +* intl(i) = call intlr(i); ** $ output integer (5 digits)
126 +* intlp(i,p) = call intlpr(i,p); ** $ integer i in p columns
127 +* tintl(s,i) = call tintlr(s,i); ** $ output text+integer
128 +* wordl(w) = call wordlr(w); ** $ output word
129 +* charl(c) = call charlr(c); ** $ output single character
130 +* endl = call endlr; ** $ end line
131 +* getlpos(p) = call contlpr(1,p);** $ get current line pos
132 +* setlpos(p) = call contlpr(2,p);** $ set line position
133 +* skipl(i) = call contlpr(3,i);** $ skip -i- columns
134 +* tabl(i) = call contlpr(4,i);** $ tab to column -i-
135 +* listl(n) = call contlpr(26,n);** $ set listing flag
136 +* terml(n) = call contlpr(27,n);** $ set terminal flag
137 +* ejectl = call contlpr(5,0);** $ eject to new page.
138 +* ejectlp(n) = call contlpr(5,n);** $ eject to new page
139 $ if less than n lines remain on current page.
140
141 +* digofchar(c) = $ value of character digit.
142 (c-1r0) $ use if codes for numbers in order.
143 **
144 +* charofdig(c) = $ maps digit into character code
145 (c+1r0) $ use if codes for numbers in order.
146 **
147
148 $ countup macro for incrementing and testing variable
149 +* countup(var,lim,msg) =
150 var = var+1;
151 if (var>lim) call gtoflo(var,lim,msg); **
152
153
154 $ q3 and macdef are used to define macros in macros. macdrop
155 $ releases macro from macro status
156
157 +* q3(a,b,c) = a b c **
158 +* macdef(text) = q3(+,*text*,*) **
159 +* macdrop(mname) = macdef(mname=) **
160
161
162 $ yes and no macros used for logical expressions to clarify
163 $ logical intent.
164 +* yes = 1 **
165 +* no = 0 **
166
167 +* blockmax = 3b'777' ** $ max length of basic block
dsw 10 +* dimsmax = $ maximum dimension
dsw 11 .+s10 3b'377777'
dsw 12 .+s32 4b'3fffffff'
dsw 13 .+s37 4b'3fffff'
utsa 28 .+s47 4b'3fffff'
dsw 14 .+s40 3b'177777'
dsw 15 .+s66 3b'177777'
dsw 16 **
169 +* levmax = 63 ** $ maximum definition level, which is the
170 $ largest value that can be held in -deflev- field.
171 +* toklenmax = 150 ** $ maximum length of token in characters
172
173 +* keylenmax = 20 ** $ maximum length of 'key' in io clause.
174 +* namsz = .sds. toklenmax **
175 +* nameorg = (namsz+1) **
176
177 $ szmax is the maximum acceptable item size. if a larger size
178 $ item is requested, an error message is issued and the size
179 $ is reduced to szmax (see routine -gensiz-). szmax also
180 $ occurs in the run-time library text, and both values should
181 $ be the same.
182 +* szmax = $ maximum item size in bits
183 2047
184 **
185 $ codes for type of call as used by generator -gencall-.
186 +* call_noparms = 1 ** $ no parameters, hence subroutine call
187 +* call_parms = 2 ** $ subroutine call with parameter list.
188 +* call_value = 3 ** $ call with value returned, must have
189 $ parameter list. may be function call or array reference.
190
191 $ the following macros assign codes to literals
192 $ these codes must be identical to the literal codes in lex
193 +* lc_if = 1 **
194 +* lc_while = 2 **
195 +* lc_until = 3 **
196 +* lc_do = 4 **
197 +* lc_end = 5 **
198 +* lc_else = 6 **
199 +* lc_size = 7 **
200 +* lc_dims = 8 **
201 +* lc_data = 9 **
202 +* lc_semicolon= 10 **
203 +* lc_nameset = 11 **
204 +* lc_access = 12 **
205 +* lc_real = 13 **
206 +* lc_call = 14 **
207 +* lc_goby = 15 **
208 +* lc_return = 16 **
209 +* lc_elseif = 17 **
210 +* lc_goin = 18 ** $ 'in', not '.in.'
211 +* lc_sdsop = 19 ** $ .sds.
212 +* lc_voapart = 20 ** $ .voapart. $ for partial voa dmump
213 +* lc_rewind = 21 **
214 +* lc_filestat = 22 **
215 +* lc_go = 23 **
216 +* lc_cont = 24 **
217 +* lc_quit = 25 **
218 +* lc_fext = 26 ** $ .f.
219 +* lc_eext = 27 ** $ .e.
220 +* lc_sext = 28 ** $ .s.
221 +* lc_chext = 29 ** $ .ch.
222 +* lc_ccat = 31 ** $ .cc.
223 +* lc_to = 32 **
224 +* lc_or = 33 ** $ .or.
225 +* lc_ex = 34 ** $ .ex.
226 +* lc_exor = 35 ** $ .exor.
227 +* lc_orsym = 36 ** $ !
228 +* lc_and = 37 ** $ .and.
229 +* lc_andsym = 38 ** $ &
230 +* lc_andbrev = 39 ** $ .a.
231 +* lc_eq = 40 ** $ .eq.
232 +* lc_ne = 41 ** $ .ne.
233 +* lc_gt = 42 ** $ .gt.
234 +* lc_lt = 43 ** $ .lt.
235 +* lc_ge = 44 ** $ .ge.
236 +* lc_le = 45 ** $ .le.
237 +* lc_eqsym = 46 ** $ =
238 +* lc_ltsym = 47 ** $ <
239 +* lc_gtsym = 48 ** $ >
240 +* lc_notsym = 49 ** $ ^
241 +* lc_plus = 50 ** $ +
242 +* lc_minus = 51 ** $ -
243 +* lc_times = 52 ** $ *
244 +* lc_divide = 53 ** $ /
245 +* lc_in = 54 **
246 +* lc_not = 55 ** $ .not.
247 +* lc_notbrev = 56 ** $ .n.
248 +* lc_fb = 57 **
249 +* lc_nb = 58 **
250 +* lc_check = 59 **
251 +* lc_trace = 60 **
252 +* lc_assert = 61 **
253 +* lc_nocheck = 62 **
254 +* lc_notrace = 63 **
255 +* lc_subr = 64 **
256 +* lc_fnct = 65 **
257 +* lc_monitor = 66 **
258 +* lc_lparen = 67 ** $ (
259 +* lc_rparen = 68 ** $ )
260 +* lc_comma = 69 **
261 +* lc_colon = 70 **
262 +* lc_then = 71 **
263 +* lc_by = 72 **
264 +* lc_index = 73 **
265 +* lc_flow = 74 **
266 +* lc_stores = 75 **
267 +* lc_entry = 76 **
268 +* lc_voadump = 77 **
269 +* lc_len = 78 **
270 +* lc_pad = 79 ** $ .pad.
271 +* lc_file = 80 **
272 +* lc_nocontr = 81 **
273 +* lc_toktr = 82 **
274 +* lc_notoktr = 83 **
275 +* lc_contr = 84 **
276 +* lc_get = 85 **
277 +* lc_put = 86 **
278 +* lc_mws = 87 ** $ .ws.
279 +* lc_mps = 88 ** $ .ps.
280 +* lc_mcs = 89 ** $ .cs.
281 +* lc_msl = 90 ** $ .sl.
282 +* lc_mso = 91 ** $ .so.
283 +* lc_limit = 92 **
284 +* lc_read = 93 **
285 +* lc_write = 94 **
286 +* lc_prog = 95 **
287 +* lc_seq = 96 ** $ .seq.
288 +* lc_sne = 97 ** $ .sne.
289
290 +* litcodes = 97 **
291
292
293 $ macros related to parser and lexical token processing
294
295
296 $ (codes must agree with those assigned by lex phase.)
297 $ the codes used in token reader routine -nextok-
298 $ codes for lexical types assigned in lexical scan
299 +* toktypes = 14 ** $ no. of token types below
300 +* nametok = 1 ** $ name
301 +* spectok = 2 ** $ special token, e.g. (
302 +* pdotok = 3 ** $ type of period delimited operators
303 +* dectok = 4 ** $ type of decimal integers, e.g. 100
304 +* sstok = 5 ** $ special string token, e.g., 6s...mcr
305 +* strtok = 6 **
306 +* bittok = 8 **
307 +* rztok = 12 ** $ right-zero type string constant (r)
308 +* realtok = 14 ** $ real token
309 +* listcontroltok = 27 ** $ '.=list' directive.
310 +* listejecttok = 28 ** $ '.=eject' list directive.
311 +* listtitletok = 29 ** $ '.=title' directive.
312 +* tokrcard = 30 ** $ code for card image
313 +* tokreof = 31 ** $ code for end-token-file
314
315 .+s66.
316 +* tokrtyp = .f. 1, 5, ** $ token type (lex type or code)
317 +* tokrlen = .f. 7, 7, ** $ length of token in chars
318 +* tokrlc = .f. 14, 9, ** $ token literal code
319 .-s66.
320 +* tokrtyp = .f. 1, 8, **
321 +* tokrlen = .f. 9, 8, **
322 +* tokrlc = .f. 17, 8, **
323 ..s66
324
325 +* tokrval = $ first few characters of short token.
326 .+s66 .f. 25, 36,
dso 21 .+s40 .f. 25, 8,
vax 18 .+s32 .f. 25, 8,
dso 22 .+s37 .f. 25, 8,
utsa 29 .+s47 .f. 25, 8,
mgfb 11 .+s10 .f. 28, 9,
329 **
330
331 +* cpstr = $ character per short token record
332 .+s66 6
dso 23 .+s40 1
vax 19 .+s32 1
dso 24 .+s37 1
utsa 30 .+s47 1
mgfb 12 .+s10 1
335 **
336
337 +* constok = 4 ** $ code of first constant type
338
339 $ macros initializing machine blocks
340 +* nblocks = 63 ** $ number of loader machine blocks
341 +* localblock = 8 ** $ local variable block
342 +* globalblock = 10 ** $ global variable block
343
344 $ macros for ha-quantity type values
345
346 +* quant = 2 **
347 +* subrtyp = 0 **
348
349
350 +* nopcodes = 76 ** $ number of voa opcodes.
351
352 +* commutes(op) = $ is this operator commutative.
353 .f. 1, 1, opkind(op) **
354
355 +* blkendtype(op) = $ gross type used by blkend.
356 .f. 3, 6, opkind(op) **
357
358 $ macros defining opcodes of voa-operations
359 +* op_add = 1 **
360 +* op_sub = 2 **
361 +* op_gt = 3 **
362 +* op_lt = 4 **
363 +* op_ge = 5 **
364 +* op_le = 6 **
365 +* op_eq = 7 **
366 +* op_ne = 8 **
367 +* op_mul = 9 **
368 +* op_div = 10 **
369 +* op_or = 11 **
370 +* op_seq = 12 ** $ .seq. character string equality.
371 +* op_and = 13 **
372 +* op_exor = 14 **
373 +* op_sne = 15 ** $ .sne. character string inequality.
374 +* op_nb = 16 ** $ number of bits operation
375 +* op_fb = 17 ** $ first bit operation
376 +* op_not = 18 ** $ not operation
377 +* op_fcall = 19 **
378 +* op_usub = 19 ** $ unary minus
379 +* op_call = 20 ** $ call-type operation
380 +* op_scall = 20 **
381 +* op_pad = 20 ** $ .pad. (not in -voa-)
382 +* op_asin = 21 ** $ simple assignment operation
383 +* op_data = 22 ** $ data operatio
384 +* op_fasin = 23 ** $ field assignment .f.
385 +* op_io = 24 ** $ binary transput
386 +* op_return = 25 ** $ return
387 +* op_fext = 26 ** $ extraction operation
388 +* op_if = 27 ** $ if (...) go to
389 +* op_lab = 28 ** $ label definition
390 +* op_goto = 29 ** $ go to
391 +* op_goby = 30 **
392 +* op_xload = 31 ** $ indexed (array) load
393 +* op_xasin = 32 ** $ indexed store
394 +* op_xfasin = 33 ** $ indexed field store
395 +* op_ifnot = 34 ** $ if not
396 +* op_ccat = 35 ** $ .cc. operation
397 +* op_in = 36 ** $ .in. operation
398 +* op_eext = 37 ** $ .e. extract op
399 +* op_sext = 38 ** $ .s. extract operation
400 +* op_easin = 39 ** $ .e. field assignment
401 +* op_sasin = 40 ** $ .s. field assignment
402 +* op_xeasin = 41 ** $ .e. indexed field store
403 +* op_xsasin = 42 ** $ .s. indexed field store
404 +* rop_add = 43 ** $ real add
405 +* rop_sub = 44 ** $ real subtract
406 +* rop_gt = 45 ** $ real greater than
407 +* rop_lt = 46 ** $ real less than
408 +* rop_ge = 47 ** $ real greater than or equal to
409 +* rop_le = 48 ** $ real less than or equal to
410 +* rop_eq = 49 ** $ real equal to
411 +* rop_ne = 50 ** $ real not equal to
412 +* rop_mul = 51 ** $ real multiplication
413 +* rop_div = 52 ** $ real division
414 +* rop_usub = 53 ** $ real unary minus
415 +* bop_first = 54 ** $ first built-in function
416 +* bop_float = 54 ** $ integer to real
417 +* bop_ifix = 55 ** $ real to integer
418 +* bop_abs = 56 ** $ absolute value
419 +* bop_iabs = 57 ** $ absolute value
420 +* bop_aint = 58 ** $ sign of a * (largest integer <= abs(a))
421 +* bop_int = 59 ** $ sign of a * (largest integer <= abs(a))
422 +* bop_amod = 60 ** $ a1 mod a2
423 +* bop_mod = 61 ** $ a1 mod a2
424 +* bop_sign = 62 ** $ sign of a2 with abs(a1)
425 +* bop_isign = 63 ** $ sign of a2 with abs(a1)
426 +* bop_dim = 64 ** $ if a1 > a2 then a1-a2 else 0
427 +* bop_idim = 65 ** $ if a1 > a2 then a1-a2 else 0
428 +* bop_exp = 66 ** $ exponential
429 +* bop_alog = 67 ** $ natural log
430 +* bop_alog10 = 68 ** $ common log
431 +* bop_sin = 69 ** $ sine
432 +* bop_cos = 70 ** $ cosine
433 +* bop_tanh = 71 ** $ hyperbolic tangent
434 +* bop_sqrt = 72 ** $ square root
435 +* bop_atan = 73 ** $ arc tangent
436 +* bop_atan2 = 74 ** $ atan(a1/a2)
437 +* bop_last = 74 ** $ last builtin.
438 +* op_list = 75 ** $ list directive for asm.
439
440
441 +* proc_initiate = 'ltlini' ** $ initiation routine for program.
442 +* proc_terminate = 'ltlfin' ** $ program termination procedure.
ldse 11 +* proc_expire = 'ltlced' ** $ check expiration date.
443
444
445
446 +* conval(hap) = (val(vbeg voa(ep ha(hap)))) ** $ constant value
447
448 $ macros to pop arguments from arglist
449
450 +* isuse(hap) = $ note use of ha(hap) as input to computation
451 call isusep(hap); **
452 +* ifaglob(xhap, nam) = $ see if name is global
453 ifaglorname = nam; call ifaglor(xhap); **
454 +* insglob(glohc, namea) = $ insert name in globals list
455 insgarg = namea; $ ptr to name in ha
456 call insglor(glohc); **
457
458
459 +* sds(n) = .sds. (n) ** $ size of sds of n characters.
460
461 +* sdsname(sdsnam, hap) = $ converts name indicated by 'hap'
462 $ to sds stored in sdsnam by calling routine sdsnamr
463 call sdsnamr(hap);
464 sdsnam = sdsnamstr; **
465
466 +* naml(hap) = $ print name of ha item
467 call sdsnamr(hap);
468 textl(sdsnamstr) ** $ sdsnamr puts char string in sdsnamstr
469
470 $ member synmac
471 $ syn run on fri 17 feb 78 10:51:46
472 +* parsearamax = 818 **
473 +* parselitaramax = 0 **
474 +* parselexaramax = 0 **
475 +* parseactmax = 39 **
476 +* parseerrloc = 814 **
477 +* parseerrmax = 103 **
478 $ end member synmac
479 +* ptmax = parsearamax **
480
481
482
483 +* push(hap) = $ push ptr onto arglist.
484 arglist(argptr) = hap; $ put onto stack.
485 argptr = argptr + 1; $ advance pointer.
486 **
487
488 +* pop(hap) = $ retrieve hap from arglist.
489 argptr = argptr-1; hap = arglist(argptr); **
490
491 +* pushint(pcon) = $ push integer on arg stack after
492 $ hashing it into ha and inserting value in val array via
493 call pshintr(pcon); **
494
495 +* pushname(hc, r) = $ hash name into ha and names array
496 $ push result on arglist
497 call pshnamr(hc, r); **
498
499
500
501 $ macros pertaining to real quantities
502 +* amode_real = 1 **
503 +* realopcd(x) = (.f. 2, 1, opkind(x)) ** $ real operation.
504 +* realcomparison(op) = $ is this real comparison.
505 ((op >= rop_gt) & (op <= rop_ne)) **
506
dst 9 +* arithcomparison(op) = $ is this arithmetic comparison.
dst 10 ((op >= op_gt) & (op <= op_le)) **
dst 11
507 $ define headers for message classes.
508 +* error_notice = '*****error**** ' **
509 +* system_notice = '*system error* ' **
510 +* warning_notice = '****warning*** ' **
511
512
mgfc 9 .+s10. $ s10 wants special characters at start of error
mgfc 10 $ and warning lines.
mgfc 11 +* warn_s10 = charl(37) ** $ per cent for warnings.
mgfc 12 +* error_s10 = charl(63) ** $ question mark for errors.
mgfc 13 ..s10
ldsa 29
ldsa 30 .+rep. $ initialize rep option codes
ldsa 31
ldsa 32 +* rep_typ = 1 ** $ type
ldsa 33 +* rep_int = 2 ** $ integer
ldsa 34 +* rep_nam = 3 ** $ name
ldsa 35 +* rep_end = 4 ** $ end (of report line)
ldsa 36
ldsa 37 +* rep_typ_c = 1 ** $ call
ldsa 38 +* rep_typ_g = 2 ** $ global variable
ldsa 39 +* rep_typ_n = 3 ** $ nameset
ldsa 40 +* rep_typ_p = 4 ** $ procedure
ldsa 41
ldsa 42 +* rep_typ_max = 4 ** $ number of rep types
ldsa 43
ldsa 44 ..rep
ldsa 45
1 .=member start
dso 25 .+s10 prog start;
vax 20 .+s32 prog start;
dso 26 .+s37 prog start;
utsa 31 .+s47 prog start;
dso 27 .+s66 subr start;
4 size proclist(1); $ on to list procedure names and pages.
5 data proclist = no;
6
7 $ define global variables and structures, in alphabetical order.
8 $ it is assumed that this text compiled with 'default access'
9 $ option so that every routine may refer to globals defined in
10 $ this routine.
11
12 $ accesstab has bit -i- set if user is to be granted
13 $ access to nameset at mba(i).
14 size accesstab(nblocks); $ access table, indexed by blocks
15
16 $ argct is number of formal arguments of current routine.
17 size argct(ps); data argct = 0;
18
19 $ a data statement is used in initialization of -littab- below.
20 $ a r g l i s t - parser/generator communication array.
21 $ argmax is the dimension of arglist. as the data values in
22 $ the value list of a data statement and the labels of a goby
23 $ statement are stacked on arglist, argmax thus gives the
24 $ maximum length of these lists.
25 +* argmax = 500 ** $ dims of arglist
26 size argptr(ps); data argptr = 1; $ ptr to arglist
27 size arglist(ps); $ operand push down stack
28 dims arglist(argmax);
29
30 $ the compiler option -ad- sets asmvoadump to request symbol
31 $ table dump at end of every routine compiled.
32 size asmvoadump(ps); data asmvoadump=0; $ on for asm voa write
33
34 $ b u i l t i n f u n c t i o n s.
35 +* numfncts = 21 ** $ total number of library and builtin fncts
36 $ macro to test for built in fnct op
37 +* builtin(op) = ((op >= bop_first)&(op <= bop_last)) **
38 $ -bifofop(op) maps opcodes for builtin operations into code
39 $ giving position of attributes in -bifatrtab-.
40 +* bifofop(op) = (op-(bop_first-1)) **
41 +* opofbif(x) = (x +(bop_first-1)) ** $ inverse of -bifofop-
42
43 size bifatrtab(ws); dims bifatrtab(numfncts); $ attribute table
44 data bifatrtab = 0(numfncts); $ filled in by -genini-
45
46 $ fields of -bifatrtab-
47 +* bfmode = .f. 1, 01, ** $ mode of return value
48 +* bfext = .f. 2, 01, ** $ 'function is off-line'
49 +* bfargs = .f. 3, 02, ** $ number of arguments
50 +* bfalias = .f. 5, 10, ** $ -xha- index of function actually
51 $ called (or zero if user name is to be used)
52
53
54 $ flag turned on when searching for possible builtin function
55 $ name in xha using -ifaglob- macro.
56 size bifxhasearch(1); data bifxhasearch = no;
57
58 .+haprobes.
59 $ blkendreset is number of times blkend had to reset deflev fld.
60 size blkendreset(ws); data blkendreset=0;
61 ..haprobes
62
63 $ buildreal is set when -real- declaration seen.
64 size buildreal(1); data buildreal = 0;
65
66 $ constant conversion.
67 $ constants are converted by the routine cnvcon and inserted
68 $ into the ha by the routine inscon.
69 $ cnvcon takes the array of characters in array cca, from
70 $ positions 1 through ccaptr. if the lexical type, as given
71 $ cclt, is that of a 'safe' constant, the constant is converted
72 $ into internal form in array -ccval-, in locations 1 through
73 $ ccvalptr. cnvcon sets -ccsyze- to the correct size.
74 $ if the constant cannot be converted, it is kept in character
75 $ form in ccval.
76 $ string constants should be passed to cnvcon then inscon
77 $ and not to cnvcon directly so that character count
78 $ ccnchars computed by cnvcon will be available to inscon.
79 $
80 $ inscon locates the ha index of the constant in ccval, building
81 $ a new ha entry if necessary.
82
83 size ccaptr(ps); $ position of last character in cca.
84 size cca(cs); dims cca(toklenmax);
85 size cclt(ps); data cclt=0; $ lexical type of constant
86 size ccnchars(ps); $ character count if string-type token.
87 size ccsyze(ps); $ length of constant in bits
88 size ccvalptr(ps); $ entries used in ccval.
89 size ccval(ws); $ value array for converted constant.
90 dims ccval(toklenmax);
91
92 $ flags to indicate character extractions or assigments.
93 size chasflg(1); data chasflg = no; $ character assignments
94 size chexflg(1); data chexflg = no; $ character extractions
95
dss 20 $ cis_opt is cis option value. if nonzero, then instances
dss 21 $ of a(e) where size of e is greater than cis_opt are reported
dss 22 $ as warnings.
dss 23 size cis_opt(ps); $ cis option value.
96
97 +* crefput(i) = $ write entry to reference file.
98 crbuffptr = crbuffptr + 1;
99 crbuff(crbuffptr) = i;
100 if crbuffptr = crbuffmax then $ write full buffer
101 call wtrwsio(crfile, iorc, crbuff, 1, crbuffptr);
102 crbuffptr = 0;
103 end if;
104 **
105 +* crbuffmax = 256 **
106 $ cross-reference variables.
107 nameset gencrf;
108 size crfilename(sds(filenamelen)); $ name of reference file.
109 size crfileparm(sds(filenamelen)); $ skeleton for ref. file name
110 size crbuffptr(ps); data crbuffptr= 0;
111 size crbuff(ws); dims crbuff(crbuffmax);
112 size crossrefoption(1); data crossrefoption = no;
113 end nameset gencrf;
114
115 $ c s a . compound statement array
116
117 $ the csa records the status of open, or pending, compound
118 $ statement groups. its dimension, csamax, gives the maximum
119 $ depth of compound statement nesting.
120 $ the csa fields fall into the following groups.
121 $ flow control - testlbl, endlbl, bodylbl. most of the flow
122 $ constructs may be divided into three parts. a test section
123 $ which computes the loop control expression, a body which
124 $ contains the loop code, and an end label marking the
125 $ start of the first statement after the compount group.
126 $ these fields contain the ha indices of generated labels.
127 $ do group - dovarp, dolop, dohip, dosignp, doincp.
128 $ dovarp is the ha index of the loop variable, dolop(dohip) the
129 $ index of the starting(ending) expression, dosignp is set for
130 $ a descending do(' by -'), and doincp is the ha index of the
131 $ increment expression, or by part.
132 $ gross type - cstype, csiftype. cstype is the type of the
133 $ entry. csiftype is used for if statements only, and gives
134 $ the type of the various member clauses.
135 $ token list - tokorg, toknum. the initial tokens of the
136 $ statement are saved in array csatok. tokorg gives the index
137 $ of the first of the toknum entries. the tokens are checked
138 $ by routine comptok as part of processing for quit, cont, and
139 $ end statements.
140 $ debugging - firstst, ifnum. firstst is the line number,
141 $ relative to the start of the routine, of the start of the
142 $ group. ifnum is the assigned block number used by flow
143 $ trace option.
144
145 +* csamax = 20 ** $ dimension of csa array
146 +* csasz = $ size of csa
147 .+s66 120
vax 21 .+s32 128
148 .+s37 128
utsa 32 .+s47 128
149 .+s10 144
150 **
151
152 +* csatokmax = csamax*5 ** $ dimension of array for saved opener
153 size csa(csasz); dims csa(csamax); $ compound statement aray
154 size csaptr(ps); data csaptr= 0; $ ptr to csa
155 .+s66.
156 +* bodylbl = .f. 01, 10, **
157 +* oldmblk = .f. 01, 06, **
158 +* endlbl = .f. 11, 10, **
159 +* testlbl = .f. 21, 10, **
160 +* dovarp = .f. 31, 10, **
161 +* dolop = .f. 41, 10, **
162 +* dohip = .f. 51, 10, **
163 +* dosignp = .f. 61, 01, **
164 +* doincp = .f. 62, 10, **
165 +* cstype = .f. 72, 04, **
166 +* csiftype = .f. 76, 03, **
167 +* tokorg = .f. 79, 07, **
168 +* toknum = .f. 86, 03, **
169 +* firstst = .f. 89, 11, **
170 +* ifnum = .f. 100, 10, **
171 ..s66
vax 22 .+s32.
vax 23 +* endlbl = .f. 1, 16, **
vax 24 +* testlbl = .f. 17, 16, **
vax 25 +* cstype = .f. 33, 8, **
vax 26 +* tokorg = .f. 41, 8, **
vax 27 +* toknum = .f. 49, 3, **
vax 28 +* dosignp = .f. 52, 1, **
vax 29 +* bodylbl = .f. 55, 10, **
vax 30 +* oldmblk = .f. 57, 8, **
vax 31 +* dovarp = .f. 65, 10, **
vax 32 +* csiftype = .f. 65, 8, **
vax 33 +* dolop = .f. 76, 10, **
vax 34 +* firstst = .f. 86, 11, **
vax 35 +* dohip = .f. 97, 10, **
vax 36 +* ifnum = .f. 108, 11, **
vax 37 +* doincp = .f. 119, 10, **
vax 38 ..s32
172 .+s37.
173 +* endlbl = .f. 1, 16, **
174 +* testlbl = .f. 17, 16, **
175 +* cstype = .f. 33, 8, **
176 +* tokorg = .f. 41, 8, **
177 +* toknum = .f. 49, 3, **
178 +* dosignp = .f. 52, 1, **
179 +* bodylbl = .f. 55, 10, **
180 +* oldmblk = .f. 57, 8, **
181 +* dovarp = .f. 65, 10, **
182 +* csiftype = .f. 65, 8, **
183 +* dolop = .f. 76, 10, **
184 +* firstst = .f. 86, 11, **
185 +* dohip = .f. 97, 10, **
186 +* ifnum = .f. 108, 11, **
187 +* doincp = .f. 119, 10, **
188 ..s37
utsa 33 .+s47.
utsa 34 +* endlbl = .f. 1, 16, **
utsa 35 +* testlbl = .f. 17, 16, **
utsa 36 +* cstype = .f. 33, 8, **
utsa 37 +* tokorg = .f. 41, 8, **
utsa 38 +* toknum = .f. 49, 3, **
utsa 39 +* dosignp = .f. 52, 1, **
utsa 40 +* bodylbl = .f. 55, 10, **
utsa 41 +* oldmblk = .f. 57, 8, **
utsa 42 +* dovarp = .f. 65, 10, **
utsa 43 +* csiftype = .f. 65, 8, **
utsa 44 +* dolop = .f. 76, 10, **
utsa 45 +* firstst = .f. 86, 11, **
utsa 46 +* dohip = .f. 97, 10, **
utsa 47 +* ifnum = .f. 108, 11, **
utsa 48 +* doincp = .f. 119, 10, **
utsa 49 ..s47
189 .+s10.
190 +* bodylbl = .f. 1, 18, **
191 +* oldmblk = .f. 1, 18, **
192 +* testlbl = .f. 19, 18, **
193 +* endlbl = .f. 37, 18, **
194 +* dovarp = .f. 55, 18, **
195 +* csiftype = .f. 55, 18, **
196 +* dolop = .f. 73, 10, **
197 +* dohip = .f. 83, 10, **
198 +* doincp = .f. 93, 10, **
199 +* cstype = .f. 103, 4, **
200 +* dosignp = .f. 107, 1, **
201 +* firstst = .f. 109, 11, **
202 +* ifnum = .f. 120, 10, **
203 +* tokorg = .f. 130, 8, **
204 +* toknum = .f. 138, 3, **
205 ..s10
206
207 $ type codes used in cstype field.
208 +* cstypes = 8 ** $ number of compound statement types.
209 +* cstype_subr = 1 **
210 +* cstype_fnct = 2 **
211 +* cstype_while = 3 **
212 +* cstype_until = 4 **
213 +* cstype_if = 5 **
214 +* cstype_do = 6 **
215 +* cstype_prog = 7 **
216 +* cstype_nameset = 8 **
217 +* csiftype_else = 3 ** $ special types of if statements
218 +* csiftype_then = 1 **
219 +* csiftype_sif = 2 ** $ simple if
220 +* csiftype_elseif = 4 ** $ elseif
221
222 +* csacountup(msg) = $ countup csa array
223 countup(csaptr, csamax, 'csa'); $ increment csa top
224 savetoks = 0; ** $ to start saving of tokens.
225
226 $ the tokens following openers and enders are saved in csatok.
227 size csatokptr(ps); data csatokptr=0; $ ptr to csatok
228 size csatok(ws); $ array of opener tokens.
229 dims csatok(csatokmax);
230
231 size curblock(ps); $ ptr to voa for basic block beginning
232 data curblock = 1;
233
234 size currsubrname(namsz); $ current subr name
235 data currsubrname = ' ';
236
237 $ if da (d-efault a-ccess) compiler option on, then each routine
238 $ is to be granted access to all namesets defined
239 $ in the first routine compiled.
240 size daopt(ps); $ on if default access is to be granted
ldse 12 size expire(ws); $ days to expiration.
241
242 $ d e b u g f a c i l i t y.
243
244 $ globals relating to debug package.
245
246 $ macros related to debugging package
247
248 +* flowgenlim = 1023 ** $ limit for no. of blocks traced
249 +* assertdim = 25 ** $ dimension of assert stack
250
251 $ values of parm to trentry routine
252 +* entrrout = 1 ** $ entry trace at subr or fnct
253 +* entrend = 2 ** $ trace print for entry at return
254
255 $ calls to debugging generators
256 +* trentry(t) = trentrp = t; call trentrr; **
257 +* trflow(t) = trflowp = t; call trflowr; **
258
259
260 $ fields of global variable trflowp which is parameter to
261 $ routine trflowr
262 +* flowp = .f. 1, 3, ** $ type of flow call (while, until, etc)
263 +* flowiftyp = .f. 4, 3, **
264 +* flowhil = 1 ** $ 'while' statement
265 +* flowtil = 2 ** $ 'until' statement
266 +* flowdo = 3 ** $ 'do' statement
267 +* flowift = 4 ** $ 'if' - true
268 +* flowiff = 5 ** $ 'if' - false
269 +* flowifsf = 3b'15' ** $ 'if' - simple case - false
270 +* flowifnsf = 3b'25' ** $ 'if' ... then ... end - false
271 +* flowifgt = 3b'14' ** $ 'if' ... go to - true
272 +* flowlab = 6 ** $ label
273 +* flowend = 99 ** $ print trace at return
274
275 size assertfg(1); data assertfg = 0; $ assert flag
276 size assertst(ps); dims assertst(assertdim); $ asserstk
277 size assertstp(ps); data assertstp = 0; $ ptr to assert stk
278 size debuglevel(2); data debuglevel = 1; $ debug level
279 $ 0: ignore all debug statements
280 $ 1: process simple assert statements (default)
281 $ 2: process full debug options (set when -help- is specified)
282
283 +* numdebugnames = 16 ** $ number of debug routines
284 +* dbg_prst = 1 ** $ print stores
285 +* dbg_pren = 5 ** $ print entry
286 +* dbg_prex = 6 ** $ print exit
287 +* dbg_prar = 7 ** $ print value of argument
288 +* dbg_prfl = 8 ** $ print flow trace
289 +* dbg_trfl = 9 ** $ trace flow
290 +* dbg_cinx = 10 ** $ check index
291 +* dbg_prhd = 11 ** $ print assert header
292 +* dbg_prvr = 12 ** $ print assert variable
293 +* dbg_asfl = 13 ** $ print assertion failed message in simple c
294 +* dbg_subn = 14 ** $ set subroutine info at entry
295 +* dbg_subx = 15 ** $ inform of subroutine exit
296 +* dbg_setx = 16 ** $ set run-time controls
297
298 size dbgts(sds(4)); $ debug trailer string
299 data dbgts = '$mp';
300
301 size debugnames(sds(8)); dims debugnames(numdebugnames);
302 data $ initialize to standard four character names
303 $ trailing blanks eliminated when trailer added by -genini-.
304 debugnames(dbg_prst) = 'prs3 ', 'prs4 ',
305 'prs5 ', 'prst ':
306 debugnames(dbg_pren) = 'pren ':
307 debugnames(dbg_prex) = 'prex ':
308 debugnames(dbg_prar) = 'prar ':
309 debugnames(dbg_prfl) = 'prfl ':
310 debugnames(dbg_trfl) = 'trfl ':
311 debugnames(dbg_cinx) = 'cinx ':
312 debugnames(dbg_prhd) = 'prhd ':
313 debugnames(dbg_prvr) = 'prvr ':
314 debugnames(dbg_asfl) = 'asfl ':
315 debugnames(dbg_subn) = 'subn ':
316 debugnames(dbg_subx) = 'subx ':
317 debugnames(dbg_setx) = 'setx ';
318
319 +* testdebug = $ this macro test to see if debugging is ignored
320 if (debuglevel ^= 2) return **
321
322 size dbgparm(ws), dbgchange(ws); $ for -gendebug-
325 size dbgha(ps); $ used by -gendebug- for ha pointer
326 size trentrp(ps); $ global variable for trentrr
327 size trflowl(ps); $ ptr to ha entry of label
328 size trflowp(ps); $ global for trflowr
329 size trstori(1); $ flag indicating indexing
330 size trstorp(ps); $ global for trsotr
331 size trstors(ps); $ ptr to source of assignemnt
332 size trstor1(ps); $ globals for debug store parametrs
333 size trstor2(ps);
334 size trstor3(ps);
335 size trstor4(ps);
336 size trstor5(ps);
337 +* dbgspcmax = 25 ** $ numbers of vars listed in trace/check
338 $ but not yet sized.
339 size dbgcspc(ps); dims dbgcspc(dbgspcmax); $ 'check' special
340 size dbgcspcf(dbgspcmax); $ 'check' flags
341 size dbgcspcp(ps); $ pointer to -dbgcspc-
342 size dbgtspc(ps); dims dbgtspc(dbgspcmax); $ 'trace' special
343 size dbgtspcf(dbgspcmax); $ 'trace' flags
344 size dbgtspcp(ps); $ pointer to -dbgtspc-
345 size dparm(ps), dval(1); $ parameters to -gendebug-.
346
meal 13 size trentrargs(1); $ trace entry argument list.
347 size trentrfg(1); $ trace entry
348 size trflowfg(1); $ trace flow
349 size trstorfg(1); $ trace stores
350 size chinxfg(1); $ check index
351 data trentrfg = no: trflowfg = no:
352 trstorfg = no: chinxfg = no;
353
354 size trstorsfg(1); $ set if trace/notrace w/o namelist given
355 size chinxsfg(1); $ same but for check/nocheck
356
357 size gtrflowfg(1); $ global flow trace flag
358 size gtrentrfg(1); $ global entry trace flag
359 size gtrstorfg(1); $ global store trace flag
360 size gchinxfg(1); $ global check stores flag
361 data gtrflowfg = no: gtrentrfg = no:
362 gtrstorfg = no: gchinxfg = no; $ flags are off by default
363 size preludefg(1); data preludefg = yes; $ reset by first subr
364 size flowgen(ps); data flowgen = 0; $ flow number generator
365
utsa 50 .+s37.
utsa 51 $ ebcascoption is nonzero to translate char strings from
utsa 52 $ ebcdic to ascii (used for s47 bootstrap).
utsd 1 size ebcascoption(ps);
utsa 54 ..s37
366 size endblock(1); data endblock = yes; $ flag to end block
367 $ at subr call
368
369 $ defaccesstab is bitstring with bit i on if nameset i defined
370 $ if first routine, and is used to determine which namesets the
371 $ program can access by deault if 'default access' option on.
372 $ defaccesstab set by gensub.
373 size defaccesstab(nblocks); data defaccesstab = 0;
374
375 size defnstouse(ps); $ 'default' ns to use
376
377 size docontrace(1); data docontrace=no; $ on to trace constants
378
379 $ variables for reusing -do- variables
380 +* dovarmax = 32 ** $ maximum number to be used (for nested -do-
381 size dovars(ps); dims dovars(dovarmax); $ -ha- pointers
382 size dovarsz(ps); dims dovarsz(dovarmax); $ sizes
383 size dovarptr(ps); data dovarptr = 0; $ no. used
384 size dovarbusy(dovarmax); $ busy flags (set when var in use)
385 data dovarbusy = 0; $ initially, all are free
386 $ cardlisted is on after listing current input card.
387 size cardlisted(ps); data cardlisted = yes;
388
389 .+haprobes.
390 size emassreset(ps); data emassreset = 0;
391 ..haprobes
392
393 $ ermesarg is used to pass extra information to ermes,
394 $ usually ha index of item.
395 size ermesarg(ps);
396
397 $ ermflag is on to note calls to unsized external functions.
398 size ermflag(1); data ermflag = yes;
399
400 size ermsgno(ps); $ number of error message
401
402 $ erthis is number of errors detected including current
403 $ routine. erprev is number of detected errors through
404 $ end of previous routine.
405 size erthis(ps); data erthis = 0;
406 size erprev(ps); data erprev = 0;
407
408 size exitcode(ps); $ exit code from -gen-
409 data exitcode = 1; $ default is bad exit (occurs more often)
410
411 size fswitch(1); $ function flag
412 data fswitch = 0;
413
414
415
416 size gsopt(1); $ on to define globals in start
417
418 $ h a . hashed array.
419
420 $ all symbols
421 $ names, constants and expressions are entered in the ha, and
422 $ the ha index is main way item is referenced. the arglist
423 $ consists largely of ha indices.
424
425 $ the fields of the ha are as follows.
426 $ ep. the index of voa for this item.
427 $ var. 'is this a variable (ie. not operation) entry'.
428 $ hainuse. 'is this entry in use'
429 $ nayme. index in names array if variable name.
430 $ nchars. number of characters in name or constant.
431 $ labno. (for names only) lablist index if used as label.
432 $ namintern. 'is this a compiler generated name'
433 $ hascon. (for constants only) 'is this safe (short) constant'.
434 $ zerents. number of preceding empty ha entries (used to
435 $ pack ha when writing voa file).
436 $ varluse. last use in block of variable. (-voa- pointer)
437 $ tracef. 'is store trace in effect.'
438 $ chinxf. 'is check index option in effect.'
439
440 +* hasz = $ size of ha in bits
441 .+s66 60
vax 39 .+s32 64
442 .+s37 64
utsa 55 .+s47 64
443 .+s10 72
444 **
dsx 23 +* hamax = 937 ** $ ha dims - must be a prime
446 .+s66 nameset blank; $ keep in blank common on s66.
447 size ha(hasz); dims ha(hamax);
448 .+s66 end nameset;
449
450 .+s66.
451 +* ep = .f. 01, 12, **
452 +* hascon = .f. 13, 01, **
453 +* var = .f. 14, 01, **
454 +* hainuse = .f. 15, 01, **
455 +* nayme = .f. 16, 13, **
456 +* labno = .f. 29, 10, **
457 +* tracef = .f. 39, 01, **
458 +* chinxf = .f. 40, 01, **
459 +* namintern = .f. 41, 01, **
460 +* zerents = .f. 42, 11, **
461 +* varluse = .f. 42, 11, ** $ overlays -zerents-
462 +* nchars = .f. 53, 08, **
463 ..s66
vax 40 .+s32.
vax 41 +* hascon = .f. 1, 1, **
vax 42 +* var = .f. 2, 1, **
vax 43 +* tracef = .f. 3, 1, **
vax 44 +* chinxf = .f. 4, 1, **
vax 45 +* ep = .f. 5, 11, **
vax 46 +* namintern = .f. 16, 1, **
vax 47 +* zerents = .f. 17, 16, **
vax 48 +* varluse = .f. 17, 16, **
vax 49 +* nchars = .f. 33, 8, **
vax 50 +* labno = .f. 41, 9, **
vax 51 +* hainuse = .f. 50, 1, **
vax 52 +* nayme = .f. 54, 11, **
vax 53 ..s32
464 .+s37.
465 +* hascon = .f. 1, 1, **
466 +* var = .f. 2, 1, **
467 +* tracef = .f. 3, 1, **
468 +* chinxf = .f. 4, 1, **
469 +* ep = .f. 5, 11, **
470 +* namintern = .f. 16, 1, **
471 +* zerents = .f. 17, 16, **
472 +* varluse = .f. 17, 16, **
473 +* nchars = .f. 33, 8, **
474 +* labno = .f. 41, 9, **
475 +* hainuse = .f. 50, 1, **
476 +* nayme = .f. 54, 11, **
477 ..s37
utsa 56 .+s47.
utsa 57 +* hascon = .f. 1, 1, **
utsa 58 +* var = .f. 2, 1, **
utsa 59 +* tracef = .f. 3, 1, **
utsa 60 +* chinxf = .f. 4, 1, **
utsa 61 +* ep = .f. 5, 11, **
utsa 62 +* namintern = .f. 16, 1, **
utsa 63 +* zerents = .f. 17, 16, **
utsa 64 +* varluse = .f. 17, 16, **
utsa 65 +* nchars = .f. 33, 8, **
utsa 66 +* labno = .f. 41, 9, **
utsa 67 +* hainuse = .f. 50, 1, **
utsa 68 +* nayme = .f. 54, 11, **
utsa 69 ..s47
478 .+s10.
479 +* ep = .f. 1, 18, **
480 +* zerents = .f. 19, 18, **
481 +* varluse = .f. 19, 18, **
482 +* nayme = .f. 37, 11, **
483 +* labno = .f. 48, 9, **
484 +* nchars = .f. 57, 8, **
485 +* hascon = .f. 65, 1, **
486 +* var = .f. 66, 1, **
487 +* tracef = .f. 67, 1, **
488 +* chinxf = .f. 68, 1, **
489 +* namintern = .f. 69, 1, **
490 +* hainuse = .f. 70, 1, **
491 ..s10
492
493 $ the following macros are to be used for all ha searches
494 $ they correspond to 'while' over ha. ha search begins with
495 $ macro call of form
496 $ haprobe(j, hcode) ,
497 $ where j is variable used to index ha, hcode is hashcode, and
498 $ user must size j, hcode.
499 $ within search-body, write 'haquit', 'hacont', and 'haend' for
500 $ actions similar to 'quit' cont and 'end' in while statements.
501 $ if ha is full, execution will be terminated.
502
503
504 +* haprobe(j, hcode) = $ ha search macro
505 hcode = mod(hcode, hamax) + 1; $ get initial hash code.
506 if (hcode = hamax) hcode = (hamax-2);
507 size zzzp(ps); $ probes this search.
508 zzzp = 0; j = 1;
509 .+haprobes tothaprobes = tothaprobes + 1; $ update probe count if st
510 macdef(haprlbl = zzza)
511 macdef(haquitlbl = zzzc) macdef(haendlbl = zzzd)
512 macdef(hafulllbl = zzze)
513 /haprlbl/ if (zzzp > hamax) go to hafulllbl; $ ha is full
514 zzzp = zzzp + 1;
515 .+haprobes tothaexam = tothaexam + 1; $ update count if ha stats on
516 j = j + hcode; $ add original hashcode for next probe loc
517 if j > hamax then j = j-hamax; end if;
518 **
519
520 +* hacont = go to haprlbl;**$ continue ha search
521 +* haquit = go to haquitlbl; ** $ quit ha search
522 +* haend = go to haprlbl; $ continue ha probe
523 /hafulllbl/ call ermes(52); call genexit;
524 /haquitlbl/
525 macdrop(haprlbl) macdrop(haquitlbl)
526 macdrop(haendlbl) macdrop(hafulllbl)
527 **
528
529 size ha_0(ps); $ ha index of constant '0' (set by gensub)
530 size ha_1(ps); $ ha index of constant '1' (set by gensub)
531 size ifaglorname(ps); $ global arg to ifaglor haptr to name
532 size iorc(ps); $ io return code.
533
534
535 .+ifconstat.
536 $ ifcontot gives number of if's with constant control
537 $ expression; ifcongoto is number chaaged to a go to.
538 size ifcontot(ws); data ifcontot=0;
539 size ifcongotos(ws); data ifcongotos=0;
540 ..ifconstat
541
542 $ the next few variables are primarily used as part of macro
543 $ expansion to pass macro parameters to routines.
544 size insnchars(ps); $ arg to insnamr - nchars
545 size insgarg(ps); $ global to hasher (globals) ptr to ha
546 size insnarg(ws); $ array holding name to be added
547 dims insnarg(namsz/ws); $ packed array of token characters
548
549 $ i n p u t / o u t p u t s u p p o r t.
550
551 +* iotamax = 40 ** $ dims of iota
552
553 size iowriting(1); $ 'is this put statement'
554 size ioformatted(1); $ set for formatted io
555 size iolistmode(1); $ on for list mode.
556
557 $ items to be transmitted, either expressions, variables or arra
558 $ are noted in the iota (io t-ransmission a-rray). the fields
559 $ -iotavar-, -iotalo- and -iotahi- give the ha indices of the
560 $ item, the first element of array slice and last element of
561 $ array slice (lo and hi 0 if not array slice).
562
563 size iota(ws); dims iota(iotamax);
564 size iotaptr(ps); data iotaptr=0; $ top of iota
565 size iovar(ps); $ ha index of item to transmit
566 size iolo(ps); $ ha index of array subscript or start of slice
567 size iohi(ps); $ ha index of end of array slice
568
569 $ the status of local variables needed for io is maintained in
570 $ the iova (io v-ariable a-rray) with top -iovaptr- adnd limit
571 $ -iovamax-. the field -iovaha- gives ha index of variable,
572 $ -iovasize- gives its size in bits. the i-th bit of -iovabusy-
573 $ is set if the i-th variable in iova is currently in use.
574 $ the busy bits are cleared when variable no longer needed
575 $ to permit reuse within io statement, and at start of io statem
576 $ ment since variables only needed in single statement.
577
578 +* ioformats = 6 ** $ number of data formats.
579
580
581
582
583 +* ionamesptr = 19 ** $ number of io routines to which calls ge
584 +* ior_onma = 1 ** $ -n- array element name
585 +* ior_onmv = 2 ** $ -n- simple name list
586 +* ior_gcfp = 3 ** $ control format processor
587 +* ior_ifma = 4 ** $ -a- input format
588 +* ior_ifmb = 5 ** $ -b- input format
589 +* ior_ifme = 6 ** $ -e- input format
590 +* ior_ifmf = 7 ** $ -f- input format
591 +* ior_ifmi = 8 ** $ -i- input format
592 +* ior_ifmr = 9 ** $ -r- input format
593 +* ior_rwnd = 10 ** $ file rewind
594 +* ior_ioqu = 11 ** $ io query
595 +* ior_vali = 12 ** $ validator.
596 +* ior_makf = 13 ** $ make system tables for file
597 +* ior_ofma = 14 ** $ -a- output format
598 +* ior_ofmb = 15 ** $ -b- output format
599 +* ior_ofme = 16 ** $ -e- output format
600 +* ior_ofmf = 17 ** $ -f- output format
601 +* ior_ofmi = 18 ** $ -i- output format
602 +* ior_ofmr = 19 ** $ -r- output format
603
604
605
606 $ fields of iota (io t-ransmission a-rray)
607 +* iotavar = .e. 01, 10, ** $ ha index of item to transmit
608 +* iotalo = .e. 11, 10, ** $ ha index of first array element
609 +* iotahi = .e. 21, 10, ** $ ha index of last array elementn
610
611 $ iova (io v-ariable a-rray) fields
612 +* iovaha = .e. 1, 10, ** $ ha index of variable
613 +* iovasize = .e. 11, 11, ** $ size of variable
614
615 +* iovasz = 20 ** $ size of iova
616 +* iovamax = 40 ** $ maximum number of entries in iova
617
618 size iovaptr(ps); data iovaptr=0; $ top of iova
619 size iova(iovasz); dims iova(iovamax);
620 size iovabusy(iovamax); data iovabusy = 0;
621
622 size iofilename(ps); data iofilename = 0; $ ha index of filename
623 size iokey(ps); $ io token key word. passed from
624 $ parser to generators
625 size ioerror(1); data ioerror = no; $ error flag
626 size ionameflag(1); data ionameflag = no; $ namelist flag
627 size iofilekeys(ps); dims iofilekeys(4); $ args for file definiti
628 $ the i/o functions are supported by various routines in the
629 $ little run-time library. to avoid name conflicts between
630 $ these routines and user routines, the compiler supports an
631 $ option to 'protect' i/o names.
632
633 $ within the source, io routines are reffered to by macros.
634 $ these macros expand to indices into the array -ionames- below.
635 $ the routine names are initially given as four characters.
636 $ these routines are protected by appending a trailer string
637 $ as part of the compiler isolation, the trailer will typically
638 $ contain a character acceptable to the loader but not
639 $ usually found in subprogram names (for example, '$').
640
641 $ the default trailer is an implementation option, but
642
643
644 $ the trailer can be at most 4 characters
645
646 size iorts(sds(4)); $ io routine trailer string
647 data iorts = '$io';
648
649 size ionames(sds(8)); dims ionames(ionamesptr);
650 data $ initialize to standard four character names
651 $ trailing blanks eliminated by genini.
652 ionames(ior_onma) = 'onma ': $ -n- array element name
653 ionames(ior_onmv) = 'onmv ': $ -n- simple name list
654 ionames(ior_gcfp) = 'gcfp ': $ control format processor
655 ionames(ior_ifma) = 'ifma ': $ -a- input format
656 ionames(ior_ifmb) = 'ifmb ': $ -b- input format
657 ionames(ior_ifme) = 'ifme ': $ -e- input format
658 ionames(ior_ifmf) = 'ifmf ': $ -f- input format
659 ionames(ior_ifmi) = 'ifmi ': $ -i- input format
660 ionames(ior_ifmr) = 'ifmr ': $ -r- input format
661 ionames(ior_rwnd) = 'rwnd ': $ file rewind
662 ionames(ior_ioqu) = 'ioqu ': $ io query
663 ionames(ior_vali) = 'vali ': $ validator.
664 ionames(ior_makf) = 'makf ': $ make system tables for file
665 ionames(ior_ofma) = 'ofma ': $ -a- output format
666 ionames(ior_ofmb) = 'ofmb ': $ -b- output format
667 ionames(ior_ofme) = 'ofme ': $ -e- output format
668 ionames(ior_ofmf) = 'ofmf ': $ -f- output format
669 ionames(ior_ofmi) = 'ofmi ': $ -i- output format
670 ionames(ior_ofmr) = 'ofmr '; $ -r- output format
671
672 $ array iodfprocs maps codes for data formats onto codes use
673 $ for formatted conversion routines. the first -ioformats-
674 $ are for input, the rest for output.
675 size iodfprocs(ps); dims iodfprocs(2*ioformats);
676 data iodfprocs =
677 ior_ifma, ior_ifmb, ior_ifme, ior_ifme,
678 ior_ifmi, ior_ifmr, ior_ofma, ior_ofmb,
679 ior_ofme, ior_ofmf, ior_ofmi, ior_ofmr;
680
681 $ several of the parameters needed for formatted io are
682 $ packed into various fields of the io parameter string;
683 $ data structures and procedures related to this packing have
684 $ names beginning with -iops-.
685 $ iopssz is the size of the string. the array iopsha is a list
686 $ of the ha indexes of the parameters to be entered.
687 $ parameters are assumed to be zero unless otherwise specified,
688 $ so iopsha entries are set to ha_0 initially.
689 $ the arrays iopsorg and iopslen give the origins and lengths of
690 $ the fields. macros beginning with 'iopsi_' give integer
691 $ codes for the fields.
692 $ the procedure -geniops- constructs the parameter string
693 $ and sets the global variable -iopshap- to the ha index;
694 $ if all the fields are constants, the string will be a constant
695 $ otherwise, the string is built by entering all constant fields
696 $ at compile time and generating code to enter nonconstant
697 $ field values at runtime.
698 +* iopsflds = 7 ** $ number of fields in iops.
699 +* iopssz = 32 ** $ size of iops.
700 size iopshap(ps); $ ha index of io parm. str.
701 size iopsha(ps); dims iopsha(iopsflds); $ ha indices of parms.
702 size iopsorg(ps); dims iopsorg(iopsflds);
703 size iopslen(ps); dims iopslen(iopsflds);
704 +* iopsi_lm = 1 ** $ on if list mode.
705 +* iopsi_fw = 2 ** $ field width.
706 +* iopsi_dw = 3 ** $ decimal width (also byte width).
707 +* iopsi_sz = 4 ** $ size of datum.
708 +* iopsi_gw = 5 ** $ group width.
709 data $ set field origins of iops fields.
710 iopsorg(iopsi_lm) = 01: iopslen(iopsi_lm) = 01:
711 iopsorg(iopsi_fw) = 02: iopslen(iopsi_fw) = 08:
712 iopsorg(iopsi_dw) = 10: iopslen(iopsi_dw) = 05:
713 iopsorg(iopsi_sz) = 17: iopslen(iopsi_sz) = 11:
714 iopsorg(iopsi_gw) = 28: iopslen(iopsi_gw) = 04;
715 $ bit iopssz is reserved for use when machine word size
716 $ is less than iopssz (see procedure geniops).
717
718 size isusenot(1); data isusenot = no; $ flag for -isuse- macro.
719 size keeptok(1); data keeptok=no; $ on to retrieve last token.
720
721 $ l a b e l p r o c e s s i n g.
722
723
724 +* lablistlen = $ dimension of label list
725 400
726 **
727
728 +* labsz = ws ** $ size of lablist entry
729 size labgen(sds(4)); data labgen = 'l.aa'; $ local label name
730 .+s66 nameset blank; $ keep in blank common on s66.
731 size lablist(labsz); dims lablist(lablistlen); $ label table
732 .+s66 end nameset;
733 size lablistptr(ps); data lablistptr = 0; $ ptr to lablist
734 $ the lablist fields are as follows.
735 $ labha is the ha index of the entry for label.
736 $ labvoa is the voa index of the item for label definition.
737
738 .+s66.
739 +* labha = .f. 01, 10, **
740 +* labvoa = .f. 11, 11, **
741 ..s66
vax 54 .+s32.
vax 55 +* labha = .f. 1, 16, **
vax 56 +* labvoa = .f. 17, 16, **
vax 57 ..s32
742 .+s37.
743 +* labha = .f. 1, 16, **
744 +* labvoa = .f. 17, 16, **
745 ..s37
utsa 70 .+s47.
utsa 71 +* labha = .f. 1, 16, **
utsa 72 +* labvoa = .f. 17, 16, **
utsa 73 ..s47
746 .+s10.
747 +* labha = .f. 1, 18, **
748 +* labvoa = .f. 19, 18, **
749 ..s10
750
751 $ macros relating to the handling of labels
752
753 $ define label by entering voaptr in lablist
754 +* labldef(v, labnum) =
755 if labvoa lablist(labnum) then $ if already defined,
756 if (namintern ha(labha lablist(labnum)) = no)
757 call ermes(14); $ duplicate label.
758 else
759 labvoa lablist(labnum) = v; end if;
760 **
761
762 $ increment number of uses of label
763 +* labluse(labnum) =
764 labuses lablist(labnum) = labuses lablist(labnum) + 1; **
765
766 +* labget(labl) = $ returns ha ptr to label
767 call advstr(labgen, labl); $ advance local label name ,hash
768 **
769
770 +* labdef(labl) = $ define label
771 push(labl) call gengol(op_lab); **
772
773 $ lcp_opt on to list compilation parameters.
774 $ lcs_opt on to list compilation statistics.
775 size lcp_opt(ps); data lcp_opt = yes;
776 size lcs_opt(ps); data lcs_opt = yes;
777
778 $ levnow and levmin are used to detect redundant calculations.
779 $ levnow is incremented for each basic block, and minlev is set
780 $ to the value of levnow at this point, so an operation has
781 $ been performed in the current block only if its definition
782 $ level is not less than levmin. levnow is also incremented for
783 $ each assignment and the deflev field of the assignment target
784 $ is set to the new value.
785 $ an operation is redundant if both the computation itself and
786 $ the computation of any inputs which are not variables have
787 $ been performed in the current block and if no input has been
788 $ assigned a new value since the prior computation.
789 $ the search for redundant computations is performed in routines
790 $ emit1, emit2 and emit3.
791 size levnow(ps); data levnow = 1; $ level number
792 size levmin(ps); data levmin=1; $ minimum level - optimization
793
794 $ t o k e n a n d l i t e r a l p r o c e s s i n g.
795
796 $ as a diagnostic aid, a list of the most recent tokens
797 $ is maintained in lexlist with dimension -lexlistmax-.
798 $ lexlist holds list of recent tokens seen, for diagnostics
799 +* lexlistmax = $ number of words listed in 'last few tokens'
800 .+s66 16
vax 58 .+s32 16*2 $ two words/token
801 .+s37 16*2 $ two words/token
utsa 74 .+s47 16*2 $ two words/token
dso 28 .+s10 16*2 $ two words/token
803 **
804
805 $ -lexlistmax- must be a power of two.
806 +* lexlistsz = ws ** $ size of lexlist entry.
807 size lexlist(lexlistsz); dims lexlist(lexlistmax);
808 size lexleng(lexlistsz); dims lexleng(lexlistmax);
809 data lexlist = 0(lexlistmax);
810 size lexlistptr(ps); data lexlistptr = 0;
811
812 size listingcode(1); $ assembler code list option value.
813 data listingcode = no; $ by default, do not list code.
814 size subtitling(1); $ set when entering subtitles.
815 data subtitling = no;
816 size listsw(1); $ flag for listing input
817 data listsw = no; $ by default, list off.
818 $ listswnew holds new listsw value until next line read.
819 $ the initial value must be same as that for listsw.
820 size listswnew(1); data listswnew = no;
821 size listauto(1); data listauto = no; $ auto-titleing flag
822 size listwds(ws); dims listwds(wpc); $ card read in
823 size listwdsp(ps); $ last non-blank word
824
825 size toklc(ps); $ token literal code
826
827 +* litclassz = $ size of littab internal entry.
828 .+s66 6
vax 59 .+s32 8
829 .+s37 8
utsa 75 .+s47 8
830 .+s10 6
831 **
832
833 +* littabl(class, indx) = $ computeentry in littab for given
834 $ literal and class
835 .f. (littabsz+1) - litclassz*(class), litclassz, littab(indx)
836 **
837
838 +* littabsz = $ size of littab (at least 60 bits)
839 .+s66 60
vax 60 .+s32 128
840 .+s37 128
utsa 76 .+s47 128
841 .+s10 72
842 **
843
845 size littab(littabsz); dims littab(litcodes); $ leteral class
846 data littab = 0(litcodes); $ see ltabini for initialization code.
847
848 $ to save space, we initialize the literals table as follows.
849 $ abstractly, -littab- is a two dimensional table, littab(cl,lc)
850 $ indexed by -cl-, a class number, and -lc- a literal code.
851 $ for example, the set of binary operator names is one such
852 $ class, and the littab entry for binary operators contains
853 $ the precedence of the operator (0 if not binary op).
854 $ the table is a set of triples .
855 $ the macros below are used to enter values in arglist as initia
856 $ data and deflit is called to build littab.
857 $ this roundabout procedure saves code space which formerly
858 $ by using execution time field extracts to set up each entry.
859
860 data arglist =
861 +* ins(lc,value ) =
862 lc + value*4b'100', **
863
864 1*4b'100',
865 ins(lc_if, 1)
866 ins(lc_while, 2)
867 ins(lc_until , 3)
868 ins(lc_do, 4)
869 ins(lc_end, 5)
870 ins(lc_else, 6)
871 ins(lc_size, 7)
872 ins(lc_dims, 8)
873 ins(lc_data, 9)
874 ins(lc_semicolon,10)
875 ins(lc_nameset, 11)
876 ins(lc_access, 12)
877 ins(lc_real,13)
878 ins(lc_elseif, 14)
879 ins(lc_subr, 15)
880 ins(lc_fnct, 16)
881 ins(lc_divide, 17)
882 ins(lc_prog, 18)
883
884 $ branch on literals - simple statements
885 2*4b'100',
886 ins(lc_call, 1)
887 ins(lc_goby, 2)
888 ins(lc_return, 3)
889 ins(lc_go, 4)
890 ins(lc_cont, 5)
891 ins(lc_quit, 6)
892 ins(lc_fext, 7)
893 ins(lc_eext, 8)
894 ins(lc_sext, 9)
895 ins(lc_chext, 10)
896 ins(lc_get, 11)
897 ins(lc_put, 12)
898 ins(lc_file, 13)
899 ins(lc_rewind, 14)
900 ins(lc_len, 15)
901 ins(lc_read, 16)
902 ins(lc_write, 17)
903 ins(lc_check, 18)
904 ins(lc_nocheck, 19)
905 ins(lc_trace, 20)
906 ins(lc_notrace, 21)
907 ins(lc_assert, 22)
908 ins(lc_monitor, 23)
909
910 $ binary operators - operator precedence level nubers
911 3*4b'100',
912 ins(lc_pad, 1)
913 ins(lc_ccat, 1)
914 ins(lc_or, 1)
915 ins(lc_ex, 1)
916 ins(lc_exor, 1)
917 ins(lc_orsym, 1)
918 ins(lc_and, 2)
919 ins(lc_andsym, 2)
920 ins(lc_andbrev, 2)
921 ins(lc_eq, 4)
922 ins(lc_ne, 4)
923 ins(lc_gt, 4)
924 ins(lc_lt, 4)
925 ins(lc_ge, 4)
926 ins(lc_le, 4)
927 ins(lc_eqsym, 4)
928 ins(lc_ltsym, 4)
929 ins(lc_gtsym, 4)
930 ins(lc_notsym, 4)
931 ins(lc_seq, 4) $ .seq.
932 ins(lc_sne, 4) $ .sne.
933 ins(lc_plus, 5)
934 ins(lc_minus, 5)
935 ins(lc_times, 6)
936 ins(lc_divide, 6)
937 ins(lc_in, 6)
938
939 $ unary operators - operator prec level numbers
940 4*4b'100',
941 ins(lc_not, 3)
942 ins(lc_notbrev, 3)
943 ins(lc_notsym, 3)
944 ins(lc_fb, 7)
945 ins(lc_nb, 7)
946 ins(lc_minus, 7)
947 ins(lc_sdsop, 7)
948 ins(lc_len, 7)
949 ins(lc_plus, 7) $ unary plus.
950
951 $ binary operators - arith routine parameter number - opcode
952 5*4b'100',
953 ins(lc_ccat, op_ccat)
954 ins(lc_in, op_in)
955 ins(lc_plus, op_add)
956 ins(lc_minus, op_sub)
957 ins(lc_gt, op_gt)
958 ins(lc_gtsym, op_gt)
959 ins(lc_lt, op_lt)
960 ins(lc_ltsym, op_lt)
961 ins(lc_ge, op_ge)
962 ins(lc_le, op_le)
963 ins(lc_eq, op_eq)
964 ins(lc_eqsym, op_eq)
965 ins(lc_ne, op_ne)
966 ins(lc_notsym, op_ne)
967 ins(lc_times, op_mul)
968 ins(lc_divide, op_div)
969 ins(lc_or, op_or)
970 ins(lc_orsym, op_or)
971 ins(lc_and, op_and)
972 ins(lc_andbrev, op_and)
973 ins(lc_andsym, op_and)
974 ins(lc_exor, op_exor)
975 ins(lc_ex, op_exor)
976 ins(lc_seq, op_seq)
977 ins(lc_pad, op_pad)
978 ins(lc_sne, op_sne)
979
980 $ unary operators - marith routine parameter number - opcode
981 6*4b'100',
982 ins(lc_fb, op_fb)
983 ins(lc_nb, op_nb)
984 ins(lc_not, op_not)
985 ins(lc_notsym, op_not)
986 ins(lc_notbrev, op_not)
987 ins(lc_minus, op_usub)
988 ins(lc_sdsop, 0) $ .sds.
989 ins(lc_len, 1) $ .len.
990 ins(lc_plus, 2)
991
992 $ branch on literals - right hand terms
993 7*4b'100',
994 $ assigned code is offset to which to branch forward in
995 $ parse of terms.
996 ins(lc_fext, 5)
997 ins(lc_eext, 6)
998 ins(lc_sext, 7)
999 ins(lc_chext, 8)
1000 ins(lc_lparen, 9)
1001 ins(lc_filestat, 10)
1002
1003 $ codes for special tokens examined by nextok.
1004 9*4b'100',
1005 ins(lc_voadump , 1)
1006 ins(lc_voapart , 2)
1007 ins(lc_contr , 5)
1008 ins(lc_nocontr , 6)
1009 ins(lc_toktr , 7)
1010 ins(lc_notoktr , 8)
1011 ins(lc_mws , 9)
1012 ins(lc_mps , 10)
1013 ins(lc_mcs , 11)
1014 ins(lc_msl , 12)
1015 ins(lc_mso , 13)
1016
1017 0, 0; $ end of data statement for ha (0 flags end of list)
1018 +* ins = ** $ drop ins macro.
1019
1020
1021
1022 $ a record is kept of the maximum use of each static array and
1023 $ the routine compiled which made maximum use.
1024 +* loadini(var,varsds) = $ initialize load statistics variable.
1025 size var(ws); data var = 0;
1026 size varsds(namsz); data varsds = ' ';
1027 **
1028 loadini(loadha , loadrha ); $ ha.
1029 loadini(loadlablist , loadrlablist ); $ lablist.
1030 loadini(loadnames , loadrnames ); $ names.
1031 loadini(loadtlist , loadrtlist ); $ tlist.
1032 loadini(loadval , loadrval ); $ val
1033 loadini(loadvoa , loadrvoa ); $ voa.
1034 loadini(loadxarg , loadrxarg ); $ xarg.
1035 macdrop(loadini)
1036
1037 size localforce(1); data localforce=no; $ on to force use
1038 $ of local block by gensiz (set by gendo)
1039
1040 size lvgen(sds(4)); data lvgen = 'v.aa'; $ local variable name
1041
1042 $ mainprogram is set when compiling program.
1043 size mainprogram(1); data mainprogram = no;
1044 $ m b a . machine block array
1045 size mbaptr(ps); data mbaptr=0; $ most recent entry in mba
1046
1047 +* mbasz = $ size of mba (m-achine b-lock a-rray)
1048 .+s66 60
dsw 17 .+s32 96
dsw 18 .+s37 96
utsa 77 .+s47 96
1050 .+s10 72
1051 **
1052
1053 size mba(mbasz); dims mba(nblocks); $ m-achine b-lock a-rray
1054 data mba = 0(nblocks);
1055
1056 .+s66.
1057 +* mblen = .f. 1, 20, **
1058 +* mbha = .f. 21, 11, **
1059 +* mbused = .f. 32, 1, **
1060 +* mbxha = .f. 33, 12, **
1061 +* mbdef = .f. 46, 1, **
1062 +* mbchain = .f. 47, 11, **
1063 ..s66
vax 62 .+s32.
vax 63 +* mbused = .f. 1, 1, **
vax 64 +* mbdef = .f. 2, 1, **
vax 65 +* mbha = .f. 4, 11, **
dsw 19 +* mblen = .f. 65, 32, **
vax 67 +* mbxha = .f. 33, 13, **
vax 68 +* mbchain = .f. 46, 11, **
vax 69 ..s32
1064 .+s37.
1065 +* mbused = .f. 1, 1, **
1066 +* mbdef = .f. 2, 1, **
1067 +* mbha = .f. 4, 11, **
dsw 20 +* mblen = .f. 65, 32, **
1069 +* mbxha = .f. 33, 13, **
1070 +* mbchain = .f. 46, 11, **
1071 ..s37
utsa 78 .+s47.
utsa 79 +* mbused = .f. 1, 1, **
utsa 80 +* mbdef = .f. 2, 1, **
utsa 81 +* mbha = .f. 4, 11, **
utsa 82 +* mblen = .f. 65, 32, **
utsa 83 +* mbxha = .f. 33, 13, **
utsa 84 +* mbchain = .f. 46, 11, **
utsa 85 ..s47
1072 .+s10.
1073 +* mblen = .f. 1, 18, **
1074 +* mbxha = .f. 19, 18, **
1075 +* mbha = .f. 37, 18, **
dst 12 +* mbchain = .f. 55, 11, **
dst 13 +* mbused = .f. 66, 1, **
dst 14 +* mbdef = .f. 67, 1, **
1079 ..s10
1080
1081 $ characters in symbolic names are kept in -names- array.
1082 +* namesmax = $ dimension of -names- array
1083 .+s66 600
vax 70 .+s32 800
1084 .+s37 800
utsa 86 .+s47 800
mgfb 13 .+s10 800
1086 **
1087
1088 size namesptr(ps); data namesptr = 1; $ ptr to names array
1089 .+s66 nameset blank; $ keep in blank common on s66.
1090 size names(ws); dims names(namesmax); $ names array
1091 .+s66 end nameset;
1092
1093 size ncards(ps); data ncards = 0; $ number of cards read.
1094
1095 size ncfopt(1); data ncfopt=1; $ on if negative constant fold ok
1096 .+ncfstat.
1097 size ncftot(ps); data ncftot=0;$ no. of negative constants fold
1098 ..ncfstat
1099
1100 size nerrors(ps); data nerrors = 0; $ no of errors
1101 size nwarnings(ps); data nwarnings=0; $ num. of warnings.
1102
1103 $ n l - names list (attributes of global variables)
1104
1105 +* nlmax = $ dimension of -nl- array
1106 400
1107 **
1108
1109 size nlptr(ps); data nlptr = 0; $ top of nl
1110 $ fields related to global names list - n l
1111 +* nlsz = $ size of nl
1112 .+s66 120
dsw 21 .+s32 96
dsw 22 .+s37 96
utsa 87 .+s47 96
1114 .+s10 72
1115 **
1116
1117 .+s66 nameset blank; $ keep in blank common on s66.
1118 size nl(nlsz); dims nl(nlmax);
1119 .+s66 end nameset;
1120
1122
1123 .+s66.
1124 +* nldimn = .f. 1, 16, **
1125 +* nlmadr = .f. 17, 16, **
1126 +* nlha = .f. 33, 10, **
1127 +* nlamode = .f. 43, 1, **
1128 +* nlchinx = .f. 44, 1, **
1129 +* nlsize = .f. 45, 11, **
1130 +* nltrac = .f. 56, 1, **
1131 +* nlfnct = .f. 57, 1, **
1132 +* nlblk = .f. 61, 6, **
1133 ..s66
vax 72 .+s32.
dsw 23 +* nldimn = .f. 1, 32, **
dsw 24 +* nlmadr = .f. 65, 32, **
vax 75 +* nlsize = .f. 33, 11, **
vax 76 +* nlblk = .f. 44, 6, **
vax 77 +* nlamode = .f. 50, 1, **
vax 78 +* nlchinx = .f. 51, 1, **
vax 79 +* nltrac = .f. 52, 1, **
vax 80 +* nlfnct = .f. 53, 1, **
vax 81 +* nlha = .f. 55, 10, **
vax 82 ..s32
1134 .+s37.
dsw 25 +* nldimn = .f. 1, 32, **
dsw 26 +* nlmadr = .f. 65, 32, **
1137 +* nlsize = .f. 33, 11, **
1138 +* nlblk = .f. 44, 6, **
1139 +* nlamode = .f. 50, 1, **
1140 +* nlchinx = .f. 51, 1, **
1141 +* nltrac = .f. 52, 1, **
1142 +* nlfnct = .f. 53, 1, **
1143 +* nlha = .f. 55, 10, **
1144 ..s37
utsa 88 .+s47.
utsa 89 +* nldimn = .f. 1, 32, **
utsa 90 +* nlmadr = .f. 65, 32, **
utsa 91 +* nlsize = .f. 33, 11, **
utsa 92 +* nlblk = .f. 44, 6, **
utsa 93 +* nlamode = .f. 50, 1, **
utsa 94 +* nlchinx = .f. 51, 1, **
utsa 95 +* nltrac = .f. 52, 1, **
utsa 96 +* nlfnct = .f. 53, 1, **
utsa 97 +* nlha = .f. 55, 10, **
utsa 98 ..s47
1145 .+s10.
1146 +* nldimn = .f. 1, 18, **
1147 +* nlmadr = .f. 19, 18, **
1148 +* nlha = .f. 37, 10, **
1149 +* nlamode = .f. 47, 1, **
1150 +* nlblk = .f. 48, 6, **
1151 +* nlchinx = .f. 54, 1, **
1152 +* nltrac = .f. 55, 1, **
1153 +* nlfnct = .f. 56, 1, **
1154 +* nlsize = .f. 57, 11, **
1155 ..s10
1156
1157 size nsflg(1); data nsflg=0; $ on when inside nameset.
1158 size nstouse(ps); $ nameset to use in next size stttement
1159 data nstouse = localblock;
1160
1161 size nsubrs(ps); data nsubrs = 0; $ number of subrs seen
1162 size ntexterr(1); data ntexterr = no; $ on if certain errors
1163 $ detected outside of subroutine to prevent run-away errors
1164
1165 $ o p e r a t o r a t t r i b u t e s.
1166
1167 $ opkind array, indexed by operator code, gives 'gross' operator
1168 $ type used by blkend and also indicates if operator commutes.
1169 $ commutativity information unpacked in genini, later accessed
1170 $ used -commutesatr- macro.
1171 size opkind(ws); dims opkind(nopcodes);
1172
1173 $ operator attributes are entered in the opkind array using the
1174 $ -op- macro below. three attributes are currently defined -
1175 $ - blkendtype, used by blkend to determine pattern in voa.
1176 $ - commutativity, used by emit2 to standardize commutative ops
1177 $ in order to detect more redundant expressions.
1178 $ -realopcd- is set for amode=amode_real ops.
1179
1180 +* op(opc, gc, c, r) = opkind(opc) = 4*gc + 2*r + c **
1181 data
1182 op(op_add , 03, yes, no):
1183 op(op_sub , 03, no , no):
1184 op(op_gt , 03, no , no):
1185 op(op_lt , 03, no , no):
1186 op(op_ge , 03, no , no):
1187 op(op_le , 03, no , no):
1188 op(op_eq , 03, yes, no):
1189 op(op_ne , 03, yes, no):
1190 op(op_mul , 03, yes, no):
1191 op(op_div , 03, no , no):
1192 op(op_or , 03, yes, no):
1193 op(op_and , 03, yes, no):
1194 op(op_exor , 03, yes, no):
1195 $ opcode not used
1196 op(op_nb , 02, no , no):
1197 op(op_fb , 02, no , no):
1198 op(op_not , 02, no , no):
1199 op(op_fcall , 05, no , no):
1200 op(op_call , 06, no , no):
1201 op(op_asin , 07, no , no):
1202 op(op_data , 01, no , no):
1203 op(op_fasin , 09, no , no):
1204 op(op_io , 15, no , no): $ unformatted io
1205 op(op_return , 01, no , no):
1206 op(op_fext , 04, no , no):
1207 op(op_if , 11, no , no):
1208 op(op_lab , 01, no , no):
1209 op(op_goto , 01, no , no):
1210 op(op_goby , 11, no , no):
1211 op(op_xload , 16, no , no):
1212 op(op_xasin , 08, no , no):
1213 op(op_xfasin , 10, no , no):
1214 op(op_ifnot , 11, no , no):
1215 op(op_ccat , 03, no , no):
1216 op(op_in , 03, no , no):
1217 op(op_eext , 04, no , no):
1218 op(op_sext , 04, no , no):
1219 op(op_easin , 09, no , no):
1220 op(op_sasin , 09, no , no):
1221 op(op_xeasin , 10, no , no):
1222 op(op_xsasin , 10, no , no):
1223 op(rop_add , 12, yes, yes):
1224 op(rop_sub , 12, no , yes):
1225 op(rop_gt , 13, no , yes):
1226 op(rop_lt , 13, no , yes):
1227 op(rop_ge , 13, no , yes):
1228 op(rop_le , 13, no , yes):
1229 op(rop_eq , 13, yes, yes):
1230 op(rop_ne , 13, yes, yes):
1231 op(rop_mul , 12, yes, yes):
1232 op(rop_div , 12, no , yes):
1233 op(rop_usub , 14, no , yes):
1234 op(bop_float , 02, no , yes):
1235 op(bop_ifix , 02, no , no):
1236 op(bop_abs , 02, no , yes):
1237 op(bop_iabs , 02, no , no):
1238 op(bop_aint , 02, no , yes):
1239 op(bop_int , 02, no , no):
1240 op(bop_amod , 03, no , yes):
1241 op(bop_mod , 03, no , no):
1242 op(bop_sign , 03, no , yes):
1243 op(bop_isign , 03, no , no):
1244 op(bop_dim , 03, no , yes):
1245 op(bop_idim , 03, no , no):
1246 op(bop_exp , 02, no , yes):
1247 op(bop_alog , 02, no , yes):
1248 op(bop_alog10, 02, no , yes):
1249 op(bop_sin , 02, no , yes):
1250 op(bop_cos , 02, no , yes):
1251 op(bop_tanh , 02, no , yes):
1252 op(bop_sqrt , 02, no , yes):
1253 op(bop_atan , 02, no , yes):
1254 op(bop_atan2 , 03, no , yes):
1255 op(op_list , 01, no , no):
1256 op(op_seq , 03, yes, no):
1257 op(op_sne , 03, yes, no);
1258
1259 +* op = ** $ drop macro.
1260
1261 size opstackp(ps); data opstackp=0; $ ptr to opstack
1262
1263 size parsereg(ps); dims parsereg(8); $ registers of parse mac
1264
1265 size parsetrace(1); data parsetrace = no;
1266
ldsa 46 .+rep.
ldsa 47 $ rep_opt on if generating report file.
ldsa 48 size rep_opt(ps);
ldsa 49 size rep_opt_c(1); $ on if reporting calls
ldsa 50 size rep_opt_p(1); $ on if reporting procedure definitions
ldsa 51 size rep_opt_g(1); $ on if reporting global storage allocation
ldsa 52 size rep_suffix(.sds. 5); $ report suffix code
ldsa 53 ..rep
ldsa 54
1267 size pelvalue(ps); $ error limit
1268
1269 $ proclineno is line number relative to start of current
1270 $ procedure.
1271 size proclineno(ps); data proclineno = 0;
1272
1273 size rlsz(ps); $ size of real (floating point) quanitty.
1274
1275
1276 $ 'replication' variables used by gendat. replication is switch
1277 $ set wheh data replication requested in data value list.
1278 $ replication_origin records position in arglist at start of
1279 $ data list processing. replicate is bit string, with bit i on
1280 $ if arglist(i) contains a replication value and not data value.
1281
1282 size replicate(argmax);
1283 size replication(1);
1284 size replication_origin(ps);
1285
1286 $ safeconst is array, indexed by lexical type, with non-zero
1287 $ entry if constants of corresponding type can safely be
1288 $ evaluated at compile time.
1289 size safeconst(ps); dims safeconst(toktypes);
1290 data safeconst = 0(toktypes); $ assume all unsafe, correct this
1291 $ assumption in genini.
1292
1293
1294 size savetoks(ps); data savetoks=5; $ conter of saved tokens
1295
1296 size sdsnamstr(namsz); data sdsnamstr=0; $ parameter to sdsnamr.
1297
1298 size setqfok(1); data setqfok = no; $ switch for -setq-.
1299
1300 size sfp_opt(1); data sfp_opt = no; $ suppress first routine
1301
1302 size signofcon(1); data signofcon=0; $ constant sign(1 is minus
1303
1304
1305 size subinfo(ps); dims subinfo(3); $ subr/fnct info array
1306
1307 size targetmachine(ps); $ index of target machine
1308 data targetmachine = hostmachine;
1309
1310 +* tlistmax = $ dimension of -tlist- (no. of temporaries)
ldsd 16 60
1312 **
1313
1314 .+s66 nameset blank; $ keep in blank common on s66.
1315 size tlist(ws); dims tlist(tlistmax); $ temporaries list
1316 .+s66 end nameset;
1317 size tlistptr(ps); data tlistptr=0; $ top of tlist.
1318 +* tokrbuflim = 256 **
1319 +* tokarasz = ws ** $ size of tokara
1320 +* tokaradims = ((toklenmax+cpw)/cpw) **
1321 size tokara(tokarasz); dims tokara(tokaradims); $ token array
1322 size toklen(ps); $ token length in characters
1323 size toklt(ps); $ token lexical type
1324 .+s66 nameset blank; $ keep in blank common on s66.
1325 size tokrbuf(ws); dims tokrbuf(tokrbuflim); $ token buffer
1326 .+s66 end nameset;
1327 size tokrbufp(ps); data tokrbufp=0; $ ptr to tokrbuf
1328 size tokwords(ps); $ no of words in token value
1329
1330 size tmara(ws); dims tmara(tmparams); $ target machine parameter
1331 size tmtokara(tokarasz); dims tmtokara(tmparams);
1332
1333 .+haprobes.
1334 size tothaexam(ws); data tothaexam=0; $ no of times ha looped
1335 size tothaprobes(ws); data tothaprobes=0; $ no of ha probes
1336 ..haprobes
1337 size totwaste(ps); data totwaste=0; $ unused memory words
1338
1339 $ v a l . (used to hold constant values)
1340 +* valmax = $ dimension of -val- array
1341 .+s66 0700
vax 83 .+s32 1100
1342 .+s37 1100
utsa 99 .+s47 1100
mgfb 14 .+s10 1100
1344 **
1345
1346 size valptr(ps); data valptr = 1; $ ptr to val array
1347 .+s66 nameset blank; $ keep in blank common on s66.
1348 size val(ws); dims val(valmax); $ holds constant values
1349 .+s66 end nameset;
1350
1351 $ v o a . variable / operations array
1352
1353 +* voasz = $ size of voa
1354 .+s66 120
dsw 27 .+s32 192
dsw 28 .+s37 192
utsa 100 .+s47 192
1356 .+s10 144
1357 **
1358 +* vomax = $ dimension of -voa-
1359 1850
1360 **
1361
1362 size voptr(ps); $ ptr to voa
1363 +* voafnct = 1 **
1364 data voptr = voafnct; $ ready to begin definition
1365
1366 size voa(voasz); dims voa(vomax);
1367 .+s66 nameset blank; $ keep in blank common on s66.
1368 size voawrt(1); $ on if writing voa file
1369 .+s66 end nameset;
1370 $ v o a f i e l d s
1371
1372 $ fields common to both -operation- and -quantity- operations
1373
1374 .+s66.
1375 +* deflev = .f. 1, 6, ** $ definition level
1376 +* keeb = .f. 7, 1, ** $ keep bit for holding till blkend
1377 +* naym = .f. 8, 10, ** $ ha ptr
1378 +* opb = .f. 18, 1, ** $ 'is this an operation'
1379 +* syze = .f. 19, 11, ** $ entry size in bits
1380 +* amode = .f. 118, 1, ** $ real or integer mode
1381
1382 $ voa field for -variable' or non-operation entries (opb = no)
1383
1384 +* arb = .f. 30, 1, ** $ argument bit
1385 +* argno = .f. 31, 5, ** $ argument no of parameter
1386 +* const = .f. 36, 1, ** $ on if 'constant'
1387 +* dimn = .f. 37, 16, ** $ dimension of array (or 0 if no dimn)
1388 +* vlen = .f. 55, 5, ** $ no of words in constant value
1389 +* temb = .f. 60, 1, ** $ on if 'temporary'
1390 +* voanl = .f. 61, 9, ** $ pointer to -nl- for global
1391 +* madr = .f. 70, 16, ** $ machine address of item
1392 +* mblk = .f. 86, 6, ** $ machine block of item
1393 +* type = .f. 92, 2, ** $ quantity type
1394 +* vbeg = .f. 94, 12, ** $ start of const val in -val- array
1395 +* signbit = .f.106,1, ** $ sign of constant (0=+, 1=-)
1396 +* lextype = .f. 107,5, ** $ lexical type of constant
1397 +* isafnct = .f. 113,1, ** $ set when name used as function name
1398 +* varnuse = .f. 114, 4, ** $ number of uses of var.
1399 +* varnusemax = 1b'1111' ** $ max of -varnuse- field
1400 +* isavar = .f. 119, 1, ** $ 'used as variable'
1401
1402 $ fields for operation type entries
1403
1404
1405 +* argbeg = .f. 30, 9, ** $ beginning of extra arguments
1406 +* arglen = .f. 39, 9, ** $ number of extra arguments
1407 +* db1 = .f. 49, 1, ** $ drop bit for input 1
1408 +* db2 = .f. 50, 1, ** $ drop bit for input 2
1409 +* db3 = .f. 51, 1, ** $ drop bit for input 3
1410 +* opcode = .f. 52, 7, **
1411 +* seblk = .f. 59, 1, ** $ indicates if scall ends block
1412 +* bytaln = .f. 60, 1, ** $ indicates char. extract or assign
1413 +* inp1 = .f. 61, 12, ** $ voa index of first input
1414 +* inp2 = .f. 73, 12, ** $ voa index of second input
1415 +* inp3 = .f. 85, 12, ** $ voa index of third input
1416 +* oup = .f. 97, 12, ** $ voa index of output
1417 +* lastuse = .f. 109, 9, **$ voa index of last use of op
1418 +* dboup = .e. 119, 01, ** $ drop bit if oup used as input.
1419 ..s66
1420
vax 85 .+s32.
vax 86 +* amode = .f. 1, 1, **
vax 87 +* keeb = .f. 2, 1, **
vax 88 +* opb = .f. 3, 1, **
vax 89 +* naym = .f. 4, 10, **
vax 90 +* syze = .f. 17, 16, **
vax 91 +* deflev = .f. 33, 6, **
vax 92
vax 93 +* const = .f. 14, 1, **
vax 94 +* temb = .f. 15, 1, **
vax 95 +* signbit = .f. 16, 1, **
vax 96 +* isafnct = .f. 39, 1, **
vax 97 +* voanl = .f. 40, 9, **
dsw 29 +* dimn = .f. 129, 32, **
dss 24 +* varnuse = .f. 65, 8, **
dss 25 +* varnusemax = 4b'ff' **
dss 26 +* mblk = .f. 73, 7, **
dss 27 +* isavar = .f. 80, 1, **
dsw 30 +* madr = .f. 161, 32, **
dss 29 +* vlen = .f. 97, 8, **
dss 30 +* lextype = .f. 105, 4, **
dss 31 +* argno = .f. 109, 5, **
dss 32 +* arb = .f. 114, 1, **
dss 33 +* type = .f. 115, 2, **
dss 34 +* vbeg = .f. 117, 12, **
vax 110
vax 111 +* db1 = .f. 14, 1, **
vax 112 +* db2 = .f. 15, 1, **
vax 113 +* db3 = .f. 16, 1, **
vax 114 +* arglen = .f. 39, 9, **
vax 115 +* dboup = .f. 48, 1, **
vax 116 +* inp1 = .f. 49, 16, **
vax 117 +* inp2 = .f. 65, 11, **
vax 118 +* lastuse = .f. 76, 10, **
vax 119 +* inp3 = .f. 86, 11, **
vax 120 +* opcode = .f. 97, 8, **
vax 121 +* seblk = .f. 105, 1, **
vax 122 +* bytaln = .f. 106, 1, **
vax 123 +* argbeg = .f. 107, 10, **
vax 124 +* oup = .f. 118, 11, **
vax 125 ..s32
1421 .+s37.
1422 +* amode = .f. 1, 1, **
1423 +* keeb = .f. 2, 1, **
1424 +* opb = .f. 3, 1, **
1425 +* naym = .f. 4, 10, **
1426 +* syze = .f. 17, 16, **
1427 +* deflev = .f. 33, 6, **
1428
1429 +* const = .f. 14, 1, **
1430 +* temb = .f. 15, 1, **
1431 +* signbit = .f. 16, 1, **
1432 +* isafnct = .f. 39, 1, **
1433 +* voanl = .f. 40, 9, **
dsw 31 +* dimn = .f. 129, 32, **
dst 15 +* varnuse = .f. 65, 8, **
dst 16 +* varnusemax = 4b'ff' **
dst 17 +* mblk = .f. 73, 7, **
dst 18 +* isavar = .f. 80, 1, **
dsw 32 +* madr = .f. 161, 32, **
dst 20 +* vlen = .f. 97, 8, **
dst 21 +* lextype = .f. 105, 4, **
dst 22 +* argno = .f. 109, 5, **
dst 23 +* arb = .f. 114, 1, **
dst 24 +* type = .f. 115, 2, **
dst 25 +* vbeg = .f. 117, 12, **
1446
1447 +* db1 = .f. 14, 1, **
1448 +* db2 = .f. 15, 1, **
1449 +* db3 = .f. 16, 1, **
1450 +* arglen = .f. 39, 9, **
1451 +* dboup = .f. 48, 1, **
1452 +* inp1 = .f. 49, 16, **
1453 +* inp2 = .f. 65, 11, **
1454 +* lastuse = .f. 76, 10, **
1455 +* inp3 = .f. 86, 11, **
1456 +* opcode = .f. 97, 8, **
1457 +* seblk = .f. 105, 1, **
1458 +* bytaln = .f. 106, 1, **
1459 +* argbeg = .f. 107, 10, **
1460 +* oup = .f. 118, 11, **
1461 ..s37
utsa 101 .+s47.
utsa 102 +* amode = .f. 1, 1, **
utsa 103 +* keeb = .f. 2, 1, **
utsa 104 +* opb = .f. 3, 1, **
utsa 105 +* naym = .f. 4, 10, **
utsa 106 +* syze = .f. 17, 16, **
utsa 107 +* deflev = .f. 33, 6, **
utsa 108
utsa 109 +* const = .f. 14, 1, **
utsa 110 +* temb = .f. 15, 1, **
utsa 111 +* signbit = .f. 16, 1, **
utsa 112 +* isafnct = .f. 39, 1, **
utsa 113 +* voanl = .f. 40, 9, **
utsa 114 +* dimn = .f. 129, 32, **
utsa 115 +* varnuse = .f. 65, 8, **
utsa 116 +* varnusemax = 4b'ff' **
utsa 117 +* mblk = .f. 73, 7, **
utsa 118 +* isavar = .f. 80, 1, **
utsa 119 +* madr = .f. 161, 32, **
utsa 120 +* vlen = .f. 97, 8, **
utsa 121 +* lextype = .f. 105, 4, **
utsa 122 +* argno = .f. 109, 5, **
utsa 123 +* arb = .f. 114, 1, **
utsa 124 +* type = .f. 115, 2, **
utsa 125 +* vbeg = .f. 117, 12, **
utsa 126
utsa 127 +* db1 = .f. 14, 1, **
utsa 128 +* db2 = .f. 15, 1, **
utsa 129 +* db3 = .f. 16, 1, **
utsa 130 +* arglen = .f. 39, 9, **
utsa 131 +* dboup = .f. 48, 1, **
utsa 132 +* inp1 = .f. 49, 16, **
utsa 133 +* inp2 = .f. 65, 11, **
utsa 134 +* lastuse = .f. 76, 10, **
utsa 135 +* inp3 = .f. 86, 11, **
utsa 136 +* opcode = .f. 97, 8, **
utsa 137 +* seblk = .f. 105, 1, **
utsa 138 +* bytaln = .f. 106, 1, **
utsa 139 +* argbeg = .f. 107, 10, **
utsa 140 +* oup = .f. 118, 11, **
utsa 141 ..s47
dso 30 .+s10.
dso 31 +* amode = .f. 1, 1, **
dso 32 +* keeb = .f. 2, 1, **
dso 33 +* opb = .f. 3, 1, **
dso 34 +* naym = .f. 4, 10, **
dso 35 +* syze = .f. 17, 11, **
dso 36 +* deflev = .f. 28, 6, **
dso 37
dso 38 +* const = .f. 14, 1, **
dso 39 +* temb = .f. 15, 1, **
dso 40 +* signbit = .f. 16, 1, **
dso 41 +* isafnct = .f. 37, 1, **
dso 42 +* inreg = .f. 38, 8, **
dso 43 +* ppdata = .f. 46, 1, **
dso 44 +* voanl = .f. 38, 9, **
dso 45 +* vlen = .f. 47, 8, **
dso 46 +* lextype = .f. 55, 4, **
dso 47 +* frsdata = .f. 47, 12, **
dso 48 +* argno = .f. 59, 5, **
dso 49 +* mblk = .f. 64, 6, **
dso 50 +* arb = .f. 70, 1, **
dso 51 +* isavar = .f. 71, 1, **
dso 52 +* type = .f. 73, 2, **
dsw 33 +* dimn = .f. 75, 17, **
dsw 34 +* madr = .f. 92, 17, **
dst 26 +* vbeg = .f. 109, 12, **
dst 27 +* varnuse = .f. 121, 8, **
dso 57 +* varnusemax = 4b'ff' **
dso 58
dso 59 +* db1 = .f. 14, 1, **
dso 60 +* db2 = .f. 15, 1, **
dso 61 +* db3 = .f. 16, 1, **
dso 62 +* arglen = .f. 37, 9, **
dso 63 +* dboup = .f. 46, 1, **
dso 64 +* inp1 = .f. 47, 11, **
dso 65 +* inp2 = .f. 58, 11, **
dso 66 +* seblk = .f. 69, 1, **
dso 67 +* bytaln = .f. 70, 1, **
dso 68 +* inp3 = .f. 73, 11, **
dso 69 +* lastuse = .f. 84, 10, **
dso 70 +* oup = .f. 94, 11, **
dso 71 +* opcode = .f. 109, 7, **
dso 72 +* argbeg = .f. 116, 10, **
dso 73 ..s10
1503 $ macro voaup counts up the voa ptr
1504 +* voaup = $ increment voa top pointer
1505 countup(voptr, vomax, 'voa'); **
1506
1507 size voafilename(ws); $ name of voa file
1508 $ v o a f i l e m a c r o s
1509 +* vofsz = $ size of voa file header frame.
vax 126 .+s32 256
1510 .+s37 256
utsa 142 .+s47 256
1511 .+s66 240
1512 .+s10 288
1513 **
1514
1515 +* voa_level = .e. 17, 16, ** $ julian date of last change
1516 $ relative to 1 jan 1976 (ie, juliandate - 76000).
1517 $ *** when change array size or fields, update version no. ***
1518
1519 $ codes for items in voa-file
1520 +* voaeof_code = 0 ** $ marks end of file
1521 +* voahdr_code = 1 ** $ file header code
1522 +* voaasm_code = 2 ** $ routine header code
1523 +* voa_code = 3 ** $ voa
1524 +* ha_code = 4** $ ha
1525 +* names_code = 5 ** $ names array
1526 +* xarg_code = 6 ** $ xarg array
1527 +* val_code = 7 ** $ val array
1528 +* mbacode = 8 ** $ m-achine b-lock a-rray (mba)
1529 +* eos_code = 9 ** $ code for end of subprogram
1530
1531
vax 127 .+s32.
vax 128 $ first, fields common to all header entries
vax 129 +* vof_code = .e. 1,16, ** $ code of item
vax 130 +* vof_hdrseq = .e. 17,16, ** $ header sequence number
vax 131 +* vof_es = .e.33,16, ** $ entry size in bits
vax 132 +* vof_lo = .e.49,16, ** $ lo entry of array
vax 133 $ for debugging
vax 134 +* vof_hi = .e.65,16, ** $ high entry of array
vax 135 +* vof_listcode = .e. 81, 01, ** $ on to list generated code.
vax 136 $ to format of any item written to voa.
vax 137 +* vof_hamax = .e. 97,16, ** $ hamax in gen
vax 138
vax 139 $ fields used to pass non/array args to assembler
vax 140 +* vof_asmarg = .e. 129, 16,** $ assemblarg
vax 141 +* vof_init = .e. 145, 16,** $ init
vax 142 +* vof_lablistptr = .e. 161, 16, ** $ lablistptr
vax 143 +* vof_sub1 = .e. 177, 16, ** $ subinfo(1), a name
vax 144 +* vof_sub2 = .e. 193, 16, ** $ subinfo(2)
vax 145 +* vof_sub3 = .e. 209, 16, ** $ subinfo(3)
vax 146 +* vof_subrargs = .e. 225, 16, ** $ no. of arguments of current
vax 147 $ routine
vax 148 +* vof_ha0 = .e. 241, 16, ** $ ha index of constant 0.
vax 149 +* vof_ha1 = .e. 113, 16, ** $ ha index of constant 1.
vax 150 ..s32
1532 .+s37.
1533 $ first, fields common to all header entries
1534 +* vof_code = .e. 1,16, ** $ code of item
1535 +* vof_hdrseq = .e. 17,16, ** $ header sequence number
1536 +* vof_es = .e.33,16, ** $ entry size in bits
1537 +* vof_lo = .e.49,16, ** $ lo entry of array
1538 $ for debugging
1539 +* vof_hi = .e.65,16, ** $ high entry of array
1540 +* vof_listcode = .e. 81, 01, ** $ on to list generated code.
1541 $ to format of any item written to voa.
1542 +* vof_hamax = .e. 97,16, ** $ hamax in gen
1543
1544 $ fields used to pass non/array args to assembler
1545 +* vof_asmarg = .e. 129, 16,** $ assemblarg
1546 +* vof_init = .e. 145, 16,** $ init
1547 +* vof_lablistptr = .e. 161, 16, ** $ lablistptr
1548 +* vof_sub1 = .e. 177, 16, ** $ subinfo(1), a name
1549 +* vof_sub2 = .e. 193, 16, ** $ subinfo(2)
1550 +* vof_sub3 = .e. 209, 16, ** $ subinfo(3)
1551 +* vof_subrargs = .e. 225, 16, ** $ no. of arguments of current
1552 $ routine
1553 +* vof_ha0 = .e. 241, 16, ** $ ha index of constant 0.
1554 +* vof_ha1 = .e. 113, 16, ** $ ha index of constant 1.
1555 ..s37
utsa 143 .+s47.
utsa 144 $ first, fields common to all header entries
utsa 145 +* vof_code = .e. 1,16, ** $ code of item
utsa 146 +* vof_hdrseq = .e. 17,16, ** $ header sequence number
utsa 147 +* vof_es = .e.33,16, ** $ entry size in bits
utsa 148 +* vof_lo = .e.49,16, ** $ lo entry of array
utsa 149 $ for debugging
utsa 150 +* vof_hi = .e.65,16, ** $ high entry of array
utsa 151 +* vof_listcode = .e. 81, 01, ** $ on to list generated code.
utsa 152 $ to format of any item written to voa.
utsa 153 +* vof_hamax = .e. 97,16, ** $ hamax in gen
utsa 154
utsa 155 $ fields used to pass non/array args to assembler
utsa 156 +* vof_asmarg = .e. 129, 16,** $ assemblarg
utsa 157 +* vof_init = .e. 145, 16,** $ init
utsa 158 +* vof_lablistptr = .e. 161, 16, ** $ lablistptr
utsa 159 +* vof_sub1 = .e. 177, 16, ** $ subinfo(1), a name
utsa 160 +* vof_sub2 = .e. 193, 16, ** $ subinfo(2)
utsa 161 +* vof_sub3 = .e. 209, 16, ** $ subinfo(3)
utsa 162 +* vof_subrargs = .e. 225, 16, ** $ no. of arguments of current
utsa 163 $ routine
utsa 164 +* vof_ha0 = .e. 241, 16, ** $ ha index of constant 0.
utsa 165 +* vof_ha1 = .e. 113, 16, ** $ ha index of constant 1.
utsa 166 ..s47
1556 .+s66.
1557 +* vof_code = .e. 01, 06, ** $ code of item
1558 +* vof_hdrseq = .e. 07, 18, ** $ header sequence number.
1559 +* vof_es = .e. 25, 12, ** $ entry size in bits
1560 +* vof_lo = .e. 37, 12, ** $ lo entry of array
1561 +* vof_hi = .e. 49, 12, ** $ high entry of array
1562 +* vof_listcode = .e. 61, 01, ** $ on to list generated code.
1563 +* vof_hamax = .e. 62, 11, ** $ hamax in gen
1564 +* vof_asmarg = .e. 73, 12,** $ assemblarg
1565 +* vof_init = .e. 85, 12,** $ init
1566 +* vof_lablistptr = .e. 97, 12, ** $ lablistptr
1567 +* vof_sub1 = .e. 109, 12, ** $ subinfo(1), a name
1568 +* vof_sub2 = .e. 121, 12, ** $ subinfo(2)
1569 +* vof_sub3 = .e. 133, 12, ** $ subinfo(3)
1570 +* vof_subrargs = .e. 145, 12, ** $ no. of arguments of current
1571 $ routine
1572 +* vof_ha0 = .e. 157, 12, ** $ ha index of constant 0.
1573 +* vof_ha1 = .e. 169, 12, ** $ ha index of constant 1.
1574 ..s66
1575 .+s10.
1576 +* vof_code = .f. 1, 18, **
1577 +* vof_hdrseq = .f. 19, 18, **
1578 +* vof_es = .f. 37, 18, **
1579 +* vof_lo = .f. 55, 18, **
1580 +* vof_hi = .f. 73, 18, **
1581 +* vof_listcode = .f. 91, 1, **
1582 +* vof_hamax = .f. 109, 18, **
1583 +* vof_asmarg = .f. 127, 18, **
1584 +* vof_init = .f. 145, 18, **
1585 +* vof_lablistptr = .f. 163, 18, **
1586 +* vof_sub1 = .f. 181, 18, **
1587 +* vof_sub2 = .f. 199, 18, **
1588 +* vof_sub3 = .f. 217, 18, **
1589 +* vof_subrargs = .f. 235, 18, **
1590 +* vof_ha0 = .f. 253, 18, **
1591 +* vof_ha1 = .f. 271, 18, **
1592 ..s10
1593
1594 size vof(vofsz); $ scratch area for building voa file frames.
1595
1596 size vofhdrseq(ps); data vofhdrseq=0; $ vof header frame sequen
1597 $ warnthis is number of warnings issued including current
1598 $ routine. warnprev is number of warnings issues through
1599 $ end of previous routine.
1600 size warnprev(ps); data warnprev = 0;
1601 size warnthis(ps); data warnthis = 0;
1602
1603 $ x a r g. extra arguments array
dsw 35 +* xargsz = $ size of xarg array.
dsw 36 .+s10 ws
dsw 37 .+s32 64
dsw 38 .+s37 64
utsa 167 .+s47 64
dsw 39 .+s66 ws
dsw 40 **
1605 +* xargmax = 511 ** $ xarg dims
1606 .+s66 nameset blank; $ keep in blank common on s66.
1607 size xarg(xargsz); dims xarg(xargmax); $ extra arguments array
1608 .+s66 end nameset;
1609 size xargptr(ps); data xargptr = 1; $ ptr to xarg
1610 $ fields of xarg array
1611 .+s66.
1612 +* xarg_voa = .f. 16, 15, ** $ ptr to voa entry
1613 +* xarg_db = .f. 31, 1, **
1614 +* xarg_rep = .f. 1, 15, **
1615 ..s66
vax 151 .+s32.
vax 152 +* xarg_voa = .f. 1, 16, **
vax 153 +* xarg_db = .f. 17, 1, **
dsw 41 +* xarg_rep = .f. 33, 32, **
vax 155 ..s32
1616 .+s37.
1617 +* xarg_voa = .f. 1, 16, **
1618 +* xarg_db = .f. 17, 1, **
dsw 42 +* xarg_rep = .f. 33, 32, **
1620 ..s37
utsa 168 .+s47.
utsa 169 +* xarg_voa = .f. 1, 16, **
utsa 170 +* xarg_db = .f. 17, 1, **
utsa 171 +* xarg_rep = .f. 33, 32, **
utsa 172 ..s47
1621 .+s10.
dsw 43 +* xarg_voa = .f. 1, 15, **
dsw 44 +* xarg_rep = .f. 19, 18, **
dsw 45 +* xarg_db = .f. 16, 1, **
1625 ..s10
1626
1627 $ x h a. hash array for global symbols
1628 +* xhamax = $ dimension of -xha-
1629 443
1630 **
1631
1632 +* xhasz = $ size of xha
1633 .+s66 60
vax 156 .+s32 64
1634 .+s37 64
utsa 173 .+s47 64
1635 .+s10 72
1636 **
1637
1638 .+s66 nameset blank; $ keep in blank common on s66.
1639 size xha(xhasz); dims xha(xhamax); $ global hash table
1640 .+s66 end nameset;
1641 $ xhafree is xha index of next free entry + 1.
1642 size xhafree(ps); data xhafree = xhamax+1;
1643
1644 $ xha fields
1645 .+s66.
1646 +* nlno = .f. 01, 09, ** $ index of size info for global var
1647 +* xlink = .f. 10, 09, ** $ link for hash in -xha-
1648 +* xnsblk = .f. 19, 06, ** $ -mba- pointer for nameset
1649 +* xhabif = .f. 25, 05, ** $ code if builtin operator name
1650 +* xnchars = .f. 33, 08, ** $ number of characters of name
1651 +* xnameptr = .f. 41, 10, ** $ -xnames- index of symbol
1652 ..s66
vax 157 .+s32.
vax 158 +* nlno = .f. 1, 16, **
vax 159 +* xlink = .f. 17, 16, **
vax 160 +* xnsblk = .f. 33, 8, **
vax 161 +* xnchars = .f. 41, 8, **
vax 162 +* xhabif = .f. 49, 6, **
vax 163 +* xnameptr = .f. 55, 10, **
vax 164 ..s32
1653 .+s37.
1654 +* nlno = .f. 1, 16, **
1655 +* xlink = .f. 17, 16, **
1656 +* xnsblk = .f. 33, 8, **
1657 +* xnchars = .f. 41, 8, **
1658 +* xhabif = .f. 49, 6, **
1659 +* xnameptr = .f. 55, 10, **
1660 ..s37
utsa 174 .+s47.
utsa 175 +* nlno = .f. 1, 16, **
utsa 176 +* xlink = .f. 17, 16, **
utsa 177 +* xnsblk = .f. 33, 8, **
utsa 178 +* xnchars = .f. 41, 8, **
utsa 179 +* xhabif = .f. 49, 6, **
utsa 180 +* xnameptr = .f. 55, 10, **
utsa 181 ..s47
1661 .+s10.
1662 +* nlno = .f. 1, 18, **
1663 +* xlink = .f. 19, 18, **
1664 +* xnameptr = .f. 37, 18, **
1665 +* xnsblk = .f. 55, 6, **
1666 +* xhabif = .f. 61, 5, **
1667 +* xnchars = .f. 66, 7, **
1668 ..s10
1669
1670 +* xnamesmax = $ dimension of -xnames-
1671 .+s66 400
vax 165 .+s32 600
1672 .+s37 600
utsa 182 .+s47 600
dso 74 .+s10 600
1674 **
1675
1676 .+s66 nameset blank; $ keep in blank common on s66.
1677 size xnames(ws); dims xnames(xnamesmax); $ xha names array
1678 .+s66 end nameset;
1679 size xnamesptr(ps); data xnamesptr = 1; $ xnames ptr
1680
1681
1682
1683 call genini; $ to initialize program and print title
1684 call parse; $ enter parser
1685 exitcode = 0; call genexit; $ end executions (normal)
dso 75 .+s10 end prog start;
vax 166 .+s32 end prog start;
dso 76 .+s37 end prog start;
utsa 183 .+s47 end prog start;
dso 77 .+s66 end subr start;
1 .=member genini
2 subr genini; $ initialize parser
3 size help(sds(filenamelen)); data help = ''; $ initial debug opt
4 size machinename(sds(20)); $ names of possible host, targets
5 dims machinename(totmachines);
6 data
ldsd 17 $ insert names of new machines after this line.
8 machinename(m66) = 'cdc 6000 series':
ldsd 18 .+s32v machinename(m32) = 'dec vax-11 vms':
ldsd 19 .+s32u machinename(m32) = 'dec vax-11 unix':
dso 78 machinename(m37) = 'ibm system/370':
utsa 184 machinename(m47) = 'amdahl uts':
dso 79 machinename(m40) = 'prime 400':
10 machinename(m16) = 'honeywell series 16':
11 machinename(m11) = 'dec pdp-11':
12 machinename(m10) = 'decsystem-10';
13
14 size tmvar(sds(10)); $ receives tm specification
15 $ --note-- require that filenamelen >= 2*tmparams
16 size tmvarlabel(sds(35));
17 size c1(cs), c2(cs); $ character temporaries for tm processing
18 data tmvarlabel = ' ws= , ps= , cs= , sl= , so= .';
19 size voafilename(sds(filenamelen)); $ name of voa file
20 size tokenfilename(sds(filenamelen)); $ name of token file
dsv 16 size appstr(.sds. getapp_len); $ actual parameter string.
22 size i(ps); $ do loop index
23 size j(ps); $ index.
24 size hap(ps), xhap(ps); $ ha and xha indexes.
ldsa 55 size rep_opt_str(.sds. filenamelen);
eaa 9 size targetmachine20(1); $ on if tm=20 for extended addr.
25
26 do i = 1 to xhamax; xha(i) = 0; end do; $ clear xha.
27 $ we hold the alias names for built-in functions in -bfntab-
28 $ during initialization in the flollowing format (op, name).
29 $ if op is zero, name is the machine for which the aliases are
30 $ assigned (0 ends list).
dss 35 +* bfntabsz = (.sds. 10) **
utsa 185 +* bfntabmax = 150 **
33 size bfntab(bfntabsz); dims bfntab(bfntabmax);
34 data bfntab =
35 +* ins(op, name) = op, name, ** $ name to insert
dso 81 0, m10, $ aliases for s10
dso 87 ins(bop_exp, 'expx$r')
dso 88 ins(bop_alog, 'alog$r')
dso 89 ins(bop_alog10, 'al10$r')
dso 90 ins(bop_sin, 'sinx$r')
dso 91 ins(bop_cos, 'cosx$r')
dso 92 ins(bop_tanh, 'tanh$r')
dso 93 ins(bop_sqrt, 'sqrt$r')
dso 94 ins(bop_atan, 'atan$r')
dso 95 ins(bop_atan2, 'atn2$r')
vax 169 0, m32, $ aliases for s32
dss 36 ins(bop_exp, 'mth$exp')
dss 37 ins(bop_alog, 'mth$alog')
ldsb 22 .+s32v ins(bop_alog10, 'mth$alog10')
ldsb 23 .+s32u ins(bop_alog10, 'mth$alg10') $ at most eight chars for unix
dss 39 ins(bop_sin, 'mth$sin')
dss 40 ins(bop_cos, 'mth$cos')
dss 41 ins(bop_tanh, 'mth$tanh')
dss 42 ins(bop_sqrt, 'mth$sqrt')
dss 43 ins(bop_atan, 'mth$atan')
ldsb 24 .+s32v ins(bop_atan2, 'mth$atan2')
ldsb 25 .+s32u ins(bop_atan2, 'mth$atn2') $ at most eight chars for unix
ldsd 20 ins(bop_amod, 'mth$amod')
ldsd 21 ins(bop_aint, 'mth$aint')
ldsd 22 ins(bop_dim, 'mth$dim')
36 0, m37, $ aliases for s37
37 ins(bop_float, 'fltc$rl')
38 ins(bop_ifix, 'ifix$rl')
39 ins(bop_aint, 'aint$rl')
40 ins(bop_int, 'ifix$rl')
41 ins(bop_amod, 'amod$rl')
42 ins(bop_exp, 'expx$rl')
43 ins(bop_alog, 'alog$rl')
44 ins(bop_alog10, 'al10$rl')
45 ins(bop_sin, 'sinx$rl')
46 ins(bop_cos, 'cosx$rl')
47 ins(bop_tanh, 'tanh$rl')
48 ins(bop_sqrt, 'sqrt$rl')
49 ins(bop_atan, 'atan$rl')
50 ins(bop_atan2, 'atn2$rl')
utsa 186 0, m47, $ aliases for s47
utsa 187 $ these names must match those used in little env mlib.s to
utsa 188 $ interface to the c library.
utsa 189 ins(bop_float, 'fltc$rl')
utsa 190 ins(bop_ifix, 'ifix$rl')
utsa 191 ins(bop_aint, 'aint$rl')
utsa 192 ins(bop_int, 'ifix$rl')
utsa 193 ins(bop_amod, 'amod$rl')
utsa 194 ins(bop_exp, 'expx$rl')
utsa 195 ins(bop_alog, 'alog$rl')
utsa 196 ins(bop_alog10, 'al10$rl')
utsa 197 ins(bop_sin, 'sinx$rl')
utsa 198 ins(bop_cos, 'cosx$rl')
utsa 199 ins(bop_tanh, 'tanh$rl')
utsa 200 ins(bop_sqrt, 'sqrt$rl')
utsa 201 ins(bop_atan, 'atan$rl')
utsa 202 ins(bop_atan2, 'atn2$rl')
51 0,m66, $ aliases for 6600.
52 ins(bop_exp ,'expx$ml')
53 ins(bop_alog ,'alog$ml')
54 ins(bop_alog10,'al10$ml')
55 ins(bop_sin ,'sinx$ml')
56 ins(bop_cos ,'cosx$ml')
57 ins(bop_tanh ,'tanh$ml')
58 ins(bop_sqrt ,'sqrt$ml')
59 ins(bop_atan ,'atan$ml')
60 ins(bop_atan2 ,'atn2$ml')
61 0, 0; $ end of alias list
62 macdrop(ins)
63
64 size wpr(ps); data wpr = 1; $ words per real.
65
66 $ initialization data for built-ins
67 size bfnames(sds(6)); dims bfnames(numfncts);
68 data bfnames = $ user names for built-in functions
69 'float', 'ifix', 'abs', 'iabs', 'aint', 'int',
70 'amod', 'mod', 'sign', 'isign', 'dim', 'idim',
71 'exp', 'alog', 'alog10', 'sin', 'cos', 'tanh',
72 'sqrt', 'atan', 'atan2';
73
74 $ the -bftyptab- array contains bit strings (one for each target
75 $ machine) indicating the types of each function. if a bit is
76 $ 1, the corresponding function is external; otherwise it is
77 $ internal.
78 size bftyptab(numfncts); dims bftyptab(totmachines);
79 data
dsr 14 bftyptab(m10) = 1b' 1 11111 11100 00000 00000':
81 bftyptab(m11) = 1b' 1 11111 11101 01011 10111':
82 bftyptab(m16) = 1b' 1 11111 11100 00000 00000':
ldsd 23 bftyptab(m32) = 1b' 1 11111 11101 00010 10000':
83 bftyptab(m37) = 1b' 1 11111 11100 00011 10011':
utsa 203 bftyptab(m47) = 1b' 1 11111 11100 00011 10011':
dso 96 bftyptab(m40) = 1b' 1 11111 11100 00011 10011':
84 bftyptab(m66) = 1b' 1 11111 11100 00000 00000';
85
86 sorg sdsnamstr = nameorg; $ initalize origin
87
88 $ on entry, the literal information is available in arglist
89 $ as 3 entry groups, giving literal code, class, and value.
90 $ a code of 0 indicates end of list.
91 size cc(ps), vv(ps);
92 do i = 1 to argmax; $ scan over initial data.
93 if (arglist(i) = 0) quit do; $ at end of table.
94 vv = .f. 9, 8, arglist(i); $ get value.
95 if .f. 1, 8, arglist(i) then $ if table entry.
96 littabl(cc, (.f. 1, 8, arglist(i))) = vv; $ set value.
97 else
98 cc = vv; $ set class
99 end if;
100 end do;
101
102 do i = 1 to hamax; $ clear the ha.
103 ha(i) = 0; end do;
104
105 i = 0; $ set to null tm
vax 184 .+s32 call getipp(i, 'tm=32/11');
106 .+s37 call getipp(i, 'tm=37/');
utsa 204 .+s47 call getipp(i, 'tm=47/');
107 .+s66 call getipp(i, 'tm=66/');
108 .+s10 call getipp(i, 'tm=10/');
eaa 10 targetmachine20 = no; $ assume not tm=20
109 $ convert supplied code to machine code value.
110 if i=66 then targetmachine = m66;
111 elseif i=37 then targetmachine = m37;
dso 97 elseif i=40 then targetmachine = m40;
112 elseif i=16 then targetmachine = m16;
113 elseif i=11 then targetmachine = m11;
114 elseif i=10 then targetmachine = m10;
eaa 11 elseif i=20 then targetmachine = m10;
eaa 12 targetmachine20 = yes; $ note so can set .ps. correctly.
vax 185 elseif i=32 then targetmachine = m32;
utsa 205 elseif i=47 then targetmachine = m47;
115 else targetmachine = hostmachine;
116 end if;
117
118 do i = 1 to numfncts;
119 bfmode bifatrtab(i) =
120 (.ch. 1, bfnames(i) < 1ri ! .ch. 1, bfnames(i) > 1rn);
121 bfext bifatrtab(i) = .f. i, 1, bftyptab(targetmachine);
122 bfargs bifatrtab(i) = blkendtype(opofbif(i))-1;
123 call pshnamr(hap, bfnames(i)); $ add name to -ha-
124 insglob(xhap, hap); $ and then to -xha-
125 xhabif xha(xhap) = i; $ mark as builtin
126 end do;
127
128 $ now, check for any alias names for this machine.
129
130 $ first, look for marker for machine.
131 do i = 1 to bfntabmax by 2; $ names kept in -bfntab-
132 if .f. 1, ws, bfntab(i) = 0 then $ we have a marker
133 if (.f. 1, ws, bfntab(i+1) = 0) quit do; $ hit end of tab
134 if .f. 1, ws, bfntab(i+1) = targetmachine then $ got it
135 do j = i+2 to bfntabmax by 2;
136 if (.f. 1, ws, bfntab(j) = 0) quit do;
137 call pshnamr(hap, bfntab(j+1)); $ add to -ha-
138 insglob(xhap, hap); $ then to -xha-
139 bfalias bifatrtab(bifofop((.f. 1, ws, bfntab(j))))
140 = xhap;
141 end do;
142 end if;
143 end if;
144 end do;
145 .+pt call getipp(parsetrace, 'pt=0/1');
146
utsa 206 .+s37. $ see if want ebcdic/ascii conversion
utsa 207 call getipp(ebcascoption,'ebcasc=0/1');
utsa 208 ..s37
utsa 209
147 call getipp(asmvoadump, 'ad=0/1');
148 tmvar = tmvardef;
149
150 if targetmachine = m16 then $ honeywell series 16
151 tmvar = '1616081616'; iorts='';
152 wpr = 2; $ two words for floating point on s16.
153 elseif targetmachine = m11 then $ pdp-11.
154 tmvar = '1615081616';
155 elseif targetmachine = m37 then
utsa 210 tmvar = '3224081616';
utsa 211 elseif targetmachine = m47 then
utsa 212 tmvar = '3224081616';
dso 98 elseif targetmachine = m40 then
dso 99 tmvar = '1615081616';
157 elseif targetmachine = m66 then
158 tmvar = '6017061113';
159 elseif targetmachine = m10 then
mgfb 15 tmvar = '3618091818';
vax 186 elseif targetmachine = m32 then
vax 187 tmvar = '3230081616';
161 end if;
eaa 13
eaa 14 if targetmachine20 then $ if extended addressing
eaa 15 tmvar = '3630091818'; $ s10, except ps=30
eaa 16 end if;
162
163 if targetmachine = hostmachine then
164 do i = 1 to toktypes;
165 safeconst(i) = yes; end do;
166 end if;
167
utsa 213
utsa 214 .+s37. $ safe to convert also if target is s47
utsa 215 if targetmachine = m47 then
utsa 216 do i = 1 to toktypes;
utsa 217 safeconst(i) = yes; end do;
utsa 218 end if;
utsa 219 ..s37
utsa 220
168 $ bit constants may always be converted safely.
169 safeconst(dectok) = yes; safeconst(bittok) = yes;
170 safeconst(sstok) = no; $ s-type strings are never safe.
171
172 call getspp(tmvar, 'tmp=' !! tmvar !! '/');
173 if (slen tmvar ^= 10) tmvar = tmvardef; $ set default.
174
175 do i = 1 to 5;
176 c1 = .ch.(i*2)-1, tmvar; c2 = .ch. i*2, tmvar;
177 tmara(i) = 10*digofchar(c1) + digofchar(c2);
178 .ch. i*7 - 2, tmvarlabel = c1;
179 .ch. i*7 - 1, tmvarlabel = c2;
180 tmtokara(i) = blankword;
181 .f. tokarasz+1 - 1*cs, cs, tmtokara(i) = c1;
182 .f. tokarasz+1 - 2*cs, cs, tmtokara(i) = c2;
183 end do;
184
185 rlsz = mws * wpr; $ size of real number.
186
187 call getipp(sfp_opt, 'sfp=0/1');
188
189 gsopt = 1; $ for now, by default first procedure defines nameset
190 daopt = 1; $ for now, each routine has default access to all name
191 $ sets
192 call getipp(gsopt, 'gs=1/0');
193 call getipp(daopt, 'da=1/0');
194
ldse 13 call getipp(expire, 'expire=0/366');
ldse 14
vax 188 .+s32 call getspp(tokenfilename, 'tokens=tokens.tmp/');
195 .+s37 call getspp(tokenfilename, 'tokens=sysut1/');
utsa 221 .+s47 call getspp(tokenfilename, 'tokens=sysut1/');
196 .+s66 call getspp(tokenfilename, 'tokens=tokens/');
mgfa 1 .+s10 call getspp(tokenfilename, 'tokens=*.tok/');
198 call opensio(tokenfile, iorc, access_read, tokenfilename,
199 0, i, 0, 0);
dsv 17 .+s66 call rewisio(tokenfile, iorc, 0);
201 call dropsio(tokenfile, iorc); $ this is terminal use of tokenfil
202 call rdrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
vax 189 .+s32 call getspp(voafilename, 'voa=voa.tmp/');
203 .+s37 call getspp(voafilename, 'voa=sysut2/');
utsa 222 .+s47 call getspp(voafilename, 'voa=sysut2/');
204 .+s66 call getspp(voafilename, 'voa=voa/');
mgfa 2 .+s10 call getspp(voafilename, 'voa=*.voa/');
206 voawrt = (.ch. 1, voafilename ^= 1r0); $ set whether writing voa
207 file voafile access=write, title=voafilename;
dsv 18 .+s66 rewind voafile;
209 $ now write frame marking start of file
210 vof = 0;
211 vof_code vof = voahdr_code; $ file header
dspp 1 .+s66 voa_level vof = voafilelevel;
213 $ other fields not defined now
214 vofhdrseq = vofhdrseq+1; vof_hdrseq vof = vofhdrseq;
215 write voafile, vof;
216
221 call getipp(pelvalue, 'pel=50/10000');
222 call getipp(proclist, 'pdir=0/1');
223
dso 101 .+s10 call getspp(crfileparm, 'rf=*.rf0/');
vax 191 .+s32 call getspp(crfileparm, 'rf=little.rf0/');
224 .+s37 call getspp(crfileparm, 'rf=sysref(ref0)/');
utsa 223 .+s47 call getspp(crfileparm, 'rf=sysref(ref0)/');
225 .+s66 call getspp(crfileparm, 'rf=ref0/');
230 call getipp(crossrefoption, 'lcr=0/1');
dsu 10 $ pdir option requires crossrefoption.
dsu 11 if (proclist) crossrefoption = yes;
231 if crossrefoption then $ open second reference file.
232 proclist = yes; $ get procedure directory.
233 call crfnam(crfilename, crfileparm, 3); $ file 3.
234 call opensio(crfile, iorc, access_write, crfilename,
235 0, i, 0, 0);
236 end if;
237 mbaptr = globalblock - 1; $ mbaptr points to last global block
238 $ that has been defined, so start off just below globalblock
239
240
ldsa 56 .+rep.
ldsa 57 call getspp(rep_opt_str, 'rep=0/pg');
ldsa 58 rep_opt_c = ('c' .in. rep_opt_str) > 0;
ldsa 59 rep_opt_g = ('g' .in. rep_opt_str) > 0;
ldsa 60 rep_opt_p = ('p' .in. rep_opt_str) > 0;
ldsa 61 rep_opt = rep_opt_c ! rep_opt_g ! rep_opt_p;
ldsa 62 if rep_opt then
ldsa 63 file repfile access=put,title='', linesize=80;
ldsa 64 end if;
ldsa 65 ..rep
241 call getipp(ncfopt, 'ncf=1/0');
242 .+s66. $ set ncfopt=0 as default for bootstrap from
243 $ s66 to s10.
dso 102 $ disable ncf by default if bootstrapping from s66.
vax 192 if targetmachine=m10 ! targetmachine=m32
vax 193 ! targetmachine=m40 then
dso 104 call getipp(ncfopt, 'ncf=0/1'); end if;
245 ..s66
246 call getipp(debuglevel, 'mlev=1/2');
247 call getspp(help, 'help=/es');
248 if ('0' .in. help) help = ''; $ if '0' anywhere, no options used
249 if (slen help) debuglevel = 2; $ set debug level
250 gtrentrfg = ('e' .in. help) ^= 0; $ set global debug flags
251 gtrstorfg = ('s' .in. help) ^= 0;
252 gtrflowfg = ('f' .in. help) ^= 0;
253 gchinxfg = ('c' .in. help) ^= 0;
254
255
meal 14 $ if trace entry in effect, arguments to procedure will be
meal 15 $ listed if value of trentrargs nonzero; otherwise, only
meal 16 $ procedure name will be listed.
meal 17 call getipp(trentrargs,'meal=1/0');
meal 18 if (trentrargs>1) trentrargs = 1;
256
257 size sl(ps); $ length of iorts
258 sl = slen iorts;
259 do i = 1 to ionamesptr;
260 if sl then $ non-null trailer, append it
261 slen ionames(i) = 4+sl; $ adjust length
262 .s. 5, sl, ionames(i) = iorts; $ append trailer
263 else $ null trailer, adjust length to 4
264 slen ionames(i) = 4;
265 end if;
266 end do i;
267
268 sl = slen dbgts;
269 do i = 1 to numdebugnames;
270 if sl then $ non-null trailer string, append it
271 slen debugnames(i) = 4+sl; $ adjust length
272 .s. 5, sl, debugnames(i) = dbgts; $ append trailer
273 else $ null trailer, adjust length
274 slen debugnames(i) = 4;
275 end if;
276 end do i;
277 call getipp(lcs_opt, 'lcs=1/0'); $ list compilation statistics.
278 call getipp(lcp_opt, 'lcp=1/0'); $ list compilation parameters.
utse 14 .+s32u. $ minimal listing by default for unix.
ldsb 27 call getipp(lcp_opt, 'lcp=0/1');
ldsb 28 call getipp(lcs_opt, 'lcs=0/1');
utse 15 ..s32u
utse 16 .+s47. $ minimal listing by default for unix.
utse 17 call getipp(lcp_opt, 'lcp=0/1');
utse 18 call getipp(lcs_opt, 'lcs=0/1');
utse 19 ..s47
279
dsv 19 $ get actual parameters specified.
dsv 20 call getapp(appstr, getapp_len);
dsv 21
dss 45 .+s10 call getipp(cis_opt, 'cis=0/18');
dss 46 .+s32 call getipp(cis_opt, 'cis=0/30');
dss 47 .+s37 call getipp(cis_opt, 'cis=0/24');
utsa 224 .+s47 call getipp(cis_opt, 'cis=0/24');
dss 48 .+s66 call getipp(cis_opt, 'cis=0/17');
280 call ltitlr(compilerlevel);
281 call stitlr(0, 'little compilation - parse phase.');
ldsc 11 if (lcp_opt=0) go to parmslisted;
283 $ remaining code lists compilation parameters.
284
285 call stitlr(1, 'parameters for this parse.');
286
dsv 22 if .len. appstr then $ if any explicitly specified.
dsv 23 textl(appstr) endl endl
dsv 24 end if;
dsv 25
287 textl('host machine = ') textl(machinename(hostmachine))
288 textl('. target machine: tm = ')
289 textl(machinename(targetmachine))
290 textl('.') endl
291
292 textl('target machine parameters: tmp = ')
293 textl(tmvarlabel)
294 endl
295
296 textl('parse error limit: pel =') intlp(pelvalue, 3)
297 textl('. asm voa dump: ad =') intlp(asmvoadump, 2)
298 textl('.') endl
299
300 textl('globals in start: gs =') intlp(gsopt, 2)
301 textl('. default access: da =') intlp(daopt, 2)
302 textl('.') endl
303
304 if slen help then $ output initial debug options
305 textl('initial debug options: help =')
306 textl(help) textl('. ')
307 end if;
308
309 textl('monitor level: mlev =') intlp(debuglevel, 2)
meal 19 textl('. monitor entry arg list: meal=') intlp(trentrargs, 2)
meal 20 textl('.') endl
311
312 textl('list statistics: lcs =') intlp(lcs_opt,2)
313 textl('. fold negative constants: ncf =') intlp(ncfopt, 2)
314 textl('.') endl
315
316 textl('voa file: voa = ') textl(voafilename)
317 textl('. suppress first procedure: sfp =') intlp(sfp_opt, 2)
318 textl('.') endl
319 textl('lexical cross reference list: lcr =')
320 intlp(crossrefoption,2)
321 textl('. reference file: rf = ') textl(crfileparm)
322 textl('.') endl
323
324 textl('list procedure directory: pdir =') intlp(proclist, 2)
dss 49 textl('. check index size: cis =') intlp(cis_opt,3)
325 textl('.') endl
ldse 15 if expire then $ only list if expire specified.
ldse 16 textl('expire: expire = ') intl(expire) textl('.') endl
ldse 17 end if;
326 endl
utsa 225 .+s37.
utsa 226 textl('ebcdic to ascii: ebcasc = ') intl(ebcascoption) textl('.')
utsa 227 endl
utsa 228 ..s37
327 endl
328
ldsc 12 /parmslisted/
329 call stitlr(1, 'program listing.'); $ set subtitle
330
331 call ptdata; call purge; $ initialize.
332
333 end subr genini;
1 .=member ptdata
2 subr ptdata; $ data for parse table (pt)
3 nameset pt;
4 size pt(32);
5 dims pt(ptmax);
6 end nameset;
7 data pt =
8 $ member syntab
9 4b'001c 1295', 4b'04a5 0895', 4b'0905 0975', 4b'0b75 0b95', $ 1
10 4b'0c55 0d85', 4b'0eb5 0015', 4b'1155 1195', 4b'11e5 0bc5', $ 2
11 4b'01a5 01f5', 4b'0335 0155', 4b'005b 0011', 4b'0016 04f3', $ 3
12 4b'0245 000b', 4b'0011 0016', 4b'0583 0245', 4b'001b 0011', $ 4
13 4b'0016 03a3', 4b'0245 002b', 4b'0011 0437', 4b'0305 0016', $ 5
14 4b'0593 0459', 4b'0447 0173', 4b'003b 0011', 4b'2a55 004b', $ 6
15 4b'0011 2a55', 4b'0016 0143', 4b'0437 0405', 4b'2bca 0113', $ 7
16 4b'0447 0123', 4b'001b 0021', 4b'0357 0133', 4b'0015 01cb', $ 8
17 4b'0031 0357', 4b'0133 0015', 4b'0457 0002', 4b'0016 04e3', $ 9
18 4b'0002 001b', 4b'0041 2a8a', 4b'04a3 0477', 4b'0535 002b', $ 10
19 4b'0041 0015', 4b'0197 0585', 4b'00ab 0041', 4b'2a55 0187', $ 11
20 4b'05d5 00bb', 4b'0041 2a55', 4b'0177 0705', 4b'0207 0423', $ 12
21 4b'0016 0433', 4b'0437 0775', 4b'2a8a 0403', 4b'0447 0413', $ 13
22 4b'00d6 07a5', 4b'00a7 07a5', 4b'009b 0041', 4b'0015 003b', $ 14
23 4b'0041 12ca', 4b'0103 004b', 4b'0041 2a55', 4b'006b 0041', $ 15
24 4b'2a55 003b', 4b'0041 0127', 4b'03c3 2bca', 4b'03e3 0207', $ 16
25 4b'03d3 2bca', 4b'03f3 003b', 4b'0021 004b', 4b'0041 0002', $ 17
26 4b'001b 0051', 4b'2a8a 0643', 4b'002b 0051', 4b'2a55 001b', $ 18
27 4b'0061 2a8a', 4b'05b3 002b', 4b'0061 2a55', 4b'001b 0071', $ 19
28 4b'0016 02f3', 4b'02e7 02c3', 4b'2a8a 02d3', 4b'0207 02b3', $ 20
29 4b'2a8a 02e3', 4b'0487 0a85', 4b'0aba 0303', 4b'2a55 002b', $ 21
30 4b'0071 2a55', 4b'0337 0b25', 4b'2a8a 0002', 4b'003b 0071', $ 22
31 4b'0002 2a8a', 4b'0002 004b', 4b'0071 0002', 4b'0081 2a55', $ 23
32 4b'005b 0041', 4b'0015 007b', 4b'0041 2a8a', 4b'0323 0477', $ 24
33 4b'0313 008b', 4b'0041 0015', 4b'0c9a 0563', 4b'0d39 2a55', $ 25
34 4b'0016 0002', 4b'0437 0553', 4b'2bca 0543', 4b'0447 0573', $ 26
35 4b'0091 0002', 4b'0457 0002', 4b'0c9a 0563', 4b'0002 0dca', $ 27
36 4b'0293 0e69', 4b'2a55 0016', 4b'0002 0437', 4b'0283 2bca', $ 28
37 4b'0273 0447', 4b'02a3 00a1', 4b'0002 0457', 4b'0002 0dca', $ 29
38 4b'0293 0002', 4b'0016 0223', 4b'0437 0f65', 4b'2bca 0233', $ 30
39 4b'0447 0243', 4b'001b 00b1', 4b'0f95 002b', 4b'00b1 0f95', $ 31
40 4b'02e7 0203', 4b'103a 0213', 4b'1109 004b', 4b'00b1 0467', $ 32
41 4b'2a55 0eb5', 4b'2b7a 0002', 4b'0437 10e5', 4b'2bca 0253', $ 33
42 4b'0447 0263', 4b'003b 00b1', 4b'0002 0088', 4b'0002 0457', $ 34
43 4b'0002 103a', 4b'0333 0002', 4b'0016 04d3', 4b'00c1 2a55', $ 35
44 4b'0016 0183', 4b'0459 00d1', 4b'2a55 0016', 4b'0523 00e1', $ 36
45 4b'1239 2a55', 4b'0457 0002', 4b'0016 0523', 4b'00e1 0002', $ 37
46 4b'12ca 0103', 4b'2a55 002c', 4b'1b95 1455', 4b'15a5 16d5', $ 38
47 4b'1705 18f5', 4b'1935 1965', 4b'1985 19a5', 4b'19c5 1d05', $ 39
48 4b'1d75 2435', 4b'25a5 1b35', 4b'1de5 1e75', 4b'25f5 2615', $ 40
49 4b'26d5 26f5', 4b'2875 28e5', 4b'0016 01c3', 4b'0437 1515', $ 41
50 4b'2a8a 01d3', 4b'1559 0447', 4b'01e3 002b', 4b'00f1 0002', $ 42
51 4b'0088 001b', 4b'00f1 0002', 4b'0457 0002', 4b'2a8a 0333', $ 43
52 4b'0002 0437', 4b'1615 2a8a', 4b'0443 0447', 4b'0453 1645', $ 44
53 4b'0016 0483', 4b'1645 0437', 4b'0473 0016', 4b'0463 0459', $ 45
54 4b'0447 0493', 4b'0101 0002', 4b'0111 0088', 4b'0002 0207', $ 46
55 4b'0423 0016', 4b'0433 0437', 4b'1855 2a8a', 4b'0403 0447', $ 47
56 4b'0413 0127', 4b'1895 2bca', 4b'03e3 0207', 4b'03d3 2bca', $ 48
57 4b'03f3 003b', 4b'0021 0002', 4b'0088 01db', 4b'0031 0002', $ 49
58 4b'00d8 0121', 4b'0088 002b', 4b'0021 0002', 4b'000b 0131', $ 50
59 4b'0088 0002', 4b'0141 0088', 4b'0002 0168', 4b'1a65 01e8', $ 51
60 4b'1a65 0268', 4b'1a65 02e8', 4b'2a8a 0673', 4b'0457 0663', $ 52
61 4b'1bda 05e3', 4b'1caa 05c3', 4b'0002 2a8a', 4b'0673 0457', $ 53
62 4b'0663 2a8a', 4b'0673 0457', 4b'0663 1bda', 4b'05e3 1caa', $ 54
63 4b'05c3 0002', 4b'0368 1bda', 4b'05e3 1caa', 4b'05c3 0002', $ 55
64 4b'1bda 00e3', 4b'00e8 1ca5', 4b'0016 0002', 4b'0437 1c75', $ 56
65 4b'2a8a 0633', 4b'0447 0623', 4b'00c8 0002', 4b'0088 0048', $ 57
66 4b'0002 02e7', 4b'0002 2a8a', 4b'05d3 0151', 4b'0002 001b', $ 58
67 4b'0161 1f0a', 4b'0002 20ba', 4b'03b3 0002', 4b'002b 0161', $ 59
68 4b'1f0a 0002', 4b'20ba 0503', 4b'0002 2a8a', 4b'0513 00bb', $ 60
69 4b'0161 206a', 4b'0073 2069', 4b'0171 0002', 4b'2a8a 0653', $ 61
70 4b'00cb 0161', 4b'206a 0073', 4b'2069 0171', 4b'0002 2a8a', $ 62
71 4b'1f55 003b', 4b'0161 0002', 4b'0088 004b', 4b'0161 0002', $ 63
72 4b'2a8a 0002', 4b'0207 2025', 4b'2a8a 05f3', 4b'002b 0181', $ 64
73 4b'0002 0088', 4b'001b 0181', 4b'0002 0457', 4b'0002 1f9a', $ 65
74 4b'0073 0002', 4b'006b 0161', 4b'211a 0002', 4b'2119 0002', $ 66
75 4b'220a 2145', 4b'0002 21ba', 4b'0002 21b9', 4b'231a 0063', $ 67
76 4b'0171 0002', 4b'0467 0002', 4b'1f9a 0073', 4b'0002 0457', $ 68
77 4b'0002 0036', 4b'0043 0437', 4b'22d5 2a8a', 4b'0093 0447', $ 69
78 4b'00c3 001b', 4b'0191 0002', 4b'0088 000b', 4b'0191 0002', $ 70
79 4b'0457 0002', 4b'0046 0053', 4b'0437 23f5', 4b'2a8a 0093', $ 71
80 4b'1559 0447', 4b'00c3 001b', 4b'01a1 0002', 4b'0088 000b', $ 72
81 4b'01a1 0002', 4b'2a8a 0343', 4b'007b 0161', 4b'24ca 00a3', $ 73
82 4b'2559 01b1', 4b'0002 0056', 4b'0002 02e7', 4b'01a3 2a8a', $ 74
83 4b'01b3 008b', 4b'0161 0002', 4b'0457 0002', 4b'24ca 00a3', $ 75
84 4b'0002 2a8a', 4b'0533 009b', 4b'0161 0002', 4b'00b8 2635', $ 76
85 4b'0138 2635', 4b'0497 01f3', 4b'0016 26a5', 4b'0459 01c1', $ 77
86 4b'0002 0088', 4b'01d1 0002', 4b'00b8 2715', 4b'0038 2715', $ 78
87 4b'27ba 05a3', 4b'0016 2785', 4b'0459 01e1', 4b'0002 0088', $ 79
88 4b'01f1 0002', 4b'04a7 27f5', 4b'00a8 0002', 4b'04b7 2835', $ 80
89 4b'01a8 0002', 4b'04c7 0002', 4b'02a8 0002', 4b'000b 0201', $ 81
90 4b'2a8a 0193', 4b'001b 0201', 4b'0002 0211', 4b'299a 00b3', $ 82
91 4b'2949 0221', 4b'0002 0457', 4b'0002 299a', 4b'00b3 0002', $ 83
92 4b'05c7 2a15', 4b'02e7 04b3', 4b'2a8a 04c3', 4b'0231 0002', $ 84
93 4b'0076 0002', 4b'0241 0002', 4b'00a7 00d3', 4b'0015 0096', $ 85
94 4b'2b05 00a6', 4b'2c15 000e', 4b'2dc9 000f', 4b'0002 000e', $ 86
95 4b'2d0a 2b55', 4b'000f 0002', 4b'000f 0002', 4b'2a8a 0002', $ 87
96 4b'0058 0121', 4b'0002 2a8a', 4b'0002 00d8', 4b'0121 0002', $ 88
97 4b'2a8a 0603', 4b'1559 0447', 4b'0613 003b', 4b'00f1 00a6', $ 89
98 4b'2ce5 000e', 4b'2dc9 000f', 4b'0002 0251', 4b'0002 2e2a', $ 90
99 4b'2d45 2dc9', 4b'0002 00f6', 4b'0002 2e2a', 4b'00f3 2dc9', $ 91
100 4b'002d 2dc9', 4b'0002 00e6', 4b'0002 2d0a', 4b'0083 001d', $ 92
101 4b'0002 00b6', 4b'0002 00c6', 4b'0002 2fa5', 4b'3025 3085', $ 93
102 4b'30e5 3145', 4b'3295 2ed5', 4b'0437 0383', 4b'2a8a 0363', $ 94
103 4b'0457 0353', 4b'0066 0373', 4b'0447 0393', 4b'00ab 0161', $ 95
104 4b'0002 2a8a', 4b'0603 1559', 4b'0447 0613', 4b'003b 00f1', $ 96
105 4b'0002 0128', 4b'31ea 0002', 4b'01ab 0261', 4b'0002 01a8', $ 97
106 4b'31ea 0002', 4b'025b 0261', 4b'0002 0228', 4b'31ea 0002', $ 98
107 4b'026b 0261', 4b'0002 02a8', 4b'2a8a 0033', 4b'0457 0023', $ 99
108 4b'2e2a 0013', 4b'001b 0261', 4b'0002 2a8a', 4b'0033 0457', $ 100
109 4b'0023 2a8a', 4b'0033 0457', 4b'0023 2e2a', 4b'0013 0002', $ 101
110 4b'2a8a 0153', 4b'0447 0163', 4b'0002 0271', 4b'3305 0086', $ 102
111 4b'2a55 3305' ; $ 103
112 $ end member syntab
113
114 $ macros for packed format of parse table.
115 +* opt_op = .f. 1, 4, ** $ operation.
116 +* opt_parm = .f. 5, 12, ** $ parameter.
117
118 $ macros for unpacked parse table format.
vax 194 .+s32.
vax 195 +* pt_op = .f. 3, 4, **
vax 196 +* pt_parm = .f. 17, 16, **
vax 197 ..s32
119 .+s37.
120 +* pt_op = .f. 3, 4, **
121 +* pt_parm = .f. 17, 16, **
122 ..s37
utsa 229 .+s47.
utsa 230 +* pt_op = .f. 3, 4, **
utsa 231 +* pt_parm = .f. 17, 16, **
utsa 232 ..s47
123 .+s66.
124 +* pt_op = .f. 1, 4, **
125 +* pt_parm = .f. 5, 17, **
126 ..s66
127 .+s10.
128 +* pt_op = .f. 1, 18, **
129 +* pt_parm = .f. 19, 18, **
130 ..s10
131
132
133 size i(ps); $ loop index.
134
135 $ now unpack the parse table.
136 do i = ptmax/2 to 1 by -1; $ unpack each pair.
137 pt_op pt(i*2) = opt_op (.f. 1, 16, pt(i));
138 pt_parm pt(i*2) = opt_parm (.f. 1, 16, pt(i));
139 pt_op pt(i*2-1) = opt_op (.f. 17, 16, pt(i));
140 pt_parm pt(i*2-1) = opt_parm (.f. 17, 16, pt(i));
141 end do;
142
143 call purge; $ initialize tables.
144
145 macdrop(opt_op) macdrop(opt_parm)
146 end subr ptdata;
1 .=member parse
2 subr parse; $ parse source text
3 access pt;
4 size parseparm(ps); $ parse item operand
5 size parsenow(ps); $ position in parse table
6 size parseok(1); $ parse 'ok' flag.
7 size pi(ps);
8
9 $ opcodes of the parse machine.
10
11 +* po_act = 01 ** $ perform action.
12 +* po_bak = 02 ** $ restore parse.
13 +* po_err = 03 ** $ report error if failure.
14 +* po_jif = 04 ** $ jump if failure.
15 +* po_jmp = 05 ** $ jump.
16 +* po_lex = 06 ** $ test for token of given lexical type.
17 +* po_lit = 07 ** $ test for literal.
18 +* po_set = 08 ** $ set parse register.
19 +* po_sev = 09 ** $ seek zero or more instances of subpart.
20 +* po_sub = 10 ** $ seek subpart.
21 +* po_op1 = 11 ** $ user operation 1.
22 +* po_op2 = 12 ** $ user operation 2.
23 +* po_op3 = 13 ** $ user operation 3.
24 +* po_op4 = 14 ** $ user operation 4.
25 +* po_op5 = 15 ** $ user operation 5.
26
27 $ lexical type encoding used for po_lex operation parm field.
28
29 +* lexc_name = 01 ** $ name.
30 +* lexc_contok = 02 ** $ constant.
31 +* lexc_cfi = 03 ** $ control format.
32 +* lexc_dfi = 04 ** $ data format code.
33 +* lexc_filekwd = 05 ** $ attribute name in file statement.
34 +* lexc_statwd = 06 ** $ valid filestat option.
35 +* lexc_dbugtok = 07 ** $
36 +* lexc_ertok = 08 **
37 +* lexc_exprtok1 = 09 ** $
38 +* lexc_exprtok2 = 10 ** $
39 +* lexc_termtok1 = 11 ** $
40 +* lexc_termtok2 = 12 ** $
41 +* lexc_cargstk = 13 **
42 +* lexc_binop = 14 **
43 +* lexc_unop = 15 **
44
45 +* lexc_max = 15 ** $ largest lexc code.
46
47
48 $ array pca (p-arse c_ontrol a-rray) contains information to
49 $ control the parse, in particular to effect recursion within
50 $ the parse.
51
52 +* pcamax = 70 ** $ dims of -pca-
53
54 size pcaptr(ps); data pcaptr = 0;
55 size pca(ws); dims pca(pcamax); $ parse recursion stack
56
57 .+s66.
58 +* pcaret(i) = .f. 1, 10,pca(i) ** $ return field in pca
59 +* pcaparm(i) = .f. 11, 10,pca(i) **
60 +* pcatot(i) = .f. 21, 10,pca(i) **
61 ..s66
62 .+s10.
63 +* pcaret(i) = .f. 1, 10,pca(i) ** $ return field in pca
64 +* pcaparm(i) = .f. 11, 10,pca(i) **
65 +* pcatot(i) = .f. 21, 10,pca(i) **
66 ..s10
vax 198 .+s32.
vax 199 +* pcatot(i) = .f. 1, 16, pca(i) **
vax 200 +* pcaparm(i) = .f. 17, 16, pca(i) **
vax 201
vax 202 size pcaret(ps); dims pcaret(pcamax);
vax 203 ..s32
67 .+s37.
68 +* pcatot(i) = .f. 1, 16, pca(i) **
69 +* pcaparm(i) = .f. 17, 16, pca(i) **
70
71 size pcaret(ps); dims pcaret(pcamax);
72 ..s37
utsa 233 .+s47.
utsa 234 +* pcatot(i) = .f. 1, 16, pca(i) **
utsa 235 +* pcaparm(i) = .f. 17, 16, pca(i) **
utsa 236
utsa 237 size pcaret(ps); dims pcaret(pcamax);
utsa 238 ..s47
73
74 $ the operator stack opstack is used for precedence parse of
75 $ expressions. each entry consists of level and type. for
76 $ efficiency opstack is realized as two arrays rather than
77 $ fields of a entries in a single array.
78
79 +* opstackmax = 30 ** $ dimension of opstack - maximum allowed
80 size oplev(ps); dims oplev(opstackmax); $ operator level
81 size optyp(ps); dims optyp(opstackmax); $ operator type
82
83 size t(ps); $ temporary.
84 size lastlt(ps); $ lexical type of prior token.
85 size savetok(ps); $ saved token.
86 size oper(ps); $ operation code.
87
88 $ begin with first word in parse table
89 parsenow = 1; keeptok = no; go to parseon;
90
91 /parsenext/ $ advance to next parse op.
92 parsenow = parsenow + 1;
93
94 /parseon/ $ process parse operation.
95
96 parseparm = pt_parm pt(parsenow);
97
98 .+pt.
99 if pt_op pt(parsenow) = 0 then
100 textl(' op zero err') tintl('parsenow',parsenow) endl
101 call genexit; $ exit
102 end if;
103
104 if parsetrace then
105 tintl('parseok',parseok);
106 tintl('parsenow ', parsenow)
107 tintl('parseop', pt_op pt(parsenow))
108 textl(' ') textl((.s. (pt_op pt(parsenow)-1)*3+1, 3,
109 'actbakerrjifjmplexlitsetsevsubop1op2op3op4op5'))
110 tintl(' param', parseparm)
111 endl
112 end if;
113
114 ..pt
115 go to po(pt_op pt(parsenow)) in 1 to po_op5;
116
117
118 /po(po_lit)/ $ match literal given by parameter value
119
120 if (keeptok=no) call nextok; $ get next token.
121 if toklc = parseparm then $ success.
122 parseok = yes; keeptok = no; $ set flags.
123 parsenow = parsenow + 2; $ set next operation.
124 go to parseon; $ continue parse.
125 else $ failure.
126 parseok = no; $ set failure status.
127 go to parsenext; $ go to failure point.
128 end if;
129
130 /po(po_lex)/ $ find token of given lexical type
131
132 if (keeptok=no) call nextok; $ get next token.
133
134 go to lexc(parseparm) in 1 to lexc_max;
135
136 /lexc(lexc_name)/ $ seek name.
137
138 if (toklt = nametok) go to found;
139 go to notfound;
140
141 /lexc(lexc_contok)/ $ seek constant.
142
143 if(toklt >= constok) go to found;
144 go to notfound;
145
146 /lexc(lexc_cfi)/ /lexc(lexc_dfi)/ /lexc(lexc_filekwd)/
147 /lexc(lexc_dbugtok)/ /lexc(lexc_statwd)/ /lexc(lexc_ertok)/
148 $ the above lexical types have rather long routines to see if
149 $ they are 'found' or not and they rarely occur. so we will cal
150 $ a routine to check for them.
151 call pfind(t, parseparm); $ call routine.
152 if t = 0 then $ not found.
153 go to notfound;
154 elseif t = 1 then $ this is special find.
155 go to found1; $ dont hash in.
156 else $ found token.
157 go to found; $ found token.
158 end if;
159
160 /lexc(lexc_exprtok1)/ $ seek one token expression.
161
162 if (toklt^=nametok & toklt subpart.
176 end if;
177
178 $ see if binary op which continues expressin.
179 if littabl(3,toklc) then $ if binary op, expression continu
180 parsenow = parsenow + 2;
181 go to po(po_op4); $ next is xbeg.
182 end if;
183
184 $ name or constant is one token expression.
185 $ complete expr search successfully.
186 $ do a bak now.
187 pcaptr = pcaptr - 1; $ pop -pca-.
188 .+pt if (pcaptr<0) call ermey(2); $ fatal error.
189 parsenow = pcaret(pcaptr+1) + 2; $ set return point.
190 go to parseon; $ continue parse.
191
192 /lexc(lexc_termtok1)/ $ here to start term.
193
194 /* assumed order of parse ops is as follows.
195 0 lex termtok1
196 1 bak
197 2 lex termtok2
198 3 bak
199 4 jmp termlp (after seeing name, left parenthesis).
200 5 jmp fexp if .f. extractor.
201 6 jmp eexp if .e. extractor.
202 7 jmp sexp if .s. extractor.
203 8 jmp checp if .ch. extractor.
204 9 jmp pexp if left parenthesis.
205 10 jmp termfs if filestat.
206
207 the literal code is relative offset in parse table.
208
209 */
210
211 lastlt = toklt; $ save lexical type.
212
213 if (toklt>=constok) go to found; $ constant is term.
214
215 if toklc then $ if literal, see if can branch forward.
216 t = littabl(7, toklc);
217 if t then
218 parseok = yes; keeptok = no;
219 parsenow = pt_parm pt(parsenow + t);
220 go to parseon;
221 end if;
222 end if;
223
224 $ if name, accept.
225 if (toklt=nametok) go to found;
226
227 parseok = no;
228 $ here we do a -bak-.
229 pcaptr = pcaptr - 1; $ pop -pca-.
230 .+pt if (pcaptr < 0) call ermey(2); $ underflow.
231 parsenow = pcaret(pcaptr+1) + 1; $ get return point.
232 go to parseon; $ continue parse.
233
234 /lexc(lexc_termtok2)/
235
236 $ here after term starts with name or constant.
237 $ if term began with constant, it is term.
238 $ here after term starts with name. if current token is
239 $ left parenthesis, return to grammar to parse. otherwise
240 $ name is term.
241
242 if toklc = lc_lparen & lastlt = nametok then
243 parseok = yes; keeptok = no;
244 parsenow = pt_parm pt(parsenow+2); $ jmp to termlp label
245 else $ accept
246 parseok = yes;
247 pcaptr = pcaptr - 1; $ pop -pca-.
248 .+pt if (pcaptr < 0) call ermey(2); $ underflow.
249 parsenow = pcaret(pcaptr+1) + 2; $ get next operation.
250 end if;
251
252 go to parseon; $ continue parse.
253
254 /lexc(lexc_cargstk)/ $ want constant on top of -arglist-.
255 parseok = hascon ha(arglist(argptr-1));
256 parsenow = parsenow + parseok + 1; $ set next parse op.
257 go to parseon; $ continue.
258
259 /lexc(lexc_unop)/ $ want valid unary operator.
260 if (toklc = 0) go to opret; $ if not literal.
261 t = littabl(4, toklc); $ get unary operator level.
262 if t = 0 then $ not operator.
263 /opret/ $ failure return point.
264 pcaptr = pcaptr-1; $ failure is -b.
265 .+pt if (pcaptr<0) call ermey(2); $ error - underflow.
266 parsenow = pcaret(pcaptr+1) + 1; $ go to failure point.
267 parseok = (parseparm = lexc_binop); $ binop is bak from sev.
268 go to parseon; $ continue parse.
269 end if;
270
271 oper = littabl(6, toklc); $ get operator number.
272 keeptok = no; $ accept token.
273 go to setoper; $ go stack operator.
274
275 /lexc(lexc_binop)/ $ want binary operator.
276 $ now see if this was either not a binary operator or
277 $ the operator on the stack has a higher precedence. if so,
278 $ say 'not found'.
279 if (toklc = 0) go to opret; $ no literal code.
280 t = littabl(3, toklc); $ get binary operator level.
281 if (oplev(opstackp) >= t) go to opret; $ fail if so.
282 oper = littabl(5, toklc); $ get operator code.
283 keeptok = no; $ accept token.
284
285 $ now check if this is a two-token operator.
286 if toklc = lc_orsym then $ !! is .cc.
287 call nextok; $ get next token.
288 if toklc = lc_orsym then $ it is.
289 oper = op_ccat; $ set new operation code.
290 keeptok = no; $ accept operator.
291 end if;
292
293 elseif t = 4 then $ this may be <=, >=, ^=.
294 savetok = toklc; $ save last token.
295 call nextok; $ get next token.
296 keeptok = (toklc ^= lc_eqsym); $ accept equal sign only.
297 $ now determine which operator this is.
298 if savetok = lc_ltsym then
299 if (keeptok = no) oper = op_le; $ this was <=.
300 elseif savetok = lc_gtsym then
301 if (keeptok = no) oper = op_ge; $ this was >=.
302 elseif savetok = lc_notsym then
303 if (keeptok) call ermes(35); $ ^ with no =
304 else $ this is not a multiple operator.
305 keeptok = yes; $ must keep token.
306 end if;
307 end if;
308
309 /setoper/ $ stack operator.
310 countup(opstackp, opstackmax, 'opstack');
311 optyp(opstackp) = oper; $ set operation type.
312 oplev(opstackp) = t; $ set level.
313 parseok = yes; $ show success.
314 parsenow = parsenow + 2; go to parseon; $ continue.
315
316
317 /found/ $ search successful, hash in token.
318 if toklt = nametok then $ if name.
319 insnchars = toklen;
320 .+movw_env.
321 call 7nmovw$li(insnarg, tokara, tokwords); $ move words.
322 .-movw_env.
323 do t = 1 to tokwords;
324 insnarg(t) = tokara(t);
325 end do;
326 ..movw_env
327
328 call insname(t);
329 if assertfg then $ in assertion - push ptr on assert st
330 countup(assertstp, assertdim, 'assertst');
331 assertst(assertstp) = t;
332 end if;
333
334 else $ if constant.
335 cclt = toklt; $ set lexical type
336 $ unpack tokara into array of chars. cca used by cnvcon.
337 .+unpk_env.
338 call 7nunpk$li(cca, 1, tokara, 1, toklen); $ unpack token.
339 .-unpk_env.
340 do t = 1 to toklen;
341 cca(t) = .f. tokarasz+1-cs - cs*mod(t-1, tokarasz/cs), cs,
dsr 16 tokara((t-1)/(tokarasz/cs)+1); $ copy character.
343 end do;
344 ..unpk_env
345
346 ccaptr = toklen;
347 call cnvcon; $ convert constant.
348 call inscon(t); $ insert constant.
349 end if;
350
351 $ place hash code on top of arg stack
352 push(t); $ insert on stack.
353 if argptr > argmax - 20 then $ overflow of stack.
354 call ermes(65); call genexit;
355 end if;
356
357 /found1/ $ arrive at this label if do not want token hashed
358 parseok = yes; keeptok = no;
359 parsenow = parsenow + 2; go to parseon;
360
361 /notfound/
362 parseok = no;
363 go to parsenext;
364
365 /po(po_sev)/ $ seek several instances of subpart.
366
367 $ -pcaret- records where request originated
368 $ set parameters, and go seek indicated object
369 countup(pcaptr,pcamax,'pca');
370 pcatot(pcaptr) = 0;
371 pcaparm(pcaptr) = parseparm;
372 pcaret(pcaptr) = parsenow;
373 parsenow = parseparm;
374 go to parseon;
375
376 /po(po_sub)/ $ find indicated subpart.
377
378 countup(pcaptr,pcamax,'pca');
379 pcaparm(pcaptr) = 0;
380 pcaret(pcaptr) = parsenow;
381 parsenow = parseparm;
382 go to parseon;
383
384 / po(po_err) / $ report error if in failure state.
385
386 if (parseok) go to parsenext;
387
388 ermsgno = parseparm;
389 pcaptr = 0; $ since at top level, clear stack
390 parsenow = parseerrloc;
391 go to parseon;
392
393 /po(po_jif)/ $ jump if failure state.
394
395 if (parseok) go to parsenext;
396
397 /po(po_jmp)/ $ branch
398
399 parsenow = parseparm; go to parseon;
400
401 /po(po_bak)/ $ restore parse status, return from search.
402
403 $ restore parser status (effectively recursion control )
404 $ recover from completion of -find subpart- or
405 $ -find repeated instances- operation
406
407 if pcaparm(pcaptr) = 0 then $ if subpart.
408 pcaptr = pcaptr-1;
409 .+pt if (pcaptr<0) call ermey(2);
410 parsenow = pcaret(pcaptr+1) + 1 + parseok;
411 else $ restore after search for repeated instances
412 if parseok then $ continue search
413 pcatot(pcaptr) = pcatot(pcaptr) + 1;
414 parsenow = pcaparm(pcaptr);
415 else $ part not found, return instance count found
416 pcaptr = pcaptr-1;
417 .+pt if (pcaptr<0) call ermey(2);
418 parsenow = pcaret(pcaptr+1) + 1;
419 arglist(argptr) = pcatot(pcaptr+1);
420 parseok = yes;
421 end if;
422 end if;
423
424 go to parseon; $ continue with parse.
425
426 /po(po_set)/ $ set parse register.
427
428 $ setting parsereg(1) is doing an 'ok' so special-case that.
429 if .f. 1, 3, parseparm = 0 then
430 parseok = yes; $ this is 'ok'.
431 else $ normal register sets.
432 parsereg(1 + (.f. 1, 3, parseparm)) = .f. 4, 9, parseparm;
433 end if;
434
435 go to parsenext;
436
437 /po(po_op1)/ $ op1 saves parseparm in pi.
438
439 pi = parseparm;
440 go to parsenext;
441
442 /po(po_act)/ $ action sequence.
443
444 go to pa(parseparm) in 1 to parseactmax;
445
446 +* pac = go to parsenext **
447
448 +* pr(i) = parsereg(i) **
449 $ member synact
450 / pa( 1) / call gensub ( pi ); pac;
451 / pa( 2) / call gengosl ( pi ); pac;
452 / pa( 3) / call gengol ( pi ); pac;
453 / pa( 4) / call genif ( pi ); pac;
454 / pa( 5) / call genwhil ( pi ); pac;
455 / pa( 6) / call genuntl ( pi ); pac;
456 / pa( 7) / call gendo ( pi ); pac;
457 / pa( 8) / call genend; pac;
458 / pa( 9) / call gensiz; pac;
459 / pa( 10) / call gendim; pac;
460 / pa( 11) / call gendat ( pi ); pac;
461 / pa( 12) / call genns; pac;
462 / pa( 13) / call genacc; pac;
463 / pa( 14) / call genreal; pac;
464 / pa( 15) / call gencall ( pi ); pac;
465 / pa( 16) / call gengoby; pac;
466 / pa( 17) / call genret; pac;
467 / pa( 18) / go to checkcexp;
468 / pa( 19) / call gencont ( pi ); pac;
469 / pa( 20) / call genquit; pac;
470 / pa( 21) / call genasin ( pr ( 7 ) , pr ( 5 ) ); pac;
471 / pa( 22) / call geniost ( pi ); pac;
472 / pa( 23) / call geniotr; pac;
473 / pa( 24) / call genioit ( pi ); pac;
474 / pa( 25) / call gencfi ( pi ); pac;
475 / pa( 26) / call gendfi ( pi ); pac;
476 / pa( 27) / call genfile; pac;
477 / pa( 28) / call gentrace ( pr ( 4 ) , 8 ); pac;
478 / pa( 29) / call gentrace ( pr ( 4 ) , 7 ); pac;
479 / pa( 30) / call gentrace ( pr ( 4 ) , pr ( 3 ) + 1 ); pac;
480 / pa( 31) / call gentrace ( pr ( 4 ) , pr ( 3 ) ); pac;
481 / pa( 32) / call gensert ( pi ); pac;
482 / pa( 33) / call gendebug ( 0 , 0 ); pac;
483 / pa( 34) / call gendebug ( 0 , 1 ); pac;
484 / pa( 35) / call gendebug ( 1 , 1 ); pac;
485 / pa( 36) / call gendebug ( dparm , dval ); pac;
486 / pa( 37) / keeptok = 1; pac;
487 / pa( 38) / call genextr ( pi ); pac;
488 / pa( 39) / call ermet; pac;
489 $ end member synact
490
491 /po(po_op2)/ $ get bronlit argument, searches literal.
492
493 $ this action implements the branch on literal feature in the
494 $ grammar. the next token in input is examined. if it has been
495 $ assigned a number in the given class, the grammar table
496 $ pointer, parsenow, is advanced by that number, else the token
497 $ is simply returned and parnsing proceeds with the next item.
498
499
500 parseok = no; $ assume not found.
501 if (keeptok=no) call nextok; $ get next token.
502 if (toklc = 0) go to parsenext; $ normal token.
503 t = littabl(parseparm, toklc); $ if literal.
504 if t then $ will take branch.
505 parseok = yes; keeptok = no; $ show success.
506 parsenow = pt_parm pt(1 + (parsenow+t)); $ set next op.
507 go to parseon; $ continue parse.
508 end if;
509
510 go to parsenext; $ else continue with next.
511
512 /po(po_op3)/
513
514 $ this action pops opstack and calls arith or marith with
515 $ appropriate parameter
516
517
518 .+pt.
519 if opstackp = 1 then
520 call ermey(6);
521 end if;
522 ..pt
523
524 opstackp = opstackp - 1;
525 t = optyp(opstackp+1);
526 if parseparm = 1 then call arith(t);
527 else call marith(t); end if;
528 go to parsenext;
529
530 /po(po_op4)/ $ stack expression.
531
532 countup(opstackp, opstackmax, 'opstack');
533 oplev(opstackp) = 0; optyp(opstackp) = 0;
534 go to parsenext;
535
536
537 /po(po_op5)/ $ unstack expression.
538
539 .+pt.
540 if oplev(opstackp) then
541 call ermey(4);
542 end if;
543
544 if opstackp = 0 then
545 call ermey(5);
546 end if;
547 ..pt
548
549 opstackp = opstackp - 1;
550 go to parsenext;
551
552
553 /checkcexp/ $ here to check for expression in constants.
554
555 if parsereg(6) then $ must be safe constant.
556 if (hascon ha(arglist(argptr-1))) go to parsenext; $ ok.
557 else $ want any constant.
558 if var ha(arglist(argptr-1)) then $ is variable or constant.
559 if (const voa(ep ha(arglist(argptr-1)))) go to parsenext;
560 end if;
561 end if;
562
563 call ermes(42); $ give error message
564 arglist(argptr-1) = ha_1; $ reset value
565
566 go to parsenext;
567
568 end subr parse;
1 .=member pfind
2 subr pfind(ret, lexc); $ do find actions for some classes.
3 size ret(ps); $ 0=notfound, 1=found1, 2=found.
4 size lexc(ps); $ lexical class.
5 size keycode(ps); $ function which returns code from string.
6 size i(ps); $ do loop variable.
7
8 go to lexc(lexc) in lexc_cfi to lexc_ertok;
9
10 /lexc(lexc_cfi)/ $ seek control format code.
11
12 if toklt = strtok then
13 iokey = 5; $ global passed to gencfi
14 go to found; $ hash in sds
15 end if;
16
17 if (toklt ^= nametok) go to notfound;
18 if(toklen > keylenmax) go to notfound;
19 call psdstok;
20 iokey = keycode(sdsnamstr, $ control codes follow.
21 '04=x 02=skip 03=page 01=column ');
22 if (iokey) go to found1;
23 go to notfound;
24
25 /lexc(lexc_dfi) / $ seek data format item, process initial -n-.
26
27 if (toklt ^= nametok) go to notfound;
28 if (toklen > 3) go to notfound;
29 $ convert token to sds form, put in iosds.
30 call psdstok;
31 ionameflag = no;
32 if .ch. 1, sdsnamstr = 1rn then $ if -n- type format
33 ionameflag = yes;
34 do i = 2 to toklen;
35 .ch. i-1, sdsnamstr = .ch. i, sdsnamstr; end do;
36 slen sdsnamstr = toklen-1;
37 toklen = toklen - 1;
38 end if;
39
40 iokey = 0;
41 if (toklen=0) go to notfound;
42 iolistmode = no;
43 if .ch. slen sdsnamstr, sdsnamstr = 1rl then $ if list mode
44 iolistmode = yes;
45 slen sdsnamstr = slen sdsnamstr - 1;
46 toklen = toklen - 1;
47 if (toklen = 0) go to notfound;
48 end if;
49
50 iokey = keycode(sdsnamstr, $ string gives format codes
51 '01=a 02=b 03=e 04=f 05=i 06=r ');
52 if (iokey) go to found1; go to notfound;
53
54 /lexc(lexc_filekwd)/
55
56 $ seek valid attribute for 'file' statement.
57 $ convert token into sds format in sdsnamstr.
58 if (toklt^=nametok) go to notfound;
59 if (toklen>keylenmax) go to notfound; $ if token too long.
60 call psdstok;
61 iokey = keycode(sdsnamstr, $ next line gives attribute codes
62 '01=title 02=access 03=linesize ');
63 if (iokey) go to found1; go to notfound;
64
65 /lexc(lexc_dbugtok)/
66
67 $ seek parameter for 'debug' statement
68 if (toklt ^= nametok ! toklen > keylenmax) go to notfound;
69 call psdstok;
70 dparm = keycode(sdsnamstr, $ string gives parameters
71 '02=nolimit 04=nobyte 05=byte 06=noflow 07=flow 08=nostores
72 09=stores 10=noentry 11=entry ');
73 dval = .f. 1, 1, dparm; dparm = .f. 2, ps, dparm; $ split
74 if (dparm) go to found1; go to notfound;
75
76 /lexc(lexc_statwd)/
77
78 $ seek 'filestat' attribute
79 if (toklt^=nametok ! toklen>keylenmax) go to notfound;
80 call psdstok;
81 iokey = keycode(sdsnamstr, $ string gives filestat codes.
82 '01=column 02=end 03=error 03=err 04=ignore 05=access 06=linesize '
83 !! '07=stream ');
84 if (iokey) go to found1; go to notfound;
85
86 /lexc(lexc_ertok)/ $ skip to end of statement on error.
87 $ this lexical class is used to recover from an error.
88 $ it will skip forward to next semicolon unless the error
89 $ occured in an expression in an -if- in which case it
90 $ will scan for either a 'then' or a semicolon.
91 if cstype csa(csaptr) = cstype_if then $ last opener was -if-.
92 $ if this was simple -if-, end simple statement.
93 if csiftype csa(csaptr) = csiftype_sif then
94 call genif(4); $ end the simple statement.
95 elseif csiftype csa(csaptr) = 0 then $ in expression.
96 if toklc = lc_then then $ found 'then'.
97 push(ha_1); call genif(2); $ dummy expression.
98 go to notfound; $ terminates search for token.
99 elseif toklc = lc_semicolon then $ this was simple -if-.
100 push(ha_1); call genif(3); call genif(4); $ null sta
101 go to notfound; $ terminates search for token.
102 end if;
103 end if;
104 end if;
105
106 $ if normal case, only semicolon ends.
107 if (toklc = lc_semicolon) go to notfound; $ terminates search.
108 go to found1; $ else continue search.
109
110
111 /found/ ret = 2; return;
112 /found1/ ret = 1; return;
113 /notfound/ ret = 0; return;
114
115 end subr pfind;
1 .=member psdstok
2 subr psdstok; $ convert token into sds form
3 $ convert token into sds form, put result in -sdsnamstr-.
4 $ (this auxiliary routine called from -pfind-.)
5 size i(ps); $ do loop index
6 slen sdsnamstr = toklen;
7 do i = 1 to tokwords;
8 .f. nameorg - i*ws, ws, sdsnamstr = tokara(i);
9 end do;
10
11 end subr psdstok;
1 .=member keycode
2 fnct keycode(key, codes); $ seek -key- in -codes-, get value.
3 $ -key- and -codes- are strings. entries of -codes- have the
4 $ form 'nn=str' where nn is integer and str is code. if
5 $ -key- corresponds to one of the entries, return numeric
6 $ value of assigned code nn; otherwise return 0.
7 size key(sds(keylenmax)); $ key for which code desired
8 size codes(sds(120)); $ string of codes
9 size s(namsz); $ delimited form of key
10 size keycode(ps); $ function vlaue.
11 size i(ps); $ do loop index for conversion.
12
13 keycode = 0; $ assume key not present.
14 if (slen key > keylenmax) return; $ too large, cannot be present
15 sorg s = nameorg; $ set string origin field.
16 slen s = slen key+2;
17 .ch. 1, s = 1r=; .ch. slen s, s = 1r ; $ enter delimiters.
18 do i = 1 to slen key;
19 .ch. i+1, s = .ch. i, key; end do;
20 i = s .in. codes;
21 if (i=0) return;
22 keycode = digofchar((.ch.i-2,codes))*10
23 + digofchar((.ch.i-1,codes));
24
25 end fnct keycode;
1 .=member gtoflo
2 subr gtoflo(ipoin, lim, iword); $ 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
mgfc 14 .+s10 error_s10; $ give s10 error character.
9 textl(error_notice) textl('array ') textl(iword)
10 textl(' overflowed: ')
11 tintl('pointer ',ipoin) tintl(' limit',lim) endl
12 terml(no); $ done with terminal file output
13 call genexit; $ terminate
14 end subr gtoflo;
1 .=member nextok
2 subr nextok; $ get next token
3 $ obtain next token from input stream, unless -keeptok- is on,
4 $ in which case return prior token. if -echoline- on, then
5 $ do nothing but list the last read if it has not yet been
6 $ listed (this action requested as part of error report).
7 $ check for 'special' period-delimited tokens,
8 $ such as '.voadump.' which requests symbol table dump, etc.
9 $ set -toklc- to literal code, -toklt- to lexical type,
10 $ -toklen- to length of token in characters,
11 $ -tokwords- to number of words in
12 $ token, and insert token in array -tokara-.
13 size i(ps); $ do loop index
14 size tokhdr(ws); $ token descriptor word
15 size toktrace(1); data toktrace=0; $ on to trace tokens read
16 size titletext(.sds. (cpw*wpc)); $ text of title directive.
17 size new(voasz); $ voa item built by list code change.
18
19 +* tokread1(wd) = $ get one word from token buffer/file
20 if tokrbufp >= tokrbuflim then
21 call rdrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
22 tokrbufp=0;
23 end if;
24 tokrbufp = tokrbufp + 1; wd = tokrbuf(tokrbufp);
25 **
26
27 +* tokread(ara, wds) = $ read wds words into ara(1) to ara(wds).
28 size zzzi(ps); $ do loop index.
29 if (wds+tokrbufp) >= tokrbuflim then $ if would empty buf,
30 do zzzi = 1 to wds;
31 tokread1(ara(zzzi)); end do;
32 else
33 .+movea_env.
34 call 7nmova$li(ara, 1, tokrbuf, tokrbufp+1, wds); $ copy.
35 .-movea_env.
36 do zzzi = 1 to wds;
37 ara(zzzi) = tokrbuf(tokrbufp + zzzi); end do;
38 ..movea_env
39 tokrbufp = tokrbufp + wds;
40 end if;
41 **
42
43 keeptok = yes;
44 /rdtok/
45 tokread1(tokhdr); $ read token descriptor
46 toklt =tokrtyp tokhdr; $ get lexical type/code
47 toklen = tokrlen tokhdr; $ no ov chars
48 toklc = tokrlc tokhdr; $ literal code
49 tokwords = (toklen-1)/cpw + 1; $ no of words
50 if (toklen = 0) tokwords = 0;
51 if toktrace then
52 tintl(' token, lt',toklt) tintl(' len',toklen)
53 tintl(' lc', toklc) endl
54 end if;
55 go to t(toklt) in 1 to tokreof;
56 /t(listcontroltok)/ $ .=list directive or change.
57 if toklen = 2 then $ change in list input mode.
58 $ save new value in listswnew until next line read.
59 listswnew = toklc;
60 elseif toklen = 1 then $ change in code list mode.
61 $ must pass on changed code listing option to asm phase.
62 $ build voa op with opcode = op_list,
63 $ inp1 = 1 to mark as listing change and inp2 = new option.
64 $ if voptr ^= voafnct then $ avoid making first entry in voa.
65 $ new = 0; opb new = yes; opcode new = op_list;
66 $ inp1 new = 1; inp2 new = toklc;
67 $ voa(voptr) = new; voaup;
68 $ end if;
69 listingcode = toklc; $ pass in voa header frame.
70 elseif toklen = 3 then $ change titling mode
71 listauto = toklc;
72 end if;
73 go to rdtok;
74 /t(listejecttok)/ $ .=eject
75 if listsw then $ if listing on, do eject action.
76 call lstlin; $ if listing input.
77 ejectlp(toklen);
78 end if;
79 go to rdtok;
80 /t(listtitletok)/ $ .=title
81 if (listsw) call lstlin; $ if listing input.
82 if toklen then $ if title not null, read it.
83 tokread(tokara, tokwords);
84 sorg titletext = 1 + .sds. toklen;
85 do i = 1 to tokwords;
86 .f. sorg titletext - i*ws, ws, titletext = tokara(i);
87 end do;
88 end if;
89 sorg titletext = 1 + .sds. toklen;
90 slen titletext = toklen;
91 if (listauto) subtitling = no; $ use main title in auto mode
92 if (listsw) call stitlr(subtitling, titletext);
93 if subtitling & listsw then
94 ejectl; $ eject if listing and is subtitle.
95 end if;
96 subtitling = yes;
97 go to rdtok;
98
99 /t(7)/ /t(9)/ /t(10)/ /t(11)/ /t(13)/
100 /t(15)/ /t(16)/ /t(17)/ /t(18)/ /t(19)/ /t(20)/
101 /t(21)/ /t(22)/ /t(23)/ /t(24)/ /t(25)/ /t(26)/
102 call ermey(9);
103
104 /t(tokrcard)/ $ card image being transmitted
105 if (listsw) call lstlin; $ if listing input.
106 listsw = listswnew; $ set if new value, or copy if old.
107 ncards = ncards + toklc; proclineno = proclineno + toklc;
108 cardlisted = no; $ new card read, not yet listed
109 listwdsp = tokwords; $ save length
110 if tokwords then $ if need to read card image.
111 tokread(listwds, tokwords); $ read card image.
112 end if;
113 go to rdtok; $ get next token
114
115 /t(tokreof)/ $ end-of-file token
116 if (listsw) call lstlin; $ if listing input.
117 exitcode = 0; call genexit; $ else exit, done
118
119 /t(nametok)/
120 /t(spectok)/
121 /t(pdotok)/
122 /t(dectok)/
123 /t(strtok)/
124 /t(bittok)/
125 /t(rztok)/
126 /t(sstok)/
127 /t(realtok)/
dso 108 .+s10 tokara(2) = blankword;
vax 207 .+s32 tokara(2) = blankword;
128 .+s37 tokara(2) = blankword;
utsa 239 .+s47 tokara(2) = blankword;
129 if toklen <= cpstr then
130 tokara(1) = blankword;
131 tokrval tokara(1) = tokrval tokhdr;
132 else
133 tokread(tokara, tokwords);
134 end if;
135 if toktrace then
136 textl('token = ')
137 do i = 1 to tokwords;
138 wordl(tokara(i))
139 end do;
140 endl
141 end if;
142 lexlist(lexlistptr+1) = tokara(1); $ save token
143 lexleng(lexlistptr+1) = toklen; $ save token length.
144 lexlistptr = (lexlistptr+1) & (lexlistmax-1);
dso 109 .+s10 lexlist(lexlistptr+1) = tokara(2); $ extra word for s10.
dso 110 .+s10 lexlistptr = (lexlistptr+1) & (lexlistmax-1);
vax 208 .+s32 lexlist(lexlistptr+1) = tokara(2); $ save extra word for s32
vax 209 .+s32 lexlistptr = (lexlistptr+1) & (lexlistmax-1);
145 .+s37 lexlist(lexlistptr+1) = tokara(2); $ save extra word for s37
utsa 240 .+s47 lexlist(lexlistptr+1) = tokara(2); $ save extra word for s47
146 .+s37 lexlistptr = (lexlistptr+1) & (lexlistmax-1);
utsa 241 .+s47 lexlistptr = (lexlistptr+1) & (lexlistmax-1);
147 if(toklt ^= pdotok) go to notapdo;
148
149 $ check for special directive to parser, or machine parameter
150 $ which must be replaced by value.
151
152 if (toklc = 0) go to notapdo;
153 i = littabl(9, toklc);
154 if (i=0) go to notapdo;
155 go to l(i) in 1 to 13;
156
157 / l(1) / $ .voadump.
158 / l(2) / $ .voapart.
159 call tabdump(1, voptr, 2-i); $ dump tables.
160
161 / l(3) / / l(4) / $ unused.
162 go to rdtok;
163
164 / l( 5) / $ .contr. - start listing converted constant values.
165 $ this flag examined by routine cnvcon.
166 docontrace = yes; go to rdtok;
167
168 / l( 6) / $ .nocontr. - terminate list of converted constants.
169 docontrace = no; go to rdtok;
170
171 / l( 7) / $ .toktr. - list tkokens as read.
172 toktrace = yes; go to rdtok;
173
174 / l( 8) / $ .notoktr. - terminate list of tokens as read.
175 toktrace = no; go to rdtok;
176
177 / l(9)/ / l(10) / / l(11) / / l(12) / / l(13) /
178 $ convert target mahchine parameters to value.
179 $ warning. code currently assumed that tokara(1) can hold number
180 $ of characters (now 2) needed to specify machine paramater
181 $ value.
182 tokara(1) = tmtokara(i-8);
183 toklen = 2; toklt = dectok; toklc = 0;
184 $ thus substituting value for operator originally present.
185
186 $ is not special token, pass on
187 /notapdo/
188 if savetoks < 5 then $ save token in csatok for opener
189 savetoks = savetoks + 1;
190 csatokptr = csatokptr + 1;
191 csatok(csatokptr) = tokara(1);
192 end if;
193
194 if toklt = realtok then $ this is real token.
195 $ check if supported on this machine.
196 if targetmachine = m11 then $ not supported.
197 call ermes(69); $ print error.
198 /unstok/ $ here to fix unsupported constants.
199 tokara(1) = blankword; $ start to set to 1.
200 .f. ws+1-cs, cs, tokara(1) = 1r1; $ set to one.
201 toklen = 1; toklt = dectok; $ set length and type.
202 end if;
203 end if;
204
205 if toklt = sstok then $ this is special string token.
206 $ see if target machine supports it.
207 if targetmachine ^= m11 then $ only pdp-11 supports it now.
208 call ermes(9); $ print error message.
209 go to unstok; $ convert it to integer 1.
210 end if;
211 end if;
212
213 end subr nextok;
1 .=member lstlin
2 subr lstlin; $ list input line.
3 size i(ps); $ loop index.
4
5 if cardlisted=no then $ if need to list.
6 cardlisted = yes;
rbko 10 intl(proclineno) skipl(3)
8 do i = 1 to listwdsp; $ list each word.
9 wordl(listwds(i));
10 end do;
11 endl
12 end if;
13
14 end subr lstlin;
1 .=member cnvcon
2 subr cnvcon; $ convert constant.
3 $ convert 'safe' constants to their internal (binary) form.
4
5 size i(ps);
6 $ note - size of rcv should be rlsz (or .rs.) when
7 $ .rs. pararameter installed.
8 size rcv(ws); $ real constant built here
9 size longint(ws); $ for integers near word size.
10 size longresult(szmax-ws); $ build long constants here
11 $ size is less than szmax so that temporary generated for
12 $ longresult * 10 has size no greater than szmax.
13
14 size c(ps); $ holds character, then numeric val
15 +* charin(c) = ccaptr = ccaptr+1; cca(ccaptr) = c; ** $ to add
16 size stringlen(ps); $ length of string
17 size charsrem(ps); $ no of chars left in word
18 size sdskel(ws); $ skeleton for self-def strings built up heree
19 size sdlast(ps); $ no of chars used in last word of str
20 size sdleft(ps); $ no of remaining char posns in last wd
21 size sddpos(ps); $ position when moving desc into val of sd
22 size cpsdd(ps); $ no. of characters in slen,sorg fields.
23 size j(ps); $ do loop index.
24 size bitwidth(ps); $ no. of bits per char in bit constant.
25 size bytenow(ps); $ current bit value.
26 size expval(ws); $ real exponent value.
27
28 ccvalptr = 1; $ assume 1 word constant
29 ccval(1) = 0;
30 ccsyze = 1; $ will return 0 if can not convert.
31 stringlen = ccaptr;
32 ccnchars = 0;
33 go to l(cclt) in 1 to toktypes;
34
35 / l(realtok) / $ real constant.
36 ccsyze = rlsz;
37 if safeconst(realtok) then $ if safe, convert real.
38 call 7nvnum$io(cca, ccaptr, expval);
ldsd 24 if cca(ccaptr+2) then $ if invalid.
ldsd 25 call ermes(10);
ldsd 26 ccsyze = 1; $ take as zero.
ldsd 27 go to converted;
ldsd 28 end if;
39 if cca(ccaptr+3) > 1 then $ if point present, adjust exponent.
40 expval = expval - (cca(ccaptr+3) - 1);
41 end if;
42 call 7ncefr$io(rcv, cca, ccaptr, expval);
ldsd 29 if cca(ccaptr+2) then $ if invalid.
ldsd 30 call ermes(10);
ldsd 31 ccsyze = 1; $ take as zero.
ldsd 32 go to converted;
ldsd 33 end if;
43 do i = 1 to rlsz/mws;
44 ccval(i) = .f. rlsz+1-i*mws, mws, rcv;
45 end do;
46 go to converted;
47 else
48 ccvalptr = (ccaptr-1)/cpw + 1;
49 ccnchars = ccaptr;
50 go to endofstr;
51 end if;
52
53 / l(nametok) /
54 / l(spectok) /
55 / l(pdotok) /
56 /l(7)/ /l(9)/ /l(10)/ /l(11)/ /l(13)/
57 call ermey(8);
58
59 /l(bittok)/
60 bitwidth = digofchar(cca(1));
61 ccsyze = 0;
62 do i = ccaptr-1 to 4 by -1;
63 c= cca(i); if (c = 1r ) cont do;
64 if c >= 1r0 & c <= 1r9 then $ is a digit.
65 bytenow = digofchar(c); $ get value.
66 else $ must be hex a-f.
67 bytenow = c - 1ra + 10; $ get value.
68 end if;
69
70 if ccsyze+bitwidth <= ws then
71 .f. ccsyze+1, bitwidth, ccval(1) = bytenow;
72 else
73 if ccsyze <= ws then
74 longresult = ccval(1);
75 end if;
76 do j = 1 to bitwidth;
77 .f. ccsyze+j, 1, longresult = .f. j, 1, bytenow;
78 end do;
79 end if;
80 ccsyze = ccsyze + bitwidth;
81 end do;
82 if ccsyze <= ws then
83 ccsyze = .fb. ccval(1);
84 else
85 ccsyze = .fb. longresult;
86 if ccsyze <= ws then
87 ccval(1) = .f. 1, ws, longresult;
88 end if;
89 end if;
90 if (ccsyze = 0) ccsyze = 1;
91 if (ccsyze > ws) go to packlong;
92 go to converted;
93
94 /packlong/
95 ccvalptr = (ccsyze-1) / ws;
96 do i = 0 to ccvalptr;
97 ccval(ccvalptr+1-i) = .f. 1+i*ws, ws, longresult;
98 end do;
99 ccvalptr = ccvalptr + 1;
100 go to converted;
101
102 / l(dectok) /
103 do i = 1 to ccaptr; $ decimal conversion
104 ccsyze = .fb. ccval(1);
105 .+s66.
106 if (ccsyze > 44) go to largeint;
107 $ the above machine dependent command is the result of the
108 $ chintzy integer multiply on the 6600.
109 .-s66.
110 $ on a better target
111 $ machine, replace the condition with the machine independent
112 $ (ccsyze>(ws-4)) since allow 4 bits to multiply by 10.
113 if (ccsyze>(ws-4)) go to largeint;
114 ..s66
115 ccval(1) = ccval(1) * 10 + digofchar(cca(i)); $ machine depe
116 end do;
117 ccsyze = .fb. ccval(1);
118 if (ccsyze=0) ccsyze = 1;
119 go to converted;
120 /largeint/
121 longint = ccval(1);
122 do i = i+1 to ccaptr;
123 ccsyze = .fb. longint;
124 if (ccsyze > (mws-3)) go to toobig;
125 .-s66 longint = longint * 10 + digofchar(cca(i));
126 .+s66. $ on s66, do via shift due to limited range
127 $ of multiply.
128 longint = longint*8 + longint*2 + digofchar(cca(i));
129 ..s66
130 end do;
131 ccsyze = .fb. longint;
132 ccval(1) = longresult; ccvalptr = 1;
133 go to converted;
134
135
136 /toobig/
137 call ermes(13);
138 ccsyze = 1; ccval(1)=0; ccvalptr=1; go to converted;
139
140
141 / l(strtok) /
142 ccnchars = stringlen;
143 if safeconst(strtok)=no then $ if should not convert,
144 if ccaptr=0 then $ if null string.
145 ccsyze=0;
146 ccsyze = mws*((msl+mso+mws-1)/mws);
147 go to converted; end if;
148 ccsyze = ((ccaptr*mcs + msl + mso + mws-1)/mws)*mws;
149 ccvalptr = (ccaptr-1)/cpw + 1;
150 go to endofstr;
151 end if;
utsa 242
utsa 243 .+s37 if (ebcascoption) call ebcasc;
152
153 sdskel = 0; $ descriptor build up here
utsb 1 .f. 1, msl, sdskel = ccaptr; $ no of chars in string
155 sdlast = ccaptr - cpw*(ccaptr/cpw); $ position of last char in wd
156 $ cpsdd is number of characters that could be held in sorg,slen
157 $ fields. at present, it is assumed that (.sl.+.so.) is
158 $ multiple of .cs. .
159 cpsdd = (msl+mso)/mcs;
160 if sdlast=0 then sdlast = cpw;end if;
161 sdleft = cpw - sdlast; $ remaining chars in last word
162 $ now pad with zeros if necessary
163 if sdleft > cpsdd then
164 do i = 1 to sdleft-cpsdd; charin(0); end do;
165 else if sdleft < cpsdd then
166 do i = 1 to (sdleft + (cpw-cpsdd) ); charin(0); end do;
167 end if ;
168 end if;
utsb 2 .f. msl+1, mso, sdskel = (ccaptr + cpsdd) * cs + 1 ;
170 sddpos = cpsdd*cs + 1; $ put descriptor val in string rep
171 while(sddpos>1);
172 sddpos = sddpos - cs; $ move to next char pos
173 charin( (.f. sddpos, cs, sdskel) );
174 end while;
175 ccsyze = mws*((ccaptr*mcs + mws-1)/mws);
176 ccvalptr = (ccaptr-1)/cpw + 1;
177 go to endofstr;
178
179
180 / l(rztok) /
181 if safeconst(rztok) then $ if should convert.
utsa 244 .+s37 if (ebcascoption) call ebcasc;
182 charsrem = ((ccaptr+cpw-1)/cpw) * cpw - ccaptr;
183 ccaptr = charsrem + stringlen;
184 if (ccaptr = 0) go to converted; $ this is null string.
185 do i = 0 to stringlen-1;
186 cca(ccaptr-i)=cca(stringlen-i);
187 end do;
188 do i = 1 to charsrem;
189 cca(i) = 0;
190 end do; $ insert leading zero
191 end if;
192
193 / l(sstok) /
194 ccnchars = stringlen;
195 if (ccaptr=0) go to converted; $ if null, return 0.
196 ccsyze = ccnchars * mcs; $ assume r-type.
197 if (cclt = sstok) ccsyze = mws*((ccnchars+2)/3); $ rad-50 on s11
198 ccvalptr = (ccaptr -1)/cpw + 1;
199 /endofstr/
200 .+pack_env call 7npack$li(ccval, 1, cca, 1, ccaptr); $ if fast pack
201 .-pack_env call linepak(ccval, cca, ccaptr);
202 /converted/
203 if docontrace then
204 tintl(' type',cclt)
205 tintl('len',ccaptr) tintl('bits',ccsyze)
206 tintl('words',ccvalptr) endl
207 call dumpaq(' converted constant ', ccval, 1, ccvalptr);
208 end if;
209 macdrop(charin)
210 end subr cnvcon;
utsa 245 .+s37.
utsa 246 subr ebcasc; $ convert from ebcdic to ascii
utsa 247 $ convert character string data in cca from ebcdic to ascii.
utsa 248 $ the conversion table is that used by cdc in the 8-bit subroutine
utsa 249 $ package and is used to write ebcdic tapes at nyu. it agrees with
utsa 250 $ values used by dec for vms, except vms map takes ascii to be 7-bit
utsa 251 $ code.
utsa 252 size i(ps);
utsc 8 size ctlc(cs);
utsa 253 size ebcasctab(.ws.); dims ebcasctab(256);
utsa 254 data ebcasctab =
utsa 255 4b'00', 4b'01', 4b'02', 4b'03', 4b'9c', 4b'09', 4b'86', 4b'7f',
utsa 256 4b'97', 4b'8d', 4b'8e', 4b'0b', 4b'0c', 4b'0d', 4b'0e', 4b'0f',
utsa 257 4b'10', 4b'11', 4b'12', 4b'13', 4b'9d', 4b'85', 4b'08', 4b'87',
utsa 258 4b'18', 4b'19', 4b'92', 4b'8f', 4b'1c', 4b'1d', 4b'1e', 4b'1f',
utsa 259 4b'80', 4b'81', 4b'82', 4b'83', 4b'84', 4b'0a', 4b'17', 4b'1b',
utsa 260 4b'88', 4b'89', 4b'8a', 4b'8b', 4b'8c', 4b'05', 4b'06', 4b'07',
utsa 261 4b'90', 4b'91', 4b'16', 4b'93', 4b'94', 4b'95', 4b'96', 4b'04',
utsa 262 4b'98', 4b'99', 4b'9a', 4b'9b', 4b'14', 4b'15', 4b'9e', 4b'1a',
utsa 263 4b'20', 4b'a0', 4b'a1', 4b'a2', 4b'a3', 4b'a4', 4b'a5', 4b'a6',
utsa 264 4b'a7', 4b'a8', 4b'5b', 4b'2e', 4b'3c', 4b'28', 4b'2b', 4b'21',
utsa 265 4b'26', 4b'a9', 4b'aa', 4b'ab', 4b'ac', 4b'ad', 4b'ae', 4b'af',
utsa 266 4b'b0', 4b'b1', 4b'5d', 4b'24', 4b'2a', 4b'29', 4b'3b', 4b'5e',
utsa 267 4b'2d', 4b'2f', 4b'b2', 4b'b3', 4b'b4', 4b'b5', 4b'b6', 4b'b7',
utsa 268 4b'b8', 4b'b9', 4b'7c', 4b'2c', 4b'25', 4b'5f', 4b'3e', 4b'3f',
utsa 269 4b'ba', 4b'bb', 4b'bc', 4b'bd', 4b'be', 4b'bf', 4b'c0', 4b'c1',
utsa 270 4b'c2', 4b'60', 4b'3a', 4b'23', 4b'40', 4b'27', 4b'3d', 4b'22',
utsa 271 4b'c3', 4b'61', 4b'62', 4b'63', 4b'64', 4b'65', 4b'66', 4b'67',
utsa 272 4b'68', 4b'69', 4b'c4', 4b'c5', 4b'c6', 4b'c7', 4b'c8', 4b'c9',
utsa 273 4b'ca', 4b'6a', 4b'6b', 4b'6c', 4b'6d', 4b'6e', 4b'6f', 4b'70',
utsa 274 4b'71', 4b'72', 4b'cb', 4b'cc', 4b'cd', 4b'ce', 4b'cf', 4b'd0',
utsa 275 4b'd1', 4b'7e', 4b'73', 4b'74', 4b'75', 4b'76', 4b'77', 4b'78',
utsa 276 4b'79', 4b'7a', 4b'd2', 4b'd3', 4b'd4', 4b'd5', 4b'd6', 4b'd7',
utsa 277 4b'd8', 4b'd9', 4b'da', 4b'db', 4b'dc', 4b'dd', 4b'de', 4b'df',
utsa 278 4b'e0', 4b'e1', 4b'e2', 4b'e3', 4b'e4', 4b'e5', 4b'e6', 4b'e7',
utsa 279 4b'7b', 4b'41', 4b'42', 4b'43', 4b'44', 4b'45', 4b'46', 4b'47',
utsa 280 4b'48', 4b'49', 4b'e8', 4b'e9', 4b'ea', 4b'eb', 4b'ec', 4b'ed',
utsa 281 4b'7d', 4b'4a', 4b'4b', 4b'4c', 4b'4d', 4b'4e', 4b'4f', 4b'50',
utsa 282 4b'51', 4b'52', 4b'ee', 4b'ef', 4b'f0', 4b'f1', 4b'f2', 4b'f3',
utsa 283 4b'5c', 4b'9f', 4b'53', 4b'54', 4b'55', 4b'56', 4b'57', 4b'58',
utsa 284 4b'59', 4b'5a', 4b'f4', 4b'f5', 4b'f6', 4b'f7', 4b'f8', 4b'f9',
utsa 285 4b'30', 4b'31', 4b'32', 4b'33', 4b'34', 4b'35', 4b'36', 4b'37',
utsa 286 4b'38', 4b'39', 4b'fa', 4b'fb', 4b'fc', 4b'fd', 4b'fe', 4b'ff';
utsa 287
utsa 288 do i = 1 to ccaptr;
utsc 9 if ebcascoption=2 then $ if want folded to lower case.
utsc 10 cca(i) = ctlc(cca(i));
utsc 11 end if;
utsa 289 cca(i) = ebcasctab(cca(i)+1);
utsa 290 end do;
utsa 291
utsa 292 end subr ebcasc;
utsa 293 ..s37
1 .=member inscon
2 subr inscon( conhc); $ add constant to ha
3
4 $ this routine returns the ha-index of a constant, adding the
5 $ constant to the ha (and voa) if not yet present.
6 $ ha-index is returned via conhc. inputs are global and are
7 $ ccsyze - no of bits in constant(its size)
8 $ we use 'add the hash' technique to resolve ha collisions
9
10
11 size conhc(ps); $ hash index returned
12 size hcode(ws); $ computed hash code
13 size j(ps); $ ha-index of entry begin examined
14 size i(ps); $ do loop temporary
15 size new(voasz); $ for building new voa entry
16 size vb(ps); $ save position in val array
17
18 hcode = ccval(1);
19 do i = 2 to ccvalptr;
20 hcode = hcode .exor. ccval(i); end do;
21
22 hcode = .f. 1, ws/2, hcode .exor. .f. ws/2+1, ws/2, hcode;
23 haprobe(j, hcode); $ search the ha
24 if (hainuse ha(j) = no) haquit; $ empty slot found
25 if ((var ha(j) = no) ! (ep ha(j) = 0)) hacont;
26 if (const voa(ep ha(j)) = no) hacont;
27 if (lextype voa(ep ha(j)) ^= cclt) hacont;
28 if (nchars ha(j) ^= ccnchars) hacont;
29 if (signbit voa(ep ha(j)) ^= signofcon) hacont;
30 if (ccvalptr ^= vlen voa(ep ha(j))) hacont;
31 vb = vbeg voa(ep ha(j)) - 1; $ con 0 origin
32 do i = 1 to ccvalptr;
33 if (val(vb+i) ^= ccval(i)) hacont; end do;
34 $ found
35 conhc = j;
36 return;
37 haend; $ end ha probe
38
39 $ add constant to ha and voa
40 new = 0;
41 hainuse ha(j) = yes; $ show in use
42 ep ha(j) = voptr; $ link to voa
43 var ha(j) = yes;
44 nchars ha(j) = ccnchars; ccnchars = 0;
45 const new = yes; $ is constant
46 amode new = (cclt = realtok);
47 syze new = ccsyze; $ size in bits
48 vlen new = ccvalptr; $ size in words
49 naym new = j; $ link to ha
50 type new = quant;
51 vbeg new = valptr;
52 lextype new = cclt; $ set constant lexical type
53 signbit new = signofcon ; $ set sign needed for cross-compiler
54
55 $ set hascon field if constant is 'safe', i.e., we can evaluate
56 $ it at compile time.
57 $ on a resident compiler, any single-word or shorter constant
58 $ is safe. on a cross compiler, only short integers and octals
59 $ are safe.
60 hascon ha(j) = safeconst(cclt); $ set if safe constant.
61 cclt = 0; $ clear lexical type value
62 if (valptr+ccvalptr) > valmax then $ if val overflow
63 call gtoflo(valptr+1, valptr, 'val');
64 end if;
65 vb = valptr - 1; $ origin for constant vlu insertion
66 do i = 1 to ccvalptr; val(vb+i) = ccval(i); end do;
67 valptr = valptr + ccvalptr; $ update free loc avail in val array
68 conhc = j;
69 voa(voptr) = new; voaup; $ entry constant itemin voa
70
71 end subr inscon;
1 .=member sdsnamr
2 subr sdsnamr(hap); $ get sds form of ha entry
3 $ converts name in names array to self defined string and
4 $ returns it in global variable sdsname
5 size hap(ps); $ ha ptr
6 size i(ps); $ do loop index
7
8 slen sdsnamstr = nchars ha(hap); $ set length field
9 if (nchars ha(hap) = 0) go to ret;
10 do i = 1 to (nchars ha(hap) -1) / cpw+1;
11 .f. nameorg -ws*i, ws, sdsnamstr = names(nayme ha(hap)+i-1);
12 end do;
13
14 /ret/
15 end subr sdsnamr;
16
1 .=member xsdsnamr
2 subr xsdsnamr(xhap); $ get sds form of -xha- entry (same as
3 $ -sdsnamr- except gets -xha- entry instead of -ha- entry)
4 size xhap(ps); $ -xha- pointer
5 size i(ps); $ do loop index
6
7 slen sdsnamstr = xnchars xha(xhap); $ set length
8 do i = 1 to (xnchars xha(xhap)-1)/cpw+1;
9 .f.nameorg-ws*i,ws,sdsnamstr = xnames(xnameptr xha(xhap)+i-1);
10 end do;
11
12
13 end subr xsdsnamr;
1 .=member pdsort
2 subr pdsort; $ sort and list procedures and pages.
3 $ read in list of procedure names and page numbers from
4 $ reference file; sort by name and print out.
5
6 size i(ps); $ do-loop index
7 size w(ws);
8 size l(ps); $ length of name.
9 size lines(ps); $ number of lines for list.
10 size m(ps); $loop index.
11 size haptr(ps); $ size of packed ha.
12 size top(ps); $ loop indices
13 size targ(ps);
14 size temp(hasz); $ temporary for swapping
15 size pdcomp(1); $ function to compare symbols.
16 size crfget(ws); $ read file.
17
18 haptr = 0; namesptr = 0;
19 $ read in reference file, get procedure names and page numbers.
20 crbuffptr = crbuffmax; $ indicate empty buffer to force read.
21 while 1;
22 if (crfget(w) = 0) quit while;
23 countup(haptr, hamax, 'cr-ha');
24 ha(haptr) = 0;
25 ep ha(haptr) = crfget(w); var ha(haptr) = yes;
26 nayme ha(haptr) = namesptr + 1;
27 l = crfget(w); $ get length of name.
28 if (l=0) return; $ cannot handle null name.
29 nchars ha(haptr) = l; $ save length.
30 l = (l-1)/cpw + 1; $ convert to word count.
31 if (l+namesptr) > namesmax then
32 namesptr = namesptr +l;
33 countup(namesptr, namesptr, 'cr - names');
34 end if;
35 do i = 1 to l;
36 names(namesptr + i) = crfget(w);
37 end do;
38 namesptr = namesptr + l;
39 end while;
40
41 if (haptr = 0) return; $ if no procedures.
42
43 +* swap(a,b) = $ macro for swapping, common sort operation
44 temp = ha(a); ha(a) = ha(b); ha(b) = temp; **
45
46 do i = 2 to haptr; $ make into heap, i is parent.
47 m = i;
48 while m>1; $ examine parents in turn
49 if pdcomp(m/2, m) quit while; $ if parent no smaller,
50 swap(m,m/2); $ promote large child
51 m = m/2;
52 end while;
53 end do i;
54
55 do top = haptr to 2 by -1; $ sort subtrees in turn
56 swap(1,top); $ extract largest element
57 m = 1; $ force remaining subtree to be heap
58 while m*2 < top;
59 if pdcomp(m*2+1, m*2) & (m*2+1 < top)
60 then targ = m*2+1;
61 else targ = m*2; end if;
62 if pdcomp(targ,m) then
63 swap(m, targ); $ child too big, so exchange
64 else quit while; end if;
65 m = targ; $ move to subtree of largest child
66 end while m;
67 end do top;
68
69 macdrop(swap)
70 textl(' ') endl $ blank line
71 call stitlr(1, 'sorted list of procedures and page numbers.');
72 ejectl; $ begin new page.
73 lines = (haptr+3)/4; $ number of lines.
74 do m = 1 to lines;
75 i = m;
76 while i <= haptr;
77 intl((ep ha(i)))
78 call sdsnamr(i);
79 skipl(2)
80 textl(sdsnamstr); $ print symbol
81 skipl(15-slen sdsnamstr)
82 i = i + lines;
83 end while;
84 endl endl
85 end do;
86 endl $ flushing last few names
87
88 end subr pdsort;
1 .=member crfget
2 fnct crfget(w); $ read word from reference file.
3 size crfget(ws); $ item to read.
4 size w(ws); $ dummy argument.
5
6 if crbuffptr = crbuffmax then $ if buffer done, read new one.
7 call rdrwsio(crfile, iorc, crbuff, 1, crbuffmax);
8 crbuffptr = 0;
9 end if;
10 crbuffptr = crbuffptr + 1;
11 crfget = crbuff(crbuffptr);
12
13 end fnct crfget;
1 .=member pdcomp
2 fnct pdcomp(jarg, karg); $ compare two symbols.
3 size jarg(ps), karg(ps); $ ha indices of symbols.
4 size pdcomp(1);
5 size jlen(ps), klen(ps); size minlen(ps);
6 size jch(cs), kch(cs); $ characters.
7 size i(ps); $ loop index.
8 size pos(ps); $ position within name words.
9 size jptr(ps), kptr(ps); $ nayme values.
10
11 jptr = nayme ha(jarg); kptr = nayme ha(karg);
12 jch = .f. ws+1-cs, cs, names(jptr);
13 kch = .f. ws+1-cs, cs, names(kptr);
14 if jch ^= kch then $ if initial characters differ,
15 pdcomp = (jch > kch); $ compare to get result.
16 return;
17 end if;
18 $ must examine rest of symbols, retrieve as sds and compare.
19 jlen = nchars ha(jarg); klen = nchars ha(karg);
20 minlen = jlen; if (klen < minlen) then minlen = klen; end if;
21 pdcomp=1; $ assume j bigger
22 pos = cpw*cs + 1;
23 do i = 1 to minlen;
24 pos = pos - cs;
25 jch = .f. pos, cs, names(jptr);
26 kch = .f. pos, cs, names(kptr);
27 if jch ^= kch then
28 pdcomp = (jch > kch);
29 return;
30 end if;
31 if pos = 1 then
32 pos = cpw*cs + 1;
33 jptr = jptr + 1; kptr = kptr + 1;
34 end if;
35 end do;
36 pdcomp = (jlen > klen); $
37
38 end fnct pdcomp;
1 .=member getxsds
2 subr getxsds(hap, str); $ get execution time form of string
3 $ given sds str, generate minimal-storage representation as sds
4 $ for use at execution time. set hap to ha index of generated
5 $ string.
6
7 size hap(ps); $ ha index of generated string
8 size str(namsz); $ string to pack
9 size i(ps); $ do loop for ccval copy
10
11 ccaptr = slen str;
12 do i = 1 to ccaptr;
13 cca(i) = .ch. i, str; end do;
14 cclt = strtok;
15 call cnvcon; $ convert constant.
16 call inscon(hap);
17 end subr getxsds;
1 .=member pshnamr
2 subr pshnamr(hc, r); $ hash name and push on arglist
3 $ hashes name into ha and names array
4 $ push result on arglist
5 size hc(ps); $ hash code returned
6 size r(namsz); $ sdsname
7 size j(ps); $ do loop index
8 $ this routine is invoked from macro pushname
9 do j = 1 to (slen r + (cpw-1))/cpw;
10 insnarg(j) = .f. (sorg r) - ws*j, ws, r;
11 end do;
12
13 if (mod(slen r,cpw)) .f. 1, ws - cs*(mod(slen r, cpw)), insnarg
14 (j-1) = blankword; $ set to blank pad like -names-.
15
16 insnchars = slen r; call insname(hc);
17 push(hc); $ push result onto arglist
18
19 end subr pshnamr;
20
1 .=member pshintr
2 subr pshintr(pcon); $ hash in constant and stack it
3 size pcon(ws); $ constant to insert in ha
4 size hai(ps); $ ha index assigned
5
6 ccsyze = .fb. pcon + (pcon=0); $ set to size.
7 cclt = dectok; ccval(1)=pcon; ccvalptr = 1;
8 if (ccsyze > mws-2) cclt = bittok; $ for debugging
9 call inscon(hai); $ hash in constant.
10 push(hai);
11
12 end subr pshintr;
1 .=member insname
2 subr insname(namhc); $ insert name into ha.
3
4 $ this routine returns the ha-index of a name, inserting the
5 $ inserting the name if not yet present. global inputs are
6 $ insnarg - name to insert
7 $ insnchars - number of characters in name.
8
9 size hcode(ws); $ hash code of name
10 size j(ps); $ ha-index of entry benng probed
11 size namhc(ps); $ ha-index returned
12 size insnwds(ps); $ number of words
13 size i(ps); $ do loop index
14
15 hcode = insnarg(1); $ first word of name
16 insnwds = (insnchars - 1) / cpw; $ number of words - 1
17 if (insnchars = 0) insnwds = 0;
18 do i = 1 to insnwds; $ compute hash code
19 hcode = hcode .ex. insnarg(i + 1);
20 end do;
21 hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
22 haprobe(j, hcode); $ search the ha
23
24 if (hainuse ha(j) = no) haquit; $ empty slot found
25 if (var ha(j) = no ) hacont; $ ignore ops
26 if (nchars ha(j) ^= insnchars) hacont;
27 if (nayme ha(j) = 0) hacont; $ if not a name.
28 do i = 0 to insnwds; $ compare names
29 if (names(nayme ha(j) + i) ^= insnarg(i+1)) hacont;
30 end do;
31 namhc = j;
32 return;
33 haend; $ end ha probe
34
35 $ add new name to ha
36 hainuse ha(j) = yes; $ show in use
37 nchars ha(j) = insnchars; $ number of chars in name
38 var ha(j) = yes; $ is variable
39 nayme ha(j) = namesptr;
40 do i = 1 to insnwds + 1; $ enter name in names array
41 names(namesptr) = insnarg(i);
42 countup(namesptr, namesmax, 'insert name');
43 end do;
44 namhc = j;
45
46 end subr insname;
1 .=member insglor
2 subr insglor(glohc); $ adds name to global name table
3 $ this routine returns (via gloha) the index in the global
4 $ names symbol table of a name, adding the name if it is not yet
5 $ present.
6 size j(ps); $ do loop index for search
7 size i(ps); $ do loop index
8 size hcode(ws); $ hash code for search
9 size glohc(ps); $ hash code in global array
10 size namp(ps); $ otr to name in names array
11 size hwords(ps); $ number of words in name
12 $ inputs are transmitted globally, and are
13 $ insgarg - name to hash
14 $ insgwds - number of words for name
15
16 namp = nayme ha(insgarg); $ ptr to names array
17 hwords = (nchars ha(insgarg) - 1)/cpw; $ number of words of nm
18 if (nchars ha(insgarg) = 0) hwords = 0;
19 hcode = names(namp); $ initialize hcode to first word of name
20 do i = 1 to hwords;
21 hcode = hcode .ex. names(namp + i);
22 end do;
23 hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
24
25 $ this routine returns the index in xha of a name, adding the
26 $ name to the xha table if it is not present.
27 $ the hasing algorith is
28 $ as described as algorithm 'c' in section 6.4 of knuth, vol 3.
29 $ note that xha size must be prime
30 j = mod(hcode, xhamax) + 1; $ get initial hash code.
31 /probe/
32 if xnchars xha(j) ^= nchars ha(insgarg) go to nomatch;
33 do i = 0 to hwords; $ compare names
34 if xnames(xnameptr xha(j) + i) ^= names(namp + i) go to
35 nomatch;
36 end do;
37 glohc = j; return; $ match found
38 /nomatch/
39 $ no match, look through links, if any
40 if xlink xha(j) then j = xlink xha(j);
41 go to probe; end if;
42 if (xnameptr xha(j) = 0) go to addnew; $ add new entry.
43 /findfree/
44 xhafree = xhafree - 1; $ look for free xha slot
45 if xhafree = 0 then $ xha full
46 call ermes(31); call genexit; end if;
47 if (xnameptr xha(xhafree)) go to findfree;
48 xlink xha(j)=xhafree; $link to new slot
49 j=xhafree; $ and point to it.
50 /addnew/
51 xnchars xha(j) = nchars ha(insgarg); $ number of characters in
52 $ name
53 xnameptr xha(j) = xnamesptr;
54 do i = 0 to hwords; $ copy name from names to xnames
55 xnames(xnamesptr) = names(namp + i);
56 countup(xnamesptr, xnamesmax, 'xglobal insert');
57 end do;
58 xlink xha(j) = 0; $ indicate link
59 glohc = j; $ hash code found
60
61 end subr insglor;
1 .=member ifaglor
2 subr ifaglor(glohc); $ see if name is global
3 $ this routine sees if the argument name is a global variable
4 $ for which access has been granted. if so, the index in the
5 $ xha of the variable is returned; otherwise 0 is returned.
6 $ arguments are passed by the global variables
7 $ ifaglorname - name of variable
8 $ ifaglorwds - number of words in name
9
10 size i(ps); $ do loop var
11 size namp(ps); $ ptr to names array
12 size hwords(ps); $ number of words of name
13 size j(ps); $ do loop index
14 size hcode(ws); $ hash code of name
15 size glohc(ps); $ha index returned
16 size hap(ps); $ ha index of nameset name
17 size xnp(ps); $ index in xnames of nameset name
18
19 namp = nayme ha(ifaglorname); $ ptr to names array
20 hwords = (nchars ha(ifaglorname) - 1)/cpw; $ nwords-1.
21 hcode = names(namp); $ first word of name.
22 do i = 1 to hwords;
23 hcode = hcode .ex. names(namp+i);
24 end do;
25
26 hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
27 j = mod(hcode, xhamax) + 1; $ set initial hash code.
28 /probe/
29 if xnchars xha(j) ^= nchars ha(ifaglorname) go to nomatch;
30 if xnames(xnameptr xha(j)) ^= names(namp) go to nomatch;
31 do i = 1 to hwords; $ compare rest of name
32 if xnames(xnameptr xha(j) + i) ^= names(namp + i)
33 go to nomatch;
34 end do;
35
36 $ if we have been looking for possible builtin function name,
37 $ we return builtin function code, not xha position.
38 if bifxhasearch then
39 glohc = xhabif xha(j);
40 return; end if;
41
42 $ name found, see if access granted
43 if (nlno xha(j) = 0) go to ret;
44 if (nlblk nl(nlno xha(j)) = 0) go to ret;
45 $ if access not granted to variable, return.
46 $ if access granted, enter nameset name into ha if not already
47 $ there, and set -mbused- bit to indicate that nameset used
48 $ in current routine.
49
50 if (.f. nlblk nl(nlno xha(j)), 1, accesstab = no) go to ret;
51
52 glohc = j; $ access granted, set glohc to xha index
53 mbused mba(nlblk nl(nlno xha(j))) = yes; $ nameset member used in
54 if (mbha mba(nlblk nl(nlno xha(j)))) go to done; $ nameset name
55 j = mbxha mba(nlblk nl(nlno xha(j))); $ get xha index of conta
56 xnp = xnameptr xha(j) - 1;
57 do i = 1 to (xnchars xha(j) - 1)/cpw + 1;
58 insnarg(i) = xnames(xnp+i);
59 end do;
60
61 insnchars = xnchars xha(j);
62 call insname(hap);
63 mbha mba(nlblk nl(nlno xha(glohc))) = hap; $ set -ha- index.
64 return;
65
66 /nomatch/ $ no match found. try next entry if there is one
67 j = xlink xha(j);
68 if (j) go to probe;
69
70 /ret/
71 glohc = 0; $ failure.
72
73 /done/
74 end subr ifaglor;
1 .=member advstr
2 subr advstr(str, hc); $ advance name and hash in
3 $ this routine is given string naming current local variable
4 $ or local label generation string. the string is four
5 $ characters, of which the last two are alphabetic. the routine
6 $ advances the name to next one in lexicographic order, eg,
7 $ from -aa- to -zz-. compilation is aborted if attempt made to
8 $ exceed -zz-.
9 size str(sds(4)); $ string to davance
10 size hc(ps); $ hash code computed
11 size ci(ps); $ character position
12 size alphabet(sds(26));
13 data alphabet = 'abcdefghijklmnopqrstuvwxyz';
14
15 ci = (.s. 4, 1, str) .in. alphabet;
16 if ci<26 then $ if last character can be advanced
17 .ch. 4, str = .ch. ci+1, alphabet; $ pick next character
18 else $ try to advance third character, restart fourth at 'a'
19 ci = (.s.3,1,str) .in. alphabet;
20 if ci<26 then
21 .ch. 3, str = .ch. ci+1,alphabet; .ch.4,str=1ra;
22 else countup(ci ,26, 'advstr - name overflow'); end if;
23 $ note that above countup will abort program execution
24 end if;
25 pushname(hc, str); $ hash in name to ha and names
26 $ pushname has added item to arglist, so remove from arglist
27 argptr = argptr-1;
28 namintern ha(hc) = yes; $ set internal name flag
29
30 end subr advstr;
1 .=member assembl
2 subr assembl; $ write tables on -voa- file
3 $ write tables onto -voa- file for used by code generator.
4 $ write entries in 'frames', indicating type and length of each
5 $ frame. if argument non-zero, dump symbol table.
6 size i(ws);
7 size nzwds(ps); $ number of zero words in ha
8 size haent(hasz); $ temporary copy of ha entry
9 if asmvoadump = yes then
10 call tabdump(1, voptr, 1); end if;
11 $ if first procedure is to be suppressed, do not write out.
12 if (nsubrs=1)&(sfp_opt) then return; end if;
13 if (voawrt = no) return; $ not writing voa file
14
15 vof = 0; $ routine header
16 vof_code vof = voaasm_code; $ indicate routine header
17 vof_listcode vof = listingcode; $ default code list mode at start
18 vof_asmarg vof = 0;
19 vof_init vof = voafnct;
20 vof_lablistptr vof = lablistptr;
21 vof_sub1 vof = subinfo(1); $ copy subinfo array
22 vof_sub2 vof = subinfo(2);
23 vof_sub3 vof = subinfo(3);
24 vof_subrargs vof = argct; $ indicate number of arguments.
25 vof_ha0 vof = ha_0; $ ha index of constant 0.
26 vof_ha1 vof = ha_1; $ ha index of constant 1.
27 vofhdrseq = vofhdrseq+1; vof_hdrseq vof = vofhdrseq;
28 write voafile, vof;
29
30 vof = 0;
31 call putvhdr(voa, 1, voptr, voasz, voa_code); $ write voa
32 write voafile, voa(1) to voa(voptr);
33
34 call putvhdr(names, 1, namesptr, ws, names_code); $ write -names
35 write voafile, names(1) to names(namesptr);
36
37 call putvhdr(xarg, 1, xargptr, xargsz, xarg_code);
38 write voafile, xarg(1) to xarg(xargptr);
39
40 call putvhdr(mba, 1, mbaptr, mbasz, mbacode);
41 write voafile, mba(1) to mba(mbaptr);
42
43 call putvhdr(val, 1, valptr, ws, val_code); $ write -val-
44 write voafile, val(1) to val(valptr);
45
46 $ now write out ha. since ha hashed, we pack ha into
47 $ linear array, recording in field -zerents- the number
48 $ of empty (all 0) entries preceeding each non-zero entry.
49 $ an extra-field is written in header, giving alvue of hamax as
50 $ usedin writer, so asm can check validity of hamax val on read.
51 $ now pack ha, hp points to last value in packed form
52 size hp(ps); $ alst entry in packed ha
53 nzwds = 0; $ number of zero entries before current one
54 hp = 0;
55 do i = 1 to hamax;
56 if var ha(i) = 0 $ ignore empty and non-variables.
57 then nzwds = nzwds + 1;
58 else zerents ha(i) = nzwds; nzwds = 0;
59 hp = hp+1; ha(hp) = ha(i); $ move done packed
60 end if;
61 end do;
62 $ now write remaining zero entries at top of ha
63 if nzwds then
64 haent = 0; zerents haent = nzwds-1;
65 hp = hp + 1; ha(hp) = haent; end if;
66 vof = 0; $ clear frame
67 vof_hamax vof = hamax; $ indicate -hamax- in wrtie phase
68 vof_code vof = ha_code; $ code for array
69 vof_es vof = hasz; $ entry size
70 vof_lo vof = 1; $ first entry
71 vof_hi vof = hp; $ last entry
72 vofhdrseq = vofhdrseq+1; vof_hdrseq vof = vofhdrseq;
73 write voafile, vof; $ write header frame.
74 write voafile, ha(1) to ha(hp);
75
76 vof = 0; vof_code vof = eos_code;
77 vofhdrseq = vofhdrseq+1; vof_hdrseq vof = vofhdrseq;
78 write voafile, vof; $ write frame marking end of routine
79
80 end subr assembl;
1 .=member putvhdr
2 subr putvhdr(ara, lo, hi, es, acode); $ put array to voa-file
3 $ write ara(lo) to ara(hi) to voa-file. entries are -es- bits
4 $ long. -acode- is integer code for array.
5 $ construct header frame and call -wtrvoahdr- to write array dat
6
7 size ara(ws); $ true size is -e-s. is array to write
8 size lo(ps); $ first entry to write
9 size hi(ps); $ last entry to write
10 size acode(ps); $ array code
11 size es(ps); $ entry size in bits
12 vof = 0; $ clear header frame
13 vof_code vof = acode;
14 vof_lo vof = lo; vof_hi vof = hi;
15 vof_es vof = es; $ entry size in bits
16 vofhdrseq = vofhdrseq+1; vof_hdrseq vof = vofhdrseq;
17 write voafile, vof;
18
19 end subr putvhdr;
1 .=member ermet
2 subr ermet; $ syntactic error message output routine
3 $ issue error message after checking for unexpected error
4 $ number. call -lstlin- to list last line read if it has not
5 $ yet been listed. increment error total count -nerrors-.
6 size synstr(.sds. 15); $ error message text.
7
8 argptr = 1; opstackp = 0; $ reset arrays.
9
10 $ if this was in the middle of an opener for an statement other
11 $ than an -if- statement, flush this -csa- entry.
12 if (toknum csa(csaptr) = 0 & cstype csa(csaptr) ^= cstype_if)
13 csaptr = csaptr-1;
14
15 terml(yes); $ give output to terminal too
16 call lstlin;
17 nerrors = nerrors + 1; $ update error count
mgfc 15 .+s10 error_s10; $ give s10 error character.
18 textl(error_notice)
19
20 if ermsgno<1 ! ermsgno>parseerrmax then
21 tintl('syntactic error',ermsgno) endl
22 go to return;
23 else
24 go to e(ermsgno) in 1 to parseerrmax;
25 end if;
26
27 +* et (erform, ertext) =
28 call ermlst(erform, ertext); go to return; **
29 $ new parser syntactic error messages
30 / e(1) /
31 / e(2) /
32 / e(3) /
33 $ these three error messages occur for many extractors. we
34 $ must therefore print out the correct extractor.
35 if parsereg(3) = 2 then
36 synstr = '.f. i1, i2, ';
37 elseif parsereg(3) = 3 then
38 synstr = '.e. i1, i2, ';
39 elseif parsereg(3) = 4 then
40 synstr = '.s. i1, i2, ';
41 else $ must be 5.
42 synstr = '.ch. i1, ';
43 end if;
44
45 $ now print appropriate text.
46 if ermsgno = 3 then
47 et(synstr, 'expression')
48 elseif ermsgno = 2 then
49 et(synstr, 'comma')
50 else $ must be 1.
51 et(synstr !! 't', 'term for extraction')
52 end if;
53
54 / e(4) / et('', 'control format item')
55 / e(5) / et('', 'data format item')
56 / e(6) / et('', 'data format item')
57 / e(7) / et('', 'data item in i/o list')
58 / e(8) / et('', 'expression after binary operator')
59 / e(9) / et('', 'expression in format item')
60 / e(10) / et('', 'file attribute in ''file'' statement')
61 / e(11) / et('', 'parameter in ''monitor'' statement')
62 / e(12) / et('', 'right parenthesis in format item')
63 / e(13) / et('', 'semicolon')
64 / e(14) / et('', 'statement to begin with name')
65 / e(15) / et('', 'term after unary operator')
66 / e(16) / et('', 'valid statement beginning')
67 / e(17) / et('/l(c1)/', 'expression')
68 / e(18) / et('/l(c1)/', 'right parenthesis')
69 / e(19) / et('/l1/', 'closing slash')
70 / e(20) / et('/l1/', 'label name')
71 / e(21) / et('(e1)', 'expression')
72 / e(22) / et('(e1)', 'right parenthesis')
73 / e(23) / et('(n1,...,n9)', 'right parenthesis')
74 / e(24) / et('access n1', 'name')
75 / e(25) / et('assert e1', 'expression')
76 / e(26) / et('attr = val', 'equal sign')
77 / e(27) / et('attr = val', 'expression')
78 / e(28) / et('call n1', 'procedure name')
79 / e(29) / et('call n1(e1,...,e9)', 'expression')
80 / e(30) / et('call n1(e1,...,e9)', 'right parenthesis')
81 / e(31) / et('check index', '''index''')
82 / e(32) / et('data n1 = c1', 'equal sign')
83 / e(33) / et('data n1 = c1', 'expression')
84 / e(34) / et('data n1 = c1', 'name')
85 / e(35) / et('data n1(c1) = c2', 'index expression')
86 / e(36) / et('data n1(c1) = c2', 'right parenthesis')
87 / e(37) / et('data v1 = c1(c2)', 'repetition expression')
88 / e(38) / et('data v1 = c1(c2)', 'right parenthesis')
89 / e(39) / et('dims n1(c1)', 'expression')
90 / e(40) / et('dims n1(c1)', 'left parenthesis')
91 / e(41) / et('dims n1(c1)', 'name')
92 / e(42) / et('dims n1(c1)', 'right parenthesis')
93 / e(43) / et('do v1 = e1 to e2', '''to''')
94 / e(44) / et('do v1 = e1 to e2', 'equal sign')
95 / e(45) / et('do v1 = e1 to e2', 'initial expression')
96 / e(46) / et('do v1 = e1 to e2', 'limit expression')
97 / e(47) / et('do v1 = e1 to e2', 'loop variable name')
98 / e(48) / et('do v1 = e2 to e2 by e3', 'expression after ''by''')
99 / e(49) / et('elseif e2 then', '''then''')
100 / e(50) / et('elseif e2 then', 'expression')
101 / e(51) / et('e1,...,e9', 'expression')
102 / e(52) / et('file fid', 'expression')
103 / e(53) / et('filestat(fid, scode)', 'comma')
104 / e(54) / et('filestat(fid, scode)', 'expression')
105 / e(55) / et('filestat(fid, scode)', 'keyword')
106 / e(56) / et('filestat(fid, scode)', 'left parenthesis')
107 / e(57) / et('filestat(fid, scode)', 'right parenthesis')
108 / e(58) / et('fnct n1', 'procedure name')
109 / e(59) / et('get formlist', 'format list')
110 / e(60) / et('go to n1(e1) in c1 to c2', '''in''')
111 / e(61) / et('go to n1(e1) in c1 to c2', '''to''')
112 / e(62) / et('go to n1(e1) in c1 to c2', 'expression')
113 / e(63) / et('go to n1(e1) in c1 to c2', 'limit expression')
114 / e(64) / et('go to n1(e1)', 'expression')
115 / e(65) / et('go to n1(e1)', 'right parenthesis')
116 / e(66) / et('go to sl', '''to''')
117 / e(67) / et('go to sl', 'label name')
118 / e(68) / et('goby (e1)(l1,...,l9)', 'expression')
119 / e(69) / et('goby (e1)(l1,...,l9)', 'right parenthesis')
120 / e(70) / et('goby n1(l1,...,l9)', 'label name')
121 / e(71) / et('goby n1(l1,...,l9)', 'left parenthesis')
122 / e(72) / et('goby n1(l1,...,l9)', 'name')
123 / e(73) / et('goby n1(l1,...,l9)', 'right parenthesis')
124 / e(74) / et('if e1', 'expression')
125 / e(75) / et('monitor limit = e1', 'equal sign')
126 / e(76) / et('monitor limit = e1', 'expression')
127 / e(77) / et('nameset n1', 'name')
128 / e(78) / et('n1,...,n9', 'name')
129 / e(79) / et('prog n1', 'procedure name')
130 / e(80) / et('put formlist', 'format list')
131 / e(81) / et('read fid', 'expression')
132 / e(82) / et('real n1', 'name')
133 / e(83) / et('rewind fid', 'expression')
134 / e(84) / et('size n1(c1)', 'expression')
135 / e(85) / et('size n1(c1)', 'left parenthesis')
136 / e(86) / et('size n1(c1)', 'name')
137 / e(87) / et('size n1(c1)', 'right parenthesis')
138 / e(88) / et('subr n1', 'procedure name')
139 / e(89) / et('subr n1(n2,..)', 'parameter name')
140 / e(90) / et('trace type', 'type of trace statement')
141 / e(91) / et('until e1', 'expression')
142 / e(92) / et('v1 = e1', 'equal sign')
143 / e(93) / et('v1 = e1', 'expression')
144 / e(94) / et('v1 = e1', 'assignment target')
145 / e(95) / et('v1(e1) to v1(e2)', 'name after ''to''')
146 / e(96) / et('v1(e1)', 'expression')
147 / e(97) / et('v1(e1)', 'right parenthesis')
148 / e(98) / et('v1(i1) = e1', 'right parenthesis')
149 / e(99) / et('v1(i1) = e1', 'subscript expression')
150 / e(100)/ et('while e1', 'expression')
151 / e(101)/ et('write fid', 'expression')
152 / e(102)/
153 / e(103)/
154 $ these two error messages are converted to errors 2 and 3.
155 ermsgno = ermsgno - 100; $ convert error number.
156 parsereg(3) = parsereg(7); $ get type of extractor.
157 go to e(2); $ process like errors 2 and 3.
158
159 /return/
160 call squeeze; $ list recent tokens
161
162 if nerrors > pelvalue then $ quit if too many errors.
mgfc 16 endl
mgfc 17 .+s10 error_s10; $ give s10 error character.
mgfc 18 textl(error_notice)
164 textl('error limit of ') intl(pelvalue)
165 textl(' exceeded. compilation aborted.') endl endl
166 call genexit; end if;
167
168 terml(no); $ done with terminal output
169
170 macdrop(parseerrmax)
171 end subr ermet; $ of syntactic error printer
1 .=member ermlst
2 subr ermlst(erform,ertext); $ list error message fragment
3 $ this routine, called only from ermet, lists part of syntactic
4 $ error message.
5 size erform(ws+1); $ text giving position in parse
6 size ertext(ws+1); $ text for diagnostic
7
8 textl('expect ') textl(ertext)
9 if slen erform then $ there is a construct text.
10 textl(' in construct ''') textl(erform) textl('''.')
11 else
12 textl('.')
13 end if;
14
15 endl
16
17 end subr ermlst;
1 .=member ermes
2 subr ermes(n); $ semantic error message routine
3 size types(.sds. 7); dims types(cstypes);
4 data types(cstype_nameset) = 'nameset':
5 types(cstype_prog) = 'prog':
6 types(cstype_subr) = 'subr':
7 types(cstype_fnct) = 'fnct':
8 types(cstype_do) = 'do':
9 types(cstype_while) = 'while':
10 types(cstype_until) = 'until':
11 types(cstype_if) = 'if';
12
13 +* ender = go to return;**
14 $ error message subroutine
15
16 size n(ps); $ error number
17
posa 1 $ avoid comparand error message for m11 for now.
posa 2 if ((n=5) & (targetmachine=m11)) return;
18 terml(yes); $ write error message to terminal file
19 call lstlin; $ list input line.
dst 28 if (n=5 & targetmachine=m11) ! n=15 ! n=70 ! n=71 then
mgfc 19 .+s10 warn_s10; $ give s10 warn character.
21 textl(warning_notice) nwarnings = nwarnings + 1;
22 else
mgfc 20 .+s10 error_s10; $ give s10 error character.
23 textl(error_notice)
24 nerrors = nerrors + 1;
25 end if;
26
dss 51 +* maxerrors = 71 ** $ maximum number of errors
28 if (n < 1 ! n > maxerrors) go to l(1);
29 go to l(n) in 1 to maxerrors;
30 $ we allow room for up to 60 error messages
31 $ unused slots branch to l(1), to list short text and number.
32 / l( 1) / textl('semantic error number ') intl(n) ender
33 / l( 2) / textl('expect data for ''') naml(ermesarg)
34 textl(''' to be in routine defining it.') ender
35 / l( 3) / go to l(1);
36 / l( 4) / textl('expect positive value.') ender
dst 29 / l( 5) / textl('comparison operand is multi-word') ender;
38 / l( 6) / textl('expect positive replication value.') ender
39 / l( 7) / if preludefg then
40 ntexterr = yes;
41 textl('expect subr, fnct, or eof to immediately ')
42 textl('follow routine.')
43 else
44 textl('expect ''') naml(ermesarg)
45 textl(''' to be sized.')
46 end if;
47 ender
48 / l(8) / textl('expect less than') intl(xargmax+1)
49 textl(' parameters or data statement entries.') ender
50 / l(9) / textl('s-type strings not valid on selected target machine.')
51 ender
ldsd 34 / l(10) / textl('expect real constant to be in range.') ender
53 / l(11) / go to l(1);
54 / l(12) / textl('expect inputs to string comparison not to be reals.')
55 ender
56 / l(13) / textl('expect constant with size less than') intl(szmax+1)
57 textl('.') ender
58 / l(14) / textl('expect label to be defined only once.') ender
pre 1 / l(15) / textl('expect no logical expressions on reals.')endl return;
61 / l(16) / textl('expect limit value to be in range.') ender
62 / l(17) / textl('expect nameset ''') naml(ermesarg)
63 textl(''' to be defined.') ender
64 / l(18) / textl('expect dimension to be less than ') intl(dimsmax+1)
65 textl('.') ender
66 / l(19) / if (preludefg) go to l(7);
67 textl('expect function ''') naml(ermesarg)
68 textl(''' to be sized.') ender
69 / l(20) /
70 / l(21) / go to l(1);
71 / l(22) / textl('expect file attribute to be defined only once.')
72 ender
73 / l(23) / textl('expect recognizable file attribute.') ender
74 / l(24) / textl('expect control format item.') ender
75 / l(25) / textl('expect data format item.') ender
76 / l(26) / textl('namelist format not valid on input.') ender
77 / l(27) / textl('expect nameset format to be applied to variable.')
78 ender
79 / l(28) / textl('expect function argument ''') naml(ermesarg)
80 textl(''' not to be changed.') ender
81 / l(29) / go to l(1);
82 / l(30) / textl('expect ''') naml(ermesarg) textl(''' to be in ')
83 textl('argument list only once.') ender
84 / l(31) / textl('-xha- is full. compilation aborted.') ender
85 / l(32) / textl('expect size value less than ') intl(szmax+1)
86 textl('.') ender
87 / l(33) / textl('expect ''') naml(ermesarg)
88 textl(''' to be a function.') ender
89 / l(34) / textl('expect ''') naml(ermesarg)
90 textl(''' to be a subroutine.') ender
91 / l(35) / textl('expect ''='' after ''^'' in binary operation.')
92 ender
93 / l(36) / go to l(1);
94 / l(37) / textl('expect ''quit'' to refer to loop') ender
95 / l(38) / textl('expect ''cont'' to refer to loop') ender
96 / l(39) / go to l(1);
97 / l(40) / textl('expect ''') naml(ermesarg)
98 textl(''' to be an array.') ender
99 / l(41) / textl('expect ''then'' in ''if'' statement.') ender
100 / l(42) / textl('expect constant expression.') ender
101 / l(43) / textl('expect tokens to match those in ''')
102 /csatell/
103 textl(types(cstype csa(ermesarg))) textl(''' at line')
104 intl(firstst csa(ermesarg)) textl('.') ender
105 / l(44) / textl('expect operands of same arithmetic mode.') ender
106 / l(45) / textl('expect constant mode data statement.') ender
107 / l(46) / textl('expect datum in io statement.') ender
108 / l(47) / textl('expect label index to be in range.') ender
109 / l(48) / textl('expect labels in ''go to'' to be in ascending order')
110 ender
111 / l(49) / textl('expect ''') naml(ermesarg)
112 textl(''' to be used as an array.') ender
113 / l(50) / textl('expect ''then'' or ''elseif'' before ''elseif''')
114 ender
115 / l(51) / textl('expect ''') naml(ermesarg)
116 textl(''' to be global.') ender
117 / l(52) / textl('-ha- is full. compilation aborted.') ender
118 / l(53) / textl('expect operands to .pad. to be constants.') ender
119 / l(54) / textl('expect ''') naml(ermesarg)
120 textl(''' to be dimensioned only once.') ender
121 / l(55) / go to l(1);
122 / l(56) / textl('expect ''') naml(ermesarg)
123 textl(''' to be sized only once.') ender
124 / l(57) / textl('expect only monitoring statements in interlude.')
125 ender
126 / l(58) / textl('name list not valid in this context.') ender
127 / l(59) / textl('expect main program not to have arguments.') ender
128 / l(60) / textl('expect ''end'' for ''') go to csatell;
129 / l(61) / textl('extraneous ''end'' statement.') ender
130 / l(62) / textl('expect only one ''else'' per ''if''.') ender
131 / l(63) / textl('invalid combination of file attributes in ''file'' ')
132 textl('statement.') ender
133 / l(64) / textl('expect arguments to .cc. to be strings.') ender
134 / l(65) / textl('-arglist- overflow. compilation aborted.') ender
135 / l(66) / textl('function ''') naml(ermesarg)
136 textl(''' used as variable.') ender
137 / l(67) / textl('expect only one dimensional array references.') ender
138 / l(68) / textl('expect correct number of arguments to built-in ')
139 textl('function.') ender
140 / l(69) / textl('reals not supported for selected target machine.')
141 ender
dss 52 / l(70) / textl('temporary size too large, size truncated.') ender
dss 53 / l(71) / textl('subscript size exceeds') intl(cis_opt) ender
142 /return/
143 endl
144 call squeeze; $ list recent tokens
145 if nerrors>pelvalue then $ quit if too many errors.
mgfc 21 endl
mgfc 22 .+s10 error_s10; $ give s10 error character.
mgfc 23 textl(error_notice)
147 textl('error limit of ') intl(pelvalue)
148 textl(' exceeded. compilation aborted.') endl endl
149 call genexit; end if;
150 terml(no); $ done with terminal output
151
152 macdrop(maxerrors)
153 end subr ermes;
1 .=member ermey
2 subr ermey(n); $ terminal error message routine
3 size n(ps); $ error number
4
5 terml(yes); $ write output to terminal
6 if n ^= 9 then $ not -nextok- error
7 call lstlin; $ list input line.
8 end if;
9 textl(system_notice)
10 +* maxerrors = 9 **
11 if (n < 1 ! n > maxerrors) go to l(1);
12 go to l(n) in 1 to maxerrors;
13 +* em = go to exit; **
14 / l(1) / textl('terminal error message number ') intl(n) em
15 / l(2) / textl('parse control stack underflow') em
16 / l(3) / textl('-bronlit- index out of range') em
17 / l(4) / textl('compiler not handling expressions correctly') em
18 / l(5) / textl('-opstack- underflow - expression') em
19 / l(6) / textl('-opstack- underflow - operator') em
20 / l(7) / textl('logic error in -gendat-') em
21 / l(8) / textl('illegal constant type') em
22 / l(9) / textl('bad token lexical type') em
23 macdrop(em) macdrop(maxerrors)
24 /exit/
25 endl call squeeze;
26 terml(no); $ done with output to terminal
27 call genexit; $ abort - fatal error
28
29 end subr ermey;
30
31
1 .=member ctcat
2 subr ctcat(resat, a1, a2);
3 $ routine to check for .cc. on constants
4 size a1(ps), a2(ps), resat(ps); $ inputs and output
5 size arg(ps); dims arg(2); $ array of arguments
6 size l(ps); dims l(2); $ array of lengths
7 size i(ps), j(ps); $ do loop variables
8
9 arg(1) = a1; arg(2) = a2; resat = 0; $ set initial values
10 do i = 1 to 2; $ process each argument
11 if (var ha(arg(i)) = no) go to ret; $ no good if temp
12 if (const voa(ep ha(arg(i))) = no) go to ret; $ not const
13 if (lextype voa(ep ha(arg(i))) ^= strtok) go to ret;
14 l(i) = nchars ha(arg(i)); $ set string length
15 end do;
16
17 if l(1)*l(2) = 0 then $ if either null, return other
18 if (l(1) = 0) resat = a2;
19 if (l(2) = 0) resat = a1;
20 go to ret;
21 end if;
22
23 $ if result too long, return not constant
24 if (l(1)+l(2) > toklenmax-cpw) go to ret;
25
26 $ now do concatenation
27 ccaptr = 0; $ start at begining of array
28 do i = 1 to 2; $ place each string into array
29 $ first, move into -sdsnamstr-
30 do j = 1 to (l(i)-1)/cpw+1; $ move a word at a time
31 .f. nameorg-ws*j, ws, sdsnamstr =
32 val(vbeg voa(ep ha(arg(i)))+j-1);
33 end do;
34 slen sdsnamstr = l(i); $ set length of string
35 $ now, unpack into -cca-
36 do j = 1 to l(i);
37 ccaptr = ccaptr+1; cca(ccaptr) = .ch. j, sdsnamstr;
38 end do;
39 end do i;
40
41 $ finally, build and hash in new constant
42 cclt = strtok; call cnvcon;
43 call inscon(resat);
44
45 /ret/
46 end subr ctcat;
47
1 .=member squeeze
2 subr squeeze; $ list recent tokens
3 size i(ps); $ index in lexlist
4 size n(ps); $ number listed
5 size l(ps); $ number of chars to list.
6 +* dstrlen = $ maximum number of chars to list.
vax 210 .+s32 8
7 .+s37 8
utsa 294 .+s47 8
8 .+s66 10
dso 111 .+s10 12 $ 2*cpw
10 **
11 size dstr(.sds. dstrlen); $ display string.
12
13 dstr = '' .pad. dstrlen; $ initialize.
14
15 skipl(15) textl('last few tokens: ')
16 i = lexlistptr-1; $ set to start
17 n = 0;
18 while 1;
19 i = (i+1) & (lexlistmax-1); $ bump i, modulo lexlistmax
20 n = n+1; if (n>lexlistmax) quit while;
21 if (lexlist(i+1) = 0) cont while; $ ignore if not set
22 charl(1r );
23 l = lexleng(i+1); if (l>dstrlen) l = dstrlen;
24 slen dstr = l;
25 .f. (.sds. dstrlen)+1-ws, ws, dstr = lexlist(i+1);
dso 112 .+s10.
dso 113 $ on s10, use up two lexlist entries.
dso 114 i = (i+1) & (lexlistmax-1); n = n + 1;
dso 115 .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
dso 116 ..s10
vax 211 .+s32. $ on s32, use up to two lexlist entries.
vax 212 i = (i+1) & (lexlistmax-1); n = n + 1;
vax 213 .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
vax 214 ..s32
26 .+s37. $ on s37, use up to two lexlist entries.
27 i = (i+1) & (lexlistmax-1); n = n + 1;
28 .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
29 ..s37
utsa 295 .+s47. $ on s47, use up to two lexlist entries.
utsa 296 i = (i+1) & (lexlistmax-1); n = n + 1;
utsa 297 .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
utsa 298 ..s47
30 textl(dstr)
31 end while;
32 endl
33 listl(listsw=no) endl listl(yes)
34
35 macdrop(dstrlen);
36 end subr squeeze;
1 .=member findcsa
2 subr findcsa(csap, typ); $ find -csa- entry.
3 $ this routine finds the -csa- pointer whose opener most closely
4 $ matches the tokens on the statement being scanned. -typ- is n
5 $ not set for -quit- and -cont- where only a loop is being
6 $ searched for.
7 size csap(ps); $ return index.
8 size typ(1); $ type parameter.
9 size csap1(ps); $ approximate match.
10 size i(ps), j(ps); $ temporaries.
11 size org(ps); $ origin in -csatoks-.
12 size toks(ps), typs(1); $ opener information.
13 dims toks(cstypes), typs(cstypes);
14
15 +* tt(cst, tok, tp) = $ initialize -toks- and -typs-.
16 toks(cst) = tok: typs(cst) = tp **
17
18 data $ initialize tables.
19 tt(cstype_subr, lc_subr, yes):
20 tt(cstype_fnct, lc_fnct, yes):
21 tt(cstype_prog, lc_prog, yes):
22 tt(cstype_while, lc_while, no):
23 tt(cstype_until, lc_until, no):
24 tt(cstype_do, lc_do, no):
25 tt(cstype_if, lc_if, yes):
26 tt(cstype_nameset, lc_nameset,yes);
27
28 macdrop(tt)
29
30 size lc(ps); $ literal code of first token.
31 size ntoks(ps); $ number of tokens after first.
32 size stoks(ws); dims stoks(5); $ succeding tokens.
33
34 $ first, show that there were no matches.
35 csap = 0; csap1 = 0; $ clear both pointers.
36
37 $ next, get first token.
38 if (keeptok = no) call nextok; $ get next token.
39 lc = toklc; $ save its literal code.
40 ntoks = 0; $ show no more tokens yet.
41 if lc ^= lc_semicolon then $ scan for more if not end.
42 do ntoks = 1 to 5; $ scan forwards.
43 call nextok; $ get next token.
44 stoks(ntoks) = tokara(1); $ get first token word.
45 if (toklc = lc_semicolon) quit do; $ stop at semicolon.
46 end do;
47
48 ntoks = ntoks-1; $ allow for last.
49 end if;
50
51 do i = csaptr to 1 by -1; $ now scan looking for match.
52 if (typs(cstype csa(i)) > typ) cont do; $ not eligable.
53 if (lc ^= lc_semicolon & lc ^= toks(cstype csa(i))) cont do;
54
55 $ we now have an entry whose first tokens match. this is
56 $ saved as best so far.
57 csap1 = i; $ save for later analysis.
58
59 $ now compare the rest of the tokens.
60 if (ntoks > toknum csa(i)) cont do; $ too many tokens given.
61 org = tokorg csa(i) - 1; $ set to one below origin.
62 do j = 1 to toknum csa(i); $ scan all tokens in original.
63 if (j > ntoks) quit do i; $ found match.
64 if (stoks(j) ^= csatok(org+j)) cont do i; $ no match.
65 end do;
66
67 quit do i; $ we have a match.
68 end do;
69
70 csap = i; $ set return value.
71
72 $ now, if no perfect match was found and a close match was found
73 $ give an error message and use the close match.
74 if csap = 0 & csap1 ^= 0 then $ use close match.
75 ermesarg = csap1; call ermes(43); $ print error message.
76 csap = csap1; $ use close match.
77 end if;
78
79 end subr findcsa;
1 .=member closer
2 subr closer; $ close last opened opener.
3 $ this routine closes the last opened opener. the action
4 $ taken depends on the type of opener.
5 size csam(csasz); $ -csa- entry being closed.
6 size arithop(ps); $ arithmetic operation to issue.
7 size comop(ps); $ comparison operation to issue.
8 size i(ps); $ temporary.
9 size hap(ps); $ pointer to -ha-.
10
11 csam = csa(csaptr); $ extract entry to close.
12 go to l(cstype csa(csaptr)) in 1 to cstypes; $ select action.
13
14 /l(cstype_nameset)/
15 $ for a nameset, just rest nameset to use.
16 nstouse = oldmblk csam; go to ret;
17
18 /l(cstype_while)/ /l(cstype_until)/
19 $ for -while- and -until- generate go to body; /end/
20 push(testlbl csam); call gengol(op_goto);
21 labdef(endlbl csam); go to ret;
22
23 /l(cstype_if)/
24 $ unless this is a -then-, define end label.
25 if csiftype csam ^= csiftype_then then
26 labdef(endlbl csam);
27 end if;
28
29 $ now unless this is an -else-, define the body label.
30 if csiftype csam ^= csiftype_else then
31 if trflowfg then $ flow tracing.
32 trflow(flowifnsf); $ generate trace code.
33 else $ just define body label.
34 labdef(bodylbl csam);
35 end if;
36 end if;
37
38 go to ret; $ done.
39
40
41 /l(cstype_do)/
42 $ generate test label if referenced.
43 if testlbl csam then labdef(testlbl csam); end if;
44
45 $ now select the arithmetic and comparison operations
46 $ depending on the sign of the increment.
47 if dosignp csam
48 then arithop = op_sub; comop = op_ge; $ sign was -.
49 else arithop = op_add; comop = op_le; end if; $ sign +.
50
51 $ now generate the increment (decrement).
52 push(dovarp csam) push(dovarp csam) push(doincp csam)
53 call arith(arithop); call genasin(1, 0);
54
55 $ now generate the test and branch to body label.
56 push(dovarp csam); push(dohip csam); call arith(comop);
57 push(bodylbl csam); call genifgo(op_if);
58
59 $ now define the end label.
60 labdef(endlbl csam);
61
62 $ finally, must rest the busy bits for any obtained -do- variabl
63 hap = dohip csam; $ start with high index.
64 while yes; $ loop until quit.
65 if namintern ha(hap) then $ this was internal.
66 do i = 1 to dovarptr; $ find spot.
67 if dovars(i) = hap then
68 .f. i, 1, dovarbusy = no; $ show not busy.
69 quit do; $ done with scan.
70 end if;
71 end do;
72 end if;
73
74 $ now if this was increment, done.
75 if (hap = doincp csam) quit while;
76
77 hap = doincp csam; $ else set to increment.
78 end while;
79
80 go to ret; $ done with this case.
81
82
83 /l(cstype_subr)/ /l(cstype_fnct)/ /l(cstype_prog)/
84 $ first, list last line if not already listed.
85 if (listsw) call lstlin; $ -lstlin- does nothing if listed.
86
dsz 8 $ if function, check that function has been sized.
dsz 9 if fswitch then $ if function
dsz 10 if syze voa(voafnct) = 0 then $ if unsized
dsz 11 ermesarg = subinfo(1); $ copy ha index.
dsz 12 call ermes(19);
dsz 13 end if;
dsz 14 end if;
dsz 15
87 $ now check for undefined labels.
88 terml(yes) $ in case there are error messages.
89 do i = 1 to lablistptr; $ scan all labels.
90 if (labvoa lablist(i)) cont do; $ label is defined.
91 if (namintern ha(labha lablist(i))) cont do; $ internal labe
92 nerrors = nerrors+1; $ increment error count.
mgfc 24 .+s10 error_s10; $ give s10 error character.
93 textl(error_notice) textl('expect label ''')
94 naml(labha lablist(i)) textl(''' to be defined.') endl
95 end do;
96
97 $ now compute and print error statistics.
98 erthis = nerrors - erprev; erprev = nerrors;
99 warnthis = nwarnings - warnprev; warnprev = nwarnings;
100
101 if erthis ^= 0 ! warnthis ^= 0 then
102 listl(listsw=no) endl listl(yes) $ conditionally print a blan
103 end if;
104
105 if erthis then $ print error count.
106 textl('******* ') intl(erthis) textl(' errors detected in ''')
107 textl(currsubrname) textl('''.') endl
108 end if;
109
110 if warnthis then $ print number of warnings.
111 textl('******* ') intl(warnthis) textl(' warnings in ''')
112 textl(currsubrname) textl('''.') endl
113 end if;
114
115 if erthis ^= 0 ! warnthis ^= 0 then endl endl end if;
116 terml(no) $ stop writing to terminal.
117
118 call genret; $ generate return statement.
119 call blkend; $ end the basic block.
120 call sortvars; $ allocate local storage.
121 call assembl; $ write out a -voa- file.
122 call purge; $ clear tables for next time.
123
124 /ret/
125 csatokptr = tokorg csam - 1; $ reset pointer.
126 csaptr = csaptr - 1; $ pop -csa-.
127
128 end subr closer;
1 .=member arith
2 subr arith(op); $ generator for binary operations
3 $ retrieve arguments from argstack. if both are constants
4 $ then try to perform operation at compile time. if arguments
5 $ same or one of them is the constant 0 or the constant 1, try
6 $ to find a formal identity, as encoded in the table -fidtab-.
7 $ check for mixed-mode arithmetic (reals and non-reals),as
8 $ well as unexpected operations ,such as .or.) on reals.
9 $ if a computation can be performed at compile time, see if
10 $ negative result is acceptable. if so, keep constant in sign
11 $ and magnitude form, with -signbit- in -voa- noting negative
12 $ sign.
13 size resat(ps); $ ha index of result
14 size op(ps); $ opcode as received
15 size opcd(ps);
16 size realops(ps);
17 size s1(ps), s2(ps); $ sizes of inputs.
18 size v(ws);
19 size v1(ws);
20 size v2(ws);
21 size a1(ps), a2(ps); $ ha indexex of inputs.
22 size ibsize(ps); $ constant size in bits
23 size am1(ps), am2(ps); $ arithmetic modes of inputs
24 size fidc(ps); $ case for formal identity search
25
26 $ formal identities are encoded in the table -fidtab-.
27 $ the result is encoded as follows:
28 $ 0 - result is constant 0,
29 $ 1 - result is constant 1,
30 $ 2 - result is the non-constant input
31 $ 3 - result must be computed.
32 $ at most one input is assumed to be constant 1 or 0, as case
33 $ where both inputs constants handled by constant folding.
34
35 $ it is left as an exercise to the zealous implementor to extend
36 $ search for formal identities to real numbers, and perhaps even
37 $ standard functions.
38
39 size fidtab(20); dims fidtab(op_sne);
40
41 $. 4. 3. 2. 1. 0. (fidc value)
42 $. a1 e e e 1 0
43 $. a2 1 0 e e e
44 data fidtab(op_add ) = 4b'3 2 3 3 2'; $ +
45 data fidtab(op_sub ) = 4b'3 2 0 3 3'; $ -
46 data fidtab(op_mul ) = 4b'2 0 3 2 0'; $ *
47 data fidtab(op_div ) = 4b'2 3 1 3 0'; $ /
48 data fidtab(op_and ) = 4b'3 0 2 3 0'; $ &
49 data fidtab(op_or ) = 4b'3 2 2 3 2'; $ !
50 data fidtab(op_exor) = 4b'3 2 0 3 2'; $ .ex.
51 data fidtab(op_eq ) = 4b'3 3 1 3 3'; $ =
52 data fidtab(op_ne ) = 4b'3 3 0 3 3'; $ =
53 data fidtab(op_gt ) = 4b'3 3 0 3 3'; $ >
54 data fidtab(op_ge ) = 4b'3 3 1 3 3'; $ >=
55 data fidtab(op_lt ) = 4b'3 3 0 3 3'; $ <
56 data fidtab(op_le ) = 4b'3 3 1 3 3'; $ <=
57 data fidtab(op_seq ) = 4b'3 3 1 3 3'; $ .seq.
58 data fidtab(op_sne ) = 4b'3 3 0 3 3'; $ .sne.
59
60 dims realops (10); $ map from integer into reals
61 data realops = rop_add, rop_sub, rop_gt, rop_lt, rop_ge,
62 rop_le, rop_eq, rop_ne, rop_mul, rop_div;
63 $ corresponds to real + - gt lt ge le eq ne * /
64 opcd = op;
65 pop(a2); pop(a1); $ retrieve two arguments.
66 $ main ordinary operator generator
67 $ uses-emit 2 - routine for code emission
68 call setq(a1); call setq(a2);
69 if op = op_ccat then $ see if .cc. on constants
70 call ctcat(resat, a1, a2);
71 if (resat) go to ret; $ if constant result, done
72 go to normseq;
73 end if;
74 if opcd = op_pad then $ do pad separately.
75 call genpad(resat, a1, a2);
76 go to ret;
77 end if;
78 if(op > op_sne) go to normseq;
79 am1 = amode voa(ep ha(a1)); am2 = amode voa(ep ha(a2)); $ modes
80 if (am1 ! am2) go to real;
81 if (hascon ha(a1) & hascon ha(a2)) go to constfold;
dsr 17 $ do not attempt folding if either input multi-word.
dsr 18 if (syze voa(ep ha(a1))>mws ! syze voa(ep ha(a2))>mws)
dsr 19 go to normseq;
82 if a1=ha_0 ! a1=ha_1 ! a2=ha_0 ! a2=ha_1 ! a1=a2 then
83 $ may have formal identity.
84 fidc = 2; $ assume e op e
85 if (a1=ha_0) fidc = 0;
86 if (a1=ha_1) fidc = 1;
87 if fidc = 2 then
88 if (a2=ha_0) fidc = 3;
89 if (a2=ha_1) fidc = 4;
90 end if fidc = 2;
91
92 go to give (.f. fidc*4 + 1, 4, fidtab(op)) in 0 to 3;
93 /give(0)/ resat = ha_0; go to ret; $ result is constant 0
94 /give(1)/ resat = ha_1; go to ret; $ result is constant 1
95 /give(2)/
96 if hascon ha(a1)
97 then resat = a2; $ if a1 constant, result is a2
98 else resat = a1; $ result is a1 (the non-constant)
99 end if;
100 go to ret;
101 end if;
102 / give(3) /
103 /normseq/
104 call emit2(opcd, a1, a2, resat);
105 /ret/
106 push(resat);
107 return;
108 /real/
109 if am1 ^= am2 then
110 call ermes(44);
111 resat = ha_1;
112 go to ret;
113 end if;
114
119 .+realsc if (hascon ha(a1) & hascon ha(a2)) go to realconstfold;
120 opcd = realops(op);
121 go to normseq;
122/constfold/
123 v1 = conval(a1); v2 = conval(a2);
124 s1=.fb. v1 ; s2=.fb.v2;
125 go to l(op) in 1 to 15;
126 / l(op_lt) / v = v1 < v2; go to con1;
127 / l(op_le) / v = v1 <=v2; go to con1;
128 / l(op_gt) / v = v1 > v2; go to con1;
129 / l(op_ge) / v = v1 >=v2; go to con1;
130 / l(op_eq) / v = v1 = v2; go to con1;
131 / l(op_ne) / v = v1 ^=v2; go to con1;
132 / l(op_add) / v = v1 + v2; go to signtest;
133 / l(op_sub) / v = v1 - v2; go to signtest;
134 / l(op_mul) / ibsize = s1 + s2;
135 .+s66 if ibsize>48 then go to normseq; end if; /* 6600 hardware */
136 v = v1 * v2; go to signtest;
137 / l(op_div) / if (v2=0) go to normseq; $ aboid divide by 0
138 v = v1 / v2; go to signtest;
139 / l(op_and) / v = v1 & v2; ibsize = .fb. v; go to con;
140 / l(op_or) / v = v1 ! v2; ibsize = .fb. v; go to con;
141 / l(op_exor) / v = v1 .exor. v2; ibsize = .fb. v; go to con;
142 / l(op_seq) /
143 / l(op_sne) /
144 $ here for string comparisons; for now just do operation.
145 go to normseq;
146 /con1/ ibsize = 1; go to con;
147 /signtest/
148 ibsize = .fb. v;
149 if v < 0 then
150 .+ncfstat ncftot = ncftot+1; $ count negative constants
151 if (ncfopt=no) go to normseq; $ if user no wants neg con fold
152 signofcon = yes; ibsize = mws;
153 end if v;
154
155 /con/
156 $ insert one word constant into ha
157 cclt = dectok;
158 ccsyze = ibsize + (ibsize=0); ccval(1) = v; ccvalptr = 1;
159 call inscon(resat);
160 signofcon = 0; $ reset sign flag to positive
161 go to ret;
162 .+realsc.
163 real r, r1, r2;
164 /realconstfold/
165 r1 = val(vbeg voa(ep ha(a1))); r2 = val(vbeg voa(ep ha(a2)));
166 go to ro(op) in 1 to 15;
167 / ro(op_lt) / r = r1 < r2; go to rcon1;
168 / ro(op_le) / r = r1 <= r2; go to rcon1;
169 / ro(op_gt) / r = r1 > r2; go to rcon1;
170 / ro(op_ge) / r = r1 >= r2; go to rcon1;
171 / ro(op_eq) / r = r1 = r2; go to rcon1;
172 / ro(op_ne) / r = r1 ^= r2; go to rcon1;
173 / ro(op_add) / r = r1 + r2; go to rcon;
174 / ro(op_sub) / r = r1 - r2; go to rcon;
175 / ro(op_mul) / r = r1 * r2; go to rcon;
176 / ro(op_div) / if (r2=0.0) go to normseq;
177 r = r1 / r2; go to rcon;
rcfa 1 / ro(op_and) /
rcfa 2 / ro(op_or) /
rcfa 3 / ro(op_exor) /
rcfa 4 go to normseq; $ don't bother to fold logical ops on reals.
181 / ro(op_seq) / / ro(op_sne) / $ error if string comparison for reals.
182 call ermes(12);
183 go to normseq;
184 /rcon/
185 cclt = realtok;
186 ccsyze = rlsz; ccval(1) = r; ccvalptr = 1;
187 call inscon(resat);
188 go to ret;
189
190 /rcon1/
191 cclt = dectok;
192 ccval(1) = v; ccvalptr = 1;
193 ccsyze = 1; call inscon(resat);
194 go to ret;
195 ..realsc
196 end subr arith;
1 .=member marith
2 subr marith(op); $ monadic operator processor
3 size a1(ps); $ pointer to -ha- entry
4 size resat(ps); $ result pointer
5 size op(ps); $ operation code
6 size hap(ps); $ temporary used for .sds.
7 size t(ws); $ integer value
8 size s(ps); $ size of .not. operand.
9
10 pop(a1); call setq(a1); $ get and check operand
11 if op = 1 then $ special case for .len.
12 if const voa(ep ha(a1)) & lextype voa(ep ha(a1))=strtok then
13 pushint(nchars ha(a1)); $ length is constant
14 else
15 $ generate .f. 1, .sl., a1
16 push(ha_1); pushint(msl); push(a1); call genextr(op_fext);
17 end if;
18 return;
19 end if;
20
21 $ if unary plus, just return input.
22 if (op=2) then push(a1); return; end if;
23 if op = op_usub then $ unary minus
24 if amode voa(ep ha(a1)) then
25 .+realsc.
26 real r;
27 if hascon ha(a1) then $ can fold
28 r = conval(a1); r = -r; $ get result
29 cclt = realtok; t = r; go to folded;
30 end if;
31 ..realsc
32 call emit1(rop_usub, a1, resat);
33 go to ret;
34 else
35 push(ha_0); push(a1); call arith(op_sub);
36 return;
37 end if;
38 end if;
39
40 $ now, check for constant values
41 if hascon ha(a1) then $ safe constant
42 t = conval(a1); $ get constant value
43 if op = 0 then $ .sds.
44 t = ((t*mcs+msl+mso+mws-1)/mws)*mws;
45 cclt = dectok; $ set to decimal token
46 elseif op = op_not then $ .not.
47 s = .fb. t; if (s=0) s = 1; $ find size.
48 t = .f. 1, s, (.not. t); cclt = bittok;
49 elseif op = op_nb then $ .nb.
50 t = .nb. t; cclt = dectok;
51 else $ .fb.
52 t = .fb. t; cclt = dectok;
53 end if;
54 /folded/
55 ccsyze = .fb. t + (t=0); ccval(1) = t; ccvalptr = 1;
56 call inscon(resat); $ insert constant
57 go to ret;
58 end if;
59
60 $ else, emit operation
61 if op = 0 then $ .sds.
62 push(a1); pushint(mcs); call arith(op_mul);
63 pushint(msl+mso+mws-1); call arith(op_add);
64 pushint(mws); call arith(op_div);
65 pushint(mws); call arith(op_mul);
66 else
67 call emit1(op, a1, resat);
68 /ret/
69 push(resat); $ push result onto stack
70 return;
71 end if;
72
73 end subr marith;
74
75
1 .=member gendebug
2 subr gendebug(case, value); $ generator for -debug- statement
3 size case(ps); $ parameter type
4 size value(1); $ parameter setting
5 size a1(ps); $ -ha- pointer
6
7 if case = 0 then $ initialization/termination
8 if value = 0 then $ initialization
9 dbgparm = 0; dbgchange = 0; $ clear parameters
10 dbgha = 0; $ clear -ha- pointer
11 else
dss 54 testdebug;
15 if dbgha then $ must generate code to move
16 call advstr(lvgen, a1); $ build variable
dss 55 push(a1) pushint(mws); localforce = yes;
18 call gensiz; $ size variable
19 push(a1) call gendat(2); $ begin data statement
20 pushint(dbgparm); arglist(argptr) = 0; call gendat(4);
dss 56 push(ha_1) pushint(mws-4) push(a1) push(dbgha)
dss 57 call genasin(2, no); $ generate .f. 1, (.ws.-4), dbgh
23 else
24 pushint(dbgparm); pop(a1); $ get first parameter set
25 end if;
26 pushname(dbgha, debugnames(dbg_setx)); $ push name
27 push(a1); pushint(dbgchange); arglist(argptr) = 1; $ push
28 call gencall(call_parms); $ call routine
29 end if;
30 return;
31 end if;
32
33 if case = 1 then $ special case for line limit
34 if value then $ value given
35 pop(a1); $ get it
36 if hascon ha(a1) then $ if safe constant
37 if .fb. conval(a1) > mps then
38 call ermes(16); $ error
39 return; $ ignore parm
40 end if;
dss 58 .f. 1, mws-4, dbgparm = conval(a1); $ set value
42 else
43 dbgha = a1; $ save for later
44 end if;
45 end if;
dss 59 .f. 1, mws-4, dbgchange = yes; $ set change flag
47 else $ simple case
dss 60 .f. (mws-5)+case, 1, dbgchange = yes; $ set change flag
dss 61 .f. (mws-5)+case, 1, dbgparm = value; $ set new value
50 end if;
51
52 end subr gendebug;
53
1 .=member genacc
2 subr genacc; $ process -access- declaration
3 size a1(ps); $ ptr to ha
4 size j(ps); $ do loop index
5 size n(ps); $ number of accessed namesets
6 size nsi(ps); $ nameset number
7 size xhap(ps); $ xha index of nameset name
8 size i(ps);
9
10 $ generator routine called upon parsing an access statement to
11 $ to access nameset
12
13 n = arglist(argptr) + 1; $ number of names
14 argptr = argptr - n;
15 do i = 0 to n - 1;
16 a1 = arglist(argptr + i); $ ith name
17 insglob(xhap, a1);
18 nsi = xnsblk xha(xhap); $ get nameset index in mba
19 if nsi then $ if global variable name,
20 .f. nsi, 1, accesstab = yes; $ grant access, and note
21 mbha mba(nsi) = a1; $ record ha index.
22 else
23 ermesarg = a1; call ermes(17);
24 end if;
25 end do;
26
27 end subr genacc;
1 .=member genasin
2 subr genasin(optyp, indxd); $ process assignment statement.
3 $ generator for all assignment statements. the parameter indxd
4 $ indicates whether the assignment is indexed. the parameter
5 $ optype indicates the operation:
6 $ 1 - simple
7 $ 2 - .f. field
8 $ 3 - .e. field
9 $ 4 - .s. field
10 $ 5 - .ch. field
11 $ 6 - .len. field
12 size indxd(1); $ flag indicating indexed store
13 size optype(ps); $ operation type
14 size optyp(ps); $ operation type as given.
15 size opc(ps); dims opc(12);
16 data opc = $ case to opcode map.
17 op_asin, op_xasin, op_fasin, op_xfasin, op_easin,
18 op_xeasin, op_sasin, op_xsasin, op_fasin, op_xfasin,
19 op_fasin, op_xfasin;
20 size args(ps); dims args(12);
21 data args = $ case to argument count map.
22 2, 2+1, 4, 4+1, 4, 4+1, 4, 4+1, 3, 3+1, 2, 2+1;
23 size nargs(ps); $ number of arguments of operation
24 size j(ps); $ do loop index
25 size a1(ps), a2(ps), a3(ps), a4(ps); $ ha indices for args.
26
27 optype = optyp;
28 nargs = args(2*optype - 1 + indxd); $ get no of args
29 do j = 1 to nargs; $ verify operands
30 call setq(arglist(argptr-j)); $ check input
31 end do;
32 $ if origin and length constant, see if .f. or .e.
33 if (optype=2)!(optype=3) then $ if .e. or .f.,
34 chasflg = no; $ ensure flag is off.
35 a1 = arglist(argptr - indxd - 4); $ starting position.
36 a2 = arglist(argptr - indxd - 3); $ field length.
37 if hascon ha(a2) then $ if length constant,
38 if hascon ha(a1) then $ and origin constant,
39 if mod(conval(a1)-1, mws) + conval(a2) > mws then
40 if (optype=2) optype = 3; $ must be .e.
41 else
42 if (optype=3) optype=2; $ may be .f.
43 end if;
44
45 if mod(conval(a2), mcs) = 0 then $ may be character
46 if mod(conval(a1)-1, mcs) = 0 then $ it is chara
47 chasflg = yes; $ is character op
48 end if;
49 end if;
50 else
51 if ((optype=3)&(a2=ha_1)) optype=2;
52 $ (convert .e.,...,1, to .f.,...,1, .)
53 end if;
54 end if;
55 end if;
56
57 if indxd then $ see if check index is in effect
58 if chinxf ha(arglist(argptr-3)) then $ should check this sto
59 call chinxr(arglist(argptr-3), arglist(argptr-2));
60 end if;
61 end if;
62 go to l(optyp) in 1 to 6; $ select code type
63
64 /l(5)/ $ .ch. - generate .f. (.f. .sl.+1, .so., a2)-cs*a1, cs, a2=a3
65 $ for unindexed case and .f. sorg a2 - cs*a1,cs, a2(a3) = a4
66 $ for indexed case.
67 nargs = nargs + 1; $ convert to .f. operation
68 if indxd then pop(a4); end if;
69 pop(a3); pop(a2); pop(a1); $ retrieve arguments.
70 pushint((msl+1)) $ stack start of sds origin field for a2.
71 pushint(mso) $ field extract length
72 push(a2)
73 if indxd then $ perform indexed load - sorg a2(i)
74 push(a3); call arith(op_xload);
75 end if;
76
77 chasflg = (mod(msl, mcs) = 0 & mod(mso, mcs) = 0);
78 call genextr(op_fext); $ to do extract
79 $ generate voa entry for a1 * cs
80 pushint(mcs)
81 push(a1)
82 call arith(op_mul);
83 call arith(op_sub); $ do subtraction
84 pushint(mcs)
85 push(a2) push(a3) $ target variable, index or source
86 if (indxd) then push(a4); call setq(a4); end if;
87 chasflg = yes; $ show character assigment
88 go to l(1); $ merge to normal code
89
90 /l(6)/ $ .len. - generate .f. 1, .sl., a1 = a2
91 nargs = nargs+2; $ convert to .f
92 if indxd then pop(a3); end if;
93 pop(a2); pop(a1); $ get arguments
94 push(ha_1) pushint(msl) push(a1) push(a2)
95 if indxd then push(a3); end if;
96 chasflg = (msl = mcs); $ set if char. op.
97 $ fall through to generation
98
99 /l(1)/ /l(2)/ /l(3)/ /l(4)/
100 $ set global parameters for trace routine
101 trstor1 = arglist(argptr - 1);
102 trstor2 = arglist(argptr - 2);
103 trstor3 = arglist(argptr - 3);
104 trstor4 = arglist(argptr - 4);
105 trstor5 = arglist(argptr - 5);
106 trstors = a1; $ for .ch. operation set to fbpos
107 call emass(opc(2*optype - 1 + indxd), nargs);
108 a1 = trstor2; if (indxd) a1 = trstor3; $ get target
109 ermesarg = a1; $ set for possible error message.
110 if argno voa(ep ha(a1)) ^= 0 & fswitch then $ error
111 call ermes(28); $ cant change that var.
112 end if;
113
114 if dimn voa(ep ha(a1)) then $ variable is dimensioned.
115 if (indxd = no) call ermes(49); $ error.
116 else $ variable is not an array.
117 if (indxd) call ermes(40); $ cannot use in this manner.
118 end if;
119 if tracef ha(a1) & namintern ha(a1) = no then $ trace
120 trstorp = optype; trstori = indxd; $ set parameters
121 call trstorr(a1); $ go trace store
122 end if;
123
124 end subr genasin;
1 .=member gencall
2 subr gencall(case); $ subroutine or function call.
3 $ this routine processes subroutine or function calls and
4 $ indexed loads. its main responsibility is to determine
5 $ whether a subscript is a function call or indexed load.
6 $ it also handles built-in functions.
7 size case(ps); $ calling case.
8 size a1(ps); $ routine or array name pointer.
9 size a2(ps); $ argument to operation.
10 size resat(ps); $ result of operation.
11 size n(ps); $ number of arguments.
12 size argbase(ps); $ base pointer to arguments on -arglist-
13 size glohc(ps); $ hash index into -xha-.
14 size bifno(ps); $ built-in function index.
15 size new(voasz); $ new -voa- entry.
16
17 $ first, see if this is a subroutine call without parameters.
18 if case = call_noparms then $ it is.
19 pop(a1); $ get routine name.
20 n = 0; argbase = argptr; $ set no parameters.
21 go to callcase; $ merge with other subroutine call code.
22 end if;
23
24 $ next get information about parameters.
25 n = arglist(argptr) + 1; $ get number of parameters.
26 argbase = argptr - n - 1; $ get pointer to below first parm.
27 a1 = arglist(argbase); $ get routine name.
28 if (case = call_parms) go to callcase; $ if call, go process.
29
30 $ we now have either a function call or an indexed load.
31 $ first, see if the name is in the -voa-.
32 if ep ha(a1) = 0 then $ it is not in -voa-.
33 $ next, check if it is a global.
34 ifaglob(glohc, a1); $ get global index.
35 if (glohc = 0) go to testbif; $ is not a global.
36 setqfok = yes; call setq(a1); $ page in name.
37 end if;
38
39 $ now see if this is an array.
40 if dimn voa(ep ha(a1)) then $ it is an array.
41 $ if this is referenced with more than one subscript
42 $ it is an error.
43 if n ^= 1 then $ more than one subscript.
44 ermesarg = a1; call ermes(67); $ output error message.
45 argptr = argptr - n + 1; $ reset pointer.
46 end if;
47
48 $ now generate the indexed load.
49 call arith(op_xload); $ all arguments are in place.
50 return; $ done in this case.
51 end if;
52
53 $ now, we have a subscripted reference to a variable which
54 $ is not an array. if it was never used as a simple variable,
55 $ then it is a function.
56 if isavar voa(ep ha(a1)) then $ was used as variable.
57 ermesarg = a1; call ermes(33); $ print message.
58 isavar voa(ep ha(a1)) = no; $ now this is a function.
59 end if;
60
61 $ otherwise, this is a normal user function.
62 go to usefcn;
63
64
65 /testbif/
66 $ here the variable is not a global. therefore, we must now
67 $ check if it is a built-in function.
68 bifxhasearch = yes; ifaglob(bifno, a1); bifxhasearch = no;
69 if (bifno = 0) go to usefcn; $ if not, assume user function.
70
71 $ now see if the correct number of arguments were used.
72 if n ^= bfargs bifatrtab(bifno) then $ error.
73 ermesarg = a1; call ermes(68); $ print error message.
74 argptr = argbase; push(ha_1); return; $ ignore call.
75 end if;
76
77 $ now see if this is an 'external' function.
78 if bfext bifatrtab(bifno) then $ it is.
79 $ now check for and process an alias to the function.
80 if bfalias bifatrtab(bifno) then $ there is an alias.
81 call xsdsnamr(bfalias bifatrtab(bifno)); $ get name.
82 argptr = argbase; pushname(a1, sdsnamstr); $ put in -ha-
83 end if;
84
85 $ now see if the function name is already in the -ha-.
86 if ep ha(a1) = 0 then $ it is not in the -ha-.
87 ep ha(a1) = voptr; $ set pointer to -voa-.
88 var ha(a1) = yes; $ show real variable or constant.
89 new = 0; type new = quant; naym new = a1; $ build entry
90 syze new = mws; isafnct new = yes; $ set size and status
91 if bfmode bifatrtab(bifno) then $ is a floating function
92 if targetmachine = m11 then $ cannot support.
93 call ermes(69); $ print error message.
94 else $ set values.
95 syze new = rlsz; amode new = yes;
96 end if;
97 end if;
98
99 voa(voptr) = new; voaup; $ update into -voa-.
100 end if;
101
102 go to fnctmerge; $ merge with normal function code.
103 end if;
104
105 $ at this point we have a built-in function which is actually
106 $ a special op-code. we handle these depending on the number
107 $ of operands.
108 if n = 2 then $ this is binary function.
109 argptr = argbase + 3; $ point to correct place.
110 pop(a2); pop(a1); $ get arguments.
111 argptr = argptr-1; $ step over name.
112 call setq(a1); call setq(a2); $ ensure are sized.
113 call emit2(opofbif(bifno), a1, a2, resat); $ emit operation.
114 else $ function has one argument.
115 argptr = argbase; a1 = arglist(argptr+1); $ get it.
116 call setq(a1); $ ensure is sized.
117 call emit1(opofbif(bifno),a1,resat); $ do operation.
118 end if;
119
120 push(resat); $ push result.
121 return; $ done.
122
123 /usefcn/ $ here to process user functions.
124 $ first, see if it is in the -voa-.
125 if ep ha(a1) = 0 then $ it isn't.
126 if ermflag & ntexterr = no then $ output message.
127 ermesarg = a1; call ermes(19);
128 end if;
129
130 $ now add entry to -voa-.
131 ep ha(a1) = voptr; var ha(a1) = yes; $ set up -ha-.
132 new = 0; type new = quant; naym new = a1; $ set up -voa-.
133 syze new = mws; isafnct new = yes; $ set more fields.
134 voa(voptr) = new; voaup; $ insert into -voa-.
135
136 elseif type voa(ep ha(a1)) ^= quant then $ not a function.
137 ermesarg = a1; call ermes(33);
138
139 else $ valid.
140 isafnct voa(ep ha(a1)) = yes; $ dont allow as var.
141 if voanl voa(ep ha(a1)) then $ this is a global.
142 nlfnct nl(voanl voa(ep ha(a1))) = yes; $ set global fnct.
143 end if;
144 end if;
145
146 /fnctmerge/ $ here to emit function call.
147 call emcall(n, op_fcall, resat, argbase); $ emit it.
148 argptr = argbase; push(resat); $ push result.
149 return; $ done in this case.
150
151
152 /callcase/ $ this is the case of a subroutine call.
153 $ first, ensure name is in -voa-.
154 if ep ha(a1) = 0 then $ not in yet.
155 ep ha(a1) = voptr; var ha(a1) = yes; $ set up -ha-.
156 new = 0; naym new = a1; $ build -voa- entry.
157 voa(voptr) = new; voaup; $ insert into -voa-.
158
159 elseif type voa(ep ha(a1)) then $ not subroutine.
160 ermesarg = a1; call ermes(34); $ print error message.
161 end if;
162
163 call emcall(n, op_call, resat, argbase); $ emit the call.
164
165 argptr = argbase; $ reset pointer to -arglist-.
166
167 end subr gencall;
1 .=member gencont
2 subr gencont(csap); $ process -cont- statement
3
4 $ this routine generated code for the cont statement and
5 $ is similar to genquit. the cont do statement, however, is
6 $ done separately as the test code for continuation of the
7 $ loop is immediately generated. otherwise the code
8 $ go to test label is generated.
9
10 size csap(ps); $ parameter - -csa- pointer or zero
11 size csapp(ps); $ ptr to csa array
12 size csam(csasz); $ csa element
13 size arithop(ps); $ arithetic operation
14 size comop(ps); $ comparison operation
15
16 .+s66.
17 if csap then $ special call from -genif- for -if (e) con t do-
18 csam = csa(csap); $ get -csa- entry of interest
19 go to contdot; $ process -cont do-
20 end if;
21 ..s66
22 call findcsa(csapp, no);
23 if (csapp = 0) go to errmes; $ error
24 csam = csa(csapp);
25 .+s66.
26 if (testlbl csam = 0) go to contdot; $ this must be -do- for 660
27 ..s66
28 push(testlbl csam) call gengol(op_goto); $ go to testlabel
29 return;
30
31 /errmes/ $ illegal cont statement
32 call ermes(38);
33 return;
34 .+s66.
35 /contdot/ $ do loop cont.
36 $ generate code to increment(decrement) do loop var.
37 $ if(cond) go to body label else go to endlabel
38 if dosignp csam $ code depends on sign of by part.
39 then arithop = op_sub; comop = op_ge; $ by -.
40 else arithop = op_add; comop = op_le; $ by +.
41 end if;
42 $ increment or decrement do var
43 push(dovarp csam) push(dovarp csam)
44 push(doincp csam)
45 call arith(arithop); call genasin(1,0); $ var = var+(-) inc
46 $ perform comparison
47 push(dovarp csam) push(dohip csam)
48 call arith(comop);
49 $ if(cond) go to body label else go to endlabel
50 push(bodylbl csam) call genifgo(op_if);
51 push(endlbl csam) call gengol(op_goto);
52 ..s66
53
54 end subr gencont;
1 .=member gendat
2 subr gendat(case); $ process -data- initialization
3 $ generator for data statements is called in 4 possible cases -
4 $ 1 - data variable is indexed
5 $ 2 - simple data variable
6 $ in both of above cases create new voa entry
7 $ 3 - replication of data value indicated. make one entry
8 $ out of 2 entries ina rglist
9 $ 4 - end of data value list. copy all data value pointers
10 $ from arglist to xarg
11
12 size n(ps); $ number of data values
13 size a1(ps); $ first argument in arglist
14 size a2(ps); $ second argument in arglist
15 size case(ps); $ case of call of routine
16 size new(voasz); $ new voa item
17 size j(ps); $ do loop index
18 size aptr(ps); $ arglist index during copy to xarg
19
20 go to l(case) in 1 to 4;
21 / l(1) / / l(2) /
22 replication = no; $ assume replcation will not occur.
23 new = 0; $ create new voa entry
24 argbeg new = xargptr; $ beginning of data values in xarg array
25 opb new = yes; $ flag as operation
26 opcode new = op_data;
27 if case = 1 then
28 pop(a2); pop(a1); $ retrieve two arguments.
29 call setq(a1);
30 naym new = a1;
31 inp3 new = ep ha(a2);
32 else
33 pop(a1); $ non-indexed variabnle
34 call setq(a1);
35 naym new = a1;
36 end if;
37 $ verify that if data variable is nameset member, then nameset
38 $ is being defined in the current routine.
39 j = mblk voa(ep ha(a1)); $ machine block of variable
40 if mbxha mba(j) then $ if nameset element
41 if mbdef mba(j) = no then
42 ermesarg = a1; call ermes(2);
43 end if;
44 end if;
45
46 replication_origin = argptr;
47 return;
48
49 / l(3) /
50 if replication=no then $ if first replication instance
51 replication = yes; $ note replication occurred.
52 replicate = 0; $ initialize replicate flag list
53 end if;
54
55 a1 = arglist(argptr-1); $ replication value
56 .f. argptr-2, 1, replicate = 1; $ note that this is replication va
57 if conval(a1) <= 0 then
58 call ermes(6); end if;
59 return;
60
61 / l(4) / $ copy data value ptrs to xarg array
62 n = arglist(argptr) + 1;
63 aptr = replication_origin;
64 if (xargptr+n+1)>=xargmax then $ if xarg would overflow,
65 call ermes(8); return; end if; $ issue error, and return.
66 arglen new = n; $ number of arguments in voa entry
67 voa(voptr) = new; voaup; $ add new voa entry to voa
68 do j = 0 to n - 1;
69 xarg(xargptr + j) = 0;
70 xarg_voa xarg(xargptr+j) = ep ha(arglist(aptr));
71 $ now check to see if amode of variable and constant agree
72 if (amode voa(ep ha(naym new)) ^=
73 amode voa(ep ha(arglist(aptr))))
74 call ermes (45 );
75
76 if replication then $ if replication occurred.
77 if .f. aptr, 1, replicate then $ if next is repl. val.
78 aptr = aptr + 1;
79 xarg_rep xarg(xargptr+j) = ep ha(arglist(aptr));
80 end if;
81 end if;
82 aptr = aptr + 1;
83 end do;
84
85 xargptr = xargptr + n;
86 if argptr^=aptr then $ if not all values processed
87 call ermey(7);
88 end if;
89
90 argptr = replication_origin;
91
92 end subr gendat;
1 .=member gendim
2 subr gendim; $ generator for -dims- statement
3 $ check that dimension is in range; if too large, truncate
4 $ to maximum allowed value. if dimension not constant,
5 $ issue error message and return.
6 $ verify that it is meaningful to assign dimension to item
7 $ names; if not, report error and return.
8 $ if item is global variable, save dimension information
9 $ in global names list, nl.
10
11 size dim(ps);
12 size i(ps),j(ps),k(ps);
13 size nln(ps); $ name list index
14 size a1(ps), a2(ps); $ ha ptrs
15
16 pop(a2); pop(a1); $ retrieve two arguments.
17
18 if (signbit voa(ep ha(a2))) call ermes(4); $ negative.
19
20 if conval(a2) > dimsmax then $ dimension too larg
21 call ermes(18); $ so issue error message
22 dim = dimsmax; $ and truncate to maximum allowed
23 else $ if dimension in range
24 dim = conval(a2);
25 end if;
26
27 if ep ha(a1) = 0 then
28 ermesarg = a1; if (ntexterr = no) call ermes(7);
29 return;
30 end if;
31
32 if (type voa(ep ha(a1)) ^= quant) then $ only quantities
33 ermesarg = a1; call ermes(7);
34 return;
35 end if;
36
37 if dim < 1 then $ zero dimension not allowed
38 call ermes(4);
39 dim = 1; return;
40 end if;
41
42 if dimn voa(ep ha(a1)) then
43 /dupdim/
44 ermesarg = a1; call ermes(54);
45 return; end if;
46
47 if isafnct voa(ep ha(a1)) then $ attempt to dimension function
48 ermesarg = a1; call ermes(55); return;
49 end if;
50
51 dimn voa(ep ha(a1)) = dim; $ enter dimension value
52 if (arb voa(ep ha(a1))) return; $ name is used as argument
53 $ name is not argument, so is variable
54 madr voa(ep ha(a1)) = madr voa(ep ha(a1))*dim; $ set correct leng
55 nln = voanl voa(ep ha(a1)); $ get -nl- index
56 if nln then $ var. is global
57 if (nldimn nl(nln)) go to dupdim;
58 nldimn nl(nln) = dim; $ save dimension value
59 end if;
60
61 end subr gendim;
1 .=member gendo
2 subr gendo(case); $ process -do- statement
3 $ this routine implements the do loop opener
4 $ the parameter case may be -
5 $ 1 - initialize - make new csa entry
6 $ 2 - do lloop with no by part. default value is 1
7 $ 3 - do loop with negative bypart
8 $ 4 - do loop with positive bypart
9
10 $ note that local variables are generated for the low do loop
11 $ expression, the hi expression, and the increment expression.
12 $ if any of these expressions are constant, no new variable need
13 $ be generated.
14
15 size case(ps); $ type of call
16 size a1(ps); $ ha pointer of do loop variable
17 size a2(ps); $ ha ptr of low expr
18 size a3(ps); $ ha ptr of hi expr
19 size a4(ps); $ ha ptr of increment
20 size dolo(ps); $ ha ptr of gneerated local variable
21 size dohi(ps); $ generated local variable - hi quant
22 size doinc(ps); $ generated local variabel - increment
23 size blab(ps); $ ha ptr of body label
24 size elab(ps); $ ha ptr of end label
25 size tlab(ps); $ test label
26 size dosign(ps); $ sign of do loop increment
27 size t(ps); $ temporary.
28 size csam(csasz); $ csa element
29
30 if case=1 then
31 $ initialize new csa entry
32 csacountup('dostatement'); $ increment csaptr
33 csam = 0;
34 cstype csam = cstype_do;
35 firstst csam = proclineno;
36 tokorg csam = csatokptr + 1;
37 csa(csaptr) = csam;
38 return;
39 end if;
40
41 $ determine sign of bypart.
42 toknum csa(csaptr) = savetoks;
43 savetoks = 5; $ do not save any more tokens
44 dosign = (case = 3);
45 if case = 2 then push(ha_1); end if; $ no by part.
46 $ default is 1
47 pop(a4); pop(a3); pop(a2); pop(a1);
48 $ a1=var, a2 =lo, a3=hi, a4=inc
49 call setq(a1); $ get do loop variable
50
51 +* getexpr(v, hap) = $hap is ha pointer. if item pointed to
52 $ is a constant, nothing is done, else a local variable v is
53 $ generated and hap assigned to it.
54 v = hap;
55 if hascon ha(hap) = no then
56 call setq(hap); $ make sure value is in -voa-.
57 t = mps; if (syze voa(ep ha(hap)) > t) t = mws; $ size
58 call getdovar(v, t); $ get variable for -do-
59 push(v) push(hap)
60 call genasin(1,0); $ lv = hap
61 end if;
62 **
63
64 dolo = a2; getexpr(dohi, a3) getexpr(doinc, a4)
65 push(a1) push(dolo) call genasin(1,0); $ dovar = dolo
66 labget(elab) $ generated end label
67 if dosign $ determine comparison operator
68 then t = op_lt; $ if 'by -.'
69 else t = op_gt; end if; $ if 'by +.'
70 push(dolo) push(dohi) call arith(t); $ compare ranges.
71 push(elab) call genifgo(op_if); $ if...go to endlabel
72
73 $ define test label for all machines except s66
74 .+s66 tlab = 0; if targetmachine ^= m66 then labget(tlab) end if;
75 .-s66 labget(tlab);
76
77 $ define body label and update csa entry
78 labget(blab) labdef(blab)
79 csam = csa(csaptr);
80 bodylbl csam = blab;
81 endlbl csam = elab;
82 testlbl csam = tlab;
83 dolop csam = dolo;
84 dohip csam = dohi;
85 doincp csam = doinc;
86 dovarp csam = a1;
87 dosignp csam = dosign;
88 csa(csaptr) = csam;
89 $ trace for debugging
90 if trflowfg then trflow(flowdo) end if;
91
92 end subr gendo;
1 .=member genend
2 subr genend; $ generator for -end-.
3 $ this routine processes an -end- statement.
4 size csap(ps); $ -csa- pointer of entry matched.
5 size i(ps); $ loop index.
6
7 $ first, see which opener is matched.
8 call findcsa(csap, yes); $ indicate not just loops.
9
10 $ check if an opener found.
11 if csap then $ a matched opener was found.
12 $ now check to see if this was the last opener.
13 do i = csaptr to csap+1 by -1; $ process each unclosed entr
14 ermesarg = i; call ermes(60); $ print error message.
15 call closer; $ close the opener.
16 end do;
17
18 call closer; $ close the opener.
19
20 else
21 $ a matching opener was not found (even a close match). so
22 $ ignore the -end- statement.
23 call ermes(61); $ print error message.
24 end if;
25
26 end subr genend;
1 .=member genextr
2 subr genextr(opcarg); $ generator for .f., .e., .ch., .s.
3 $ generator for extract - .f., .e., .s., ann .ch. the value of
4 $ opcase is the opcode
5 $ for .ch. operator, in line code is generated. to compute the
6 $ expression .ch. a1, a2 code for
7 $ ((sorg a2) - cs * a1), cs, a2
8 $ is generated. if either a1 or a2 are constant, this code
9 $ can be simplified.
10 size opcase(6); $ opcode
11 size resat(ps); $ result
12 size a1(ps); $ ha ptrs to operands
13 size a2(ps);
14 size a3(ps);
15 size conha1(ps); $ ha constant ptrs
16 size conha2(ps);
17 size opcarg(ps); $ code for extractor type
18
19 opcase = opcarg;
20 if(opcase = 1) go to chext; $ .ch. operation
21 pop(a3); pop(a2); pop(a1); $ retrieve three arguments.
22 call setq(a1); call setq(a2); call setq(a3);
23 chexflg = no; $ show not character extraction.
24 if hascon ha(a2) then $ if length constant,
25 $ if length is zero, return zero.
26 if a2 = ha_0 then push(ha_0); return; end if;
27 if hascon ha(a1) then $ and origin constant,
28 if mod(conval(a1)-1, mws) + conval(a2) > mws then
29 if (opcase=op_fext) opcase = op_eext; $ must be .e.
30 else
31 if (opcase=op_eext) opcase=op_fext; $ may be .f.
32 end if;
33
34 if mod(conval(a2), mcs) = 0 then $ may be character.
35 if mod(conval(a1)-1, mcs) = 0 then $ is character.
36 chexflg = yes; $ it is character extraction
37 end if;
38 end if;
39 else
40 if ((opcase=op_eext)&(a2=ha_1)) opcase=op_fext;
41 $ (convert .e.,...,1, to .f.,...,1, .)
42 end if;
43 end if;
44
45 call emit3(opcase, a1, a2, a3, resat); $ to generate voa entry
46 push(resat);
47 return;
48
49 /chext/ $ generate inline code for the .ch. operation
50 pop(a2); pop(a1); $ retrieve two arguments.
51 $ generate code for sorg a1
52 call setq(a2);
53 pushint((msl+1)); pop(conha1); $ get ha index of sorg value.
54 pushint(mso); pop(conha2); $ get ha index of sorgl value.
55 chexflg = (mod(msl, mcs) = 0 & mod(mso, mcs) = 0);
56 call emit3(op_fext, conha1, conha2, a2, resat);
57 push(resat)
58 $ multiply first character a1 by cs
59 pushint(mcs)
60 push(a1)
61 call arith(op_mul);
62 $ do subtraction
63 call arith(op_sub);
64 pushint(mcs); pop(conha1); $ get ha index of mcs val.
65 call setq(arglist(argptr-1)); call setq(a2); $ check inputs.
66 chexflg = yes; $ show character operation
67 call emit3(op_fext, arglist(argptr - 1), conha1, a2, resat);
68 arglist(argptr - 1) = resat;
69
70 end subr genextr;
1 .=member gengoby
2 subr gengoby; $ -goby- generator
3 $ check that number of labels given is not excessive.
4 $ check that control item is value-producer.
5 $ construct new voa entry with labels kept in xarg,
6 $ noting label uses.
7
8 size n(ps);
9 size i(ps); $ loop index.
10 size new(voasz); $ new voa entry build here if needed
11 size labn(ps); $ label no
12
13 n = arglist(argptr)+1;
14 argptr = argptr-n-1;
15 call setq(arglist(argptr));
16 new = 0;
17 opb new = yes;
18 opcode new = op_goby;
19
20 $ now all labels must be placed on xarg stack
21 arglen new = n;
22 argbeg new = xargptr;
23 $ first check for room on stack
24 if (xargptr+n) > xargmax then $ if -xarg- would overflow
25 call ermes(8); return;
26 end if;
27
28 do i = 1 to n;
29 call setlabl(arglist(argptr+i), labn);
30 xarg_voa xarg(xargptr + i - 1) = labn;
31 end do i;
32
33 inp1 new = ep ha(arglist(argptr));
34 inp3 new = proclineno; $ record position in procedure.
35 isuse(arglist(argptr));
36 xargptr = xargptr + n;
37 voa(voptr) = new; voaup;
38
39 end subr gengoby;
1 .=member gengosl
2 subr gengosl(c); $ generator for subscripted labels
3
4 $ for subscripted label or goto, generate label name and then
5 $ call -gengol-. for switched goto, generate labels and call
6 $ -gengoby-.
7
8 size c(ps); $ case
9 size slname(namsz); $ generated label name
10 size sl(ps); $ length of slname
11 size d(ps); dims d(3); $ digits of generated suffix code
12 size vlo(ws), vhi(ws); $ values of label subscripts
13 size i(ps), l(ps); $ do loop indices
14 size hap(ps); $ ha index of generated name
15 size op(ps); $ operation to be generated
16 size labvar(ps); $ ha index of label array name
17 size lablo(ps), labhi(ps); $ ha indices of subscripts
18 size lv(ps); $ value of integer to be appended to name
19 size lw(ps); $ number of columns sed by vale
20 size a1(ps), a2(ps), a3(ps), a4(ps); $ ha indices of arguments
21
22 go to l(c) in 1 to 4;
23 / l(1) / $ /l(c)/
24 op = op_lab; go to l(4);
25 / l(2) / $ 'go to l(c)'
26 op = op_goto; go to l(4);
27 / l(4) / $ common code for /l(c)/ and 'go to l(c);'
28 pop(a2); pop(a1); $ retrieve two arguments.
29 labvar = a1; lablo = a2; labhi = a2;
30 /def/
31 $ generate labels, call appropriate generators.
32 vlo = val(vbeg voa(ep ha(lablo)));
33 vhi = val(vbeg voa(ep ha(labhi)));
34
35 if (signbit voa(ep ha(lablo))) ! (signbit voa(ep ha(labhi))) !
36 (vlo > 999) ! (vhi > 999) then call ermes(48); return; end if;
37
38 if vlo>vhi then call ermes(47); return; end if;
39
40 $ see if putting these labels on -argstack- would overflow it.
41 if argptr + vhi - vlo > argmax - 15 then $ overflow.
42 call ermes(65); call genexit; $ fatal error.
43 end if;
44
45 do i = vlo to vhi;
46 sdsname(slname, labvar); $ get label array name as sds
47 $ last three digits of generated label taken from
48 $ subscript value.
49 lv = i;
50 d(1) = lv/100; d(2) = mod(lv, 100)/10;
51 d(3) = mod(lv, 10);
52 lw = 1 + (lv>9) + (lv>99); $ num chars in value
53 slen slname = slen slname + 2 + lw;
54 sl = slen slname;
55 .ch. sl, slname = 1r); .ch. sl-lw-1, slname = 1r(;
56 do l = 1 to lw;
57 .ch. sl-l, slname = charofdig(d(4-l));
58 end do;
59 pushname(hap, slname);
60 if (c=4) return;
61 if op then $ if not switch case
62 call gengol(op);
63 end if;
64 end do;
65
66 if op=0 then $ if switch case, call gengoby
67 arglist(argptr) = vhi - vlo; $ gengoby expects lab_count-1
68 call gengoby;
69 end if;
70 return;
71
72 / l(3) / $ 'go to l(e) in e1 to e2'
73 pop(a4); pop(a3); pop(a2); pop(a1); call setq(a2); $ e must be qu
74 $ generate code for goby starting at 1
75 $ goby expression is e-(lo-1), compute it
76 push(a2); $ e
77 push(a3); push(ha_1); call arith(op_sub); $ lo-1
78 call arith(op_sub); $ e - (lo-1)
79 labvar = a1; lablo = a3; labhi = a4;
80 op = 0; go to def;
81 end subr gengosl;
1 .=member gengol
2 subr gengol(op); $ -go- and -/lab/- generator
3 $ single argument a1 is label. note label usage/definition
4 $ according as operation is goto/labeldef.
5 $ construct new voa etnntry, calling blkend if this is a
6 $ label definition, which terminates basic block.
7
8 size a1(ps); $ ptr to ha
9 size op(ps);
10 size labn(ps);
11 size new(voasz); $ new voa entry built here.
12 pop(a1);
13 $ go statement generator routine,combined with
14 $ label routine. both include code emission routine.
15 call setlabl(a1, labn);
16 new = 0;
17 opb new = yes;
18 opcode new = op;
19 naym new = a1; $ index to ha
20 inp1 new = labn; $ index to lablist
21 voa(voptr)=new; voaup;
22 if op=op_lab then
23 call blkend; $ label ends basic block.
24 labldef(voptr, labn);
25 if trflowfg & namintern ha(a1) = no then $ trace flow
26 trflowl = a1; trflow(flowlab); $ trace label
27 end if;
28 end if;
29
30 end subr gengol;
1 .=member genifgo
2 subr genifgo(ifcode); $ process conditional branch
3
4 size ifcode(ps);
5 size labn(ps);
6 size a1(ps), a2(ps); $ ha ptrs
7 size new(voasz); $ new voa entry built here.
8 $ genif calls setq to verify that its first input is a quantity,
9 $ and call setlab to verify that the second argument is a label
10 $ a new voa operation entry is then constructued.
11
12 pop(a2); pop(a1); $ retrieve two arguments.
13
14 $ if input to if is a constant we can evaluate, then we
15 $ replace if by either goto or noop.
16
17 if hascon ha(a1) then
18 .+ifconstat ifcontot = ifcontot+1;
19 if (conval(a1) ^= 0) = (ifcode = op_if) then
20 push(a2); call gengol(op_goto); $ issue goto
21 .+ifconstat ifcongotos = ifcongotos+1;
22 end if;
23 return;
24 end if;
25
26 call setlabl(a2, labn);
27 call setq(a1);
28 if syze voa(ep ha(a1)) > mws then
29 push(a1) push(ha_0)
30 call arith(op_ne); pop(a1);
31 end if;
32 isuse(a1);
33 new = 0;
34 opb new = yes;
35 opcode new = ifcode;
36 inp1 new = ep ha(a1);
37 inp2 new = labn; $ index to label list
38 naym new = a2; $ index to ha
39 voa(voptr)=new; voaup;
40
41 end subr genifgo;
1 .=member genif
2 subr genif(case); $ process -if- statement
3
4 $ process various clauses of if statement, according to
5 $ argument case. meaning of each case given in code below.
6
7 size case(ps); $ type of call
8 size csanew(csasz); $ new csa entry
9 size blab(ps); $ body label ha ptr
10 size elab(ps); $ end label ha ptr
11 size csapp(ps); $ -csa- pointer
12 size t(ps); $ temporary.
13
14 go to l(case) in 1 to 11;
15 / l(1) / $ make new entry in csa array.
16 csanew = 0;
17 csacountup(' if statement');
18 cstype csanew = cstype_if;
19 firstst csanew = proclineno; $ line number in subr
20 tokorg csanew =csatokptr + 1;
21 csa(csaptr) = csanew;
22 return;
23 / l(2) / $ then part.
24 toknum csa(csaptr) = savetoks; $ number of tokens in csatok
25 savetoks = 5; $ to indicate not to save any more tokens
26 labget(blab) $ gnerate body label
27 push(blab) call genifgo(op_ifnot); $ ifnot..go to blab
28 bodylbl csa(csaptr) = blab;
29 csiftype csa(csaptr) = csiftype_then;
30 $ trace for debugging
31 if trflowfg then trflow(flowift) end if;
32 return;
33 / l(3) / $ process simple if statement, issue 'ifnot(a1) go to..'
34 labget(elab) $ generate an end label
35 push(elab) call genifgo(op_ifnot); $ simple statement after
36 $ condition - ifnot...go to endlabel
37 endlbl csa(csaptr) = elab;
38 csiftype csa(csaptr) = csiftype_sif;
39 $ trace for debugging
40 if trflowfg then trflow(flowift) end if;
41 return;
42 / l(4) / $ end of simple staement - define end label
43 elab = endlbl csa(csaptr);
44 if trflowfg then
45 $ trace for debugging
46 trflow(flowifsf) else labdef(elab) end if;
47 savetoks = 5; $ do not save tokens
48 csatokptr = tokorg csa(csaptr) - 1; $ reset ptr to csatok
49 csaptr = csaptr - 1; $ pop coas stack
50 return;
51 / l(5) / $ else part
52 if csiftype csa(csaptr) = csiftype_elseif then
53 elab = endlbl csa(csaptr);
54 elseif csiftype csa(csaptr) = csiftype_else then
55 call ermes(62); return; $ this is an error.
56 else
57 labget(elab); $ get an end label.
58 end if;
59
60 push(elab); call gengol(op_goto); $ go to end label.
61 blab = bodylbl csa(csaptr);
62 if blab = 0 then call ermes(41); return; end if;
63 labdef(blab) $ define bodylabel
64 csiftype csa(csaptr) = csiftype_else;
65 endlbl csa(csaptr) = elab;
66 if trflowfg then
67 $ trace for debugging
68 trflow(flowiff) end if;
69 return;
70 / l(6) / $ if(cond) go to ... this statement form is
71 $ special cased from the simple statement after an if to produce
72 $ better code. one conditional branch only need be gnerated
73 $ instead of a conditional and unconditional branch.
74 savetoks = 5; $ do not save any more tokens
75 csatokptr = tokorg csa(csaptr) - 1; $ reset ptr to csatok
76 csaptr = csaptr - 1;
77 if trflowfg then
78 trflow(flowifgt) $ true part for debugging
79 else call genifgo(op_if);
80 end if;
81 $ trace for debugging
82 if trflowfg then trflow(flowiff) end if;
83 return;
84 / l(7) / $ after 'elseif' in elseif clause
85 $ define body label for previous 'then' or 'elseif', then get
86 $ new body label, generate 'ifnot (e) to to blab'.
87 if csiftype csa(csaptr) = csiftype_then then
88 $ if previous clause is then, generate end label, branch to
89 $ elab, define blab, get new blab, generate
90 $ 'ifnot(e) go to blab;' and set type to elseif type
91 labget(elab); endlbl csa(csaptr) = elab; $ generate end label
92 csiftype csa(csaptr) = csiftype_elseif;
93 elseif csiftype csa(csaptr) = csiftype_elseif then
94 elab = endlbl csa(csaptr);
95 else
96 call ermes(50); return; $ must have 'then' or 'elseif' before
97 end if;
98
99 push(elab); call gengol(op_goto); $ terminate then clause
100 blab = bodylbl csa(csaptr);
101 if blab=0 then call ermes(41); return; end if;
102 labdef(blab);
103 labget(blab); bodylbl csa(csaptr) = blab;
104 if trflowfg then trflow(flowiff) end if;
105 return;
106 / l(8) / $ after 'then' in elseif clause emit conditional branch
107 blab = bodylbl csa(csaptr);
108 if blab=0 then call ermes(41); return; end if;
109 push(blab); call genifgo(op_ifnot);
110 if trflowfg then trflow(flowift) end if;
111 return;
112 / l(9) / $ if (e) go to l(c)
113 $ action similar to case=6, but use gengosl to process
114 $ subscripted label in go to.
115 call gengosl(4);
116 go to l(6); $ now have single label, treat as case=6
117 / l(10) / / l(11) / $ if (e) quit/cont
118 $ special cased by branching to test label for -cont- and
119 $ end label for -quit- except in the case of a -cont do-
120 $ for s66.
121 call findcsa(csapp, no); $ find which loop
122 if csapp = 0 then $ error
123 call ermes(case+27); $ print error message
124 go to l(4); $ attempt to recover
125 end if;
126 if case = 10 then $ quit
127 elab = endlbl csa(csapp); $ get end label
128 else $ cont
129 elab = testlbl csa(csapp); $ get test label
130 end if;
131 .+s66. $ check for -cont do-
132 if elab = 0 then $ have it
133 labget(elab) push(elab) call genifgo(op_ifnot); $ do if
134 endlbl csa(csaptr) = elab; csiftype csa(csaptr) =csiftype_sif;
135 if trflowfg then trflow(flowift) end if;
136 call gencont(csapp); $ generate -cont do-
137 go to l(4); $ now end simple statement
138 end if;
139 ..s66
140 push(elab) go to l(6); $ treat as -if (e) go to-
141
142 end subr genif;
1 .=member genns
2 subr genns; $ process -nameset- declaration
3 size xhap(ps); $ xha index of nameset name
4 size i(ps); $ do loop index
5 size a1(ps); $ ptr to entry in ha of nameset name
6 size csanew(csasz); $ new -csa- entry.
7
8 $ begin nameset definition, see if previous use as nameset.
9 $ if so, return nameset index. otherwise build new nameset entry
10 $ when nameset index obtained, set nstouse to indicate nameset
11 pop(a1);
12 nsflg = yes; $ to indicate processing naemset
13 insglob(xhap, a1); $ add nameset name to xha
14 i = xnsblk xha(xhap); $ get nameset number (index in mba)
15
16 if i=0 then $ if new nameset, we must enter it in mba
17 countup(mbaptr, nblocks, 'nameset');
18 mba(mbaptr) = 0;
19 mbxha mba(mbaptr) = xhap; $ record xha position of name
20 mbdef mba(mbaptr) = yes; $ nameset defined in this routine
21 xnsblk xha(xhap) = mbaptr; $ record nameset index in mba
22 i = mbaptr;
23 end if;
24
25 mbha mba(i) = a1; $ set -ha- index.
26 $ is set
27
28 csanew = 0; $ clear new -csa- entry.
29 cstype csanew = cstype_nameset; $ set opener type.
30 oldmblk csanew = nstouse; $ set old block.
31 firstst csanew = proclineno; $ set line number.
32 tokorg csanew = csatokptr + 1; $ set token list origin.
33 toknum csanew = 1; $ just nameset name.
34 csatokptr = csatokptr + 1; $ get space for token.
35 csatok(csatokptr) = names(nayme ha(a1)); $ get token word.
36 csacountup('nameset'); csa(csaptr) = csanew; $ add new entry.
37 savetoks = 5; $ do not collect tokens.
38
39 nstouse = i; $ set nameset to new one
40 .f. i, 1, accesstab = yes; $ grant access to nameset
41
42 end subr genns;
1 .=member genpad
2 subr genpad(res, a1, a2); $ generator for .pad.
3 $ a1 .pad. a2 pads character string constant a1 with blanks
4 $ to have length a2. a2 must be integer constant.
5 $ if arguments not valid or a2 too large, return a1; otherwise,
6 $ build new constant and hash it in.
7 size res(ps); $ result ha index.
8 size a1(ps), a2(ps); $ working copies of a1, a2.
9 size l1(ps), l2(ps); $ lengths of inputs.
10 size i(ps); $ loop index.
11
12 res = a1; $ set result to a1 in case error.
13 if (const voa(ep ha(a1)) = no) go to err;
14 if (lextype voa(ep ha(a1)) ^= strtok) go to err;
15 if (const voa(ep ha(a2)) = no) go to err;
16 l1 = nchars ha(a1); $ length of string.
17 if (hascon ha(a2) = no) go to err;
18 l2 = conval(a2); $ desired pad length.
19 if (l1>l2) l1 = l2; $ truncate if pad count longer than string.
20 if (l2 > toklenmax) go to err; $ if pad length too long.
21 ccaptr = 0;
22 $ get first string, copy into cca.
23 if l1 then
24 do i = 1 to (l1-1)/cpw + 1;
25 .f. nameorg - i*ws, ws, sdsnamstr =
26 val(vbeg voa(ep ha(a1)) + i - 1);
27 end do;
28 slen sdsnamstr = l1;
29 do i = 1 to l1;
30 ccaptr = ccaptr + 1; cca(ccaptr) = .ch. i, sdsnamstr;
31 end do;
32 end if;
33
34 do i = l1+1 to l2; $ pad with blanks.
35 ccaptr = ccaptr + 1; cca(ccaptr) = 1r ;
36 end do;
37
38 cclt = strtok; call cnvcon;
39 call inscon(res);
40 return;
41 /err/ $ if error, issue message and return a1.
42 call ermes(53); res = a1;
43
44 end subr genpad;
1 .=member genquit
2 subr genquit; $ process -quit- statement
3
4 $ genquit generates code for the quit statement.
5 $ quit and cont statements refer to the innermost while, until,
6 $ or do loop in which it occurs. therefore, when a cont or
7 $ quit statement appers within if-then-else statements the
8 $ csa stack must be searched for the innermost loop. the code
9 $ generated is simply 'go to end label' .
10
11 size csapp(ps); $ -csa- stack pointer.
12
13 call findcsa(csapp, no); $ find loop
14 if (csapp = 0) go to errmes;
15 if (endlbl csa(csapp) = 0) go to errmes;
16 push(endlbl csa(csapp)) call gengol(op_goto); $ go to end labe
17 return;
18
19 /errmes/ $ issue error message - illegal quit statement
20 call ermes(37);
21
22 end subr genquit;
1 .=member genreal
2 subr genreal; $ process -real- declaration
3 $ genreal is the generator routine invoked when processing
4 $ a real declaration in a little program. it sizes the
5 $ variable to word-size and sets the amode field of
6 $ the voa entry associated with the variable to amode_real.
7
8 pushint(rlsz); $ size of real.
9 if targetmachine = m11 then $ does not support reals yet.
10 call ermes(69); $ print error message.
11 else $ ok to build real.
12 buildreal = yes; $ set flag to tell gensiz to build real
13 end if;
14
15 $ real quantity
16 call gensiz;
17 buildreal = no; $ reset flag
18
19 end subr genreal;
1 .=member genret
2 subr genret; $ -return- generator
3 size new(voasz); $ new voa entry built here.
4 size hap(ps); $ dummy -ha- pointer
5 $ genret buils voa entry for return operation
6
7 $ trace for debugging aids
8 if trentrfg then trentry(entrend) end if;
9 if trflowfg then trflow(flowend) end if;
10 if debuglevel = 2 then $ must show exit from routine
11 pushname(hap, debugnames(dbg_subx)); $ push routine name
12 endblock = no;
13 call gencall(call_noparms); $ call routine
14 end if;
15
16 $ for main program, issue call ltlfin(0,0).
17 if mainprogram then
18 pushname(hap, proc_terminate);
19 push(ha_0); push(ha_0);
20 arglist(argptr) = 1; $ two params.
21 call gencall(call_parms);
22 return;
23 end if;
24 new = 0;
25 opb new = yes;
26 opcode new = op_return ;
27 voa(voptr)=new; voaup;
28
29 end subr genret;
1 .=member gensiz
2 subr gensiz; $ -size- generator
3 $ check that size value in range; if too big, truncate to
4 $ allowed maximum size szmax. check that item named can
5 $ can be sized and has not been sized already.
6 $ if sizing global variable, save information in xha,nl.
7
8 size new(voasz); $ used to build new voa entry
9 size sz(ps); $ size value
10 size i(ps); $ do loop index
11 size nssave(ps); $ saves nameset index when localblock forced
12 size nlwd(nlsz); $ nl entry to set
13 size a1(ps);
14 size a2(ps); $ ha ptr
15
16 pop(a2); pop(a1); $ retrieve two arguments.
17 sz = val(vbeg voa(ep ha(a2)));
18 if sz > szmax then $ if size too big.
19 call ermes(32);
20 sz = szmax;
21 elseif sz < 1 then $ if zero, report error and give size mws.
22 call ermes(4);
23 sz = mws;
24 end if;
25
26 $ set trace and check flags
27 tracef ha(a1) = trstorfg; $ set trace flag
28 chinxf ha(a1) = chinxfg; $ set check flag
29 $ now check special 'check' and 'trace' list
30 do i = 1 to dbgcspcp; $ check 'check' stack
31 if dbgcspc(i) = a1 then $ found
32 dbgcspc(i) = 0; $ clear place
33 chinxf ha(a1) = .f. i, 1, dbgcspcf; $ get special value
34 end if;
35 end do;
36
37 do i = 1 to dbgtspcp; $ check 'trace' stack
38 if dbgtspc(i) = a1 then $ found
39 dbgtspc(i) = 0; $ clear place
40 tracef ha(a1) = .f. i, 1, dbgtspcf; $ get special value
41 end if;
42 end do;
43
44 if (ep ha(a1) = 0) go to sizenew; $ sizing.
45 if arb voa(ep ha(a1)) then $ sizing argument
46 if syze voa(ep ha(a1)) then
47 ermesarg = a1; call ermes(56);
48 end if;
49
50 syze voa(ep ha(a1)) = sz; type voa(ep ha(a1)) = quant;
51 if (buildreal) amode voa(ep ha(a1)) = amode_real;
meal 21 if trentrfg & trentrargs then $ call to print argument
53 trentry(2+a1); $ bias of 2 for ha pointer
54 end if;
55 return;
56 end if;
57
58 $ not argument name, see if sizing function begin defined
59 if fswitch & a1 = subinfo(1) then
60 if syze voa(voafnct) then $ re-sizing.
61 ermesarg = a1; call ermes(56);
62 end if;
63
64 syze voa(voafnct) = sz;
65 if (buildreal) amode voa(voafnct) = amode_real;
66 subinfo(3) = voafnct; $ voafnct is loc at which def begins
67 return;
68 end if;
69
70 $ see if this item is already sized.
71 if syze voa(ep ha(a1)) then $ already has size assigned.
72 ermesarg = a1; call ermes(56);
73 end if;
74
75 $ if we get here, something strange is happening, but size the
76 $ item anyway to prevent further errors.
77 syze voa(ep ha(a1)) = sz; $ set size of item.
78 if (buildreal) amode voa(ep ha(a1)) = yes; $ set if real.
79 return;
80
81 /sizenew/
82 new = 0; $ build new voa entry
83 ep ha(a1) = voptr;
84 var ha(a1) = yes; $ is variable
85 if (buildreal) amode new = amode_real;
86 if localforce then $ save current nameset index, force local
87 nssave = nstouse; nstouse = localblock; end if;
88
89 vbeg new = mbchain mba(nstouse); $ set chain to last
90 mbchain mba(nstouse) = voptr; $ this is head of list
91 mblk new = nstouse; $ enter current machine block
92 mbdef mba(nstouse) = yes;
93 mbused mba(nstouse) = yes; $ use of this nameset.
94 madr new = (sz-1)/mws + 1; $ set size in words
95 type new = quant; syze new = sz; naym new = a1;
96 voa(voptr) = new; voaup; $ add at top of voa
97 $ if localforce has been set, we must use local block
98 if localforce then
99 nstouse = nssave; $ restore priod nameset
100 localforce = no; return; end if;
101 if nstouse = localblock then return; end if;
102 $ done if local variable, if
103 $ global names array, so can be used by following routines
104 insglob(i, a1);
105 if nlno xha(i) then $ is global, resizing
106 ermesarg = a1; call ermes(56);
107 return;
108 end if;
109
110 $ add new global variable
111 countup(nlptr, nlmax, 'nl');
112 nlwd = 0;
113 nlsize nlwd = sz; $ save size
114 if (buildreal) nlamode nlwd = amode_real;
115 nlblk nlwd = nstouse; $ save machine block
116 nlha nlwd = i;
117 nltrac nlwd = tracef ha(a1); $ set global trace
118 nlchinx nlwd = chinxf ha(a1); $ set global check
119 nl(nlptr) = nlwd;
120 nlno xha(i) = nlptr;
121 voanl voa(ep ha(a1)) = nlptr; $ link voa to -nl-
122
123 end subr gensiz;
1 .=member gensub
2 subr gensub(casearg); $ fnct / prog / subr generator.
3 size casearg(ps); $ case.
4 size case(ps); $ call case
5 size i(ps); $ loop index.
6 size j(ps);
7 size new(voasz); $ used to build new voa entry
8 size a1(ps); $ ha ptr
9 size xhap(ps); $ xha index of nameset name
10 size temptitle(.sds. (cpw+ cpw*wpc)); $ used to build subtitle
ldse 18 size ta(ws); dims ta(8); $ current time array.
11
12 $ subroutine generator for declaration
13 $ together with function declaration generator
14 $ if an end card does not preceed the present statement, call
15 $ genend, thus effectively inserting an end card.-
16 case = casearg;
17 go to c(case) in 0 to 5; $ select case.
18
19 /c(no)/ /c(yes)/ $ subr/fnct encountered
20 /c(5)/
21 do j = csaptr to 1 by -1; $ end any open blocks.
22 ermesarg = j; call ermes(60); $ print error message.
23 call closer; $ close the block.
24 end do;
25
26 if voptr ^= voafnct then
27 call ermes(57); $ print error message.
28 call purge;
29 end if;
30
31 ntexterr = no; $ clear error flag
32 csaptr = 1;
33 fswitch = (case = 1);
34 mainprogram = (case = 5);
35 if case = 0 then i = cstype_subr;
36 elseif case = 1 then i = cstype_fnct;
37 elseif case = 5 then i = cstype_prog; end if;
38 csa(1) = 0; cstype csa(1) = i; $ set compound statement type.
39 flowgen = 0; $ initialize flow trace counter
40 csatokptr = 0; $ ptr to -csatok- array
41 tokorg csa(1) = 1; $ set save token origin
42 firstst csa(1) = 1; $ set line number.
43 savetoks = 0; $ save tokens
44 dovarptr = 0; dovarbusy = 0; $ clear -do- variables stack
45
46 preludefg = no; $ show not in prelude
47 trentrfg = gtrentrfg; trflowfg = gtrflowfg; $ set initial values
48 trstorfg = gtrstorfg; chinxfg = gchinxfg; $ of debug flags
49 trstorsfg = no; chinxsfg = no; $ clear indicators
50 dbgcspcp = 0; dbgtspcp = 0; $ reset debug stack pointers
51 iovaptr = 0; $ clear list of local io variables
52 iotaptr = 0; $ clear list of saved transmission items
53 $ reset levmin and levnow since routine begins with empty
54 $ ha and voa.
55 levmin = 1;
56 levnow = 1;
57 tlistptr = 0; $ reset temporaries list.
58 curblock = voptr;
59 proclineno = 1; $ reset line number within routine.
60 argct = 0;
61 return;
62
63 /c(2)/ $ have subr/fnct name
64 pop(a1); $ get name
65 new = 0;
66 ep ha(a1) = voptr;
67 var ha(a1) = yes; $ variable type entry
68 naym new = a1; $ link to ha
69 if fswitch = 0 then type new = subrtyp;
70 else type new = quant; end if;
71 voa(voptr) = new; voaup; $ add entry to voa
72 subinfo(1) = a1; $ ptr to current subr
73 sdsname(currsubrname, a1); $ subrname = sds string
74 subinfo(2) = fswitch;
75 if (mainprogram) subinfo(2) = 2;
76 if listsw then $ insert subr/fnct seporator or title
77 if listauto then $ insert title
78 temptitle = ''.pad.(cpw*wpc + cpw); $ temporary title.
79 do i = 1 to listwdsp; $ copy out header line.
80 .f. sorg temptitle - i*ws, ws, temptitle = listwds(i);
81 end do;
82 do i = 1 to 72; $ find first non blank.
83 if (.ch. i, temptitle ^= 1r ) then
84 call stitlr(1, (.s. i, 73-i, temptitle));
85 ejectl; $ start new page.
86 quit do;
87 end if;
88 end do;
89 else $ auto-titling mode not on
90 ejectlp(5); $ dont want only 'subr' line on page
91 endl endl endl $ write default seporator
92 end if;
93 end if;
94 $ insert constants 0 and 1 in ha, save indices
95 ccsyze = 1; cclt = dectok; ccval(1) = 0; ccvalptr=1;
96 ccnchars = 0;
97 call inscon(ha_0);
98 ccsyze = 1; cclt = dectok; ccval(1) = 1; ccvalptr=1;
99 call inscon(ha_1);
100 nsubrs = nsubrs + 1; $ update subroutine count
101 nstouse = localblock; $ use local block for new vars
102 defnstouse = localblock;
103 mba(localblock) = 0; $ clear local block
104
105 $ since purge has cleared ha, set -mbha- fields to 0, and
106 $ reset -used- bits for each global nameset
107 $ (nameset is global if it is in xha)
108
109 do j = 1 to mbaptr;
110 mbha mba(j) = 0;
111 mbused mba(j) = no; $ not yet used in current routine
112 mbdef mba(j) = no; $ clear nameset definition bit
113 mbchain mba(j) = 0; $ clear defined variable chain
114 end do;
115
116 $ nameset of same name as routine name, define new nameset,
117 $ and set default nameset to be this nameset for this routine.
118 if (nsubrs=1) & (gsopt=1) then
119 mbaptr = globalblock; $ block for globals in first procedure
120 nstouse = mbaptr;
121 defnstouse = nstouse; $ set default nameeet
122 mba(mbaptr) = 0;
123 .f. nameorg-cs, cs, sdsnamstr = 1r$; $ set special name for fi
124 pushname(a1, sdsnamstr); $ set to new name for nameset
125 insglob(xhap, a1); $ locate nameset name in xha
126 xnsblk xha(xhap) = mbaptr; $ record machine block (also index
127 $ in mba) for new nameset.
128 mbha mba(mbaptr) = a1;$ record ha index of nameset name
129 mbxha mba(mbaptr) = xhap; $ record xha index of nameset name
130 end if;
131
132 if (nsubrs=2) & (daopt=yes) then $ if default access on, note
133 $ namesets defined in first procedure.
134 do j = 1 to mbaptr;
135 xhap = mbxha mba(j); $ get xha index (nonzero if global )
136 if (xhap=0) cont do; $ not global machine block
137 .f. j, 1, defaccesstab = yes;
138 end do;
139 end if;
140
141 accesstab = defaccesstab; $ reset default access table
142
143 if (nsubrs=1) & (gsopt=yes) then $ if first rout and gsopt,
144 .f. mbaptr, 1, accesstab = yes; $ must grant access to
145 end if; $ the global block being defined in first procedure.
146
147 if crossrefoption then
148 crefput(ncards); $ first line number of routine.
149 $ write page number if listing input, else write 0.
150 i = 0; if (listsw) call contlpr(12,i);
151 crefput(i); $ write page info.
152 crefput((slen currsubrname)); $ length of name.
153 size refpos(ps), refent(ws);
154 refpos = cpw*cs + 1; refent = blankword;
155 do i = 1 to slen currsubrname;
156 refpos = refpos - cs;
157 .f. refpos, cs, refent = .ch. i, currsubrname;
158 if refpos = 1 then
159 crefput(refent);
160 refpos = cpw*cs + 1; refent = blankword;
161 end if;
162 end do;
163 if refpos ^= (cpw*cs+1) then crefput(refent); end if;
164 end if;
165 if mainprogram then $ if program, generate call to ltlini.
166 pushname(i, proc_initiate);
167 push(ha_0);
168 arglist(argptr) = 0; $ one param.
169 call gencall(call_parms);
ldse 19 $ if expire option specified, generate call to ltlced to
ldse 20 $ check expiration.
ldse 21 if expire then
ldse 22 $ lntime gives year in ta(1), day of year in ta(7).
ldse 23 call lntime(ta);
ldse 24 ta(1) = ta(1) + (ta(7) + expire)/365; $ expiry year.
ldse 25 ta(7) = mod(ta(7)+expire, 365); $ expiry day of year.
ldse 26 if (ta(7)=0) ta(7)=1; $ avoid day 0.
ldse 27 $ generate call ltlced(year_expire, day_expire);
ldse 28 pushname(i, proc_expire);
ldse 29 pushint(ta(1)); $ year.
ldse 30 pushint(ta(7)); $ day of year.
ldse 31 arglist(argptr) = 1; $ two args.
ldse 32 call gencall(call_parms);
ldse 33 end if;
170 end if;
171 testdebug; $ see if debug code wanted
172 pushname(a1, debugnames(dbg_subn)); $ push routine name
173 endblock = no; $ dont end block
174 call sdsnamr(naym voa(voafnct)); $ get name of current routin
175 call getxsds(a1, sdsnamstr); $ build constant
176 push(a1); pushint(fswitch+2*mainprogram); $ push parms
177 arglist(argptr) = 1; $ show one parm
178 call gencall(call_parms); $ generate call
179 if trentrfg then trentry(entrrout) end if;
180 return;
181
182 /c(3)/ $ process arguments
183 argct = arglist(argptr)+1; $ number of formal arguments
184 do i = 0 to argct-1;
185 a1 = arglist(argptr-argct+i); $ get argument
186 if ep ha(a1) then $ argument already defined
187 ermesarg = a1; $ set error message number.
188 call ermes(30); cont do;
189 end if;
190
191 new = 0; $ build voa entry
192 ep ha(a1) = voptr; naym new = a1;
193 type new = quant; argno new = i+1;
194 arb new = yes; $ show is argument
195 isavar new = yes; $ show cannot be function.
196 voa(voptr) = new; voaup;
197 end do;
198
199 $ fall through to terminal processing
200
201 /c(4)/ $ end of subr/fnct statement
202 toknum csa(1) = savetoks;
203 savetoks = 5; $ do not save any more tokens
204 if mainprogram & (argct>0) then $ no args to main program
205 call ermes(59);
206 end if;
207
ldsa 66 .+rep.
ldsa 67 if rep_opt_p then $ if reporting procedure definitions
ldsa 68 call putrep(rep_typ, rep_typ_p);
ldsa 69 call putrep(rep_nam, subinfo(1)); $ name
ldsa 70 call putrep(rep_int, subinfo(2)); $ type
ldsa 71 call putrep(rep_int, argct);
ldsa 72 call putrep(rep_end, 0);
ldsa 73 end if;
ldsa 74 ..rep
ldsa 75
208 end subr gensub;
1 .=member genuntl
2 subr genuntl(case); $ process -until- statement
3
4 $ implements an intil loop opener statement.
5 $ if case = 1, make new csa entry of type until.
6 $ generate a goto bodylabel entry in voa, using routine
7 $ gengol.
8 $ if case = 2, definetest label and generate code for
9 $ if...go to end label and then define bodylabel.
10
11 size case(ps); $ type of call
12 size blab(ps); $ body label
13 size tlab(ps); $ test label
14 size elab(ps); $ end label
15 size csanew(csasz); $ new coasa entry
16
17 go to l(case) in 1 to 2;
18 / l(1) /
19 labget(blab) push(blab) call gengol(op_goto); $ generate go to
20 labget(tlab) labdef(tlab)
21 $ body label
22 csacountup('until'); $ increment csaptr
23 csanew = 0; $ build new csa entry
24 cstype csanew = cstype_until;
25 firstst csanew = proclineno;
26 bodylbl csanew = blab;
27 testlbl csanew = tlab;
28 tokorg csanew =csatokptr + 1;
29 csa(csaptr) = csanew;
30 return;
31
32 / l(2) /
33 toknum csa(csaptr) = savetoks;
34 savetoks = 5; $ do not save any more tokens
35 labget(elab) $ generate end label
36 push(elab) call genifgo(op_if); $ generate if..go to elab
37 blab = bodylbl csa(csaptr); $ get body label, already defined
38 labdef(blab)
39 endlbl csa (csaptr) = elab;
40 $ trace for debugging
41 if trflowfg then trflow(flowtil) end if;
42
43 end subr genuntl;
1 .=member genwhil
2 subr genwhil(case); $ process -while- statement
3
4 $ implements a while loop opener statement. if case = 1, make
5 $ new entry in csa stack, flagged as a while type.
6 $ generate a new label definition which is the test label
7 $ if case = 2, generate code for ifnot go to endlabel
8
9 size case(ps); $ type of call
10 size csanew(csasz); $ new entry in csa
11 size elab(ps); $ end label ha ptr
12 size tlab(ps); $ test label ha ptr
13
14 go to l(case) in 1 to 2;
15 / l(1) /
16 labget(tlab) $ generate new label tlab
17 labdef(tlab) $ define new label
18 csacountup('while'); $ increment csaptr
19 csanew = 0; $ make new entry in csa
20 cstype csanew = cstype_while;
21 firstst csanew = proclineno; $ first statement of opener
22 testlbl csanew = tlab;
23 tokorg csanew =csatokptr + 1;
24 csa(csaptr) = csanew;
25 return;
26 / l(2) /
27 toknum csa(csaptr) = savetoks;
28 savetoks = 5; $ do not save any more tokens
29 labget(elab) $ generate end label
30 push(elab) $ on argument stack
31 call genifgo(op_ifnot);
32 endlbl csa(csaptr) = elab;
33 $ trace for debugging
34 if trflowfg then trflow(flowhil) end if;
35
36 end subr genwhil;
1 .=member genfile
2 subr genfile; $ process file declaration
3
4 $ generator for file statement.
5 $ emits call makfile(filename, actname, attributes...)
6 $ the actual filename is restricted to 10 characters
7
8 size i(ps); $ ha index for call generation.
9 size given(ps); $ list of values given.
10
11 $ generate call makf(filename, given, iofilekeys(1),
12 $ ...,iofilekeys(4));
13 given = 0;
14 do i = 1 to 4;
15 $ if attribute given, set bit in -given.
16 $ if attribute not given, pass constant 0 as arg.
17 if iofilekeys(i) then $ if given.
18 .f. i, 1, given = 1;
19 else
20 iofilekeys(i) = ha_0;
21 end if;
22 end do;
23
24 if given ^= 1b'010' & given ^= 1b'011' & given ^= 1b'111' then
25 call ermes(63); return; $ this is an error.
26 end if;
27
28 pushname(i, ionames(ior_makf)); push(iofilename);
29 pushint(given);
30 do i = 1 to 4; push(iofilekeys(i)); end do;
31 endblock = no; $ dont end block
32 arglist(argptr) = 5; call gencall(call_parms);
33
34 end subr genfile;
1 .=member geniost
2 subr geniost(c); $ miscellaneous io generator
3 $ process miscellaneous io generator functions.
4
5 size c(ps); $ action code
6 size a1(ps); $ ha index of first arg, if present
7 size i(ps); $ loop index
8 size keycode(ps); $ function to search string with codes.
9
10 go to l(c) in 1 to 12;
11 /l(1)/ /l(2)/ $ start of put or get, indicate mode
12 iowriting = (c=2);
13 iovabusy = 0; $ free all io-related local variables
14 iotaptr = 0; $ clear list of saved transmission items
15 iofilename = 0;
16 return;
17
18 / l(3) / $ process file name.
19 pop(iofilename);
20 return;
21
22 / l(4) / $ 'get' or 'put' with no file given
23 pushint(1+iowriting); pop(iofilename);
24 return;
25
26 / l(5) / / l(6) / $ indicate whether formatted or unformatted io
27 ioformatted = (c=6);
28 if ioformatted then $ if formated, clear iops.
29 do i = 1 to iopsflds;
30 iopsha(i) = ha_0;
31 end do;
32 end if;
33
34 $ generate validation request.
35 pushname(i, ionames(ior_vali)); push(iofilename);
36 pushint(iowriting + 2*(1-ioformatted));
37 endblock = no; $ dont end basic block
38 arglist(argptr) = 1; call gencall(call_parms);
39 return;
40
41 / l(7) / $ process file definition statement
42 do i = 1 to 4; iofilekeys(i) = 0; end do;
43 go to l(3); $ to process file name
44
45 / l(8) / $ process attribute specifications in file statement
46 pop(a1);
47 $ error if attribute already given.
48 if (iofilekeys(iokey)) call ermes(22);
49 if iokey = 2 then $ iotype
50 if var ha(a1) then
51 sdsname(sdsnamstr, a1);
52 i = keycode(sdsnamstr, $ next line gives iotype encoding
53 '01=get 02=print 03=put 04=read 05=string 06=write 07=release ');
54 if (i) go to fkey;
55 end if;
56
57 $ error if not variable or bad attribute.
58 call ermes(23); return;
59 /fkey/
60 pushint(i); pop(a1); $ set a1 to ha index of i value.
61 end if;
62 iofilekeys(iokey) = a1;
63 return;
64
65 / l(9) / $ process rewind request
66 pop(iofilename);
67 pushname(i, ionames(ior_rwnd)); push(iofilename);
68 endblock = no; $ not end of block
69 push(ha_0) $ indicate no access change.
70 arglist(argptr) = 1; call gencall(call_parms);
71 return;
72
73 / l(10) / $ process filestat request
74 $ generate = ioqu(iofilename, hap) .
75 pop(iofilename); $ get file id.
76 pushname(i, ionames(ior_ioqu)); push(iofilename);
77 pushint(iokey);
78 ermflag = no; $ suppress unsized function diagnostic
79 arglist(argptr) = 1; call gencall(call_value); ermflag=yes;
80 return;
81 /l(11)/ /l(12)/ $ binary io entries.
82 iovabusy = 0; iotaptr = 0;
83 pop(iofilename);
84 iowriting = (c=12);
85 go to l(5);
86 end subr geniost;
1 .=member geniotr
2 subr geniotr; $ generate or stack transmission request
3 $ in unformatted case, do nothing, as -genioit- will issue io
4 $ request.
5 $ in formatted case, call formatted data primitives for stacked
6 $ data items. (items are stacked if multiple items with same
7 $ format, as in ':x:y:z,i(10)'.)
8 size i(ps); $ do loop index
9 size iopshasv(ps); dims iopshasv(iopsflds);
10 size j(ps); $ loop index.
11
12 if (ioformatted=no) return;
13
14 $ if more than one item, must save iopsha since geniops
15 $ clears it at end.
16 if iotaptr > 1 then
17 do j = 1 to iopsflds; iopshasv(j) = iopsha(j); end do;
18 end if;
19
20 do i = 1 to iotaptr;
21 iovar = iotavar iota(i);
22 iolo = iotalo iota(i); iohi = iotahi iota(i);
23 call setq(iovar);
24 if iolo then call setq(iolo); end if;
25 if iohi then call setq(iohi); end if;
26 if i > 1 then $ if must restore iopsha.
27 do j = 1 to iopsflds; iopsha(j) = iopshasv(j); end do;
28 end if;
29 if iowriting
30 then call genpdi;
31 else call gengdi; end if;
32 end do;
33
34 ionameflag = no;
35 iotaptr = 0;
36
37 end subr geniotr;
1 .=member genioit
2 subr genioit(c); $ process io data item specification
3 $ process datum to transmit. if c=1 then have name, perhaps
4 $ of array (implying transmission of all of array);
5 $ if c=2 have array slice, parsed as indexed loads.
6
7 size c(ps); $ case, 1 if single item, 2 if definite slice
8 size hap(ps); $ ha index of generated entries
9 size a1(ps), a2(ps); $ ha indices of arguments
10 size it1(voasz), it2(voasz); $ voa entries for arguments
11 size new(voasz); $ new voa entry for unformatted case
12
13 iolo = 0; iohi = 0; $ assume not slice
14
15 if c=1 then $ variable or expression
16 pop(a1); call setq(a1);
17 it1 = voa(ep ha(a1));
18 if opb it1 = no then $ variable case
19 iovar = naym it1; $ variable to transmit
20 if dimn it1 then $ entire array
21 iolo = ha_1;
22 pushint(dimn it1); pop(iohi);
23 end if;
24 else
25 if opcode it1 = op_xload then $ array element, set lo
26 iovar = naym voa(inp1 it1);
27 iolo = inp3 it1;
28 else
29 iovar = a1;
30 end if;
31 end if;
32 end if;
33
34 if c=2 then $ array slice
35 pop(a2); pop(a1); $ retrieve two arguments.
36 call setq(a1); call setq(a2); $ check inputs.
37 it1 = voa(ep ha(a1)); it2 = voa(ep ha(a2));
38 if ((opb it1 + opb it2) ^= 2) go to baditem;
39 if (opcode it1 ^= opcode it2) go to baditem;
40 if (opcode it1 ^= op_xload) go to baditem;
41 if (inp1 it1 ^= inp1 it2) go to baditem;
42 iovar = naym voa(inp1 it1); $ array being transmitted
43 iolo = inp3 it1; iohi = inp3 it2;
44 if iohi=iolo then iohi = 0; end if;
45 end if;
46
47
48 if ioformatted then $ build iota entry
49 countup(iotaptr, iotamax, 'genioit');
50 iota(iotaptr) = 0; iotavar iota(iotaptr) = iovar;
51 iotalo iota(iotaptr) = iolo; iotahi iota(iotaptr)=iohi;
52 else
53 call setq(iovar);
54 if iolo then call setq(iolo); isuse(iolo); end if;
55 if iohi then call setq(iohi); isuse(iohi); end if;
56 new = 0;
57 opb new = yes; opcode new = op_io;
58 oup new = iowriting;
59 inp1 new = ep ha(iofilename);
60 inp2 new = ep ha(iovar);
dss 62 isuse(iofilename);
dss 63 isuse(iovar);
dss 64 if iolo then inp3 new = ep ha(iolo); isuse(iolo); end if;
62 if iohi then
dss 65 isuse(iohi);
63 xarg_voa xarg(xargptr) = ep ha(iohi);
64 argbeg new = xargptr;
65 countup(xargptr, xargmax, 'genioit');
66 arglen new = 1;
67 end if;
68 voa(voptr) = new; voaup;
69 end if;
70 $ if reading, terminate block since values read
71 if iowriting=no then call blkend; end if;
72 return;
73 /baditem/ $ bad transmission item, build no iota enrytry
74 call ermes(46);
75
76 end subr genioit;
1 .=member gencfi
2 subr gencfi(c); $ process control format.
3 $ process control format, c is 0 if no parameter supplied, and
4 $ one if parameter supplied.
5 size c(ps);
6 size a1(ps); $ ha index of count.
7 size hap(ps); $ ha index.
8
9 if iokey = 5 then $ convert title to a format output.
10 pop(a1);
11 iovar = a1; iolo = 0; iohi = 0;
12 iokey = 1; $ reset to key of a format.
13 arglist(argptr) = 0; $ no args.
dsq 9 call gendfi(0);
15 call genpdi;
16 return;
17 end if;
18 $ check that no parm given for page.
19 if (c) & (iokey = 3) go to err;
20 $ if no parm given, set to one.
21 if c = 0 then push(ha_1); end if;
22 pop(a1); $ get count.
23 pushname(hap, ionames(ior_gcfp));
24 push(a1); pushint(iokey);
25 endblock = no; $ dont end basic block
26 arglist(argptr) = 1; call gencall(call_parms);
27 return;
28 /err/
29 ioerror = yes;
30 call ermes(24);
31
32 end subr gencfi;
1 .=member gendfi
2 subr gendfi(c); $ process data format.
3 size c(ps); $ zero if no args, else one if args given.
4 size ioara(ps); dims ioara(3);
5 $ maxargara gives maximum number of parameters for data
6 $ format, as function of assigned encoding established in parse.
7 size maxargara(ps); dims maxargara(ioformats);
8 data maxargara = 2, 3, 3, 3, 3, 2;
9 size nargs(ps); $ number of arguments.
10 size i(ps); $ loop index.
11
12 ioerror = no;
13 nargs = 0; if (c = 1) nargs = arglist(argptr) + 1;
14 if (nargs > maxargara(iokey)) go to err;
15 if (iolistmode) iopsha(iopsi_lm) = ha_1; $ indicate list mode.
16 if nargs then $ retrieve arguments, if present.
17 argptr = argptr - nargs;
18 do i = 1 to nargs;
19 ioara(i) = arglist(argptr+i-1);
20 end do;
21 end if;
22 do i = nargs+1 to maxargara(iokey); $ clear unspecified args.
23 ioara(i) = ha_0; end do;
24 $ as first approximation to checking consistency of arguments,
25 $ assume that the first parameter specified is field width, and
26 $ that if maximum number of parameters is specified, then last
27 $ is group width. also, for formats with maximum three
28 $ parameters, second is decimal width (e,f) or byte width (b).
29 if ioara(1) then $ first parm is always field width.
30 iopsha(iopsi_fw) = ioara(1);
31 end if;
32 if nargs = maxargara(iokey) then $ if group width given.
33 iopsha(iopsi_gw) = ioara(nargs);
34 end if;
35 if (nargs > 1) & (maxargara(iokey) = 3) then $ if dw (or bw) gi
36 iopsha(iopsi_dw) = ioara(2);
37 end if;
38 iolistmode = no;
39 return;
40 /err/
41 ioerror = yes;
42 call ermes(25);
43
44 end subr gendfi;
1 .=member geniops
2 subr geniops; $ generate io parm. str.
3 size hap(ps); $ ha index.
4 size i(ps); $ loop index.
5 size iopsval(iopssz); $ constant part of parm. str.
6 size varorg(ps); $ if nonzero, index of first nonconst parm
7 size getiov(ps); $ get local variable for io.
8
9 iopsval = 0;
10 $ if target machine word size is less than size of iops,
11 $ iops is multiword, so set high order bit to guarantee that
12 $ multiword parameter string obtained.
13 if (mws < iopssz) then
14 .f. iopssz, 1, iopsval = 1;
15 end if;
16 varorg = 0;
17 do i = 1 to iopsflds;
18 hap = iopsha(i);
19 if (hap = ha_0) cont do;
20 if hascon ha(hap) then $ if constant enter value.
21 .f. iopsorg(i), iopslen(i), iopsval = conval(hap);
22 else $ if non constant, save loc if first.
23 if (varorg = 0) varorg = i;
24 end if;
25 end do;
26
27 if varorg then $ if any variables, generate assigns.
28 iopshap = getiov(iopssz); $ get variable.
29 push(iopshap); pushint(iopsval); $ v = val.
30 call genasin(1, no);
31 do i = varorg to iopsflds;
32 hap = iopsha(i);
33 if (hap = ha_0) cont do;
34 if (hascon ha(hap)) cont do;
35 pushint(iopsorg(i)); pushint(iopslen(i));
36 push(iopshap); push(hap);
37 call genasin(2, no);
38 end do;
39 else $ if all fields constant, hash in constant.
40 pushint(iopsval);
41 pop(iopshap);
42 end if;
43
44 do i = 1 to iopsflds; $ reset iopsha to initial state.
45 iopsha(i) = ha_0;
46 end do;
47
48 end subr geniops;
1 .=member gengdi
2 subr gengdi; $ process -get- for a data item.
3 $ this routine emits a call to a get data formatted routine.
4 $ the format type is indicated by -iokey-. the arguments
5 $ are stored in - iodfitems-.
6 size index(ps); $ ha index of index
7 size nbts(ps); $ number of bits
8 size hap(ps); $ ha index of rout name
9 size datum(ps); $ ha index of datum
10 size array(ps); $ ha index of array
11 size dovar(ps); $ do loop generated variable
12 size getiov(ps); $ returns ha index of io local variable
13
14 if (ioerror) return; $ was a format error - supress call
15 if (ionameflag) call ermes(26); $ namelist request on input
16 index = iolo; datum = iovar;
17 call setq(datum); $ check input.
18 array = 0;
19 nbts = syze voa(ep ha(datum));
20
21 if iolo then $ need a temporary. because of little
22 $ linkage mechanisms, cannot pass
23 $ indexed arrays as parameter to input.
24 $ a temporary is passed, and stored in
25 $ array after call.
26 array = datum;
27 datum = getiov(nbts); $ get io local variable
28 dovar = 0; $ do loop variable
29 if iohi then
30 $ issue a do loop.
31 call gendo(1); $ to initialize
32 dovar = getiov(mps); push(dovar);
33 push(iolo); push(iohi);
34 call gendo(2); $ do dovar = lo to hi (no by part)
35 index = dovar;
36 end if;
37 end if;
38
39 pushint(nbts); pop(hap); $ enter sz field in iops.
40 iopsha(iopsi_sz) = hap;
41 call geniops; $ generate io parm. str.
42 push(iopshap);
43 pushname(hap, ionames(iodfprocs(iokey + ioformats*iowriting)));
44 push(datum) $ first parameter.
45 push(iopshap);
46 arglist(argptr) = 1; $ two params.
47 call gencall(call_parms); $ generate call
48 if array then $ a(i) = temp
49 push(array) push(index) push(datum)
50 call genasin(1, 1); $ simple index assign
51 if (dovar) call closer;
52 end if;
53
54 end subr gengdi;
1 .=member genpdi
2 subr genpdi; $ process request to put data item
3 $ this routine emits a call to a formatted output routine.
4 $ the routine to be called is indicated by the value of
5 $ -iokey-. the arguments are stored in the array -iodfitems-.
6 $ if ionameflag is set, namelist format is specified, and a call
7 $ routine onmlst_name is generate.
8 size datum(ps); $ ha index of datum
9 size dovar(ps); $ ha index of do loop variable
10 size ion(ps); $ index of namelist routine to use
11 size nbts(ps); $ number of bits
12 size hap(ps); $ ha index of routine name
13 size getiov(ps); $ get local variable for io
14 size array(ps); $ ha index of array if array case
15 size index(ps); $ ha index of array element whose name to list
16
17 if (ioerror) return; $ format error - supress
18 datum = iovar;
19 call setq(iovar);
20 array = 0; $ assume not transmitting array element
21 nbts = syze voa(ep ha(iovar));
22
23
24 if iolo then $ if array element(s) involved
25 array = iovar;
26 dovar = 0;
27 if iohi then $ array slice, generate do loop
28 call gendo(1); $ to initialize do loop
29 dovar = getiov(mps); $ get do loop index
30 push(dovar)
31 push(iolo); push(iohi);
32 call gendo(2); $ no by part
33 push(iovar) push(dovar)
34 else $ transmit array(iolo)
35 push(iovar); push(iolo);
36 end if iohi;
37
38 index = arglist(argptr-1); $ save index in case -n- output
39 arglist(argptr) = 0; call gencall(call_value); $ index operati
40 pop(datum);
41 end if iolo;
42
43 if ionameflag then $ namelist output (for variable)
44 if var ha(iovar) = 0 then call ermes(27);return; end if;
45 $ generate call onmv(nameofvariable)
46 if iolo
47 then ion = ior_onma;
48 else ion = ior_onmv; $ simple variable case
49 end if;
50
51 pushname(hap, ionames(ion));
52 sdsname(sdsnamstr, iovar); $ get name of variable as sds
53 call getxsds(hap, sdsnamstr); push(hap); $ get execution form
54 arglist(argptr) = 0; $ one parameter.
55 if iolo then $ if array element, pass index
56 push(index); arglist(argptr) = 1; end if; $ two params.
57 endblock = no; $ not end of basic block
58 call gencall(call_parms);
59 end if ionameflag;
60
61 $ generate call
62 pushint(nbts); pop(hap); $ enter sz field in iops.
63 iopsha(iopsi_sz) = hap;
64 call geniops; $ generate io parm. str.
65 pushname(hap, ionames(iodfprocs(iokey + ioformats*iowriting)));
66 push(datum) $ first parameter.
67 push(iopshap);
68 arglist(argptr) = 1; $ two parameters.
69 endblock = no; $ dont end basic block
70 call gencall(call_parms); $ emit call
71 if (iohi) call closer;
72
73 end subr genpdi;
1 .=member getiov
2 fnct getiov(nb); $ get local variable for io
3 $ obtain local variable of -nb- bits for io. use a free one if
4 $ available, else allocate a new local variable.
5 size getiov(ps); $ ha pointer returned
6 size nb(ps); $ number of bits
7 size v(ps); $ ha index of variable
8 size i(ps); $ -iova- index
9
10 do i = 1 to iovaptr;
11 if (iovasize iova(i) ^= nb) cont do; $ not right size
12 if (.f. i, 1, iovabusy = 0) go to exists; $ if free, assign
13 end do;
14
15 $ build new entry in iova
16 call advstr(lvgen, v); $ get fresh variable name
17 push(v) pushint(nb)
18 localforce = yes; $ make sure gensiz uses local block
19 call gensiz;
20 countup(iovaptr, iovamax, 'getiov');
21 iova(iovaptr) = 0;
22 iovasize iova(iovaptr) = nb;
23 iovaha iova(iovaptr) = v;
24 i = iovaptr;
25 /exists/
26 .f. i, 1, iovabusy = 1; $ mark variable as in use
27 getiov = iovaha iova(i);
28
29 end fnct getiov;
1 .=member blkend
2 subr blkend; $ basic block processor
3 $ terminate basic block. if no instructions in block, then
4 $ return immediately.
5 $ for each voa item in the block:
6 $ if the entry is an operation, obtain a temporary,
7 $ and then for each of its inputs, check for last use of
8 $ input in this block. if last use found, set drop bit
9 $ for later use by machine code generator, as after last use
10 $ need no longer keep items in machine registers.
11
12 size this(voasz); $ copy of voa(voanow)
13 size sz(ps); $ size of temporary
14 size retinp(ps); $ voa index of input examined by retarg.
15 size i(ps);
16 size voanow(ps); $ index of voa item being examined.
17 size opa(6); $ opatr entry for opcode of this item.
18 size mode(1); $ arithmetic mode.
19
20 $ the operator attributes used by blkend are encoded in the
21 $ array opatr, indexed by op code initialized in -kind- array
22 $ in routine start. the attributes are as follows, where 1
23 $ indicates attribute true for this operator class.
24 $ te- op has value, get temporary to hold output value.
25 $ i1- inp1 field has input
26 $ i2- inp2 field has input.
27 $ i3 - inp3 field has input.
28 $ xa - -xarg- stack may have varying list of inputs.
29 $ ou - oup field has input.
30
31 size opatr(6); dims opatr(16);
32 data opatr =
33 $. te i1 i2 i3 ou xa
34 1b' 0 0 0 0 0 0', $ 01. return, data, etc.
35 1b' 1 1 0 0 0 0', $ 02. unary
36 1b' 1 1 1 0 0 0', $ 03. binary
37 1b' 1 1 1 1 0 0', $ 04. field extract
38 1b' 1 0 0 0 0 1', $ 05. function call
39 1b' 0 0 0 0 0 1', $ 06. subroutine call
40 1b' 0 1 1 0 0 0', $ 07. a1 = a2
41 1b' 0 1 1 1 0 0', $ 08. a1(a2) = a3
42 1b' 0 1 1 1 1 0', $ 09. .e. a1, a2, a3 = a4
43 1b' 0 1 1 1 1 1', $ 10. .e. a1, a2, a3(a4) = a5
44 1b' 0 1 0 0 0 0', $ 11. if, goby
45 1b' 1 1 1 0 0 0', $ 12. real binary
46 1b' 1 1 1 0 0 0', $ 13. real comparison
47 1b' 1 1 0 0 0 0', $ 14. real unary
48 1b' 0 1 1 1 0 1', $ 15. unformatted io
49 1b' 1 0 1 0 0 0'; $ 16. indexed load
50
51 +* oa_temp = .e. 06, 01, ** $ 'does oup hold value.'
52 +* oa_inp1 = .e. 05, 01, ** $ 'does inp1 contain input.'
53 +* oa_inp2 = .e. 04, 01, ** $ 'does inp2 contain input.'
54 +* oa_inp3 = .e. 03, 01, ** $ 'does inp3 contain input.'
55 +* oa_oup = .e. 02, 01, ** $ 'does oup contain input.'
56 +* oa_xarg = .e. 01, 01, ** $ 'may xarg contain inputs.'
57
58 $ if there are no instructions in the current block, return
59 $ at once. else set levmin = levnow+1.
60 $ if this overflows the levmin counter, go to over.
61 $ macros used in this routine only, dropped at end
62
63 +* tlist_voa = .e. 01, 11, ** $ voa index of temporary
64 +* tlist_size = .e. 12, 11, ** $ temporary length.
65 +* tlist_free = .e. 23, 01, ** $ 'is temporary free.'
66 +* tlist_mode = .e. 24, 01, ** $ arithmetic mode.
67 +* retarg(f, v, db) = $ return argument, drop field to set.
68 retinp = f v;
69 $ check voa entry indexed by -retinp-. if the lastuse field of
70 $ this entry corresponds to current voa entry (index -voanow-)
71 $ set the drop bit -db-. if lastuse of temporary, indicate
72 $ the temporary no longer busy.
73 $ if this item is a variable or constant, then set the last use
74 $ bit (drop bit) if this entry is the last use of the item.
75
76 if opb voa(retinp) then $ if operation, check lastuse
77 f v = oup voa(retinp); $ replace output pointer by temp..
78 if retinp + lastuse voa(retinp) = voanow & keeb voa(retinp) =
79 no then $ this is last use.
80 tlist_free tlist(vbeg voa(oup voa(retinp))) = yes;
81 db v = yes; $ set drop bit.
82 end if;
83
84 else $ this is a variable or constant.
85 if varluse ha(naym voa(retinp)) = voanow then $ drop bit set
86 db v = yes; $ set drop bit in -voa-.
87 end if;
88 end if;
89 **
90
91 if (curblock >= voptr) return;
92
93 levnow=levnow+1;
94 levmin=levnow;
95 if (levmin >= levmax) then;
96 $ here follows overflow sequence for
97 $ level counter.use same sequence as asign
98 $ make a complete pass over the entire ha array, setting
99 $ the definition level of every variable entry referenced by an
100 $ ha entry to 1, then set levmin = 1 and levnow = 1, go back to
101 $ starter to perform the normal blocked procedure.
102
103 do i = 1 to hamax;
104 if (ep ha(i) = 0) cont do;
105 deflev voa(ep ha(i)) = var ha(i);
106 end do;
107 .+haprobes blkendreset = blkendreset+1;
108 levmin = 1; levnow = 1;
109 end if;
110
111 $ if entry voanow in the voa stack is not an operation entry,
112 $ bypass the steps below by going to next.
113
114 voanow = curblock;
115 /start/
116 if (opb voa(voanow)=no) go to next;
117 this = voa(voanow); $ copy entry
118 sz = syze this;
119 mode = amode this;
120 opa = opatr(blkendtype(opcode this));
121 if (opa=0) go to next; $ if no actions, continue.
122 if oa_temp opa then $ if need output temporary
123 $ locate free temporary of desired size on tlist, constructing
124 $ new one if necessary. nameset -block- contains input argument
125 $ sz giving desired size, and -temp- which is set to voa index
126 $ of temporary.
127 size new(voasz); $ new voa entry for temporary.
128
129 do i = 1 to tlistptr;
130 if (tlist_size tlist(i) ^= sz) cont do;
131 if (tlist_mode tlist(i) ^= mode) cont do; $ if wrong mode.
132 if (tlist_free tlist(i)) go to exists;
133 end do;
134 $ no entry found, construct new temporary.
135 countup(tlistptr, tlistmax, 'gettemp');
136 i = tlistptr;
137 if sz>szmax then $ if size too big, trim it.
dss 66 call ermes(70);
142 sz = szmax; end if;
143 tlist_size tlist(i) = sz; tlist_voa tlist(i) = voptr;
144 tlist_mode tlist(i) = mode;
145 new = 0; temb new = yes; type new = quant;
146 vbeg new = tlistptr; $ save tlist position.
147 syze new = sz;
148 amode new = mode;
149 voa(voptr) = new; voaup;
150 /exists/
151 tlist_free tlist(i) = no;
152 oup this = tlist_voa tlist(i);
153 end if;
154
155 if oa_inp1 opa then $ if inp1 has input
156 $ check for lastuse of temporary.
157 retarg(inp1, this, db1); end if;
158
159 if oa_inp2 opa then $ if inp2 is input
160 retarg(inp2, this, db2); end if;
161
162 if oa_inp3 opa then $ if inp3 is input
163 retarg(inp3, this, db3); end if;
164
165 if oa_oup opa then $ if oup has input
166 retarg(oup, this, dboup); end if;
167
168 if oa_xarg opa then $ if inputs on xarg stack
169 if arglen this then $ if any inputs present
170 do i = argbeg this to argbeg this + arglen this - 1;
171 retarg(xarg_voa, xarg(i), xarg_db);
172 end do;
173 end if;
174 end if;
175
176 voa(voanow) = this;
177
178 /next/
179 voanow = voanow+1;
180 if(voanow < voptr) go to start;
181
182 curblock = voptr;
183
184 macdrop(retarg)
185 end subr blkend;
1 .=member getdovar
2 subr getdovar(hap, sz); $ get variable for -do-
3 $ this routine searches the list of variables obtained for
4 $ bounds and indexes of -do- statements to determine if any
5 $ may be re-used. if not, this routine creates a new one,
6 $ generates a -size- statement, and adds it to the list.
7 size hap(ps); $ -ha- pointer
8 size sz(ps); $ size to assign.
9 size i(ps); $ do loop index
10
11 do i = 1 to dovarptr; $ scan list
12 if .f. i, 1, dovarbusy = 0 then $ found a free one
13 if (dovarsz(i) ^= sz) cont do; $ skip if wrong size.
14 hap = dovars(i); $ get -ha- pointer
15 .f. i, 1, dovarbusy = yes; $ set busy
16 return; $ done
17 end if;
18 end do;
19
20 $ not found, must create a new one.
21 call advstr(lvgen, hap); $ get new variable
22 countup(dovarptr, dovarmax, 'dovars');
23 dovars(dovarptr) = hap; $ insert into list
24 dovarsz(dovarptr) = sz; $ set size of variable.
25 .f. dovarptr, 1, dovarbusy = yes; $ show in use
26 push(hap) pushint(sz) localforce = yes; $ set for -gensiz-
27 call gensiz; $ size it in local block
28
29 end subr getdovar;
1 .=member sortvars
2 subr sortvars; $ sort and assign storage for vars.
3 $ this routine scans each -mba- entry for namesets that are
4 $ defined in the current routine. it then scans the chain of
5 $ defined variables and sorts in order of increasing total size
6 $ (size*dimn). then, storage is allocated for the variable.
7 $
8 $ the sorting method used is a list merge sort from knuth's
9 $ algorithm 5.2.4l with the suggestion given in the answer to
10 $ exercise 12 included.
11 $
12 $ the nodes for 0 and n+1 are voa(1) and voa(voptr),
13 $ respectively, which are always available.
14 $ the array -pq- is used for the variables -p- and -q-
15 $ so that steps l4,l5 and l6,l7 can be written in common.
16 $
17 $ since the variables are chained via the -vbeg- field of the
18 $ -voa-, it is natural to use the high order bit of this field
19 $ to replace the positive and negative links.
20 $
21 $ the macro -vbegs- is the first bit position of the -vbeg-
22 $ field and -vbegl- is the length of the -vbeg- field. note
23 $ that .fb. voamax must be less than vbegl.
24 $
25 .+s66 +* vbegs = 94 ** +* vbegl = 12 **
dss 67 .+s32 +* vbegs = 117 ** +* vbegl = 12 **
dst 30 .+s37 +* vbegs = 117 ** +* vbegl = 12 **
utsa 299 .+s47 +* vbegs = 117 ** +* vbegl = 12 **
dst 31 .+s10 +* vbegs = 109 ** +* vbegl = 12 **
28
29 size mbap(ps); $ -mba- pointer
30 size s(vbegl), t(vbegl); $ list heads
31 size p(vbegl); $ temporary used in scanning list
32 size pq(vbegl); dims pq(2); $ used for -p- and -q-
33 size x(2); $ set to 1 or 2 to index -pq-
34 size addr(ps); $ cumulative address in block
35 size mdr(ps); $ address of variable in block
ldsa 76 size nsha(ps); $ ha index of nameset name.
36
37
38 do mbap = 1 to mbaptr; $ process all blocks
39 if (mbdef mba(mbap) = 0) cont do; $ skip if not defined
40 $ reverse mbchains so that items
41 $ of same volume allocated storage in increasing order.
42 if mbchain mba(mbap) then $ if want reversal.
43 p = mbchain mba(mbap); $ current start.
44 s = vbeg voa(p); $ first item in list.
45 if s then $ if any elements to reverse.
46 vbeg voa(p) = 0; $ current head becomes tail.
47 while s; $ while elements to reverse.
48 t = vbeg voa(s); $ next successor.
49 vbeg voa(s) = p; $ reverse link.
50 p = s; $ move to next item in list.
51 s = t;
52 end while;
53
54 mbchain mba(mbap) = p; $ new header.
55 end if;
56 end if;
57
58 vbeg voa(1) = mbchain mba(mbap); $ set to start of list
59 t = voptr; p = mbchain mba(mbap); $ initialize pointers
60 while vbeg voa(p); $ loop until end of chain
61 s = vbeg voa(p); $ point to next in the list
62 if madr voa(p) > madr voa(s) then $ improper order
63 vbeg voa(t) = s; .f. vbegs+vbegl-1, 1, voa(t) = yes;
64 t = p; $ set up new sublist
65 end if;
66
67 p = s; $ set up for next time through
68 end while;
69
70 vbeg voa(t) = 0; .f. vbegs+vbegl-1, 1, voa(voptr) = 0;
71
72 $ two sublists have been formed. sort may now begin.
73 while 1; $ loop until sorted
74 s = 1; t = voptr; $ initialize for next pass
75 pq(1) = vbeg voa(1); pq(2) = vbeg voa(voptr); $ set heads
76 if (pq(2) = 0) quit while; $ only one list - sorted
77 while pq(2); $ loop until end of pass
78 until pq(x) = 0 ! .f. vbegl, 1, pq(x); $ q <=0
79 x = (madr voa(pq(1)) > madr voa(pq(2)))+1; $ compa
80 .f. vbegs, vbegl-1, voa(s) = pq(x); s = pq(x);
81 pq(x) = vbeg voa(pq(x)); $ set to next in list
82 end until;
83
84 vbeg voa(s) = pq(3-x); s = t; $ set new sublist
85 until pq(3-x) = 0 ! .f. vbegl, 1, pq(3-x);
86 t = pq(3-x); pq(3-x) = vbeg voa(pq(3-x));
87 end until;
88
89 .f. vbegl, 1, pq(1) = no; .f. vbegl, 1, pq(2) = no;
90 end while;
91
92 .f. vbegs, vbegl-1, voa(s) = pq(1); $ clean up for
93 .f. vbegs, vbegl-1, voa(t) = 0; $ next pass
94 end while;
95
96
97 $ list is now sorted by length. proceed to allocate
98 $ storage and clean up tables.
99 p = vbeg voa(1); $ start of sorted list
100 mbchain mba(mbap) = p; $ set for -asm- (if it wants it)
101 addr = 0; $ set at first location in block
ldsa 77 .+rep.
ldsa 78 if rep_opt_g then $ if reporting global declarations
mdsa 1 if voanl voa(p) then $ if global
ldsa 80 nsha = mbha mba(mbap); $ save ha index of nameset name
ldsa 81 end if;
ldsa 82 end if;
ldsa 83 ..rep
102 while p; $ loop over all variables
103 mdr = addr + ((syze voa(p)-1)/mws+1); $ set to var. addre
104
105 $ ensure that arr(0) is in block.
106 if dimn voa(p) ^= 0 & addr < (syze voa(p)-1)/mws + 1 then
107 addr = (syze voa(p)-1)/mws + 1; $ set to leave room.
108 mdr = 2*addr; $ now set starting address.
109 end if;
110
111 addr = addr + madr voa(p); $ set new block end address
112 madr voa(p) = mdr; $ set address in block
113 if voanl voa(p) then $ is global, must set in -nl-
114 nlmadr nl(voanl voa(p)) = mdr; $ set address in -nl-
ldsa 84 .+rep.
ldsa 85 if rep_opt_g then $ if reporting globals.
ldsa 86 call putrep(rep_typ, rep_typ_g);
ldsa 87 call putrep(rep_nam, naym voa(p)); $ variable name
ldsa 88 call putrep(rep_int, syze voa(p)); $ size
ldsa 89 call putrep(rep_int, dimn voa(p)); $ dimension
ldsa 90 call putrep(rep_nam, nsha); $ nameset name
ldsa 91 call putrep(rep_int, mdr); $ offset in block
ldsa 92 call putrep(rep_end, 0);
ldsa 93 end if;
ldsa 94 ..rep
115 end if;
116
117 .f. vbegs+vbegl-1, 1, voa(p) = 0; $ ensure correct chain
118 p = vbeg voa(p); $ point to next in list
119 end while;
120
121 mblen mba(mbap) = addr; $ set length of nameset
ldsa 95 .+rep.
ldsa 96 $ if reporting on globals, give nameset length.
ldsa 97 if rep_opt_g & (mbap>=globalblock) then
ldsa 98 call putrep(rep_typ, rep_typ_n);
ldsa 99 call putrep(rep_nam, nsha);
ldsa 100 call putrep(rep_int, addr); $ nameset length
ldsa 101 call putrep(rep_end, 0);
ldsa 102 end if;
ldsa 103 ..rep
122 end do;
123
124 $ clear -voanl- fields in -voa- because some asms expect zeros.
125 do p = 1 to voptr-1; $ scan -voa-.
126 if (opb voa(p)) cont do; $ skip operations.
127 voanl voa(p) = 0; $ clear field.
128 end do;
129
130 macdrop(vbegs) macdrop(vbegl)
131 end subr sortvars;
1 .=member emass
2 subr emass(storop, nargs); $ emit assignment statement
3 size a5(ps);
4 size storop(ps); $ opcode giving assignment type
5 size new(voasz); $ new voa entry build if needed
6 size a1(ps),a2(ps),a3(ps),a4(ps);
7 $ emit subroutine for store operations
8 $ up to four arguments
9 size i(ps);
10 size j(ps);
11 size nargs(ps); $ number of arguments
12 size this(voasz); $ temporary -voa- entry.
dss 68 size subi(ps); $ ha index of subscript if indexed assign
13
14 $ increment the levnow counter. test for overflow, go to
15 $ go to the overflow case.
16 $ else go to simple, index, subfiel or both
17 $ depending on the parameter n defining the type of assignment
18 $ statement for which macro code is to be generated.
19
20 new = 0;
21 levnow = levnow+1;
22 if levnow > levmax then
23 do i = 1 to hamax;
24 if (ep ha(i) = 0) cont do;
25 deflev voa(ep ha(i)) = var ha(i);
26 end do;
27 .+haprobes emassreset = emassreset+1;
28 levmin = 1; levnow = 1;
29 end if;
30
dss 69 subi = 0; $ assume not indexed assignment.
dss 70
31 go to l(nargs) in 2 to 5;
32 / l(2) / $ a1 = a2.
33
34 pop(a2); pop(a1); $ retrieve two arguments.
35 deflev voa(ep ha(a1)) = levnow;
36 inp2 new = ep ha(a2);
37 inp1 new = ep ha(a1);
38
39 $ we must now show that the last use of the variable to which we
40 $ have just assigned is the last one in the basic block.
41 if varluse ha(a1) >= curblock then $ last used in this block.
42 this = voa(varluse ha(a1)); $ get -voa- entry.
43 j = ep ha(a1); $ get -voa- index for variable.
44 if (inp1 this = j) db1 this = yes; $ set drop bit.
45 if (inp2 this = j) db2 this = yes;
46 if (inp3 this = j) db3 this = yes;
47 if (oup this = j) dboup this = yes;
48 voa(varluse ha(a1)) = this; $ replace entry.
49 if arglen this then $ check any arguments.
50 do i = argbeg this to argbeg this + arglen this - 1;
51 if (xarg_voa xarg(i) = j) xarg_db xarg(i) = yes;
52 end do;
53 end if;
54 end if;
55
56 isuse(a1); isuse(a2); go to rest;
57
58 / l(3) / $ a1(a2) = a3
59 pop(a3); pop(a2); pop(a1); $ retrieve three arguments.
60 deflev voa(ep ha(a1)) = levnow;
61 inp1 new = ep ha(a1);
62 inp2 new= ep ha(a3);
63 inp3 new= ep ha(a2);
64 isuse(a1); isuse(a3);
65 isusenot = hascon ha(a2); $ dont count if constant.
66 isuse(a2); isusenot = no; $ flag and reset.
dss 71 subi = a2; $ a2 is subscript.
67 go to rest ;
68 / l(4) / $ .e. a1, a2, a3 = a4
69 pop(a4); pop(a3); pop(a2); pop(a1);
70 if (a2=ha_0) return; $ if length zero, op is no-op.
71 deflev voa(ep ha(a3)) = levnow;
72 isuse(a3); isuse(a4);
73 isusenot = hascon ha(a1); isuse(a1); $ count unless constant.
74 isusenot = hascon ha(a2); isuse(a2); $ count this unless constan
75 isusenot = no; $ reset flag.
76 inp1 new = ep ha(a3);
77 inp2 new = ep ha(a4);
78 inp3 new = ep ha(a1);
79 oup new = ep ha(a2);
80 bytaln new = chasflg; $ set character mode flag
81 chasflg = no; $ clear for next time
82 go to rest;
83
84 / l(5) / $ .e. a1, a2, a3(a4) = a5
85 pop(a5); pop(a4); pop(a3); pop(a2); pop(a1); $ retrieve five argum
86 if (a2=ha_0) return; $ if length zero, op is no-op.
87 isuse(a3); isuse(a5);
88 isusenot = hascon ha(a1); isuse(a1);
89 isusenot = hascon ha(a2); isuse(a2);
90 isusenot = hascon ha(a4); isuse(a4);
91 isusenot = no; $ reset flag.
92 deflev voa(ep ha(a3)) = levnow;
93 inp1 new= ep ha(a3);
94 inp2 new= ep ha(a5);
95 inp3 new= ep ha(a4);
96 oup new= ep ha(a2);
97 bytaln new = chasflg; $ set character mode flag
98 chasflg = no; $ reset
99 xarg(xargptr) = 0;
100 xarg_voa xarg(xargptr)=ep ha(a1);
101 argbeg new= xargptr;
102 arglen new = 1;
103 countup(xargptr, xargmax, 'xarg');
dss 72 subi = a4; $ a4 is subscript.
104
105 /rest/
dss 73 if subi then $ check if subscript size ok.
dss 74 i = syze voa(ep ha(subi));
dss 75 if (cis_opt>0 & i>cis_opt) call ermes(71);
dss 76 end if;
dss 77
106 opb new = yes;
107 opcode new = storop;
108 voa(voptr)=new;
109 voaup;
110
111 end subr emass;
1 .=member emcall
2 subr emcall(n,ki,resat, argbase); $ build voa entry for call.
3 $ construct voa entry for subroutine or function call,
4 $ with arguments kept in xarg array. note argument uses.
5 $ for a function call, locate a free ha entry and then
6 $ set it to represent function value.
7
8 size n(ps); $ number of parameters.
9 size resat(ps);
10 size argbase(ps); $ arglist index of inputs.
11 size ki(ps);
12 size i(ps); $ do loop temporary
13 size hcode(ps); $ hash-code for ha function search
14 size j(ps), k(ps);
15 size new(voasz);
16 size this(voasz); $ for last use values.
17
18 new = 0;
19 opb new = yes;
20 opcode new = ki;
21 inp3 new = proclineno; $ record line no of call statement
22
23 if n then $ if any arguments.
24 arglen new = n;
25 argbeg new = xargptr;
26 if (xargptr+n)>xargmax then
27 call ermes(8);
28 call genexit; $ overflow case.
29 end if;
30
31 do i = 1 to n; $ put argument pointers into xarg
32 xarg(xargptr+i-1) = 0; $ clear -xarg- entry
33 call setq(arglist(argbase+i)); $ ensure sized.
34 xarg_voa xarg(xargptr+i-1) = ep ha(arglist(argbase+i));
35
36 $ now set the last use bit for this prior useage of
37 $ any arguments.
38 if var ha(arglist(argbase+i)) then $ is a variable or co
39 if varluse ha(arglist(argbase+i)) >= curblock then
40 this = voa(varluse ha(arglist(argbase+i)));
41 j = ep ha(arglist(argbase+i));
42 if (inp1 this = j) db1 this = yes;
43 if (inp2 this = j) db2 this = yes;
44 if (inp3 this = j) db3 this = yes;
45 if (oup this = j) dboup this = yes;
46 voa(varluse ha(arglist(argbase+i))) = this;
47 if arglen this then
48 do k = argbeg this to argbeg this +
49 arglen this - 1; $ all args.
50 if (xarg_voa xarg(k) = j)
51 xarg_db xarg(k) = yes;
52 end do;
53 end if;
54 end if;
55 end if;
56 end do;
57
58 xargptr = xargptr + n;
59 isusenot = yes; $ dont count arguments.
60 do i = 1 to n; $ process all arguments.
61 isuse(arglist(argbase+i));
62 end do;
63
64 isusenot = no;
65 end if;
66
67 naym new = arglist(argbase);
68 syze new = syze voa(ep ha(arglist(argbase)));
dsy 9 deflev new = levnow; $ set definition level
ldsa 104 .+rep.
dsx 37
ldsa 105 $ if rep_opt_c selected, report call. arguments are name of
ldsa 106 $ caller, name of called procedure, and number of arguments.
ldsa 107 if rep_opt_c then
ldsa 108 call putrep(rep_typ, rep_typ_c); $ call
ldsa 109 call putrep(rep_nam, subinfo(1)); $ caller name
ldsa 110 call putrep(rep_nam, arglist(argbase)); $ called name
ldsa 111 call putrep(rep_int, n);
ldsa 112 call putrep(rep_end, 0);
ldsa 113 end if;
ldsa 114 ..rep
69 /ret/
70 if (ki = op_call) go to calcase;
72
73 $ locate empty ha-slot to correspond to returned function value
74 hcode = arglist(argbase); $ use ha index fo hash-code
75 haprobe(i, hcode);
76 if (hainuse ha(i) = no) haquit;
77 haend;
78
79 hainuse ha(i) = yes;
80 ep ha (i) = voptr;
81 amode new = amode voa(ep ha(arglist(argbase)));
82 resat = i; voa(voptr) = new; voaup;
83 return;
84
85 /calcase/
86 seblk new = endblock; voa(voptr) = new; voaup;
87 if endblock = no then
88 endblock = yes;
89 else call blkend; end if;
90 resat = 0;
91
92 end subr emcall;
1 .=member emit1
2 subr emit1(op,a1,resat); $ give voa entry for unary operation
3 size a1(ps);
4 size resat(ps);
5 size op(ps);
6 size j(ps); $ ha index during search
7 size hcode(ps); $ hash code to begin search
8 size sz(ps); $ size of result
9 size new(voasz); $ new voa entry built here if needed
10 size def1(ps), defj(ps); $ deflev values.
11 hcode = a1 * op; $ random value from inputs
12 haprobe(j, hcode); $ search the ha
13 if (hainuse ha(j) = no) go to notfound;
14 if (var ha(j)) hacont; $ ignore variables
15 if (ep ha(j) = 0) hacont; $ ignore if not iv voa
16 if (deflev voa(ep ha(j)) < levmin) go to notfound;
17 if (opcode voa(ep ha(j)) ^= op) hacont;
18 if (inp1 voa(ep ha(j)) ^= ep ha(a1)) hacont;
19 go to found; $ formally identical op. found
20 haend; $ end ha probe
21 /found/
22 def1 = deflev voa(ep ha(a1)); defj = deflev voa(ep ha(j));
23 if (defj < def1) go to notfound; $ arg reassigned.
24 if var ha(a1) = no then $ if op, must be avail in this block.
25 if (def1 < levmin) go to notfound;
26 end if;
27 resat = j; $ redundant calculation.
28 return;
29 /notfound/
30 new = 0;
31 deflev new = levnow;
32 opcode new = op;
33 inp1 new = ep ha(a1);
34 opb new = yes;
35 if realopcd(op) then $ mode is real
36 sz = rlsz; $ size of real
37 amode new = amode_real; $ set to real.
38 elseif op = op_nb ! op = op_fb then
39 sz = mps; $ these return pointer size
40 elseif builtin(op) then sz = mws;
41 else
42 sz = syze voa(ep ha(a1));
43 end if;
44
45 syze new = sz;
46 hainuse ha(j) = yes;
47 ep ha(j)=voptr;
48 isuse(a1);
49 voa(voptr) = new; voaup;
50 resat = j;
51
52 end subr emit1;
1 .=member emit2
2 subr emit2(op,a1,a2,resat); $ give voa entry for binary operation
3 size a1(ps);
4 size a2(ps);
5 size op(ps);
6 size sz(ps); $ size of result
7 size sz1(ps), sz2(ps); $ sizes of inputs
8 size c1(ps), c2(ps); $ string capacities for size of !!.
9 $ (the input arguments and the result arguments are all ha
10 $ item references).
11 size j(ps);
12 size k(ps);
13 size resat(ps);
14 size new(voasz); $ new voa entry built here if needed
15 size hcode(ps); $ hash-code for search
16 $ check to see if this opcode represents a commutative
17 $ operation.
18 $ if it does, rearrange arguments so that the argument with
19 $ the largest voa pointer appears as first argument.
20 if commutes(op) then
21 if ep ha(a1) > ep ha(a2) then $ reorder
22 j=a1; a1=a2; a2=j; end if;
23 end if;
24 $ search the ha array, beginning at a random
25 $ location determined by the opcode and inputs, bypassing
26 $ all entries of variable type.
27 $ search wil find either empty location, or reference to a
28 $ formally identical operation.
29
30 hcode = op + a1 + a2; $ random bits from inputs
31 haprobe(j, hcode);
32 if (hainuse ha(j) = no) go to notfound;
33 if (var ha(j)) hacont; $ ignore variables
34 if (ep ha(j) = 0) hacont; $ ignore if not in voa
35 $ if op of previous block, reuse entry
36 if (deflev voa(ep ha(j)) < levmin) go to notfound;
37 if (opcode voa(ep ha(j)) ^= op) hacont;
38 if (inp1 voa(ep ha(j)) ^= ep ha(a1)) hacont;
39 if (inp2 voa(ep ha(j)) ^= ep ha(a2)) hacont;
40 go to found; $ formally identical op.
41 haend; $ end ha search
42 /found/
43 size defent(ps), defen1(ps), defen2(ps);
44 defent=deflev voa(ep ha(j)); defen1=deflev voa(ep ha(a1));
45 defen2=deflev voa(ep ha(a2));
46 if (defent < defen1) go to notfound; $ if first input changed.
47 if (defent < defen2) go to notfound; $ if second input changed.
48 $ inputs which are operations must have been computed
49 $ in the current block.
50 if var ha(a1) = no then
51 if (defen1 < levmin) go to notfound; end if;
52 if var ha(a2) = no then
53 if (defen2 < levmin) go to notfound; end if;
54 resat = j; $ operation is redundant.
55 return;
56
57 /notfound/
58 sz = 0; $ becomes nonzero when size of result known
59 new=0;
60 opcode new=op;
61 deflev new = levnow;
62 $ real operations have size 1 for comparison, size mws
63 $ for integer-valued functions, and otherwise size rlsz.
64 if realopcd(op) then $ if real operation.
65 if realcomparison(op) then $ if comparison,
66 sz = 1; $ set size to 1.
67 else
68 sz = rlsz;
69 amode new = amode_real;
70 end if;
71 elseif builtin(op) then $ if built-in function
72 sz = mws; $ size of integer.
73 end if;
74 $ now if fetching indexed real quantity,
75 $ set amode field to amode_real
76 if op = op_xload & amode voa(ep ha(a1)) = amode_real then
77 amode new = amode_real;
78 sz = rlsz; $ size of real.
79 end if;
80 inp1 new=ep ha(a1);
81 inp2 new=ep ha(a2);
82 opb new=yes;
83 isuse(a2); isuse(a1);
84 if op=op_xload then $ if indexed load
85 inp3 new = a2; $ save ha index of subscript
dss 78 $ report warning if size greater than index size.
dss 79 if (cis_opt>0 & syze voa(inp2 new)>cis_opt) call ermes(71);
86 end if;
87
88 if sz=0 then $ if size not yet known, compute it
89 sz1 = syze voa(inp1 new);
90 sz2 = syze voa(inp2 new);
91 $ set syze as max of input sizes
92 sz = sz1; if sz=op_gt)&(op<=op_ne) then
dst 33 sz = 1; $ comparison
dst 34 if arithcomparison(op) then $ check operand sizes.
dst 35 if (sz1>mws ! sz2>mws) call ermes(5);
dst 36 end if;
94 elseif op=op_seq ! op=op_sne then sz = 1; $ string comparis
95 elseif (op=op_in) then sz = msl; $ .in.
96 $ for .in., use length of sds length field.
97 elseif op = op_ccat then $ if string concatenation.
98 $ each input contains descriptor fields and only need
99 $ one set of descriptor fields in result.
100 if sz1>=(msl+mso) & sz2>=(msl+mso) then
101 sz = (sz1 + sz2 + mws - 1 - msl - mso)/mws * mws;
102 else
103 call ermes(64); $ print error.
104 sz = sz1 + sz2; $ if either short, take sum.
105 end if;
106
107 elseif op=op_mul then $ if multiplication
108 if (sz1<=mws)&(sz2<=mws) then $ take max if both <=mws
109 $ on s16, force size up to ws.
110 if (targetmachine = m16) sz = mws;
111 else sz = sz1+sz2;
112 end if (sz1;
113 elseif op=op_xload then sz = sz1;
114 end if;
115 end if sz=0;
116
117 syze new = sz;
118 hainuse ha(j) = yes;
119 ep ha(j)=voptr;
120 resat = j;
121 voa(voptr)=new; voaup;
122
123 end subr emit2;
1 .=member emit3
2 subr emit3(op,a1,a2,a3,resat); $ construct voa entry for extract.
3 size a1(ps);
4 size a2(ps);
5 size a3(ps);
6 size k(ws);
7 size resat(ps);
8 size op(ps);
9 size new(voasz); $ used to build new voa fentry
10 size hcode(ps); $ hash code computed
11 size j(ps); $ ha index during search
12 size sz(ps); $ size of extractor
13 size con(ps); $ value if length of extracter is constant
14 size defent(ps), defen1(ps), defen2(ps), defen3(ps);
15 $ emit subroutine for triadic(extract)op
16 hcode = (op .ex. a1) * (a2 .ex. a3); $ hash inputs
17 haprobe(j, hcode); $ search the ha
18 if (hainuse ha(j) = no) go to notfound;
19 if ( var ha(j)) hacont; $ ignore variables
20 if( ep ha(j) = 0) hacont; $ ignre if no voa item
21 if (deflev voa(ep ha(j)) < levmin) go to notfound;
22 $ reuse op from pevious basic block
23 if (opcode voa(ep ha(j)) ^= op) hacont;
24 if (inp1 voa(ep ha(j)) ^= ep ha(a1)) hacont;
25 if (inp2 voa(ep ha(j)) ^= ep ha(a2)) hacont;
26 if (inp3 voa(ep ha(j)) ^= ep ha(a3)) hacont;
27 go to found; $ formally identical op. found.
28 haend; $ end ha probe
29 /found/
30 $ the operation is formally redundant, now check that no
31 $ inputs of type operation have been redefined since the prior
32 $ calculation, and that both the operation and any
33 $ operation-type inputs have been computed in the current
34 $ basic block.
35
36 defent = deflev voa(ep ha(j)); defen1 = deflev voa(ep ha(a1));
37 defen2 = deflev voa(ep ha(a2)); defen3 = deflev voa(ep ha(a3));
38 if (defent < defen1) go to notfound;
39 if (defent < defen2) go to notfound;
40 if (defent < defen3) go to notfound;
41 $ inputs have not changed, see if inputs available in block.
42 if var ha(a1) = no then $ if a1 is op.
43 if (defen1 < levmin) go to notfound; end if;
44 if var ha(a2) = no then $ if a2 is op.
45 if (defen2 < levmin) go to notfound; end if;
46 if var ha(a3) = no then $ if a3 is op.
47 if (defen3 < levmin) go to notfound; end if;
48 resat = j; $ operation is redundant.
49 return;
50
51 /notfound/
52 new = 0;
53 opcode new = op;
54 deflev new = levnow;
55 inp1 new = ep ha(a1);
56 inp2 new = ep ha(a2);
57 inp3 new = ep ha(a3);
58 isuse(a3);
59 isusenot = hascon ha(a1); isuse(a1);
60 isusenot = hascon ha(a2); isuse(a2);
61 isusenot = no;
62 opb new = yes;
63 bytaln new = chexflg; $ set character mode flag
64 chexflg = no; $ clear for next time
65 $ compute size of result, exploiting length if constant
66 con = 0;
67 if hascon ha(a2) then $ if length is constant,put in con.
68 con = conval(a2); end if;
69
70 sz = 0;
71 if op=op_fext then $ if .f. extract,
72 $ use length if is constant, else word size.
73 if con
74 then sz = con;
75 else sz = mws; end if;
76 elseif op=op_eext then $ if .e. extract,
77 $ use length if is constant, else size of source.
78 if (con) sz = con;
79 elseif op=op_sext then $ if .s. extract,
80 $ use length of appropriate sds if constant, else source size.
81 if con then
82 sz = mws*((con*mcs + msl + mso + mws-1)/mws);
83 end if;
84 end if;
85
86 if (sz=0) sz = syze voa(ep ha(a3));
87 syze new = sz;
88 hainuse ha(j) = yes;
89 ep ha(j)=voptr;
90 resat = j;
91 voa(voptr)=new; voaup;
92
93 end subr emit3;
1 .=member setlabl
2 subr setlabl(h, labnum); $ note use as label
3
4 $ this routine receives as input an ha pointer -h- and returns
5 $ a label number 'labnum'. it first checks the 'labno' field
6 $ in the ha , which if non-zero, indicates that the
7 $ label has been used previously. in this case, it returns this
8 $ labno. otherwise, the lablist ptr is incremented, and its new
9 $ value is recorded in the ha and returned as the labnum.
10
11 size h(ps); $ ha pointer
12 size labnum(ps); $ label number
13
14 labnum = labno ha(h); $ retur if use as label already noted
15 if (labnum) return;
16 $ label not used before
17 countup(lablistptr, lablistlen, 'setlabl');
18 labno ha(h) = lablistptr; $ note that name has use as label
19 lablist(lablistptr) = 0;
20 labha lablist(lablistptr) = h; $ link to ha
21 labnum = lablistptr; $ record label number
22
23 end subr setlabl;
1 .=member setq
2 subr setq(a); $ check validity as input.
3 $ verify that ha(a) represents an item which can receive
4 $ or produce a value. if the item is a accessible global
5 $ variable not yet in the ha, use the information saved
6 $ in xha and nl to construct new voa entry.
7 $ in any event, if cannot locate item, create a local
8 $ variable of word-size, to help user continue in
9 $ the absence of the size declaration.
10
11 size i(ps); $ do loop index
12 size a(ps);
13 size new(voasz); $ for building new voa item
14 size xhax(ps); $ pointer to xha, non zero for global
15 size nlp(ps); $ pointeg to nl
16 $ test to see if quantity or calc.if so, ok
17 $ set used and set lastdef
18 $ if other, then error
19 if (var ha(a) = no) go to ret;
20 if (ep ha(a) ^= 0 & type voa(ep ha(a)) = quant) go to checksiz;
21 $ encountered unsized variable,
22 $ first see if global, and if so, page into ha
23 ifaglob(xhax, a) $ see if global
24 if(xhax=0) go to er; $ not global variable, report error
25 $ now page in var from global names list
26 nlp = nlno xha(xhax); $ nl org
27 ep ha(a) = voptr; $ build new voa entry
28 tracef ha(a) = nltrac nl(nlp); $ flag to trace stores
29 chinxf ha(a) = nlchinx nl(nlp); $ flag to check index range
30 $ check for special trace/check
31 if (trstorsfg) tracef ha(a) = trstorfg; $ set if trace/notrace g
32 if (chinxsfg) chinxf ha(a) = chinxfg; $ set if check/nocheck
33 do i = 1 to dbgcspcp; $ check 'check' stack
34 if dbgcspc(i) = a then $ found
35 dbgcspc(i) = 0; $ clear place
36 chinxf ha(a) = .f. i, 1, dbgcspcf; $ get special value
37 end if;
38 end do;
39
40 do i = 1 to dbgtspcp; $ check 'trace' stack
41 if dbgtspc(i) = a then $ found
42 dbgtspc(i) = 0; $ clear place
43 tracef ha(a) = .f. i, 1, dbgtspcf; $ get special value
44 end if;
45 end do;
46
47 new = 0;
48 type new = quant;
49 mblk new = nlblk nl(nlp); madr new = nlmadr nl(nlp);
50 syze new = nlsize nl(nlp); dimn new = nldimn nl(nlp);
51 naym new = a; $ link to ha
52 amode new = nlamode nl(nlp);
53 voanl new = nlp; $ point to -nl-.
54 isafnct new = nlfnct nl(nlp); $ set function flag.
55 voa(voptr) = new; voaup;
56 return;
57
58 /er/
59 ermesarg = a; if (ntexterr = no) call ermes(7); $ report unsized
60 push(a) pushint(mws) localforce = yes; $ set up for -gensiz-
61 call gensiz; $ generate size statemant for variable
62
63 /checksiz/
64 if (syze voa(ep ha(a)) = 0) go to er; $ not sized but in -voa-.
65
66 $ ensure that this is not a function being used as a variable.
67 if isafnct voa(ep ha(a)) & setqfok = no then $ if function.
68 ermesarg = a; call ermes(66); $ print error.
69 isafnct voa(ep ha(a)) = no; $ no longer function.
70 end if;
71
72 setqfok = no; $ clear special case flag.
73
74 /ret/
75
76 end subr setq;
1 .=member isusep
2 subr isusep(hap); $ note use of ha(hap) as input
3 $ macro -isuse- expands into call to this routine.
4 $ if ha(hap) is operation, update lastuse field to reflect use.
5 $ else, add to usage count until overflow and set last use.
6 size hap(ps); $ ha index of item
7 size vop(ps); $ voa index of ha(hap)
8
9 vop = ep ha(hap);
10 if var ha(hap) then $ entry is variable or constant
11 varluse ha(hap) = voptr; $ set last use
12 isavar voa(vop) = yes; $ show usage as variable.
13 if (isusenot) return; $ done if no count.
14 if (varnuse voa(vop)+1 <= varnusemax)
15 varnuse voa(vop) = varnuse voa(vop) + 1;
16 return;
17 end if;
18
19 if voptr-vop <= blockmax then $ if lastuse in range.
20 lastuse voa(vop) = voptr-vop; $ set it.
21 else $ not in range.
22 keeb voa(vop) = yes; $ set overflow bit.
23 end if;
24
25 end subr isusep;
1 .=member putrep
2 .+rep.
3 subr putrep(typ, n); $ put entry to report file
4 $ if report file selected, write entry to report file.
5 size typ(ps); $ typ of entry to be written
6 size n(ws); $ integer value or ha index to write.
7 size typltrs(.cs.); dims typltrs(rep_typ_max);
8 data typltrs(rep_typ_c) = 1rc;
9 data typltrs(rep_typ_g) = 1rg;
10 data typltrs(rep_typ_n) = 1rn;
11 data typltrs(rep_typ_p) = 1rp;
12
13 size nargs(ps); $ number of arguments written
14
15 if typ = rep_typ then $ if start of line
16 put repfile ,x(8) :typltrs(n),r(1) ,x(7);
17 nargs = 0;
18 elseif typ = rep_int then
19 if nargs then put repfile ,','; end;
20 nargs = nargs + 1;
21 put repfile :n,i; $ write integer value
22 elseif typ = rep_nam then $ if want name, n is ha index
23 if nargs then put repfile ,','; end;
24 nargs = nargs + 1;
25 call sdsnamr(n);
26 put repfile :sdsnamstr,a;
27 elseif typ = rep_end then $ if end of line
28 put repfile ,skip;
29 end if;
30 end subr putrep;
31 ..rep
1 .=member purge
2 subr purge; $ cleanse tables, prepare for next routine
3
4 $ reset all stacks and clear the ha. collect statistics on
5 $ table usage.
6
7 size haused(ps); $ no of ha entries used in routine
8 size i(ps);
9
10 haused = 0;
11 do i = 1 to hamax; $ count ha load and clear ha
12 if (hainuse ha(i)) haused = haused+1;
13 ha(i) = 0;
14 end do;
15
16 if haused>loadha then
17 loadha = haused; loadrha = currsubrname; end if;
18 if namesptr > loadnames then $ update max load
19 loadnames = namesptr; loadrnames = currsubrname; end if;
20 namesptr = 1; $ reset names ptr
21 if voptr > loadvoa then $ update voa load count
22 loadvoa = voptr; loadrvoa = currsubrname; end if;
23 voptr = voafnct; $ reset voa for start of definition
24 curblock = voptr; $ set current block to start.
25
26 $ reset xargptr,voptr to next available locations
27 if xargptr > loadxarg then $ update xarg load
28 loadxarg = xargptr; loadrxarg = currsubrname; end if;
29 if valptr > loadval then $ update val load
30 loadval = valptr; loadrval = currsubrname; end if;
31 valptr=1;
32 xargptr=1;
33 if lablistptr > loadlablist then $ update lablist load
34 loadlablist = lablistptr; loadrlablist = currsubrname; end if;
35 lablistptr = 0; $ reset label list origin
36 if tlistptr>loadtlist then $ if new tlist load seen,
37 loadtlist = tlistptr;
38 loadrtlist = currsubrname; end if;
39 levmin = 1; levnow = 1;
40 lvgen = 'v.aa'; labgen = 'l.aa';
41 $ reset local name and label names
42 argptr = 1; arglist(argptr)=0; $ clear arglist
43
44 $ show in prelude for monitoring statements.
45 preludefg = yes; $ show in prelude.
46 accesstab = 0; $ show no accesses in effect.
47 do i = 1 to mbaptr; $ now set all accesses to allow trace statem
48 .f. i, 1, accesstab = yes; $ set bit to allow variables.
49 end do;
50
51 end subr purge;
1 .=member gentrace
2 subr gentrace(fg, case); $ process debug 'trace' statement.
3 $ this generator is called for trace ,notrace debug statements.
4 $ and also for check index.
5 $ the cases are the following -
6 $ 1 - flow 2 - flow with subr name list
7 $ 3 - store 4 - store with variable name list
8 $ 5 - entry 6 - entry with subr name list
9 $ 7 - index 8 - index with variable name list
10 size nargs(ps); $ number of names in namelist
11 size fg(1); $ flag - argument
12 size case(ps); $ case of call - argument
13 size xnl(ps); $ index in nl
14 size xhax(ps); $ ptr to xha
15 size hap(ps);
16 size i(ps), j(ps); $ do loop indexes
17
18 testdebug; $ exit if debugging not wanted
19 if preludefg then $ this is global
20 go to p(case) in 1 to 8;
21 else
22 go to l(case) in 1 to 8;
23 end if;
24
25 / p(1) / $ trace/notrace flow
26 gtrflowfg = fg; $ set global flow flag
27 return;
28 / p(3) / $ trace/notrace stores
29 do i = 1 to nlptr; $ change all trace bits
30 nltrac nl(i) = fg; $ set flag
31 end do;
32 gtrstorfg = fg; $ set global flag
33 return;
34 / p(7) / $ check/nocheck index
35 do i = 1 to nlptr; $ change all c