Forgot your password?
Document Actions
SEM: Semantic pass; second pass of the SET compiler.
SEM: Semantic pass; second pass of the SET compiler. stlsem.opl
1 .=member intro
2$ ssssssss eeeeeeeeee tttttttttt ll
3$ ssssssssss eeeeeeeeee tttttttttt ll
4$ ss ss ee tt ll
5$ ss ee tt ll
6$ sssssssss eeeeee tt ll
7$ sssssssss eeeeee tt ll
8$ ss ee tt ll
9$ ss ss ee tt ll
10$ ssssssssss eeeeeeeee tt llllllllll
11$ ssssssss eeeeeeeee tt llllllllll
12$
13$
14$ ssssssss eeeeeeeeee mm mm
15$ ssssssssss eeeeeeeeee mmm mmm
16$ ss ss ee mmmm mmmm
17$ ss ee mm mmmm mm
18$ sssssssss eeeeee mm mm mm
19$ sssssssss eeeeee mm mm mm
20$ ss ee mm mm
21$ ss ss ee mm mm
22$ ssssssssss eeeeeeeeee mm mm
23$ ssssssss eeeeeeeeee mm mm
24$
25$
26$ t h e s e t l s e m a n t i c p a s s
27$
28$ this software is part of the setl programming system
29$ address queries and comments to
30$
31$ setl project
32$ department of computer science
33$ new york university
34$ courant institute of mathematical sciences
35$ 251 mercer street
36$ new york, ny 10012
37$
38
39
40$ this is the second or semantic pass of the setl compiler. it
41$ translates the polish string produced by the parser into an
42$ internal form known as 'q1' which is used to drive the
43$ optimizer.
44
45$ many of the data structures used in the semantic pass are
46$ specified in the introduction to the optimizer. we recommend
47$ that the user read these comments before continuing.
48
49$ basic design considerations
50$ ---------------------------
51
52$ there are three problem areas in compiling setl. these have motivated
53$ most of the design decisions in the semantic pass.
54$
55$ 1. loop constructs
56$
57$ setl contains a variety of unusual loop constructs. for
58$ example the statement
59$
60$ s1 = << x+1 : x in s st c(x) >>;
61$
62$ involves a loop over 's' to build 's1'. the code for 'x+1'
63$ is actually part of the loop body, even though it comes
64$ befoe the actual loop specification. thus we cannot
65$ generate code for this statement by scanning the program
66$ in a strictly left-right order.
67$
68$ here is another example of the same problem:
69$
70$ loop init open(input);
71$ doing read x;
72$ while x /= nil
73$ term print 'end of file found'; close(input);
74$ do
75$
76$ s with x;
77$ s1 with x+1;
78$ end;
79$
80$ in this case the loop body comes after the loop specification.
81$ however the loop specification includes a block of code which
82$ is performed at the end of the loop. once again we cannot
83$ emit code in left-right order.
84$
85$ one solution to this problem is to have the parser build
86$ a tree, then write a clever tree-walk routine which does
87$ not necessarily process the descendents of each node in
88$ left-right order. this solution is elegent, but requires
89$ mutually recursive routines, something hard to imitate
90$ in little.
91$
92$ the other solution is to emit code in left-right order
93$ saving a pointer to the place where the loop body should
94$ go, then move the body into place once we have finally
95$ processed the whole loop.
96$
97$ this second solution turns out to be quite comfortable,
98$ particularly since we must emit the code as a list anyway.
99$ it also allows the parser to produce the tree in a very
100$ straight forward depth-first left-right ordering, i.e.
101$ reverse polish notation.
102$
103$ the exact mechanism for moving code is discussed in the
104$ next section.
105$
106$ 2. assignments and left hand sides
107$
108$ the second problem area is the treatment of assignments and
109$ left hand sides. let us examine the following on the fly
110$ assignment:
111$
112$ f(x+1, y) := p(a, b)
113$
114$ two problems arise here. first of all, when we see 'f(x+1, y)'
115$ we do not know whether it is a retrieval operation or a left
116$ hand side. thus we do not know what code to generate for it.
117$
118$ second, it may be that 'p' is a function which modifies 'x'
119$ and 'y'. in order to make the program meaningful in this case,
120$ we require that the right hand side of an assignment always
121$ be evaluated before the left hand side. this is another
122$ case where code motion is required.
123$
124$ we encounter another problem with multiple assignments, i.e.
125$
126$ [ [a, b], [c, d] ] := e;
127$
128$ here we must assign 'e' to some temporary, then assign its
129$ components to two other temporaries, and finally assign their
130$ components to a, b, c, and d. in order to generate the
131$ outer assignments first, we must do some kind of top
132$ down tree traversal.
133$
134$ in order to process assignments, we first build trees
135$ for their left and right hand sides, then walk these trees top
136$ down. the trees themselves are built by a rather simple
137$ method: we emit q1 code for both the left and right hand
138$ sides, building a map from each temporary to the instruction
139$ which defines it. this map allows us to walk q1 as if it
140$ were a tree.
141$
142$ a list of instructions is called a 'code fragment'. each code
143$ fragment is identified by two pointers:
144$
145$ prev: pointer to instruction before fragment
146$ last: pointer to last instruction
147$
148$ each temporary can be thought of as being the result of a code
149$ fragment. we provide two maps on temporaries which are used
150$ to identify their code fragment, known as tprev and tlast.
151$ if 't' is a temporary, then tlast(t) is not only the end of
152$ its code fragment, but points to the instruction which
153$ actually generates 't'.
154$
155$ 3. separate compilations
156$
157$ a setl program consists of a set of 'members'. these members
158$ may be compiled together or separately.
159$
160$ the compiler has between one and three input files:
161$
162$ a. the source for the current compilation. this file
163$ contains one or more members, sorted do that each
164$ library and directory staticly preceeds all members
165$ which reference it.
166$
167$ b. a file containing the results of zero or more previous
168$ compilations. this file is refered to as the binder file.
169$
170$ c. a file containing the left justified blank terminated
171$ names of additional 'binder' files which should be processed
172$ after the first binder file.
173$
174$ the semantic pass begins by merging the binder file into
175$ its output file, leaving all relavent symbols in the
176$ symbol table. it then processes all new members contained
177$ on the input file. it aborts if it finds either a previously
178$ compiled member or a reference to a library or directory
179$ which has not already been seen on either the input or
180$ binder file.
181
182
1 .=member mods
2
3
4$ program revision history
5$ ------------------------
6
7$ this section contains a description of each revision to the program.
8$ these descriptions have the following format:
9$
10$ mm-dd-yy jdate author(s)
11$
12$ 1.............15........25............................................
13$
14$ where mm-dd-yy are the month, day, and year, and jdate is the julian
15$ date.
16$
17$ each time a revision is installed, the author should insert a
18$ description after line 'mods.21', and change the macro 'prog_level'
19$ to the current julian date.
20$
21$ ......................................................................
bnda 1
bnda 2
bnda 3$ 01/07/85 85007 s. freudenberger
bnda 4$
bnda 5$ 1. hash non-primitive constants.
bnda 6$ modules affected: genst, gcase4, and msyms.
bnda 7$ 2. make all val-table local to the scope of the symbol.
bnda 8$ modules affected: gcnst1 and ginit.
bnda 9$ 3. set the ft_deref field correctly.
bnda 10$ modules affected: gtpref and mforms.
bnda 11$ 4. improve the error messages for invalid -integer lo..hi- repr.
bnda 12$ modules affected: gtint and ermsg.
sunb 1
sunb 2
sunb 3$ 07/24/84 84206 s. freudenberger
sunb 4$
sunb 5$ 1. introduce program parameters -lcp- and -lcs- to control default
sunb 6$ output: -lcp- controls the listing of program parameters, i.e.
sunb 7$ the initial phase heading; -lcs- controls the listing of the
sunb 8$ final statistics. if both are set, the old listing is generated;
sunb 9$ if neither is set, no output is generated unless an error occurs.
sunb 10$ modules affected: start, semini, and semtrm.
suna 1
suna 2
suna 3$ 02/05/84 84065 s. freudenberger
suna 4$
suna 5$ 1. support motorola mc68000 microprocessor on sun workstation.
suna 6$ modules affected: start, semini, and binder.
suna 7$ 2. correct a sizing error in the form hashing routines.
suna 8$ modules affected: hashf1 and hashf2.
suna 9$ 3. move all q1_stmt quadruples between an unconditional goto and the
suna 10$ end of the basic block before the unconditional goto.
suna 11$ module affected: blkdec.
suna 12$ 4. handle f_gen correctly when checking procedures for based
suna 13$ arguments.
suna 14$ module affected: isfbsd.
smfd 1
smfd 2
smfd 3$ 09/01/83 83244 s. freudenberger
smfd 4$
smfd 5$ 1. correct the is_back flag setting for temporaries in boolean
smfd 6$ expressions.
smfd 7$ module affected: gbin.
smfd 8$ 2. use the new short integer binary file format.
smfd 9$ module affected: putsbi.
smfe 1$ 3. correct the termination test during the jump table expansion for
smfe 2$ the case statement.
smfe 3$ module affected: gcase4.
smfe 4$ 4. modify the loop generators to allow the folding of while, where,
smfe 5$ and until clauses. the new code integrates boolean results.
smfe 6$ modules affected: gunivq, gwhile, gwhere, guntil, and movblk.
smfe 7$ 5. correct the constant folding of the mod function.
smfe 8$ module affected: fldbin.
smfc 1
smfc 2
smfc 3$ 09/01/83 83244 s. freudenberger
smfc 4$
smfc 5$ 1. document and adjust the machine-dependency of integer represen-
smfc 6$ tation in setl binary i/o.
smfc 7$ modules affected: start and putsbi.
smfc 8$ 2. remove the warning message for ambiguous map reprs.
smfc 9$ modules affected: gtmap1 and warn.
smfb 1
smfb 2
smfb 3$ 08/08/83 83220 s. freudenberger
smfb 4$
smfb 5$ 1. improve mode propagation and code generated for arithmetic
smfb 6$ iterators. include form checks as appropriate.
smfb 7$ modules affected: start, garith, fndinc, ermsg, and dblock.
smfb 8$ 2. generate better code for boolean operations. this includes the
smfb 9$ introduction of a new stack, called bstack, and three new opcodes,
smfb 10$ q1_pos, q1_bif, and q1_bifnot (boolean if and ifnot).
smfb 11$ modules affected: start, gstat, gif2, gbin, gun, and dblock.
smfb 12$ module added: gbool (after gbin).
smfb 13$ 2. increase the limit of the control statement stack, cstack.
smfb 14$ module affected: start.
smfb 15$ 3. add a new conditional branch, q1_ifasrt, with the semantics to
smfb 16$ branch to a1 if getipp('assert=1/2') = 0.
smfb 17$ modules affected: start and dblock.
smfb 18$ module deleted: gasrt.
smfb 19$ modules added: gasrt1, gasrt2, and gasrt3.
smfb 20$ 4. increase the size of the rpr_flag for the reprs program parameter.
smfb 21$ the old reprs=1 corresponds to the new reprs >= 1, to allow
smfb 22$ addition of the reprs program parameter in cod.
smfb 23$ modules affected: start, grepr, gcase4, and gputtb.
smfb 24$ 5. correct the declaration for 'close'.
smfb 25$ module affected: inbip1.
smfb 26$ 6. correct the code for -writes all ;- to give only read-access to
smfb 27$ constants. also, print an error message for -libraries all ;-.
smfb 28$ modules affected: ghead4 and ermsg.
smfb 29$ 7. change the name generated for the return value of a routine from
smfb 30$ 'g$name' to 'name(..)'. this improves the readability of messages
smfb 31$ generated by the optimiser.
smfb 32$ module affected: prcdcl.
smfb 33$ 8. insert missing re-initialisation of code table so that the binder
smfb 34$ works properly.
smfb 35$ modules affected: gdef1 and blkdec.
smfb 36$ 9. include a check for previously declared user-defined labels to
smfb 37$ asure that the name actually is a label.
smfb 38$ module affected: glabel.
smfb 39$ 10. generate a separate call block for each user-defined procedure to
smfb 40$ to avoid having to do this in the optimiser.
smfb 41$ module affected: gcall.
smfb 42$ 11. modify the gasn routine to eliminate the type check on parallel
smfb 43$ assignments.
smfb 44$ module affected: gasn.
smfb 45$ 12. include the code to generate case tuples.
smfb 46$ modules affected: gcase4, ermsg, and warn.
smfb 47$ 14. include a check for zero divisor into the fold-binary routine.
smfb 48$ modules affected: fldbin and ermsg.
smfa 1
smfa 2
smfa 3$ 12/16/82 82350 s. freudenberger
smfa 4$
smfa 5$ 1. correct the initialisation of the standard form f_pair.
smfa 6$ module affected: inisym.
smfa 7$ 2. correct the setting of the ft_deref field for local, base, and
smfa 8$ element-of-base forms.
smfa 9$ modules affected: useloc, gbase1, and hashf1.
smfa 10$ 3. check that we actually find a loop to continue or quit on cstack.
smfa 11$ modules affected: gcont, gquit, and findlp.
22
23
24$ 08/12/82 82224 s. freudenberger
25$
26$ 1. string pattern sets have been defined as a separate entity. they
27$ are (still) represented as packed tuples, but are parameterised
28$ to generate byte tables for r32. the necessary form f_pset is
29$ generated.
30$ module affected: inisym.
31$ 2. the form table layout has been changed: the fields 'ft_deref' and
32$ 'ft_imset' have been added, and are set as appropriate.
33$ modules affected: inform, gtmap1, hashf1, hashf2, sputtb, mforms,
34$ and fmdump.
35$ 3. we postpone the check for constant expressions to the semantic
36$ pass, and are thus able to constant fold additional operators.
37$ module affected: gint, greal, gstr, fldbin, foldun, and ermsg.
38$ modules deleted: gsnint and gsreal.
39$ 4. error messages were corrected.
40$ modules affected: findlp and ermsg.
41$ 5. variables aliased to sym_true and sym_false were incorrectly
42$ written onto the sq1 file.
43$ module affected: sputtb.
44$ 6. getint builds a (signed) denotation from the value and hashes it
45$ into the symbol table. before it merely allocated an internal
46$ constant.
47$ module affected: getint.
48$ 7. the form of user-defined labels is correctly set.
49$ module affected: glabel.
50
51
52$ 06/15/82 82166 s. freudenberger
53$
54$ 1. we count the 'case of' of a case statement as a separate
55$ statement.
56$ module affected: (remote text inclusion)
57
58
59$ 06/01/82 82152 s. freudenberger
60$
61$ 1. we added conditional code for the s37 mts implementation.
62$ module affected: semini.
63$ 2. we distinguish, for better diagnostics, inconsistent repr'ing and
64$ attempts to repr formal parameters without repr'ing the associated
65$ procedure.
66$ modules affected: grepr and ermsg.
67$ 3. we initialise and use the ft_low form table field, to hold i, the
68$ minimum value of a 'integer i..j' mode. this makes the ft_nonzero
69$ field superfluous, which hence has been deleted from the setl q1
70$ file.
71$ modules affected: gtpref, gtint, sputtb, and fmdump.
72$ 4. the keyword 'map' is back in the language: first code additions
73$ have been made to support this repr.
74$ modules affected: start, gtmap1, and warn. (warn is temporary.)
75$ 5. an error introduced with the last correction set has been
76$ corrected.
77$ module affected: gdef.
78$ 6. 'gendr1', which is called at the end of a scope before the tables
79$ are written out, has been modified to give better diagnostics for
80$ missing procedures/perform blocks.
81$ module affected: gendr1.
82$ 7. the interation variable of an arithmetic iterator is set to omega
83$ in the term block.
84$ module affected: garith.
85$ 8. 'chkvar' now diagnoses an error whenever an implicit declaration
86$ for a non-local variable is attempted.
87$ module affected: chkvar.
88$ 9. the dimension of ctab has been quadrupled to 100.
89$ module affected: copy.
90$ 10. several error message texts were found to be dead, and were
91$ changed to null strings.
92$ module affected: ermsg.
93$ 11. the mixed-tuple-table dump routine has been rewritten to produce a
94$ more compact listing.
95$ module affected: mtdump.
96$ 12. the error message format of the 'overfl' routine has been changed
97$ to the format used by the 'ermsg' routine.
98$ module affected: overfl.
99
100
101$ 03/16/82 82075 s. freudenberger
102$
103$ 1. a program parameter has been added which allows warnings to be
104$ printed for each unrepr'ed variable. these warnings are only
105$ issued if reprs=1 is specified as well. this work required to
106$ revisit the setting of the is_repr flag, to assure its correct
107$ setting.
108$ new program parameter:
109$ ur=0/1 print warnings for unrepr'ed variables whenever
110$ reprs=1 is specified
111$ modules affected: start, semini, gmemb, ghead7, prcdcl, ginit,
112$ rproc, gmode, gputtb, and warn.
113$ 2. the default value of the 'reprs' program parameter has been
114$ changed to 'reprs=1/1', expressing our increased confidence into
115$ this feature.
116$ module affected: semini.
117$ 3. the keyword 'map' has been reserved again, to be used eventually
118$ for ambiguous map declarations.
119$ module affected: inisym.
120$ 4. the name for the main procedure has been changed from s$main to
121$ _main.
122$ modules affected: inisym and getglb.
123$ 5. the return value for the eof build-in function has been corrected
124$ to f_atom from f_string.
125$ module affected: inbip1 and inibip3.
126$ 6. we allow the syntax 'procedure () ' to declare the return
127$ mode of a parameterless procedure. to this end, we added the new
128$ type processing routine gtprc4.
129$ module added: gtprc4 (after gtprc3).
130$ 7. the <*name> after library, directory, and program is checked to be
131$ in the local scope. otherwise the member's value is not written
132$ with its scope. this change is needed for partial compilation as
133$ well as for the optimiser. we also check the <*name>'s of proce-
134$ dures.
135$ modules affected: gdirct, gprog3, glib, prcdcl, and ermsg.
136$ 8. the symbol table flags is_proc, is_memb, and is_base have been
137$ replaced by test on the ft_type of the symbol's form. this change
138$ modified the sq1- and q1 file formats.
139$ modules affected: gmemb, ghead7, prcdcl, gbase1, gplex, sputtb,
140$ and msyms.
141$ 9. the symbol table flag is_rec has been made part of the sq1- and
142$ q1-files, so that it can be set by the optimiser. this change
143$ modified the sq1- and q1 file formats.
144$ modules affected: prcdcl, sputtb, and msyms.
145$ 10. a new symbol table flag is_init has been added to flag initialised
146$ variables. this flag is part of the sq1- and q1-files, hence
147$ modified the sq1- and q1 file formats. this change removes all
148$ restrictions from the use of init declarations.
149$ modules affected: ginit, grepr, sputtb, msyms, and symdmp.
150$ 11. the form table field ft_low has been made part of the sq1 file,
151$ hence modified the sq1 file format.
152$ module affected: sputtb.
153$ 12. up to now, we never really checked for read-access of a variable:
154$ this has been changed. for the time being, we merely print a
155$ warning message if we use a non-local variable without having
156$ read-access. eventually, this will be changed to an error.
157$ module affected: gdef, chkvar, ermsg, and warn.
158$ 13. we suppress the generation of an internal variable for compound
159$ operators on tuples in the binary form.
160$ module affected: gcomp5.
161
162
163$ 02/01/82 82032 s. freudenberger
164$
165$ 1. the listing output has been moved to start each line in column 1
166$ rather than column 7. dump outputs have not been modified.
167$ modules affected: semini, ermsg, warn, overfl, semtrm, and usratp.
168$ 2. the line layout for error and warning messages has been modified.
169$ modules affected: ermsg and warn.
170$ 3. arithmetic iterators emit code to bypass the loop body if the
171$ increment (decrement) of the loop control variable is zero.
172$ before, such a loop would be infinite.
173$ modules affected: garith and fndinc.
174$ 4. gnexst has been added to emit code for the 'notexists' quantifier.
175$ module added: gnexst (after exist).
176$ 5. gtint now sets the ft_low field for 'integer low .. high' modes.
177$ this field is not yet used, yet should replace the ft_nonzero
178$ eventually.
179$ module affected: gtint.
180
181
182$ 02/01/82 82032 d. shields
183$
184$ use r32 conditional symbol for standard 32-bit fields.
185$ this replaces the field definitions for s32, s37 and s47.
186
187
188$ 01/15/82 82015 s. freudenberger
189$
190$ 1. semini has been modified to print the phase header to the terminal
191$ whenever the new control card parameter 'termh=0/1' is set.
192$ new control card parameter:
193$ termh=0/1 print phase header on the terminal file
194$ module affected: semini.
195$ 2. gcase4 has been modified to always declare the case map as an s-ma
196$ regardless of the reprs control card parameter.
197$ module affected: gcase4.
198$ 3. fix problem in statement number generation (gmprog).
199
200
201$ 11/29/81 81333 d.shields
202$
203$ 1. support s47: amdahl uts (universal timesharing system).
204$ this implementation runs on s37 architecture using an operating
205$ system very close to unix (v7), and uses the ascii character set.
206
207
208$ 10/27/81 81300 s. freudenberger
209$
210$ 1. the setl-fortran interface has been implemented for the
211$ s32, s37, and s66 versions.
212$ the interface uses a communication area which is kept as a
213$ tuple in the setl heap as the symbol intf: sym_intf replaces
214$ sym_spare1.
215$ the actual call to fortran is done by the new built-in function
216$ callf, for which a new q1 symbol table entry was needed.
217$ modules affected: inisym and inibip1.
218$ 2. the reserved words 'spec' and 'unspec' have been deleted.
219$ modules affected: inisym and inibip1.
220
221
222$ 06/24/81 81175 s. freudenberger
223$
224$ 1. a third argument has been added to the q1_free instruction to
225$ specify the argument number. this is needed because otherwise
226$ the code generator can not determine when to free the skip word
227$ of an untyped parameter.
228$ modules affected: start and gcall.
229$ 2. the compiler debugging options rtrs0 and rtrs1 have been dropped.
230$ the runtime statement trace can be control using trace statements
231$ and notrace statements
232$ module affected: inisym.
233$ 3. we initialise the symbol table entries for s$ovar, s$scopes,
234$ s$rnspec, and s$rnames. (see compl for a more detailed account
235$ on what these entries are used for.)
236$ module affected: inisym.
237$ 4. the inbip1 routine has been modified to account for the change
238$ that the setl open function returns a boolean, indicating the
239$ success or failure of this operation.
240$ 5. when we see a program or module statement, we check that it has
241$ been declared in the directory.
242$ modules affected: gprog2, gprog3, gmod2, and ermsg.
243$ 6. we now allow simple programs to access libraries.
244$ module affected: ghead6.
245$ 7. we set the is_memb flag when we have seen a in the
246$ input. this allows us to detect missing members in a separate
247$ compilation.
248$ module affected: ghead7.
249$ 8. there was some confusion about the sequence of imports and
250$ exports lists. this has been taken care of.
251$ modules affected: sethd and gendm.
252$ 9. we reset curmemb to curdir at the end of a non-library member.
253$ module affected: gendm.
254$ 10. the gcnst1 and ginit routines have been modified to set the
255$ is_decl flag of the generated internal variable.
256$ 11. the gcnst1 and ginit routines have been modified to copy only the
257$ val entries of values not in the current scope.
258$ 12. formal paramaters are implicitly repred by the procedure decla-
259$ ration. in particular, if the procedure is not repred, they
260$ are implicitly repred to have the mode general. this is now
261$ checked properly.
262$ module affected: grepr.
263$ 13. local set types based on plex bases must be initialiased in a
264$ static scope with an init statement. this requirement is now
265$ tested for.
266$ module affected: grepr.
267$ 14. only based smaps can have untyped ranges. we perform the requi-
268$ red test now.
269$ module affected: grepr.
270$ 15. we changed the allocation for named constants of mode f_elmt so
271$ that their name depends on the name of the variable it was gene-
272$ rated from. this reduces the number of internal variables re-
273$ alocated during binding.
274$ modules affected: rconst, rinit, and genelt.
275$ 16. we implemented case map optimisation for the case when the case
276$ expression is an element of a base.
277$ module affected: gcase4
278$ 17. the gdomi routine has been modified so that the iterator
279$ variable (t2) is checked for omega, rather than the domain
280$ value (t3).
281$ 18. the table overflow check in readpg has been corrected. it did
282$ check the bias instead of the lower bound of the array slice
283$ being read.
284$ 19. we changed the file format of the sq1 file: constants of mode
285$ f_atom must be the booleans true and false (or symbol table
286$ entries aliased to these two). the sq1 entry for such a constant
287$ now is, indeed, a boolean.
288$ module affected: sputtb.
289
290$ 08/20/81 81232 s. tihor
291$
292$ 1. expand the s32 polish file word format.
293$ 2. expand proctab for ada compiler.
294$ 3. increase the limit on real denotationss.
295
296
297$ 04/02/81 80092 s. tihor
298$
299$ 1. add symbol table support for 20 space variables. the addition
300$ while motivated by the psetl variant work is part of the
301$ general change to a production quality compiler footing.
302
303
304$ 08/30/80 80252 s. tihor
305$
306$ 1. add the ibind parameter which gives the name of a file
307$ of left justified file names which are to be treated as bind
308$ files successively.
309$ 2. add code to read files in.
310$ 3. alter gcnst and ginit proc to copy their value table entries
311$ into the val table slice that correspondes to the current
312$ symtab slice.
313$ 4. increase proctab_lim by 100 to 200 for ada.
314$ 5. check in greal for bad number (overflow, etc.)
315$ 6. get name of terminal file from little.
316
317
318$ 12/02/80 80337 s. freudenberger
319$
320$ 1. 'cstmt_count', the cummulative statement counter, and
321$ 'ustmt_count', the cstmt_count at the start of the current
322$ compilation unit, have been initialized to zero (rather
323$ than one). they are incremented now in gstat1 before they
324$ are used, thus giving different cstmt-counts for the last
325$ statement of the previous unit and the first statement of
326$ the current unit.
327
328
329$ 11/05/80 80310 s. freudenberger
330$
331$ 1. the string comparisons of the file titles in semini has been
332$ corrected to use the .seq. operator, and not bit string
333$ equality.
334$ 2. the standard form f_uset does not set the is_neltok bit
335$ anymore.
336$ 3. semtrm has been modified to write an additional zero for
337$ the q1 tail record. this is a consequence of change (2)
338$ recorded on 07/08/80 (80190).
339$ 4. packed integer ranges have been restricted to exclude zero.
340$ this was necessary because the pack key for the range
341$ integer i .. j stores the integer i-1: for i=0, this would
342$ mean that we attempt to store -1.
343$ 5. for remote objects, the test that they are not based on a
344$ plex base has been moved so that it will cover remote sets
345$ as well.
346$ 6. the form dump routine (fmdump) has been updated to reflect
347$ the form table changes described in compl.
348
349
350$ 09/08/80 80252 s. freudenberger
351$
352$ 1. the hash table header arrays for the symbol- and form tables
353$ have been increased for s32 and s37.
354$ 2. the hash table header array for the form table has been moved
355$ into member start. the nameset fheads has been eliminated.
356$ 3. the form table entry for f_pair is initialized to zero.
357
358
359$ 08/18/80 80231 s. freudenberger
360$
361$ 1. the mode prefix map is initialized completely.
362$ 2. for set formers, the code sequence emitted for has been
363$ changed for the case where is not temporary:
364$ the result of always is a temporary.
365$ this change has been made to facilitate the handling of set
366$ formers in the optimizer.
367$ 3. the bind file read statement has been corrected to reflect
368$ the recent q1 file format change.
369
370
371$ 08/01/80 80214 s. freudenberger
372$
373$ 1. the gasn routine has been re-visited to special case an
374$ optimization: if a routine returns a tuple, it is assigned
375$ to a temporary, which has form general, which would mean
376$ a type check. in this case, however, we like to propagate
377$ the proper form onto the internal variable generated to
378$ replace the temporary. this is done now.
379$ 2. the new conditional assembly member of compl replaces the
380$ section 'conditional assembly' of member start.
381
382
383$ 07/10/80 80192 s. freudenberger
384$
385$ 1. a new q1 opcode has been introduced: q1_error. it is emitted
386$ in procedure scopes whenever an error is diagnosed, and whenever
387$ the parser signaled an error.
388$ 2. the line "parse error limit..." is not echoed to the terminal
389$ anymore.
390
391
392$ 07/09/80 80191 s. freudenberger
393$
394$ a dependency on the grammar and ltlsyn output has been parameterized.
395
396
397$ 07/08/80 80190 s. freudenberger
398$
399$ 1. the end of both the polish and auxiliary polish files are
400$ marked by a special polish node. the driver routine checks
401$ for this special node to terminate.
402$ 2. once again, efforts have been made to synchronize statement
403$ numbers between the parser, semantic pass, code generator,
404$ and the run-time library. this time it is done by recording
405$ the cummulative statement number of the q1_entry instruction so
406$ that the code generator can insert the proper statement number
407$ into the statement quadruples.
408$ 3. the semantic of compound assignments has been made more precise:
409$ the right-hand side must be a tuple. the only exception occurs
410$ in the seti and domi routines, where we like to assign omega to
411$ the iteration variables. these assignments are special cased in
412$ the gasn routine, and a flag (a new third parameter) marks this
413$ case.
414$ 4. the tprev pointer for the temporary used in the code sequence
415$ generated for the query operator (-?-) is set properly.
416$ 5. the line "no errors..." is not echoed to the terminal anymore.
417$ 6. the layout of the title line has been changed.
418
419
420$ 06/20/80 80172 s. freudenberger
421$
422$ 1. a bug related to the global string specifiers has been corrected.
423$ 2. the gasn routine has been modified so that is does not generate
424$ the check for omega if the right-hand side is known to be a tuple.
425
426
427$ 05/27/80 80148 s. freudenberger
428$
429$ 1. the nelt field of the embedded tuple of a remote map is not
430$ maintained. consequently the ft_neltok flag must not be set.
431
432
433$ 05/09/80 80130 s. freudenberger
434$
435$ 1. the last correction set misplaced some lines conditioned to s10.
436$ these lines are hereby deleted.
437$ 2. we now allow omegas in constants. the result of constant folding
438$ on [ [om, 1] ] is f_uset, as [om, 1] is not a pair.
439$ 3. 'gasn' has been modified to diagnose constant right hand sides
440$ correctly in '[x, y, ..., z] := const'.
441$ 4. a new global flag has been added to control the processing of
442$ user-supplied representation statements: rpr_flag. this flag
443$ can be set via the new reprs control card parameter.
444$ 5. the code sequence generated for the query operator has been
445$ changed to suppress evaluation of the right operand if the
446$ left operand is not omega. the q1_query operator has been
447$ eliminated.
448$ 6. the standard symbol is_primitive and the q1_isprim operator
449$ have been eliminated.
450
451
452$ 04/11/80 80102 d. shields
453
454$ 1. increase astack limit for s32 - this needed for lalr and
455$ ada work. other implementations desiring to use these
456$ products should be adjusted accordingly.
457$ 2. delete cdc update yankdeck directives.
458$ 3. avoid use of '0' null file. this needed since s10 env does
459$ not support this, and code conditioned by s10.
460
461
462
463$ 04/09/80 80100 s. freudenberger
464$
465$ 1. the gasn routine has been modified to produce correct code for
466$ (/ x1, ..., xn /) := om;
467$ 2. the gseti and gdomi routines have been modified to set all
468$ iteration variables to omega, as specified in the semantic
469$ definition of setl.
470$ 3. an equality test in the getglb routine has been corrected to
471$ check character string equality rather then bitstring equality.
472$ 4. the binder routine msyms has been modified to read constants
473$ a little more efficiently.
474
475
476$ 02/04/80 80035 s. freudenberger and d. shields
477$
478$ 1. implement unary operators acos, asin, atan, char, cos, exp,
479$ log, sin, sqrt, tan and tanh.
480$ 2. implement binary operators atan2 and interrogation (?).
481$ 3. implement type predicates is_atom, is_boolean, is_integer,
482$ is_map, is_real, is_set, is_string and is_tuple.
483$ change prim to is_primitive.
484$ 4. add procedure host() to provide means for adding
485$ implementation- or site-dependent features.
486$ 5. the argument to q1_stmt (the cummulative statement count) has
487$ been dropped.
488$ 6. an attemt to repr a variable with a procedure-, member-, or label-
489$ form now produces an error message (actually, only the first of
490$ the three possibilities is of importance...)
491$ 7. the 'fold unary operator' routine (foldun) has been corrected
492$ to use correctly sized variables.
493
494
495$ 01/21/80 80021 s. freudenberger
496$
497$ the form table limit has been increased for s32.
498
499
500$ 01/16/80 80016 s. freudenberger
501$
502$ 1. 'gsin' has been modified to suppress the generation of an
503$ internal variable for the last retrieval operation, since
504$ this operation is deleted anyway.
505$ 2. 'gcall' has been updated as to allow assignment of a write-
506$ parameter to a read-only parameter of the inclosing scope.
507
508
509$ 01/15/80 80015 s. freudenberger
510$
511$ the semantic routines for signed numeric constants have been changed
512$ to create a new val entry.
513
514
515$ 12/17/79 79351 s. freudenberger
516$
517$ 1. conditional assembly 'sq1' has been introduced to conditionally
518$ assemble the setl q1 interface.
519$ 2. the semantic of the 'quit' statement has been changed: quit does
520$ not execute the term block, but rather branches to a label imme-
521$ diately after the term block.
522$ 3. domain iterators set the range- and domain elements to omega upon
523$ completion of the iteration.
524$ 4. the semantic routines for signed numeric constants have been
525$ changed to create a new symbol table entry.
526
527
528$ 11/30/79 79334 s. freudenberger
529$
530$ 1. 'gsin' has been corercted to handle <*name>
531$ correctly. problem due to improper temporary handling.
532$ 2. the error message for case map overflow has been improved, and will
533$ now state 'too many cases' as opposed to 'settup'.
534$ 3. 'gseti' has been corrected to emit a code sequence which supports
535$ repr's. problem due to final q2_locate before test for termination
536$ 4. 'foldst' now checks for both too many values and omegas before
537$ constant folding takes place.
538$ 5. on compiler table overflow it is now possible to print the compiler
539$ tables using the 'et' (error trace) control card parameter.
540
541
542$ 11/12/79 79316 s. freudenberger
543$
544$ 1. mode keyword 'map' has been dropped. the related grammar changes
545$ have been reflected in the semantic routines 'gtmap2' (has been
546$ deleted), 'gtmmap' (has been updated), 'gtmmp1' 'gtmmp2' (have
547$ been added).
548$ 2. the 'dump' control card parameter has been replaced by the
549$ 'sq1sd' and 'sq1cd' parameters, thus avoiding the name conflict
550$ with the 'dump' parameter of lib and dmp.
551$ 3. 'sif' has been introduced as a new control card parameter. it
552$ control whether intermediate files are to be saved.
553$ files affected are the pol- and xpol-files.
554$ 4. 'pre_flag', which used to indicate prefix-stropping, has been
555$ eliminated.
556$ 5. the map_code mapping has been dropped. (it had become trivial)
557$ 6. decks 'insn', 'settup', and 'copy' have been updated to use the
558$ 'nargs_lim' macro (defined in cmnpl.q1symtab)
559$ 7. the setl binary i/o interface has been re-done. it is now
560$ consistent with the optimizer interfaces and the code generator
561$ setl binary i/o interface.
562$ 8. the decks 'gsnint' and 'gsreal' have been added. they perform the
563$ semantic actions corresponding to signed numeric constants.
564$ 9. the unit_xxx codes have been corrected.
565
566
567$ 09/27/79 79269 s. freudenberger
568$
569$ 1. the binder has been put back into operation.
570$ 2. a blank is printed after the variable name in a warning message.
571
572
573$ 09/17/79 79259 s. freudenberger
574$
575$ 1. all procedure and function names have been shortened to at most
576$ six alphamerics.
577
578
579$ 09/13/79 79256 s. freudenberger
580$
581$ 1. 'gcnst2' has been modified to process 'const id;' correctly.
582$ 2. 'sethd' has been modified to print an error messages if an
583$ undeclared identifier appears in a reads or writes list.
584$ 3. logical file names are sized using 'filenamlen' (defined in
585$ cmnpl.sysmac).
586$ 4. 'gcall1' has been modified to check for calls to perform blocks.
587$ this required the addition of 'gcall3', to distinct between
588$ '<*name> ;' and '<*name> ( ) ;'.
589
590
591$ 09/05/79 79248 s. freudenberger
592$
593$
594$ this correction set installs setl 2.1
595$
596$
597$ 1. 'opmap' and 'q1tab' have been changed and amended.
598$ 2. two tables have been added: 'mode_map' maps mode keywords to
599$ predefined modes. 'tuple_type' and 'map_type' map element
600$ forms to the corresponding tuple- and map-forms.
601$ 3. 'true' and 'false' are two new system constants.
602$ 4. '//' is now written as 'mod'.
603$ 5. two new string primitives have been defined: 'len(str, int)'
604$ returns the first 'int' characters of 'str', and 'rlen(str, int)'
605$ does the same from the right end of the 'str'. as usual, on
606$ success 'str' is shortened by the returned string.
607$ 6. the processing of 'repr' statements has been rewritten.
608$ 7. the processing for 'from',... has been rewritten.
609$ 8. assignments are uniformly handled by 'gasn1'...'gasn4'. these
610$ routines replace 'gdefop' and 'gdefop1'.
611$ 9. multi-variate maps now are represented as [[d1, d2, ..., dn] r].
612$ the necessary changes to 'gof' and 'gofa' have been made.
613$ 10. the code generated for domain iterators had to be changed to
614$ reflect the semantic change outlined under (9.).
615$ 11. the 'notexist' quantifier has been added.
616$ 12. a binary form of the compound operator has been added. its syntax
617$ is 'e1 op/ e2', its semantic e1 op e2(1) op e2(2) op ... op e2(n).
618
619
620$ 07/25/79 79206 s. freudenberger
621$
622$ inclusion deck 'binaryio' has been renamed 'binio'.
623
624
625$ 07/20/79 79201 s. freudenberger
626$
627$ 1. 'q1tab' is initialized by a data-statement, and not via executable
628$ code at the beginning of execution.
629$ 2. error messages on the dec-10 are written to the device 'tty:',
630$ rather then the file 'tty'.
631$ 3. error messages on the dec-10 are preceded by '?', the standard
632$ error marker for that system. also, warning messages are preceded
633$ by ':'.
634$ 4. the default file titles for the binder- and setl-q1 files have been
635$ changed to '0' (zero), the little default for a *sink*. after the
636$ files have been opened, the titles are reset to the null string.
637$ n.b. this saves us to test whether files have been supplied, since
638$ we can read from and write to the *sink* indefinitely.
639$ 5. 'semini' prints a line 'start...' on the terminal.
640$ 6. 'gcnst1' has been modified to handle 'om' as a constant.
641$ 7. error messages in 'gcnst1' and 'gvar' have been changed to aid
642$ novice users in their aim to understand their meaning.
643$ 8. the result of a set former must be a temporary. this had been
644$ changed incorrectly for v2.0(79138).
645$ 9. 'genst' incorrectly called 'gttup1' when it pushed negative-2 onto
646$ 'astac', a ps-sized array. this has been corrected by special
647$ casing for n=0, pushing 'f_gen' and 'sym_zero', and calling
648$ 'gttup2' directly.
649$ 10. 'val'-entries and strings are now correctly written to the setl-
650$ q1 file.
651
652
653$ 05/18/79 79138 s. freudenberger and d. shields
654$
655$ 1. more shared code has been moved into 'cmnpl'.
656$ 2. code has been added to write the q1 file in setl binary
657$ format. this involves a new control card parameter,
658$ sq1, to specify the file name of the setl q1 file, as
659$ well as code to write out the setl format q1 file.
660$ 3. the code sequence for iterative set formers has been
661$ modified to meet an optimizer constraint. the new code
662$ sequence assigns the result of the incremented element
663$ counter to a temporary, and then assigns the temporary
664$ back to the counter.
665$ 4. the code sequence for arithmetic iterators has been
666$ modified along simillar lines. here the result of
667$ adding the increment to the index variable is first
668$ assigned to a (new) temporary, then assigned back to the
669$ index variable.
670$ 5. overall, code has been cleaned up.
671
672
673$ 04/27/79 79117 s. freudenberger
674$
675$ 1. 'ghead6' has been modified so that in a short compilation
676$ (i.e. a compilation with no directory) a rights list of
677$ zeros is given to the member name. this way the optimizer
678$ can assume that every member name has a rights list.
679$ 2. to further reduce the amount of output produced by this
680$ phase, no message is printed anymore at the beginning of each
681$ unit. error messages and dump headings have been modified to
682$ account for this change.
683$ 3. after the symbols '_' and '/_' can not be operators anymore
684$ (cf. character set change, version 79102), it seemed logical
685$ to delete them from the symbol table as well. this has been
686$ done, and also triggered changes 4 and 5.
687$ 4. since the data structures for the q1 symbol table and the form
688$ table are shared among several phases of the compiler, they
689$ have been placed into a special library, 'cmnpl'. they are
690$ now included into the compilation as an inclusion library.
691$ n.b. there is more code that should be placed into this
692$ common library.
693$ 5. the names for system variables are now preceded by 's$', and
694$ the names of globals by 'g$'.
695$ 6. a start has been made to eliminate the phase heading. the
696$ file information is now printed two files per line.
697
698
699$ 04/12/79 79102 s. freudenberger and d. shields
700$
701$ 1. an option has been added to echo all error messages to the terminal
702$ file specified by the -term- control card parameter.
703$ 2. the layout of the q1 statistics has been condensed.
704
705
706$ 04/10/79 79100 s. freudenberger
707$
708$ 1. some form table fields for the 6600 have been redefined to
709$ avoid the -ft_pos- field to cross a word boundery.
710$ 2. the 'q1_na' instruction is emitted with the correct argument.
711$ 3. the symbol table dimension has been increased to 1500.
712
713
714$ 04/03/79 79093 s. freudenberger and d. shields
715$
716$ 1. as a first step to remove prefix stropping, the pre control card
717$ parameter has been deleted, and the pre_flag initialized to
718$ reserved word stropping.
719$ 2. the blockof-field of the first q1 instruction has been made to
720$ point back to the blocktab entry (as the documentation promisses).
721$ 3. the form predicates have been implemented in a different way, so
722$ that machines with a wordsize less than 35 bits will get the
723$ correct results. (the new implementation also should be more
724$ efficient)
725
726
727$ 03/27/79 79086 s. freudenberger
728$
729$ 1. the code sequence generated for -from- has be corrected.
730$ 2. an erroneous field definition for s10 has been corrected.
731$ 3. the predicates on forms have been reviewed and corrected.
732$ 4. the size of the names table has been increased to 1500.
733
734
735$ 03/15/79 79074 s. freudenberger
736$
737$ 1. the order in which the q1 tables are written onto the
738$ q1 file has been changed to conform with the sequence
739$ in which the optimizer reads them in.
740$ 2. the routine -move- has been renamed -movblk-.
741$ 3. the following semantic pass debugging options have been
742$ renamed:
743$ tre0 ---> stre0
744$ tre1 ---> stre1
745$ trs0 ---> strs0
746$ trs1 ---> strs1
747$ 4. the code emitted for 'f(x) from g(y)' has been corrected.
748$ 5. the size of the array -opname- in routine -dblock- has been
749$ increased so that there is enough space to store the longest
750$ op name.
751
752
753$ 03/05/79 79065 s. freudenberger
754$
755$ 1. the following changes have been made to the debug statement
756$ options:
757$
758$ 1.1 three new options have been introduced to allow local dumps
759$ during code generation (see comment in setl.cod for more
760$ detail)
761$ 1.2 two semantic pass options have been renamed:
762$ q1dump ----> sq1cd
763$ symdump ---> sq1sd
764$ 1.3 a typo in the spelling of sym_rtrs0 has been corrected.
765$ 2. the statement numbering has been cleaned up. hopefully error
766$ messages will print now the statement number corresponding to
767$ the source listing...
768
769
770$ 02/12/79 79043 a. grand and s. freudenberger
771$
772$ 1. the code for evaluating the expression in
773$ <*bin> '/' '[' ':' ']'
774$ has been moved inside the iterator block.
775
776
777$ 12/27/78 78361 a. grand and d. shields
778$
779$ this mod includes machine dependent code for the ibm-370, dec-10,
780$ and vax.
781
782
783$ 12/08/78 78342 a. grand
784$
785$ 1. there is a control card option 'diter' which specifies that
786$ (! x _ s) can be done using x and s directly. we only make this
787$ optimization when x and s are know to have compatible types.
788$ the same option allows us to do use 'i' directly in (! i := 1...n).
789$ here we only make the optimization if i is general or an integer.
790$ 2. the assignment f(x+1, y) := z was not processed correctly. we
791$ now allocate an internal variable 't' and emit
792$ t := x+1; f(t, y) := z;
793$ 3. the size of argtab has been increased to 4000.
794
795
796$ 11-15-78 78319 a. grand and s. freudenberger
797$
798$ 1. it adds the deck 'mods'.
799$ 2. it fixes various bugs in the treatment of short iterators.
800$ 3. it sets the is_back flag of the temporaries yielded by quantifiers.
801$ 4. it redoes the treatment of statement numbers in the q1 code.
802
803
1 .=member start
suna 15 .=include cndasm
suna 16
suna 17 .+r32 prog stlsem;
suna 18 .+r36 prog stlsem;
7 .+s66 subr start;
8
9$ in this section we define all the data structures of the semantic
10$ pass. we begin with a few meta macros and utilities.
11
12 +* prog_level = $ program level (julian date of last fix)
bnda 13 'sem(85007) '
14 **
15
16
18 .=include sysmac
19
20 macdrop(deflab) $ since we have a routine 'deflab'
21
22
23 +* maxsi = $ maximum value for short int
24 .+s66 3b'377777'
25 .+r32 4b'3fffff'
26 .+s10 3b'777777'
27 .+s20 3b'777777'
28 **
29
30
31$ the polish string
32$ -----------------
33
34$ the output of the parser is a reversed polish string. the polish
35$ string is represented as an array of nodes, each of which may
36$ occupy one or more words. the first word of each node has a
37$ standard format and contains the following fields:
38
39$ pol_typ: type code pol_xxx
40$ pol_val: value of entry
41
42$ there are three types of nodes
43
44$ a. names
45
46$ these nodes indicate names appearing in the source program.
47$ they have:
48
49$ pol_typ: pol_name
50$ pol_val: length of name in words
51
52$ the actual name is contained in successive words,
53$ stored in the format used by the 'names' array.
54
55$ b. counters
56
57$ counters are integers which indicate the number of clauses
58$ found by each operation of the parser. they have:
59
60$ pol_typ: pol_count
61$ pol_val: integer indicating count
62
63$ c. markers
64
65$ markers are nodes indicating points where semantic routines
66$ are to be invoked. they have:
67
68$ pol_typ: pol_mark
69$ pol_val: code p_xxx
70
71$ we do not keep the entire polish string in core at once, but rather
72$ read in nodes as we need them.
73
74$ the polish string is actually read in from two files called the
75$ main and auxiliary files. the auxiliary file contains a description
76$ of each procedure and its parameters. the two files are read in
77$ alternately so that we can process forward references to procedures.
78
79$ the variable pol_file gives the number of the polish string file
80$ currently being read. it is reset by the routines gsw1 and gsw2.
81
82$ the fields of each node are:
83
84
85 +* polsz = 16 ** $ size of node header
86
87 +* pol_typ_ = .f. 01, 02, **
88 +* pol_val_ = .f. 03, 14, **
89
90 .+r32 +* polsz = 32 ** $ upsized node header
91
92 .+r32 +* pol_typ_ = .f. 01, 02, **
93 .+r32 +* pol_val_ = .f. 03, 30, **
94
95
96 +* getp(tp, vl) = $ read node from polish
97 size zzza(polsz);
98
99 read pol_file, zzza;
100 tp = pol_typ_ zzza;
101 vl = pol_val_ zzza;
102 **
103
104$ polish string types
105
106 .=zzyorg z
107
108 defc0(pol_name) $ name
109 defc0(pol_count) $ counter
110 defc0(pol_mark) $ marker
111 defc0(pol_end) $ end-of-file node
112
113 +* pol_min = pol_name ** $ minimum type
114 +* pol_max = pol_end ** $ maximum type
115
116
117$ the macros defining the polish string markers are generated
118$ by 'syn' when it compiles the grammar, and are included here.
119
120 +* synimpmap(a, b) = macdef(a = b) **
121
122 .=include synmac
suna 20 .=include synimp $ include macros
124
125
126
127
128$ q1 data structures
129$ ------------------
130
131$ in the next section we describe the various q1 data structures.
132$ the q1 tables are written out in pages at the end of each unit.
133$ only those pages necessary to process the current unit are kept
134$ in core at any given time.
135
136$ a page of q1 consists of:
137
138$ 1. the unit type unit_xxx
139$ 2. a string of toklen_lim characters giving the unit name
140$ 3. a pointer to the symtab entry for the unit
141$ 4. the number of procedures in current member
142$ 5. the number of the first statement for the unit.
143$ 6. slices of the q1 tables.
144
145$ note that we never write out an entire q1 table. instead we
146$ write out an array slice which contains all the new entries
147$ for the current unit.
148
149$ each array slice is identified by two pointers:
150
151$ xxx_org: pointer to zero-th entry
152$ xxxp: pointer to last entry
153
154$ we read array entries from xxx(xxx_org+1) to xxx(xxxp).
155
156$ the q1 file ends with a special page with type unit_end.
157$ this page does not contain items 2-6 above.
158
159
160 .=include q1symtab
161
162
163$ symtab is arranged as a hash table, with the link field used
164$ to resolve all collisions. a separate array called 'heads'
165$ holds the head of each clash list.
166
167
168 +* heads_lim = $ number of hash headers
169 .+s10 211
170 .+s20 211
171 .+r32 1021
172 .+s66 211
173 **
174
175
176 size heads(ps); $ array of hash headers
177 dims heads(heads_lim);
178 data heads = 0(heads_lim);
179
180
181 .=include formtab
182
183
184 +* fheads_lim = $ number of hash headers
185 .+s10 101
186 .+s20 101
187 .+r32 509
188 .+s66 101
189 **
190
191
192 size fheads(ps); $ form table hash headers
193 dims fheads(fheads_lim);
194 data fheads = 0(fheads_lim);
195
196
197 .=include q1code
198 .=include binio
smfc 11 .=include lipkg $ long integer arithmetic package
199
200
201$ internal data structures
202$ ------------------------
203
smfb 50$ the semantic pass uses three auxiliary stacks to generate code.
205$ these are:
206
207
208$ astack
209$ ------
210
211$ this is an argument stack used for communication between the various
212$ semantic routines. its entries are symbol table pointers, integers
213$ etc. the variable 'asp' points to the top entry of astack.
214
215 +* astack_lim = $ length of astack
216 .+s10 1000
217 .+s20 1000
218 .+r32 10000
219 .+s66 1000
220 **
221
222 size astack(ps);
223 dims astack(astack_lim);
224
225 size asp(ps);
226 data asp = 0;
227
228$ the following macros are used to manipulate astack:
229
230 +* get_stack(n) = $ get stack space
231 asp = asp + (n);
232 if (asp > astack_lim) call overfl('astack');
233 **
234
235
236 +* free_stack(n) = $ free stack space
237 .+tr.
238 if (n) > asp then $ underflow
239 put, skip, 'astack underflow', skip;
240 asp = n;
241 end if;
242 ..tr
243 asp = asp - (n);
244 **
245
246
247 +* stack_trace(str, n) = $ trace astack
248 if (trs_flag)
249 put, x(2), str, x(2):
250 astack(asp-(n)+1) to astack(asp), il, skip;
251 **
252
253
254 +* push1(a) = $ push a
255 get_stack(1);
256 astack(asp) = a;
257 .+tr stack_trace('push', 1);
258 **
259
260 +* push2(a, b) = $ push a; push b;
261 get_stack(2);
262 astack(asp) = b;
263 astack(asp-1) = a;
264 .+tr stack_trace('push', 2);
265 **
266
267
268 +* push3(a, b, c) =
269 get_stack(3);
270 astack(asp) = c;
271 astack(asp-1) = b;
272 astack(asp-2) = a;
273 .+tr stack_trace('push', 3);
274 **
275
276
277 +* push4(a, b, c, d) =
278 get_stack(4);
279 astack(asp) = d;
280 astack(asp-1) = c;
281 astack(asp-2) = b;
282 astack(asp-3) = a;
283 .+tr stack_trace('push', 4);
284 **
285
286
287 +* pop1(a) = $ pop a;
288 .+tr stack_trace('pop', 1);
289 a = astack(asp);
290 free_stack(1);
291 **
292
293
294 +* pop2(a, b) = $ pop a; pop b;
295 .+tr stack_trace('pop', 2);
296 a = astack(asp);
297 b = astack(asp-1);
298 free_stack(2);
299 **
300
301
302 +* pop3(a, b, c) =
303 .+tr stack_trace('pop', 3);
304 a = astack(asp);
305 b = astack(asp-1);
306 c = astack(asp-2);
307 free_stack(3);
308 **
309
310
311 +* pop4(a, b, c, d) =
312 .+tr stack_trace('pop', 4);
313 a = astack(asp);
314 b = astack(asp-1);
315 c = astack(asp-2);
316 d = astack(asp-3);
317 free_stack(4);
318 **
smfb 51
smfb 52
smfb 53
smfb 54
smfb 55$ bstack
smfb 56$ ------
smfb 57
smfb 58$ bstack is used to generate code for boolean expressions.
smfb 59
smfb 60 +* bstack_sz =
smfb 61 .+s10 72
smfb 62 .+s20 72
smfb 63 .+r32 64
smfb 64 .+s66 60
smfb 65 **
smfb 66
smfb 67 +* bstack_lim = 100 **
smfb 68
smfb 69 size bstack(bstack_sz);
smfb 70 dims bstack(bstack_lim);
smfb 71
smfb 72 size bsp(ps);
smfb 73 data bsp = 0;
smfb 74
smfb 75 .+s10.
smfb 76 +* bs_temp(p) = .f. 1, 18, bstack(p) **
smfb 77 +* bs_true(p) = .f. 19, 18, bstack(p) **
smfb 78 +* bs_false(p) = .f. 37, 18, bstack(p) **
smfb 79 ..s10
smfb 80
smfb 81 .+s20.
smfb 82 +* bs_temp(p) = .f. 1, 18, bstack(p) **
smfb 83 +* bs_true(p) = .f. 19, 18, bstack(p) **
smfb 84 +* bs_false(p) = .f. 37, 18, bstack(p) **
smfb 85 ..s20
smfb 86
smfb 87 .+r32.
smfb 88 +* bs_temp(p) = .f. 1, 16, bstack(p) **
smfb 89 +* bs_true(p) = .f. 17, 16, bstack(p) **
smfb 90 +* bs_false(p) = .f. 33, 16, bstack(p) **
smfb 91 ..r32
smfb 92
smfb 93 .+s66.
smfb 94 +* bs_temp(p) = .f. 1, 15, bstack(p) **
smfb 95 +* bs_true(p) = .f. 16, 15, bstack(p) **
smfb 96 +* bs_false(p) = .f. 31, 15, bstack(p) **
smfb 97 ..s66
319
320
321
322
323$ cstack
324$ ------
325
326$ cstack is used to process control statements, such as 'if',
327$ 'case', and 'while'.
328
329$ there are four types of cstack entries:
330
331$ cs_if: if statements and conditional expressions
332$ cs_case: case statements and expressions
333$ cs_iter: first loop in compound iterator
334$ cs_citer: inner loop in compound iterator
335
336$ cstack has the following fields:
337
338$ cs_type: code cs_xxx
339
340
341$ fields for loops:
342
343$ cs_internal: flags internal iterator
344$ cs_bvar: name of bound variable for short iterators
345$ cs_ldoing: name of label for doing block
346$ cs_lstep: name of label for step block
347$ cs_lterm: name of label for term block
348$ cs_lquit: name of label for quit target
349$ cs_init: code pointer to end of init block
350$ cs_doing: code pointer to end of doing block
351$ cs_while: code pointer to end of while block
352$ cs_where: code pointer to end of where block
353$ cs_body: code pointer to end of body
354$ cs_step: code pointer to end of step block
355$ cs_until: code pointer to end of until block
356$ cs_term: code pointer to end of term block
357
358$ fields for 'if' statements and expressions
359
360$ cs_else: name of else label
361$ cs_end: name of end label
362$ cs_temp: name of result temporary for if expressions
363
364$ fields for expression blocks
365
366$ cs_end: name of label for end of block
367$ cs_temp: name of temporary yielded by block
368
369$ fields for case statements and expressions
370
371$ cs_num: counter for number of case tags
372$ cs_jump: code pointer to branch instruction
373$ cs_tag: name of label for current tag
374$ cs_else: name of label for else clause
375$ cs_end: name of label for end
376$ cs_temp: name of result temporary for case expression
377
378$ the variable 'csp' points to the top cstack entry.
379
380$ the macros for cstack are:
381
382 +* cstack_sz =
383 .+s10 216
384 .+s20 216
385 .+r32 224
386 .+s66 240
387 **
388
389
smfb 98 +* cstack_lim = 100 **
391
392 size cstack(cstack_sz);
393 dims cstack(cstack_lim);
394
395 size csp(ps);
396 data csp = 0;
397
398
399 .+s10. $ fields for dec-10
400 +* cs_type(p) = .f. 001, 03, cstack(p) **
401 +* cs_internal(p) = .f. 004, 01, cstack(p) **
402 +* cs_bvar(p) = .f. 013, 12, cstack(p) **
403 +* cs_ldoing(p) = .f. 025, 12, cstack(p) **
404 +* cs_lstep(p) = .f. 037, 12, cstack(p) **
405 +* cs_lterm(p) = .f. 049, 12, cstack(p) **
406 +* cs_lquit(p) = .f. 061, 12, cstack(p) **
407 +* cs_init(p) = .f. 073, 18, cstack(p) **
408 +* cs_doing(p) = .f. 091, 18, cstack(p) **
409 +* cs_while(p) = .f. 109, 18, cstack(p) **
410 +* cs_where(p) = .f. 127, 18, cstack(p) **
411 +* cs_body(p) = .f. 145, 18, cstack(p) **
412 +* cs_step(p) = .f. 163, 18, cstack(p) **
413 +* cs_until(p) = .f. 181, 18, cstack(p) **
414 +* cs_term(p) = .f. 199, 18, cstack(p) **
415 ..s10
416
417 .+s20. $ fields for dec-10
418 +* cs_type(p) = .f. 001, 03, cstack(p) **
419 +* cs_internal(p) = .f. 004, 01, cstack(p) **
420 +* cs_bvar(p) = .f. 013, 12, cstack(p) **
421 +* cs_ldoing(p) = .f. 025, 12, cstack(p) **
422 +* cs_lstep(p) = .f. 037, 12, cstack(p) **
423 +* cs_lterm(p) = .f. 049, 12, cstack(p) **
424 +* cs_lquit(p) = .f. 061, 12, cstack(p) **
425 +* cs_init(p) = .f. 073, 18, cstack(p) **
426 +* cs_doing(p) = .f. 091, 18, cstack(p) **
427 +* cs_while(p) = .f. 109, 18, cstack(p) **
428 +* cs_where(p) = .f. 127, 18, cstack(p) **
429 +* cs_body(p) = .f. 145, 18, cstack(p) **
430 +* cs_step(p) = .f. 163, 18, cstack(p) **
431 +* cs_until(p) = .f. 181, 18, cstack(p) **
432 +* cs_term(p) = .f. 199, 18, cstack(p) **
433 ..s20
434
435
436
437 .+r32. $ fields for regular 32-bit implementatinon
438 +* cs_type(p) = .f. 001, 08, cstack(p) **
439 +* cs_internal(p) = .f. 009, 08, cstack(p) **
440 +* cs_bvar(p) = .f. 017, 16, cstack(p) **
441 +* cs_ldoing(p) = .f. 033, 16, cstack(p) **
442 +* cs_lstep(p) = .f. 049, 16, cstack(p) **
443 +* cs_lterm(p) = .f. 065, 16, cstack(p) **
444 +* cs_lquit(p) = .f. 081, 16, cstack(p) **
445 +* cs_init(p) = .f. 097, 16, cstack(p) **
446 +* cs_doing(p) = .f. 113, 16, cstack(p) **
447 +* cs_while(p) = .f. 129, 16, cstack(p) **
448 +* cs_where(p) = .f. 145, 16, cstack(p) **
449 +* cs_body(p) = .f. 161, 16, cstack(p) **
450 +* cs_step(p) = .f. 177, 16, cstack(p) **
451 +* cs_until(p) = .f. 193, 16, cstack(p) **
452 +* cs_term(p) = .f. 209, 16, cstack(p) **
453 ..r32
454
455
456 .+s66. $ fields for cdc 6600
457 +* cs_type(p) = .f. 055, 03, cstack(p) **
458 +* cs_internal(p) = .f. 058, 01, cstack(p) **
459 +* cs_bvar(p) = .f. 001, 17, cstack(p) **
460 +* cs_ldoing(p) = .f. 019, 17, cstack(p) **
461 +* cs_lstep(p) = .f. 037, 17, cstack(p) **
462 +* cs_lterm(p) = .f. 061, 17, cstack(p) **
463 +* cs_lquit(p) = .f. 079, 17, cstack(p) **
464 +* cs_init(p) = .f. 121, 15, cstack(p) **
465 +* cs_doing(p) = .f. 136, 15, cstack(p) **
466 +* cs_while(p) = .f. 151, 15, cstack(p) **
467 +* cs_where(p) = .f. 166, 15, cstack(p) **
468 +* cs_body(p) = .f. 181, 15, cstack(p) **
469 +* cs_step(p) = .f. 196, 15, cstack(p) **
470 +* cs_until(p) = .f. 211, 15, cstack(p) **
471 +* cs_term(p) = .f. 226, 15, cstack(p) **
472 ..s66
473
474
475 +* cs_else(p) = cs_lstep(p) **
476 +* cs_end(p) = cs_lterm(p) **
477 +* cs_temp(p) = cs_bvar(p) **
478 +* cs_jump(p) = cs_init(p) **
479 +* cs_num(p) = cs_doing(p) **
480 +* cs_tag(p) = cs_ldoing(p) **
481
482$ codes for cs_types
483
484 .=zzyorg z
485
486 defc(cs_if) $ if statement or expression
487 defc(cs_case) $ case statement of expression
488 defc(cs_iter) $ outer loop
489 defc(cs_citer) $ inner loop
490 defc(cs_eblk) $ expression block
491
492 +* cs_min = cs_if ** $ minimum cs_type
493 +* cs_max = cs_eblk ** $ maximum cs_type
494
495
496
497$ we also use two other internal tables:
498
499$ proctab
500$ -------
501
502$ proctab is an array containing the names of all procedures which
503$ should be defined in this member. it is the union of the members
504$ exports and procs lists.
505
506$ the variable 'proctabp' points to the last entry on proctab.
507
508 +* proctab_lim = 500 **
509
510 size proctab(ps);
511 dims proctab(proctab_lim);
512
513 size proctabp(ps);
514 data proctab = 0;
515
516
517$ opmap
518$ -----
519
520$ the array 'opmap' maps symbol table pointers into q1 opcodes.
521
522 size opmap(ps);
523 dims opmap(sym_maximum);
524
525 data opmap(sym_plus) = q1_add: $ +
526 opmap(sym_minus) = q1_sub: $ -
527 opmap(sym_mult) = q1_mult: $ *
528 opmap(sym_div) = q1_div: $ div
529 opmap(sym_slash) = q1_slash: $ /
530 opmap(sym_mod) = q1_mod: $ mod
531 opmap(sym_exp) = q1_exp: $ **
532 opmap(sym_lt) = q1_lt: $ <
533 opmap(sym_gt) = q1_lt: $ '>' permute args, use '<'
534 opmap(sym_le) = q1_ge: $ <= permute args, use >=
535 opmap(sym_ge) = q1_ge: $ >=
536 opmap(sym_eq) = q1_eq: $ =
537 opmap(sym_ne) = q1_ne: $ /=
538 opmap(sym_in) = q1_in: $ in
539 opmap(sym_notin) = q1_notin: $ notin
540 opmap(sym_incs) = q1_incs: $ incs
541 opmap(sym_with) = q1_with: $ with
542 opmap(sym_from) = q1_from: $ from
543 opmap(sym_fromb) = q1_fromb: $ fromb
544 opmap(sym_frome) = q1_frome: $ frome
545 opmap(sym_less) = q1_less: $ less
546 opmap(sym_lessf) = q1_lessf: $ lessf
547 opmap(sym_min) = q1_min: $ min
548 opmap(sym_max) = q1_max: $ max
549 opmap(sym_subset) = q1_incs: $ subset
550 opmap(sym_npow) = q1_npow: $ npow
551 opmap(sym_atan2) = q1_atan2: $ atan2
552 opmap(sym_not) = q1_not: $ not
553 opmap(sym_even) = q1_even: $ even
554 opmap(sym_odd) = q1_odd: $ odd
555 opmap(sym_isint) = q1_isint: $ is_integer
556 opmap(sym_isreal) = q1_isreal: $ is_real
557 opmap(sym_isstr) = q1_isstr: $ is_string
558 opmap(sym_isbool) = q1_isbool: $ is_boolean
559 opmap(sym_isatom) = q1_isatom: $ is_atom
560 opmap(sym_istuple) = q1_istup: $ is_tuple
561 opmap(sym_isset) = q1_isset: $ is_set
562 opmap(sym_ismap) = q1_ismap: $ is_map
563 opmap(sym_arb) = q1_arb: $ arb
564 opmap(sym_dom) = q1_dom: $ domain
565 opmap(sym_range) = q1_range: $ range
566 opmap(sym_pow) = q1_pow: $ pow
567 opmap(sym_nelt) = q1_nelt: $ #
568 opmap(sym_abs) = q1_abs: $ abs
569 opmap(sym_char) = q1_char: $ char
570 opmap(sym_ceil) = q1_ceil: $ ceil
571 opmap(sym_floor) = q1_floor: $ floor
572 opmap(sym_fix) = q1_fix: $ fix
573 opmap(sym_float) = q1_float: $ float
574 opmap(sym_sin) = q1_sin: $ sin
575 opmap(sym_cos) = q1_cos: $ cos
576 opmap(sym_tan) = q1_tan: $ tan
577 opmap(sym_arcsin) = q1_arcsin: $ asin
578 opmap(sym_arccos) = q1_arccos: $ acos
579 opmap(sym_arctan) = q1_arctan: $ atan
580 opmap(sym_tanh) = q1_tanh: $ tanh
581 opmap(sym_expf) = q1_expf: $ expf
582 opmap(sym_log) = q1_log: $ log
583 opmap(sym_sqrt) = q1_sqrt: $ sqrt
584 opmap(sym_rand) = q1_rand: $ random
585 opmap(sym_sign) = q1_sign: $ sign
586 opmap(sym_type) = q1_type: $ type
587 opmap(sym_str) = q1_str: $ str
588 opmap(sym_val) = q1_val; $ val
589
590
591
592$ q1tab
593$ -----
594
595$ the table 'q1tab' contains various maps defined on q1 opcodes.
596$ these maps are:
597
598$ numargs: number of arguments
599$ sinmap: maps retrieval ops into sinister ops
600$ defs_temp: indicates that operation defines a temp
601
602$ numargs is zero for operations with variable numbers of operands
603
604 +* numargs(op) = .f. 01, 08, q1tab(op) **
605 +* sinmap(op) = .f. 09, 08, q1tab(op) **
606 +* defs_temp(op) = .f. 17, 01, q1tab(op) **
607
608 size q1tab(24);
609 dims q1tab(q1_maximum);
610 data
611
612 +* s(op, a, b, c) = $ initialize q1tab entry
613 q1tab(op) = a + b*4b'000100' + c*4b'010000'
614 **
615
616$ binary operators:
617
618 s(q1_add, 3, 0, yes):
619 s(q1_div, 3, 0, yes):
620 s(q1_exp, 3, 0, yes):
621 s(q1_eq, 3, 0, yes):
622 s(q1_ge, 3, 0, yes):
623 s(q1_lt, 3, 0, yes):
smfb 99 s(q1_pos, 3, 0, yes):
624 s(q1_in, 3, 0, yes):
625 s(q1_incs, 3, 0, yes):
626 s(q1_less, 3, 0, yes):
627 s(q1_lessf, 3, 0, yes):
628 s(q1_max, 3, 0, yes):
629 s(q1_min, 3, 0, yes):
630 s(q1_mod, 3, 0, yes):
631 s(q1_mult, 3, 0, yes):
632 s(q1_ne, 3, 0, yes):
633 s(q1_notin, 3, 0, yes):
634 s(q1_npow, 3, 0, yes):
635 s(q1_atan2, 3, 0, yes):
636 s(q1_slash, 3, 0, yes):
637 s(q1_sub, 3, 0, yes):
638 s(q1_with, 3, 0, yes):
639
640$ unary operators:
641
642 s(q1_abs, 2, 0, yes):
643 s(q1_char, 2, 0, yes):
644 s(q1_ceil, 2, 0, yes):
645 s(q1_floor, 2, 0, yes):
646 s(q1_isint, 2, 0, yes):
647 s(q1_isreal, 2, 0, yes):
648 s(q1_isstr, 2, 0, yes):
649 s(q1_isbool, 2, 0, yes):
650 s(q1_isatom, 2, 0, yes):
651 s(q1_istup, 2, 0, yes):
652 s(q1_isset, 2, 0, yes):
653 s(q1_ismap, 2, 0, yes):
654 s(q1_arb, 2, 0, yes):
655 s(q1_val, 2, 0, yes):
656 s(q1_dom, 2, 0, yes):
657 s(q1_fix, 2, 0, yes):
658 s(q1_float, 2, 0, yes):
659 s(q1_nelt, 2, 0, yes):
660 s(q1_not, 2, 0, yes):
661 s(q1_pow, 2, 0, yes):
662 s(q1_sin, 2, 0, yes):
663 s(q1_cos, 2, 0, yes):
664 s(q1_tan, 2, 0, yes):
665 s(q1_arcsin, 2, 0, yes):
666 s(q1_arccos, 2, 0, yes):
667 s(q1_arctan, 2, 0, yes):
668 s(q1_tanh, 2, 0, yes):
669 s(q1_expf, 2, 0, yes):
670 s(q1_log, 2, 0, yes):
671 s(q1_sqrt, 2, 0, yes):
672 s(q1_rand, 2, 0, yes):
673 s(q1_range, 2, 0, yes):
674 s(q1_type, 2, 0, yes):
675 s(q1_umin, 2, 0, yes):
676 s(q1_even, 2, 0, yes):
677 s(q1_odd, 2, 0, yes):
678 s(q1_str, 2, 0, yes):
679 s(q1_sign, 2, 0, yes):
680
681$ miscellaneous:
682
683 s(q1_end, 3, q1_send, yes):
684 s(q1_subst, 4, q1_ssubst, yes):
685 s(q1_newat, 1, 0, yes):
686 s(q1_time, 1, 0, yes):
687 s(q1_date, 1, 0, yes):
688 s(q1_na, 1, 0, yes):
689 s(q1_set, 0, 0, yes):
690 s(q1_set1, 3, 0, no ):
691 s(q1_tup, 0, 0, yes):
692 s(q1_tup1, 3, 0, no ):
693 s(q1_from, 2, 0, no ):
694 s(q1_fromb, 2, 0, no ):
695 s(q1_frome, 2, 0, no ):
696
697$ iterators:
698
699 s(q1_next, 3, 0, no ):
700 s(q1_nextd, 3, 0, no ):
701 s(q1_inext, 3, 0, no ):
702 s(q1_inextd, 3, 0, no ):
703
704$ mappings:
705
706 s(q1_of, 3, q1_sof, yes):
707 s(q1_ofa, 3, q1_sofa, yes):
708
709 s(q1_sof, 3, 0, no ):
710 s(q1_sofa, 3, 0, no ):
711 s(q1_send, 3, 0, no ):
712 s(q1_ssubst, 4, 0, no ):
713
714$ assignments:
715
716 s(q1_asn, 2, 0, no ):
717
718$ argument passage:
719
720 s(q1_argin, 3, 0, no ):
721 s(q1_argout, 3, 0, yes):
722
723 s(q1_push, 2, 0, no ):
724 s(q1_free, 3, 0, no ):
725
726$ control statements:
727
728 s(q1_call, 2, 0, no ):
729 s(q1_goto, 1, 0, no ):
730
731 s(q1_if, 2, 0, no ):
732 s(q1_ifnot, 2, 0, no ):
smfb 100 s(q1_bif, 2, 0, no ):
smfb 101 s(q1_bifnot, 2, 0, no ):
smfb 102 s(q1_ifasrt, 1, 0, no ):
bnda 14 s(q1_case, 2, 0, no ):
734 s(q1_stop, 0, 0, no ):
735
736 s(q1_entry, 1, 0, no ):
737 s(q1_exit, 1, 0, no ):
738
739 s(q1_ok, 0, 0, no ):
740 s(q1_lev, 1, 0, yes):
741 s(q1_fail, 0, 0, no ):
742 s(q1_succeed, 0, 0, no ):
743
744 s(q1_asrt, 1, 0, no ):
745 s(q1_stmt, 0, 0, no ):
746 s(q1_label, 1, 0, no ):
747 s(q1_tag, 1, 0, no ):
748 s(q1_debug, 1, 0, no ):
749 s(q1_trace, 1, 0, no ):
750 s(q1_notrace, 1, 0, no ):
751 s(q1_error, 0, 0, no ):
752 s(q1_noop, 0, 0, no );
753
754 macdrop(s)
755
756
757$ the matrix 'prefix_map' is used to handle type descriptors
758$ such as 'remote set(int)' which involve a prefix and a type.
759$ it maps the prefix and the initial ft_type into a new ft_type.
760
761 +* prefix_map(prefix, type) =
762 .f. 1 + 8 * (prefix-sym_local), 8, a_prefix(type+1)
763 **
764
765 size a_prefix(40);
766 dims a_prefix(f_max+1);
767 data a_prefix = 0(f_max+1);
768
769
770$ the function 'mode_map' maps mode keywords (such as 'general') to
771$ the corresponding forms (such as 'f_gen').
772
773 +* mode_map(mode) = a_mode(mode - sym_mgen + 1) **
774
775 size a_mode(ps);
776 dims a_mode(sym_mode_max - sym_mode_min + 1);
777
778 data a_mode(sym_mgen) = f_gen:
779 a_mode(sym_mint) = f_int:
780 a_mode(sym_mreal) = f_real:
781 a_mode(sym_mstring) = f_string:
782 a_mode(sym_mbool) = f_atom:
783 a_mode(sym_matom) = f_atom:
784 a_mode(sym_merror) = f_error:
785 a_mode(sym_melmt) = 0:
786 a_mode(sym_mtuple) = f_tuple:
787 a_mode(sym_mset) = f_uset:
788 a_mode(sym_mmap) = f_umap:
789 a_mode(sym_msmap) = 0:
790 a_mode(sym_mmmap) = 0;
791
792
793$ the functions 'tuple_type' and 'map_type' map element forms
794$ to the corresponding tuple- and map-forms.
795
796 +* tuple_type(fm) = .f. 01, 08, a_type_tab(ft_type(fm)+1) **
797 +* map_type(fm) = .f. 09, 08, a_type_tab(ft_type(fm)+1) **
798
799 size a_type_tab(32);
800 dims a_type_tab(f_max+1);
801 data
802
803 +* s(fm, tuple, map) =
804 a_type_tab(fm+1) = map*4b'000100'
805 + tuple*4b'000001'
806 **
807
808 s(f_gen, f_tuple, f_umap ):
809 s(f_sint, f_tuple, f_umap ):
810 s(f_sstring, f_tuple, f_umap ):
811 s(f_atom, f_tuple, f_umap ):
812 s(f_latom, f_tuple, f_umap ):
813 s(f_elmt, f_tuple, f_umap ):
814 s(f_uint, f_ituple, f_uimap ):
815 s(f_ureal, f_rtuple, f_urmap ):
816 s(f_int, f_tuple, f_umap ):
817 s(f_string, f_tuple, f_umap ):
818 s(f_real, f_tuple, f_umap ):
819 s(f_ituple, f_tuple, f_umap ):
820 s(f_rtuple, f_tuple, f_umap ):
821 s(f_ptuple, f_tuple, f_umap ):
822 s(f_tuple, f_tuple, f_umap ):
823 s(f_mtuple, f_tuple, f_umap ):
824 s(f_uset, f_tuple, f_umap ):
825 s(f_lset, f_tuple, f_umap ):
826 s(f_rset, f_tuple, f_umap ):
827 s(f_umap, f_tuple, f_umap ):
828 s(f_lmap, f_tuple, f_umap ):
829 s(f_rmap, f_tuple, f_umap ):
830 s(f_lpmap, f_tuple, f_umap ):
831 s(f_limap, f_tuple, f_umap ):
832 s(f_lrmap, f_tuple, f_umap ):
833 s(f_rpmap, f_tuple, f_umap ):
834 s(f_rimap, f_tuple, f_umap ):
835 s(f_rrmap, f_tuple, f_umap ):
836 s(f_base, f_tuple, f_umap ):
837 s(f_pbase, f_tuple, f_umap ):
838 s(f_uimap, f_tuple, f_umap ):
839 s(f_urmap, f_tuple, f_umap ):
840 s(f_error, f_tuple, f_umap ):
841 s(f_proc, f_tuple, f_umap ):
842 s(f_memb, f_tuple, f_umap ):
843 s(f_lab, f_tuple, f_umap );
844
845 macdrop(s);
846
847
848$ miscelaneous global variables
849$ -----------------------------
850
851
852 size curmemb(ps); $ name of current member
853 size curdir(ps); $ name of current directory
854 size currout(ps); $ name of current routine
855 size curperf(ps); $ name of current perform block
856 size curunit(ps); $ name of current unit
857
858 data curmemb = 0:
859 curdir = 0:
860 currout = 0:
861 curperf = 0:
862 curunit = 0;
863
864$ each unit has a code unit_xxx associated with it which indicates
865$ whether it is a module, program, library, or procedure. the
866$ global unit_type indicates the mode of the current unit, and
867$ the global 'memb_type' indicates the type of the current member.
868
869 size unit_type(ps),
870 memb_type(ps);
871
872 .=zzyorg z $ unit_xxx codes
873
874 defc(unit_sys) $ unit for system names
875 defc(unit_lib) $ library
876 defc(unit_dir) $ directory
877 defc(unit_prog) $ main program
878 defc(unit_mod) $ module
879 defc(unit_proc) $ procedure
880 defc(unit_end) $ end of compilation
881
882 +* unit_min = unit_sys **
883 +* unit_max = unit_end **
884
885 data unit_type = unit_sys;
886
887 size stop_lab(ps); $ stop label for current routine
888 size exit_lab(ps); $ exit label for current routine
889
890 size op_flag(1); $ true if current procedure is an operator
891
892
893$ we keep three statement counters:
894
895$ cstmt_count: the cummulative statement count
896$ ustmt_count: the cstmt_count at the start of the current unit
897$ estmt_count: the cstmt_count for the q1_entry instruction in a
898$ procedure scope. note that this counter is not set
899$ in a non-procedure scope.
900
901$ the current statement number is equal to cstmt_cout - ustmt_count + 1.
902 +* stmt_count = (cstmt_count - ustmt_count + 1) **
903
904 size cstmt_count(ps); data cstmt_count = 0;
905 size ustmt_count(ps); data ustmt_count = 0;
906 size estmt_count(ps); data estmt_count = 0;
907
908
909 size error_count(ps); $ number of errors
910 data error_count = 0;
911
912
913$ the following variables are used to process module and program
914$ headers:
915
916 size head_ptr(ps); $ vptr for corresponding val entry
917 size head_len(ps); $ vlen for corresponding val entry
918 size head_tot(ps); $ total number of global names in header
919
920 size cur_rt(ps); $ name of rights list being processed
921
922$ rt_len maps each rigths name(imports, exports, etc.) into the lenght
923$ of the corresponding rights list.
924
925 +* rt_len(i) = a_rt_len(i - sym_rts_min + 1) **
926
927 size a_rt_len(ps);
928 dims a_rt_len(sym_rts_max - sym_rts_min + 1);
929
930
931$ 'bvar_flag' is on when we must save the bound variable in
932$ << x in s st c(x) >>.
933
934 size bvar_flag(1);
935 data bvar_flag = no;
936
937$ the flag 'bk_flag' is on when compiling a 'var' statement for
938$ backtracked variable.
939
940 size bk_flag(1);
941 data bk_flag = no;
942
943
944
945$ the following variables give the maximum values of various
946$ table pointers.
947
948 size names_max(ps); $ namesp
949 size val_max(ps); $ val
950 size symtab_max(ps); $ symtab
951 size formtab_max(ps); $ formtab
952 size mttab_max(ps); $ mttab
953 size codetab_max(ps); $ codetab
954 size argtab_max(ps); $ argtab
955 size blocktab_max(ps); $ blocktab
956
957 data names_max = 0:
958 val_max = 0:
959 symtab_max = 0:
960 formtab_max = 0:
961 mttab_max = 0:
962 codetab_max = 0:
963 argtab_max = 0:
964 blocktab_max = 0;
965
966
967
968
969$ compilation parameters
970$ ----------------------
971
972$ the following global variables are read in from the control card
973$ to select various compiler options.
974
975 size mpol_title(.sds. filenamlen); $ main polish file
976 size xpol_title(.sds. filenamlen); $ auxiliary polish file
977 size q1_title(.sds. filenamlen); $ little q1 file
978 size sq1_title(.sds. filenamlen); $ setl q1 file
979 size bind_title(.sds. filenamlen); $ binder file
980 size ibnd_title(.sds. filenamlen); $ indirect binder file
981 size term_title(.sds. filenamlen); $ terminal file
982
983 size tre_flag(1); $ entry trace
984 size trp_flag(1); $ polish string trace
985 size trs_flag(1); $ astack trace
986 size ur_flag(1); $ give warnings for unrepr'ed variables
987 size uv_flag(1); $ give warnings for undeclared variables
988 size et_flag(1); $ error trace desired
989 size chk_flag(1); $ check for valid code fragments
990 size q1sd_flag(1); $ q1 symbol table dump requested
991 size q1cd_flag(1); $ q1 code dump requested
992 size sel(ps); $ semantic error limit
sunb 12 size lcp_flag(1); $ listing control: program parameters
sunb 13 size lcs_flag(1); $ listing control: program statistics
993 size opt_flag(1); $ global optimization flag
smfb 103 size rpr_flag(ps); $ process repr statements
995 size sif_flag(1); $ save intermediate files
996
997$ in general, iterations such as 'x in s' must be done using
998$ shadow variables so that assignments to x and s within the
999$ loop do not cause problems.
1000
1001$ the 'diter' control card option indicates that iteration
1002$ can be performed directly on x and s. it implies that
1003$ they are never modified within the loop.
1004
1005 size diter_flag(1);
1006
1007
1008$ file identifiers
1009$ ---- -----------
1010
1011 .=zzyorg z
1012
1013 defc(inp_file) $ input
1014 defc(out_file) $ output
1015 defc(mpol_file) $ main polish file
1016 defc(xpol_file) $ auxiliary polish file
1017 defc(q1_file) $ q1 output
1018 defc(sq1_file) $ setl q1 binary output
1019 defc(bind_file) $ binder input
1020 defc(ibnd_file) $ indirect binder inputs
1021
1022 size pol_file(ps); $ current polish file
1023 data pol_file = mpol_file;
1024
1025
1026$ utility functions
1027$ -----------------
1028
1029$ the following utility functions are used often enough to be sized
1030$ globaly:
1031
1032 size hash(ps), $ hashes array into symtab
1033 hashst(ps), $ hashes string into symtab
1034 hashf1(ps), $ hashes simple form into formtab
1035 hashf2(ps), $ hashes form with mttab entry into formta
1036 getsym(ps), $ gets new symtab entry
1037 gettmp(ps), $ gets new temporary
1038 getvar(ps), $ gets new variable
1039 getglb(ps), $ gets new global
1040 getlab(ps), $ gets new label
1041 getint(ps), $ gets new integer
1042 copy(ps), $ copies the code for an expression
1043 symsds(sds_sz); $ gets symbol name as sds
1044
1045
1046$ general utility macros
1047$ ----------------------
1048
1049 +* symtype(nam) = $ type of symbol
1050 ft_type(form(nam))
1051 **
1052
1053
1054 +* symval(nam) = $ first word of value
1055 val(vptr(nam))
1056 **
1057
1058
1059 +* lines_max = $ number of lines between headings on dumps
1060 20
1061 **
1062
1063
1064
1065
1066$ main program
1067
1068
1069
1070
1071 call semini; $ initialize
1072
1073 call binder; $ bind previous compilations
1074
1075 call driver; $ interpret polish string
1076
1077 call semtrm; $ terminate
1078
1079
1080
1081
suna 21 .+r32 end prog stlsem;
suna 22 .+r36 end prog stlsem;
1087 .+s66 end subr start;
1 .=member semini
2 subr semini;
3
4$ this routine is called to initialize the semantic pass. there
5$ are four types of initialization performed:
6
7$ 1. read control card parameters
8$ 2. open files and read initial tables
9$ 3. initialize standard symtab amd formtab entries
10$ 4. initialize codetab.
11
12
13 size timestr(.sds. 30); $ current time and date
14 size termh_flag(1); $ print phase header on the terminal
15
16 size op(ps); $ q1 opcode
17 size ret(ps); $ return code from dropsio and namesio
18
19$ get name of terminal file from little
20
21 term_title = '';
22 call namesio(max_no_files, ret, term_title, filenamlen); $ errors
23 if (ret > 1) term_title = ''; $ error, no term, or namesio
24 $ not implemented
25$ read control card options:
26
27 .+s10.
28 call getspp(mpol_title, 'pol=pol/pol'); $ polish string
29 call getspp(xpol_title, 'xpol=xpol/xpol'); $ aux polish str
30 call getspp(bind_title, 'bind=0/bind'); $ binder input
31 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind bind input
32 call getspp(q1_title, 'q1=q1/q1'); $ q1 output
33 call getspp(sq1_title, 'sq1=0/sq1'); $ setl q1 output
34 ..s10
35
36 .+s20.
37 call getspp(mpol_title, 'pol=pol/pol'); $ polish string
38 call getspp(xpol_title, 'xpol=xpol/xpol'); $ aux polish str
39 call getspp(bind_title, 'bind=0/bind'); $ binder input
40 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind bind input
41 call getspp(q1_title, 'q1=q1/q1'); $ q1 output
42 call getspp(sq1_title, 'sq1=0/sq1'); $ setl q1 output
43 ..s20
44
45
46 .+s32.
47 call getspp(mpol_title, 'pol=pol.tmp/'); $ polish string
48 call getspp(xpol_title, 'xpol=xpol.tmp/'); $ aux polish str
49 call getspp(bind_title, 'bind=0/bind.tmp'); $ binder input
50 call getspp(ibnd_title,'ibind=0/ibind.tmp');$ ind bind input
51 call getspp(q1_title, 'q1=q1.tmp/'); $ q1 output
52 call getspp(sq1_title, 'sq1=0/sq1.tmp'); $ setl q1 output
53 ..s32
54
55 .+s37cms.
56 call getspp(mpol_title, 'pol=pol/pol'); $ polish string
57 call getspp(xpol_title, 'xpol=xpol/xpol'); $ aux polish str
58 call getspp(bind_title, 'bind=0/bind'); $ binder input
59 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind bind input
60 call getspp(q1_title, 'q1=q1/q1'); $ q1 output
61 call getspp(sq1_title, 'sq1=0/sq1'); $ setl q1 output
62 ..s37cms
63 .+s37mts.
64 call getspp(mpol_title, 'pol=-setlpol/'); $ polish string
65 call getspp(xpol_title, 'xpol=-setlxpol/'); $ aux. polish string
66 call getspp(bind_title, 'bind=0/bind'); $ binder input
67 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind. binder input
68 call getspp(q1_title, 'q1=-setlq1/'); $ little q1 file
69 call getspp(sq1_title, 'sq1=0/-setlsq1'); $ setl q1 file
70 ..s37mts
71 .+s47.
72 call getspp(mpol_title, 'pol=pol/pol'); $ polish string
73 call getspp(xpol_title, 'xpol=xpol/xpol'); $ aux polish str
74 call getspp(bind_title, 'bind=0/bind'); $ binder input
75 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind bind input
76 call getspp(q1_title, 'q1=q1/q1'); $ q1 output
77 call getspp(sq1_title, 'sq1=0/sq1'); $ setl q1 output
78 ..s47
79
80 .+s66.
81 call getspp(mpol_title, 'pol=pol/pol'); $ polish string
82 call getspp(xpol_title, 'xpol=xpol/xpol'); $ aux polish str
83 call getspp(bind_title, 'bind=0/bind'); $ binder input
84 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind bind input
85 call getspp(q1_title, 'q1=q1/q1'); $ q1 output
86 call getspp(sq1_title, 'sq1=0/sq1'); $ setl q1 output
87 ..s66
suna 23
suna 24 .+s68.
suna 25 call getspp(mpol_title, 'pol=setl.pol/'); $ polish string
suna 26 call getspp(xpol_title, 'xpol=setl.xpol/'); $ aux polish str
suna 27 call getspp(bind_title, 'bind=0/bind'); $ binder input
suna 28 call getspp(ibnd_title, 'ibind=0/ibind'); $ ind bind input
suna 29 call getspp(q1_title, 'q1=setl.lq1/'); $ little q1 file
suna 30 call getspp(sq1_title, 'sq1=0/setl.sq1'); $ setl q1 file
suna 31 ..s68
88
89 call getipp(tre_flag, 'tre=0/1'); $ entry trace
90 call getipp(trp_flag, 'trp=0/1'); $ trace polish string
91 call getipp(trs_flag, 'trs=0/1'); $ trace astack
92 call getipp(ur_flag, 'ur=0/1'); $ warning for unrepr'ed vars
93 call getipp(uv_flag, 'uv=0/1'); $ warning for undeclared var
94 call getipp(et_flag, 'et=0/1'); $ dump tables after error
95 call getipp(chk_flag, 'chk=0/1'); $ check code fragments
96 call getipp(q1sd_flag, 'sq1sd=0/1'); $ dump q1 symbol tables
97 call getipp(q1cd_flag, 'sq1cd=0/1'); $ dump q1 code
98 call getipp(sel, 'sel=1000/1000');
99 call getipp(opt_flag, 'opt=0/1'); $ global optimization
100 call getipp(rpr_flag, 'reprs=1/1'); $ process repr statements
101 call getipp(sif_flag, 'sif=0/1'); $ save polish files
102 call getipp(diter_flag, 'diter=0/1'); $ direct iteration
103 call getipp(termh_flag, 'termh=0/1'); $ print phase header
sunb 14
sunb 15
sunb 16 .-s68.
sunb 17 .-s47.
sunb 18 .-s32u.
sunb 19 call getipp(lcp_flag, 'lcp=1/1'); $ list program parameters
sunb 20 call getipp(lcs_flag, 'lcs=1/1'); $ list program statistics
sunb 21 .+s32u.
sunb 22 call getipp(lcp_flag, 'lcp=0/1'); $ list program parameters
sunb 23 call getipp(lcs_flag, 'lcs=0/1'); $ list program statistics
sunb 24 ..s32u
sunb 25 .+s47.
sunb 26 call getipp(lcp_flag, 'lcp=0/1'); $ list program parameters
sunb 27 call getipp(lcs_flag, 'lcs=0/1'); $ list program statistics
sunb 28 ..s47
sunb 29 .+s68.
sunb 30 call getipp(lcp_flag, 'lcp=0/1'); $ list program parameters
sunb 31 call getipp(lcs_flag, 'lcs=0/1'); $ list program statistics
sunb 32 ..s68
sunb 33
104
105 $ initialize little trace
106 if tre_flag then
107 monitor entry, limit = 10000;
108 else
109 monitor noentry;
110 end if;
111
112 $ open files
113 file mpol_file access = read, title = mpol_title;
114 file xpol_file access = read, title = xpol_title;
115 file bind_file access = read, title = bind_title;
116 file ibnd_file access = get, title = ibnd_title,
117 linesize = 80;
118 file q1_file access = write, title = q1_title;
119 file sq1_file access = write, title = sq1_title;
120
121 if (.len. term_title) call opnterm(term_title);
122
123 $ indicate which files can be deleted upon completion of sem
124 if ^ sif_flag then
125 call dropsio(mpol_file, ret);
126 call dropsio(xpol_file, ret);
127 end if;
128
129 .+s66.
130 rewind mpol_file; rewind xpol_file; rewind bind_file;
131 rewind q1_file; rewind sq1_file; rewind ibnd_file;
132 ..s66
133
134 $ little reserves the file title '0' for a *sink*. there is,
135 $ however, no need for the setl user to know about this, and
136 $ we therefore reset the bind- and sq1-titles to the null
137 $ string if no such files were supplied by the user.
138 if (bind_title .seq. '0') bind_title = '';
139 if (ibnd_title .seq. '0') ibnd_title = '';
140 if (sq1_title .seq. '0') sq1_title = '';
141
142 $ initialize listing control
143 call contlpr( 6, yes); $ start paging
144 call contlpr( 7, yes); $ enable titling
145 call lstime(timestr); $ get current time
146 call etitlr(0, 'cims.setl.' .cc. prog_level, 1, 0);
147 call etitlr(0, timestr, 41, 0);
148 call etitlr(0, 'page', 71, 0);
149 call contlpr( 8, 76); $ set page number in column 76
150 call contlpr(13, 0); $ set number of current page
sunb 34 call contlpr(10, ret); $ get lines per page
sunb 35 call contlpr(15, ret); $ set line number within page
151
sunb 36 if lcp_flag then $ print phase heading
sunb 37 put ,'parameters for this compilation: ' ,skip
155 ,skip ,'polish string file: pol = ' :mpol_title ,a ,'. '
156 ,skip ,'auxiliary string file: xpol = ' :xpol_title ,a ,'. '
157 ,skip ,'binder file: bind = ' :bind_title ,a ,'. '
158 ,'ind. bind file: ibind = ' :ibnd_title ,a ,'. '
159 ,skip ,'little q1 file: q1 = ' :q1_title ,a ,'. '
160 ,'setl q1 file: sq1 = ' :sq1_title ,a ,'. '
161 ,skip ,'semantic error limit: sel = ' :sel ,i ,'. '
162 ,'semantic error file: term = ' :term_title ,a ,'. '
163 ,skip ,'global optimisation: opt = ' :opt_flag ,i ,'. '
164 ,'user data structures: reprs = ' :rpr_flag ,i ,'. '
165 ,skip ,'direct iteration: diter = ' :diter_flag ,i ,'. '
166 ,skip;
sunb 38 end if;
167
168 if termh_flag then
169 $ the following line is printed on the terminal file only
170 call contlpr(26, no); call contlpr(27, yes);
171 put ,' start cims.setl.' ,prog_level :timestr ,a ,skip;
172 call contlpr(26, yes); call contlpr(27, no);
173 end if;
174
175 .-sq1.
176 if .len. sq1_title then
177 put, skip, column(5); $ emit blank line, position next line
178 call contlpr(27, yes);$ echo to the terminal
179 put, '*** setl q1 interface not available ***', skip;
180 call contlpr(27, no); $ stop to echo to the terminal
181 call ltlfin(1, 0);
182 end if;
183 ..sq1
184
185$ initialize prefix_map.
186
187 +* s(i, j, k) = prefix_map(i, j) = k; **
188
189 s(sym_local, f_uset, f_lset);
190 s(sym_local, f_umap, f_lmap);
191 s(sym_local, f_uimap, f_limap);
192 s(sym_local, f_urmap, f_lrmap);
193
194 s(sym_packed, f_tuple, f_ptuple);
195 s(sym_packed, f_lmap, f_lpmap);
196 s(sym_packed, f_rmap, f_rpmap);
197
198 s(sym_remote, f_uset, f_rset);
199 s(sym_remote, f_umap, f_rmap);
200 s(sym_remote, f_uimap, f_rimap);
201 s(sym_remote, f_urmap, f_rrmap);
202
203 s(sym_sparse, f_uset, f_uset);
204 s(sym_sparse, f_umap, f_umap);
205 s(sym_sparse, f_uimap, f_uimap);
206 s(sym_sparse, f_urmap, f_urmap);
207
208 s(sym_untyped, f_sint, f_uint);
209 s(sym_untyped, f_int, f_uint);
210 s(sym_untyped, f_real, f_ureal);
211
212 macdrop(s);
213
214$ initialize the q1 tables
215
216 call inform;
217 call inisym;
218 call incode;
219
220
221 end subr semini;
1 .=member inform
2 subr inform;
3
4$ this routine builds the standard entries for formtab. this
5$ is simply a matter of iterating over the ft_type codes, hashing
6$ in the proper entries.
7
8 size fm(ps); $ form table pointer
9 size j(ps); $ loop index
10
11 do j = f_min to f_max;
12 countup(formtabp, formtab_lim, 'formtabp');
13
14 formtab(formtabp) = 0;
15 ft_type(formtabp) = j;
16
17$ fill in any special fields
18
19 if is_fmap(j) then $ set mapc
20 ft_mapc(formtabp) = ft_map;
21 ft_elmt(formtabp) = f_tuple;
22 ft_imset(formtabp) = f_uset;
23
24 if is_fimap(j) then $ untyped integer map
25 ft_im(j) = f_uint;
26 elseif is_frmap(j) then $ untyped real map
27 ft_im(j) = f_ureal;
28 end if;
29
30 elseif is_ftup(j) then $ keep nelt
31 ft_neltok(j) = yes;
32
33 if j = f_ituple then
34 ft_elmt(j) = f_uint;
35 elseif j = f_rtuple then
36 ft_elmt(j) = f_ureal;
37 end if;
38 end if;
39
40 fm = hashf1(0);
41 end do;
42
43
44 end subr inform;
1 .=member inisym
2 subr inisym;
3
4$ this routine initializes the symbol table.
5
6
7 size fm(ps); $ form table pointer
8 size p(ps); $ symtab pointer
9 size j(ps); $ loop index
10
11 size digit(.sds. 1); $ digits as stringds
12 dims digit(10);
13 data digit = '0', '1', '2', '3', '4', '5', '6', '7', '8', '9';
14
15 size genst(ps); $ builds sets and tuples
16 size getint(ps); $ returns symbol table entry for integer
17
18
19$ the standard symbols are arranged in several strings, separated
20$ by blanks. we call 'inistd' to process each string.
21
22 $ system defined modes
23 call inistd('general integer real string boolean atom ');
24 call inistd('error elmt tuple set map smap mmap ');
25
26 $ base type keywords
27 call inistd('local remote sparse packed untyped ');
28
29 $ read-write keywords
30 call inistd('rd wr rw ');
31
32 $ keywords for rights lists
33 call inistd('libraries reads writes imports exports ');
34
35 $ system defined binary operators
36 call inistd('impl or and in notin incs subset < <= > >= = /= ');
37 call inistd('with from fromb frome less lessf ');
38 call inistd('npow min max + - * / div mod ? atan2 ** ');
39
40 $ system define unary operators
41 call inistd('not even odd is_integer is_real is_string ');
42 call inistd('is_boolean is_atom is_tuple ');
43 call inistd('is_set is_map arb domain range pow # ');
44 call inistd('abs char ceil floor fix float sin cos tan ');
45 call inistd('asin acos atan tanh exp log sqrt random ');
46 call inistd('sign type str val ');
47
48 $ compiler debugging options
49 call inistd('ptrm0 ptrm1 ptrp0 ptrp1 ptrt0 ptrt1 ');
50 call inistd('prsod prspd prssd ');
51 call inistd('stre0 stre1 strs0 strs1 sq1cd sq1sd scstd ');
52 call inistd('cq1cd cq1sd cq2cd ');
53 call inistd('rtre0 rtre1 rtrc0 rtrc1 ');
54 call inistd('rtrg0 rtrg1 rgcd0 rgcd1 rdump rgarb ');
55
56 $ user trace options
57 call inistd('calls statements ');
58
59 $ system constants
60 call inistd('''integer'' ''real'' ''string'' ');
61 call inistd('''boolean'' ''atom'' ''tuple'' ''set'' ');
62 call inistd('om s$nullset s$nulltup s$nullstr true false ');
63
64 $ initialize standard integers.
65 do j = 1 to 10;
66 push1(hashst(digit(j))); call gint; free_stack(1);
67 end do;
68
69
70 $ misc. symbols
71 call inistd('_main ');
72
73 $ the run time library uses several special variables with
74 $ with primal scope. call gvar to process them.
75 push1(hashst('s$t1')); $ used by copy routine
76 push1(hashst('s$t2'));
77 push1(hashst('s$t3'));
78 push1(hashst('s$t4'));
79
80 push1(hashst('s$okval')); $ result of 'ok'
81
82 push1(hashst('s$fid')); $ map on file names
83 push1(hashst('s$free')); $ set of free file ids
84 push1(hashst('s$fmax')); $ maximum file id
85 push1(hashst('s$fmode')); $ map on file modes
86
87 push1(hashst('s$io1')); $ io work areas
88 push1(hashst('s$io2'));
89
90 push1(hashst('s$stat')); $ tuple for performance measurements
91
92 push1(hashst('s$ss1')); $ string specifier one
93 push1(hashst('s$ss2')); $ string specifier two
94
95 push1(hashst('s$ovar')); $ packed tuple for q2 ops_ovar
96 push1(hashst('s$scopes')); $ packed tuple for variable tracing
97 push1(hashst('s$rnspec')); $ untyped tuple for runtime names spec
98 push1(hashst('s$rnames')); $ character string for run-time names
99 push1(hashst('s$intf')); $ fortran interface tuple
100 push1(hashst('s$spare2')); $ and testing of new features
101 push1(hashst('s$spare3'));
102 push1(hashst('s$spare4'));
103 push1(hashst('s$spare5'));
104 push1(hashst('s$spare6'));
105 push1(hashst('s$spare7'));
106 push1(hashst('s$spare8'));
107 push1(hashst('s$spare9'));
108 push1(hashst('s$sparea'));
109 push1(hashst('s$spareb'));
110 push1(hashst('s$sparec'));
111 push1(hashst('s$spared'));
112 push1(hashst('s$sparee'));
113 push1(hashst('s$sparef'));
114 push1(hashst('s$spareg'));
115 push1(hashst('s$spareh'));
116 push1(hashst('s$sparei'));
117 push1(hashst('s$sparej'));
118 push1(hashst('s$sparek'));
119
120 push1(37); $ number of library variables hereabove
121 $ added to the symbol table
122 call gnobk;
123 call gvar;
124
125
126 $ built in procedures
127 call inistd('open close print read printa reada get put ');
128 call inistd('getb putb getk putk getf callf putf rewind eof ');
129 call inistd('eject title getipp getspp ');
130 call inistd('getem setem ');
131 call inistd('host ');
132 call inistd('span break match lpad len any notany ');
133 call inistd('rspan rbreak rmatch rpad rlen rany rnotany ');
134
135
136 $ initialize system constants
137 do j = sym_int to sym_set;
138 push1(j); call gstr; free_stack(1);
139 end do;
140
141 $ declare 'om' like a read only variable.
142 is_decl(sym_om) = yes;
143 is_read(sym_om) = yes;
144 is_repr(sym_om) = yes;
145 is_store(sym_om) = yes;
146
147 push2(sym_nulltup, genst(q1_tup, 0)); call gcnst1;
148 push2(sym_nullset, genst(q1_set, 0)); call gcnst1;
149 push2(sym_nullstr, hashst(2q'')); call gstr; call gcnst1;
150
151
152 $ initialize true and false as short atoms 0 and maxsi, resp.
153 is_repr(sym_true) = yes; is_decl(sym_true) = yes;
154 is_read(sym_true) = yes; is_store(sym_true) = yes;
155 form(sym_true) = f_atom;
156 countup(valp, val_lim, 'val'); val(valp) = 0;
157 vptr(sym_true) = valp; vlen(sym_true) = 1;
158
159 is_repr(sym_false) = yes; is_decl(sym_false) = yes;
160 is_read(sym_false) = yes; is_store(sym_false) = yes;
161 form(sym_false) = f_atom;
162 countup(valp, val_lim, 'val'); val(valp) = maxsi;
163 vptr(sym_false) = valp; vlen(sym_false) = 1;
164
165 $ build form table entry for 'tuple(general)(2)'
smfa 13 push2(f_gen, sym_two); call gttup2; pop1(fm);
167 assert fm = f_pair;
168
169 $ build form table entry for 'packed tuple(integer 1..1)'
170 push1(sym_packed);
171 push3(sym_mint, sym_one, sym_one); call gtint;
172 push1(sym_zero); call gttup2; call gtpref; pop1(fm);
173 assert fm = f_pt11;
174
175 $ build form table entry for 'packed tuple(integer 1..pset_lim)'
176 push1(sym_packed);
177 push3(sym_mint, sym_one, getint(pset_lim)); call gtint;
178 push1(sym_zero); call gttup2; call gtpref; pop1(fm);
179 assert fm = f_pset;
180
181 $ declare builtin procedures and main program
182 call inbip1;
183
184 user_org = symtabp; $ point to zero-th symbol supplied by user
185
186 call gputtb; $ write out system scope
187
188
189 end subr inisym;
1 .=member inbip1
2 subr inbip1;
3
4$ this routine initializes the built in procedures. this is done in
5$ two steps: first we declare the procedures, then we repr them.
6
7
8 +* s(nam, n, m1, m2, m3, var) = $ declare procedure
9 call inbip2(nam, n, m1, m2, m3, var);
10 **
11
smfb 104 s(sym_open, 2, sym_rd, sym_rd, 0, no );
smfb 105 s(sym_close, 1, sym_rd, 0, 0, no );
14 s(sym_print, 1, sym_rd, 0, 0, yes);
15 s(sym_read, 1, sym_wr, 0, 0, yes);
16 s(sym_printa, 2, sym_rd, sym_rd, 0, yes);
17 s(sym_reada, 2, sym_rd, sym_wr, 0, yes);
18 s(sym_get, 2, sym_rd, sym_wr, 0, yes);
19 s(sym_put, 2, sym_rd, sym_rd, 0, yes);
20 s(sym_getb, 2, sym_rd, sym_wr, 0, yes);
21 s(sym_putb, 2, sym_rd, sym_rd, 0, yes);
22 s(sym_getk, 2, sym_rd, sym_wr, 0, no );
23 s(sym_putk, 2, sym_rd, sym_rd, 0, no );
24 s(sym_getf, 2, sym_rd, sym_wr, 0, yes);
25 s(sym_callf, 3, sym_rd, sym_rd, sym_rd, no );
26 s(sym_putf, 2, sym_rd, sym_rd, 0, yes);
27 s(sym_rewind, 1, sym_rd, 0, 0, no );
28 s(sym_eof, 0, 0, 0, 0, no );
29 s(sym_eject, 1, sym_rd, 0, 0, yes);
30 s(sym_title, 1, sym_rd, 0, 0, yes);
31
32 s(sym_getipp, 1, sym_rd, 0, 0, no );
33 s(sym_getspp, 1, sym_rd, 0, 0, no );
34 s(sym_getem, 2, sym_wr, sym_wr, 0, no );
35 s(sym_setem, 2, sym_rd, sym_rd, 0, no );
36
37 s(sym_host, 1, sym_rd, 0, 0, yes);
38
39 s(sym_span, 2, sym_rw, sym_rd, 0, no );
40 s(sym_break, 2, sym_rw, sym_rd, 0, no );
41 s(sym_match, 2, sym_rw, sym_rd, 0, no );
42 s(sym_lpad, 2, sym_rd, sym_rd, 0, no );
43 s(sym_len, 2, sym_rw, sym_rd, 0, no );
44 s(sym_any, 2, sym_rw, sym_rd, 0, no );
45 s(sym_notany, 2, sym_rw, sym_rd, 0, no );
46
47 s(sym_rspan, 2, sym_rw, sym_rd, 0, no );
48 s(sym_rbreak, 2, sym_rw, sym_rd, 0, no );
49 s(sym_rmatch, 2, sym_rw, sym_rd, 0, no );
50 s(sym_rpad, 2, sym_rd, sym_rd, 0, no );
51 s(sym_rlen, 2, sym_rw, sym_rd, 0, no );
52 s(sym_rany, 2, sym_rw, sym_rd, 0, no );
53 s(sym_rnotany, 2, sym_rw, sym_rd, 0, no );
54
55 s(sym_main_, 0, 0, 0, 0, no );
56
57 macdrop(s)
58
59
60 +* s(nam, n, f1, f2, f3, f4) = $ repr procedure
61 call inbip3(nam, n, f1, f2, f3, f4);
62 **
63
64
65 s(sym_open, 2, f_string, f_string, 0, f_atom );
smfb 106 s(sym_close, 1, f_string, 0, 0, f_gen );
67 s(sym_print, 1, f_gen, 0, 0, f_gen );
68 s(sym_read, 1, f_gen, 0, 0, f_gen );
69 s(sym_printa, 2, f_string, f_gen, 0, f_gen );
70 s(sym_reada, 2, f_string, f_gen, 0, f_gen );
71 s(sym_get, 2, f_string, f_string, 0, f_gen );
72 s(sym_put, 2, f_string, f_string, 0, f_gen );
73 s(sym_getb, 2, f_string, f_gen, 0, f_gen );
74 s(sym_putb, 2, f_string, f_gen, 0, f_gen );
75 s(sym_getk, 2, f_string, f_gen, 0, f_gen );
76 s(sym_putk, 2, f_string, f_gen, 0, f_gen );
77 s(sym_getf, 2, f_sint, f_gen, 0, f_gen );
78 s(sym_callf, 3, f_sint, f_sint, f_sint, f_gen );
79 s(sym_putf, 2, f_sint, f_gen, 0, f_gen );
80 s(sym_rewind, 1, f_string, 0, 0, f_gen );
81 s(sym_eof, 0, 0, 0, 0, f_atom );
82 s(sym_eject, 1, f_gen, 0, 0, f_gen );
83 s(sym_title, 1, f_gen, 0, 0, f_gen );
84
85 s(sym_getipp, 1, f_string, 0, 0, f_int );
86 s(sym_getspp, 1, f_string, 0, 0, f_string);
87 s(sym_getem, 2, f_sint, f_sint, 0, f_gen );
88 s(sym_setem, 2, f_sint, f_sint, 0, f_gen );
89
90 s(sym_host, 1, f_gen, 0, 0, f_gen);
91
92 s(sym_span, 2, f_string, f_string, 0, f_string);
93 s(sym_break, 2, f_string, f_string, 0, f_string);
94 s(sym_match, 2, f_string, f_string, 0, f_string);
95 s(sym_lpad, 2, f_string, f_sint, 0, f_string);
96 s(sym_len, 2, f_string, f_sint, 0, f_string);
97 s(sym_any, 2, f_string, f_string, 0, f_string);
98 s(sym_notany, 2, f_string, f_string, 0, f_string);
99
100 s(sym_rspan, 2, f_string, f_string, 0, f_string);
101 s(sym_rbreak, 2, f_string, f_string, 0, f_string);
102 s(sym_rmatch, 2, f_string, f_string, 0, f_string);
103 s(sym_rpad, 2, f_string, f_sint, 0, f_string);
104 s(sym_rlen, 2, f_string, f_sint, 0, f_string);
105 s(sym_rany, 2, f_string, f_string, 0, f_string);
106 s(sym_rnotany, 2, f_string, f_string, 0, f_string);
107
108
109 macdrop(s)
110
111
112 user_org = symtabp; $ point to zero-th symbol supplied by user
113
114
115 end subr inbip1;
1 .=member inbip2
2 subr inbip2(nam, n, m1, m2, m3, vary);
3
4$ this routine initializes the symbol table entry for a built in
5$ procedure. its arguments are:
6
7 size nam(ps), $ procedure name
8 n(ps), $ number of arguments
9 m1(ps), $ mode for first argument
10 m2(ps), $ mode for second argument
11 m3(ps), $ mode for third argument
12 vary(1); $ indicates variable number of arguments
13
14$ we jump on the number of arguments and make an appropriate call
15$ to prcdcl.
16
17 push1(nam);
18
19 go to case(n) in 0 to 3;
20
21/case(0)/
22
23 go to esac;
24
25/case(1)/
26
27 push1(m1);
28 go to esac;
29
30/case(2)/
31
32 push2(m1, m2);
33 go to esac;
34
35/case(3)/
36
37 push3(m1, m2, m3);
38 go to esac;
39
40/esac/
41
42 call prcdcl(n, vary);
43 free_stack(1);
44
45
46 end subr inbip2;
1 .=member inbip3
2 subr inbip3(nam, n, f1, f2, f3, f4);
3
4$ this routine sets the repr for a built in procedure.
5
6 size nam(ps), $ procedure name
7 n(ps), $ number of arguments
8 f1(ps), $ form of first argument
9 f2(ps), $ form of third argument
10 f3(ps), $ form of third argument
11 f4(ps); $ form of result
12
13 size tp(ps); $ type of procedure
14
15$ we jump on the number of arguments and make an appropriate call
16$ to rproc.
17
18
19 go to case(n) in 0 to 3;
20
21/case(0)/
22
23 push1(f4); call gtprc4; pop1(tp);
24 call rproc(nam, tp);
25 return;
26
27/case(1)/
28
29 push1(f1);
30 go to esac;
31
32/case(2)/
33
34 push2(f1, f2);
35 go to esac;
36
37/case(3)/
38
39 push3(f1, f2, f3);
40 go to esac;
41
42/esac/
43
44 push2(n-1, f4); call gtprc1; pop1(tp);
45 call rproc(nam, tp);
46
47
48 end subr inbip3;
1 .=member inistd
2 subr inistd(string);
3
4$ this routine hashes a series of standard symbols into the symbol
5$ table. the symbols are arranged in a string, seperted by blanks.
6
7 size string(sds_sz); $ string containing symbols
8
9 size first(ps), $ points to start of string
10 last(ps), $ points to blank after string
11 len(ps), $ length of string
12 p(ps); $ pointer returned by hashst
13
14
15 first = 1; $ pointer to start of symbol
16 len = .len. string;
17
18 while first <= len;
19 last = first + 1;
20
21 while .ch. last, string ^= 1r ;
22 last = last + 1;
23 end while;
24
25 p = hashst(.s. first, last-first, string);
26
27 first = last + 1;
28 end while;
29
30
31 end subr inistd;
1 .=member incode
2 subr incode;
3
4$ this routine initializes codetab, argtab, and blocktab.
5
6$ the code for each routine starts with a noop instruction.
7$ both prog_start and prog_end are set to point to this
8$ instruction.
9
10$ initialize pointers
11 argtab_org = 0;
12 codetab_org = 0;
13 blocktab_org = 0;
14
15 argtabp = 0;
16 blocktabp = 0;
17 codetabp = 1;
18
19$ install noop
20 codetab(codetabp) = 0;
21 opcode(codetabp) = q1_noop;
22
23 prog_start = codetabp;
24 prog_end = codetabp;
25
26
27 end subr incode;
1 .=member driver
2 subr driver;
3
4$ this is the main driving routine for the semantic pass. it
5$ iterates over the polish string, performing the appropriate
6$ action for each node.
7
8 size tp(ps), $ type of node
9 vl(ps), $ value of node
10 nam(ps); $ symtab pointer
11
12 size ara(ws); $ array for new names entry
13 dims ara(sds_sz/ws);
14
15
16
17 while 1;
18 getp(tp, vl);
19 if (filestat(pol_file, end)) quit;
20
21 go to case(tp) in pol_min to pol_max;
22
23 /case(pol_name)/ $ hash name and push onto astack
24
25 read pol_file, ara(1) to ara(vl);
26 nam = hash(ara, vl);
27
28 push1(nam);
29 cont;
30
31 /case(pol_count)/ $ push counter
32
33 push1(vl);
34 cont;
35
36 /case(pol_mark)/ $ call semantic routine
37
38 call actgen(vl);
39 cont while 1;
40
41 /case(pol_end)/ $ end-of-file
42
43 quit while 1;
44
45 end while;
46
47 end subr driver;
1 .=member gsw1
2 subr gsw1;
3
4$ this routine switches to the main polish file.
5
6 pol_file = mpol_file;
7
8
9 end subr gsw1;
1 .=member gsw2
2 subr gsw2;
3
4$ this routine switches to the auxiliary polish file.
5
6 pol_file = xpol_file;
7
8
9 end subr gsw2;
1 .=member actgen
2 subr actgen(c);
3
4$ this routine calls the various generator routine corresponding to
5$ marker nodes. it is based on the following macro which expands the
6$ output of 'syn':
7
8 +* synsemmap(a, b) =
9 /case(a)/ call b; go to esac;
10 **
11
12 size c(ps);
13
14 go to case(c) in 1 to parseimpmax;
15
16 .=include 'synsem'
17
18/esac/
19
20
21 end subr actgen;
1 .=member gdirct
2 subr gdirct;
3
4$ this routine opens a new directory
5
6
7 pop1(curdir);
8
9 $ the symbol table entry for a directory is the first entry in its
10 $ own scope.
11 if ( ^ is_local(curdir)) call ermsg(92, curdir);
12
13 call gmemb(curdir, unit_dir);
14
15
16 end subr gdirct;
1 .=member gprog1
2 subr gprog1;
3
4$ this routine is called after seeing the directory name in a
5$ 'program' statement. we treat it as if we were processing a
6$ module statement.
7
8
9 call gmod1;
10
11
12 end subr gprog1;
1 .=member gprog2
2 subr gprog2;
3
4$ this routine is called after seeing 'program xxx - yyy'. we
5$ pop the program name, set the unit type and add the main
6$ program to proctab.
7
8
9 size nam(ps); $ program name
10
11
12 pop1(nam);
13
14 if ^ is_decl(nam) then
15 call ermsg(90, nam);
16 call semtrm;
17 end if;
18
19 call gmemb(nam, unit_prog);
20
21 countup(proctabp, proctab_lim, 'proctab');
22 proctab(proctabp) = sym_main_;
23
24
25 end subr gprog2;
1 .=member gprog3
2 subr gprog3;
3
4$ this routine is called after seeing 'program xxx;'. it is
5$ similar to gprog2 except that we check that there is no
6$ directory.
7
8
9 size nam(ps); $ program name
10
11
12 if curdir ^= 0 then
13 call ermsg(66, curdir);
14 call semtrm;
15
16 else
17 pop1(nam);
18
19 $ the symbol table entry for the program scope of a simple
20 $ program is the first entry in its own scope.
21 if ( ^ is_local(nam)) call ermsg(93, nam);
22
23 call gmemb(nam, unit_prog);
24
25 countup(proctabp, proctab_lim, 'proctab');
26 proctab(proctabp) = sym_main_;
27 end if;
28
29
30 end subr gprog3;
1 .=member glib
2 subr glib;
3
4$ this routine processes the library statement. it is similar to gprog.
5
6 size nam(ps); $ library name
7
8
9 pop1(nam);
10
11 $ the symbol table entry for a library is the first entry in its
12 $ own scope.
13 if ( ^ is_local(nam)) call ermsg(94, nam);
14
15 call gmemb(nam, unit_lib);
16
17
18 end subr glib;
1 .=member gmod1
2 subr gmod1;
3
4$ this routine is called after seeing the directory name in
5$ a module statement.
6
7$ we begin by checking whether we have alreay seen a directory. if so,
8$ we check that it is the same one; otherwise we read it in.
9
10
11 size nam(ps); $ name of program
12
13
14 pop1(nam);
15
16 if curdir = 0 then $ read it in
17 curdir = nam;
18 curunit = nam;
19 if (^ is_seen(nam)) call ermsg(78, nam);
20
21 elseif nam ^= curdir then
22 call ermsg(46, 0);
23 call semtrm;
24 end if;
25
26
27 end subr gmod1;
1 .=member gmod2
2 subr gmod2;
3
4$ this routine is called after seeing the module name in a module
5$ statement. it is similar to glib and gprog.
6
7$ note that the scope of a module is its program.
8
9
10 size nam(ps); $ name of module
11
12
13 pop1(nam);
14
15 if ^ is_decl(nam) then
16 call ermsg(91, nam);
17 call semtrm;
18 end if;
19
20 call gmemb(nam, unit_mod);
21
22
23 end subr gmod2;
1 .=member gmemb
2 subr gmemb(nam, mode);
3
4$ this routine opens a new member. nam is the name of the member, and mo
5$ is its type.
6
7
8 size nam(ps), $ name of member
9 mode(ps); $ compilation mode
10
11
12 curmemb = nam;
13 curunit = nam;
14
15 if (is_seen(nam)) call ermsg(23, nam); $ duplicate member
16
17 is_decl(nam) = yes;
18 is_repr(nam) = yes;
19 is_seen(nam) = yes;
20 form(nam) = f_memb;
21
22 unit_type = mode;
23 memb_type = mode;
24
25 proctabp = 0; $ initialize proctab
26
27
28 end subr gmemb;
1 .=member ghead1
2 subr ghead1;
3
4$ this routine is called at the start of each header to initialize
5$ various globals.
6
7
8 size j(ps); $ loop index
9
10
11 head_tot = 0;
12
13 do j = sym_rts_min to sym_rts_max;
14 rt_len(j) = 0;
15 end do;
16
17
18 end subr ghead1;
1 .=member ghead2
2 subr ghead2;
3
4$ this routine is called after seeing the name of a rights list.
5$ we pop the name and store it in 'cur_rt'.
6
7
8 pop1(cur_rt);
9
10
11 end subr ghead2;
1 .=member ghead3
2 subr ghead3;
3
4$ this routine is called after seeing a name in a rights list. we
5$ push the name of the rights list onto astack and increment various
6$ counters.
7
8
9 push1(cur_rt);
10
11 head_tot = head_tot + 1;
12 rt_len(cur_rt) = rt_len(cur_rt) + 1;
13
14
15 end subr ghead3;
1 .=member ghead4
2 subr ghead4;
3
4$ this routine is called after seeing the keyword 'all' in a rights
5$ list. we iterate over all the global variables calling ghead3.
6
7
smfb 107 size save_cur_rt(ps); $ local copy of cur_rt
smfb 108 size j(ps); $ loop index
9
10
smfb 109 if cur_rt = sym_libs then
smfb 110 $ meaningless since only between gsym_org+1 and gsymp.
smfb 111 $ (strictly speaking a grammar bug: extra production needed.)
smfb 112 call ermsg(98, 0);
smfb 113 return;
smfb 114 end if;
smfb 115
smfb 116 save_cur_rt = cur_rt;
11 do j = gsym_org+1 to gsymp;
12 if (is_internal(j)) cont;
13
smfb 117 if is_const(j) then $ pretend that this is -reads <*name> ;-
smfb 118 cur_rt = sym_reads; push1(j); call ghead3;
smfb 119 else
smfb 120 cur_rt = save_cur_rt; push1(j); call ghead3;
smfb 121 end if;
16 end do;
smfb 122
smfb 123 cur_rt = save_cur_rt;
17
18
19 end subr ghead4;
1 .=member ghead5
2 subr ghead5;
3
4$ this routine builds a val entry for a header and sets two global
5$ variables to point to it.
6
7$ at this point astack contains head_tot pairs [right, name]. we
8$ begin by sorting these pairs first by right then by name. we
9$ then pop the pairs and move the names into val.
10
11
12 size vp(ps), $ val pointer
13 len(ps), $ length of rights list
14 rt(ps), $ right
15 nam(ps), $ name
16 i(ps), $ loop index
17 j(ps); $ loop index
18
19
20 call sorthd;
21
22 head_ptr = valp + 1;
23 head_len = head_tot + 5; $ for lengths of five lists
24
25 valp = valp + head_len;
26 if (valp > val_lim) call overfl('val');
27
28
29$ we use two loops to move the names into val, one over rights,
30$ and the other over the length of each rights list.
31 vp = head_ptr-1;
32
33 do i = sym_rts_min to sym_rts_max;
34 len = rt_len(i);
35
36 vp = vp + 1;
37 val(vp) = len;
38
39 do j = 1 to len;
40 pop2(rt, nam);
41
42 vp = vp + 1;
43 val(vp) = nam;
44 end do;
45 end do;
46
47
48 end subr ghead5;
1 .=member ghead6
2 subr ghead6;
3
4$ this routine is called after seeing the list for the
5$ current member. there are four possibilities:
6
7$ 1. we are compiling a library. install the new rights list as
8$ the val entry for the current member.
9
10$ 2. we are compiling a module, and it contains a null header.
11$ in this case we simply use the header supplied for it in
12$ the directory.
13
14$ 3. we are compiling a module and it contains a non-null header.
15$ we compare the header with the one given in the directory.
16
17$ 4. we are processing a main program and there is no directory.
18$ make sure the rights list only includes libraries.
19
20$ once we have processed the appropriate case we call 'sethd' to
21$ absorb the rights lists.
22
23
24 size p(ps), $ old vptr for module
25 l(ps), $ old vlen for module
26 j(ps); $ loop index
27
28
29 if memb_type = unit_lib then
30 vptr(curmemb) = head_ptr;
31 vlen(curmemb) = head_len;
32
33 elseif memb_type = unit_prog & curdir = 0 then
34 $ recall that val(head_ptr) = number of libraries
35 if (head_len ^= val(head_ptr) + 5) go to no_match;
36
37 vptr(curmemb) = head_ptr;
38 vlen(curmemb) = head_len;
39
40 elseif head_len ^= 5 then $ non-null header
41
42 p = vptr(curmemb); $ val entry from main program
43 l = vlen(curmemb);
44
45 if (head_len ^= l) go to no_match; $ wrong length
46
47 do j = 0 to head_len-1;
48 if (val(p+j) ^= val(head_ptr+j)) go to no_match;
49 end do;
50 end if;
51
52 call sethd;
53
54 return;
55
56
57/no_match/ $ headers dont match
58
59 call ermsg(37, 0);
60
61 return;
62
63
64 end subr ghead6;
1 .=member ghead7
2 subr ghead7;
3
4$ this routine is called after seeing a module descriptor in a
5$ directory. we install the current header as the val entry for
6$ the module.
7
8
9 size mod(ps), $ module name
10 dir(ps);
11
12
13 pop2(mod, dir);
14
15 if (dir ^= curdir) call ermsg(46, 0);
16
17 if is_decl(mod) then
18 call ermsg(38, mod);
19
20 else
21 is_decl(mod) = yes;
22 is_repr(mod) = yes;
23 vptr(mod) = head_ptr;
24 vlen(mod) = head_len;
25 form(mod) = f_memb;
26 end if;
27
28
29 end subr ghead7;
1 .=member sorthd
2 subr sorthd;
3
4$ this routine sorts the astack entries for a header. the top
5$ head_tot entries are pairs [right, name]. we sort them first
6$ by right then by name with the smallest value closest to
7$ the top of the stack. we use a bubble sort.
8
9 size i(ps), $ loop index
10 j(ps); $ loop index
11
12 +* rt(i) = $ i-th right name
13 astack(asp - 2 * (i) + 2)
14 **
15
16 +* nm(i) = $ i-th name
17 astack(asp - 2 * (i) + 1)
18 **
19
20 do i = 2 to head_tot;
21 do j = i-1 to 1 by -1;
22
23 if (rt(j) < rt(j+1)) quit;
24
25 if (rt(j) = rt(j+1) & nm(j) < nm(j+1)) quit;
26
27 swap(rt(j), rt(j+1));
28 swap(nm(j), nm(j+1));
29 end do;
30 end do;
31
32 macdrop(rt)
33 macdrop(nm)
34
35 return;
36
37 end subr sorthd;
1 .=member sethd
2 subr sethd;
3
4$ this routine processes the header for the current member,
5$ absorbing its libs, reads, writes, and exports lists.
6
7
8 size org(ps); $ origin in val
9 size n(ps); $ number of words in list
10 size nam(ps); $ variable name
11 size j(ps); $ loop index
12
13 size org1(ps); $ origin for library
14 size n1(ps); $ length for library
15 size j1(ps); $ index for library
16 size nam1(ps); $ name in library
17
18$
19$ begin by clearing the is_read, is_write, and is_avail flags
20$ from the previous module.
21$
22 do j = user_org + 1 to symtabp;
23 is_read(j) = no;
24 is_write(j) = no;
25 is_avail(j) = no;
26 end do;
27$
28$ process all libraries mentioned in header
29$
30 org = vptr(curmemb); $ point to zero-th library
31 n = val(org); $ number of libraries
32
33 do j = 1 to n;
34 nam = val(org+j);
35 if (^ is_seen(nam)) call ermsg(78, nam);
36 $
37 $ find the library's exported procedures and set their
38 $ is_avail bits. we begin by crawling through the
39 $ library's val entry, looking for its exported procedures.
40 $
41 org1 = vptr(nam);
42 n1 = val(org1);
43
44 do j1 = 1 to 4; $ skip libs, reads, and writes lists
45 org1 = org1 + n1 + 1;
46 n1 = val(org1);
47 end do;
48
49 do j1 = 1 to n1; $ set is_avail bits
50 nam1 = val(org1 + j1);
51 is_avail(nam1) = yes;
52 end do;
53 end do;
54$
55$ process reads variables
56$
57 org = org + n + 1; $ zero-th reads variable
58 n = val(org); $ number of reads variables
59
60 if (memb_type = unit_lib & n ^= 0) call ermsg(63, 0);
61
62 do j = 1 to n;
63 nam = val(org+j);
64 if (^ is_decl(nam)) call ermsg(79, nam);
65
66 is_read(nam) = yes;
67 end do;
68$
69$ repeat for writes variables.
70$
71 org = org + n + 1; $ zero-th writes variable
72 n = val(org); $ number of writes variables
73
74 if (memb_type = unit_lib & n ^= 0) call ermsg(63, 0);
75
76 do j = 1 to n;
77 nam = val(org+j);
78 if (^ is_decl(nam)) call ermsg(80, nam);
79
80 is_read(nam) = yes;
81 is_write(nam) = yes;
82 end do;
83$
84$ process the imports list, indicating that they are available to be
85$ called.
86$
87 org = org + n + 1;
88 n = val(org);
89
90 do j = 1 to n;
91 nam = val(org+j);
92 is_avail(nam) = yes;
93 end do;
94$
95$ process the exports list, adding each procedure to proctab and
96$ indicating that it is available to be called.
97$
98 org = org + n + 1;
99 n = val(org);
100
101 do j = 1 to n;
102 nam = val(org+j);
103 is_avail(nam) = yes;
104
105 countup(proctabp, proctab_lim, 'proctab');
106 proctab(proctabp) = nam;
107 end do;
108
109
110 end subr sethd;
1 .=member ggsym1
2 subr ggsym1;
3
4$ this routine is called before seeing the first declaration in a
5$ . we save a pointer to the zero'th global variable so
6$ that we can later process 'reads all' and 'writes all'.
7
8
9 gsym_org = symtabp;
10
11
12 end subr ggsym1;
1 .=member ggsym2
2 subr ggsym2;
3
4$ this routine is called after the last global declaration. we
5$ save a pointer to the last global variable.
6
7
8 gsymp = symtabp;
9
10
11 end subr ggsym2;
1 .=member gpdcl1
2 subr gpdcl1;
3
4$ this routine declares procedures with a variable number of
5$ arguments.
6
7
8 size n(ps); $ number of arguments-1
9
10
11 pop1(n);
12 call prcdcl(n+1, yes);
13
14
15 end subr gpdcl1;
1 .=member gpdcl2
2 subr gpdcl2;
3
4$ this routine declares procdeures with a fixed number of arguments
5
6
7 size n(ps); $ number of arguments-1
8
9
10 pop1(n);
11 call prcdcl(n+1, no);
12
13
14 end subr gpdcl2;
1 .=member gpdcl3
2 subr gpdcl3;
3
4$ this routine declares procedures with 0 arguments.
5
6 call prcdcl(0, no);
7
8
9 end subr gpdcl3;
1 .=member gpdcl4
2 subr gpdcl4;
3
4$ this routine provides the default mode for a parameter.
5
6 push1(sym_rd);
7
8
9 end subr gpdcl4;
1 .=member gpdcl5
2 subr gpdcl5;
3
4$ this routine declares a procedure with 1 argument.
5
6 call prcdcl(1, no);
7
8
9 end subr gpdcl5;
1 .=member gpdcl6
2 subr gpdcl6;
3
4$ this routine declares a procedure with 2 arguments.
5
6 call prcdcl(2, no);
7
8
9 end subr gpdcl6;
1 .=member gpdcl7
2 subr gpdcl7;
3
4$ this routine is called after we have processed a procedure
5$ declaration at the beginning of a member. we must do two things:
6
7$ 1. pop the procedure name from astack.
8
9$ 2. enter it in proctab if it is not already there.
10
11 size rout(ps), $ routine name
12 j(ps); $ loop index
13
14 pop1(rout);
15
16 do j = 1 to proctabp;
17 if (rout = proctab(j)) return;
18 end do;
19
20 countup(proctabp, proctab_lim, 'proctab');
21 proctab(proctabp) = rout;
22
23
24 end subr gpdcl7;
1 .=member prcdcl
2 subr prcdcl(n, vary);
3
4$ this routine 'declares' a procedure with n arguments. 'vary' is
5$ true if the routine has a variable number of arguments.
6
7$ on entry astack contains 'n' keywords such as '.rd' or '.rw'
8$ followed by the routine name. we build the routines symbol table
9$ entry then pop the keywords, leaving the routine name on the top
10$ of the stack.
11
12$ each procedure has a global variable associated with it which is
13$ used to store the result of the procedure. the name of this variable
smfb 124$ is stored in the procedure's val entry.
15
16$ the procedure itself recieves storage. this is done so that we
17$ will be able to get to the procedure name at run time.
18
smfb 125 size n(ps); $ number of args (vary = yes: min no.)
smfb 126 size vary(1); $ variable number of arguments
21
smfb 127 size rout(ps); $ symtab pointer for routine name
smfb 128 size ret(ps); $ symtab pointer for its return value
smfb 129 size vp(ps); $ routine's val pointer
smfb 130 size j(ps); $ loop index
25
26
27 rout = astack(asp-n);
28
29 if is_decl(rout) then $ duplicate declaration, check consistency
30
31 if ( ^ is_proc(rout)) call ermsg(95, rout);
32
33 vp = vptr(rout);
34
35 if (val(vp+1) ^= vary) call ermsg(64, rout);
36 if (val(vp+2) ^= n) call ermsg(64, rout);
37
38 do j = 1 to n;
39 if (val(vp+2+j) ^= astack(asp-n+j)) call ermsg(64, rout);
40 end do;
41
42 else $ process new declaration
43 is_decl(rout) = yes;
44 is_rec(rout) = yes;
45 is_avail(rout) = yes;
46 is_store(rout) = yes;
47
48 form(rout) = f_proc;
49
smfb 131 $ get the symbol table pointer for the return value
smfb 132 ret = hashst( symsds(rout) .cc. '(..)' );
smfb 133 is_stk(ret) = yes; is_store(ret) = yes;
smfb 134 is_read(ret) = yes; is_write(ret) = yes;
smfb 135
smfb 136 $ build the val entry for rout
50 vptr(rout) = valp + 1;
51 vlen(rout) = n + 3;
52
53 valp = valp + n + 3;
54 if (valp > val_lim) call overfl('val');
55
56 vp = vptr(rout);
57
smfb 137 val(vp) = ret;
59 val(vp+1) = vary;
60 val(vp+2) = n;
61
62 do j = 1 to n; $ copy argument modes into val.
63 val(vp+2+j) = astack(asp-n+j);
64 end do;
65 end if;
66
67 free_stack(n);
68
69
70 end subr prcdcl;
1 .=member gendm
2 subr gendm;
3
4$ this routine is called at the end of each member. it checks that
5$ there are no missing procedures
6
7
8 size j(ps), $ loop index
9 proc(ps); $ procedure name
10
11 size org(ps), $ origin for members val entry
12 n(ps); $ length of rights list
13
14 size isfbsd(1); $ true if type is based
15
16
17$ check procedures
18 do j = 1 to proctabp;
19 proc = proctab(j);
20 if (^ is_decl(proc)) call ermsg(40, proc);
21 end do;
22
23$ if this is a library, check that none of the exported procedures
24$ have based reprs.
25
26
27 if unit_type ^= unit_lib then
28 curmemb = curdir;
29 return;
30 end if;
31
32 org = vptr(curmemb); $ start of val entry
33 n = val(org);
34
35$ find first exported procedure
36 do j = 1 to 4;
37 org = org+n+1;
38 n = val(org);
39 end do;
40
41 do j = 1 to n;
42 proc = val(org+j);
43 if (isfbsd(form(proc))) call ermsg(78, proc);
44 end do;
45
46
47 end subr gendm;
1 .=member gmprog
2 subr gmprog;
3
4$ this routine is called at the start of the main program.
5$ a main program is treated as a subroutine with a reserved
6$ name.
7
8 push1(sym_main_);
9 call gdef1;
10 call gdef3;
11
12 $ pretend that we have seen 'program s$main;', i.e. emit
13 $ a statement quadruple and reset estmt_count.
14 call emit(q1_stmt, 0, 0, 0);
15 estmt_count = estmt_count - 1;
16
17
18 end subr gmprog;
1 .=member gcnst1
2 subr gcnst1;
3
4$ this routine processes the statement 'const a = b'.
5
6$ we treat each symbolic constant as an alias for a unique internally
7$ generated constant. this is done in order to avoid forward
8$ references from a symbol table entry with is_store = yes to
9$ its value. such forward references cause problems during
10$ code generation.
11
12
13 size a(ps), $ symbol table pointers
14 b(ps);
15 size i(ps); $ loop index
16
17 size temp(ps); $ internal variable
18
19
20 pop2(b, a);
21
22 if (^ is_store(b)) b = alias(b);
23
24 if is_decl(a) then
25 if is_memb(a) ! is_proc(a) then
26 call ermsg(2, a);
27 else
28 call ermsg(5, a);
29 end if;
30
31 elseif ^ is_local(a) then
32 call ermsg(39, a);
33
34 else
35
36$ allocate an internal variable. note that if 'a' is global we
37$ must allocate a variable whose name depends on 'a'.
38
39 if b ^= sym_om then
40
41 if unit_type = unit_proc then $ local
42 temp = getvar(0);
43 else
44 temp = getglb(a);
45 end if unit_type;
46
47 form(temp) = form(b);
48 is_decl(temp) = yes;
49
bnda 15 $ copy the val entry, so that is is local to the current
bnda 16 $ scope.
bnda 17
bnda 18 vptr(temp) = valp + 1;
bnda 19
bnda 20 do i = 0 to vlen(b) - 1;
bnda 21 countup(valp, val_lim, 'val');
bnda 22 val(valp) = val(vptr(b) + i);
bnda 23 end do;
bnda 24
64 vlen(temp) = vlen(b);
65
66 is_repr(temp) = yes;
67 is_store(temp) = yes;
68 is_write(temp) = no;
69 is_stk(temp) = no;
70
71 else
72 temp = sym_om;
73 end if b;
74
75 is_decl(a) = yes;
76 is_read(a) = yes;
77 is_repr(a) = yes;
78 is_store(a) = no;
79
80 alias(a) = temp;
81
82$ set the fields of 'a' to match those of 'temp' so that macros like
83$ symtype and symval work properly.
84 vptr(a) = vptr(temp);
85 vlen(a) = vlen(temp);
86 form(a) = form(temp);
87 end if;
88
89
90 end subr gcnst1;
1 .=member gcnst2
2 subr gcnst2;
3
4$ this routine processes the statement 'const nam;'. we treat it
5$ as a short form for 'const nam = 'nam';'.
6
7
8 size nam(ps); $ name of identifier
9 size str(ps); $ symtab pointer for string
10
11
12 nam = astack(asp);
13 str = hashst(1q' .cc. symsds(nam) .cc. 1q');
14
15 push1(str); call gstr; call gcnst1;
16
17
18 end subr gcnst2;
1 .=member gvar
2 subr gvar;
3
4$ this routine is called after seeing a complete 'var' declaration.
5$ we pop a series of names and set their storage options.
6
7
8 size n(ps), $ number of variables-1
9 j(ps), $ loop index
10 var(ps); $ name of variable
11
12
13 pop1(n); $ number of names-1
14
15 do j = 1 to n+1;
16 pop1(var);
17
18 if is_param(var) then $ set 'back' option
19 is_back(var) = bk_flag;
20
21 elseif is_decl(var) then
22 if is_memb(var) ! is_proc(var) then
23 call ermsg(2, var);
24 else
25 call ermsg(5, var);
26 end if;
27
28 elseif ^ is_local(var) then $ wrong scope
29 call ermsg(39, var);
30
31 else
32 is_decl(var) = yes;
33 is_read(var) = yes;
34 is_write(var) = yes;
35 is_store(var) = yes;
36 is_back(var) = bk_flag;
37
38 if unit_type = unit_proc & currout ^= sym_main_ then
39 is_stk(var) = yes;
40 else
41 is_stk(var) = no;
42 end if;
43 end if;
44 end do;
45
46
47 end subr gvar;
1 .=member gbk
2 subr gbk;
3
4$ this routine is called after seeing the keyword 'back' in a var
5$ statement.
6
7 bk_flag = yes;
8
9
10 end subr gbk;
1 .=member gnobk
2 subr gnobk;
3
4$ this routine is called after seeing a var statement without a
5$ 'back' option.
6
7 bk_flag = no;
8
9
10 end subr gnobk;
1 .=member ginit
2 subr ginit;
3
4$ this routine processes the 'init' statement. the semantics of
5$ the 'init' statement depend on whether the variable being
6$ initialized is global or local.
7
8$ global variables are static, and are initialized once at
9$ compile time. we do this by adjusting the symtab entry for
10$ the variable so that it is just like the entry for a
11$ symbolic constant, but has its is_write flag set. see
12$ -gcnst1- for details.
13
14$ local variables are stacked, and are initialized each time
15$ their routine is entered. this is done simply by emitting the
16$ proper assignment.
17
18 size var(ps), $ program variable
19 temp(ps), $ internal variable
20 vl(ps); $ value
21 size i(ps); $ loop index
22
23 pop2(vl, var);
24
25 if ^ is_local(var) then
26 call ermsg(48, var);
27
28 elseif is_const(var) ! is_param(var) then
29 call ermsg(76, var);
30
31 elseif unit_type = unit_proc then $ local variable
32 call emit(q1_asn, var, vl, 0);
33
34 else $ global variable
35
36 temp = getglb(var);
37
38 is_decl(temp) = yes;
39 is_repr(temp) = yes;
40 is_stk(temp) = yes;
41 form(temp) = form(vl);
42
bnda 25 $ copy the val entry, so that is is local to the current
bnda 26 $ scope.
bnda 27
bnda 28 vptr(temp) = valp + 1;
bnda 29
bnda 30 do i = 0 to vlen(vl) - 1;
bnda 31 countup(valp, val_lim, 'val');
bnda 32 val(valp) = val(vptr(vl) + i);
bnda 33 end do;
bnda 34
57 vlen(temp) = vlen(vl);
58
59 is_init(var) = yes;
60 is_store(var) = no;
61 alias(var) = temp;
62 end if;
63
64
65 end subr ginit;
1 .=member grepr
2 subr grepr;
3
4$ this routine processes the repr statement. we iterate over the list
5$ of names, setting their forms. we call a separate routine to
6$ process local objects.
7
8
9 size fm(ps); $ form of object to be repr'ed
10 size tp(ps), $ type descriptor
11 n(ps), $ no. of variables-1
12 j(ps), $ loop index
13 nam(ps); $ variable name
14
15
16 pop2(fm, n);
17
18 do j = 1 to n+1;
19 pop1(nam);
20
21 if (is_floc(fm)) call useloc(fm); $ get unique form
22
23 if ^ is_local(nam) then
24 call ermsg(6, nam);
25
smfb 138 elseif rpr_flag = 0 then
27 cont;
28
29 elseif is_proc(nam) then
30 call rproc(nam, fm);
31
32 elseif is_const(nam) then
33 call rconst(nam, fm);
34
35 elseif is_init(nam) then $ initialised variable
36 call rinit(nam, fm);
37
38 elseif is_repr(nam) then
39 if is_fset(fm) then
40 if (^ same_repr(fm, form(nam))) call ermsg(9, nam);
41 else
42 if (fm ^= form(nam)) call ermsg(9, nam);
43 end if;
44
45 elseif is_param(nam) then
46 if is_fset(fm) then
47 if ( ^ same_repr(fm, form(nam))) call ermsg(15, 0);
48 else
49 if (fm ^= form(nam)) call ermsg(15, 0);
50 end if;
51
52 else $ variable
53
54$ see if the variable has been declared in a 'var' statement.
55$ if not there are possibilities:
56
57$ 1. we are compiling a procedure. then the occurrence of 'nam' is
58$ an explicit declaration.
59
60$ 2. otherwise the repr is changing the scope of nam, which is an
61$ error.
62
63 if ^ is_decl(nam) then
64 if unit_type = unit_proc then
65 call chkvar(nam);
66 else
67 call ermsg(61, nam);
68 end if;
69 end if;
70
71 $ if this is a plex form, we should not have come here,
72 $ since we require all plex forms to be initialised by
73 $ an init statement.
74 if (is_fplex(fm)) call ermsg(88, nam);
75
76 $ we only allow based smaps to have untyped ranges: check
77 if is_fmap(fm) then
78 if ^ is_fbsd(fm) & is_funt(ft_im(fm)) then
79 call ermsg(74, nam);
80 end if;
81 end if;
82 tp = ft_type(fm);
83
84 if tp = f_proc ! tp = f_memb ! tp = f_lab then
85 call ermsg(81, nam);
86 end if;
87
88$ emit a warning if a stacked or backtracked variable is given
89$ a local repr.
90 if is_floc(fm) then
91 if (is_stk(nam)) call warn(1, nam);
92 if (is_back(nam)) call warn(2, nam);
93 end if;
94
95 is_repr(nam) = yes;
96 form(nam) = fm;
97 end if;
98 end do;
99
100
101 end subr grepr;
1 .=member rconst
2 subr rconst(nam, fm);
3
4$ this routine processes reprs for symbolic constants. each
5$ symbolic constant is an alias for a unique internally generated
6$ constant.
7
8$ reprs for constants are processed in four steps:
9$
10$ 1. set 'xfm' to the original type of the constant. if fm = xfm
11$ return.
12$
13$ 2. otherwise if fm and xfm are compatible, i.e. both sets, set
14$ the forms for the symbolic constant and the internal constant
15$ to 'fm'.
16$
17$ 3. otherwise if 'fm' is type element then build a new symtab
18$ entry with the proper type and value and set alias(nam) to
19$ point to it.
20$
21$ 4. otherwise the types are inconsistemt, and we issue an error
22$ message.
23
24$ for now we do a 1 level check for type consistency. the code
25$ generator does a full check later on.
26
27
28 size nam(ps); $ name of symbolic constant
29 size fm(ps); $ desired type
30
31 size xfm(ps); $ original form of constant
32 size elmt(ps); $ new entry of type element
33
34 size genelt(ps); $ builds element
35
36
37 is_repr(nam) = yes;
38
39 xfm = form(nam);
40
41 if fm = xfm then
42 return;
43
44 elseif (is_fint(fm) & is_fint(xfm)) ! $ two integers
45 (is_freal(fm) & is_freal(xfm)) ! $ two reals
46 (is_fset(fm) & is_fset(xfm)) ! $ two sets
47 (is_ftup(fm) & is_ftup(xfm)) then $ two tuples
48
49 form(alias(nam)) = fm;
50 form(nam) = fm;
51
52 elseif ft_type(fm) = f_elmt then $ make new entry
53 elmt = genelt(nam, fm);
54
55 alias(nam) = elmt;
56 form(nam) = fm;
57 vptr(nam) = vptr(elmt);
58 vlen(nam) = vlen(elmt);
59
60
61 else
62 call ermsg(22, nam);
63 end if;
64
65
66
67 end subr rconst;
1 .=member rinit
2 subr rinit(nam, fm);
3
4$ this routine is similar to rconst, but processes variables
5$ which hanve already been initialized. we check that the repr is
6$ consistent with the repr of the initial value.
7
8 size nam(ps); $ name of initialised variable
9 size fm(ps); $ desired type
10
11 size xfm(ps); $ form of initialised variable's value
12
13 size genelt(ps); $ builds element
14
15
16 is_repr(nam) = yes;
17
18 xfm = form(alias(nam));
19
20 if fm = xfm then
21 form(nam) = fm;
22 return;
23
24 elseif (is_fint(fm) & is_fint(xfm)) ! $ two ints
25 (is_freal(fm) & is_freal(xfm)) ! $ two reals
26 (is_fset(fm) & is_fset(xfm)) ! $ two sets
27 (is_ftup(fm) & is_ftup(xfm)) then $ two tuples
28
29 form(alias(nam)) = fm;
30 form(nam) = fm;
31
32 elseif ft_type(fm) = f_elmt then $ make new entry
33 alias(nam) = genelt(nam, fm);
34 form(nam) = fm;
35
36 else
37 call ermsg(22, nam);
38 end if;
39
40
41 end subr rinit;
1 .=member rproc
2 subr rproc(nam, tp);
3
4$ this routine tries to give the repr 'tp' to a procedure 'nam'.
5
6 size nam(ps), $ procedure name
7 tp(ps); $ its type
8
9 size ret(ps); $ name of variable for procedure result
10
11 size fm(ps), $ form of procedure
12 na(ps); $ its number of arguments
13
14 size loc(1); $ see below
15
16$ before we assign a type to a procedure we check whether
17$ the types of any of its arguments or of its returned value
18$ are 'local set' or 'local map'. if so then we generate a
19$ unique formtab entry with unique argument types. this
20$ is done by calling 'ulcprc'.
21
22$ the flag 'loc' is set to indicate whether there are local
23$ argument types. if so, we must issue a warning.
24
25 is_repr(nam) = yes;
26
27 fm = form(nam);
28 na = val(vptr(nam)+2);
29
30 if tp = f_proc then
31 ret = symval(nam); $ declare the return value
32 form(ret) = f_gen;
33 is_repr(ret) = yes;
34
35 return;
36
37 elseif fm = f_proc & ft_type(tp) = f_proc & na = ft_lim(tp)-1 then
38
39 call ulcprc(tp, loc);
40 if (loc) call warn(1, nam);
41
42 form(nam) = tp;
43
44 ret = symval(nam); $ type result
45
46 is_repr(ret) = yes;
47 form(ret) = mttab(ft_elmt(tp) + ft_lim(tp));
48
49 else
50 call ermsg(67, nam);
51 end if;
52
53
54 end subr rproc;
1 .=member useloc
2 subr useloc(fm);
3
4$ this routine is called whenever a local type is used in a repr
5$ statement. we reset fm to point to a new formtab entry with a
6$ unique ft_pos and increment the ft_num field of the base.
7
8 size fm(ps); $ form
9
10 size tp(ps), $ ft_type
11 base(ps); $ form of base
12
13 countup(formtabp, formtab_lim, 'formtab');
14 formtab(formtabp) = formtab(fm);
smfa 14 ft_link(formtabp) = 0; ft_deref(formtabp) = formtabp;
16
17 fm = formtabp;
18
19 tp = ft_type(fm);
20 base = ft_base(fm);
21
22 countup(ft_num(base, tp), ft_num_max, 'ft_num');
23 ft_pos(fm) = ft_num(base, tp);
24
25$ all local objects based on 'base' must be repred in the same
26$ scope as 'base'.
27 if (^ is_local_repr(base)) call ermsg(69, 0);
28
29
30 end subr useloc;
1 .=member ulcprc
2 subr ulcprc(tp, loc);
3
4$ this routine is called before assigning a type to a procedure.
5$ we check whether any of the argument types of the procedure are
6$ local. if so we generate a new formtab entry.
7
8 size tp(ps), $ procedure type
9 loc(1); $ set to yes if there are local args
10
11 size n(ps), $ number of arguments
12 j(ps), $ loop index
13 tp1(ps); $ argument type
14
15 n = ft_lim(tp);
16 loc = no;
17
18 do j = 1 to n;
19 tp1 = mttab(ft_elmt(tp)+j);
20
21 if is_floc(tp1) then
22 loc = yes;
23 call useloc(tp1);
24 end if;
25
26 push1(tp1);
27 end do;
28
29 if loc then
30 push1(n-1); call gtprc1; pop1(tp);
31 else
32 free_stack(n);
33 end if;
34
35
36 end subr ulcprc;
1 .=member gmode
2 subr gmode;
3
4$ this routine processes mode declarations.
5
6
7 size nam(ps), $ mode name
8 type(ps); $ its type
9
10
11 pop2(type, nam); $ pop type and mode nam.
12
13 if is_decl(nam) then
14 call ermsg(8, nam);
15 else
16 is_decl(nam) = yes;
17 is_repr(nam) = yes;
18 is_mode(nam) = yes;
19 form(nam) = type;
20 end if;
21
22
23 end subr gmode;
1 .=member gbase1
2 subr gbase1;
3
4$ this routine processes 'base b1 ... bn: type'. we generate a unique
5$ formtab entry for each base.
6
7$ notice that constant base names are always treated as an alias for
8$ an internally generated constant.
9$
10$ we first generate a new formtab entry for 'base()'. new
11$ formtab entries, or mode descriptors, are built in two steps:
12$
13$ 1. increment formtabp and build the new entry at formtab(formtabp).
14$
15$ 2. search formtab for an earlier entry which matches the new one.
16$ if there is an earlier entry, we erase the new entry and
17$ return the old one; otherwise we return the new entry.
18$
19$ formtab is searched by two routines: hashf1 handles one word
20$ forms and hashf2 handles forms which use mttab.
21
22
23 size base(ps); $ base name
24 size elmt(ps); $ form of base elements
25 size fm(ps); $ form of base
26 size n(ps); $ number of bases - 1
27 size j(ps); $ loop index
28
29
30 pop2(elmt, n);
31
32 if (is_funt(elmt) ! is_floc(elmt)) call ermsg(71, 0);
33
34 countup(formtabp, formtab_lim, 'formtab');
35 formtab(formtabp) = 0;
36 ft_type(formtabp) = f_base;
37 ft_elmt(formtabp) = elmt;
38
39 fm = hashf1(0);
40
41 do j = 1 to n+1;
42 pop1(base);
43
44 if is_decl(base) & ^ is_const(base) then
45 call ermsg(4, base);
46
47 else
48
49 if (alias(base) ^= 0) base = alias(base);
50
51 is_decl(base) = yes;
52 is_repr(base) = yes;
53 is_store(base) = yes;
54
55$ generate a new formtab entry for each base
56 countup(formtabp, formtab_lim, 'formtab');
57 formtab(formtabp) = formtab(fm);
smfa 15 ft_link(formtabp) = 0; ft_deref(formtabp) = formtabp;
58
59 if (is_const(base)) ft_lim(formtabp) = vlen(base);
60
61 form(base) = formtabp;
62 end if;
63
64 end do;
65
66
67 end subr gbase1;
1 .=member gbase2
2 subr gbase2;
3
4$ this routine processes 'base b1 ... bn;'. we push the formtab
5$ pointer for general then call 'gbase1'.
6
7 push1(f_gen);
8 call gbase1;
9
10
11 end subr gbase2;
1 .=member gplex
2 subr gplex;
3
4$ this routine processes the 'plex base' statement. it is similar
5$ to gbase1.
6
7
8 size n(ps), $ number of bases-1
9 j(ps), $ loop index
10 base(ps); $ base name
11
12
13
14 pop1(n);
15
16 do j = 1 to n+1;
17 pop1(base);
18
19 if is_decl(base) then
20 call ermsg(4, base);
21
22 else
23 is_decl(base) = yes;
24 is_repr(base) = yes;
25 is_store(base) = yes;
26
27$ generate a new formtab entry for each base
28 countup(formtabp, formtab_lim, 'formtab');
29 formtab(formtabp) = 0;
30 ft_type(formtabp) = f_pbase;
31
32 form(base) = formtabp;
33 end if;
34
35 end do;
36
37
38 end subr gplex;
1 .=member gtpref
2 subr gtpref;
3
4$ this routine processes mode descriptors of the form ' ',
5$ where is 'local', 'untyped', etc.
6$
7$ we begin by popping the original mode and the prefix. we
8$ then determine the new mode and jump on the prefix.
9
10
11 size prefix(ps); $ name of prefix
12 size type(ps); $ original type
13 size ntype(ps); $ new ft_type
14 size etype(ps); $ element type
15 size itype(ps); $ image type
16 size ptype(ps); $ packed type
17 size ttype(ps); $ type of embedded tuple for remote maps
18
19 size mx(ps); $ maximum value stored in packed object
20
21
22 pop2(type, prefix);
23
24 ntype = prefix_map(prefix, ft_type(type));
25
26 go to case(prefix) in sym_local to sym_untyped;
27
28/case(sym_local)/ $ local set or map
29
30/case(sym_remote)/
31
32$ set etype and ttype, then check etype for validity
33 if is_fmap(type) then
34 etype = ft_dom(type);
35
36 if prefix = sym_remote then
37 itype = ft_im(type);
38
39 $ get the form for the embedded tuple
40 if (is_floc(itype)) call ermsg(72, 0);
41
42 countup(formtabp, formtab_lim, 'formtab');
43 formtab(formtabp) = 0;
44 ft_type(formtabp) = tuple_type(itype);
45 ft_elmt(formtabp) = itype;
46
47 ttype = hashf1(0);
48
49 else
50 ttype = 0;
51 end if;
52
53 elseif is_fset(type) then
54 etype = ft_elmt(type);
55 ttype = 0;
56
57 else
58 go to error;
59 end if;
60
61 if (ft_type(etype) ^= f_elmt) go to error;
62 if prefix = sym_remote then
63 if (ft_type(ft_base(etype)) = f_pbase) call ermsg(70, 0);
64 end if;
65
66$ build new formtab entry
67 countup(formtabp, formtab_lim, 'formtab');
68
69 formtab(formtabp) = formtab(type);
70 ft_link(formtabp) = 0;
bnda 35 ft_deref(formtabp) = 0;
71
72 ft_type(formtabp) = ntype;
73 ft_base(formtabp) = ft_base(etype);
74 ft_tup(formtabp) = ttype;
75
76 go to esac;
77
78/case(sym_sparse)/
79
80 if is_fmap(type) then
81 etype = ft_dom(type);
82
83 elseif is_fset(type) then
84 etype = ft_elmt(type);
85
86 else
87 go to error;
88 end if;
89
90 if (ft_type(etype) ^= f_elmt) go to error;
91
92$ since 'sparse set(_ b)' and 'set(_ b)' are really the same type
93$ we merely push the original formtab pointer and return.
94
95 push1(type);
96 return;
97
98
99/case(sym_packed)/
100
101$ find type being packed
102
103 if ft_type(type) = f_tuple then
104 ptype = ft_elmt(type);
105
106 elseif ft_type(type) = f_rmap ! ft_type(type) = f_lmap then
107 if (ft_mapc(type) = ft_mmap) go to error;
108 ptype = ft_im(type);
109
110 else
111 go to error;
112 end if;
113
114$ check that ptype is valid
115
116 if (ft_type(ptype) = f_sint) go to pass; $ short integer
117
118 if (ft_type(ptype) ^= f_elmt) go to error; $ not element
119 if (ft_lim(ft_base(ptype)) = 0) go to error; $ not const
120
121/pass/ $ valid packed type
122
123$ if the packed value takes more than ws/2 bits and this is not
124$ a local map, ignore the repr.
125$
126$ nb. implementation restriction: the range integer 0 .. n can
127$ not be packed, since the pack key stores (i-1) for the range
128$ integer i .. j.
129$
130 if ft_type(ptype) = f_elmt then
131 mx = ft_lim(ft_base(ptype));
132 else
133 mx = ft_lim(ptype);
134 if (ft_low(ptype) = 0) call ermsg(85, 0);
135 end if;
136
137 if .fb. mx > ws/2 & ntype ^= f_lpmap then
138 push1(type);
139 return;
140 end if;
141
142$ if we are building a packed remote map we must compute build
143$ a new formtab entry for its embedded tuple.
144
145 if ntype = f_rpmap then
146 countup(formtabp, formtab_lim, 'formtab');
147
148 formtab(formtabp) = formtab(ft_tup(type));
149 ft_link(formtabp) = 0;
bnda 36 ft_deref(formtabp) = 0;
150
151 ft_type(formtabp) = f_ptuple;
152
153 ttype = hashf1(0);
154
155 else $ ft_tup unused
156 ttype = 0;
157 end if;
158
159 countup(formtabp, formtab_lim, 'formtab');
160
161 formtab(formtabp) = formtab(type);
162 ft_link(formtabp) = 0;
bnda 37 ft_deref(formtabp) = 0;
163
164 ft_type(formtabp) = ntype;
165 ft_tup(formtabp) = ttype;
166
167 go to esac;
168
169
170/case(sym_untyped)/
171
172 if (^ is_fnum(type)) go to error;
173
174$ 'ntype' gives the new type. push it and return.
175 push1(ntype);
176 return;
177
178/esac/
179
180 push1(hashf1(0));
181
182 return;
183
184/error/
185
186 call ermsg(12, prefix);
187 push1(f_gen);
188
189 return;
190
191 end subr gtpref;
1 .=member gtmode
2 subr gtmode;
3
4$ this routine processes a mode name when it is used as a type.
5
6
7 size nam(ps); $ mode name
8
9
10 pop1(nam);
11
12 if is_mode(nam) then
13 push1(form(nam));
14 else
15 call ermsg(10, nam);
16 push1(f_gen);
17 end if;
18
19
20 end subr gtmode;
1 .=member gtgen
2 subr gtgen;
3
4$ this routine processes the mode '*'.
5
6 push1(f_gen);
7
8 end subr gtgen;
1 .=member gtint
2 subr gtint;
3
4$ this routine processes the mode 'integer lo ... hi'.
5
6 size mode(ps); $ mode keyword 'integer'
7 size lo(ps); $ lower bound of range
8 size hi(ps); $ upper bound of range
9
10
11 pop3(hi, lo, mode);
12
13 if symtype(lo) ^= f_sint then
14 call ermsg(14, lo); push1(f_int);
15
16 elseif symtype(hi) ^= f_sint then
17 call ermsg(14, hi); push1(f_int);
18
19 elseif symval(lo) > symval(hi) then
bnda 38 call ermsg(99, 0); push1(f_int);
21
22 elseif symval(hi) > ft_lim_max then
23 push1(f_sint);
24
25 else
26 countup(formtabp, formtab_lim, 'formtab');
27 formtab(formtabp) = 0;
28 ft_type(formtabp) = f_sint;
29 ft_low(formtabp) = symval(lo);
30 ft_lim(formtabp) = symval(hi);
31
32 if (symval(lo) > ft_low_max) ft_low(formtabp) = ft_low_max;
33
34 push1(hashf1(0));
35 end if;
36
37
38 end subr gtint;
1 .=member gtprim
2 subr gtprim;
3
4$ this routine processes modes consisting only of a mode keyword.
5$
6$ rather than popping the mode keyword from the stack, and pushing
7$ the proper form onto the stack, we map the top astack entry directly.
8
9 astack(asp) = mode_map(astack(asp));
10
11 end subr gtprim;
1 .=member gtelmt
2 subr gtelmt;
3
4$ this routine processes 'elmt base'.
5$
6$ notice that constant base names are always treated as an alias for
7$ an internally generated constant.
8
9
10 size base(ps); $ base name
11
12
13 pop1(base); if (alias(base) ^= 0) base = alias(base);
14
15 if is_base(base) then $ valid base name
16 countup(formtabp, formtab_lim, 'formtab');
17 formtab(formtabp) = 0;
18 ft_type(formtabp) = f_elmt;
19 ft_base(formtabp) = form(base);
20
21 push1(hashf1(0));
22
23 else
24 call ermsg(11, base); push1(f_elmt);
25 end if;
26
27
28 end subr gtelmt;
1 .=member gttup1
2 subr gttup1;
3
4$ this routine processes type decsriptors for mixed tuples.
5$ the top astack entry is the number of modes - 2.
6$
7$ yes, we do mean - 2.
8
9
10 size elmt(ps); $ mode of element
11 size n(ps); $ number of elements - 2
12 size j(ps); $ loop index
13
14
15 pop1(n);
16
17 countup(formtabp, formtab_lim, 'formtab');
18 formtab(formtabp) = 0;
19 ft_type(formtabp) = f_mtuple;
20 ft_elmt(formtabp) = mttabp;
21 ft_lim(formtabp) = n + 2;
22 ft_neltok(formtabp) = yes;
23
24 $ enter elements in mttab
25 do j = n+1 to 0 by -1;
26 elmt = astack(asp-j);
27
28 if (is_funt(elmt) ! is_floc(elmt)) call ermsg(75, 0);
29
30 countup(mttabp, mttab_lim, 'mttab');
31 mttab(mttabp) = elmt;
32 end do;
33
34 free_stack(n+2);
35
36 push1(hashf2(0));
37
38
39 end subr gttup1;
1 .=member gttup2
2 subr gttup2;
3
4$ this routine processes homogeneous tuple where the average
5$ length of the tuple is given.
6
7
8 size elmt(ps); $ mode of tuple elements
9 size lim(ps); $ length of tuple
10
11
12 pop2(lim, elmt);
13
14 if (^is_const(lim) ! form(lim)^=f_sint) call ermsg(14, lim);
15
16 if (is_floc(elmt)) call ermsg(72, 0);
17
18 countup(formtabp, formtab_lim, 'formtab');
19 formtab(formtabp) = 0;
20 ft_type(formtabp) = tuple_type(elmt);
21 ft_elmt(formtabp) = elmt;
22 ft_neltok(formtabp) = yes;
23
24 if (symval(lim) < ft_lim_max) ft_lim(formtabp) = symval(lim);
25
26 push1(hashf1(0));
27
28
29 end subr gttup2;
1 .=member gttup3
2 subr gttup3;
3
4$ this routine processes homogeneous tuples where no range is given
5$ treat it as if it had a range of 0.
6
7 push1(sym_zero); call gttup2;
8
9
10 end subr gttup3;
1 .=member gtset
2 subr gtset;
3
4$ this routine processes the mode 'set( )'. it builds a
5$ formtab entry and pushes a pointer to it onto the stack.
6
7
8 size mode(ps); $ mode keyword 'set'
9 size elmt(ps); $ mode of elements
10
11
12 pop2(elmt, mode);
13
14 if (is_funt(elmt) ! is_floc(elmt)) call ermsg(72, 0);
15
16 countup(formtabp, formtab_lim, 'formtab');
17 formtab(formtabp) = 0;
18 ft_type(formtabp) = f_uset;
19 ft_elmt(formtabp) = elmt;
20
21 push1(hashf1(0));
22
23
24 end subr gtset;
1 .=member gtmap1
2 subr gtmap1;
3
4$ this is the main routine for processing map types.
5$
6$ the top entries on the stack are:
7$
8$ 1. the mode of the range
9$ 2. a counter n
10$ 3. n+1 domain modes
11$ 4. a mode keyword, one of 'smap', 'mmap'
12
13
14 size range(ps); $ mode of map range
15 size n(ps); $ number of domains - 1
16 size domain(ps); $ mode of map domain
17 size mode(ps); $ mode keyword
18 size map_code(ps); $ map code corresponding to mode
19 size rng_elmt(ps); $ single range element
20 size map_elmt(ps); $ map element (pair)
21 size imset(ps); $ range set type (ambiguous maps only)
22
23
24 pop2(range, n);
25
26 if n > 0 then $ build tuple describing domain
27 push1(n-1); call gttup1;
28 end if;
29
30 pop2(domain, mode);
31
32 if mode = sym_msmap then map_code = ft_smap;
33 elseif mode = sym_mmap then map_code = ft_map;
35 elseif mode = sym_mmmap then map_code = ft_mmap;
36 end if;
37
38 $ find the map element type. note that when we extract an
39 $ element from an untyped map we always get a pair whose
40 $ components are both typed.
41 if map_code = ft_mmap then
42 rng_elmt = ft_elmt(range);
43
44 elseif ft_type(range) = f_uint then
45 rng_elmt = f_int;
46
47 elseif ft_type(range) = f_ureal then
48 rng_elmt = f_real;
49
50 else
51 rng_elmt = range;
52 end if;
53
54 push3(domain, rng_elmt, 0); call gttup1; pop1(map_elmt);
55
56 if map_code = ft_map then
57 push2(sym_mset, rng_elmt); call gtset; pop1(imset);
58 else
59 imset = 0;
60 end if;
61
62 if (is_funt(domain) ! is_floc(domain)) call ermsg(73, 0);
63 if (is_floc(range)) call ermsg(74, 0);
64
65 countup(formtabp, formtab_lim, 'formtab');
66 formtab(formtabp) = 0;
67 ft_type(formtabp) = map_type(range);
68 ft_mapc(formtabp) = map_code;
69 ft_elmt(formtabp) = map_elmt;
70 ft_dom(formtabp) = domain;
71 ft_im(formtabp) = range;
72 ft_imset(formtabp) = imset;
73
74 push1(hashf1(0));
75
76
77 end subr gtmap1;
1 .=member gtsmap
2 subr gtsmap;
3
4$ this routine processes the mode 'smap'. we treat it as a short
5$ hand for 'smap(general) general'.
6
7 push3(f_gen, 0, f_gen); call gtmap1;
8
9 end subr gtsmap;
1 .=member gtmmp1
2 subr gtmmp1;
3
4$ this routine processes 'mmap(t1, t2, ..., tn) tn+1'. we treat it as
5$ 'mmap<> set(tn+1)'.
6
7
8 size elmt(ps); $ mode of set elements
9
10
11 pop1(elmt); push2(sym_mset, elmt); call gtset;
12
13 call gtmap1;
14
15
16 end subr gtmmp1;
1 .=member gtmmp2
2 subr gtmmp2;
3
4$ this routine processes 'mmap<> tn+1'. we check that
5$ the range mode is a set mode.
6
7
8 size mode(ps); $ range mode
9
10
11 mode = astack(asp);
12
13 if ^ is_fset(mode) then
14 call ermsg(13, 0);
15 astack(asp) = f_uset;
16 end if;
17
18 call gtmap1;
19
20
21 end subr gtmmp2;
1 .=member gtmmap
2 subr gtmmap;
3
4$ this routine processes the mode 'mmap'. we treat it as a short
5$ hand for 'mmap<> set(general)'.
6
7
8 push4(f_gen, 0, sym_mset, f_gen);
9 call gtset;
10 call gtmap1;
11
12
13 end subr gtmmap;
1 .=member gtprc1
2 subr gtprc1;
3
4$ this routine processes the type 'proc(t1 ... tn+1)tn+2'.
5
6 size j(ps), $ loop index
7 n(ps), $ number of argument types-1
8 type(ps), $ argument type
9 rtyp(ps); $ result type
10
11
12 pop2(rtyp, n); $ result type and no. of args-1
13
14 countup(formtabp, formtab_lim, 'formtab');
15 formtab(formtabp) = 0;
16
17 ft_type(formtabp) = f_proc;
18 ft_elmt(formtabp) = mttabp;
19
20 ft_lim(formtabp) = n+2;
21
22$ enter argument types in mttab.
23
24$ push the result type, then processes it along with the argument
25$ types.
26 push1(rtyp);
27
28 do j = 1 to n+2;
29 type = astack(asp-n-2+j);
30
31 countup(mttabp, mttab_lim, 'mttab');
32 mttab(mttabp) = type;
33 end do;
34
35
36 free_stack(n+2); $ pop astack
37
38 push1(hashf2(0));
39
40
41 end subr gtprc1;
1 .=member gtprc2
2 subr gtprc2;
3
4$ this routine processes the type 'proc'.
5
6 push1(f_proc);
7
8
9 end subr gtprc2;
1 .=member gtprc3
2 subr gtprc3;
3
4$ this routine processes 'proc(t1 ... tn)'.
5
6 push1(f_gen); $ result type
7 call gtprc1;
8
9
10 end subr gtprc3;
1 .=member gtprc4
2 subr gtprc4;
3
4$ this procedure processes 'procedure () mode'.
5
6 size mode(ps); $ result mode
7
8
9 pop1(mode);
10
11 countup(formtabp, formtab_lim, 'formtab');
12 formtab(formtabp) = 0;
13
14 ft_type(formtabp) = f_proc;
15 ft_elmt(formtabp) = mttabp;
16 ft_lim(formtabp) = 1;
17
18 countup(mttabp, mttab_lim, 'mttab');
19 mttab(mttabp) = mode;
20
21 push1(hashf2(0));
22
23
24 end subr gtprc4;
1 .=member gdef1
2 subr gdef1;
3
4$ this routine is called after seeing 'proc ' in a procedure
5$ definition.
6
7$ setl makes no distinction between subroutines and functions.
8$ instead we assume that every procedure returns a value. this
9$ value may be omega, and may be ignored by the caller.
10
11$ we begin by popping the routine name and checking that it has
12$ appeared in an exports or procs statement but has not already
13$ been defined.
14
15
16 pop1(currout);
17
18 if (^ is_proc(currout)) call ermsg(57, currout);
19 if (is_seen(currout)) call ermsg(23, currout);
20
21 curunit = currout; $ set unit type, etc.
22 unit_type = unit_proc;
23
24 is_seen(currout) = yes; $ indicate seen
25
26$ emit entry instruction then allocate exit and stop labels
smfb 139 call incode; $ re-initialise code table.
27 call emit(q1_entry, currout, 0, 0);
28 estmt_count = cstmt_count; $ statement number of procedure entry
29
30 stop_lab = getlab(0);
31 exit_lab = getlab(0);
32
33
34 end subr gdef1;
1 .=member gdef2
2 subr gdef2;
3
4$ this routine is called after seeing proc(x1 ... xn(*)).
5
6 size n(ps); $ number of parameters-1
7
8 pop1(n);
9 call gdef(n+1, yes);
10
11
12 end subr gdef2;
1 .=member gdef3
2 subr gdef3;
3
4$ this routine is called after seeing a procedure or operator
5$ definition with zero parameters.
6
7 call gdef(0, no);
8
9
10 end subr gdef3;
1 .=member gdef4
2 subr gdef4;
3
4$ this routine is called at the start of a procedure(as opposed to
5$ operator) definition.
6
7 op_flag = no;
8
9
10 end subr gdef4;
1 .=member gdef5
2 subr gdef5;
3
4$ this routine is called at the start of an operator definition.
5
6 op_flag = yes;
7
8
9 end subr gdef5;
1 .=member gdef6
2 subr gdef6;
3
4$ this routine is called after seeing proc p(x1 ... xn).
5
6 size n(ps); $ number of arguments-1
7
8 pop1(n);
9 call gdef(n+1, no);
10
11
12 end subr gdef6;
1 .=member gdef
2 subr gdef(n, vary);
3
4$ this routine is called at the end of a procedure or op
5$ definition.
6
7
8 size n(ps), $ number of arguments
9 vary(1); $ flags variable number of arguments
10
11 size fm(ps), $ form of routine
12 j(ps), $ loop index
13 reprd(1), $ on if parameters are reprd.
14 morg(ps), $ origin in mttab
15 org(ps), $ origin in astack
16 vp(ps), $ vptr for routine
17 mode(ps), $ mode of parameter
18 param(ps); $ parameter name
19
20
21$ user defined operators can have at most two parameters.
22 if (op_flag & (n > 2 ! vary)) call ermsg(68, currout);
23
24$ see if 'n' and 'vary' agree with the procedures declaration.
25
26 vp = vptr(currout);
27
28 if (vary ^= val(vp+1) ! n ^= val(vp+2)) call ermsg(7, currout);
29
30$ see if the user has supplied a detailed repr for the procedure.
31$ if so, we will use it to repr the formal parameters.
32
33 reprd = (is_repr(currout) & form(currout) ^= f_proc);
34
35 if (reprd) morg = ft_elmt(form(currout));
36
37$ process arguments one at a time, comparing their modes with
38$ those given in the procedure value.
39
40 org = asp - 2 * n; $ origin in astack
41
42 do j = 1 to n;
43 param = astack(org + 2 * j);
44 mode = astack(org + 2 * j - 1);
45
46 if is_decl(param) then
47 call ermsg(41, param);
48
49 elseif mode ^= val(vp+2+j) then
50 call ermsg(41, param);
51
52 else
53 is_decl(param) = yes;
54
55 if reprd then
56 form(param) = mttab(morg+j);
57 is_repr(param) = yes;
58 end if;
59
60 is_read(param) = yes;
61 if (mode ^= sym_rd) is_write(param) = yes;
62 is_store(param) = yes;
63 is_param(param) = yes;
64 end if;
65 end do;
66
67 free_stack(2 * n);
68
69
70 end subr gdef;
1 .=member gendr1
2 subr gendr1;
3
4$ this routine is called at the end of each subroutine or function.
5$ we define the routines exit and stop blocks, close its scope, then
6$ call 'blkdec' to put the code for the routine into the exact form
7$ desired by the optimizer.
8$
9$ note that we define the exit block before the stop block.
10$ this means we will return automaticly if we execute an end
11$ statement.
12
13
14 size j(ps); $ loop index
15
16
17 call deflab(exit_lab);
18 call emit(q1_exit, currout, 0, 0);
19
20 call deflab(stop_lab);
21 call emit(q1_stop, 0, 0, 0);
22
23$ check that all labels appearing in explicit gotos have been defin
24
25 do j = symtab_org to symtabp;
26 if is_perf(j) then
27 if ^ is_seen(val(vptr(j))) then
28 push1(j); call gperf1; $ build a dummy perform block,
29 call ermsg(25, j); $ mark it as erroneous,
30 call gperf2; $ and close it.
31 end if;
32 end if;
33
34 if ft_type(form(j)) = f_lab then
35 if ^ is_seen(j) then
36 push1(j); call glabel; $ build a dummy definition
37 if is_internal(j) then $ this is a compiler error
38 call ermsg(26, j); $ mark it as erroneous
39 else $ this is a user error
40 call ermsg(27, j); $ mark it as erroneous
41 end if;
42 end if;
43 end if;
44 end do;
45
46 call blkdec; $ call cleanup pass
47
48
49 end subr gendr1;
1 .=member gendr2
2 subr gendr2;
3
4$ this routine is called after the tables for a procedure have
5$ been written. we restore the previous scope.
6
7 curunit = curmemb;
8 unit_type = memb_type;
9 currout = 0;
10
11
12 end subr gendr2;
1 .=member gendb
2 subr gendb;
3
4$ this routine is called at the end of a routine body, before the
5$ first perform block. we generate 'return om' so that control
6$ never flows from the body to the first perform block.
7
8 call gret2;
9
10
11 end subr gendb;
1 .=member gperf1
2 subr gperf1;
3
4$ this routine opens a perform block. we pop the perform block and
5$ make sure that it has appeared previously in a perform-call. we
6$ then find its entry label from its val entry and define it.
7
8
9 size lab(ps); $ label for start of perform block
10
11
12 pop1(curperf);
13
14 if ^ is_perf(curperf) then
15 call ermsg(35, curperf);
16 else
17 lab = val(vptr(curperf));
18 call deflab(lab);
19 end if;
20
21
22 end subr gperf1;
1 .=member gperf2
2 subr gperf2;
3
4$ this routine is called at the end of a perform block.
5$ we emit an 'exit' statement then set curperf = 0.
6
7 call gexit;
8 curperf = 0;
9
10
11 end subr gperf2;
1 .=member glabel
2 subr glabel;
3
4$ this routine processes user defined labels. we pop the label from
5$ astack and define it.
6
7
8 size lab(ps); $ label
9
10
11 pop1(lab);
12
smfb 140 if is_decl(lab) & symtype(lab) ^= f_lab then
smfb 141 call ermsg(21, lab);
smfb 142 else
smfb 143 is_decl(lab) = yes;
smfb 144 is_repr(lab) = yes;
smfb 145 form(lab) = f_lab;
smfb 146
smfb 147 call deflab(lab);
smfb 148 end if;
18
19
20 end subr glabel;
1 .=member gstat1
2 subr gstat1;
3
4$ reset ustmt_count.
5
6 cstmt_count = cstmt_count + 1;
7 ustmt_count = cstmt_count;
8 estmt_count = 0;
9
10
11 end subr gstat1;
1 .=member gstat
2 subr gstat;
3
4$ this routine is called at the start of every statement. we
5$ do three things:
6
7$ 1. increment the statement counter
8$ 2. emit a q1_stmt instruction
9$ 3. if desired, we check that the code fragment from prog_start
10$ to prog_end is one continuous list.
11
12 size p(ps); $ code pointer
13
14 cstmt_count = cstmt_count + 1;
15
16 call emit(q1_stmt, 0, 0, 0);
17
18 if chk_flag then
19 p = prog_start;
20
21 while next(p) ^= 0;
22 p = next(p);
23 end while;
24
25 if p ^= prog_end then
26 put, skip, column(7),
27 '**** prog check failed at stmt ':
28 stmt_count, il, '****', skip(2);
29
30 call ltlfin(1, 0); $ abort with dump
31 end if;
32 end if;
33
34$ dump astack if requested
35 if trs_flag then
36 put, skip, 'statement number: ': stmt_count, i, skip;
37 stack_trace('astack: ', asp);
38 end if;
smfb 149
smfb 150 $ clear bstack, the stack used to process boolean operations.
smfb 151 bsp = 0;
39
40
41 end subr gstat;
1 .=member gerror
2 subr gerror;
3
4$ this routine is called at the point of each syntax error. it
5$ clears astack and advances the polish string to the start of
6$ the next statement.
7
8 size tp(ps), $ node type
9 vl(ps); $ node value
10
11
12 if unit_type = unit_proc then
13 call emit(q1_error, 0, 0, 0);
14 end if;
15
16 asp = 0; $ reset astack
17
18 while 1;
19 getp(tp, vl);
20 if (filestat(pol_file, end)) quit;
21
22 if (tp = pol_mark & vl = p_stat) quit;
23 end while;
24
25 call gstat; $ increment statement counter
26
27
28 end subr gerror;
1 .=member gpcall
2 subr gpcall;
3
4$ this routine generates a 'call' to a perform block 'p'. this is
5$ done in three steps:
6
7$ 1. pop 'p' and see if it has already been used. if so, issue an
8$ error message, since a perform block can only be called from
9$ one place. otherwise set p's is_decl and is_perf fields.
10
11$ 2. obtain two labels 'l1' and 'l2', then emit 'go to l1; /l2/'.
12
13$ 3. make a val entry for the perform block. this will consist
14$ of two words, the first giving l1 and the second giving l2.
15
16
17 size p(ps), $ perform block name
18 l1(ps), $ label for perform block
19 l2(ps); $ label for return point
20
21
22 pop1(p);
23
24 if is_decl(p) then
25 call ermsg(33, p);
26
27 else
28 is_decl(p) = yes;
29 is_perf(p) = yes;
30
31 l1 = getlab(0); $ get labels
32 l2 = getlab(0);
33
34 call emit(q1_goto, l1, 0, 0);
35 call deflab(l2);
36
37$ make val entry
38 vptr(p) = valp+1;
39 vlen(p) = 2;
40
41 if (valp + 2 > val_lim) call overfl('val');
42
43 val(valp+1) = l1;
44 val(valp+2) = l2;
45 valp = valp+2;
46 end if;
47
48
49 end subr gpcall;
1 .=member gcall1
2 subr gcall1;
3
4$ this routine generates a zero argument procedure call.
5
6
7 size nam(ps); $ routine or perform block name
8
9
10 nam = astack(asp);
11
12 if is_decl(nam) then
13 call gcall(0); $ routine with zero parameters
14 else
15 call gpcall; $ invocation of perform block
16 end if;
17
18
19 end subr gcall1;
1 .=member gcall2
2 subr gcall2;
3
4$ this routine processes call statements with arguments.
5
6 size n(ps); $ number of arguments-1
7
8 pop1(n);
9
10 call gcall(n+1);
11
12
13 end subr gcall2;
1 .=member gcall3
2 subr gcall3;
3
4$ this routine processes '<*name> ( ) ;', i.e. a routine call with zero
5$ parameters. unlike for 'gcall1', we know that it can not be a perform
6$ block definition.
7
8
9 call gcall(0);
10
11
12 end subr gcall3;
1 .=member gcall
2 subr gcall(n);
3
4$ this routine generates an n-argument procedure call.
5
6$ procedure calls always return a value. this is done by assigning
7$ the returned value to the name of the procedure.
8
9$ a calling sequence consists of two parts:
10
11$ 1. the actual call
12$ 2. the code to save the returned value in a temporary.
13
14$ this routine generates (1), while 'gfcall' generates both (1) and
15$ (2).
16
17$ we generate the call in three steps:
18
19$ 1. generate a series of 'argin' assignments to assign the arguments
20$ to the run time stack.
21
22$ 2. generate the actual call.
23
24$ 3. generate argout assignments assigning the stack entries back to
25$ the arguments.
26
27$ calls to procedures with a variable number of arguments are
28$ treated in one of two ways:
29
30$ 1. if we are calling a built in procedure we treat it as if it
31$ has 'n' arguments and generate an argin and argout assignment
32$ for each.
33
34$ 2. otherwise we gather all the extra arguments into a tuple
35$ and generate argin and argout assignments for the tuple.
36
37 size n(ps); $ number of arguments
38
39 size rout(ps), $ routine name
40 vp(ps), $ its val pointer
41 na(ps), $ its declared no. of arguments
42 vary(1), $ indicates variable no. of arguments
43 bip(1), $ flags built in procedure
44 bnum(1), $ standard no. of args for built in proc
45 bvary(1), $ flags built in proc with variable no. of args
46 j(ps), $ loop index
47 t(ps), $ temp for argout
48 arg(ps), $ argument
49 mode(ps); $ its mode
50 size temp(ps); $ internal variable for in-conversion
51
52
53$ get routine name and various pointers.
54
55 rout = astack(asp-n);
56
57 if ^ is_proc(rout) then $ not procedure
58 call ermsg(43, rout);
59 free_stack(n+1);
60 return;
61
62 elseif ^ is_avail(rout) then $ not imported
63 call ermsg(77, rout);
64 free_stack(n+1);
65 return;
66 end if;
67
68 vp = vptr(rout);
69 vary = val(vp+1);
70 na = val(vp+2);
71
72 bip = is_bip(rout);
73 bnum = na;
74 bvary = bip & vary;
75
76 if vary then
77 if n < na-1 then
78 call ermsg(62, rout);
79 free_stack(n+1);
80 return;
81
82 elseif bip then
83 vary = no;
84 na = n;
85
86 elseif n = na-1 then
87 push1(sym_nulltup);
88 else
89 push1(n-na);
90 call gtup3;
91 end if;
92
93 elseif n ^= na then
94 call ermsg(62, rout);
95
96 free_stack(n+1);
97 return;
98 end if;
99
100
101$ generate argins. note that write only arguments are initialized
102$ to omega. if the procedure has a variable number of arguments
103$ and they are all write only, we initialize the corresponding tuple
104$ to nult.
105
106 do j = 1 to na;
107 arg = astack(asp-na+j);
108 mode = val(vp+2+j);
109 if (bvary & j > bnum) mode = val(vp+2+bnum);
110
111 if mode = sym_wr then
112 arg = sym_om;
113 if (vary & j = na) arg = sym_nulltup;
114 end if;
115
116 if ft_type(form(arg)) = f_elmt then
117 $ need assignment for conversion
118 temp = getvar(0); call emit(q1_asn, temp, arg, 0);
119 arg = temp;
120 end if;
121
122 call emit(q1_argin, arg, rout, getint(j));
123 end do;
124
125
smfb 152 $ start the call block: the optimiser assumes that each procedure
smfb 153 $ call is contained in a single-instruction block.
smfb 154 if is_bip(rout) = no then call deflab(getlab(0)); end if;
126 $ emit call
127 call emit(q1_call, rout, getint(n), 0);
smfb 155
smfb 156 $ end the call block.
smfb 157 if is_bip(rout) = no then call deflab(getlab(0)); end if;
128
129
130$ iterate over arguments, emitting argouts. there are three
131$ possibilities for each argument
132
133$ 1. it is read only. emit a q1_free instruction.
134
135$ 2. it is a general left hand side. emit an argout to a temporary
136$ and a sinister assignment.
137
138$ 3. otherwise simply emit an argout.
139
140$ note that if a general left hand side is used as a read-write
141$ argument then we must copy its code fragment before emitting
142$ the sinister assignment.
143
144 do j = na to 1 by -1;
145 arg = astack(asp-na+j);
146 mode = val(vp+2+j);
147 if (bvary & j > bnum) mode = val(vp+2+bnum);
148
149 if mode = sym_rd then
150 call emit(q1_free, arg, rout, getint(j));
151
152 elseif ^ is_write(arg) & ^ is_param(arg) then
153 call ermsg(53, arg);
154
155 elseif is_temp(arg) then $ general left hand side
156 if (mode = sym_rw) arg = copy(arg);
157 t = gettmp(0);
158
159 call emit(q1_argout, t, rout, getint(j));
160 call gasn(arg, t, no);
161
162 else
163 call emit(q1_argout, arg, rout, getint(j));
164 end if;
165 end do;
166
167 free_stack(na+1);
168
169
170 end subr gcall;
1 .=member gasn
2 subr gasn(lhs, rhs, iterflag);
3
4$ this is the main routine for generating assignments. 'rhs' is
5$ the right hand side of the assignment, and 'lhs' is a model
6$ which tells us how to generate the assignment. lhs
7$ is one of the following:
8
9$ 1. a variable 'v' . this indicates that we should emit the
10$ simple assignment 'v = rhs'.
11
12$ 2. a temporary generated by an expression 't := [a, b]'.
13$ this indicates that we should emit the multiple
14$ assignment '[a, b] := rhs'.
15
16$ 3. a temporary generated by a retrieval operation 't = f(x)'.
17$ this indicates that we should generate the sinister
18$ assignment 'f(x) = y'.
19
20$ note that in case (2) we could just as well have
21$ 't := [ [a, b], f(x)]'. here we must proceed recursively
22$ along the components of the tuple, emitting each of the
23$ inner assignments in order.
24
25$ we handle this recursion by using the top of 'astack' as
26$ a workpile. we begin by saving a pointer to the top of
27$ astack, then pushing 'lhs' and 'rhs'. we then iterate
28$ until the stack is 'empty', popping pairs from the
29$ stack and processing assignments.
30
31$ compound assignments are processed by pushing the
32$ appropriate pairs onto the stack. simple assignments
33$ are handled in line, and sinister assignments are
34$ handled by a lower level routine, 'gsin'.
35
36$ note that compound assignments of the form
37
38$ [a, -] := [1, 2];
39
40$ appear as:
41
42$ [a, .om] := [1, 2];
43
44$ such assignments to omega on an inner level are treated as noops.
45$ for a fuller explanation, see 'gdash'.
46
47$ for iterators, we allow [ x1, x2, ..., xn ] := om to undefine all
48$ iteration variables at the end of the iteration. this is the only
49$ context in which we allow omega as the right-hand side of a compound
50$ assignment. in this context, we replace the compound assignment by
51$ the sequence x1 := om; x2 := om; ..., xn := om.
52$
53$ setl permits assignments to read-only parameters. it does, however,
54$ copy only those parameters back to the caller which were declared
55$ as 'wr' or 'rw'.
56
57
58 size lhs(ps), $ original lhs
59 rhs(ps); $ original rhs
60 size iterflag(1); $ flags iterators
61
62 size savep(ps), $ saved value of asp
63 l(ps), $ current lhs
64 r(ps); $ current rhs
65
66 size j(ps), $ index over tuple components
67 var(ps), $ internal variable
68 l1(ps), $ inner lhs
69 r1(ps), $ inner rhs
70 inst(ps), $ instruction defining 'l'
71 op(ps); $ its opcode
72 size i(ps); $ instruction defining r
73 size fm(ps); $ form of right-hand side
74
75 size goft(ps); $ emits y = f(x) for tuples
76
77
78 savep = asp; $ save astack pointer, then push [lhs, rhs].
79 push2(lhs, rhs);
80
81 until asp = savep;
82 pop2(r, l);
83
84 if is_temp(l) then
85$ l is probably a retrieval or tuple former. find the instruction
86$ which defined it, and branch on its opcode.
87 inst = tlast(l); $ instruction defining l.
88 op = opcode(inst);
89
90 if op = q1_tup then $ multiple assignment
91
92$ if 'r' is an expression, we begin by assigning it to an internal
93$ variable. we then iterate for j := 1 ... ? l, pushing l(j)
94$ and r(j) onto the stack.
smfb 158
smfb 159$$== nb. this routine has been modified to generate better code for
smfb 160$$== (forall [ x, y ] in f) ... end forall;
smfb 161$$== and
smfb 162$$== [ x, y ] := f(z)
smfb 163$$== when f, x, and y are repred appropriately (as is the case in the
smfb 164$$== optimiser). the new code would not detect if one wrote
smfb 165$$== [ x, y ] := 'ab' or [ x, y ] := < [ 1, 1 ], [ 2, 4 ] !
smfb 166$$== which is not permitted.
95
96 if is_temp(r) then
97 i = tlast(r); $ instruction defining r
98 if opcode(i) = q1_asn then
99 $ use the form of the input of the assignment
100 $ rather than the form of the right-hand side
101 fm = form(arg2(i));
102 else
103 fm = form(r);
104 end if;
105 else
106 fm = form(r);
107 end if;
108
109 if ft_type(fm) = f_elmt then
110 $ compute the form of the value
111 while ft_type(fm) = f_elmt;
112 if (ft_type(ft_base(fm)) = f_pbase) quit;
113 fm = ft_elmt(ft_base(fm));
114 end while;
115
116 $ create a split variable and emit a conversion
117 var = getvar(0);
118
smfb 167$$== if (fm = f_gen) fm = f_tuple;
smfb 168$$== if ( ^ is_ftup(fm)) call ermsg(84, r);
smfb 169$$++
smfb 170 if ^ (is_ftup(fm) ! fm = f_gen) then
smfb 171 call ermsg(84, r);
smfb 172 end if;
smfb 173$$--
121
122 form(var) = fm; is_repr(var) = yes;
123 call emit(q1_asn, var, r, 0, 0); r = var;
124
smfb 174$$== elseif is_temp(r) ! (r ^= sym_om & fm = f_gen) then
smfb 175$$++
smfb 176 elseif is_temp(r) then
smfb 177$$--
126 var = getvar(0);
127
smfb 178$$== if (fm = f_gen) fm = f_tuple;
smfb 179$$== if ( ^ is_ftup(fm)) call ermsg(84, r);
smfb 180$$++
smfb 181 if ^ (is_ftup(fm) ! fm = f_gen) then
smfb 182 call ermsg(84, r);
smfb 183 end if;
smfb 184$$--
130
131 form(var) = fm; is_repr(var) = yes;
132 call emit(q1_asn, var, r, 0, 0); r = var;
133
smfb 185$$== elseif ^ (is_ftup(fm) ! (iterflag & r = sym_om)) then
smfb 186$$++
smfb 187 elseif r = sym_om & ^ iterflag then
smfb 188 call ermsg(84, r);
smfb 189
smfb 190 elseif ^ (is_ftup(fm) ! fm = f_gen) then
smfb 191$$--
135 call ermsg(84, r);
136 end if;
137
138 do j = nargs(inst)-1 to 1 by -1;
139 l1 = argn(inst, j+1); $ j-th component of l
140 if (l1 = sym_om) cont;
141
142 if (iterflag & r = sym_om) then
143 r1 = sym_om;
144 else
145 r1 = goft(r, j); $ temp for 'r(1)'
146 end if;
147
148 push2(l1, r1);
149 end do;
150
151$ change tuple former to a noop.
152 opcode(inst) = q1_noop;
153 is_store(arg1(inst)) = no;
154
155 elseif sinmap(op) ^= 0 then $ retrieval operation
156 call gsin(l, r);
157
158 else $ some other expression
159 call ermsg(18, 0);
160 end if;
161
162 elseif ^ is_write(l) & ^ is_param(l) then
163 call ermsg(19, l);
164
165 else $ simple assignment
166 call emit(q1_asn, l, r, 0);
167 end if;
168 end until;
169
170
171 end subr gasn;
1 .=member gsin
2 subr gsin(lhs, rhs);
3
4$ this routine generates sinister assignments 'lhs := rhs'.
5$ 'lhs' is a temporary generated by an of, ofa, or ofb
6$ operation. we map the code which generated 'lhs' into
7$ the corresponding sinister assignment.
8
9
10 size lhs(ps); $ left hand side
11 size rhs(ps); $ right hand side
12
13 size targ(ps); $ target of code motion
14 size model(ps); $ model instruction for assignment
15 size r(ps); $ current right hand side
16 size op(ps); $ retrieval opcode
17 size rmap(ps); $ map we retrieve from
18 size lmap(ps); $ map we store into
19 size indx(ps); $ index for assignment
20 size sinop(ps); $ sinister assignment opcode
21 size last(ps); $ last retrieval operation
22
23 size a(ps); $ array of arguments
24 dims a(4);
25
26
27$ we begin by moving the code for lhs to the end of the
28$ program so that it is executed after the code for rhs.
29
30 targ = prog_end; last = tlast(lhs);
31 call movblk(tprev(lhs), last, targ);
32
33$ next we find the retrieval instruction which created 'lhs'.
34$ we use this instruction as a model to emit the appropriate
35$ assignment.
36
37$ 'lhs' will generally be the result of some expression such
38$ as 't := f(x1 ... xn)', that is it will be the result of a
39$ series of retrieval instructions which start with a program
40$ variable and continue accessing pieces of more deeply nested
41$ maps. the corresponding assignment must start by assigning
42$ to the innermost map, then keep generating assignments until
43$ it stores into a variable.
44
45$ note that the parser will accept '(a+b) (1)' as a valid left
46$ hand side. thus as we generate assignments we must watch out
47$ for errors. we use an array called sinmap to map retrieval opcodes
48$ into the corresponding storage opcodes. if we find a
49$ storage opcode of 0, it means that we have an illegal
50$ expression used as a left hand side.
51
52
53 model = last; $ model instruction for assignment
54 r = rhs; $ current right hand side
55
56 while 1;
57 op = opcode(model); $ get map name and opcode
58 rmap = arg2(model);
59
60 if ^ is_write(rmap) & ^ is_param(rmap) then
61 call ermsg(53, rmap);
62 end if;
63
64 if model ^= last then
65 call reuse(model, 2); call reuse(model, 3);
66 end if;
67
68 lmap = arg2(model); indx = arg3(model);
69
70 if op = q1_subst then $ substring assignments
71 if (model ^= last) call reuse(model, 4);
72
73 a(1) = lmap;
74 a(2) = indx;
75 a(3) = arg4(model); $ length of substring
76 a(4) = r;
77
78 call emitn(q1_ssubst, a, 4);
79
80 else
81 sinop = sinmap(op); $ get sinister opcode
82 if (sinop = 0) go to error;
83
84 call emit(sinop, lmap, indx, r);
85 end if;
86
87$ if 'map' is a variable we're done. otherwise we must store
88$ it back in the map it came from.
89
90 if (^ is_temp(rmap)) quit while;
91
92 model = tlast(rmap);
93 r = lmap;
94 end while;
95
96$ change the 'of' instruction which created 'lhs' to a noop.
97 opcode(last) = q1_noop;
98 is_store(lhs) = no;
99
100 return;
101
102/error/ $ found bad left hand side
103
104 call ermsg(18, 0);
105
106 return;
107
108 end subr gsin;
1 .=member gif1
2 subr gif1;
3
4$ this routine is called after seeing the keyword 'if'.
5$ we generate a cstack entry and get the 'else' and 'end'
6$ labels.
7
8$ make cstack entry
9 countup(csp, cstack_lim, 'cstack');
10 cstack(csp) = 0;
11 cs_type(csp) = cs_if;
12
13$ get labels for else and end.
14 cs_else(csp) = getlab(0);
15 cs_end(csp) = getlab(0);
16
17
18 end subr gif1;
1 .=member gif2
2 subr gif2;
3
4$ this routine is called after seeing 'if then' or
5$ 'elseif then'. we emit 'if (^ exp) go to else-label'
6
7
smfb 192 size exp(ps); $ symtab pointer for result of expression
smfb 193 size lab(ps); $ else label
smfb 194
smfb 195
smfb 196 pop1(exp); lab = cs_else(csp);
smfb 197
smfb 198 if is_temp(exp) = yes & bsp >= 1 then
smfb 199 if exp = bs_temp(bsp) then
smfb 200 call gbool(q1_ifnot,exp,yes,bs_true(bsp),bs_false(bsp),lab);
smfb 201 bsp = bsp - 1;
smfb 202 else
smfb 203 call emit(q1_ifnot, exp, lab, 0);
smfb 204 end if;
smfb 205 else
smfb 206 call emit(q1_ifnot, exp, lab, 0);
smfb 207 end if;
14
15
16 end subr gif2;
1 .=member gif3
2 subr gif3;
3
4$ this routine is called after seeing the last 'elseif' clause of
5$ an if-statement. we emit 'go to end-label; /else-label/'.
6$ this gives us a null 'else' clause if the user does not supply
7$ one.
8
9 call emit(q1_goto, cs_end(csp), 0, 0);
10
11 call deflab(cs_else(csp));
12
13
14 end subr gif3;
1 .=member gif4
2 subr gif4;
3
4$ this routine is called after seeing the end of an if-statement or
5$ conditional expression. we must do three things:
6
7$ 1. define the 'end' label.
8
9$ 2. if this is a conditional expression(cs_temp ^= 0), we must
10$ push the result of the expression onto the stack and set its
11$ tlast field to point to the 'end' label.
12
13$ 3. pop cstack
14
15
16 size temp(ps); $ temp for result of conditional expression
17
18
19 call deflab(cs_end(csp));
20
21 temp = cs_temp(csp);
22
23 if temp ^= 0 then
24 tlast(temp) = prog_end;
25 push1(temp);
26 end if;
27
28 csp = csp-1; $ pop cstack
29
30
31 end subr gif4;
1 .=member gif5
2 subr gif5;
3
4$ this routine is called after seeing 'if then ...
5$ elseif'. we emit 'go to end_label; /else_label/', then obtain
6$ a new else_label for the next else-clause.
7
8 call emit(q1_goto, cs_end(csp), 0, 0);
9
10 call deflab(cs_else(csp));
11
12 cs_else(csp) = getlab(0);
13
14
15 end subr gif5;
1 .=member gloop1
2 subr gloop1;
3
4$ this routine is called at the start of a loop body. loops
5$ have the form
6
7$ ( ! ) end;
8
9$ when we process the we generate the code for
10$ a complete loop with a null body. after we have processed
11$ the actual loop body, we move it into the middle of the loop.
12
13$ in order to move the body, we must save a pointer to the last
14$ instruction emitted before the body.
15
16 push1(prog_end);
17
18
19 end subr gloop1;
1 .=member gloop2
2 subr gloop2;
3
4$ this routine is called after processing the entire loop body.
5$ we pop a pointer to the start of the body, then move it into
6$ the middle of loop.
7
8
9 size prev(ps), $ pointers to code fragment
10 last(ps);
11
12
13 pop1(prev);
14 last = prog_end;
15
16 call gbody(prev, last);
17 call endlp;
18
19
20 end subr gloop2;
1 .=member gcase1
2 subr gcase1;
3
4$ this routine is called after seeing the key word 'case'. we
5$ build a new cstack entry and get the 'end' and 'else' labels.
6$ we also initilize the number of choices to 0.
7
8 countup(csp, cstack_lim, 'cstack');
9 cstack(csp) = 0;
10 cs_type(csp) = cs_case;
11
12$ fill in 'else' label and 'end' label. set the number of map elements
13$ to zero.
14 cs_else(csp) = getlab(0);
15 cs_end(csp) = getlab(0);
16 cs_num(csp) = 0;
17
18
19 end subr gcase1;
1 .=member gcase2
2 subr gcase2;
3
4$ this routine is called after seeing 'case of'. at this
5$ point we emit two instructions:
6
7$ 1. q1_case: look up in a map and jump on the result
8$ if it is defined.
9
10$ 2. q1_goto: branch to the else label
11
12$ the map used in (1) is not built until the end of the case statement.
13$ we save a pointer to the instruction and set its first argument later.
14
15$ since the case map is a constant, the optimizer can examine its
16$ value to find the sucessors of the case statement.
17
18 size exp(ps); $ expression for case jump
19
20 pop1(exp);
21
22 call emit(q1_case, 0, exp, 0);
23 cs_jump(csp) = prog_end;
24
25 call emit(q1_goto, cs_else(csp), 0, 0);
26
27
28 end subr gcase2;
1 .=member gcase3
2 subr gcase3;
3
4$ this routine is called after seeing the last choice in a case
5$ statement. at this point we define the else label. if the
6$ user has not supplied an 'else' clause, we will generate an empty one.
7
8 call deflab(cs_else(csp));
9
10
11 end subr gcase3;
1 .=member gcase4
2 subr gcase4;
3
4$ this routine is called at the end of a case statement. we must
5$ do four things:
6
7$ 1. finish building the case map
8
9$ we do this by pushing the number of tags-1 onto
10$ the stack and calling 'gset3'. we then pop the result
11$ and install it as the first argument of the jump
12$ instruction.
13
14$ 2. define the end label
15
16$ 3. if this is a case expression(cs_temp ^= 0), we must push
17$ the result of the expression onto the stack and set its
18$ tlast field to point to the end label.
19
20$ 4. pop cstack.
21
22 size map(ps); $ variable used to hold case map value
23 size temp(ps); $ temporary for result of case expression
24 size fm(ps); $ form of in case of
25 size base(ps); $ form of base (if form() = f_elmt)
26 size prefix(ps); $ based map prefix
smfb 208 size save_rpr_flag(ps); $ so we can overwrite repr-processing mode
smfb 209 size caseb(1); $ indicates case map can be based
smfb 210 size caset(1); $ indicates case 'map' can be tuple
smfb 211 size done(1); $ indicates that case tags are sorted
smfb 212 size i(ps), j(ps); $ loop indices
smfb 213 size exp(ps); $ symbol table pointer for case expression
smfb 214 size nam(ps); $ symbol table pointer for case tag
smfb 215 size max(ws); $ maximum index for case tuple
smfb 216 size v(ws); $ integer value (signed)
smfb 217
28
29$ first finish the setformer
30
31 if (cs_num(csp) >= vlen_lim) call overfl('too many cases');
32
39 $ if of 'case of...' has the form 'elmt b', then we
40 $ generate the form 'remote smap(elmt b) label' for the case map;
41 $ otherwise we generate the form 'smap(general) label'.
42 save_rpr_flag = rpr_flag; rpr_flag = 1;
smfb 218 exp = arg2(cs_jump(csp)); $ in 'case of'
smfb 219 fm = form(exp); $ form of
44 base = ft_base(fm); $ form of 's base (if any)
45
46 if ft_type(fm) = f_elmt & ft_type(base) ^= f_pbase then
smfb 220 caseb = yes;
smfb 221 else
smfb 222 caseb = no;
smfb 223 end if;
smfb 224
smfb 225 $ if all case tags are positive integers within a dense enough
smfb 226 $ range we repesent the case 'map' as a tuple. next we dermine
smfb 227 $ whether this is the case.
smfb 228
smfb 229 caset = yes; max = 0;
smfb 230
smfb 231 do j = 0 to cs_num(csp)-1;
smfb 232
smfb 233 $ astack(asp-j) is a pair [ tag, label ]. we check whether
smfb 234 $ the tag, i.e. the first component of the pair, is a positive
smfb 235 $ integer. simultaneously we determine the largest index to
smfb 236 $ avoid generating a very sparse tuple.
smfb 237
smfb 238 nam = symval(astack(asp-j)); $ first component of pair
smfb 239 if ^ is_fint(form(nam)) then caset = no; quit do; end if;
smfb 240 v = symval(nam); if v <= 0 then caset = no; quit do; end;
smfb 241 if (v > max) max = v;
smfb 242 end do;
smfb 243
smfb 244 +* ebm_nw = 4 ** $ q2 map element block number of words
smfb 245 if (max > ebm_nw*cs_num(csp)) caset = no;
smfb 246
smfb 247 $ don't generate a tuple if this would cause an error which would
smfb 248 $ not occur if we generated a map.
smfb 249 if max > cs_num(csp) then
smfb 250 if (max >= vlen_lim) caset = no;
smfb 251 if (max >= nargs_lim) caset = no;
smfb 252 end if;
smfb 253
smfb 254 if caset = yes & max < cs_num(csp) then
smfb 255 $ there must be dublicate case tag values.
smfb 256 call ermsg(28, 0); caset = no;
smfb 257 end if;
smfb 258
smfb 259 if (opt_flag) caset = no;
smfb 260
smfb 261 if caseb = no & caset = yes then
smfb 262 if is_repr(exp) &
smfb 263 ^ (is_fint(ft_deref(fm)) ! ft_deref(fm) = f_gen) then
smfb 264 call warn(07, 0);
smfb 265 end if;
smfb 266
smfb 267 $ sort the case tags into ascending order using bubble sort.
smfb 268 $ we can assume that typically they are almost sorted.
smfb 269
smfb 270 until done;
smfb 271 done = yes; $ assume all sorted
smfb 272 do j = 1 to cs_num(csp)-1;
smfb 273 if symval(symval(astack(asp-j+1))) <
smfb 274 symval(symval(astack(asp-j))) then
smfb 275 swap(astack(asp-j+1), astack(asp-j)); done = no;
smfb 276 end if;
smfb 277 end do;
smfb 278 end until;
smfb 279
smfb 280 $ create dummy entries as required to get the full sequence of
smfb 281 $ short integers. simultaneously replace each pair by its
smfb 282 $ label, i.e. its second component; also delete the pairs as
smfb 283 $ we go along. in the loop that follows, i ranges over the
smfb 284 $ original astack entries, nam points to the i'th pair, and v
smfb 285 $ holds the tag value of the i'th pair; j ranges over the
smfb 286 $ case tuple components.
smfb 287
smfb 288 i = asp; nam = astack(i); v = symval(val(vptr(nam)));
smfb 289 get_stack(max - cs_num(csp));
smfb 290
smfb 291 do j = max to 1 by -1;
smfb 292 if v = j then $ insert i'th entry at j'th position
smfb 293 astack(asp-max+j) = val(vptr(nam)+1);
bnda 39 assert is_internal(nam); assert is_ftup(form(nam));
bnda 40 is_store(nam) = no;
smfe 9 i = i - 1; if (i <= asp-max) cont do j;
smfb 297 nam = astack(i); v = symval(val(vptr(nam)));
smfb 298 else
smfb 299 astack(asp-max+j) = cs_else(csp);
smfb 300 end if;
smfb 301 end do;
smfb 302
smfb 303 $ generate the case tuple value
smfb 304 push1(max-1); call gtup3; pop1(map);
smfb 305 else
smfb 306 $ generate the case map value
smfb 307 push1(cs_num(csp)-1); call gset3; pop1(map);
smfb 308 end if;
smfb 309
smfb 310 $ insert the case map constant into the case instruction
smfb 311 arg1(cs_jump(csp)) = map;
smfb 312
smfb 313 $ finally, we repr the case map.
smfb 314 if caseb = no & caset = yes then $ generate the form tuple(label)
smfb 315 push2(map, 0);
smfb 316 push2(f_lab, sym_zero);
smfb 317 call gttup2; $ generate tuple(label)
smfb 318 call grepr; $ and repr map: tuple(label);
smfb 319
smfb 320 elseif caseb = yes then
smfb 321 $ generate the form 'based smap(elmt b) label'.
smfb 322
47 if is_local_repr(base) & ft_lim(base) > 0 then
48 $ a constant base in the current scope
49 prefix = sym_local;
50 else
51 prefix = sym_remote;
52 end if;
53
54 push2(map, 0);
55 push1(prefix);
56 push4(sym_msmap, fm, 0, f_lab);
57 call gtmap1; $ generate smap(fm) label
58 call gtpref; $ generate smap(fm) label
59 call grepr; $ and repr map: remote smap(fm) label;
60
61 else
62 push2(map, 0);
63 push4(sym_msmap, f_gen, 0, f_lab);
64 call gtmap1; $ generate smap(general) label
65 call grepr; $ and repr map: smap(general) label;
66 end if;
67 rpr_flag = save_rpr_flag; $ restore original repr-processing mode
68
69$ define 'end' label
70 call deflab(cs_end(csp));
71
72 temp = cs_temp(csp); $ push result if necessary
73
74 if temp ^= 0 then
75 tlast(temp) = prog_end;
76 push1(temp);
77 end if;
78
79 csp = csp-1; $ pop cstack
80
81
82 end subr gcase4;
1 .=member gcase5
2 subr gcase5;
3
4$ this routine is called at the end of each case choice. it generates
5$ a branch to the end label.
6
7 call emit(q1_goto, cs_end(csp), 0, 0);
8
9
10 end subr gcase5;
1 .=member gtag1
2 subr gtag1;
3
4$ this routine is called at the start of a case tag. it
5$ allocates a label for the tag and defines it, then
6$ saves the label on cstack.
7
8 size tag(ps); $ tag label
9
10 tag = getlab(0);
11 call deftag(tag);
12
13 cs_tag(csp) = tag;
14
15
16 end subr gtag1;
1 .=member gtag2
2 subr gtag2;
3
4$ this routine is called after seeing a simple tag name.
5$ we pop the tag value and label then do two things:
6
7$ 1. check that the tag is constant, then build a pair
8$ [tag, label] and push a pointer to it onto astack.
9
10$ 2. increment the number of tags.
11
12 size nam(ps), $ tag name
13 lab(ps); $ tag label
14
15$ get name and label
16 pop1(nam);
17 lab = cs_tag(csp);
18
19$ build pair
20 push3(nam, lab, 1);
21 call gtup3;
22
23$ increment counter for number of map elements.
24 cs_num(csp) = cs_num(csp) + 1;
25
26
27 end subr gtag2;
1 .=member gtag3
2 subr gtag3;
3
4$ this routine is called after seeing '_ name' in a case
5$ tag. we check that nam is a constant set or tuple, then
6$ iterate over its elements, calling 'gtag2'.
7
8 size nam(ps), $ name of constant set
9 j(ps), $ loop index
10 elmt(ps); $ element of constant set
11
12 pop1(nam);
13
14 if ^ is_const(nam) ! is_fprim(form(nam)) then
15 call ermsg(20, nam);
16
17 else
18 do j = 0 to vlen(nam)-1;
19 elmt = val(vptr(nam)+j);
20 push1(elmt);
21 call gtag2;
22 end do;
23 end if;
24
25
26 end subr gtag3;
1 .=member ggoto
2 subr ggoto;
3
4$ this routine processes the goto statement. for now we make
5$ no checking for invalid gotos.
6
7 size lab(ps); $ label name
8
9 pop1(lab); $ get target of goto.
10
11 if is_decl(lab) & symtype(lab) ^= f_lab then
12 call ermsg(21, lab);
13 else
14 is_decl(lab) = yes;
15 form(lab) = f_lab;
16 call emit(q1_goto, lab, 0, 0);
17
18 call deflab(getlab(0));
19 end if;
20
21
22 end subr ggoto;
1 .=member gasrt1
2 subr gasrt1;
3
4$ this routine is called at the start of every assert statement. we
5$ emit the branch 'if getipp('assert=1/2') = 0 then goto lab' and save
6$ the label.
7
8 size lab(ps); $ symbol table pointer for label
9
10 lab = getlab(0);
11 call emit(q1_ifasrt, lab, 0, 0);
12 push1(lab);
13
14 end subr gasrt1;
1 .=member gasrt2
2 subr gasrt2;
3
4$ this routine finishes the processing of 'assert := '.
5
6 size lhs(ps); $ left hand side of statement
7 size exp(ps); $ result of expression
8 size var(ps); $ internal variable for expression
9 size lab(ps); $ symbol table pointer for label
10
11
12 pop2(exp, lhs);
13
14 if is_temp(exp) then
15 var = getvar(0); call emit(q1_asn, var, exp, 0); exp = var;
16 end if;
17
18 $ generate code for 'if lhs /= exp then'
19 call gif1;
20 push3(lhs, exp, sym_ne); call gbin; $ emit 'lhs /= exp'
21 call gif2;
22
23 $ generate code for 'then' block, i.e. when assertion failed
24 call emit(q1_asrt, sym_false, 0, 0); $ this assertion failed
25 push2(lhs, exp); call gasn1; $ emit recovery code
26
27 $ generate code for 'else' block, i.e. when assert succeeded
28 call gif3;
29 call emit(q1_asrt, sym_true, 0, 0); $ this assertion succeeded
30
31 $ finish if statement
32 call gif4;
33
34 pop1(lab); call deflab(lab);
35
36
37 end subr gasrt2;
1 .=member gasrt3
2 subr gasrt3;
3
4$ this routine finishes the processing of 'assert '.
5
6 size exp(ps); $ result of expression
7 size lab(ps); $ symbol table pointer for label
8
9 pop1(exp); call emit(q1_asrt, exp, 0, 0);
10 pop1(lab); call deflab(lab);
11
12 end subr gasrt3;
1 .=member gret1
2 subr gret1;
3
4$ this routine processes 'return '. each procedure has a global
5$ variable associated with it which is used to pass the returned value.
6$ the name of this variable is given by 'retvar(routine)'.
7
8$ a return statement is treated as an assignment to the appropriate
9$ global followed by a jump to the routines exit block.
10
11 size exp(ps); $ expression being returned
12
13 pop1(exp);
14
15 call emit(q1_asn, symval(currout), exp, 0);
16 call emit(q1_goto, exit_lab, 0, 0);
17
18
19 end subr gret1;
1 .=member gret2
2 subr gret2;
3
4$ this routine processes 'return;'. this is treated as short for
5$ 'return om;'.
6
7 push1(sym_om);
8 call gret1;
9
10
11 end subr gret2;
1 .=member gexit
2 subr gexit;
3
4$ this routine handles the exit statement. we make sure that we are
5$ in a perform block then emit a branch to its exit label.
6
7 size lab(ps); $ label for return point
8
9 if curperf = 0 then $ not in perform block
10 call ermsg(36, 0);
11 else
12 lab = val(vptr(curperf)+1);
13 call emit(q1_goto, lab, 0, 0);
14 end if;
15
16
17 end subr gexit;
1 .=member gcont
2 subr gcont;
3
smfa 16$ this routine processes the continue statement. the top astack entry
smfa 17$ is a counter indicating which loop we should continue. we emit a
smfa 18$ branch to its step label.
smfa 19
smfa 20 size lab(ps); $ label to branch to
smfa 21 size n(ps); $ number of loops to quit
smfa 22 size p(ps); $ cstack pointer
smfa 23
smfa 24 size findlp(ps); $ returns cstack pointer to proper loop
smfa 25
smfa 26
smfa 27 pop1(n); p = findlp(n);
smfa 28
smfa 29 if p = 0 then lab = stop_lab; else lab = cs_lstep(p); end if;
smfa 30 if (lab = 0) lab = stop_lab;
smfa 31 if (lab = stop_lab) call emit(q1_error, 0, 0, 0);
smfa 32
smfa 33 call emit(q1_goto, lab, 0, 0);
18
19
20 end subr gcont;
1 .=member gquit
2 subr gquit;
3
smfa 34$ this routine processes the quit statement. the top astack entry is a
smfa 35$ counter indicating which loop we should quit. we emit a branch to its
smfa 36$ quit label.
smfa 37
smfa 38 size lab(ps); $ label to branch to
smfa 39 size n(ps); $ number of loops to quit
smfa 40 size p(ps); $ cstack pointer
smfa 41
smfa 42 size findlp(ps); $ returns cstack pointer to proper loop
smfa 43
smfa 44
smfa 45 pop1(n); p = findlp(n);
smfa 46
smfa 47 if p = 0 then lab = stop_lab; else lab = cs_lquit(p); end if;
smfa 48 if (lab = 0) lab = stop_lab;
smfa 49 if (lab = stop_lab) call emit(q1_error, 0, 0, 0);
smfa 50
smfa 51 call emit(q1_goto, lab, 0, 0);
17
18
19 end subr gquit;
1 .=member gyield
2 subr gyield;
3
4$ this routine processes the yield statement. the yield
5$ statement is essentially a return from an 'expr' block.
6
7$ we begin by getting a cstack pointer to the innermost
8$ 'expr' block; if none exists we diagnose an error.
9$ otherwise we look up the name of the temporary for
10$ the block, and its exit label. we then emit
11$ 'temp = exp; go to label'.
12
13
14 size j(ps), $ loop index
15 exp(ps); $ temp for expression
16$ look for 'expr' entry on cstack.
17
18 do j = csp to 1 by -1;
19
20 if cs_type(j) = cs_eblk then
21 pop1(exp);
22
23 call emit(q1_asn, cs_temp(j), exp, 0);
24 call emit(q1_goto, cs_end(j), 0, 0);
25
26 return;
27 end if;
28 end do;
29
30 call ermsg(24, 0);
31
32
33 end subr gyield;
1 .=member gstop
2 subr gstop;
3
4$ this routine processes the stop statement. it is treated as a jump
5$ to the routines stop label.
6
7 call emit(q1_goto, stop_lab, 0, 0);
8
9
10 end subr gstop;
1 .=member gdebug
2 subr gdebug;
3
4$ this routine handles the debugging statement. this statement
5$ consists of the keyword 'debug' followed by a list of names.
6$ it is used to trigger various switches in the compiler.
7
8 size n(ps), $ number of names-1
9 j(ps), $ loop index
10 nam(ps); $ debugging token
11
12 pop1(n); $ number of names-1
13
14 do j = n to 0 by -1;
15 nam = astack(asp-j);
16
17 if nam < sym_debug_min ! nam > sym_debug_max then
18 call ermsg(47, nam);
19
20 elseif nam < sym_sdebug_min then $ ignore parser option
21 cont;
22
23 elseif nam > sym_sdebug_max then $ pass to codegen
24 call emit(q1_debug, nam, 0, 0);
25
26 else $ valid debugging option
27 go to case(nam) in sym_sdebug_min to sym_sdebug_max;
28
29 /case(sym_stre0)/ $ enable entry trace
30
31 monitor noentry;
32 cont;
33
34 /case(sym_stre1)/ $ enable entry trace
35
36 monitor entry, limit = 10000;
37 cont;
38
39 /case(sym_strs0)/ $ disable astack trace
40
41 trs_flag = no;
42 cont;
43
44 /case(sym_strs1)/ $ enable astack trace
45
46 trs_flag = yes;
47 cont;
48
49 /case(sym_sq1cd)/ $ q1 code dump
50
51 call prgdmp;
52 cont;
53
54 /case(sym_sq1sd)/ $ q1 symbol table dump
55
56 call sdump;
57 cont;
58
59 /case(sym_scstd)/ $ dump cstack
60
61 call csdump;
62 cont;
63
64 end if;
65 end do;
66
67 free_stack(n+1);
68
69
70 end subr gdebug;
1 .=member gfail
2 subr gfail;
3
4$ this routine processes the fail statement.
5
6 call emit(q1_fail, 0, 0, 0);
7
8
9 end subr gfail;
1 .=member gscdst
2 subr gscdst;
3
4$ this routine processes the succeed statement.
5
6 call emit(q1_succeed, 0, 0, 0);
7
8
9 end subr gscdst;
1 .=member gok
2 subr gok;
3
4$ this routine processes the 'ok' operator.
5
6 size temp(ps); $ temp for result
7
8 temp = gettmp(0);
9
10 tprev(temp) = prog_end;
11
12 call emit(q1_ok, 0, 0, 0);
13 call emit(q1_asn, temp, sym_okval, 0);
14
15 tlast(temp) = prog_end;
16 push1(temp);
17
18
19 end subr gok;
1 .=member glev
2 subr glev;
3
4$ this routine processes the '.lev' operator
5
6 size temp(ps); $ temp for result
7
8 temp = gettmp(0);
9
10 call emit(q1_lev, temp, 0, 0);
11
12 push1(temp);
13
14
15 end subr glev;
1 .=member gtrace
2 subr gtrace;
3
4$ this routine processes the trace statement. for now, we
5$ merely pop the list of options and return.
6
7
8 size option(ps); $ trace option
9 size n(ps); $ number of 's - 1
10 size j(ps); $ loop index
11
12
13 pop1(n);
14
15 do j = 0 to n;
16 pop1(option);
17
18 call emit(q1_trace, option, 0, 0);
19 end do;
20
21
22 end subr gtrace;
1 .=member gnotrc
2 subr gnotrc;
3
4$ this routine processes the 'notrace ;' statement.
5
6 size option(ps); $ trace option
7 size n(ps); $ number of 's - 1
8 size j(ps); $ loop index
9
10
11 pop1(n);
12
13 do j = 0 to n;
14 pop1(option);
15
16 call emit(q1_notrace, option, 0, 0);
17 end do;
18
19
20 end subr gnotrc;
1 .=member gasn1
2 subr gasn1;
3
4$ this routine processes ' := ;', i.e. when it is used
5$ as a statement.
6
7
8 size lhs(ps); $ left hand side
9 size exp(ps); $ result of
10
11
12 pop2(exp, lhs); call gasn(lhs, exp, no);
13
14
15 end subr gasn1;
1 .=member gasn2
2 subr gasn2;
3
4$ this routine is called after seeing ' op:= ;', i.e.
5$ when it is used as a statement. we treat it as a short hand
6$ notation for 'temp := op ; := temp;'.
7
8
9 size lhs(ps); $ left hand side
10 size op(ps); $ binary operator <*bin> or <*bold>
11 size exp(ps); $ result of
12 size temp(ps); $ result of <*bin>
13
14
15 pop3(exp, op, lhs);
16
17 push3(lhs, exp, op); $ generate 'temp := op '
18 if op < user_org then call gbin; else call gubin; end if;
19 pop1(temp);
20
21$ there are 4 cases for the assignment:
22$
23$ 1. is a general left hand side. call 'gasn1' with a
24$ copy of the code fragment for .
25$
26$ 2. has an element mode. we take the same action as in
27$ case 1 since we need the assignment to convert the result.
28$
29$ 3. is a simple variable with write access. emit a simple
30$ assignment.
31$
32$ 4. is read-only. generate a diagnostic.
33
34 if is_temp(lhs) ! ft_type(form(lhs)) = f_elmt then
35 push2(copy(lhs), temp); call gasn1;
36
37 elseif is_write(lhs) ! is_param(lhs) then
38 push2(lhs, temp); call gasn1;
39
40 else
41 call ermsg(19, lhs);
42 end if;
43
44
45 end subr gasn2;
1 .=member gasn3
2 subr gasn3;
3
4$ this routine processes ' := ', i.e. when itis used
5$ as an expression. there are three possibilities:
6$
7$ 1. both lhs and rhs are expressions: we emit
8$ internal := rhs
9$ lhs := internal
10$ result := internal
11$ and push result.
12$
13$ 2. lhs is a name: emit
14$ lhs := rhs
15$ result := lhs
16$ and push result.
17$
18$ 3. rhs is a name: emit
19$ lhs := rhs
20$ result := rhs
21$ and push result.
22
23
24 size lhs(ps); $ left hand side
25 size rhs(ps); $ right hand side
26 size var(ps); $ 'internal' above
27 size result(ps); $ result above
28
29
30 pop2(rhs, lhs);
31
32 result = gettmp(0);
33
34 if is_temp(rhs) then
35 tprev(result) = tprev(rhs);
36 else
37 tprev(result) = prog_end;
38 end if;
39
40 if is_temp(lhs) & is_temp(rhs) then
41 var = getvar(0);
42
43 call emit(q1_asn, var, rhs, 0);
44 push2(lhs, var); call gasn1;
45 call emit(q1_asn, result, var, 0);
46
47 elseif ^ is_temp(lhs) then
48 call emit(q1_asn, lhs, rhs, 0);
49 call emit(q1_asn, result, lhs, 0);
50
51 else
52 push2(lhs, rhs); call gasn1;
53 call emit(q1_asn, result, rhs, 0);
54 end if;
55
56 tlast(result) = prog_end;
57 push1(result);
58
59
60 end subr gasn3;
1 .=member gasn4
2 subr gasn4;
3
4$ this routine is called after seeing ' op:= ', i.e.
5$ when it is used as an expression. we treat it as a short hand
6$ notation for 'temp := op ; := temp;'.
7$
8$ this routine is identical to 'gasn2', except that we call 'gasn3'
9$ for the final assignment.
10
11
12 size lhs(ps); $ left hand side
13 size op(ps); $ binary operator <*bin> or <*bold>
14 size exp(ps); $ result of
15 size temp(ps); $ result of <*bin>
16
17
18 pop3(exp, op, lhs);
19
20 push3(lhs, exp, op); $ generate 'temp := op '
21 if op < user_org then call gbin; else call gubin; end if;
22 pop1(temp);
23
24 if is_temp(lhs) ! ft_type(form(lhs)) = f_elmt then
25 push2(copy(lhs), temp); call gasn3;
26
27 elseif is_write(lhs) ! is_param(lhs) then
28 push2(lhs, temp); call gasn3;
29
30 else
31 call ermsg(19, lhs);
32 end if;
33
34
35 end subr gasn4;
1 .=member gfrom1
2 subr gfrom1;
3
4$ this routine processes 'a1 <*from> a2;'.
5
6$ n.b. 'a1' is an output, while 'a2' is both an input and an output.
7$ we therefore might have to generate two sinister assignments.
8
9
10 size op(ps); $ operator
11 size a1(ps); $ left operand
12 size a2(ps); $ right operand
13
14 size t1(ps), t2(ps); $ possible copies of operands
15
16
17 pop3(a2, op, a1);
18
19 if is_temp(a1) then
20 t1 = getvar(0);
21 else
22 if (^is_write(a1) & ^is_param(a1)) call ermsg(19, a1);
23
24 t1 = a1;
25 end if;
26
27 if is_temp(a2) ! ft_type(form(a2)) = f_elmt then
28 t2 = gettmp(0); tprev(t2) = tprev(a2);
29 call emit(q1_asn, t2, a2, 0);
30 else
31 if (^is_write(a2) & ^is_param(a2)) call ermsg(19, a2);
32
33 t2 = a2;
34 end if;
35
36 call emit(opmap(op), t1, t2, 0);
37
38 if (t1 ^= a1) call gasn( a1 , t1, no);
39 if (t2 ^= a2) call gasn(copy(a2), t2, no);
40
41
42 end subr gfrom1;
1 .=member gfrom2
2 subr gfrom2;
3
4$ this routine processes 'result := a1 <*from> a2'.
5
6$ n.b. 'a1' is an output, while 'a2' is both an input and an output.
7$ we therefore might have to generate two sinister assignments.
8
9
10 size op(ps); $ operator
11 size a1(ps); $ left operand
12 size a2(ps); $ right operand
13
14 size result(ps); $ temporary for result of expression
15 size t1(ps), t2(ps); $ possible copies of operands
16
17
18 pop3(a2, op, a1);
19
20 result = gettmp(0); tprev(result) = prog_end;
21
22 if is_temp(a1) then
23 t1 = getvar(0);
24 else
25 if (^is_write(a1) & ^is_param(a1)) call ermsg(19, a1);
26
27 t1 = a1;
28 end if;
29
30 if is_temp(a2) ! ft_type(form(a2)) = f_elmt then
31 t2 = gettmp(0);
32 call emit(q1_asn, t2, a2, 0);
33 else
34 if (^is_write(a2) & ^is_param(a2)) call ermsg(19, a2);
35
36 t2 = a2;
37 end if;
38
39 call emit(opmap(op), t1, t2, 0);
40
41 if (t1 ^= a1) call gasn( a1 , t1, no);
42 if (t2 ^= a2) call gasn(copy(a2), t2, no);
43
44 call emit(q1_asn, result, t1, 0); tlast(result) = prog_end;
45 push1(result);
46
47
48 end subr gfrom2;
1 .=member gbin
2 subr gbin;
3
4$ this routine proceses 'result = a1 <*bin> a2'.
5
6
7 size op(ps); $ (binary) operator
8 size a1(ps); $ left operand
9 size a2(ps); $ right operand
10
smfb 323 size lab(ps); $ label in logical expression
smfb 324 size bool1(1); $ 'left operand is result of boolean'
smfb 325 size true1(ps); $ true list for left operand
smfb 326 size false1(ps); $ false list for left operand
smfb 327 size bool2(1); $ 'right operand is result of boolean'
smfb 328 size true2(ps); $ true list for right operand
smfb 329 size false2(ps); $ false list for right operand
11 size t1(ps); $ internal variable for a1
12 size t2(ps); $ result of test for query
13 size prev(ps); $ program end at start of routine
smfb 330 size result(ps); $ result of operation
smfb 331 size success(1); $ indicates successful constant folding
16
17
18 pop3(op, a2, a1);
19
smfb 332 if op = sym_and ! op = sym_or ! op = sym_impl then
smfb 333
smfb 334 $ first determine whether any of the inputs is the result of a
smfb 335 $ boolean operation. we can simplify the code if it is.
smfb 336 if is_temp(a2) = yes & bsp >= 1 then
smfb 337 if a2 = bs_temp(bsp) then
smfb 338 true2 = bs_true(bsp); false2 = bs_false(bsp);
smfb 339 bool2 = yes; bsp = bsp - 1;
smfb 340 else
smfb 341 bool2 = no;
smfb 342 end if;
smfb 343 else
smfb 344 bool2 = no;
smfb 345 end if;
smfb 346
smfb 347 if is_temp(a1) = yes & bsp >= 1 then
smfb 348 if a1 = bs_temp(bsp) then
smfb 349 true1 = bs_true(bsp); false1 = bs_false(bsp);
smfb 350 bool1 = yes; bsp = bsp - 1;
smfb 351 else
smfb 352 bool1 = no;
smfb 353 end if;
smfb 354 else
smfb 355 bool1 = no;
smfb 356 end if;
smfb 357
smfb 358 lab = getlab(0);
smfb 359 result = gettmp(0); tprev(result) = prog_end;
smfd 10 is_back(result) = yes;
smfb 360
smfb 361 if op = sym_and then
smfb 362
smfb 363 call emit(q1_asn, result, sym_false, 0);
smfb 364
smfb 365 prev = prog_end; call movblk(tprev(a1), tlast(a1), prev);
smfb 366 call gbool(q1_bifnot, a1, bool1, true1, false1, lab);
smfb 367
smfb 368 prev = prog_end; call movblk(tprev(a2), tlast(a2), prev);
smfb 369 call gbool(q1_bifnot, a2, bool2, true2, false2, lab);
smfb 370
smfb 371 call emit(q1_asn, result, sym_true, 0);
smfb 372
smfb 373 countup(bsp, bstack_lim, 'bstack'); bstack(bsp) = 0;
smfb 374 bs_temp(bsp) = result; bs_false(bsp) = lab;
smfb 375
smfb 376 elseif op = sym_or then
smfb 377
smfb 378 call emit(q1_asn, result, sym_true, 0);
smfb 379
smfb 380 prev = prog_end; call movblk(tprev(a1), tlast(a1), prev);
smfb 381 call gbool(q1_bif, a1, bool1, false1, true1, lab);
smfb 382
smfb 383 prev = prog_end; call movblk(tprev(a2), tlast(a2), prev);
smfb 384 call gbool(q1_bif, a2, bool2, false2, true2, lab);
smfb 385
smfb 386 call emit(q1_asn, result, sym_false, 0);
smfb 387
smfb 388 countup(bsp, bstack_lim, 'bstack'); bstack(bsp) = 0;
smfb 389 bs_temp(bsp) = result; bs_true(bsp) = lab;
smfb 390
smfb 391 else $ op = sym_impl
smfb 392
smfb 393 call emit(q1_asn, result, sym_true, 0);
smfb 394
smfb 395 prev = prog_end; call movblk(tprev(a1), tlast(a1), prev);
smfb 396 call gbool(q1_bifnot, a1, bool1, true1, false1, lab);
smfb 397
smfb 398 prev = prog_end; call movblk(tprev(a2), tlast(a2), prev);
smfb 399 call gbool(q1_bif, a2, bool2, false2, true2, lab);
smfb 400
smfb 401 call emit(q1_asn, result, sym_false, 0);
smfb 402
smfb 403 countup(bsp, bstack_lim, 'bstack'); bstack(bsp) = 0;
smfb 404 bs_temp(bsp) = result; bs_true(bsp) = lab;
smfb 405 end if;
smfb 406
smfb 407 call deflab(lab);
smfb 408
smfb 409 tlast(result) = prog_end; push1(result);
31
32 elseif op = sym_query then
33 $ 'result := if (t2 := (t1 := a1) /= om) then t1 else a2 end'
34 if is_temp(a1) then
35 t1 = getvar(0); prev = tprev(a1);
36 call emit(q1_asn, t1, a1, 0);
37 else
38 t1 = a1; prev = prog_end;
39 end if;
40 t2 = gettmp(0);
41 call emit(q1_ne, t2, t1, sym_om); tprev(t2) = prev;
42 call gcond(t2, t1, a2);
43
44 else
45 $ try to fold the instruction
46 call fldbin(op, a1, a2, success); if (success) return;
47
48 $ emit the necessary code. if the operator is >, <=, or
49 $ subset, we begin by permuting the operands.
50
51 if op = sym_gt ! op = sym_le ! op = sym_subset then
52 swap(a1, a2);
53 end if;
54
55 result = gettmp(0);
56 call emit(opmap(op), result, a1, a2);
57 push1(result);
58
59 end if;
60
61
62 end subr gbin;
1 .=member gbool
2 subr gbool(opc, a1, bool, l1, l2, lab);
3$
4$ this routine modifies the code generated for the boolean result a1
5$ when a1 is used in an conditional branch.
6$
7 size opc(ps); $ opcode for conditional branch
8 size a1(ps); $ symtab pointer for operand
9 size bool(1); $ indicates that a1 is result of boolean
10 size l1(ps), l2(ps); $ symtab pointers for true/false labels
11 size lab(ps); $ symtab pointer for new label
12
13 size p(ps); $ codetab pointer to current instruction
14 size op(ps); $ opcode of current instruction
15
16
17 if trs_flag then $ provide trace
18 put ,skip
19 ,'entering gbool with ' :opc:a1:bool:l1:l2:lab,nil ,skip;
20 call prgdmp;
21 end if;
22
23 if bool = no then
24 call emit(opc, a1, lab, 0);
25 return;
26 end if;
27
28 p = next(tprev(a1)); $ iterate over code fragment
29 while 1;
30 if (p = 0) quit while 1;
31
32 op = opcode(p);
33 if op = q1_asn & arg1(p) = a1 then
34 if arg2(p) = sym_true ! arg2(p) = sym_false then
35 opcode(p) = q1_noop; $ delete instruction
36 else
37 call ermsg(0, a1);
38 end if;
39
40 elseif (op = q1_bif ! op = q1_bifnot) & arg2(p) = l2 then
41 arg2(p) = lab;
42
43 elseif op = q1_goto & arg1(p) = l2 then
44 arg1(p) = lab;
45
46 elseif op = q1_label then
47 if arg1(p) = l1 then
48 opcode(p) = q1_noop; $ 'undefine' label
49 is_seen(l1) = no; vptr(l1) = 0; vlen(l1) = 0;
50 elseif arg1(p) = l2 then
51 opcode(p) = q1_noop;
52 symtab(l2) = 0; $ drop dead label
53 end if;
54 end if;
55
56 if (p = tlast(a1)) quit while 1;
57
58 p = next(p);
59 end while 1;
60
61 symtab(a1) = 0; $ drop dead temporary
62
63 if l1 ^= 0 then
64 call emit(q1_goto, lab, 0, 0);
65 call deflab(l1);
66 end if;
67
68
69 end subr gbool;
1 .=member gubin
2 subr gubin;
3
4$ this routine processes calls to user defined binary operators. we
5$ reorder the arguments on astack then call gfcall.
6
7 size op(ps), $ operator
8 a1(ps), $ first argument
9 a2(ps); $ second argument
10
11 pop3(op, a2, a1);
12 push3(op, a1, a2);
13
14 call gfcall(2);
15
16
17 end subr gubin;
1 .=member gun
2 subr gun;
3
4$ this routine processes unary operators. we pop the operand and
5$ operator symbol from the stack then emit an instruction.
6
7 size op(ps), $ name of operator
8 opc(ps), $ q1 opcode
9 a1(ps), $ operand
10 temp(ps), $ result
11 success(1); $ flags successful folding
smfb 410 size p(ps); $ codetab pointer
12
13 pop2(op, a1);
14
15 if op = sym_plus then $ treat as noop
16 push1(a1);
17 return;
18 end if;
19
20$ try to fold instruction
21 call foldun(op, a1, success);
22 if (success) return;
smfb 411
smfb 412 if op = sym_not & is_temp(a1) = yes & bsp >= 1 then
smfb 413 if a1 = bs_temp(bsp) then
smfb 414
smfb 415 p = next(tprev(a1)); $ iterate over code fragment
smfb 416 while 1;
smfb 417 if (p = 0) quit while 1;
smfb 418
smfb 419 if opcode(p) = q1_asn & arg1(p) = a1 then
smfb 420 if arg2(p) = sym_true then
smfb 421 arg2(p) = sym_false;
smfb 422 elseif arg2(p) = sym_false then
smfb 423 arg2(p) = sym_true;
smfb 424 else
smfb 425 call ermsg(0, a1);
smfb 426 end if;
smfb 427 end if;
smfb 428
smfb 429 if (p = tlast(a1)) quit while 1;
smfb 430
smfb 431 p = next(p);
smfb 432 end while 1;
smfb 433
smfb 434 swap(bs_true(bsp), bs_false(bsp));
smfb 435 push1(a1);
smfb 436
smfb 437 return;
smfb 438 end if;
smfb 439 end if;
23
24 temp = gettmp(0); $ temporary for result
25
26 if op = sym_minus then
27 opc = q1_umin;
28 else
29 opc = opmap(op);
30 end if;
31
32 call emit(opc, temp, a1, 0);
33
34 push1(temp);
35
36
37 end subr gun;
1 .=member guun
2 subr guun;
3
4$ this routine processes user defined unary operators. it is
5$ similar to 'gubin'.
6
7 size op(ps), $ operator
8 arg(ps); $ argument
9
10 pop2(op, arg);
11 push2(op, arg);
12
13 call gfcall(1);
14
15
16 end subr guun;
1 .=member gnewat
2 subr gnewat;
3
4$ this routine processes 'newat'.
5
6 size t(ps); $ temp for result
7
8 t = gettmp(0);
9 call emit(q1_newat, t, 0, 0);
10
11 push1(t);
12
13
14 end subr gnewat;
1 .=member gtime
2 subr gtime;
3
4$ this routine processes the time operator
5
6size temp(ps); $ temp for result
7
8 temp = gettmp(0);
9 call emit(q1_time, temp, 0, 0);
10
11 push1(temp);
12
13
14 end subr gtime;
1 .=member gdate
2 subr gdate;
3
4$ this routine processes the date operator
5
6size temp(ps); $ temp for result
7
8 temp = gettmp(0);
9 call emit(q1_date, temp, 0, 0);
10
11 push1(temp);
12
13
14 end subr gdate;
1 .=member gna
2 subr gna;
3
4$ this routine proceses the 'number of arguments' operator
5
6 size t(ps); $ temp for result
7
8 t = gettmp(0);
9 call emit(q1_na, t, 0, 0);
10
11 push1(t);
12
13
14 end subr gna;
1 .=member gdash
2 subr gdash;
3
4$ this routine is called after seeing the expression '-'.
5
6$ according to the definition of setl, the dash can only occur
7$ in two contexts:
8
9$ 1. in a multiple assignment '[a, -] := [1, 2]'.
10$ 2. in an argument list 'y := f(x, -)'.
11
12$ it is extremely expensive to check that the dash is not used anywhere
13$ else. instead we allow it to be used in any expression and treat it
14$ as a synonym for omega.
15
16$ at this point we simply push omega. if an omega appears in the left
17$ hand side of a multiple assignment we assume that it is a substitute
18$ for a dash and ignore the assignment.
19
20 push1(sym_om);
21
22
23 end subr gdash;
1 .=member geof
2 subr geof;
3
4$ this routine handles the 'eof' operator. we simply push sym_eof
5$ then handle it like a function call with no parameters.
6
7
8 push1(sym_eof); call gfcall(0);
9
10
11 end subr geof;
1 .=member gifx1
2 subr gifx1;
3
4$ this routine is called at the start of a conditional expression.
5$ conditional expressions are treated like if-statements, with
6$ a few extra generators to assign the value of each alternative
7$ to a temporary.
8
9$ at this point we have already built a cstack entry. we allocate
10$ a temporary for the result, set its 'tprev' field to point to
11$ the last instruction, and save a pointer to it on cstack.
12
13 size temp(ps); $ temporary for result
14
15 temp = gettmp(0);
16 tprev(temp) = prog_end;
17
18 cs_temp(csp) = temp;
19
20
21 end subr gifx1;
1 .=member gifx2
2 subr gifx2;
3
4$ this routine is called after we have seen one of the alternatives
5$ in a conditional expression. we assign it to the temporary which
6$ we have saved on cstack.
7
8 size exp(ps); $ result of expression
9
10 pop1(exp);
11
12 call emit(q1_asn, cs_temp(csp), exp, 0);
13
14
15 end subr gifx2;
1 .=member gcond
2 subr gcond(e1, e2, e3);
3
4$ this routine emits 'if e1 then e2 else e3'. it does this by
5$ faking the proper sequence of calls to the 'gif' routines.
6
7$ note that before using any of the expressions e1, etc. we
8$ must move them to the end of the program.
9
10 size e1(ps), $ first expression
11 e2(ps), $ second expression
12 e3(ps); $ third expression
13
14 size targ(ps); $ target of move
15
16 call gif1; $ open if-expression
17 call gifx1;
18
19$ emit 'e1 then'
20 if is_temp(e1) then
21 targ = prog_end;
22 call movblk(tprev(e1), tlast(e1), targ);
23
24 tprev(cs_temp(csp)) = tprev(e1);
25 end if;
26
27 push1(e1);
28 call gif2;
29
30$ emit 'e2 else'
31 if is_temp(e2) then
32 targ = prog_end;
33 call movblk(tprev(e2), tlast(e2), targ);
34 end if;
35
36 push1(e2);
37 call gifx2;
38 call gif3;
39
40$ emit 'e3 end'
41 if is_temp(e3) then
42 targ = prog_end;
43 call movblk(tprev(e3), tlast(e3), targ);
44 end if;
45
46 push1(e3);
47 call gifx2;
48 call gif4;
49
50
51 end subr gcond;
1 .=member gof
2 subr gof;
3
4$ this is the top level routine for processing 't = f(x1 ... xn)'.
5$ we call lower level routines to handle two cases:
6
7$ 1. 'f' is known to be a procedure
8
9$ 2. 'f' is a procedure
10
11 size n(ps), $ number of arguments
12 f(ps); $ function/map name
13
14$ we begin by popping the number of arguments, then getting the
15$ the name of the map.
16
17 pop1(n); $ no. of arguments-1
18
19 f = astack(asp-n-1);
20
21 if is_proc(f) then
22 call gfcall(n+1);
23 else
24 call gof1(n);
25 end if;
26
27
28 end subr gof;
1 .=member gof1
2 subr gof1(n);
3
4$ this routine processes 'result := map(indx)'. at this point we
5$ know that we actually have to generate a map retrieval and not a
6$ function call.
7
8
9 size n(ps); $ number of indices minus one
10
11 size map(ps); $ symbol table pointer for map
12 size indx(ps); $ dto. for index
13 size result(ps); $ result of map retrieval
14
15
16 if n > 0 then $ form index tuple
17 push1(n); call gtup3;
18 end if;
19
20 pop2(indx, map); call chkvar(map); result = gettmp(0);
21 call emit(q1_of, result, map, indx);
22 push1(result);
23
24
25 end subr gof1;
1 .=member gfcall
2 subr gfcall(n);
3
4$ this routine emits an n-argument function call.
5
6$ setl makes no distinction between functions and subroutines.
7$ instead, every procedure returns a value. this value may be
8$ omega, and may be disgarded by the caller. the value is returned
9$ by assigning it to the name of the procedure.
10
11$ a function call is identical to a subroutine call except that it saves
12$ the returned value in a temporary. we begin by allocating a temporary
13$ and setting its tprev field. we then emit a subroutine call and assign
14$ the returned value to the temporary.
15
16 size n(ps); $ number of arguments
17
18 size j(ps), $ loop index
19 rout(ps), $ routine name
20 arg(ps), $ argument name
21 t(ps), $ result of call
22 prev(ps); $ value of tprev
23
24$ allocate a temporary then set 'prev'
25 t = gettmp(0);
26
27 prev = 0;
28
29 do j = 1 to n;
30 arg = astack(asp-n+j);
31
32 if is_temp(arg) then
33 prev = tprev(arg);
34 quit;
35 end if;
36 end do;
37
38 if (prev = 0) prev = prog_end;
39 tprev(t) = prev;
40
41$ save routine name, then emit call and assignment.
42 rout = astack(asp-n);
43
44 call gcall(n);
45 call emit(q1_asn, t, symval(rout), 0);
46
47 tlast(t) = prog_end;
48 push1(t);
49
50
51 end subr gfcall;
1 .=member gofa
2 subr gofa;
3
4$ this routine processes 'result := map<>'.
5
6
7 size map(ps); $ symbol table pointer for map
8 size indx(ps); $ dto. for index
9 size n(ps); $ number of indices minus one
10 size result(ps); $ result of map retrieval
11
12
13 if astack(asp) > 0 then $ form index tuple
14 call gtup3;
15 else
16 pop1(n);
17 end if;
18
19 pop2(indx, map); call chkvar(map); result = gettmp(0);
20 call emit(q1_ofa, result, map, indx);
21 push1(result);
22
23
24 end subr gofa;
1 .=member goft
2 fnct goft(tuple, indx);
3
4$ this routine emits 't = tuple(indx)' and returns a symbol table
5$ pointer to 't'.
6
7$ note that 'indx' is not a symbol table pointer, but an integer.
8
9 size tuple(ps), $ symtab pointer for tuple
10 indx(ps); $ value of index
11
12 size goft(ps); $ temporay returned
13
14
15 push2(tuple, getint(indx)); call gof1(0); pop1(goft);
16
17
18 end fnct goft;
1 .=member gsub1
2 subr gsub1;
3
4$ this routine emits 't = f(i ... j)'.
5
6
7 size t(ps), $ result
8 f(ps), $ tuple
9 i(ps), $ origin
10 j(ps); $ length
11
12 size a(ps); $ array of arguments
13 dims a(4);
14
15
16 pop3(j, i, f);
17
18 t = gettmp(0);
19
20 a(1) = t; $ pack arguments into 'a'
21 a(2) = f;
22 a(3) = i;
23 a(4) = j;
24
25 call emitn(q1_subst, a, 4);
26
27 push1(t);
28
29
30 end subr gsub1;
1 .=member gsub2
2 subr gsub2;
3
4$ this routine emits 't = f(i:)'.
5
6
7 size t(ps), $ result
8 f(ps), $ tuple
9 i(ps); $ origin
10 pop2(i, f);
11
12 t = gettmp(0);
13 call emit(q1_end, t, f, i);
14
15 push1(t);
16
17
18 end subr gsub2;
1 .=member gfnp
2 subr gfnp;
3
4$ this routine processes 't = f()'.
5
6 call gfcall(0);
7
8
9 end subr gfnp;
1 .=member gquant
2 subr gquant;
3
4$ this routine is called at the start of a quantifier. the basic
5$ form of a quantifier is 'exists x in s st c(x)' and is implemented
6$ as:
7$
8$ expr
9$ t := false;
10$
11$ (forall x in s st c(x)) t := true; quit forall; end;
12$
13$ yield t;
14$ end
15$
16$ we allocate a temporary 't' and initialize it to false. we then
17$ push it onto astack so we can refer to it later.
18$
19$ note that the temporary must always be backtracked.
20
21
22 size t(ps); $ temporary for result
23
24
25 t = gettmp(0); tprev(t) = prog_end; is_back(t) = yes;
26
27 call emit(q1_asn, t, sym_false, 0);
28
29 push1(t);
30
31
32 end subr gquant;
1 .=member gexist
2 subr gexist;
3
4$ this routine is called after processing an entire existential
5$ quantifier.
6
7
8 size prev(ps); $ start of loop body
9 size last(ps); $ end of loop body
10 size result(ps); $ result of quantifier
11
12
13 prev = prog_end; $ save pointer to start of loop body
14
15 pop1(result); call emit(q1_asn, result, sym_true, 0);
16 push1(1); call gquit;
17 last = prog_end; call gbody(prev, last);
18 call endlp;
19
20 tlast(result) = prog_end; push1(result);
21
22
23 end subr gexist;
1 .=member gnexst
2 subr gnexst;
3$
4$ this routine is called after seeing a complete negated existential
5$ quantifier
6$ 'notexists x in s st c(x)'
7$ we treat is as
8$ 'not exists x in s st c(x)'
9$
10 call gexist;
11
12 $ now complement the result
13 push1(sym_not); call gun;
14
15
16 end subr gnexst;
1 .=member gunivq
2 subr gunivq;
3
4$ the universal quantifier
5$ 'forall x in s st c(x)'
6$ is treated as
7$ 'not exists x in s st not c(x)'
8$
9$ at this point we have already emitted the opener for the
10$ existential quantifier. we merely negate the condition, emit the
11$ body of the existential quantifier, and finally negate the result.
smfe 10
smfe 11 push1(sym_not); call gun; call gwhere;
26
27 call gexist;
28
29 $ now compliment the result
30 push1(sym_not); call gun;
31
32
33 end subr gunivq;
1 .=member geblk1
2 subr geblk1;
3
4$ this routine is called at the start of an expression block.
5$ it builds a new cstack entry, then obtains a temporary for
6$ the result and a label for the end of the block.
7
8
9 size t(ps); $ temp for result
10
11
12 countup(csp, cstack_lim, 'cstack');
13 cstack(csp) = 0;
14 cs_type(csp) = cs_eblk;
15
16 t = gettmp(0);
17 tprev(t) = prog_end;
18
19 cs_temp(csp) = t;
20 cs_end(csp) = getlab(0);
21
22
23 end subr geblk1;
1 .=member geblk2
2 subr geblk2;
3
4$ this routine is called at the end of an expression block. we
5$ begin by defining the label for the block. we then push the
6$ result of the block onto astack and pop cstack.
7
8
9 size t(ps); $ temp for result
10
11
12 call deflab(cs_end(csp));
13
14$ push result and set tlast.
15
16 t = cs_temp(csp);
17 tlast(t) = prog_end;
18 push1(t);
19
20 csp = csp-1; $ pop cstack
21
22
23 end subr geblk2;
1 .=member gcomp1
2 subr gcomp1;
3
4$ this routine is called at the start of a compound operator.
5$ the compound operator 'op/ s' is treated as:
6
7$ expr
8$ t1 = true;
9
10$ (! t3 _ s)
11$ if t1 then $ first time through loop
12$ t1 := false;
13$ t2 := t3;
14$ else $ all other iterations
15$ t2 := t2 op t3;
16$ end if;
17$ end !;
18
19$ yield t2;
20$ end
21
22$ at this point we allocate the two temporaries and push pointers
23$ to them onto astack. we also emit code to initialize t1.
24
25 size t1(ps), $ temporaries
26 t2(ps);
27
28 call geblk1; $ open expression block
29
30 t1 = getvar(0);
31 t2 = getvar(0);
32
33 call emit(q1_asn, t1, sym_true, 0);
34 call emit(q1_asn, t2, sym_om, 0);
35
36 push2(t1, t2); $ save temporary names on stack
37
38
39 end subr gcomp1;
1 .=member gcomp2
2 subr gcomp2;
3
4$ this routine is called after seeing a compound operator of the
5$ form 'op/ [ exp: x _ s]'. this would seem to imply a double
6$ iteration, one to build the tuple and one for the compond operator.
7$ in fact we can do it in a single iteration, and avoid building the
8$ tuple.
9
10$ at this point we have already emitted the loop over s and pushed
11$ a pointer to 'exp' onto astack.
12
13$ at this point the top astack entries are:
14
15$ 1. a pointer to 'exp'. this corresponds to 't3' in gcomp1, above.
16$ 2. a pointer to 't2' (see gcomp1)
17$ 3. a pointer to 't1' (see gcomp1)
18
19$ we pop the arguments, then emit the 'if' statement given in
20$ gcomp1.
21
22 size t1(ps), $ temporaries in above setl code
23 t2(ps),
24 t3(ps),
25 exp(ps);
26
27 size t(ps); $ result of 'op'
28
29 size prev(ps), $ start of body
30 last(ps), $ end of body
31 op(ps); $ compound operator
32
33 pop3(exp, t2, t1);
34
35 prev = prog_end; $ save pointer to start of loop body
36
37 if is_temp(exp) then
38 call movblk(tprev(exp), tlast(exp), prev);
39 prev = tprev(exp);
40
41 t3 = getvar(0);
42 call emit(q1_asn, t3, exp, 0);
43
44 else
45 t3 = exp;
46 end if;
47
48 call gif1; $ emit 'if t1 then'
49
50 push1(t1);
51 call gif2;
52
53$ emit 'then' block.
54 call emit(q1_asn, t1, sym_false, 0);
55 call emit(q1_asn, t2, t3, 0);
56
57 call gif3; $ emit else block
58
59$ emit 't2 op t3'. begin by popping 'op' and seeing whether it is a
60$ system operator.
61
62 pop1(op);
63 push3(t2, t3, op);
64
65 if op <= sym_maximum then call gbin; else call gubin; end if;
66
67 pop1(t);
68 call emit(q1_asn, t2, t, 0);
69
70 call gif4; $ emit 'end if'
71
72$ install loop body
73 last = prog_end;
74
75 call gbody(prev, last);
76 call endlp;
77
78$ close expr block
79 push1(t2);
80 call gyield;
81 call geblk2;
82
83
84 end subr gcomp2;
1 .=member gcomp3
2 subr gcomp3;
3
4$ this routine is called after seeing a general compound operator
5$ 'op/ s'. it is similar to gcomp2, above.
6
7$ we begin by popping t1 and t2, then generating an iterator over
8$ s.
9
10 size s(ps), $ set being iterated over
11 t1(ps), $ temporaries above
12 t2(ps),
13 t3(ps);
14
15 size t(ps); $ result of 'op'
16
17 size prev(ps), $ start of body
18 last(ps), $ end of body
19 op(ps); $ compound operator
20
21 size gtiter(ps); $ returns iterator
22
23 pop3(s, t2, t1);
24 t3 = gtiter(s, no);
25
26$ save pointer to start of body, then open 'if' statement.
27 prev = prog_end;
28
29 call gif1;
30 push1(t1);
31 call gif2;
32
33$ emit 'then' block.
34 call emit(q1_asn, t1, sym_false, 0);
35 call emit(q1_asn, t2, t3, 0);
36
37 call gif3; $ emit else block
38
39$ emit 't2 op t3'. begin by popping 'op' and seeing whether it is a
40$ system operator.
41
42 pop1(op);
43 push3(t2, t3, op);
44
45 if op <= sym_maximum then call gbin; else call gubin; end if;
46
47 pop1(t);
48 call emit(q1_asn, t2, t, 0);
49
50 call gif4; $ emit 'end if'
51
52$ install loop body
53 last = prog_end;
54
55 call gbody(prev, last);
56 call endlp;
57
58$ close expr block
59 push1(t2);
60 call gyield;
61 call geblk2;
62
63
64 end subr gcomp3;
1 .=member gcomp4
2 subr gcomp4;
3
4$ this routine is called at the start of a compound operator.
5$ the compound operator 'result := a1 op/ a2' is treated as:
6$
7$ t1 = a1;
8$
9$ (forall t2 in a2)
10$ temp := t1 op t2; t1 := temp;
11$ end forall;
12$
13$ result := t1;
14$
15$ at this point we allocate an internal variable for t1, set it to
16$ a1, and save it on the stack. we also allocate the temporary
17$ for the final result, and save it.
18
19
20 size a1(ps); $ left operand
21 size op(ps); $ (binary) operator
22 size t1(ps); $ copy of left operand
23 size result(ps); $ temporary for result
24
25
26 pop2(op, a1); t1 = getvar(0); result = gettmp(0);
27
28 if is_temp(a1) then
29 tprev(result) = tprev(a1);
30 else
31 tprev(result) = prog_end;
32 end if;
33
34 call emit(q1_asn, t1, a1, 0);
35
36 push3(result, t1, op);
37
38
39 end subr gcomp4;
1 .=member gcomp5
2 subr gcomp5;
3
4$ this routine is called after seeing the right operand of the
5$ compound operator 'result := a1 op/ [ ]'. this
6$ construct seems to imply two iterations: the first to build the
7$ tuple, and the second over the tuple applying the operator 'op'.
8$ since the tuple is never assigned to a program variable, we can
9$ avoid building it by applying 'op' to successive components of
10$ the tuple while we execute the iterator.
11
12
13
14 size op(ps); $ <*bin> or <*bold> operator
15 size t1(ps); $ copy of left operand
16 size exp(ps); $ bound variable of
17 size temp(ps); $ temporary in 'temp := t1 op t2;'
18 size result(ps); $ temporary for result
19
20 size prev(ps); $ start of loop body
21 size last(ps); $ end of loop body
22
23
24 pop4(exp, op, t1, result);
25
26 prev = prog_end; $ save pointer to start of loop body
27
28 if is_temp(exp) then $ move into loop body
29 call movblk(tprev(exp), tlast(exp), prev);
30 prev = tprev(exp);
31 end if;
32
33 push3(t1, exp, op); $ generate 'temp := t1 op exp;'
34 if op < user_org then call gbin; else call gubin; end if;
35 pop1(temp);
36
37 call emit(q1_asn, t1, temp, 0);
38
39 last = prog_end; $ install loop body
40 call gbody(prev, last); call endlp;
41
42 call emit(q1_asn, result, t1, 0); tlast(result) = prog_end;
43 push1(result);
44
45
46 end subr gcomp5;
1 .=member gcomp6
2 subr gcomp6;
3
4$ this routine is called after seeing the right operand of the
5$ compound operator 'result := a1 op/ a2'.
6
7
8 size op(ps); $ <*bin> or <*bold> operator
9 size t1(ps); $ copy of left operand
10 size a2(ps); $ right operand
11 size t2(ps); $ bound variable for iteration over a2
12 size temp(ps); $ temporary in 'temp := t1 op t2;'
13 size result(ps); $ temporary for result
14
15 size prev(ps); $ start of loop body
16 size last(ps); $ end of loop body
17
18 size gtiter(ps); $ returns iterator
19
20
21 pop4(a2, op, t1, result);
22
23 t2 = gtiter(a2, no); $ generate iterator over right operand
24
25 prev = prog_end; $ save pointer to start of loop body
26
27 push3(t1, t2, op); $ generate 'temp := t1 op t2;'
28 if op < user_org then call gbin; else call gubin; end if;
29 pop1(temp);
30
31 call emit(q1_asn, t1, temp, 0);
32
33 last = prog_end; $ install loop body
34 call gbody(prev, last); call endlp;
35
36 call emit(q1_asn, result, t1, 0); tlast(result) = prog_end;
37 push1(result);
38
39
40 end subr gcomp6;
1 .=member gset1
2 subr gset1;
3
4$ this routine is called when we start processing an iterative
5$ set former. we allocate two temporaries, one for the result
6$ and one to count the number of elements. we then initialize
7$ the counter and push both temporaries onto the stack.
8
9
10 size result(ps), $ temp for result
11 counter(ps); $ counter
12
13
14 result = gettmp(0);
15 counter = getvar(0);
16
17 tprev(result) = prog_end;
18
19 call emit(q1_asn, counter, sym_zero, 0);
20
21 push2(counter, result);
22
23
24 end subr gset1;
1 .=member gset2
2 subr gset2;
3
4$ this routine is called at the end of a set former of the form
5
6$ << : >>
7
8$ at this point the top astack entries are and an auxiliary
9$ temporary used to count the number of set elements.
10
11$ the loop body for the set former will consist of
12
13$ 1. code for
14$ 2. an instruction to push .
15$ 3. an instruction to increment the counter.
16
17
18 size exp(ps), $ expression for set element
19 result(ps), $ temp for result
20 counter(ps); $ temp for size of set
21
22 size prev(ps), $ pointer to previous instruction
23 last(ps); $ pointer to last instruction
24
25 size temp(ps); $ temporary used for counter addition
26
27
28 pop3(exp, result, counter);
29$
30$ if is not a temporary, then generate a new temporary and assign
31$ to it. then move the code for into the loop body.
32$
33 if ^ is_temp(exp) then
34 temp = gettmp(0); tprev(temp) = prog_end;
35 call emit(q1_asn, temp, exp, 0); tlast(temp) = prog_end;
36 exp = temp;
37 end if;
38
39 call gbody(tprev(exp), tlast(exp));
40
41$ emit the push and add instructions then move them into place.
42
43 prev = prog_end;
44
45 call emit(q1_push, exp, result, 0);
46
47 temp = gettmp(0);
48 tprev(temp) = prog_end;
49
50 call emit(q1_add, temp, counter, sym_one);
51 call emit(q1_asn, counter, temp, 0);
52
53 last = prog_end;
54
55 call gbody(prev, last);
56 call endlp;
57
58$ emit setformer
59
60 call emit(q1_set1, result, exp, counter);
61
62$ fill in tlast
63
64 tlast(result) = prog_end;
65
66 push1(result);
67
68
69 end subr gset2;
1 .=member gset3
2 subr gset3;
3
4$ this routine processes enumerative setformers. we simply call
5$ a lower level routine which handles both set and tuple formers.
6
7
8 call settup(q1_set);
9
10
11 end subr gset3;
1 .=member gset4
2 subr gset4;
3
4$ this routine is called after seeing '<< >>'.
5
6 push1(sym_nullset);
7
8
9 end subr gset4;
1 .=member gtup1
2 subr gtup1;
3
4$ this routine is called at the opening of an iterative tuple
5$ former. it is equivlent to 'gset1'.
6
7 call gset1;
8
9
10 end subr gtup1;
1 .=member gtup2
2 subr gtup2;
3
4$ this routine is called at the end of an iterative tuple former.
5$ the code sequence for a tuple former is the same as that for a
6$ set former except for the opcode of the last instruction. we
7$ emit a setformer then fix the final opcode.
8
9 call gset2;
10 opcode(prog_end) = q1_tup1;
11
12
13 end subr gtup2;
1 .=member gtup3
2 subr gtup3;
3
4$ this routine processes enumerative tuple formers. it does this by
5$ calling a lower level routine.
6
7 call settup(q1_tup);
8
9
10 end subr gtup3;
1 .=member gtup4
2 subr gtup4;
3
4$ this routine is called after seeing '[]'.
5
6 push1(sym_nulltup);
7
8
9 end subr gtup4;
1 .=member settup
2 subr settup(op);
3
4$ this routine processes enumerative set and tuple formers. 'op'
5$ is either q1_set or q1_tup, indicating the instruction we are
6$ to emit. before emitting the instruction, we try constant folding.
7
8$ the top astack entries are currently:
9
10$ 1. a counter 'n'
11$ 2. n+1 set elements
12
13$ we begin by popping 'n' then calling foldst to try to constant
14$ fold the setformer. if this is successful, we return. otherwise
15$ we emit a setformer.
16
17 size op(ps); $ q1 opcode
18
19 size n(ps), $ number of elements
20 success(1), $ set by foldst
21 j(ps), $ loop index
22 org(ps), $ origin in astack
23 temp(ps); $ temp for result
24
25 size args(ps); $ array of arguments
26 dims args(nargs_lim);
27
28 pop1(n);
29 n = n + 1;
30
31 call foldst(op, n, success);
32 if (success) return;
33
34$ move elements into 'args' then call emitn.
35
36 if n >= nargs_lim then
37 call overfl('settup');
38
39 else
40 temp = gettmp(0); $ temp for result
41 args(1) = temp;
42
43 org = asp-n;
44
45 do j = 1 to n;
46 args(j+1) = astack(org+j);
47 end do;
48
49 free_stack(n);
50
51 call emitn(op, args, n+1);
52 push1(temp);
53 end if;
54
55
56 end subr settup;
1 .=member gname
2 subr gname;
3
4$ this routine is called whever a name appears in an expression.
5$ we check that we have read access to the name.
6$ declaration.
7
8 size nam(ps); $ name being processed
9
10 nam = astack(asp);
11 call chkvar(nam);
12
13
14 end subr gname;
1 .=member gcname
2 subr gcname;
3
4$ this routine is called after seeing a name in a constant
5$ expression. it is similar to gname.
6
7 size nam(ps);
8
9 nam = astack(asp);
10 call chkvar(nam);
11
12 if ^ is_const(nam) then
13 call ermsg(1, nam);
14 astack(asp) = sym_one;
15 end if;
16
17
18 end subr gcname;
1 .=member gint
2 subr gint;
3
4$ this routine is called after seeing an integer denotation. we
5$ begin by checking whether we have already declared the denotation.
6$ if so we are done. otherwise we make a val entry for it and reset
7$ its scope to the current member.
8
9 size int(ps), $ symtab pointer
10 v(ws), $ value of integer
11 fm(ps), $ form of int
12 j(ps), $ loop index
13 str(sds_sz), $ name of integer as sds
14 ch(ps); $ currnet character of name
15
16
17 int = astack(asp);
18
19 is_read(int) = yes; $ can always read a denotation
20 if (is_decl(int)) return;
21
22$ get name of denotation, then convert value.
23 str = symsds(int);
24
25 v = 0;
26
27 do j = 1 to .len. str;
28 ch = .ch. j, str;
29 v = 10 * v + digofchar(ch);
30
31 if .fb. v > ws-1 then $ overflow
32 call ermsg(31, int);
33 quit;
34 end if;
35 end do;
36
37 if v <= maxsi then fm = f_sint; else fm = f_int; end if;
38 form(int) = fm; is_decl(int) = yes; is_repr(int) = yes;
39 is_store(int) = yes;
40 countup(valp, val_lim, 'val'); val(valp) = v;
41 vptr(int) = valp; vlen(int) = 1;
42
43
44 end subr gint;
1 .=member greal
2 subr greal;
3
4$ this routine is called after seeing an real denotation. we
5$ begin by checking whether wwe have already declared the denotation.
6$ if so we are done. otherwise we make a val entry for it and reset
7$ its scope to the current member.
8
9 size r(ps); $ symtab pointer for denotation
10
11 size str(sds_sz), $ token as sds
12 len(ps), $ length of sds
13 j(ps), $ loop index
14 v(ws), $ value of real
15 expval(ws); $ exponent value
16
17 size char(ps); $ array of characters
18 dims char(toklen_lim+3);
19
20 r = astack(asp);
21
22 is_read(r) = yes; $ can always read a denotation
23 if (is_decl(r)) return;
24
25$ convert the name of the real to an array of characters, then
26$ compute its value.
27
28 str = symsds(r);
29 len = .len. str;
30
31 if len > toklen_lim then
32 call ermsg(32, r);
33 return;
34 end if;
35
36 do j = 1 to len;
37 char(j) = .ch. j, str;
38 end do;
39
40$ the actual conversion is handled by a series of assembly language
41$ routines in the little run time library. see the little system
42$ documentation for details.
43
44 call 7nvnum$io(char, len, expval);
45
46 if char(len+2) then $ bad exponent
47 call ermsg(32, r);
48 return;
49 end if;
50
51 if char(len+3) > 1 then $ point present, adjust exponent
52 expval = expval - (char(len+3) - 1);
53 end if;
54
55 call 7ncefr$io(v, char, len, expval);
56
57 if ( char(len+2)^= 0 ) call ermsg(86,r);
58
59 is_decl(r) = yes;
60 is_read(r) = yes;
61 is_repr(r) = yes;
62 is_store(r) = yes;
63
64 form(r) = f_real;
65
66 countup(valp, val_lim, 'val');
67 val(valp) = v;
68
69 vptr(r) = valp;
70 vlen(r) = 1;
71
72
73 end subr greal;
1 .=member gstr
2 subr gstr;
3
4$ this routine is called after seeing an string denotation. we
5$ begin by checking whether wwe have already declared the denotation.
6$ if so we are done. otherwise we make a val entry for it and reset
7$ its scope to the current member.
8
9 size string(ps), $ symtab pointer
10 str(sds_sz), $ string in sds form
11 words(ps), $ number of words in value
12 j(ps); $ loop index
13
14 string = astack(asp);
15
16 is_read(string) = yes; $ can always read a denotation
17 if (is_decl(string)) return;
18
19$ string values are represented in the same format as 'names' entries.
20$ however we cannot simply copy the names entry for the string,
21$ but must strip off the enclosing quotes.
22
23 str = symsds(string); $ get original string
24 str = .s. 2, .len. str-2, str; $ strip quotes
25
26 words = sorg str/ws; $ number of words in value
27
28 vptr(string) = valp+1;
29 vlen(string) = words;
30
31 do j = 0 to words-1;
32 countup(valp, val_lim, 'val');
33 val(valp) = .f. 1+j*ws, ws, str;
34 end do;
35
36 is_decl(string) = yes;
37 is_read(string) = yes;
38 is_repr(string) = yes;
39 is_store(string) = yes;
40
41 form(string) = f_string;
42
43
44 end subr gstr;
1 .=member giter1
2 subr giter1;
3
4$ this routine is called at the start of each iterator. we begin
5$ by building a new cstack entry and obtaining labels for the
6$ doing, step, and term blocks. after this we build a skeleton
7$ for the iterator as if there were empty clauses for init, doing, etc.
8$ when we encounter the actual clauses suppied by the user, we
9$ will simply insert them in the proper place.
10
11
12
13$ begin by making a cstack entry.
14 countup(csp, cstack_lim, 'cstack');
15 cstack(csp) = 0;
16 cs_type(csp) = cs_iter;
17
18$ get labels for the doing, step and term blocks.
19 cs_ldoing(csp) = getlab(0);
20 cs_lstep(csp) = getlab(0);
21 cs_lterm(csp) = getlab(0);
22 cs_lquit(csp) = getlab(0);
23
24$ create null init block
25 call emit(q1_noop, 0, 0, 0);
26 cs_init(csp) = prog_end;
27
28$ create doing block and define doing label
29 call deflab(cs_ldoing(csp));
30 cs_doing(csp) = prog_end;
31
32$ create while block
33 call emit(q1_noop, 0, 0, 0);
34 cs_while(csp) = prog_end;
35
36$ create where block
37 call emit(q1_noop, 0, 0, 0);
38 cs_where(csp) = prog_end;
39
40$ emit null body
41 call emit(q1_noop, 0, 0, 0);
42 cs_body(csp) = prog_end;
43
44$ emit step block and define step label
45 call deflab(cs_lstep(csp));
46 cs_step(csp) = prog_end;
47$
48$ create until block
49$
50 $ the until block will contain a series of statements of the
51 $ form:
52 $ if then go to term; end;
53 call emit(q1_noop, 0, 0, 0);
54 cs_until(csp) = prog_end;
55
56$ emit 'go to doing block' followed by term label
57 call emit(q1_goto, cs_ldoing(csp), 0, 0);
58
59 call deflab(cs_lterm(csp));
60 cs_term(csp) = prog_end;
61
62$
63$ define label for quit statements
64$
65 $ note that this label does not define another block.
66 call deflab(cs_lquit(csp));
67
68 if trs_flag then $ dump cstack
69 put, skip, 'exiting gloop at stmt ': stmt_count, i, skip;
70 call csdump;
71 end if;
72
73
74 end subr giter1;
1 .=member giter2
2 subr giter2;
3
4$ this routine is called just before seeing a , i.e.
5$ a sequence ', '. the code for each must
6$ be placed inside the body of the surrounding iterator.
7$ in order to do this, we must save a code pointer to the
8$ start of the .
9
10 push1(prog_end);
11
12
13 end subr giter2;
1 .=member giter3
2 subr giter3;
3
4$ this routine is called after seeing a , i.e. an
5$ inner loop in a compound iterator. we move the code for the
6$ iterator into the body of the outer iterator and reset
7$ the type of its cstack entry.
8
9 size prev(ps), $ previous instruction
10 last(ps); $ last instruction
11
12 pop1(prev);
13 last = prog_end;
14
15$ move iterator
16 call movblk(prev, last, cs_body(csp-1));
17 cs_body(csp-1) = last;
18
19
20 cs_type(csp) = cs_citer; $ reset type
21
22
23 end subr giter3;
1 .=member ginit1
2 subr ginit1;
3
4$ this routine is called at the start of an init block.
5$ we save a pointer to the start of the block on astack.
6
7 push1(prog_end);
8
9
10 end subr ginit1;
1 .=member ginit2
2 subr ginit2;
3
4$ this routine is called after seeing an init block.
5$ we simply move the block into place.
6
7 size prev(ps), $ start of block
8 last(ps); $ end of block
9
10 pop1(prev);
11 last = prog_end;
12
13 if (prev = last) return; $ null block
14
15 call movblk(prev, last, cs_init(csp));
16 cs_init(csp) = last;
17
18
19 end subr ginit2;
1 .=member ginit3
2 subr ginit3(exp);
3
4$ this routine moves the code for an expression into the init block of
5$ the current loop.
6
7 size exp(ps); $ temporary yielded by expression
8
9 size prev(ps), $ its tprev
10 last(ps), $ its tlast
11 p(ps); $ pointer to init block
12
13 if (^ is_temp(exp)) return; $ not expression
14
15 prev = tprev(exp);
16 last = tlast(exp);
17 p = cs_init(csp);
18
19 call movblk(prev, last, p);
20
21 cs_init(csp) = last; $ reset end of ini block
22
23
24 end subr ginit3;
1 .=member gdng1
2 subr gdng1;
3
4$ this routine is called at the start of a doing block. it is similar
5$ to ginit1
6
7 push1(prog_end);
8
9
10 end subr gdng1;
1 .=member gdng2
2 subr gdng2;
3
4$ this routine is called after seeing a doing block. it is similar to
5$ ginit2.
6
7 size prev(ps), $ pointer to start of block
8 last(ps);
9
10 pop1(prev);
11 last = prog_end;
12
13 if (prev = last) return; $ null block
14
15 call movblk(prev, last, cs_doing(csp));
16 cs_doing(csp) = last;
17
18
19 end subr gdng2;
1 .=member gwhile
2 subr gwhile;
3
4$ this routine is called after seeing 'while exp'.
5$ we move the expresion into place and insert a test.
6
smfe 12 size exp(ps); $ symtab pointer for expression
smfe 13 size prev(ps); $ pointer to start of block
smfe 14 size last(ps); $ pointer to end of block
smfe 15 size true1(ps); $ true label for boolean expression
smfe 16 size false1(ps); $ false label for boolean expression
smfe 17 size lab(ps); $ step label
9
smfe 18
10 pop1(exp);
11
smfe 19 prev = prog_end;
smfe 20 lab = cs_lterm(csp);
smfe 21
smfe 22 until 1;
smfe 23 until 2;
smfe 24 if (is_temp(exp) = no) quit until 2;
smfe 25
smfe 26 call movblk(tprev(exp), tlast(exp), prev);
smfe 27 prev = tprev(exp);
smfe 28
smfe 29 if (bsp = 0) quit until 2;
smfe 30 if (exp ^= bs_temp(bsp)) quit until 2;
smfe 31
smfe 32 true1 = bs_true(bsp); false1 = bs_false(bsp);
smfe 33 call gbool(q1_ifnot, exp, yes, true1, false1, lab);
smfe 34 bsp = bsp - 1;
smfe 35
smfe 36 quit until 1;
smfe 37
smfe 38 end until 2;
smfe 39
smfe 40 call emit(q1_ifnot, exp, lab, 0);
smfe 41
smfe 42 end until 1;
smfe 43
smfe 44 last = prog_end; call movblk(prev, last, cs_while(csp));
smfe 45 cs_while(csp) = last;
21
22
23 end subr gwhile;
1 .=member gwhere
2 subr gwhere;
3
4$ this routine is called after seeing 'where exp'.
5$ it is similar to gwhile.
6
smfe 46 size exp(ps); $ symtab pointer for expression
smfe 47 size prev(ps); $ pointer to start of block
smfe 48 size last(ps); $ pointer to end of block
smfe 49 size true1(ps); $ true label for boolean expression
smfe 50 size false1(ps); $ false label for boolean expression
smfe 51 size lab(ps); $ step label
9
smfe 52
10 pop1(exp);
11
smfe 53 prev = prog_end;
smfe 54 lab = cs_lstep(csp);
smfe 55
smfe 56 until 1;
smfe 57 until 2;
smfe 58 if (is_temp(exp) = no) quit until 2;
smfe 59
smfe 60 call movblk(tprev(exp), tlast(exp), prev);
smfe 61 prev = tprev(exp);
smfe 62
smfe 63 if (bsp = 0) quit until 2;
smfe 64 if (exp ^= bs_temp(bsp)) quit until 2;
smfe 65
smfe 66 true1 = bs_true(bsp); false1 = bs_false(bsp);
smfe 67 call gbool(q1_ifnot, exp, yes, true1, false1, lab);
smfe 68 bsp = bsp - 1;
smfe 69
smfe 70 quit until 1;
smfe 71
smfe 72 end until 2;
smfe 73
smfe 74 call emit(q1_ifnot, exp, lab, 0);
smfe 75
smfe 76 end until 1;
smfe 77
smfe 78 last = prog_end; call movblk(prev, last, cs_where(csp));
smfe 79 cs_where(csp) = last;
21
22
23 end subr gwhere;
1 .=member gbody
2 subr gbody(prev, last);
3
4$ this routine inserts a block of code into the loop body.
5$ we simply move the block to the end of the body clause.
6
7 size prev(ps), $ pointer to start of block to be moved
8 last(ps); $ pointer to end of block
9
10 size p(ps); $ pointer to end of body
11
12
13 p = cs_body(csp);
14
15 call movblk(prev, last, p);
16 cs_body(csp) = last;
17
18
19 end subr gbody;
1 .=member gstep1
2 subr gstep1;
3
4$ this routine is called at the start of a step block. it is similar
5$ to ginit1
6
7
8 push1(prog_end);
9
10
11 end subr gstep1;
1 .=member gstep2
2 subr gstep2;
3
4$ this routine is called after seeing a step block. it is similar to
5$ ginit2.
6
7
8 size prev(ps), $ pointer to start of block
9 last(ps); $ pointer to end of block
10
11
12 pop1(prev);
13 last = prog_end;
14
15 if (prev = last) return; $ null block
16
17 call movblk(prev, last, cs_step(csp));
18 cs_step(csp) = last;
19
20
21 end subr gstep2;
1 .=member guntil
2 subr guntil;
3
4$ this routine is called after seeing 'until exp'.
5$ it is similar to gwhile.
6
smfe 80 size exp(ps); $ symtab pointer for expression
smfe 81 size prev(ps); $ pointer to start of block
smfe 82 size last(ps); $ pointer to end of block
smfe 83 size true1(ps); $ true label for boolean expression
smfe 84 size false1(ps); $ false label for boolean expression
smfe 85 size lab(ps); $ step label
10
11
12 pop1(exp);
13
smfe 86 prev = prog_end;
smfe 87 lab = cs_lterm(csp);
smfe 88
smfe 89 until 1;
smfe 90 until 2;
smfe 91 if (is_temp(exp) = no) quit until 2;
smfe 92
smfe 93 call movblk(tprev(exp), tlast(exp), prev);
smfe 94 prev = tprev(exp);
smfe 95
smfe 96 if (bsp = 0) quit until 2;
smfe 97 if (exp ^= bs_temp(bsp)) quit until 2;
smfe 98
smfe 99 true1 = bs_true(bsp); false1 = bs_false(bsp);
smfe 100 call gbool(q1_if, exp, yes, true1, false1, lab);
smfe 101 bsp = bsp - 1;
smfe 102
smfe 103 quit until 1;
smfe 104
smfe 105 end until 2;
smfe 106
smfe 107 call emit(q1_if, exp, lab, 0);
smfe 108
smfe 109 end until 1;
smfe 110
smfe 111 last = prog_end; call movblk(prev, last, cs_until(csp));
smfe 112 cs_until(csp) = last;
23
24
25 end subr guntil;
1 .=member gterm1
2 subr gterm1;
3
4$ this routine is called at the start of a term block. it is similar
5$ to ginit1
6
7
8 push1(prog_end);
9
10
11 end subr gterm1;
1 .=member gterm2
2 subr gterm2;
3
4$ this routine is called after seeing a term block. it is similar to
5$ ginit2.
6
7
8 size prev(ps), $ pointer to start of block
9 last(ps); $ pointer to end of block
10
11
12 pop1(prev);
13 last = prog_end;
14
15 if (prev = last) return; $ null block
16
17 call movblk(prev, last, cs_term(csp));
18 cs_term(csp) = last;
19
20
21 end subr gterm2;
1 .=member endlp
2 subr endlp;
3
4$ this routine pops the cstack entries for a compound iterator.
5
6
7 while cs_type(csp) = cs_citer; $ pop the inner loops
8 csp = csp-1;
9 end while;
10
11 csp = csp - 1; $ pop the outer loop
12
13
14 end subr endlp;
1 .=member garith
2 subr garith;
3
4$ this routine processes arithmetic iterators. the iterator
smfb 440$ 'i in [ e1, e2 .. e3 ]' is treated as:
6$
smfb 441$ init i := t1 := e1;
smfb 442$ t2 := e2-t1;
9$ t3 := e3;
10$
smfb 443$ while t1 <= t3
12$
smfb 444$ step temp := t1 + t2;
smfb 445$ i := t1 := temp;
15$
16$ term i := om;
17$
18$ note that 'i' is a variable, not a general left hand side.
19$
20$ if the user has seleted the 'diter' control card option, we suppress
21$ the internal variables.
22
23
24 size i(ps); $ bound variable
25 size e1(ps); $ initial value
26 size e2(ps); $ second value
27 size e3(ps); $ final value
28
smfb 446 size t1(ps); $ shadow variable for 'i'
smfb 447 size t2(ps); $ temporary for increment
31 size t3(ps); $ shadow variable for e3
32 size t4(ps); $ temporaries used in while test
33 size t5(ps);
34 size t6(ps);
35 size temp(ps); $ temporary used in step
36
37 size op(ps); $ comparison operator
38 size v(ps); $ value of increment
39
40 size prev(ps); $ pointer to start of code block
41 size last(ps); $ pointer to end of code block
42
43 size fndinc(ps); $ function to find increment
44
45
46 pop4(e3, e2, e1, i);
47
48 if bvar_flag then $ save bound variable
49 if is_temp(i) then
50 cs_bvar(csp) = copy(i);
51 else
52 cs_bvar(csp) = i;
53 end if;
54 end if;
smfb 448$
smfb 449$ emit init block
smfb 450$
smfb 451$ - emit the code for 'i := t1 := e1;'.
smfb 452$
smfb 453 if diter_flag & (form(i) = f_int ! form(i) = f_gen) then
smfb 454 t1 = i;
smfb 455 else
smfb 456 t1 = getvar(0); is_back(t1) = yes;
smfb 457 if is_fint(form(i)) then
smfb 458 form(t1) = form(i); is_repr(t1) = yes;
smfb 459 end if;
smfb 460 end if;
smfb 461
smfb 462 call ginit3(e1); $ move e1 into the init block
smfb 463
smfb 464 prev = prog_end;
smfb 465 call emit(q1_asn, t1, e1, 0); $ emit initialisation
smfb 466 if (i ^= t1) call emit(q1_asn, i, t1, 0);
smfb 467 last = prog_end;
smfb 468 call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 469$
smfb 470$ - emit 't2 = e2 - e1'. note that we use t1 instead of e1 in the
smfb 471$ code emitted.
smfb 472$
smfb 473 $ note that e2 may not be present in the user's program.
smfb 474 if (e2 ^= 0) call ginit3(e2); $ move e2 into the init block
smfb 475
smfb 476 $ note that fndinc might generate code; also note that fndinc
smfb 477 $ might delete the code for e2. for this reason we emit a no-op
smfb 478 $ here to make sure that the code fragment for e2 is neither at
smfb 479 $ the end of the program nor at the end of the init block.
smfb 480 prev = prog_end; call emit(q1_noop, 0, 0, 0); last = prog_end;
smfb 481 call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 482
smfb 483 prev = prog_end;
smfb 484
smfb 485 t2 = fndinc(t1, e1, e2); $ find the increment
smfb 486
smfb 487 if t2 = sym_zero then
smfb 488 call emit(q1_goto, cs_lterm(csp), 0, 0);
smfb 489 elseif ^ is_const(t2) then
smfb 490 push3(t2, sym_zero, sym_eq); call gbin; pop1(temp);
smfb 491 call emit(q1_if, temp, cs_lterm(csp), 0);
smfb 492 end if;
smfb 493
smfb 494 if prev ^= prog_end then
smfb 495 last = prog_end;
smfb 496 call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 497 end if;
smfb 498$
smfb 499$ - emit the code for 't3 := e3;'.
smfb 500$
smfb 501 if is_const(e3) then
smfb 502 if ( ^ is_fint(ft_deref(form(e3)))) call ermsg(17, e3);
smfb 503 t3 = e3;
smfb 504 else
smfb 505 t3 = getvar(0); is_back(t3) = yes;
smfb 506 if is_fint(form(e3)) then
smfb 507 form(t3) = form(e3); is_repr(t3) = yes;
smfb 508 end if;
smfb 509
smfb 510 call ginit3(e3); $ move e3 into the init block
smfb 511 prev = prog_end;
smfb 512 call emit(q1_asn, t3, e3, 0); last = prog_end;
smfb 513 call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 514 end if;
106
107$ emit the 'while' test. there are several possibilities:
108
109$ 1. no upper bound is given(e3 = 0). dont emit any test.
110
111$ 2. the increment, namely t1, is constant. if t1 is positive, we
112$ emit 'while i <= t3'; otherwise we emit 'while i >= t3'.
113
114$ 3. the increment is a variable. we emit 'while if t1 >= 0 then
115$ i <= t3 else i >= t3'.
116
117 if e3 = 0 then
118 push1(sym_one)
119
smfb 515 elseif is_const(t2) then $ constant increment
121
smfb 516 v = symval(t2); $ look at sign of increment
smfb 517 if v > 0 then op = sym_le; else op = sym_ge; end if;
smfb 518 push3(t1, t3, op); call gbin; $ emit comparison
132
133 else
134 $ (
smfb 519 $ t4 := (t2 >= 0);
smfb 520 $ t5 := (t1 <= t3);
smfb 521 $ t6 := (t1 >= t3);
138 $ if t4 then t5 else t6
139 $ )
smfb 522 t4 = gettmp(0); call emit(q1_pos, t4, t2, sym_zero);
smfb 523 t5 = gettmp(0); call emit(q1_ge, t5, t3, t1);
smfb 524 t6 = gettmp(0); call emit(q1_ge, t6, t1, t3);
143 call gcond(t4, t5, t6);
144 end if;
145
146 call gwhile;
147$
148$ emit step block
149$
150 prev = prog_end;
151
smfb 525 push3(t1, t2, sym_plus); call gbin; pop1(temp);
153
smfb 526 call emit(q1_asn, t1, temp, 0);
smfb 527 if (i ^= t1) call emit(q1_asn, i, t1, 0);
156
157 last = prog_end;
158 call movblk(prev, last, cs_step(csp));
159 cs_step(csp) = last;
160$
161$ emit term block
162$
163 prev = prog_end;
164 call emit(q1_asn, i, sym_om, 0);
165 last = prog_end;
166 call movblk(prev, last, cs_term(csp));
167 cs_term(csp) = last;
168
169
170 end subr garith;
1 .=member fndinc
2 fnct fndinc(var, e1, e2);
3
4$ this routine finds the increment in an iterator (! i := e1, e2, ...)
5$ there are two possibilities:
6
7$ 1. e1 and e2 differ by a constant. this will occur in cases such
8$ as (! i := ? s, ? s-1 ... 1). in this case we can return the
9$ constant -1.
10
11$ 2. otherwise we must emit code to calculate the increment at
12$ run time.
13
14$ note that in case(2), e1 will be used twice: once to initialize
15$ 'i' and once to calculate the increment. this violates a basic
16$ assumption of the compiler, namely that each temporary is only
17$ used once.
18
19$ in order to avoid this problem we emit an assignment
20$ 'internal variable := e1' before calling fndinc. if
21$ it proves necessary to emit a code to find the increment
22$ we will use this variable rather than e1.
23
24$ the reason we pass both 'var' and 'e1' as arguments to
25$ fndinc is that it is necessary to walk the code fragment
26$ of e1 and compare it with the code fragment of e2.
27
28$ we begin by looking for three special cases:
29
30$ (1) i := e1 ....
31
32$ (2) i := e1, e1+n, ....
33
34$ (3) i := e1, e1-n, ...
35
36$ where n is an integer constant. case (1) is identified by e2 = 0.
37
38$ note that findinc returns either a constant or an internal
39$ variable, never a temporary.
40
41 size var(ps), $ internal variable := e1
42 e1(ps), $ initial value
43 e2(ps); $ second value
smfb 528 size v1(ws), v2(ws); $ values of integer constants
smfb 529 size v(ws); $ value of integer constant
44
45 size fndinc(ps); $ temp or constant returned
46
smfb 530 size i1(ps); $ instruction for e1
smfb 531 size op1(ps); $ operator of e1
smfb 532 size a2(ps), a3(ps); $ operands of e1
smfb 533 size i2(ps); $ instruction for e2
smfb 534 size op2(ps); $ operator of e2
smfb 535 size b2(ps), b3(ps); $ operands of e2
52
53 size t(ps); $ result of subtraction
54
55 size eqexp(1); $ compares two expressions for equality
56 size getint(ps); $ returns symtab pointer for integer const
57
58 if e2 = 0 then $ increment is 1.
59 fndinc = sym_one;
60 return;
61
62 elseif is_temp(e2) then $ might be e1+ or e1-.
smfb 536
smfb 537 i2 = tlast(e2); op2 = opcode(i2);
smfb 538 b2 = arg2(i2); b3 = arg3(i2);
smfb 539
smfb 540 if (op2 = q1_add ! op2 = q1_sub) & is_const(b3) then
smfb 541 if ( ^ is_fint(ft_deref(form(b3)))) call ermsg(17, b3);
smfb 542
smfb 543 if eqexp(e1, b2) then
smfb 544 call killex(e2);
smfb 545 if op2 = q1_add then
smfb 546 fndinc = b3;
smfb 547 else
smfb 548 v = symval(b3); fndinc = getint(-v);
smfb 549 end if;
smfb 550 return;
smfb 551 end if;
smfb 552
smfb 553 if is_temp(e1) then
smfb 554
smfb 555 i1 = tlast(e1); op1 = opcode(i1);
smfb 556 a2 = arg2(i1); a3 = arg3(i1);
smfb 557
smfb 558 if (op1 = q1_add ! op1 = q1_sub) &
smfb 559 is_const(a3) & eqexp(a2, b2) then
smfb 560 if ^ is_fint(ft_deref(form(a3))) then
smfb 561 call ermsg(17, a3);
smfb 562 end if;
smfb 563 call killex(e2);
smfb 564 v1 = symval(a3); v2 = symval(b3);
smfb 565 if op1 = op2 then v = v1-v2; else v = v1+v2; end;
smfb 566
smfb 567 if op1 = q1_add then
smfb 568 fndinc = getint(-v);
smfb 569 else
smfb 570 fndinc = getint(v);
smfb 571 end if;
smfb 572 return;
smfb 573 end if;
smfb 574 end if;
smfb 575 end if;
smfb 576
smfb 577 elseif is_const(e1) & is_const(e2) then
smfb 578 if ( ^ is_fint(ft_deref(form(e1)))) call ermsg(17, e1);
smfb 579 if ( ^ is_fint(ft_deref(form(e2)))) call ermsg(17, e2);
smfb 580 v1 = symval(e1); v2 = symval(e2); fndinc = getint(v2-v1);
smfb 581 return;
82 end if;
83
84$ otherwise call gbin to emit 'e2-e1'. gbin will return a constant
85$ or a temporary. in the latter case we assign it to an internal
86$ variable.
87
88 push3(e2, var, sym_minus); call gbin; pop1(t);
89
90 if is_temp(t) then
91 fndinc = getvar(0); is_back(fndinc) = yes;
92 call emit(q1_asn, fndinc, t, 0);
93 else
94 fndinc = t;
95 end if;
96
97
98 end fnct fndinc;
1 .=member gnonam
2 subr gnonam;
3
4$ this routine is called at the start of an iterator such as
5$ '1 ... n'. we supply a temporary for the bound variable.
6
7$ note that we must clear the temporaries 'is_temp' bit so that
8$ it looks like a variable when we make assignments to it.
9
10 size t(ps); $ temp used as bound variable
11
12 t = getvar(0);
13 is_back(t) = yes;
14
15 push1(t);
16
17 return;
18
19 end subr gnonam;
1 .=member gnolow
2 subr gnolow;
3
4$ this routine supplies the default lower bound for an arithmetic
5$ iterator.
6
7 push1(sym_one);
8 call gnostp;
9
10 return;
11
12 end subr gnolow;
1 .=member gnostp
2 subr gnostp;
3
4$ this routine is called when the second expression in an arithmetic
5$ iterator is missing. we push a zero onto the stack.
6
7 push1(0);
8 return;
9
10 end subr gnostp;
1 .=member gseti
2 subr gseti;
3
4$ this routine processes set iterators. the iterator 'x in s' is
5$ treated as:
6$
7$ init t1 := s;
8$ inext(t2, t3, t1);
9$
10$ doing next(t2, t3, t1);
11$ if t3 = om then go to term; end;
12$ x := t2;
13$
14$
15$
16$ term: t1 := om;
17$ x := om;
18$
19$ as with arithmetic iterators, the code is simplified if the user
20$ has selected the 'diter' control card option.
21
22
23 size s(ps); $ set being iterated over
24 size x(ps); $ element of s
25 size x_term(ps); $ copy of code fragment for x
26
27 size t1(ps); $ shadow variable for s
28 size t2(ps); $ shadow variable for x
29 size t3(ps); $ extra temporary needed by 'next'
30 size t4(ps); $ temporary for omega test
31
32 size prev(ps); $ pointer to start of code block
33 size last(ps); $ pointer to end of code block
34
35
36 pop2(s, x);
37
38 if bvar_flag then $ save bound variable
39 if is_temp(x) then
40 cs_bvar(csp) = copy(x);
41 else
42 cs_bvar(csp) = x;
43 end if;
44 end if;
45
46 $ if x is a temporary, it must be of the form [x1, ..., xn].
47 $ to be able to assign omega to the xi, we need a copy of the
48 $ code fragment for x. get it before the call to gasn in the
49 $ doing block destroys it.
50 if is_temp(x) then x_term = copy(x); else x_term = x; end if;
51
52 if diter_flag & ^ is_temp(s) then $ use 's' directly
53 t1 = s;
54 else
55 t1 = getvar(0); is_back(t1) = yes;
56 end if;
57
58 if diter_flag
59 & ^ is_temp(x)
60 & (form(x) = ft_elmt(form(s)) ! form(x) = f_gen) then
61
62 t2 = x;
63 else
64 t2 = getvar(0); is_back(t2) = yes;
65 end if;
66
67 t3 = getvar(0); is_back(t3) = yes;
68
69 $ if s is an expression, we must move the code for it into
70 $ the init block.
71 call ginit3(s);
72$
73$ emit init block
74$
75 prev = prog_end;
76
77 if (t1 ^= s) call emit(q1_asn, t1, s, 0);
78 call emit(q1_inext, t2, t3, t1);
79
80 last = prog_end;
81 call movblk(prev, last, cs_init(csp));
82 cs_init(csp) = last;
83$
84$ emit doing block
85$
86 prev = prog_end;
87
88 call emit(q1_next, t2, t3, t1);
89
90 $ emit test for omega
91 push3(t3, sym_om, sym_eq); call gbin;
92 pop1(t4); call emit(q1_if, t4, cs_lterm(csp), 0);
93
94 if (t2 ^= x) call gasn(x, t2, no);
95
96 $ move doing block into place
97 last = prog_end;
98 call movblk(prev, last, cs_doing(csp));
99 cs_doing(csp) = last;
100$
101$ emit term block
102$
103 prev = prog_end;
104
105 if (t1 ^= s) call emit(q1_asn, t1, sym_om, 0);
106 if (t2 ^= x_term) call gasn(x_term, sym_om, yes);
107
108 last = prog_end;
109 call movblk(prev, last, cs_term(csp));
110 cs_term(csp) = last;
111
112
113 end subr gseti;
1 .=member gdomi1
2 subr gdomi1;
3
4$ this routine generates the iterator 'y := f(x1 ... xn)'
5
6 call gdomi(no);
7 return;
8
9 end subr gdomi1;
1 .=member gdomi2
2 subr gdomi2;
3
4$ this routine generates the iterator 'y := f<>'
5
6 call gdomi(yes);
7 return;
8
9 end subr gdomi2;
1 .=member gdomi
2 subr gdomi(c);
3
4$ this is the main routine for processing domain iterators.
5$
6$ the parameter 'c' indicates whether we process 'y = f(x0, ..., xn)'
7$ or 'y = f<>'.
8$
9$ we treat (forall y = f(x)) as a short form for:
10$
11$ init t1 = f;
12$ inextd(t3, t2, t1);
13$
14$ doing nextd(t3, t2, t1);
15$ if t2 = om then go to term; end;
16$ t4 := t1(t3);
17$ y := t4;
18$
19$ if we generate code for 'y = f(x)', we have to assign
20$
21$ x := t3;
22$
23$ otherwise we generate
24$
25$ [x1, ..., xn] = t3;
26$
27$
28$
29$ term: t1 := om;
30$ x := om;
31$ y := om;
32
33
34 size c(1); $ flags iterator 'y = f<>'
35
36 size n(ps); $ number of domain indices minus one
37 size f(ps); $ the map we iterate over
38 size y(ps); $ map range
39 size y_term(ps); $ copy of code fragment for y
40 size x(ps); $ map domain
41 size x_term(ps); $ copy of code fragment for x
42 size t1(ps); $ shadow variable for 'f'
43 size t2(ps); $ iterator-format pointer
44 size t3(ps); $ domain element of 'f'
45 size t4(ps); $ range element of 'f'
46 size prev(ps); $ pointer to start of init/doing block
47 size last(ps); $ pointer to end of init/doing block
48
49
50 pop1(n);
51
52 f = astack(asp-n-1);
53 y = astack(asp-n-2);
54
55 $ if y is a temporary, it must be of the form [y1, ..., yn].
56 $ to be able to assign omega to the yi, we need a copy of the
57 $ code fragment for y. get it before the call to gasn in the
58 $ doing block destroys it.
59 if is_temp(y) then y_term = copy(y); else y_term = y; end if;
60
61 $ if 'f' is an expression, we must move the code for it into
62 $ the init block.
63 if (is_temp(f)) call ginit3(f);
64
65 $ get a shadow variable for 'f' if necessary.
66 if diter_flag & ^ is_temp(f) then
67 t1 = f;
68 else
69 t1 = getvar(0); is_back(t1) = yes;
70 end if;
71
72 t2 = getvar(0); is_back(t2) = yes;
73 t3 = getvar(0); is_back(t3) = yes;
74$
75$ emit init block
76$
77 prev = prog_end;
78
79 if (t1 ^= f) call emit(q1_asn, t1, f, 0);
80 call emit(q1_inextd, t3, t2, t1);
81
82 last = prog_end;
83 call movblk(prev, last, cs_init(csp));
84 cs_init(csp) = last;
85$
86$ emit doing block
87$
88 prev = prog_end;
89
90 call emit(q1_nextd, t3, t2, t1);
91
92 $ emit test for omega
93 push3(t2, sym_om, sym_eq); call gbin;
94 pop1(t4); call emit(q1_if, t4, cs_lterm(csp), 0);
95
96 $ emit range retrieval
97 push3(t1, t3, 0);
98 if c then call gofa; else call gof; end if;
99 pop1(t4); call gasn(y, t4, no);
100
101 $ emit domain retrievals and assignments
102 if n > 0 then
103 push1(n); call gtup3;
104 end if;
105
106 pop1(x);
107
108 $ if x is a temporary, it must be of the form [x1, ..., xn].
109 $ to be able to assign omega to the xi, we need a copy of the
110 $ code fragment for x. get it before the following call to
111 $ gasn destroys it.
112 if is_temp(x) then x_term = copy(x); else x_term = x; end if;
113
114 call gasn(x, t3, no);
115
116 $ move doing block into place
117 last = prog_end;
118 call movblk(prev, last, cs_doing(csp));
119 cs_doing(csp) = last;
120$
121$ emit term block
122$
123 prev = prog_end;
124
125 if(t1 ^= f) call emit(q1_asn, t1, sym_om, 0);
126
127 call gasn(x_term, sym_om, yes);
128 call gasn(y_term, sym_om, yes);
129
130 last = prog_end;
131 call movblk(prev, last, cs_term(csp));
132 cs_term(csp) = last;
133
134 free_stack(2); $ 'f' and 'y'
135
136
137 end subr gdomi;
1 .=member gbvar1
2 subr gbvar1;
3
4$ this routine is called before the iterator in << x in s st c(x) >>.
5$ we set bvar_flag to indicate that it is necessary to save the
6$ bound variable 'x'.
7
8 push1(bvar_flag); $ save old value
9
10 bvar_flag = yes;
11
12
13 end subr gbvar1;
1 .=member gbvar2
2 subr gbvar2;
3
4$ this routine is called after seeing the iterator in
5$ << x in s st c(x) >>. we check that the iterator had a bound
6$variable, and then push it onto the stack.
7
8 size bvar(ps); $ bound variable
9
10 bvar = cs_bvar(csp);
11
12 if bvar = 0 then
13 call ermsg(33, 0);
14 bvar = sym_one;
15 end if;
16
17 pop1(bvar_flag);
18 push1(bvar);
19
20
21 end subr gbvar2;
1 .=member gtiter
2 fnct gtiter(s, citer);
3
4$ this routine opens an iterator '(! t _ s)' and returns a pointer
5$ to 't'.
6
7$ 'citer' flags a
8
9$ we begin by allocating 't', then setting its is_temp flag to 0.
10$ this is necessary so that assignments to t will be done as simple
11$ assignments.
12
13 size s(ps), $ set we are iterating over
14 citer(1); $ flags in grammar
15
16 size gtiter(ps); $ bound variable returrned
17
18 gtiter = getvar(0);
19
20$ emit iterator
21
22 if (citer) call giter2;
23 call giter1;
24
25 cs_internal(csp) = yes;
26
27 push2(gtiter, s);
28 call gseti;
29
30 if (citer) call giter3;
31
32 return;
33
34 end fnct gtiter;
1 .=member fldbin
2 subr fldbin(op, a1, a2, success);
3
4$ this routine attempts to constant fold 'a1 op a2', and sets
5$ 'success' to indicate whether it was successful.
6
7$ if we are successful, we push the result on astack.
8
9$ for the moment the only operations we fold are +, -, *,
10$ /, and mod on integers whose 'val' entries are only one
11$ word.
12
13$ op, a1, and a2 are all symbol table pointers.
14
15 size op(ps); $ operator name
16 size a1(ps), a2(ps); $ operands
17 size success(1); $ indicates successful folding
18
19 size f1(ps), f2(ps); $ operand forms
20 size j(ps); $ loop index
21 size len(ps); $ length of string result
22 size l1(ps), l2(ps); $ lengths of val entries, then of strings
23 size p1(ps), p2(ps); $ pointers to val entries
24 size s1(sds_sz); $ string values
25 size s2(sds_sz);
26 size str(sds_sz);
27 size t(ps); $ symbol table pointer for result
28 size v1(ws); $ integer values
29 size v2(ws);
30 real r1, r2; $ real values
31
32
33 success = no; $ assume failure
34
35 if ( ^ is_const(a1)) return;
36 if ( ^ is_const(a2)) return;
37
38 f1 = form(a1); f2 = form(a2);
39
40 if is_fstr(f1) & is_fstr(f2) then
41 if op = sym_plus then
42 l1 = vlen(a1); l2 = vlen(a2);
43 p1 = vptr(a1); p2 = vptr(a2);
44 do j = 0 to l1-1; .f. 1+j*ws, ws, s1 = val(p1+j); end;
45 do j = 0 to l2-1; .f. 1+j*ws, ws, s2 = val(p2+j); end;
46 l1 = slen s1; l2 = slen s2;
47 len = l1 + l2 + 2; if (len > toklen_lim) return;
48 str = 0; slen str = len; sorg str = .sds. len + 1;
49 .ch. 1, str = 1r'; .ch. len, str = 1r';
50 do j = 1 to l1; .ch. 1+j, str = .ch. j, s1; end do;
51 do j = 1 to l2; .ch. 1+l1+j, str = .ch. j, s2; end do;
52 push1(hashst(str)); call gstr; is_read(astack(asp)) = yes;
53 success = yes;
54 end if;
55
56
57 elseif is_fint(f1) & is_fint(f2) then
58 if ( ^ (sym_plus <= op & op <= sym_mod)) return;
59 v1 = symval(a1); v2 = symval(a2);
60 assert vlen(a1) = 1; assert vlen(a2) = 1;
61
62 go to icase(op) in sym_plus to sym_mod;
63
64 /icase(sym_plus)/ v1 = v1 + v2; go to esaci;
65 /icase(sym_minus)/ v1 = v1 - v2; go to esaci;
66 /icase(sym_mult)/ v1 = v1 * v2; go to esaci;
smfe 113
smfe 114 /icase(sym_mod)/
smfe 115 if v2 = 0 then
smfe 116 call ermsg(16, 0); v1 = 0; go to esaci;
smfe 117 end if;
smfe 118 v1 = mod(v1, v2); if (v1 < 0) v1 = v1 + iabs(v2);
smfe 119 go to esaci;
smfb 582
smfb 583 /icase(sym_div)/
smfb 584 if v2 = 0 then
smfb 585 call ermsg(16, 0); v1 = 0; go to esaci;
smfb 586 end if;
smfb 587 v1 = v1 / v2;
smfb 588 go to esaci;
69
70 /icase(sym_slash)/
smfb 589 if v2 = 0 then
smfb 590 call ermsg(16, 0); r1 = 0.0; go to esacr;
smfb 591 end if;
71 r1 = float(v1); r2 = float(v2); r1 = r1 / r2;
72 go to esacr;
73
74 /esaci/
75 push1(getint(v1)); success = yes;
76
77
78 elseif is_freal(f1) & is_freal(f2) then
79 if ( ^ (sym_plus <= op & op <= sym_slash)) return;
80 r1 = symval(a1); r2 = symval(a2);
81 assert vlen(a1) = 1; assert vlen(a2) = 1;
82
83 go to rcase(op) in sym_plus to sym_slash;
84
85 /rcase(sym_plus)/ r1 = r1 + r2; go to esacr;
86 /rcase(sym_minus)/ r1 = r1 - r2; go to esacr;
87 /rcase(sym_mult)/ r1 = r1 * r2; go to esacr;
smfb 592
smfb 593 /rcase(sym_slash)/
smfb 594 if r2 = 0.0 then
smfb 595 call ermsg(16, 0); r1 = 0.0; go to esacr;
smfb 596 end if;
smfb 597 r1 = r1 / r2;
smfb 598 go to esacr;
89
90 /esacr/
91 t = getsym(0); form(t) = f_real; is_repr(t) = yes;
92 is_decl(t) = yes; is_read(t) = yes; is_store(t) = yes;
93 countup(valp, val_lim, 'val'); val(valp) = r1;
94 vptr(t) = valp; vlen(t) = 1;
95 push1(t); success = yes;
96
97 end if;
98
99 end subr fldbin;
1 .=member foldun
2 subr foldun(op, a1, success);
3$
4$ this routine attempts to constant fold 'op a1', and sets 'success' to
5$ indicate whether it was successvful.
6$
7 size op(ps); $ operator name
8 size a1(ps); $ operand
9 size success(1); $ indicates successful folding
10
11 size fm(ps); $ operand form
12 size str(sds_sz); $ string value
13 size t(ps); $ symbol table pointer for result
14 size v(ws); $ integer value
15 real r; $ real value
16
17
18 success = no; $ assume failure
19
20 if ( ^ is_const(a1)) return;
21
22 v = symval(a1); fm = form(a1);
23
24 if op = sym_minus then
25 if is_fint(fm) then
26 assert vlen(a1) = 1;
27 push1(getint(-v)); success = yes;
28 elseif is_freal(fm) then
29 assert vlen(a1) = 1;
30 r = v; r = -r;
31 t = getsym(0); form(t) = f_real; is_repr(t) = yes;
32 is_decl(t) = yes; is_read(t) = yes; is_store(t) = yes;
33 countup(valp, val_lim, 'val'); val(valp) = r;
34 vptr(t) = valp; vlen(t) = 1;
35 push1(t); success = yes;
36 else
37 call ermsg(30, a1);
38 end if;
39
40
41 elseif op = sym_char then
42 if ^ is_fint(fm) then call ermsg(34, a1); v = 1r ; end if;
43 if v < 0 ! cssz <= v then call ermsg(34, a1); v = 1r ; end if;
44 str = 3q' '; .ch. 2, str = v; push1(hashst(str)); call gstr;
45 is_read(astack(asp)) = yes; success = yes;
46
47 end if;
48
49 end subr foldun;
1 .=member foldst
2 subr foldst(op, n, success);
3
4$ this routine performs constant folding on set and tuple formers.
5$ its arguments are:
6
7$ op: indicates q1_set or q1_tup
8$ n: the number of elements
9$ success: set to true if folding is possible
10
11$ if we succeed in folding the set(tuple), we push the result
12$ onto the stack and set success = true.
13
14$ the actual elements are the top n astack entries.
15
16 size op(ps), $ q1_set or q1_tup
17 n(ps), $ no. of elements
18 success(1); $ set if successful
19
20 size j(ps), $ loop index
21 elmt(ps); $ set element
22
23 size genst(ps); $ generates constant set or tuple
24
25 size p(ps); $ symtab pointer
26
27 success = no; $ assume folding is impossible
28
29 if (n >= vlen_lim) return;
30
31 do j = 0 to n-1;
32 elmt = astack(asp-j);
33 if (^ is_const(elmt)) return;
34 end do;
35
36 success = yes;
37
38 p = genst(op, n);
39 push1(p);
40
41
42 end subr foldst;
1 .=member blkdec
2 subr blkdec;
3
4$ blkdec is called when we finish compiling each routine. it
5$ breaks the code fragment for the routine into basic blocks
6$ and puts it in the form required by the optimizer.
7
suna 32 size p2(ps); $ pointer to previous previous instruction
8 size prev(ps), $ pointer to previous instruction
9 now(ps), $ pointer to current instruction
10 op(ps); $ opcode of prev
11
12
13$ iterate over the program, looking for the end of each
14$ block.
15
16$ set prev to point to the routines entry instruction.
17 prev = prog_start;
18
19 while opcode(prev) ^= q1_entry;
20 prev = next(prev);
21 end while;
22
23$ iterate over the blocks in the routine
24 while prev ^= 0;
25
26$ make blocktab entry
27
28 countup(blocktabp, blocktab_lim, 'blocktab');
29 b_first(blocktabp) = prev;
30 b_rout(blocktabp) = currout;
31
32 blockof(prev) = blocktabp; $ thread first instruction
33
34$ set 'now' to point to the instruction after the blocks label.
35 now = next(prev);
suna 33 p2 = 0;
36
37$ look for end of block
smfb 599 while now ^= 0;
smfb 600 op = opcode(now);
smfb 601
smfb 602 if (op = q1_label ! op = q1_tag) quit;
smfb 603
smfb 604 if op = q1_noop then
49 if (prev ^= 0) next(prev) = next(now);
50 now = next(now);
51
suna 34 elseif opcode(prev) = q1_goto then
suna 35 if op = q1_stmt then
suna 36 assert p2 ^= 0;
suna 37 next(p2) = now; p2 = now; now = next(now);
suna 38 next(p2) = prev; blockof(p2) = blocktabp;
suna 39 else
suna 40 opcode(now) = q1_noop; now = next(now);
suna 41 end if;
52 else
53 blockof(now) = blocktabp;
suna 42 p2 = prev; prev = now; now = next(now);
57 end if;
58 end while;
59
60$ we now have:
61
62$ prev: points to end of current block
63$ now: points to next block if one exists
64
65$ the current block must end in with one of the following instructions:
66
67$ q1_exit
68$ q1_goto
69$ q1_stop
70
71$ if it does not end in one of these, there is an implicit
72$ branch to the next block; we make this explict by inserting
73$ a 'goto'.
74
75$ if this is the routine's stop or exit block, we save a pointer
76$ to it in routab.
77
78 op = opcode(prev);
79
80 if op ^= q1_exit & op ^= q1_goto & op ^= q1_stop then
81 call insert(prev, q1_goto, arg1(now), 0, 0);
82 blockof(prev) = blocktabp;
83 end if;
84
85 next(prev) = 0; $ indicate end of list
86 prev = now; $ point to label of next block
87 end while;
88
90
91 end subr blkdec;
1 .=member genelt
2 fnct genelt(nam, fm);
3$
4$ this routine generates a constant of type element. nam is the symbol
5$ table entry for the original constant (or initialised variable), and
6$ fm is the desired form.
7$
8$ if nam is a global, we must allocate a variable whose name depends on
9$ the name of nam.
10$
11 size nam(ps); $ symbol table pointer for constant
12 size fm(ps); $ desired form
13
14 size genelt(ps); $ symbol table pointer returned
15
16
17 genelt = hashst('e$' .cc. symsds(nam));
18
19 is_repr(genelt) = yes;
20 is_decl(genelt) = yes;
21 is_read(genelt) = yes;
22 is_store(genelt) = yes;
23
24 form(genelt) = fm;
25
26 countup(valp, val_lim, 'val');
27 val(valp) = alias(nam);
28
29 vptr(genelt) = valp;
30 vlen(genelt) = 1;
31
32
33 end fnct genelt;
1 .=member genst
2 fnct genst(op, n);
3
4$ this routine generates a constant set or tuple and returns a symbol
5$ table pointer to it.
6
bnda 41 size op(ps); $ opcode (q1_set or q1_tup)
bnda 42 size n(ps); $ number of elements
9
bnda 43 size genst(ps); $ symbol table pointer returned
11
bnda 44 size all_pairs(1); $ indicates that all elements are pairs
bnda 45 size card(ps); $ cardinality of result
bnda 46 size done(1); $ indicates that set elements are sorted
bnda 47 size elmt(ps); $ symtab pointer for element
bnda 48 size fm(ps); $ formtab pointer for result
bnda 49 size hashc(ws); $ hash code
bnda 50 size indx(ps); $ index into heads
bnda 51 size j(ps), k(ps); $ loop counters
bnda 52 size temp(ps); $ temporary astack pointer
bnda 53
bnda 54
bnda 55$ if this is a set former, sort the elements by their symbol table index
bnda 56$ and remove duplicate elements.
bnda 57
bnda 58 if op = q1_set & n > 0 then
bnda 59
bnda 60 $ first sort the set elements using bubble sort.
bnda 61 do j = asp-n+2 to asp;
bnda 62 done = yes; $ assume that the set elements are sorted.
bnda 63 do k = asp-1 to j-1 by -1;
bnda 64 if astack(k) > astack(k+1) then
bnda 65 swap(astack(k), astack(k+1)); done = no;
bnda 66 end if;
bnda 67 end do k;
bnda 68 if (done) quit do j;
bnda 69 end do j;
bnda 70
bnda 71 $ remove duplicate elements, if any, and adjust the stack.
bnda 72 k = asp - n + 1;
bnda 73 do j = asp-n+1 to asp;
bnda 74 if astack(j) ^= astack(k) then $ a new element.
bnda 75 k = k + 1; astack(k) = astack(j);
bnda 76 end if;
bnda 77 end do j;
bnda 78 card = n - (asp - k);
bnda 79 free_stack(asp - k); $ remove excess elements.
bnda 80
bnda 81 else $ op = q1_tup.
bnda 82 card = n;
bnda 83 end if;
bnda 84
bnda 85$ next compute the hash code for the constant.
bnda 86
bnda 87 hashc = 0;
bnda 88 do j = asp-card+1 to asp;
bnda 89 if (alias(astack(j))) astack(j) = alias(astack(j));
bnda 90 hashc = hashc .ex. astack(j);
bnda 91 end do j;
bnda 92 hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
bnda 93
bnda 94$ next seach the clash list for this hash code to see whether another
bnda 95$ set (or tuple) with the same value exists.
bnda 96
bnda 97 indx = mod(hashc, heads_lim)+1;
bnda 98 genst = heads(indx);
bnda 99 while genst ^= 0;
bnda 100 until 1; $ exit when not this symtab entry.
bnda 101 if (name(genst) ^= 0) quit until; $ not non-primitive
bnda 102 if (op = q1_set & is_fset(form(genst)) = no) quit until;
bnda 103 if (op = q1_tup & is_ftup(form(genst)) = no) quit until;
bnda 104 if (vlen(genst) ^= card) quit until; $ different length
bnda 105 temp = asp - card + 1; $ first astack entry of constant
bnda 106 do k = 0 to card-1;
bnda 107 if (astack(temp+k) ^= val(vptr(genst)+k)) quit until;
bnda 108 end do k;
bnda 109
bnda 110 $ found a matching entry: free the new elements and
bnda 111 $ return the pointer to the old entry.
bnda 112
bnda 113 free_stack(card);
bnda 114 return;
bnda 115
bnda 116 end until 1;
bnda 117 genst = link(genst);
bnda 118 end while;
18
19 genst = getsym(0);
20
21 is_repr(genst) = yes;
22 is_decl(genst) = yes;
23 is_read(genst) = yes;
24 is_store(genst) = yes;
25
bnda 119 $ link to front of clash list.
bnda 120 link(genst) = heads(indx);
bnda 121 heads(indx) = genst;
bnda 122
bnda 123$ build the val entry for the set or tuple. for sets, check whether all
bnda 124$ the elements are pairs, and if so, allocate a map rather than a set.
26
27 vptr(genst) = valp + 1;
bnda 125 vlen(genst) = card;
29
32
33 all_pairs = yes;
bnda 126 if (card = 0) all_pairs = no;
35
bnda 127 do j = asp-card+1 to asp;
bnda 128 elmt = astack(j);
bnda 129 if alias(elmt) then call ermsg(0, 0); end if;
39 if (alias(elmt) ^= 0) elmt = alias(elmt);
40
41 fm = form(elmt);
42
43 if elmt = sym_om & op = q1_set then
44 call ermsg(82, 0);
bnda 130 elseif elmt = sym_om then
bnda 131 call warn(6, 0);
45 elseif ^ is_ftup(fm) ! ft_lim(fm) ^= 2 then
46 all_pairs = no;
47 elseif val(vptr(elmt)) = sym_om !
48 val(vptr(elmt)+1) = sym_om then
49 all_pairs = no;
50 end if;
51
52 countup(valp, val_lim, 'val');
53 val(valp) = elmt;
54 end do;
55
56 if op = q1_set then
57 if all_pairs then
58 fm = f_umap;
59 else $ set
60 fm = f_uset;
61 end if;
62
63 else $ tuple
bnda 132 if card = 0 then $ treat as (homogeneous) null tuple.
65 push2(f_gen, sym_zero);
66 call gttup2;
67
bnda 133 elseif card = 1 then $ treat as homogeneous tuple.
69 elmt = astack(asp);
70
71 push2(form(elmt), sym_one);
72 call gttup2;
73
74 else $ treat as mixed tuple
75 temp = asp;
76
bnda 134 do j = temp-card+1 to temp;
bnda 135 elmt = astack(j);
79 push1(form(elmt));
80 end do;
81
bnda 136 push1(card-2); $ yes, card - 2.
83 call gttup1;
84 end if;
85
86 pop1(fm);
87
88 end if;
89
90 form(genst) = fm;
91
bnda 137 free_stack(card); $ pop elements from stack.
93
94
95 end fnct genst;
1 .=member hash
2
3 .+tr notrace entry;
4
5 fnct hash(ara, words);
6
7$ this routine hashes a names into symtab. its arguments are:
8
9$ ara: a word size array containing the name, formatted as
10$ if it were a 'names' entry.
11
12$ words: the number of words in the name
13
14 size ara(ws);
15 dims ara(1);
16
17 size words(ps);
18
19 size hash(ps); $ symbol table pointer
20
21 size hashc(ws), $ hash code
22 indx(ps), $ index into heads
23 j(ps), $ loop index
24 n(ps); $ names pointer
25
26
27$ compute hash code
28 hashc = 0;
29
30 do j = 1 to words;
31 hashc = hashc .ex. ara(j);
32 end do;
33
34 hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
35
36$ compute index into array of hash headers and search for
37$ the name.
38
39 indx = mod(hashc, heads_lim) + 1;
40 hash = heads(indx);
41
42 while hash ^= 0;
43 n = name(hash)-1; $ compare names
44
45 do j = 1 to words;
46 if (names(n+j) ^= ara(j)) go to nxt;
47 end do;
48
49 return;
50
51 /nxt/
52 hash = link(hash);
53
54 end while;
55
56
57$ if we reach here, we must make a new symtab entry.
58
59 countup(symtabp, symtab_lim, 'symtab');
60 hash = symtabp;
61
62 symtab(hash) = 0;
63 name(hash) = namesp + 1;
64
65 do j = 1 to words;
66 countup(namesp, names_lim, 'names');
67 names(namesp) = ara(j);
68 end do;
69
70$ add to front of clash list
71 link(hash) = heads(indx);
72 heads(indx) = hash;
73
74
75 end fnct hash;
1 .=member hashst
2 fnct hashst(str1);
3
4$ this routine hashes a self defining string into symtab. this is
5$ done in two steps:
6
7$ 1. copy str1 into str2 then set its insignificant bits to
8$ zero. we do this so that strings can be compared for
9$ equality useing a simple word by word test.
10
11$ 2. convert str2 to 'names array' format and call hash.
12
13 size str1(sds_sz); $ string being hashed
14
15 size hashst(ps); $ symbol table pointer returned
16
17 size p(ps), $ pointer to new names entry
18 org(ps), $ sorg of strings
19 len(ps), $ slen of strings
20 extra(ps), $ number of extra bits
21 words(ps), $ length of names entry
22 j(ps), $ loop index
23 str2(sds_sz); $ duplicate string
24
25 size ara(ws); $ array for string
26 dims ara(sds_sz/ws);
27
28 org = sorg str1; $ get origin and length
29 len = slen str1;
30
31$ copy string and clear extra bits.
32 str2 = str1;
33
34 extra = org - 1 - .sl. - .so. - len * cs;
35 .e. 1 + .sl. + .so., extra, str2 = 0;
36
37 words = org/ws;
38
39$ convert to names format and call hash.
40 do j = 1 to words;
41 ara(j) = .f. 1 + (j-1) * ws, ws, str2;
42 end do;
43
44 hashst = hash(ara, words);
45
46
47 end fnct hashst;
1 .=member hashf1
2 fnct hashf1(dummy);
3
4$ this routine hashes forms which donot use mttab. we begin by
5$ computing the hash by exclusive-oring pieces of the form.
6
7
8 size hashf1(ps); $ formtab pointer returned
9
suna 43 size hashc(ws); $ hash code.
suna 44 size indx(ps); $ index into fheads.
suna 45 size j(ps); $ loop index.
suna 46
13
14 hashc = 0; $ hash code of form
15
16 do j = 0 to formtab_sz/ws-1;
17 hashc = hashc .ex. .f. 1+j*ws, ws, formtab(formtabp);
18 end do;
19
20 hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
21
22$ compute index in 'fheads' and get formtab pointer
23 indx = mod(hashc, fheads_lim) + 1;
24 hashf1 = fheads(indx);
25
26$ look for a matching entry. we compare entries by
27$ setting ft_link(formtabp) to ft_link(entry being compared)
28$ then doing a full word comparison.
29
30$ note that if we try to hash in f_gen we will always wind up
31$ building a new formtab entry. this is because a pointer to
32$ formtab(0) is taken as a null pointer. fortunately, f_gen is
33$ only hashed in once.
34
35 while hashf1 ^= 0;
36 ft_link(formtabp) = ft_link(hashf1);
37 ft_deref(formtabp) = ft_deref(hashf1);
38
39 if formtab(formtabp) = formtab(hashf1) then $ found match
40 formtabp = formtabp - 1; $ free new entry
41 return;
42 end if;
43
44 hashf1 = ft_link(hashf1);
45 end while;
46
47$ add new entry to clash list
48 ft_link(formtabp) = fheads(indx);
49 fheads(indx) = formtabp;
50
51$ compute the dereferenced form
52 if ft_type(formtabp) = f_elmt then
53 if ft_type(ft_base(formtabp)) = f_pbase then
54 ft_deref(formtabp) = formtabp;
55 else
smfa 52 ft_deref(formtabp) = ft_deref(ft_elmt(ft_base(formtabp)));
57 end if;
58 else
59 ft_deref(formtabp) = formtabp;
60 end if;
61
62 hashf1 = formtabp;
63
64
65 end fnct hashf1;
1 .=member hashf2
2 fnct hashf2(dummy);
3
4$ this routine hashes forms which use mttab.
5$ the new form is at formtab(formtabp).
6
7 size hashf2(ps); $ pointer returned
8
9 size type(ps), $ ft_type
10 high(ps), $ ft_lim
11 elmt(ps); $ ft_elmt
12
suna 47 size hashc(ws); $ hash code.
suna 48 size indx(ps); $ index into fheads.
suna 49 size el(ps); $ ft_elmt value.
suna 50 size j(ps); $ loop index.
17
18
19$ get the ft_type, ft_lim and ft_elmt.
20
21 type = ft_type(formtabp);
22 high = ft_lim(formtabp);
23 elmt = ft_elmt(formtabp);
24
25$ compute the hash as the exclusive or of the type and the mttab
26$ entries.
27
28 hashc = type;
29
30 do j = 1 to high;
31 hashc = hashc .ex. mttab(elmt + j);
32 end do;
33
34 indx = mod(hashc, fheads_lim) + 1; $ get index into table of heade
35 hashf2 = fheads(indx);
36
37$ scan for match
38 while hashf2 ^= 0;
39 if (ft_type(hashf2) ^= type) go to nxt;
40 if (ft_lim(hashf2) ^= high) go to nxt;
41
42 el = ft_elmt(hashf2);
43
44 do j = 1 to high;
45 if (mttab(el+j) ^= mttab(elmt+j)) go to nxt;
46 end do;
47
48$ found match. free duplicate entries in formtab and mttab.
49 formtabp = formtabp - 1;
50 mttabp = elmt;
51 return;
52
53 /nxt/
54 hashf2 = ft_link(hashf2);
55
56 end while;
57
58$ link new entry into clash list
59 ft_link(formtabp) = fheads(indx);
60 fheads(indx) = formtabp;
61
62$ compute the dereferenced form
63 if ft_type(formtabp) = f_elmt then
64 if ft_type(ft_base(formtabp)) = f_pbase then
65 ft_deref(formtabp) = formtabp;
66 else
67 ft_deref(formtabp) = ft_deref(ft_base(formtabp));
68 end if;
69 else
70 ft_deref(formtabp) = formtabp;
71 end if;
72
73 hashf2 = formtabp;
74
75
76 end fnct hashf2;
1 .=member chkvar
2 subr chkvar(nam);
3
4$ this routine is called after 'nam' is used as a variable. if
5$ nam has been seen before(is_decl = yes) we check that it is
6$ not a procedure or member name. otherwise we give it an implicit
7$ declaration.
8
9 size nam(ps); $ name being checked
10
11 if is_decl(nam) then
12 if (is_proc(nam) ! is_memb(nam)) call ermsg(29, nam);
13 if ^ is_read(nam) then
14 if ^ is_local(nam) then
15 call ermsg(96, nam);
16 else
17 call ermsg(97, nam);
18 end if;
19 is_read(nam) = yes;
20 end if;
21
22 else
23 if ( ^ is_local(nam)) call ermsg(03, nam);
24 if (uv_flag & ^ is_internal(nam)) call warn(4, nam);
25 is_decl(nam) = yes;
26 is_read(nam) = yes;
27 is_write(nam) = yes;
28 is_store(nam) = yes;
29
30 if unit_type = unit_proc & currout ^= sym_main_ then
31 is_stk(nam) = yes;
32 else
33 is_stk(nam) = no;
34 end if;
35 end if;
36
37
38 end subr chkvar;
1 .=member insn
2 subr insn(i, op, ara, n);
3
4$ this routine inserts an instruction after 'i' and advances 'i' to
5$ point to it. if the instruction defines a temporary, it also
6$ sets 'tprev' and 'tlast' for the temporary.
7
8$ the arguments are:
9
10$ i: insert new instruction here
11$ op: opcode q1_xxx
12$ ara: array of arguments
13$ n: number of arguments
14
15 size i(ps), $ pointer to instruction
16 op(ps), $ opcode
17 ara(ps), $ array of arguments
18 n(ps); $ no. of arguments
19 size p(ps); $ pointer into argtab
20
21 dims ara(1); $ dummy dimension
22
23 size j(ps), $ loop index
24 prev(ps), $ pointer to previous instruction
25 in(ps); $ name of input
26
27$ the variables 'prev1' and 'last1' delimit the code fragment for the
28$ inputs. the function 'after' is used to tell if one instruction is
29$ after another.
30
31 size prev1(ps),
32 last1(ps);
33
34 size after(1);
35
36
37$ begin by building the new instruction.
38
39 countup(codetabp, codetab_lim, 'codetab');
40
41 codetab(codetabp) = 0;
42
43 opcode(codetabp) = op;
44 nargs(codetabp) = n;
45 argp(codetabp) = argtabp;
46
47$ add arguments to argtab.
48
49 p = argtabp; $ save current position in argtab
50 argtabp = argtabp + n; $ get extra space
51 if (argtabp > argtab_lim) call overfl('argtab');
52
53 do j = 1 to n;
54 argtab(p+j) = ara(j);
55 end do;
56
57$ next link new instruction into code list
58 next(codetabp) = next(i);
59 next(i) = codetabp;
60
61$ advance 'i'
62 prev = i;
63 i = codetabp;
64
65$ if 'op' doesnt define a temporary, we are done.
66 if (^ (defs_temp(op) & is_temp(ara(1)))) return;
67
68$ otherwise find the code fragment for the inputs.
69
70 prev1 = 0; $ initialize
71 last1 = 0;
72
73 do j = 2 to n;
74 in = ara(j);
75
76 if ^ is_temp(in) then
77 cont;
78
79 elseif prev1 = 0 then $ first temporary seen
80 prev1 = tprev(in);
81 last1 = tlast(in);
82
83 elseif after(tprev(in), last1) then $ -in- is last input
84 last1 = tlast(in);
85
86 elseif after(prev1, tlast(in)) then $ -in- is first input
87 prev1 = tprev(in);
88 end if;
89 end do;
90
91 if (prev1 = 0) prev1 = prev; $ use previous instruction
92
93 tprev(ara(1)) = prev1;
94 tlast(ara(1)) = i;
95
96
97 end subr insn;
1 .=member after
2 fnct after(i1, i2);
3
4$ this function returns true if either:
5
6$ 1. i1 and i2 point to the same instruction
7$ 2. i1 occurs after i2 in the code.
8
9$ we simply scan the code starting from i2 until we reach i1 or the
10$ end of the program.
11
12 size i1(ps), $ code pointers
13 i2(ps);
14
15 size after(1); $ flag returned
16
17 size p(ps); $ code pointer
18
19 p = i2;
20
21 while 1;
22 if (p = i1) go to pass; $ i2 is first
23 if (p = 0) go to fail; $ i1 is first
24
25 p = next(p);
26 end while;
27
28/pass/
29
30 after = yes;
31 return;
32
33/fail/
34
35 after = no;
36 return;
37
38 end fnct after;
1 .=member insert
2 subr insert(i, op, a1, a2, a3);
3
4$ this is a version of 'insn' for handling opcodes with up to
5$ three arguments. the map 'numargs' tells us how many arguments
6$ are actually supplied for each opcode.
7
8 size i(ps), $ pointer to instruction
9 op(ps), $ opcode
10 a1(ps), $ arguments
11 a2(ps),
12 a3(ps);
13
14 size ara(ps); $ array for arguments
15 dims ara(3);
16
17 ara(1) = a1; $ pack arguments into array.
18 ara(2) = a2;
19 ara(3) = a3;
20
21 call insn(i, op, ara, numargs(op));
22
23
24 end subr insert;
1 .=member emitn
2 subr emitn(op, ara, n);
3
4$ this routine is similar to 'insn', but adds the new instruction at the
5$ end of the program.
6
7 size op(ps), $ opcode
8 ara(ps), $ array of arguments
9 n(ps); $ number of arguments
10
11 dims ara(1); $ dummy dimension
12
13 call insn(prog_end, op, ara, n);
14
15
16 end subr emitn;
1 .=member emit
2 subr emit(op, a1, a2, a3);
3
4$ this is a variation of 'insert' which adds an instruction to the
5$ end of the program.
6
7 size op(ps), $ opcode
8 a1(ps), $ arguments
9 a2(ps),
10 a3(ps);
11
12 call insert(prog_end, op, a1, a2, a3);
13
14
15 end subr emit;
1 .=member movblk
2
3 .+tr trace entry;
4
5 subr movblk(prev, last, targ);
6
7$ this routine moves a block of code. its arguments are:
8
9$ prev: points to instruction before block to be moved
10$ last: points to end of block to be moved
11$ targ: insert block after this instruction
12
13$ note that if we are moving code from or to the end of the program,
14$ we must reset 'prog_end'. for this reason prog_end itself should
15$ not be used as an argument to the routine.
16
17
18 size prev(ps), $ previous instruction to block
19 last(ps), $ last instruction of block
20 targ(ps); $ target
21
22 size first(ps), $ first instruction of block
23 j(ps); $ loop index
24
25
26 if trs_flag then $ provide trace
smfe 120 put ,skip ,'entering movblk at ' :symsds(curmemb),a
smfe 121 ,'.' :symsds(currout),a ,'.' :stmt_count,i
smfe 122 ,': ' :prev:last:targ,nil ,skip;
32
33 stack_trace('astack ', asp);
34 call prgdmp;
35 end if;
36
37
38 if (prev = last) return; $ null block
39
40 if (prev = targ) return; $ already in place
41
42 if (last = targ) return; $ already in place
43
44 first = next(prev); $ pointer to start of block
45
46 next(prev) = next(last);
47 next(last) = next(targ);
48 next(targ) = first;
49
50 if prog_end = last then $ moving code from end of program
51 prog_end = prev;
52
53 elseif prog_end = targ then $ moving code to end of program
54 prog_end = last;
55 end if;
56
57$ adjust all 'tprev' fields which point to prev, last, or targ.
58
59 do j = symtab_org+1 to symtabp;
60 if tprev(j) = prev then
61 tprev(j) = targ;
62
63 elseif tprev(j) = last then
64 tprev(j) = prev;
65
66 elseif tprev(j) = targ then
67 tprev(j) = last;
68 end if;
69 end do;
70
71
72 end subr movblk;
1 .=member killexp
2 subr killex(e);
3
4$ this routine deletes the code fragment for an expression 'e'.
5$ we assume that 'e' is dead and that there are no pointers
6$ from cstack to the code fragment we are deleting.
7
8
9 size e(ps); $ the expression
10
11 size prev(ps), $ its tprev
12 last(ps);
13
14
15 if (^ is_temp(e)) return;
16
17 prev = tprev(e);
18 last = tlast(e);
19
20 next(prev) = next(last);
21
22 if (prog_end = last) prog_end = prev;
23
24
25 end subr killex;
1 .=member copy
2 fnct copy(exp);
3
4$ this routine copies the code fragment for an expression 'exp'.
5
6$ typically copy is called to process 'f(e1) with x'. this statement
7$ is processed in three steps:
8
9$ 1. emit the binary operator 't := f(e1) with x'.
10$ 2. copy the code fragment for 'f(e1)'.
11$ 3. use the copy to emit 'f(e1) := t'.
12
13$ if we were to do a complete copy of the code fragment for 'f(e1)'
14$ we would wind up evaluating 'e1' twice. this is undesirable.
15
16$ instead of doing a full copy, we change the original code fragment
17$ to 'f(t1 := e1)' and return 'f(t1)'.
18
19$ note that we expect 'exp' to be a valid left hand side.
20
21
22$ copy works by making two passes over the code for 'exp'. during
23$ the first pass we modify the original code fragment and mark those
24$ instructions which will eventually have to be copied. this is
25$ done using a workpile technique.
26
27$ during the second pass we iterate forward through the code copying
28$ all necessary instructions.
29
30$ rather than add a special field to indicate which instructions must
31$ be copied, we use the 'sflag' field. this field is otherwise
32$ unused during the semantic pass.
33
34
35 size exp(ps); $ temporary for original expression
36
37 size copy(ps); $ symtab pointer returned
38
39 size e(ps); $ local copy of 'exp'
40
41 size last(ps), $ tlast(e)
42 op(ps), $ opcode defining 'e'
43 arg(ps), $ argument
44 p(ps), $ code pointer
45 t(ps), $ temporary
46 i(ps), $ instruction
47 j(ps); $ loop index
48
49 size ara(ps); $ array of argumments
50 dims ara(nargs_lim);
51
52 size savep(ps); $ saved astack pointer
53
54 size subst(ps); $ does name substitution
55
56$ when we copy an instruction we must allocate a new temporary
57$ for its result. the array 'ctab' maps temporaries in the original
58$ expression into temporaries in the copy.
59
60 nameset ctab;
61 +* ctab_lim = 100 ** $ dimension of ctab
62
63 size ctab(32);
64 dims ctab(ctab_lim);
65
66 size ctabp(ps); $ pointer to last entry
67
68 +* old(i) = .f. 01, 16, ctab(i) ** $ original name
69 +* new(i) = .f. 17, 16, ctab(i) ** $ new name
70 end nameset;
71
72
73$ if 'exp' is a variable we simply return it.
74 if ^ is_temp(exp) then
75 copy = exp;
76 return;
77 end if;
78
79$ otherwise use a workpile technique to iterate backwards through the
80$ code fragment.
81
82 savep = asp;
83 push1(exp);
84
85 until savep = asp;
86 pop1(e);
87
88 last = tlast(e);
89 op = opcode(last);
90
91 if op = q1_tup then $ [a, b] - push 'a' and 'b'
92 do j = 2 to nargs(last);
93 arg = argn(last, j);
94
95 if is_temp(arg) then
96 push1(arg);
97 end if;
98 end do;
99
100 sflag(last) = yes;
101
102 elseif sinmap(op) ^= 0 then $ f(x), etc.
103
104$ if 'f' is a temporary then it is the result of some outer level
105$ retreival, so we push it on the stack.
106 if is_temp(arg2(last)) then
107 push1(arg2(last));
108 end if;
109
110 call reuse(last, 3); $ indicate indices are used twice
111 if (op = q1_subst) call reuse(last, 4);
112
113 sflag(last) = yes;
114
115 else $ all other operators are illegal
116 call ermsg(18, 0);
117
118 asp = savep;
119 copy = sym_om;
120
121 return;
122 end if;
123 end until;
124
125
126$ iterate forward copying instructions.
127
128 ctabp = 0;
129
130 p = next(tprev(exp)); $ first instruction
131
132 while 1;
133 if sflag(p) then
134 sflag(p) = no; $ reset
135
136 t = gettmp(0); $ get temp and store in 'ctab'
137
138 countup(ctabp, ctab_lim, 'copy');
139
140 old(ctabp) = arg1(p);
141 new(ctabp) = t;
142
143 ara(1) = t; $ build array of arguments
144
145 do j = 2 to nargs(p);
146 arg = argn(p, j);
147 if (is_temp(arg)) arg = subst(arg);
148
149 ara(j) = arg;
150 end do;
151
152 call emitn(opcode(p), ara, nargs(p));
153
154 end if;
155
156 if (p = tlast(exp)) quit;
157 p = next(p);
158 end while;
159
160 copy = subst(exp);
161
162
163 end fnct copy;
1 .=member subst
2
3 .+tr notrace entry;
4
5 fnct subst(nam);
6
7$ this routine is called from 'copy' to perform name substitution.
8
9 size nam(ps); $ name of original temporary or label
10
11 size subst(ps); $ new name returned
12
13 size j(ps); $ loop index
14
15 access ctab;
16
17$ iterate over ctab, looking for an occurrence of 'nam'.
18 do j = 1 to ctabp;
19 if old(j) = nam then
20 subst = new(j);
21 return;
22 end if;
23 end do;
24
25 macdrop(old)
26 macdrop(new);
27
28 end fnct subst;
1 .=member reuse
2 subr reuse(i, j);
3
4$ this routine is called when we find out that 'argn(i, j)' will be
5$ used twice.
6
7$ we begin by setting arg = argn(i, j). if arg is a variable or constant
8$ we return. otherwise arg is a temporary, and can only be used once.
9$ we generate an internal variable 't', insert an assignment 't := arg'
10$ after tlast(arg) and set argn(i, j) = t.
11
12 size i(ps), $ instruction number
13 j(ps); $ argument number
14
15 size arg(ps), $ argument name
16 t(ps), $ internal variable
17 p(ps); $ code pointer to tlast(arg)
18
19 arg = argn(i, j);
20
21 if (^ is_temp(arg)) return;
22
23 t = getvar(0);
24
25 p = tlast(arg);
26 call insert(p, q1_asn, t, arg, 0);
27
28 argn(i, j) = t;
29
30
31 end subr reuse;
1 .=member eqexp
2 fnct eqexp(e1, e2);
3
4$ this function returns true if two expressions are obviously
5$ equal, i.e. if they have code fragments which are identical
6$ except for temporary names.
7
8$ expressions are considered unequal if they contain operations
9$ which fall into one of four categories:
10
11$ 1. operations which are nondeterministic
12$ 2. assignments
13$ 3. iterative set or tuple formers
14$ 4. labels. these occur in expr blocks, quantifiers, etc.
15
16$ eqexp is called by fndinc in order to determine that the
17$ iterator (! i := e1, e1+1, ...) has a constant increment.
18
19 size e1(ps), $ original expressions
20 e2(ps);
21
22 size eqexp(1); $ flag returned
23
24 size a1(ps), $ copies of arguments
25 a2(ps);
26
27 size i1(ps), $ tlast(a1)
28 i2(ps); $ tlast(a2);
29
30 size j(ps), $ loop index
31 op(ps), $ opcode
32 n(ps); $ number of arguments
33
34 size savep(ps); $ saved astack pointer
35
36$ we consider expressions unequal if they contain any of the
37$ following operators:
38
39 size bad_op(ps);
40 dims bad_op(8);
41
42 data bad_op =
43 q1_rand, q1_newat, q1_time, q1_date,
44 q1_set1, q1_tup1, q1_asn, q1_label;
45
46 savep = asp;
47
48 push2(e1, e2);
49
50 until asp = savep;
51 pop2(a2, a1);
52
53 if (a1 = a2) cont; $ same variable
54
55 if (^ is_temp(a1) ! ^ is_temp(a2)) go to fail;
56
57 i1 = tlast(a1);
58 i2 = tlast(a2);
59
60 op = opcode(i1);
61 n = nargs(i1);
62
63 if (op ^= opcode(i2)) go to fail;
64 if (n ^= nargs(i2)) go to fail;
65
66$ if op is nondeterministic or modifies any variables, go to fail
67
68 do j = 1 to 8;
69 if (op = bad_op(j)) go to fail;
70 end do;
71
72$ otherwise scan inputs recursively
73 do j = 2 to n;
74 a1 = argn(i1, j);
75 a2 = argn(i2, j);
76
77 push2(a1, a2);
78 end do;
79
80 end until;
81
82/pass/ $ equal expressions
83
84 eqexp = yes;
85 return;
86
87
88/fail/ $ unequal expressions
89
90 asp = savep; $ restore stack
91
92 eqexp = no;
93 return;
94
95 end fnct eqexp;
1 .=member gettmp
2 fnct gettmp(dummy);
3
4$ this routine returns a pointer to a new temporary
5 size gettmp(ps);
6
7 gettmp = getsym(0);
8
9 is_temp(gettmp) = yes;
10 is_stk(gettmp) = yes;
11 is_store(gettmp) = yes;
12 is_read(gettmp) = yes;
13 is_write(gettmp) = yes;
14
15
16 end fnct gettmp;
1 .=member getvar
2 fnct getvar(dummy);
3
4$ this routine returns a symtab pointer to an internally generated
5$ variable.
6
7 size getvar(ps);
8
9 getvar = getsym(0);
10
11 is_stk(getvar) = yes;
12 is_store(getvar) = yes;
13 is_read(getvar) = yes;
14 is_write(getvar) = yes;
15
16
17 end fnct getvar;
1 .=member getglb
2 fnct getglb(var);
3
4$ this routine allocates a new global variable. it is similar to
5$ getvar except that the name of the new variable is calculated from
6$ the name of a program variable. this allows us to refer to the new
7$ variable in separate compilations.
8
9
10 size var(ps); $ original variable
11
12 size getglb(ps); $ symbol table pointer returned
13
14 size nam(sds_sz); $ variable name as character string
15
16
17 nam = 'g$' .cc. symsds(var);
18 getglb = hashst(nam);
19
20 is_stk(getglb) = yes;
21 is_store(getglb) = yes;
22 is_read(getglb) = yes;
23 is_write(getglb) = yes;
24
25
26 end fnct getglb;
1 .=member getint
2 fnct getint(n);
3
4$ this routine generates a symbol table pointer to the integer
5$ 'n'. we get a new name, then make a val entry for it.
6
7 size n(ws); $ integer value
8
9 size getint(ps); $ symbol table pointer returned
10
11 size fm(ps); $ form of result
12 size j(ps); $ index
13 size org(ps); $ sorg of string
14 size len(ps); $ slen of string
15 size str(sds_sz); $ integer denotation string
16 size v1(ws); $ temporary integer values
17 size v2(ws);
18 size v3(ws);
19
20
21 if n >= 0 & n <= 9 then $ use standard symtab entry
22 getint = sym_zero + n;
23 return;
24 end if;
25
26$ otherwise build new entry
27 if n > 0 then v1 = n; len = 0;
28 elseif n < 0 then v1 = -n; len = 1;
29 else assert 0;
30 end if;
31
32 v2 = v1 / 10; v3 = 1; len = len + 1;
33 while v2 > 0; v2 = v2 / 10; v3 = v3 * 10; len = len + 1; end;
34
35 org = .sds. len + 1; str = 0; slen str = len; sorg str = org;
36 if n < 0 then .f. org-cs, cs, str = 1r-; j = 2; else j = 1; end;
37
38 while v3 > 0;
39 .f. org-j*cs, cs, str = charofdig(v1/v3);
40 v1 = v1 - (v1 / v3) * v3; v3 = v3 / 10; j = j + 1;
41 end while;
42
43 getint = hashst(str); is_read(getint) = yes;
44
45 if is_decl(getint) then
46 if ( ^ is_const(getint)) call ermsg(0, getint);
47 if (n ^= symval(getint)) call ermsg(0, getint);
48 return;
49 end if;
50
51 if 0 <= n & n <= maxsi then fm = f_sint; else fm = f_int; end;
52 form(getint) = fm; is_decl(getint) = yes; is_repr(getint) = yes;
53 is_store(getint) = yes;
54 countup(valp, val_lim, 'val'); val(valp) = n;
55 vptr(getint) = valp; vlen(getint) = 1;
56
57
58 end fnct getint;
1 .=member getlab
2 fnct getlab(dummy);
3
4$ this routine returns a pointer to a new label
5
6
7 size getlab(ps);
8
9
10 getlab = getsym(0);
11
12 is_decl(getlab) = yes;
13 is_repr(getlab) = yes;
14 form(getlab) = f_lab;
15
16
17 end fnct getlab;
1 .=member deflab
2 subr deflab(lab);
3
4$ this routine defines a label. we begin by checking whether the
5$ label has already been seen. if so, we issue a diagnostic; otherwise
6$ we emit a q1 label instruction and build a val entry for the label.
7
8 size lab(ps); $ symtab pointer for label
9
10 if is_seen(lab) then
11 call ermsg(33, lab);
12
13 else
14 is_seen(lab) = yes;
15
16 call emit(q1_label, lab, 0, 0);
17
18 countup(valp, val_lim, 'val'); $ make val entry
19 val(valp) = prog_end; vptr(lab) = valp; vlen(lab) = 1;
20 end if;
21
22
23 end subr deflab;
1 .=member deftag
2 subr deftag(tag);
3
4$ this routine defines a case tag. it is similar to deflab except
5$ that it emits a q1_tag instruction.
6
7 size tag(ps); $ symtab pointer for tag
8
9 if is_seen(tag) then
10 call ermsg(33, tag);
11
12 else
13 is_seen(tag) = yes;
14
15 call emit(q1_tag, tag, 0, 0);
16
17 countup(valp, val_lim, 'val'); $ make val entry
18 val(valp) = prog_end; vptr(tag) = valp; vlen(tag) = 1;
19 end if;
20
21
22 end subr deftag;
1 .=member getsym
2 fnct getsym(dummy);
3
4$ this routine returns a pointer to a new symbol table entry.
5
6 size getsym(ps); $ pointer returned
7
8 countup(symtabp, symtab_lim, 'symtab');
9 getsym = symtabp;
10
11 symtab(getsym) = 0;
12
13
14 end fnct getsym;
1 .=member findlp
2 fnct findlp(n);
3
4$ this routine finds the cstack entry for a 'quit' or 'continue'
5$ statement and returns a pointer to it. 'n' is an integer which
6$ has the following significance:
7
8$ if n = 0, we return a pointer to the innermost iterator which appears
9$ explicitly in the program. this ignores iterators for f[x] and +/s
10$ operations.
11
12$ if n ^= 0 then we are processing a statement of the form 'cont '. in this case we return a pointer to the n-th entry
14$ from the top of cstack, excluding internal iterators and
15$ .
16
17$ note that the parser has already checked that the appropriate
18$ cstack entry exists.
19
20$ as we probe through cstack, we see whether we are passing any
21$ entries for 'expr' blocks. if so, we are illegally jumping out
22$ of an expr block, and we issue a diagnostic.
23
24 size n(ps);
25
26 size findlp(ps); $ cstack pointer returned
27
28 size j(ps); $ loop index
29 size tp(ps); $ cs_type
30 size count(ps); $ number of entries found so far
31
32
smfa 53 findlp = 0;
smfa 54
33 if n = 0 then $ find innermost explicit loop
34 do j = csp to 1 by -1;
35 tp = cs_type(j);
36
37 if tp = cs_eblk then
38 call ermsg(42, 0);
39 elseif cs_internal(j) then
40 cont;
41 elseif tp = cs_iter ! cs = cs_citer then
smfb 606 findlp = j;
42 quit;
43 end if;
44 end do;
47
48 else $ find i-th entry
49 count = 0;
50
51 do j = csp to 1 by -1;
52 tp = cs_type(j);
53
54 if tp = cs_eblk then
55 call ermsg(42, 0);
56 elseif tp = cs_iter & ^ cs_internal(j) then
57 count = count + 1;
smfb 607 if count = n then findlp = j; quit do; end if;
59 end if;
60
61 end do;
64 end if;
65
66
67 end fnct findlp;
1 .=member symsds
2 fnct symsds(p);
3
4$ this routine returns the name of a symbol table entry as a self
5$ defining string. if p is an internal symbol we return txxxx
6$ where 'xxx' is the value of p.
7
8 size p(ps); $ symbol table pointer
9
10 size symsds(sds_sz),
11 namsds(sds_sz); $ gets string from names ptr
12
13 size n(ps), $ integer to be converted
14 j(ps); $ loop index
15
16 if p = 0 then
17 symsds = '';
18
19 elseif name(p) ^= 0 then
20 symsds = namsds(name(p));
21
22 else
23 symsds = 't' .pad. 5;
24
25 n = p;
26
27 do j = 5 to 2 by -1;
28 .ch. j, symsds = charofdig(mod(n, 10));
29 n = n/10;
30 end do;
31 end if;
32
33
34 end fnct symsds;
1 .=member namsds
2 fnct namsds(nam);
3
4$ this routine converts a names entry to an sds string.
5
6 size nam(ps); $ pointer to names entry
7
8 size namsds(sds_sz);
9
10 size j(ps), $ loop index
11 words(ps); $ number of words in names entry
12
13 if (nam = 0) go to error;
14
15 words = n_sorg(nam)/ws;
16 if (words = 0) go to error;
17
18 do j = 0 to words-1;
19 .f. 1+j*ws, ws, namsds = names(nam+j);
20 end do;
21
22 return;
23
24/error/
25
26 namsds = '';
27
28 return;
29
30
31 end fnct namsds;
1 .=member gsave
2
3 .+tr trace entry;
4
5 subr gsave;
6
7$ this routine is called at the start of a unit. it
8$ saves the current values of namesp, symtabp, and valp on the
9$ stack so that we can later free the table space used by
10$ the unit.
11
12 push3(namesp, symtabp, valp);
13
14
15 end subr gsave;
1 .=member greset
2 subr greset;
3
4$ this routine is called at the end of a procedure, etc. to
5$ restore the symbol table to its saved state. it also
6$ reinitializes the code tables.
7
8 size j(ps), $ loop index
9 p(ps); $ symbol table pointer
10
11$ if astack is wrong at this point it can be a disaster, so we are
12$ prepared to dump it.
13 if trs_flag then
14 stack_trace('greset - before pop', asp);
15 end if;
16
17$ reset pointers
18 pop3(valp, symtabp, namesp);
19
20 names_org = namesp; $ reset origins
21 symtab_org = symtabp;
22 val_org = valp;
23
24$ delete freed symtab entries from their clash lists. note that the f
25$ freed entries are at the beginning of their clash list.
26
27 do j = 1 to heads_lim;
28 p = heads(j);
29
30 while p > symtabp;
31 p = link(p);
32 end while;
33
34 heads(j) = p;
35 end do;
36
37 call incode; $ reinitialize code tables
38
39
40 end subr greset;
1 .=member gputtb
2 subr gputtb;
3
4$ this routine writes out a page of q1.
5
6 size j(ps); $ loop index
7$
8$ before we write out the scope, we check, if so requested, whether all
9$ user-defined variables have been given data structure declarations.
10$
smfb 608 if unit_type ^= unit_sys & rpr_flag ^= 0 & ur_flag ^= 0 then
12 do j = symtab_org + 1 to symtabp;
13 if (is_internal(j)) cont;
14 if (is_repr(j)) cont;
15 call warn(05, j);
16 end do;
17 end if;
18
19 if (q1sd_flag) call sdump;
20 if (q1cd_flag) call q1dump;
21
22 if .len. sq1_title then call sputtb; else call lputtb; end if;
23
24 +* update(org, p, max) =
25 org = p; if (max < p) max = p;
26 **
27
28 update(mttab_org, mttabp, mttab_max)
29 update(formtab_org, formtabp, formtab_max)
30 update(names_org, namesp, names_max)
31 update(val_org, valp, val_max)
32 update(symtab_org, symtabp, symtab_max)
33 update(blocktab_org, blocktabp, blocktab_max)
34 update(argtab_org, argtabp, argtab_max)
35 update(codetab_org, codetabp, codetab_max)
36
37 macdrop(update)
38
39
40 end subr gputtb;
1 .=member lputtb
2 subr lputtb;
3
4$ this routine writes a page of q1 onto the little q1 file.
5
6
7 write q1_file, unit_type, symsds(curunit), curunit,
8 proctabp, ustmt_count, estmt_count;
9
10 +* putr(ara, org, last) = $ write table slice
11 write q1_file, org, last;
12 if (org < last) write q1_file, ara(org+1) to ara(last);
13 **
14
15 putr(mttab, mttab_org, mttabp)
16 putr(formtab, formtab_org, formtabp)
17 putr(names, names_org, namesp)
18 putr(val, val_org, valp)
19 putr(symtab, symtab_org, symtabp)
20 putr(blocktab, blocktab_org, blocktabp)
21 putr(argtab, argtab_org, argtabp)
22 putr(codetab, codetab_org, codetabp)
23
24 macdrop(putr);
25
26
27 end subr lputtb;
1 .=member sputtb
2 subr sputtb;
3
4$ this routine writes a page of q1 onto setl q1 file.
5
6
7 .+sq1.
8
9 size fm(ps); $ form
10 size putbhdrblk(ws); $ binary header word
11 size i(ps); $ loop index
12 size j(ps); $ inner loop index
13
14 +* putbhdr(t, v) = $ write binary header block
15 putbhdrblk = 0;
16 bh_typ_ putbhdrblk = t;
17 bh_val_ putbhdrblk = v;
18 write sq1_file, putbhdrblk;
19 **
20
21 +* putbdat(v) = $ write one word binary data block
22 write sq1_file, v;
23 **
24
25
26$
27$ unit identifying record
28$
29 call putsbi(unit_type);
30 call putsbs(curunit);
31 call putsbi(curunit);
32 call putsbi(proctabp);
33 call putsbi(ustmt_count);
34 call putsbi(estmt_count);
35$
36$ form table
37$
38 call putsbi(formtab_org); call putsbi(formtabp);
39
40 do i = formtab_org+1 to formtabp;
41 putbhdr(bt_tuple, 0)
42
43 call putsbi(ft_type(i));
44 call putsbi(ft_mapc(i));
45 call putsbi(ft_elmt(i));
46 call putsbi(ft_dom(i));
47 call putsbi(ft_im(i));
48 call putsbi(ft_imset(i));
49 call putsbi(ft_base(i));
50 call putsbi(ft_deref(i));
51 call putsbi(ft_low(i));
52 call putsbi(ft_lim(i));
53 call putsbi(ft_pos(i));
54 call putsbb(ft_hashok(i));
55 call putsbb(ft_neltok(i));
56
57 putbhdr(bt_tuple, 0)
58
59 if ft_type(i) = f_mtuple ! ft_type(i) = f_proc then
60 do j = 1 to ft_lim(i);
61 call putsbi(mttab(ft_elmt(i)+j));
62 end do;
63
64 elseif is_fbase(i) then
65 call putsbi(ft_num(i, f_lset));
66 call putsbi(ft_num(i, f_lmap));
67 call putsbi(ft_num(i, f_lpmap));
68 call putsbi(ft_num(i, f_limap));
69 call putsbi(ft_num(i, f_lrmap));
70
71 elseif is_fmap(i) & is_frem(i) then
72 call putsbi(ft_tup(i));
73 end if;
74
75 putbhdr(bt_tuple, 1)
76
77 putbhdr(bt_tuple, 1)
78 end do;
79$
80$ symbol table
81$
82 call putsbi(symtab_org); call putsbi(symtabp);
83
84 do i = symtab_org+1 to symtabp;
85 putbhdr(bt_tuple, 0)
86
87 call putsbs(i); $ write name or null string
88 call putsbi(form(i));
89 call putsbi(alias(i));
90 call putsbb(is_repr(i));
91 call putsbb(is_temp(i));
92 call putsbb(is_stk(i));
93 call putsbb(is_read(i));
94 call putsbb(is_write(i));
95 call putsbb(is_param(i));
96 call putsbb(is_store(i));
97 call putsbb(is_init(i));
98 call putsbb(is_seen(i));
99 call putsbb(is_back(i));
100 call putsbb(is_rec(i));
101
102 fm = form(i);
103
104 if vptr(i) ^= 0 then
105 call putsbb(yes); $ has_value_ in setl.opt = true
106 call putsbi(vlen(i));
107
108 putbhdr(bt_tuple, 0)
109
110 if is_fint(fm) then
111 call putsbi(val(vptr(i)));
112
113 elseif is_freal(fm) then
114 call putsbr(val(vptr(i)));
115
116 elseif is_fstr(fm) then
117 call putsbs(-i);
118
119 elseif ft_type(fm) = f_atom then
120 $ recall that booleans are represented by the short
121 $ atoms 0 and maxsi, resp.
122 if val(vptr(i)) = 0 then call putsbb(yes);
123 elseif val(vptr(i)) = maxsi then call putsbb(no);
124 else call ermsg(89, i);
125 end if;
126
127 else
128 do j = 0 to vlen(i)-1;
129 call putsbi(val(vptr(i)+j));
130 end do;
131 end if;
132
133 putbhdr(bt_tuple, 1)
134
135 else
136 call putsbb(no); $ has_value_ in setl.opt = false
137 end if;
138
139 putbhdr(bt_tuple, 1)
140 end do;
141$
142$ block table
143$
144 call putsbi(blocktab_org); call putsbi(blocktabp);
145
146 do i = blocktab_org+1 to blocktabp;
147 call putsbi(b_first(i));
148 end do;
149$
150$ code table
151$
152 call putsbi(codetab_org); call putsbi(codetabp);
153
154 do i = codetab_org+1 to codetabp;
155 putbhdr(bt_tuple, 0)
156
157 call putsbi(opcode(i));
158 call putsbi(blockof(i));
159 call putsbi(next(i));
160 call putsbi(cflag(i));
161 call putsbi(sflag(i));
162
163 call putsbi(nargs(i));
164
165 putbhdr(bt_tuple, 0)
166
167 do j = 1 to nargs(i);
168 call putsbi(argtab(argp(i)+j));
169 end do;
170
171 putbhdr(bt_tuple, 1)
172
173 putbhdr(bt_tuple, 1)
174 end do;
175
176 ..sq1
177
178
179 end subr sputtb;
1 .=member putsbi
2 subr putsbi(arg);
3
4$ this routine writes out the argument as a setl binary integer
5$ to the setl q1 file.
smfc 12$
smfc 13$ n.b. the code here corresponds to the code of the putintli and putbli
smfc 14$ routines in the run-time library. it does depend on the exact repre-
smfc 15$ sentation of setl long integers. strictly speaking, we simulate the
smfc 16$ sequence
smfc 17$
smfc 18$ put_intval(spec, arg); putbli(sq1_file, spec);
smfc 19$
smfc 20$ without using the heap.
6
7
8 .+sq1.
9
10 size arg(ws); $ integer argument
11 size putbhdrblk(ws); $ binary header block
smfc 21 size putbdatblk(ws); $ binary data block
12
13
smfd 11 if 0 <= arg & arg <= bh_val_max then
smfd 12
smfd 13 putbhdr(bt_sint, arg);
smfd 14
smfd 15 elseif iabs(arg) < li_dbas then
smfc 23
smfc 24 putbhdr(bt_int, 1)
smfc 25
smfc 26 putbdatblk = 0;
smfc 27 .f. 1, dds, putbdatblk = iabs(arg); $ li_ddigit
smfc 28 .f. ws, 1, putbdatblk = (arg < 0); $ li_sign
smfc 29 putbdat(putbdatblk)
smfc 30
smfc 31 else
smfc 32 putbhdr(bt_int, 2)
smfc 33
smfc 34 putbdatblk = 0;
smfc 35 .f. 1, dds, putbdatblk = iabs(arg); $ li_ddigit
smfc 36 .f. ws, 1, putbdatblk = (arg < 0); $ li_sign
smfc 37 putbdat(putbdatblk)
smfc 38
smfc 39 putbdatblk = 0;
smfc 40 .f. 1, dds, putbdatblk = .f. dds+1, ws-dds-1, iabs(arg);
smfc 41 putbdat(putbdatblk)
smfc 42 end if;
16
17 ..sq1
18
19
20 end subr putsbi;
1 .=member putsbr
2 subr putsbr(arg);
3
4$ this routine writes out the argument as a setl binary real
5$ to the setl q1 file.
6
7
8 .+sq1.
9
10 size arg(ws); $ real argument
11 size putbhdrblk(ws); $ binary header word
12
13
14 putbhdr(bt_real, 1)
15 putbdat(arg)
16
17
18 ..sq1
19
20 end subr putsbr;
1 .=member putsbb
2 subr putsbb(arg);
3
4$ this routine writes a little flag as a setl boolean onto the
5$ setl q1 file
6
7
8 .+sq1.
9
10 size arg(1); $ little boolean
11 size putbhdrblk(ws); $ binary header block
12 size putbdatblk(ws); $ binary data block
13
14
15 putbdatblk = arg; $ widen to full ws bitstring
16
17 putbhdr(bt_bool, 1)
18 putbdat(putbdatblk)
19
20
21 ..sq1
22
23 end subr putsbb;
1 .=member putsbs
2 subr putsbs(arg);
3
4$ this routine writes out the character string specified by the
5$ argument as a setl binary string to the setl q1 file.
6$
7$ the argument is a symbol table pointer with the following
8$ interpretion:
9$
10$ arg = 0: write a null string
11$
12$ arg < 0: write the string from val(-arg)
13$
14$ arg > 0: for non-internal variables, write their name;
15$ otherwise, write a null string.
16
17
18 .+sq1.
19
20 size arg(ws); $ string argument
21
22 size putbhdrblk(ws); $ binary header block
23 size str(sds_sz); $ string
24 size org(ps); $ string origin
25 size len(ps); $ number of characters in string
26 size words(ps); $ number of words in the string
27 size j(ps); $ loop index
28
29 size namsds(sds_sz); $ converts names entry to sds string
30
31
32 if arg > 0 then $ write the name of the variable
33 if ^ is_internal(arg) then
34 str = namsds(name(arg));
35 else
36 str = '';
37 end if;
38
39 elseif arg < 0 then $ write the string constant from val(-arg)
40 words = vlen(-arg);
41
42 do j = 0 to words - 1;
43 .f. 1+j*ws, ws, str = val(vptr(-arg)+j);
44 end do;
45
46 else $ arg = 0: write a null string
47 str = '';
48 end if;
49
50 len = slen str;
51
52 if len then
53 words = ((len-1) / cpw) + 1;
54 else
55 words = 0;
56 end if;
57
58 putbhdr(bt_string, len)
59
60 org = sorg str;
61 sorg str = 0;
62 slen str = 0;
63
64 do j = 1 to words;
65 write sq1_file, (.f. org-j*ws, ws, str);
66 end do;
67
68 macdrop(putbhdr)
69 macdrop(putbdat)
70
71
72 ..sq1
73
74 end subr putsbs;
1 .=member binder
2 subr binder;
3
4$ this unit is called at the start of compilation. it merges the
5$ results of all previous compilations into the new q1 file.
6
7$ the following nameset contains globals used to bind separate
8$ compilations:
9
10 nameset bind;
11
12$ the array 'smap' maps pointers to the symbol table contained
13$ on 'bind_file' into pointers to the symbol table contained in
14$ core.
15
16 +* smap(i) =
suna 51 .+r32 .f. 1 + mod(i-1, 2)*16, 16, a_smap((i-1)/2+1)
suna 52 .+r36 .f. 1 + mod(i-1, 2)*18, 18, a_smap((i-1)/2+1)
17 .+s66 .f. 1 + mod(i-1, 4)*15, 15, a_smap((i-1)/4+1)
23 **
24
25 size a_smap(ws);
26
suna 53 .+r32 dims a_smap(symtab_lim/2);
suna 54 .+r36 dims a_smap(symtab_lim/2);
27 .+s66 dims a_smap(symtab_lim/4);
33
34$ the array 'fmap' serves the same function for formtab.
35
36 +* fmap(i) =
suna 55 .+r32 .f. 1 + mod(i, 2)*16, 16, a_fmap((i)/2+1)
suna 56 .+r36 .f. 1 + mod(i, 2)*18, 18, a_fmap((i)/2+1)
37 .+s66 .f. 1 + mod(i, 4)*15, 15, a_fmap(i/4+1)
43 **
44
45 size a_fmap(ws);
46
suna 57 .+r32 dims a_fmap(formtab_lim/2);
suna 58 .+r36 dims a_fmap(formtab_lim/2);
47 .+s66 dims a_fmap(formtab_lim/4);
53
54
55$ the binding routines also used three pointers into each array xxx:
56
57$ x_org: first entry in old table being read in
58$ x_last: last entry in old table being read in
59$ x_bias: see below
60
61$ the high order end of each array is used as a temporary buffer
62$ to store the slice of the array being read in from the old q1 file.
63$ the old table entry xxx(i) is temporarily stored at xxx(i+x_bias).
64
65 size n_org(ps), $ pointers for names
66 n_last(ps),
67 n_bias(ps);
68
69 size v_org(ps), $ pointers for val
70 v_last(ps),
71 v_bias(ps);
72
73 size s_org(ps), $ pointers for symtab
74 s_last(ps),
75 s_bias(ps);
76
77$ pointers for formtab. since formtab is zero origined, f_org
78$ can take on a value of -1. this means that it must be sized ws.
79 size f_org(ws),
80 f_last(ps),
81 f_bias(ps);
82
83 size m_org(ps), $ pointers for mttab
84 m_last(ps),
85 m_bias(ps);
86
87$ codetab, argtab, and blocktab are always read in their entirety,
88$ and do not need special pointers.
89
90 end nameset;
91
92 size ret(ws); $ return code from namesio
93
94 if bind_title .sne. '' then
95 until filestat(bind_file, end);
96 call readpg;
97 end until;
98 end if;
99
100 if ibnd_title .sne. '' then
101 until filestat(ibnd_file,end);
102 bind_title = '0';
103 get ibnd_file :bind_title,a(filenamlen),skip;
104 if ( ' ' .in. bind_title )
105 slen bind_title = ( ' ' .in. bind_title ) - 1;
106 file bind_file access = read, title = bind_title;
107 if filestat(bind_file,access) = 0 then
108 put, column(7), 'attempt to open file '
109 :bind_title, a, '.', skip(1);
110 call ermsg(87, 0);
111 else
112 call namesio(bind_file,ret,bind_title,filenamlen);
113$ get true name of file included for message
bnda 138 if (et_flag) put ,'reading from file ' :bind_title,a,skip;
116 .+s66 rewind bind_file; $ force rewinding
117 until filestat(bind_file,end);
118 call readpg;
119 end until;
120 file bind_file access=release;
121 end if;
122 end until;
123 end if;
124
125
126$ reinitialize unit name and type, etc.
127 curunit = 0;
128 unit_type = unit_sys;
129
130 curmemb = 0;
131 currout = 0;
132
133
134 end subr binder;
1 .=member readpg
2 subr readpg;
3
4$ this routine reads a single page of q1 from 'old_file'. this
5$ is done in the following steps:
6
7$ 1. save the current values of symtabp, etc. so that we are
8$ ready to restore them at the end of the page.
9
10$ 2. read the unit type and name. determine whether we have seen this
11$ unit before.
12
13$ 3. read each of the q1 tables into the high order end of the
14$ corresponding array.
15
16$ 4. hash the entries at the high order end of symtab into the low
17$ order end.
18
19$ 5. repeat (3) for formtab.
20
21$ 6. adjust the new argtab entries to point to the adjusted symtab
22$ entries.
23
24$ 7. adjust the new val entries for sets, tuples, etc. to point to
25$ the new symtab entries.
26
27$ 8. if we have not seen this unit before, write out the new page
28
29$ 9. if this is the end of a procedure or member, release the space
30$ used by local variables.
31
32 access bind;
33
34 size nprocs(ps), $ number of procs in member
35 nseen(ps), $ number seen so far
36 membtype(ps), $ unit type of current member
37 str(sds_sz), $ name of unit as sds
38 p(ps), $ symtab pointer
39 n(ps); $ number of routines
40
41$ we read each table slice into the high order end of the
42$ corresponding table. when we read a slice of the array xxx
43$ we set three variables:
44
45$ x_org: orign of slice in predefined q1 table
46$ x_last: end of slice in predefined table
47$ x_bias: see below
48
49$ xxx(i) is always read into xxx(i+x_bias).
50
51 +* getr(ara, ptr, lim, org, last, bias) =
52 size zzza(ws), $ length of slice
53 zzzb(ws); $ origin of temporary buffer area
54
55 read bind_file, org, last;
56
57 zzza = last-org;
58 zzzb = lim-zzza;
59
60 bias = zzzb-org;
61 if (zzzb < ptr) call overfl('getr');
62
63 if (zzzb < lim) read bind_file, ara(zzzb+1) to ara(lim);
64 **
65
66$ the slices for codetab, argtab, and blocktab always have org = 0.
67$ we read them directly into the low order end of the appropriate
68$ tables.
69
70 +* getr1(ara, org, last) =
71 read bind_file, org, last;
72 if (org < last) read bind_file, ara(org+1) to ara(last);
73 **
74
75 push3(namesp, symtabp, valp); $ save table pointers
76
77$ read header information.
78 read bind_file, unit_type, str, p, n, ustmt_count, estmt_count;
79
80 if filestat(bind_file, end) ! unit_type = unit_end then
81 free_stack(3);
82 return;
83
84 elseif unit_type = unit_sys then $ standard prelude
85 curunit = 0;
86 curmemb = 0;
87
88 else
bnda 139 if (et_flag) put ,'binding ' :str,a ,skip;
90 curunit = hashst(str);
91
92 if unit_type = unit_proc then
93 currout = curunit;
94 else
95 curmemb = curunit;
96 membtype = unit_type;
97 nprocs = n;
98 nseen = 0;
99 end if;
100 end if;
101
102$ read the tables
103
104
105 getr(mttab, mttabp, mttab_lim, m_org, m_last, m_bias)
106 getr(formtab, formtabp, formtab_lim, f_org, f_last, f_bias)
107 getr(names, namesp, names_lim, n_org, n_last, n_bias)
108 getr(val, valp, val_lim, v_org, v_last, v_bias)
109 getr(symtab, symtabp, symtab_lim, s_org, s_last, s_bias)
110
111 getr1(blocktab, blocktab_org, blocktabp)
112 getr1(argtab, argtab_org, argtabp)
113 getr1(codetab, codetab_org, codetabp)
114
115$ hash in symtab and formtab entries
116 call msyms;
117 call mforms;
118 call adjarg;
119 call adjvls;
120
121 if unit_type = unit_sys then $ reset pointers and return
122 call reset;
123 return;
124
125 else $ write tables if not yet seen
126
127 if ^ is_seen(curunit) then
128 is_seen(curunit) = yes;
129 call gputtb;
130 end if;
131
132 if unit_type = unit_proc then $ clear local variables
133 call reset;
134 nseen = nseen + 1;
135
136 if nseen = nprocs then $ clear symbols for member
137 unit_type = membtype;
138 call reset;
139 end if;
140 end if;
141 end if;
142
143
144 macdrop(getr)
145 macdrop(getr1)
146
147
148 end subr readpg;
1 .=member msyms
2 subr msyms;
3
4$ hash the symtab entries we have just read from bind_file into
5$ symtab.
6
7 access bind;
8
11 size old(ps), $ pointer to old symtab
12 new(ps), $ pointer to new symtab
13 temp(ps); $ pointer to temporary location in symtab
14 size v_new(ps); $ pointer to new val entry
15 size v_temp(ps); $ pointer to temporary val entry
16 size v_len(ps); $ length of val entry
bnda 140 size f_temp(ps); $ pointer to temporary form table entry
bnda 141 size f_new(ps); $ pointer to temporary form table entry
bnda 142 size hashc(ws); $ hash code
bnda 143 size indx(ps); $ index into hash table
bnda 144 size j(ps); $ loop counter
bnda 145 size k(ps); $ loop counter
17
18 size nam(ps), $ pointer to names entry
19 words(ps); $ length of names entry
20
21 size ara(ws); $ array for new names entry
22 dims ara((toklen_lim-1)/cpw+1);
23
24 do old = s_org+1 to s_last;
25 temp = old + s_bias;
26 nam = name(temp);
27
28 if nam = 0 then $ generated name
bnda 146 f_temp = form(temp);
bnda 147 if f_temp > f_org then $ not yet merged.
bnda 148 f_temp = f_temp + f_bias; $ index unmerged table.
bnda 149 else
bnda 150 f_temp = fmap(f_temp); $ index merged table.
bnda 151 end if;
bnda 152 if is_ftup(f_temp) ! is_fset(f_temp) then
bnda 153 $ hash the value in the old symbol table.
bnda 154 $ first compute the hash code for the constant.
bnda 155 hashc = 0;
bnda 156 v_temp = vptr(temp) + v_bias;
bnda 157 do j = v_temp to v_temp+vlen(temp)-1;
bnda 158 hashc = hashc .ex. smap(val(j));
bnda 159 end do j;
bnda 160 hashc = (.f. 1, ws/2, hashc) .ex.
bnda 161 (.f. ws/2+1, ws/2, hashc);
bnda 162
bnda 163 $ then search the clash list for this hash code to see
bnda 164 $ whether another set (or tuple) with the same value
bnda 165 $ exists.
bnda 166
bnda 167 indx = mod(hashc, heads_lim)+1;
bnda 168 new = heads(indx);
bnda 169 while new ^= 0;
bnda 170 until 1; $ exit when not this symtab entry.
bnda 171 if (name(new) ^= 0) quit until 1;
bnda 172
bnda 173 f_new = form(new); $ get form of 'new'.
bnda 174 if is_local(new) then $ form not yet mapped.
bnda 175 if f_new > f_org then $ index temp table.
bnda 176 f_new = f_new + f_bias;
bnda 177 else $ index merged table.
bnda 178 f_new = fmap(f_new);
bnda 179 end if;
bnda 180 end if;
bnda 181 if (is_fset(f_temp) ^= is_fset(f_new)) quit;
bnda 182 if (is_ftup(f_temp) ^= is_ftup(f_new)) quit;
bnda 183
bnda 184 if (vlen(new) ^= vlen(temp)) quit until 1;
bnda 185 v_new = vptr(new);
bnda 186 if is_local(new) then $ val not yet mapped.
bnda 187 do k = 0 to vlen(temp)-1;
bnda 188 if smap(val(v_temp+k)) ^=
bnda 189 smap(val(v_new+k)) then
bnda 190 quit until 1;
bnda 191 end if;
bnda 192 end do k;
bnda 193 else
bnda 194 do k = 0 to vlen(temp)-1;
bnda 195 if (smap(val(v_temp+k)) ^=
bnda 196 val(v_new+k)) quit until 1;
bnda 197 end do k;
bnda 198 end if;
bnda 199 $ found a matching entry: return it.
bnda 200 smap(old) = new;
bnda 201 cont do old;
bnda 202
bnda 203 end until 1;
bnda 204 new = link(new);
bnda 205 end while;
bnda 206
bnda 207 new = getsym(0); $ generate new entry.
bnda 208 link(new) = heads(indx); $ add to clash list.
bnda 209 heads(indx) = new;
bnda 210
bnda 211 else
bnda 212 new = getsym(0);
bnda 213 end if;
30 else
31 words = n_sorg(nam + n_bias)/ws;
32
33 do j = 1 to words;
34 ara(j) = names(nam + n_bias - 1 + j);
35 end do;
36
37 new = hash(ara, words);
38 end if;
39
40 smap(old) = new;
41
42$ see if the name has already been seen in another unit. there are
43$ three possibilities:
44
45$ 1. we are processing the current unit for the second time.
46$ this will be true if we are processing the system unit
47$ (which is written out in every compilation) or is
48$ is_seen(curunit) = yes.
49
50$ there are two possibilities here:
51
52$ a. the name is a global base. in this case there are two
53$ formtab entries for the base: one in the old part of
54$ the form table, and one in the new unit we are reading in.
55$ we adjust fmap so that it sends the new form into the old one.
56
57$ b. otherwise we go on to the next symbol.
58
59$ 2. the name is itself a member. go on to the next symbol.
60
61$ 3. otherwise the same name is used in two conflicting scopes,
62$ and we issue an error message.
63
64 if ^ is_local(new) then
65 if unit_type = unit_sys ! is_seen(curmemb) then
66 if (is_base(new)) fmap(form(temp)) = form(new);
bnda 214 if (is_floc(form(new))) fmap(form(temp)) = form(new);
67 cont;
68
69 elseif is_memb(new) then
70 cont;
71
72 else
73 call ermsg(2, new);
74 cont;
75 end if;
76 end if;
77
78 if vptr(temp) ^= 0 & alias(temp) = 0 then
79 v_new = valp+1;
80 v_temp = vptr(temp) + v_bias;
81 v_len = vlen(temp);
82
83 valp = valp + v_len;
84 if (valp > v_org + v_bias) call overfl('val');
85
86 do j = 0 to v_len-1;
87 val(v_new + j) = val(v_temp + j);
88 end do;
89
90 vptr(new) = v_new;
91 vlen(new) = v_len;
92 end if;
93
94 form(new) = form(temp);
95 tprev(new) = tprev(temp);
96 tlast(new) = tlast(temp);
97
98 is_mode(new) = is_mode(temp);
99 is_perf(new) = is_perf(temp);
100 is_decl(new) = is_decl(temp);
101 is_repr(new) = is_repr(temp);
102 is_temp(new) = is_temp(temp);
103 is_stk(new) = is_stk(temp);
104 is_read(new) = is_read(temp);
105 is_write(new) = is_write(temp);
106 is_param(new) = is_param(temp);
107 is_store(new) = is_store(temp);
108 is_init(new) = is_init(temp);
109 is_avail(new) = is_avail(temp);
110 $ nb. is_seen may neither be copied from the temporary entry,
111 $ nor reset.
112 is_back(new) = is_back(temp);
113 is_rec(new) = is_rec(temp);
114 end do;
115
116 do old = s_org+1 to s_last;
117 temp = alias(old + s_bias);
118 if temp ^= 0 then
119 new = smap(old); temp = smap(temp);
120
121 alias(new) = temp;
122
bnda 215 if vptr(old + s_bias) ^= 0 then $ copy val ptr and len.
bnda 216 vptr(new) = vptr(temp);
bnda 217 vlen(new) = vlen(temp);
bnda 218 end if;
125 end if;
126 end do;
127
128
129 end subr msyms;
1 .=member mforms
2 subr mforms;
3
4$ this routine reads in the old formtab. we read one entry at
5$ a time and hash it in.
6
7 access bind;
8
9 size n(ps), $ number of entries
10 j(ps), $ loop index
11 tp(ps), $ type code
12 org(ps),$ origin in mttab
13 len(ps),$ length of mttab entry
14 b(ps); $ base name
15
16 size old(ps), $ old formtab pointer
17 new(ps), $ new formtab pointer
18 temp(ps); $ temporary location at high end of formtab
19
20 do old = f_org+1 to f_last;
21
22 if old <= f_max then $ standard type f_xxx
23 fmap(old) = old;
24 cont;
25 end if;
26
27 temp = old + f_bias;
28
29$ suppose 'b' is a global base. then the unit containing 'b'
30$ may be read in more than once. for example, the 'bind' file
31$ may contain the results of several compilations, each of
32$ which contains a copy of the directory which declares 'b'.
33$ each time we read in the directory we must give 'b' the same
34$ form.
35
36$ when 'msyms' read in the symbol table it checked each
37$ base 'b' to see whether it was seeing it for the second time.
38$ if so, if set 'fmap(new entry) = form(old entry)'. if it did
39$ this then we go on to the next formtab entry.
40
41 if (is_fbase(temp) & fmap(old) ^= 0) cont;
bnda 219 if (is_floc(temp) & fmap(old) ^= 0) cont;
42
43$ otherwise build a new formtab entry
44 countup(formtabp, formtab_lim, 'formtab');
45
46 formtab(formtabp) = formtab(temp);
47 ft_link(formtabp) = 0;
bnda 220 ft_deref(formtabp) = 0;
48
49$ handle procedures and mixed tuples specially
50 tp = ft_type(formtabp);
51
52 if tp = f_mtuple ! tp = f_proc then
53 ft_elmt(formtabp) = mttabp;
54
55 org = ft_elmt(temp) + m_bias;
56 len = ft_lim(formtabp);
57
58 do j = 1 to len; $ adjust pointers
59 countup(mttabp, mttab_lim, 'mttab');
60 mttab(mttabp) = fmap(mttab(org+j));
61 end do;
62
63
64 fmap(old) = hashf2(0); $ hash in form
65
66 else $ doesnt use mttab
bnda 221 ft_elmt(formtabp) = fmap(ft_elmt(formtabp));
bnda 222
bnda 223 if is_fbase(formtabp) = no then
bnda 224 ft_dom(formtabp) = fmap(ft_dom(formtabp));
bnda 225 ft_im(formtabp) = fmap(ft_im(formtabp));
bnda 226 ft_imset(formtabp) = fmap(ft_imset(formtabp));
bnda 227 ft_base(formtabp) = fmap(ft_base(formtabp));
bnda 228 end if;
72
73 if is_frem(formtabp) then
74 ft_tup(formtabp) = fmap(ft_tup(formtabp));
75 end if;
76
bnda 229 if is_floc(formtabp) ! is_fbase(formtabp) then
bnda 230 ft_deref(formtabp) = formtabp;
78 fmap(old) = formtabp;
79 else
80 fmap(old) = hashf1(0);
81 end if;
82 end if;
83
84 end do;
85
86
87 end subr mforms;
1 .=member adjarg
2 subr adjarg;
3
4$ adjust the pointers from argtab and blocktab to symtab
5
6 access bind;
7
8 size j(ps); $ loop index
9
10 do j = 1 to argtabp;
11 argtab(j) = smap(argtab(j));
12 end do;
13
14 do j = 1 to blocktabp;
15 b_rout(j) = smap(b_rout(j));
16 end do;
17
18
19 end subr adjarg;
1 .=member adjvls
2 subr adjvls;
3
4$ this routine iterates over symtab, reseting the form fields
5$ to their new values then updating 'val' entries.
6
7
8 access bind;
9
10 size old(ps), $ old symtab pointer
11 new(ps); $ new symtab pointer
12
13 do old = s_org+1 to s_last;
14 new = smap(old);
15
16 if (^ is_local(new)) cont;
17
18 form(new) = fmap(form(new));
bnda 231
bnda 232 if (vptr(new) = 0) cont do; $ no val entry.
bnda 233 if (alias(new) ^= 0) cont do; $ will be mapped with alias.
bnda 234
bnda 235 call adjval(new); $ adjust val entry.
bnda 236
20 end do;
21
22
23 end subr adjvls;
1 .=member adjval
2 subr adjval(sym);
3
4$ this routine adjusts the value of a symtab entry. it is essentially
5$ a big jump on the type of the entry.
6
7 access bind;
8
9 size sym(ps); $ symbol to be adjusted
10
11 size ptr(ps), $ its vptr
12 len(ps); $ its vlen
13
14 size j(ps), $ loop index
15 org(ps), $ origin in val
16 n(ps); $ length of entry
17
18 access bind;
19
20 ptr = vptr(sym);
21 len = vlen(sym);
22
23 if (ptr = 0) return; $ no val entry
24
25 go to case(symtype(sym)) in f_min to f_max;
26
27
28/case(f_gen)/
29
30/case(f_sint)/
31
32/case(f_sstring)/
33
34/case(f_atom)/
35
36/case(f_latom)/
37
38/case(f_int)/
39
40/case(f_string)/
41
42/case(f_real)/
43
44/case(f_lab)/
45
46/case(f_ureal)/
47
48/case(f_uint)/
49
50/case(f_error)/
51
52 return;
53
54
55/case(f_elmt)/ $ element
56
57 val(ptr) = smap(val(ptr));
58
59 return;
60
61
62/case(f_tuple)/
63
64/case(f_ptuple)/
65
66/case(f_ituple)/
67
68/case(f_rtuple)/
69
70/case(f_mtuple)/
71
72/case(f_uset)/
73
74/case(f_umap)/
75
76/case(f_lset)/
77
78/case(f_rset)/
79
80/case(f_lmap)/
81
82/case(f_rmap)/
83
84/case(f_lpmap)/
85
86/case(f_limap)/
87
88/case(f_lrmap)/
89
90/case(f_rpmap)/
91
92/case(f_rimap)/
93
94/case(f_rrmap)/
95
96/case(f_base)/
97
98/case(f_pbase)/
99
100/case(f_uimap)/
101
102/case(f_urmap)/ $ sets, tuples, and bases
103
104 do j = 0 to len-1;
105 val(ptr+j) = smap(val(ptr+j));
106 end do;
107
108 return;
109
110
111/case(f_proc)/ $ procedures and functions
112
113 val(ptr) = smap(val(ptr)); $ temporary for returned value
114
115 return;
116
117
118/case(f_memb)/ $ members
119
120 org = ptr; $ zero-th library
121 n = val(org);
122
123 do j = 1 to n;
124 val(org+j) = smap(val(org+j));
125 end do;
126
127 org = org + n + 1; $ zero-th reads variable
128 n = val(org);
129
130 do j = 1 to n;
131 val(org+j) = smap(val(org+j));
132 end do;
133
134 org = org + n + 1; $ zero-th writes variable
135 n = val(org);
136
137 do j = 1 to n;
138 val(org+j) = smap(val(org+j));
139 end do;
140
141
142 org = org + n + 1; $ zero-th exports variable
143 n = val(org);
144
145 do j = 1 to n;
146 val(org+j) = smap(val(org+j));
147 end do;
148
149 org = org + n + 1; $ zero-th 'imported' variable
150 n = val(org);
151
152 do j = 1 to n;
153 val(org+j) = smap(val(org+j));
154 end do;
155
156 return;
157
158
159 end subr adjval;
1 .=member reset
2 subr reset;
3
4$ this routine deletes some of the table entries for the page
5$ we have just merged into the symbol table.
6
7$ as usual we save the values of various table pointers at the
8$ start of each unit. usually we call 'greset' at the end of
9$ the unit to reset the pointers to their saved values. this
10$ deletes all the table entries for the unit.
11
12$ when we read in a unit from the bind_file we must keep
13$ certain entries in the symbol table. this is done by
14$ branching on the type of the current unit
15$ and taking the appropriate action. for procedures and
16$ modules we simply call 'greset'. for libraries and
17$ directories we take special actions.
18
19 size j(ps), $ loop index
20 p(ps); $ symbol table pointer
21
22$ jump on the type of the current unit and reset symtabp, etc.
23 go to case(unit_type) in unit_min to unit_max;
24
25/case(unit_sys)/ $ system unit
26
27$ the only new entries added to symtab when we bind a copy of
28$ the system unit are a series of internally generated constants
29$ which are never used. we simply restore the pointers to their
30$ stacked values.
31
32 pop3(valp, symtabp, namesp);
33
34 names_org = namesp;
35 symtab_org = symtabp;
36 val_org = valp;
37
38 return;
39
40
41/case(unit_lib)/ $ library
42
43$ reset the various pointers to the start of the library then
44$ advance them so that we keep all exported procedures and there
45$ return variables.
46
47 pop3(valp, symtabp, namesp);
48
49$ note that in the loop which follows symtabp points to the last
50$ saved entry. we examine symtab(symtabp+1) to see if it should
51$ also be saved.
52
53$ we use the following macro to adjust symtabp, namesp, and valp.
54
55 +* keep_symbol =
56 size zzza(ps), $ misc pointers
57 zzzb(ps),
58 zzzc(ps);
59
60 symtabp = symtabp + 1; $ adjust symtabp
61
62$ get a pointer to the last word of the names entry and see if
63$ it goes beyond namesp.
64
65 zzza = name(symtabp); $ names pointer
66 zzzb = n_sorg(zzza)/ws; $ number of words in name
67 zzzc = zzza + zzzb - 1; $ last word in names entry
68
69 if (namesp < zzzc) namesp = zzzc;
70
71 if vptr(symtabp) ^= 0 then $ adjust valp
72 zzza = vptr(symtabp) + vlen(symtabp) - 1;
73 if (valp < zzza) valp = zzza;
74 end if;
75 **
76
77 while 1;
78 if is_proc(symtabp+1) then $ exported proc
79 keep_symbol;
80
81$ skip variable used to return procedure value
82 keep_symbol;
83
84 elseif is_memb(symtabp+1) then $ referenced library
85 keep_symbol;
86
87 else
88 quit;
89 end if;
90 end while;
91
92 names_org = namesp; $ reset origins
93 symtab_org = symtabp;
94 val_org = valp;
95
96$ delete freed symtab entries from their clash lists. note that the f
97$ freed entries are at the beginning of their clash list.
98
99 do j = 1 to heads_lim;
100 p = heads(j);
101
102 while p > symtabp;
103 p = link(p);
104 end while;
105
106 heads(j) = p;
107 end do;
108
109 call incode; $ reinitialize code tables
110
111 return;
112
113 macdrop(keep_symbol)
114
115
116
117/case(unit_dir)/ $ program
118
119$ all symbols remain in symtab
120 names_org = namesp;
121 symtab_org = symtabp;
122 val_org = valp;
123
124 free_stack(3);
125 return;
126
127/case(unit_prog)/ $ program
128
129/case(unit_mod)/ $ module
130
131/case(unit_proc)/ $ procedure
132
133 call greset;
134 return;
135
136/case(unit_end)/ $ end of compilation
137
138 return;
139
140
141 macdrop(smap)
142 macdrop(fmap)
143
144 end subr reset;
1 .=member isfbsd
2 fnct isfbsd(fm);
3
4$ this routine does a recursive test to check whether a form 'fm'
5$ is based.
6
7 size fm(ps); $ top level form
8
9 size isfbsd(1); $ flag returned
10
11 size savep(ps), $ saved astack pointer
12 fm1(ps), $ inner level form
13 tp(ps), $ ft_type
14 j(ps); $ loop index
15
16 savep = asp;
17 push1(fm);
18
19 until savep = asp;
20 pop1(fm1);
21
22 tp = ft_type(fm1);
23
24 if tp = f_elmt then
25 isfbsd = yes;
26 asp = savep;
27
28 return;
suna 59
suna 60 elseif tp = f_gen then
suna 61 cont;
29
30 elseif tp = f_mtuple ! tp = f_proc then
31 do j = 1 to ft_lim(fm1);
32 push1(mttab(ft_elmt(fm1)+j));
33 end do;
34
35 elseif ^ is_fprim(fm1) then
36 push1(ft_elmt(fm1));
37 end if;
38
39 end until;
40
41 isfbsd = no;
42
43
44 end fnct isfbsd;
1 .=member ermsg
2 subr ermsg(n, nam);
3
4$ this routine prints all error messages. 'n' is the error number,
5$ and 'nam' is an optional symbol table pointer.
6
7$ error messages have the form:
8$
9$ *** error xxx at line yyy - expect zzz ***
10$
11$ where:
12$
13$ xxx is the error number
14$ yyy is the current line number
15$ zzz is the individual message
16
17$ if 'nam' is non-zero, we print the name of the symbol
18$ table entry after the word 'expect'.
19
20 size n(ps), $ message number
21 nam(ps); $ optional symtab pointer
22
23 size string(sds_sz); $ string for message
24
25$ we begin by jumping on the error number to assign the proper string
26$ to 'string'. we use the following convenience macro:
27
28 +* er(n, str) =
29 /case(n)/ string = str; go to esac;
30 **
31
32
bnda 237 +* max_case = 99 **
34
35 if ( ^ ( 1 <= n & n <= max_case )) n = 0;
36 go to case(n) in 0 to max_case;
37
38 er(00, 'valid error message')
39 er(1, 'to be a constant');
40 er(02, 'not to be a member or procedure name.');
41 er(03, 'to specify a program variable')
42 er(4, 'to be declared only once');
43 er(5, 'to be declared only once');
44 er(6, 'to be repred in proper scope');
45 er(7, 'procedure definition to match declaration');
46 er(8, 'to be declared only once');
47 er(9, 'to be repered only once');
48 er(10, 'to be a mode')
49 er(11, 'to be a base')
50 er(12, 'to be followed by a valid type');
51 er(13, 'valid range set type');
bnda 238 er(14, 'to be a non-negative integer constant')
53 er(15, 'formal parameters to be repred with procedure')
smfb 610 er(16, 'non-zero divisor')
smfb 611 er(17, 'to be an integer constant')
56 er(18, 'legal left hand side');
57 er(19, 'to be a valid left-hand side.');
58 er(20, 'to be a constant set or tuple');
59 er(21, 'to be a label');
60 er(22, 'to be repred consitently with its value');
61 er(23, 'to be defined only once');
62 er(24, 'yield statement in expression block only');
63 er(25, 'to name a procedure or perform block')
64 er(26, 'to be defined')
65 er(27, 'to be a defined statement label')
smfb 612 er(28, 'case tag values to be unique')
67 er(29, 'to be a variable, not a member or procedure name.');
68 er(30, 'to be a numeric constant following unary minus')
69 er(31, 'no long integer denotations');
70 er(32, 'valid real constant');
71 er(33, 'to be defined only once');
72 er(34, 'to be a integer character code following -char-')
73 er(35, 'to be called');
74 er(36, '-exit- to occur in perform block only');
75 er(37, 'module or program header to match header in directory');
76 er(38, 'only one header per module');
77 er(39, 'to be declared in proper scope');
78 er(40, 'procedure definition to match repr');
79 er(41, 'to appear only once in parameter list');
80 er(42, 'valid environment for -continue- or -quit-')
81 er(43, 'to be a procedure');
82 er(44, 'to be read-only');
83 er(45, 'to be a valid member');
84 er(46, 'all members in batch compilation to have same directory');
85 er(47, 'valid debugging option');
86 er(48, 'to be initialized in its own scope');
87 er(49, 'to be initialized only once');
88 er(50, 'constant expression in -init- statement');
89 er(51, 'to have matching repr');
90 er(52, 'to be stacked - conflict with repr');
91 er(53, 'to be read-write');
92 er(54, 'to occur in only one scope');
93 er(55, 'valid type for base');
94 er(56, 'formal parameter on formal base');
95 er(57, 'to appear in -procs- or -exports- list');
96 er(58, 'to appear in -uses- list');
97 er(59, 'only typed objects in mixed tuple');
98 er(60, '-procs- statement to appear outside procedure');
99 er(61, 'to be declared before it is repred');
100 er(62, 'procedure call to have proper number of arguments');
101 er(63, 'valid options for library');
102 er(64, 'to be declared consistently');
103 er(65, 'to be a constant set');
104 er(66, ' - directory name in program statement');
105 er(67, 'to be repred with proper number of arguments');
106 er(68, 'to have two parameters or less');
107 er(69, '-local set(_ b)- to appear in same scope as -base b-');
108 er(70, 'only local objects on plex bases');
109 er(71, 'valid element type for base');
110 er(72, 'valid element type for set or tuple');
111 er(73, 'valid domain type for map');
112 er(74, 'valid image type for map');
113 er(75, 'valid component type for tuple');
114 er(76, 'to be a variable, not a constant or parameter');
115 er(77, 'to be imported from another member');
116 er(78, 'to be precompiled - fatal error');
117 er(79, 'to be a declared global constant or variable.')
118 er(80, 'to be a declared global variable.')
119 er(81, 'to receive non-procedure repr')
120 er(82, 'valid constant. (omega not allowed in set)')
121 er(83, 'to be a constant tuple or om')
122 er(84, 'to have a tuple mode.')
123 er(85, 'valid packed mode: cannot pack -integer 0..n-')
124 er(86, 'to be a valid real denotation');
125 er(87, 'to be able to open bind file');
126 er(88, 'to be initilised by an init stmt because of plex repr')
127 er(89, 'to be a valid constant - compiler error')
128 er(90, 'to appear as the program member in the directory')
129 er(91, 'to appear as a module member in the directory')
130 er(92, 'to name a directory (symbol has been used before)')
131 er(93, 'to name a simple program (symbol has been used before)')
132 er(94, 'to name a library (symbol has been used before)')
133 er(95, 'to name a procedure (symbol has been used before)')
134 er(96, 'to be declared in a -reads- list')
135 er(97, 'to specify a program variable')
smfb 613 er(98, 'legal language construct: -libraries all;- is not legal')
bnda 239 er(99, 'valid integer subrange (0 <= lo <= hi)')
136
137/esac/ $ print error message
138
139 put, skip;
140
141 call contlpr(27, yes); $ start to echo to terminal
142 .+s10 put, '?'; $ emit standard s10 error marker
143 .+s20 put, '?'; $ emit standard s10 error marker
144 put ,'*** error ' :n ,i;
145 if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
146 if (currout ^= 0) put ,'.' :symsds(currout) ,a;
147 if (curmemb ^= 0) put ,'.' :stmt_count ,i;
148 put ,': expect ';
149 if (nam ^= 0) put: symsds(nam), a, x(1);
150
151 if (.len. string = 0) put ,' (missing error text) ';
152 put: string, a, ' ***', skip;
153
154 call contlpr(27, no); $ stop to echo to the terminal
155
156 if unit_type = unit_proc then
157 call emit(q1_error, 0, 0, 0); $ emit error quadruple
158 end if;
159
160 error_count = error_count + 1;
161
162 if error_count > sel then
163 put, skip, '*** semantic error limit exceeded ***', skip;
164 call semtrm;
165
166 elseif 'fatal error' .in. string then
167 call semtrm;
168 end if;
169
170 macdrop(max_case)
171
172
173 end subr ermsg;
1 .=member warn
2 subr warn(n, nam);
3
4$ this routine is similar to ermsg, except that it prints
5$ warnings.
6
7$ warnings have the form:
8
9$ *** warning xxx at line yyy - zzz ***
10
11$ where:
12
13$ xxx is the warning number
14$ yyy is the current line number
15$ nam is a symbol table pointer
16$ zzz is the individual message
17
18$ if 'nam' is non-zero, we print the name of the symbol
19$ table entry after the word 'expect'.
20
21 size n(ps), $ message number
22 nam(ps); $ optional symtab pointer
23
24 size string(sds_sz); $ string for message
25
26$ we begin by jumping on the error number to assign the proper string
27$ to 'string'. we use the following convenience macro:
28
29 +* wa(n, str) =
30 /case(n)/ string = str; go to esac;
31 **
32
33
smfb 614 +* max_case = 07 **
35
36 if ( ^ ( 1 <= n & n <= max_case )) n = 0;
37 go to case(n) in 0 to max_case;
38
39 wa(0, 'expect valid warning message')
40 wa(1, 'has illegal repr if current routine is recursive');
41 wa(2, 'has illegal repr if backtracking is used');
42 wa(3, 'has not yet been compiled');
43 wa(4, 'has not been declared in a -var- statement');
44 wa(5, 'has not been declared in a -repr- statement')
bnda 240 wa(6, 'omega illegal in tuple former (temp. compiler extension)')
smfb 615 wa(7, 'no case tag value matches the type of the case expression')
46
47/esac/ $ print warning
48
49 put, skip;
50
51 call contlpr(27, yes); $ start to echo to the terminal
52 .+s10 put, ':'; $ emit standard s10 warning character
53 .+s20 put, ':'; $ emit standard s10 warning character
54 put ,'*** warning ' :n ,i;
55 if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
56 if (currout ^= 0) put ,'.' :symsds(currout) ,a;
57 if (curmemb ^= 0) put ,'.' :stmt_count ,i;
58 put ,': ';
59 if (nam ^= 0) put: symsds(nam), a, x;
60
61 put: string, a, ' ***', skip;
62
63 call contlpr(27, no); $ stop to echo to the terminal
64
65 macdrop(max_case)
66
67
68 end subr warn;
1 .=member sdump
2 subr sdump;
3
4$ this routine dumps symtab and various related tables.
5
6
7 call symdmp; $ dump symtab
8 call valdmp; $ dump val
9 call fmdump; $ dump formtab
10 call mtdump; $ dump mttab
11
12
13 end subr sdump;
1 .=member symdmp
2 subr symdmp;
3
4$ this routine dumps symtab. the dump is formatted in columns,
5$ with a series of column headings printed at standard intervals.
6
bnda 241 size lines(ps); $ number of lines since last heading
bnda 242 size str(sds_sz); $ symbol name as sds
bnda 243 size j(ps); $ loop counter
10
11
bnda 244 put ,skip(4)
bnda 245 ,'s y m t a b d u m p - ' :symsds(curunit),a ,skip(2);
14
15 lines = lines_max; $ set to force new heading
16
17 do j = 1 to symtabp;
18 lines = lines + 1;
19
20 if lines > lines_max then $ print heading
bnda 246 put ,skip(2)
bnda 247 ,'index name vptr vlen link alias '
bnda 248 ,'form tprev tlast bs md pr pf dc rp tm sk rd '
bnda 249 ,'wr pm st in se av '
bnda 250 ,skip
bnda 251 ,'---------------------------------------------'
bnda 252 ,'---------------------------------------------'
bnda 253 ,'------------------'
bnda 254 ,skip(2);
30
31 lines = 1;
32 end if;
33
34 str = symsds(j);
35 if (.len. str > 10) .len. str = 10;
36
bnda 255 put ,column(001) :j,i
bnda 256 ,column(008) :str,a
bnda 257 ,column(021) :vptr(j),i
bnda 258 ,column(028) :vlen(j),i
bnda 259 ,column(034) :link(j),i
bnda 260 ,column(040) :alias(j),i
bnda 261 ,column(046) :form(j),i
bnda 262 ,column(052) :tprev(j),i
bnda 263 ,column(058) :tlast(j),i
bnda 264 ,column(064) :is_base(j),i
bnda 265 ,column(067) :is_mode(j),i
bnda 266 ,column(070) :is_proc(j),i
bnda 267 ,column(073) :is_perf(j),i
bnda 268 ,column(076) :is_decl(j),i
bnda 269 ,column(079) :is_repr(j),i
bnda 270 ,column(082) :is_temp(j),i
bnda 271 ,column(085) :is_stk(j),i
bnda 272 ,column(088) :is_read(j),i
bnda 273 ,column(091) :is_write(j),i
bnda 274 ,column(094) :is_param(j),i
bnda 275 ,column(097) :is_store(j),i
bnda 276 ,column(100) :is_init(j),i
bnda 277 ,column(103) :is_seen(j),i
bnda 278 ,column(106) :is_avail(j),i
bnda 279 ,skip;
62 end do;
63
64
65 end subr symdmp;
1 .=member valdmp
2 subr valdmp;
3
4$ this routine dumps val in byte format, two entries per line.
5
bnda 280 size rows(ps); $ number of rows in dump
bnda 281 size tab(ps); $ current tab position
bnda 282 size i(ps); $ index over rows
bnda 283 size j(ps); $ index over columns
bnda 284 size indx(ps); $ index over val
12
bnda 285 put ,skip(4)
bnda 286 ,'v a l d u m p - ' :symsds(curunit),a ,skip(2);
15
16 rows = (valp-1)/2 + 1; $ number of rows
17
18 do i = 1 to rows;
19 do j = 1 to 2;
20 indx = (j-1) * rows + i;
bnda 287 tab = 1 + (j-1) * 35;
22
bnda 288 put ,column(tab) :indx,i ,'.' ,column(tab+7) :val(indx),i;
25 end do;
26
bnda 289 put ,skip;
28 end do;
29
30
31 end subr valdmp;
1 .=member fmdump
2 subr fmdump;
3$
4$ this routine dumps the form table.
5$
6 size fm(ps); $ loop index
7 size lines(ps); $ number of lines since last heading
8 size mc(.sds. 5); $ map code name
9 size j1(ps), j2(ps); $ loop indices
10
11 +* lines_max = 20 ** $ number of lines between headings
12
13 +* ftname(tp) = a_ftname(tp+1) ** $ array of form type names
14
15 size a_ftname(.sds. 7);
16 dims a_ftname(f_max+1);
17
18 data ftname(f_gen) = 'gen':
19 ftname(f_sint) = 'sint':
20 ftname(f_sstring) = 'sstring':
21 ftname(f_atom) = 'atom':
22 ftname(f_latom) = 'latom':
23 ftname(f_elmt) = 'elmt':
24 ftname(f_int) = 'int':
25 ftname(f_string) = 'string':
26 ftname(f_real) = 'real':
27 ftname(f_uint) = 'uint':
28 ftname(f_ureal) = 'ureal':
29 ftname(f_ituple) = 'ituple':
30 ftname(f_rtuple) = 'rtuple':
31 ftname(f_mtuple) = 'mtuple':
32 ftname(f_ptuple) = 'ptuple':
33 ftname(f_tuple) = 'tuple':
34 ftname(f_uset) = 'uset':
35 ftname(f_lset) = 'lset':
36 ftname(f_rset) = 'rset':
37 ftname(f_umap) = 'umap':
38 ftname(f_lmap) = 'lmap':
39 ftname(f_rmap) = 'rmap':
40 ftname(f_lpmap) = 'lpmap':
41 ftname(f_limap) = 'limap':
42 ftname(f_lrmap) = 'lrmap':
43 ftname(f_rpmap) = 'rpmap':
44 ftname(f_rimap) = 'rimap':
45 ftname(f_rrmap) = 'rrmap':
46 ftname(f_base) = 'base':
47 ftname(f_pbase) = 'pbase':
48 ftname(f_uimap) = 'uimap':
49 ftname(f_urmap) = 'urmap':
50 ftname(f_error) = 'error':
51 ftname(f_proc) = 'proc':
52 ftname(f_memb) = 'memb':
53 ftname(f_lab) = 'lab';
54
55 size mname(.sds. 4); $ array of ft_mapc names
56 dims mname(ft_max);
57
58 data mname(ft_map) = 'map':
59 mname(ft_smap) = 'smap':
60 mname(ft_mmap) = 'mmap';
61
62
63 put ,skip(4)
64 ,'f o r m t a b d u m p - '
65 :symsds(curunit) ,a
66 ,skip(2);
67
68
69 lines = lines_max; $ set to force new heading
70
71 do fm = 0 to formtabp;
72
73 lines = lines + 1;
74
75 if lines > lines_max then $ print heading
76 put ,skip(2)
77 ,'index type mapc elmt dom im imset '
78 ,'base deref low lim hsh nlt link'
79 ,skip
80 ,'-------------------------------------------'
81 ,'-------------------------------------'
82 ,skip;
83
84 lines = 1;
85 end if;
86
87 put ,column(01) :fm ,i
88 ,column(07) :ftname(ft_type(fm)) ,a;
89
90 if (is_fmap(fm)) put ,column(15) :mname(ft_mapc(fm)) ,a;
91
92 put ,column(20) :ft_elmt(fm) ,i
93 ,column(26) :ft_dom(fm) ,i
94 ,column(32) :ft_im(fm) ,i
95 ,column(38) :ft_imset(fm) ,i
96 ,column(44) :ft_base(fm) ,i
97 ,column(50) :ft_deref(fm) ,i;
98
99 put ,column(56);
100 if (ft_type(fm) = f_sint) put :ft_low(fm) ,i;
101 if (is_floc(fm) ! is_fbase(fm)) put :ft_bit(fm) ,i;
102
103 put ,column(62);
104 if (ft_type(fm) = f_sint) put :ft_lim(fm) ,i;
105 if (ft_type(fm) = f_proc) put :ft_lim(fm) ,i;
106 if (is_ftup(fm) ! is_fbase(fm)) put :ft_lim(fm) ,i;
107 if (is_floc(fm)) put :ft_pos(fm) ,i;
108 if (is_frem(fm) & is_fmap(fm)) put :ft_tup(fm) ,i;
109
110 put ,column(68);
111 if (is_ftup(fm) ! is_fset(fm)) put :ft_hashok(fm) ,i;
112
113 put ,column(72);
114 if (is_ftup(fm) ! is_fset(fm)) put :ft_neltok(fm) ,i;
115
116 put ,column(76) :ft_link(fm) ,i;
117
118 if is_fbase(fm) then
119 put ,column(86);
120 do j1 = f_lset to f_lpmap; if ( ^ is_floc(j1)) cont do j1;
121 put :ft_num(fm, j1) ,i(5);
122 end do;
123 end if;
124
125 put ,skip;
126 end do;
127
128
129 end subr fmdump;
1 .=member mtdump
2 subr mtdump;
3
4$ this routine dumps mttab. we dump mttab as a series of integers,
5$ two abreast.
6
7
8 size lines(ps); $ number of lines since last heading
9 size j1(ps), j2(ps); $ loop indices
10
11 put, skip(4), column(7), 'm t t a b d u m p - ':
12 symsds(curunit), a, skip(2);
13
14 lines = lines_max; $ set to force new heading
15
16 do j1 = 0 to (mttabp+9)/10;
17 lines = lines + 1;
18 if lines > lines_max then
19 put ,skip(2)
20 ,'index ...0 ...1 ...2 ...3 ...4'
21 ,' ...5 ...6 ...7 ...8 ...9'
22 ,skip
23 ,'-------------------------------------------'
24 ,'-----------------------------------'
25 ,skip;
26 lines = 1;
27 end if;
28
29 put :j1 ,i(5) ,'. ';
30
31 do j2 = 0 to 9; if (j1*10+j2 > mttabp) quit do j1;
32 if j1*10+j2 = 0 then put ,x(7); cont do j2; end if;
33 put :mttab(j1*10+j2) ,i(6) ,x;
34 end do;
35
36 put ,skip;
37
38 end do;
39
40 put ,skip(2);
41
42
43 end subr mtdump;
1 .=member q1dump
2 subr q1dump;
3
4$ this routine dumps the q1 code. it essentially iterates over
5$ blocktab, dumping a block at a time. we call 'dblock' to
6$ dump the code for each block.
7
8 size j(ps), $ loop index
9 str(sds_sz); $ routine name as sds
10
11 put, skip(4), column(7), 'c o d e d u m p - ':
12 symsds(curunit), a, skip(2);
13
14 do j = 1 to blocktabp;
15 str = symsds(b_rout(j));
16
17 put, skip(2), $ print heading
18 column(07), 'block: ': j, i,
19 column(20), 'routine: ': str, a,
20 column(40), 'first: ': b_first(j), i;
21
22 call dblock(b_first(j)); $ print instructions
23 end do;
24
25
26 end subr q1dump;
1 .=member prgdmp
2 subr prgdmp;
3
4$ this routine dumps the q1 code from prog_start to prog_end.
5
6 put, skip(4), column(7), 'p r o g r a m d u m p - ':
7 symsds(curunit), a, skip(2);
8
9 put, column(07), 'prog start: ': prog_start, i,
10 column(30), 'prog end: ': prog_end, i,
11 column(07), 'prog_start: ': prog_start, i,
12 column(30), 'prog_end: ': prog_end, i,
13 skip;
14
15 call dblock(prog_start);
16
17
18 end subr prgdmp;
1 .=member dblock
2 subr dblock(first);
3
4$ this routine dumps a list of instructions starting with 'first'.
5$ it iterates along the list until it finds a codetab pointer of 0.
6$ the dump is formatted in columns with headings at standard
7$ intervals.
8
9 size first(ps); $ pointer to start of list
10
11 size p(ps), $ current instruction
12 op(ps), $ current opcode
13 j(ps), $ loop index
14 tab(ps), $ tab position
15 lines(ps), $ lines since last header
16 stats(ps), $ statement counter
17 str(sds_sz); $ symbol as sds
18
19 size opname(.sds. 7); $ names of q1 operators
20 dims opname(q1_maximum);
21
22 data opname(q1_add) = 'add':
23 opname(q1_div) = 'div':
24 opname(q1_slash) = 'slash':
25 opname(q1_exp) = 'exp':
26 opname(q1_eq) = 'eq':
27 opname(q1_ge) = 'ge':
28 opname(q1_lt) = 'lt':
smfb 616 opname(q1_pos) = 'pos':
29 opname(q1_in) = 'in':
30 opname(q1_incs) = 'incs':
31 opname(q1_with) = 'with':
32 opname(q1_less) = 'less':
33 opname(q1_lessf) = 'lessf':
34 opname(q1_max) = 'max':
35 opname(q1_min) = 'min':
36 opname(q1_mod) = 'mod':
37 opname(q1_mult) = 'mult':
38 opname(q1_ne) = 'ne':
39 opname(q1_notin) = 'notin':
40 opname(q1_npow) = 'npow':
41 opname(q1_atan2) = 'atan2':
42 opname(q1_sub) = 'sub':
43 opname(q1_abs) = 'abs':
44 opname(q1_char) = 'char':
45 opname(q1_ceil) = 'ceil':
46 opname(q1_floor) = 'floor':
47 opname(q1_isint) = 'is_int':
48 opname(q1_isreal) = 'is_real':
49 opname(q1_isstr) = 'is_str':
50 opname(q1_isbool) = 'is_bool':
51 opname(q1_isatom) = 'is_atom':
52 opname(q1_istup) = 'is_tup':
53 opname(q1_isset) = 'is_set':
54 opname(q1_ismap) = 'is_map':
55 opname(q1_arb) = 'arb':
56 opname(q1_val) = 'val':
57 opname(q1_dom) = 'dom':
58 opname(q1_fix) = 'fix':
59 opname(q1_float) = 'float':
60 opname(q1_sin) = 'sin':
61 opname(q1_cos) = 'cos':
62 opname(q1_tan) = 'tan':
63 opname(q1_arcsin) = 'arcsin':
64 opname(q1_arccos) = 'arccos':
65 opname(q1_arctan) = 'arctan':
66 opname(q1_tanh) = 'tanh':
67 opname(q1_expf) = 'expf':
68 opname(q1_log) = 'log':
69 opname(q1_sqrt) = 'sqrt':
70 opname(q1_nelt) = 'nelt':
71 opname(q1_not) = 'not':
72 opname(q1_pow) = 'pow':
73 opname(q1_rand) = 'rand':
74 opname(q1_range) = 'range':
75 opname(q1_type) = 'type':
76 opname(q1_umin) = 'umin':
77 opname(q1_even) = 'even':
78 opname(q1_odd) = 'odd':
79 opname(q1_str) = 'str':
80 opname(q1_sign) = 'sign':
81 opname(q1_end) = 'end':
82 opname(q1_subst) = 'subst':
83 opname(q1_newat) = 'newat':
84 opname(q1_time) = 'time':
85 opname(q1_date) = 'date':
86 opname(q1_na) = 'na':
87 opname(q1_set) = 'set':
88 opname(q1_set1) = 'set1':
89 opname(q1_tup) = 'tup':
90 opname(q1_tup1) = 'tup1':
91 opname(q1_from) = 'from':
92 opname(q1_fromb) = 'fromb':
93 opname(q1_frome) = 'frome':
94 opname(q1_next) = 'next':
95 opname(q1_nextd) = 'nextd':
96 opname(q1_inext) = 'inext':
97 opname(q1_inextd) = 'inextd':
98 opname(q1_of) = 'of':
99 opname(q1_ofa) = 'ofa':
100 opname(q1_argin) = 'argin':
101 opname(q1_argout) = 'argout':
102 opname(q1_asn) = 'asn':
103 opname(q1_push) = 'push':
104 opname(q1_free) = 'free':
105 opname(q1_sof) = 'sof':
106 opname(q1_sofa) = 'sofa':
107 opname(q1_send) = 'send':
108 opname(q1_ssubst) = 'ssubst':
109 opname(q1_call) = 'call':
110 opname(q1_goto) = 'goto':
111 opname(q1_if) = 'if':
112 opname(q1_ifnot) = 'ifnot':
smfb 617 opname(q1_bif) = 'bif':
smfb 618 opname(q1_bifnot) = 'bifnot':
smfb 619 opname(q1_ifasrt) = 'ifasrt':
113 opname(q1_case) = 'case':
114 opname(q1_stop) = 'stop':
115 opname(q1_entry) = 'entry':
116 opname(q1_exit) = 'exit':
117 opname(q1_ok) = 'ok':
118 opname(q1_lev) = 'lev':
119 opname(q1_fail) = 'fail':
120 opname(q1_succeed) = 'succeed':
121 opname(q1_asrt) = 'asrt':
122 opname(q1_stmt) = 'stmt':
123 opname(q1_label) = 'label':
124 opname(q1_tag) = 'tag':
125 opname(q1_debug) = 'debug':
126 opname(q1_trace) = 'trace':
127 opname(q1_notrace) = 'notrace':
128 opname(q1_error) = 'error':
129 opname(q1_noop) = 'noop';
130
131
132
133 p = first;
134 lines = lines_max;
135
136 while p ^= 0;
137 lines = lines + 1;
138
139 if lines > lines_max then
140 lines = 1;
141
142 put, skip(2), column(7),
143 'index opcode args',
144 skip, column(7),
145 '----- ------ ----',
146 skip;
147 end if;
148
149 op = opcode(p);
150
151 put, column(07): p, i,
152 column(15): opname(op), a;
153
154 tab = 15;
155
156 do j = 1 to nargs(p); $ print arguments
157 tab = tab + 15;
158
159 if tab > 60 then
160 put, skip;
161 tab = 30;
162 end if;
163
164 if op = q1_stmt then
165 put, column(tab): argn(p, j), i;
166
167 else
168 str = symsds(argn(p, j));
169 if (.len. str > 10) .len. str = 10;
170
171 put, column(tab): str, a;
172 end if;
173
174 end do;
175
176 put, skip;
177 p = next(p);
178 end while;
179
180
181 end subr dblock;
1 .=member csdump
2 subr csdump;
3
4$ this routine dumps cstack. the dump has a format similar to the
5$ symtab dump.
6
7 size j(ps), $ loop index
8 lines(ps), $ number of lines since last heading
9 tp(.sds. 5); $ type of entry
10
11 size tname(.sds. 5); $ array of cs_type names
12 dims tname(cs_max);
13
14 data tname(cs_if) = 'if':
15 tname(cs_case) = 'case':
16 tname(cs_iter) = 'iter':
17 tname(cs_citer) = 'citer':
18 tname(cs_eblk) = 'eblk';
19
20
21 put, skip, column(7), 'c s t a c k d u m p', skip;
22 lines = lines_max;
23
24 do j = 1 to csp;
25 lines = lines + 1;
26
27 if lines > lines_max then
28 lines = 1;
29
30 put, skip(2), column(7),
31 'index type int ldo lstep lterm bvar ',
32 'init/ doing/ while/ where/ body step/ until/',
33 ' term',
34 skip, column(7),
35 ' ',
36 'else end temp jump num tag ',
37 skip, column(7),
38 '-----------------------------------------------',
39 '------',
40 '---------------------------------------------',
41 skip;
42 end if;
43
44 tp = tname(cs_type(j));
45
46 put, column(007): j, i,
47 column(015): cs_type(j), i,
48 column(021): cs_internal(j), i,
49 column(027): cs_ldoing(j), i,
50 column(033): cs_lstep(j), i,
51 column(042): cs_lterm(j), i,
52 column(048): cs_bvar(j), i,
53 column(054): cs_init(j), i,
54 column(060): cs_doing(j), i,
55 column(066): cs_while(j), i,
56 column(074): cs_where(j), i,
57 column(081): cs_body(j), i,
58 column(087): cs_step(j), i,
59 column(093): cs_until(j), i,
60 column(100): cs_term(j), i,
61 skip;
62 end do;
63
64
65 end subr csdump;
1 .=member overfl
2 subr overfl(msg);
3
4$ this routine is called when a compiler array overflows. we issue
5$ an error message and abort.
6
7
8 size msg(.sds. 50); $ message string
9
10
11 put ,skip; $ emit blank line
12
13 call contlpr(27, yes); $ start to echo to terminal
14
15 put, '*** compiler table overflow - ': msg, a;
16
17 if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
18 if (currout ^= 0) put ,'.' :symsds(currout) ,a;
19 if (curmemb ^= 0) put ,'.' :stmt_count ,i;
20
21 put, ' ***', skip;
22
23 call contlpr(27, no); $ stop to echo to terminal
24
25 put, skip;
26
27 if et_flag then
28 call sdump;
29 call q1dump;
30 call csdump;
31 end if;
32
33 call ltlfin(1, 0);
34
35
36 end subr overfl;
1 .=member semtrm
2 subr semtrm;
3
4$ this routine is called for normal termination of the semantic pass
5
6
7 size j(ps); $ loop index
8
9
10$ issue warnings for all missing members.
11
12 do j = 1 to symtabp;
13 if (is_memb(j) & ^ is_seen(j)) call warn(3, j);
14 end do;
15
16$ write 'end of compilation' marker onto q1 file.
17
18 if (.len. sq1_title) then $ write setl q1 trailer
19 call putsbi(unit_end);
20 call putsbs(0); $ null string
21 call putsbi(0);
22 call putsbi(0);
23 call putsbi(0);
24 call putsbi(0);
25
26 else
27 write q1_file, unit_end, '' .pad. toklen_lim, 0, 0, 0, 0;
28 end if;
29
sunb 39 if lcs_flag then $ print statistics
sunb 40 put ,skip; $ emit blank line
31
sunb 41 if error_count = 0 then
sunb 42 put, 'no errors were detected.', skip;
sunb 43 else
sunb 44 put, 'number of errors detected = ': error_count, i, skip;
sunb 45 end if;
37
38 +* put_stat(nam, used, lim) =
39 nam, '(': used, i, ',': lim, i, ')'
40 **
41
42 put ,skip ,'q1 statistics:'
43 ,skip ,put_stat('symtab', symtab_max, symtab_lim ), ', '
44 ,put_stat('val', val_max, val_lim ), ', '
45 ,put_stat('names', names_max, names_lim ), '. '
46 ,skip ,put_stat('formtab', formtab_max, formtab_lim ), ', '
47 ,put_stat('mttab', mttab_max, mttab_lim ), '. '
48 ,skip ,put_stat('codetab', codetab_max, codetab_lim ), ', '
49 ,put_stat('argtab', argtab_max, argtab_lim ), ', '
50 ,put_stat('blocktab', blocktab_max, blocktab_lim), '. '
51 ,skip;
52
53 put ,skip ,'normal termination.' ,skip;
sunb 46
sunb 47 end if;
54
55 file mpol_file access = release; $ close scratch files
56 file xpol_file access = release;
57 file q1_file access = release;
58 file sq1_file access = release;
59 file bind_file access = release;
60 file ibnd_file access=release;
61
62 call ltlterm(2, 0); $ call overlay exec
63
64
65 end subr semtrm;
1 .=member usratp
2 subr usratp;
3
4$ this routine is called by the system in case of an abort. it
5$ dumps various tables.
6
7 put ,skip(2) ,'*** fatal error detected by system '
8 ,'at line ' :stmt_count ,i ,' ***'
9 ,skip(2);
10
11 if ( ^ et_flag) return; $ trace not requested
12
13 call sdump; $ dump symtab
14 call csdump; $ dump cstack
15 call q1dump; $ dump q1
16 call prgdmp; $ dump code from prog_start to prog_end
17
18 stack_trace('full astack dump', asp);
19
20
21 end subr usratp;