Forgot your password?
Document Actions
COD: Code generator; final pass of the SETL compiler.
COD: Code generator; final pass of the SETL compiler. stlcod.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$ cccccccc oooooooo ddddddddd
15$ cccccccccc oooooooooo dddddddddd
16$ cc cc oo oo dd dd
17$ cc oo oo dd dd
18$ cc oo oo dd dd
19$ cc oo oo dd dd
20$ cc oo oo dd dd
21$ cc cc oo oo dd dd
22$ cccccccccc oooooooooo dddddddddd
23$ cccccccc oooooooo ddddddddd
24$
25$
26$ t h e s e t l c o d e g e n e r a t o r
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 final pass of the setl compiler. it translates
41$ the program from an internal form known as q1 into an internal
42$ form known as q2. q2 is then used to drive the code generator.
43$
44$ the input to the code generator is a single q1 file containing
45$ code for all the members in the program.
46$
47$ the q1 file is divided into a series of 'compilation units' or
48$ 'units'. a unit is either:
49$
50$ 1. a member header
51$ 2. a procedure
52$
53$ the code generator processes units one at a time. its output is
54$ a single file containing the initial value of the run time heap
55$ and various auxiliary tables.
56$
57$ the code generator consists of three sections:
58$
59$ 1. initialization
60$
61$ during this phase we initialize various compiler tables
62$ and zero out the heap.
63$
64$ 2. main loop
65$
66$ this phase processes each unit on the q1 file. it
67$ has five parts:
68$
69$ 2.1 gettab
70$
71$ in this section we read the next page of q1.
72$
73$ a page of q1 consists of:
74$
75$ 1. the unit type unit_xxx
76$ 2. a toklen_lim character string giving the name of the unit
77$ 3. a pointer to the symtab entry for the unit
78$ 4. the number of procedures in the current member
79$ 5. the number of the first statement in the unit.
80$ 6. slices of each of the q1 tables.
81$
82$ note that we never write out an entire q1 table. instead we
83$ write out an array slice which contains all the new entries
84$ for the current unit.
85$
86$ each array slice is identified by two pointers:
87$
88$ xxx_org: pointer to zero-th entry
89$ xxxp: pointer to last entry
90$
91$ we read array entries from xxx(xxx_org+1) to xxx(xxxp).
92$
93$ since we do not read in the entire symbol table,
94$ information which we still need from previous
95$ units is not destoyed.
96$
97$ they q1 file ends with a special unit with type unit_end and
98$ items 2-5 above omitted.
99$
100$ 2.2 fixup
101$
102$ this phase performs peephole optimizations and types
103$ temporaries. it is only used if the global optimizer
104$ is unavailable.
105$
106$ 2.3 alloc
107$
108$ this phase performs storage allocation. we assign
109$ each variable, etc. in the current unit a symbol table
110$ address.
111$
112$ 2.4 codegen
113$
114$ this phase emits the actual q2 code for the unit.
115$
116$ 2.5 initevn2
117$
118$ this phase initializes the run time symbol table
119$ entries for constants and static variables in the current
120$ unit. it must be done after code generation so that
121$ values of labels are known.
122$
123$ 3. termination
124$
125$ in this phase we write out the q2 tables.
126
127
128
129$ treatment of temporaries
130$
131$ the semantic pass allocates a unique temporary for each
132$ instruction. both the optimizer and the fixup phase merge
133$ temporaries which are never live at the same time.
134$
135$ in addition to the temporaries which appear explicitly in
136$ the q1 code there are temporaries which must be used for
137$ the results of copies and conversions.
138$
139$ the temporaries used for copies and conversions have a life
140$ of a single instruction. furthermore no instruction requires
141$ more than three of them. for these reason we allocate three
142$ standard temporaries and use them for all copies and
143$ conversions.
144$
145$ the names of these temporaries are given by the macros
146$ t1_, t2_, and t3_. their addresses are given
147$ by addr_temp1, addr_temp2, and addr_temp3 respectively.
148
149
150
151$ data structures
152$ ---------------
153$
154$ the data structures for the code generator are divided into four
155$ groups:
156$
157$ 1. the data structures describing q1. these are essentially the
158$ same data structures used in the semaintic pass except that
159$ a few symbol table fields are reused.
160$
161$ 2. the data structures for q2. these are the run time data
162$ structures. the macros and declarations for the run time
163$ data structures are included verbatum from the source
164$ of the run time library.
165$
166$ 3. miscelaneous globals. each time we iterate over the q1 code,
167$ we unpack the instruction and put information about it
168$ into a series of global variables.
169
170
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. modify 'cnvcon' to reflect that non-primitive denotations are
bnda 6$ hashed by sem.
bnda 7$ module affected: cnvcon.
strb 1
strb 2
strb 3$ 07/24/84 84206 s. freudenberger
strb 4$
strb 5$ 1. modify intab1 so that nelt, of, and sof on f_sstring and f_string
strb 6$ always emit q2_neltic, q2_ofcl, and q2_sofcl, resp.
strb 7$ module affected: initab1.
stra 1
stra 2
stra 3$ 07/24/84 84206 d. shields and s. freudenberger
stra 4$
stra 5$ 1. support short character strings.
stra 6$ modules affected: getsbs, emconv, and incnst.
stra 7$ 2. rename storage class macros sc_xxx to scl_xxx in order to avoid
stra 8$ name conflicts with short character macros.
stra 9$ modules affected: start, alloc, sclass, fsclass, ementry, emexit,
stra 10$ embentry, and embexit.
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, codini, inienv1, and codtrm.
asca 1
asca 2
asca 3$ 03/05/84 84065 d. shields
asca 4$
asca 5$ 1. for s37, support switch ascii=0/1 such that ascii=1 causes
asca 6$ character strings to be generated in the heap in ascii.
asca 7$ this is needed to support nyu ada/ed ada compiler.
asca 8$ modules affected: codini, bldpset, incnst, and initio.
suna 1
suna 2
suna 3$ 03/05/84 84065 s. freudenberger
suna 4$
suna 5$ 1. support motorola mc68000 microprocessor on sun workstation.
suna 6$ modules affected: start and codini.
suna 7$ 2. correct an error test in the shrtct routine to handle the code
suna 8$ resulting from the fixgo routine in the case of a case statement
suna 9$ where one case ends with a refinement and the next case is null.
suna 10$ replace assert statements by calls to the error message routine.
suna 11$ modules affected: shrtct and ermsg.
suna 12$ 3. correct a conversion error for binary set operations.
suna 13$ module affected: embin.
smfd 1
smfd 2
smfd 3$ 09/01/83 83244 s. freudenberger
smfd 4$
smfd 5$ 1. use the new short integer binary file format.
smfd 6$ module affected: getsbi.
smfd 7$ 2. ok_conv is really used for testing whether a conversion might
smfd 8$ succeed or will always succeed. this, of course, cannot be done
smfd 9$ in one routine. hence introduce a new routine can_conv which
smfd 10$ checks whether a conversion could succeed, and modify ok_conv
smfd 11$ to succeed if and only if the conversion will always succeed.
smfd 12$ modules affected: sixchar, emconv, and okconv.
smfd 13$ module added: canconv.
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$ module affected: getsbi.
smfc 8$ 2. modify the form propagation for range set types of ambiguous maps.
smfc 9$ module affected: rsettype.
mjsa 1
mjsa 2
mjsa 3$ 08/08/83 83220 s. freudenberger and m. smosna
mjsa 4$
mjsa 5
mjsa 6$ 1. implement arbitrary precision integer arithmetic. include
mjsa 7$ the new member 'lipkg' into stlini.
mjsa 8$ module affected: stlini.
smfb 1
smfb 2
smfb 3$ 08/08/83 83220 s. freudenberger
smfb 4$
smfb 5$ 1. change the six character name of match_repr from mtcrep to matchr.
smfb 6$ module affected: sixchar.
smfb 7$ 2. do not write the dead block following the last run-time names
smfb 8$ string block to the q2 file.
smfb 9$ modules affected: start, inienv3, and codtrm.
smfb 10$ 3. add a unary predicate q1_pos for use in arithmetic iterators when
smfb 11$ the sign of the increment is not know. this allows the optimiser
smfb 12$ to detect the special nature of this test easily. this opcode
smfb 13$ always has sym_zero as a third operand, and is changed during the
smfb 14$ fixup phase to the corresponding q1_lt.
smfb 15$ modules affected: start, fixup, and dblock.
smfb 16$ 4. add two new conditional branches to q1: q1_bif and q1_bifnot.
smfb 17$ this allows the optimiser to recognise whether a conditional
smfb 18$ branch was generated as part of the translation of a boolean
smfb 19$ operation. no new q2 opcodes are needed for this.
smfb 20$ modules affected: start, fixup, fixnot, fixpred, and dblock.
smfb 21$ 5. add a new conditional branch to both q1 and q2 to check the assert
smfb 22$ program parameter and branch if assert=0. this prevents the
smfb 23$ evaluation of the asserted expression if that is desired.
smfb 24$ modules affected: start, fixup, codegen, and dblock.
smfb 25$ 6. add a new routine format_form = formfm which formats a form table
smfb 26$ entry into a repr-syntax string. use this routine to print a
smfb 27$ message for each non-primitive conversion emitted iff reprs=2 is
smfb 28$ specified.
smfb 29$ new program parameter:
smfb 30$ reprs=1/1 process repr declarations: if reprs=2, print a
smfb 31$ message for each non-trivial conversion emitted.
smfb 32$ module affected: sixchar, start, codini, and emconv.
smfb 33$ module added: formfm (after mtdump).
smfb 34$ 7. add a new routine inidbg to build the is_ovar predicate if debug=1
smfb 35$ is specified. this predicate is represented compactly as a packed
smfb 36$ tuple(integer 1..1) and is stored in the s_ovar standard run-time
smfb 37$ symbol table entry. include a call to this routine into inienv3.
smfb 38$ module affected: inienv3.
smfb 39$ module added: inidbg (after initio).
smfb 40$ 8. add to the inline opcode mapping the opcodes for ambiguous map
smfb 41$ retrievals and the share-retrieval for tuples where the index is
smfb 42$ known to be in range.
smfb 43$ module affected: initab2.
smfb 44$ 9. try to convert short constants to the required form for binary
smfb 45$ oparators and predicates.
smfb 46$ modules affected: fixup, speceq, specin, and specpred.
smfb 47$ 10. change the propagation for short integer forms on assignments.
smfb 48$ module affected: fixasn.
smfb 49$ 11. correct the code sequence generated for iterators over maps:
smfb 50$ interpret the copy flag, which is set by the optimiser.
smfb 51$ module affected: codegen.
smfb 52$ 12. correct special casing error on untyped variables in equality
smfb 53$ tests.
smfb 54$ module affected: speceq.
smfb 55$ 13. correct the code generated for certain legal though unlikely
smfb 56$ operations such as set difference where the right operand cannot
smfb 57$ be converted to the left operand form, or set less element where
smfb 58$ the element cannot be converted to the set element form.
smfb 59$ modules affected: embin and emwith.
smfb 60$ 14. improve the code generated for tuple retrievals and embeddings:
smfb 61$ modify the definitions of the relevant q2 inline opcodes to accept
smfb 62$ long and short integers; do index range check statically where
smfb 63$ possible; correct a typo in emsof.
smfb 64$ modules affected: emof and emsof.
smfb 65$ 15. allow the result of a domain or range operation to receive a map
smfb 66$ representation. this relaxation was needed since the optimiser
smfb 67$ treats all sets of pairs as maps.
smfb 68$ module affected: emst2.
smfb 69$ 16. pass the copy flag from emasn to emconv if a conversion is needed.
smfb 70$ module affected: emasn.
smfb 71$ 17. modify the semantic definition of q2_checki1 to check for short
smfb 72$ integer in range. this means that no q2_checktp needs to precede
smfb 73$ a q2_checki1.
smfb 74$ module affected: emconv.
smfb 75$ 18. include a range check for short integer constant conversion;
smfb 76$ prevent short integer constant conversion to integer constant.
smfb 77$ module affected: convcon.
smfb 78$ 19. prevent a new run-time symbol table to be generated for different
smfb 79$ short integer constants.
smfb 80$ module affected: cnvcon.
smfb 81$ 20. always generate an alternate representation for numeric constants
smfb 82$ as required and appropriate.
smfb 83$ module affected: matchr.
smfb 84$ 21. modify the forwards form propagation for binary operators on
smfb 85$ primitive forms.
smfb 86$ module affected: bintype.
smfa 1
smfa 2
smfa 3$ 12/16/82 82350 s. freudenberger
smfa 4$
smfd 14$ 1. the recently introduced ft_deref field is used in this phase to
smfa 6$ replace the deref_typ function.
smfa 7$ modules affected: sixchar, start, and most others.
smfa 8$ module deleted: dereftyp.
smfa 9$ 2. run-time names are stored differently: see compl for an explana-
smfa 10$ tion. this version is upwards compatible for all implementations.
smfa 11$ iname now has three parameters: a prefix string, a q1 symbol
smfa 12$ table pointer, and a q2 symbol table address. care must be taken
smfa 13$ in the future to asure that iname can allocate space in the
smfa 14$ dynamic part of the heap.
smfa 15$ modules affected: start, iname, emdebg, trmcod, inenv1, inenv3,
smfa 16$ codtrm, alloc, genint, cnvcon, genelt,
smfa 17$ and bldpset.
22
23
24$ 08/12/82 82224 s. freudenberger
25$
26$ 1. the q2 definitions have been moved into a separate subroutine
27$ stlini, whose definition should correspond to the definition of
28$ libpl.stlini. this enables us to link cod against stlshr on s32.
29$ variable declarations global to cod have been placed into the
30$ nameset nscod, and access statements added as needed.
31$ modules affected: all.
32$ module added: stlini.
33$ 2. the q2 opcodes have been updated: all aliases and unused codes
34$ have been eliminated.
35$ modules affected: initab1 and emconv.
36$ 3. the form table layout has been changed: the fields 'ft_deref' and
37$ 'ft_imset' have been added. this fields are included in the sq1
38$ file. (fmdump has been replaced for convenience.)
39$ module affected: sgettb and fmdump.
40$ 4. a typo has been corrected in the specin routine: as a result an
41$ undefined variable had been accessed, causing problems on s37.
42$ module affected: specin.
43$ 5. procedure linkage has been modified: the relevant opcodes specify
44$ the low-core address of the block to be moved, instead of the
45$ high-core address.
46$ module affected: embentry, embexit, and emmove.
47$ 6. string pattern sets have been defined as a separate entity. they
48$ are (still) represented as packed tuples, but are parameterised
49$ to generate byte tables for r32.
50$ module affected: bldpset.
51$ 7. the argument sequence for the q2_entry, q2_exit, and q2_undo
52$ instructions has been changed: the code address now occupies the
53$ codea1 field of the first quadruple (recall that all other code
54$ addresses use this field, which is larger than the remaining
55$ fields). furthermore, the necessary q2_lab instructions are
56$ emitted if we generate assembly code (asm=1). finally, the
57$ routines are relocated when assembly code is generated.
58$ modules affected: embentry and embexit.
59
60
61$ 06/15/82 82166 s. freudenberger
62$
63$ 1. code controled by the asm program parameter has been changed as
64$ follows:
65$
66$ 1.1 q2 code is generated in the collectable part of the heap. as
67$ a consequence, constant pattern sets are allocated in the
68$ constant part of the heap.
69$ modules affected: start, bldpset, initcode, em2, and termcode.
70$ 1.2 procedures do not start with a q2_stmt quadruple.
71$ module affected: codegen.
72$ 1.3 the first instruction emitted for a non-backtracked procedure
73$ has been corrected to pentry.
74$ module affected: ementry.
75$ 1.4 the implicit start of a basic block after a conditional
76$ conversion has been made explicit by emitting the required
77$ q2_lab instructions.
78$ module affected: emconv.
79$ 2. branch operations have been optimised further.
80$ modules affected: fixup, fixgo, and fixpred.
81$ module added: shrtct (after fixpred).
82$ 3. div on untyped reals has been eliminated.
83$ module affected: initab1.
84$ 4. the mode propagation predicates have been improved for strings.
85$ modules affected: elmt_type, dom_type, and im_type.
86$ 5. q2_asrt has been changed so that its second operand is the current
87$ routine name and its third argument is the current statement
88$ number. thus no call to find_stmt is needed anymore to print the
89$ trace message.
90$ module affcted: codegen.
91
92
93$ 06/01/82 82152 s. freudenberger
94$
95$ 1. we added conditional code for the s37 mts implementation.
96$ module affected: codini.
97$ 2. a new program parameter has been added to control the generation
98$ of q2_stmt quadruples:
99$ stmt=1/2 0: suppress generation of q2_stmt
100$ quadruples completely - all run time
101$ error messages will diagnose the error
102$ to occur in statement one of the
103$ correct routine;
104$ 1: generate q2_stmt quadruples as before,
105$ yet move any q2_stmt at the end of a
106$ basic block to the start of the next
107$ basic block.
108$ 2: in addition to the q2_stmt generated
109$ under stmt=1, generate a q2_stmt after
110$ each q2_call instruction and set its
111$ codea4 field to one (this quadruple is
112$ usefull for dynamic frequency counts).
113$ modules affected: start, codini, and codegen.
114$ 3. the initialisation of the special q2 opcode for q2_of on long
115$ character strings (f_string) has been added.
116$ module affected: initb1.
117$ 4. 'sgettb' has been modified to account for the new sq1 file format.
118$ (see sempl for details).
119$ modules affected: sgettb and fmdump.
120$ 5. conversions involving short integer modes (f_sint's) have been
121$ modified to reflect the use of ft_low.
122$ modules affected: emconv, okconv, convcon, canasn, and insamp.
123$ 6. to simplify the machine code generation for setl, the inline code
124$ for q2_lessflm has been disabled for local maps based on plex
125$ bases.
126$ module affected: emlessf.
127$ 7. the mixed-tuple-table dump routine has been rewritten to produce a
128$ more compact listing.
129$ module affected: mtdump.
130
131
132$ 03/16/82 82075 s. freudenberger
133$
134$ 1. the initialisation of the special q2 opcode for q2_sof on long
135$ character strings (f_string) has been corrected.
136$ this changed the code just a little, yet little enough to show
137$ a bug in little. it could be circumvented by moving some code
138$ from initb1 to initb2, which has been done.
139$ module affected: initb1 and initb2.
140$ 2. the initialisation of the special q2 opcodes for sym_true and
141$ sym_false has been deleted, to correct the bug that 'newat = true'
142$ causes an execution error. the q2 opcodes q2_eqtrue, q2_eqfalse,
143$ q2_eqif, q1_eqifnot, q2_goif, and q2_goifnot are not emitted any
144$ longer and should be removed as time permits.
145$ modules affected: initb2 and speceq.
146$ 3. the q1 symbol table flag is_rec is now set by either sem or opt:
147$ remove the initialisation code.
148$ module affected: gettab and sgettb.
149$ 4. the form table field ft_low has been made part of the sq1 file.
150$ module affected: sgettb.
151$ 5. the q1 symbol table flag is_memb has been removed from the symbol
152$ table, and the flag is_init has been added.
153$ module affected: sgettb.
154$ 6. a mode propagation bug on internal variables has been corrected:
155$ the construct 'e1 op/ e2' would miscompile if e1 was a constant
156$ with a more specific mode than the element mode of e2. this has
157$ been corrected using the is_seen q1 symbol table flag for internal
158$ variables.
159$ module affected: fixasn.
160$ 7. we look ahead for q1_free instructions to collect as many of them
161$ as possible into each q2_free instruction.
162$ module affected: codegen.
163$ 8. when we select inline cases for equality test, we take the form of
164$ both input operands into account to select special cases. this
165$ enables us to emit an q2_eqv for equality tests on sym_true and
166$ sym_false.
167$ module affected: speceq.
168
169
170$ 02/01/82 82032 s. freudenberger
171$
172$ 1. the listing output has been moved to start each line in column 1
173$ rather than column 7. dump outputs have not been modified.
174$ modules affected: codini, inenv1, ermsg, codwrn, overfl, abort,
175$ and codtrm.
176$ 2. the line layout for error and warning messages has been modified.
177$ modules affected: ermsg and codwrn.
178
179
180$ 02/01/82 82032 d. shields
181$
182$ use r32 conditional symbol for standard 32-bit fields.
183$ this replaces the field definitions for s32, s37 and s47.
184
185
186$ 01/15/82 82015 s. freudenberger & d. shields
187$
188$ 1. codini has been modified to print the phase header to the terminal
189$ whenever the new control card parameter 'termh=0/1' is set.
190$ new control card parameter:
191$ termh=0/1 print phase header on the terminal file
192$ module affected: codini.
193$ 2. the case map of a case statement is always repred. we use this
194$ knowledge to print better error messages if an error occurs while
195$ we allocate a casemap.
196$ 3. the map used for second argument of open has been modified so that
197$ for mixed-case implementations, the argument can be specified in
198$ lower or upper case.
199$ modules affected: fixup, incnst, ermsg, and codwrn, initio.
200
201
202$ 11/29/81 81333 d.shields
203$
204$ 1. support s47: amdahl uts (universal timesharing system).
205$ this implementation runs on s37 architecture using an operating
206$ system very close to unix (v7), and uses the ascii character set.
207
208
209$ 81/10/27 81300 s. freudenberger
210$
211$ 1. the q2 interface has been formalized: a total of six routines
212$ read and write a standard q2 file, and a seventh routine
213$ checks a q2 file to determine whether it is in the correct
214$ format.
215$ the routines wrheap, wrheap1, and wrheap2 write the entire
216$ heap, the environment block, and the heap slices, resp.
217$ the routine wrheap1 is used in codtrm to write the
218$ environment block. specialised code, however, is used to
219$ write the heap slices since we do not write the dead block
220$ between the constants area and the heap proper.
221$ module affected: codtrm.
222$ 2. for the dec vax vms version we now allocate the heap dynamically.
223$ 3. the setl-fortran interface has been implemented for the
224$ s32, s37, and s66 versions.
225$ the interface uses a communication area which is kept as a
226$ tuple in the setl heap as the symbol intf: sym_intf replaces
227$ sym_spare1, and s_intf replaces s_spare1.
228$ the actual call to fortran is done by the new built-in function
229$ callf, for which a new q1 symbol table entry and a new q2 opcode
230$ were needed.
231$ modules affected: start and inienv3.
232$ 4. the address range of the q2 symbol table is tested whether it
233$ can be stored in the q2 instructions, and a fatal error message
234$ is issued if it does not.
235$ module affected: inenv1.
236$ 5. the reserved words 'spec' and 'unspec' have been deleted.
237$ module affected: start.
238$ 6. if the mode of x cannot be converted to the domain mode of f,
239$ then a q2_ofa is emitted (and not a q2_of) for a q1_ofa. this
240$ typo has been corrected.
241$ module affected: emofa.
242
243
244$ 06/24/81 81175 s. freudenberger
245$
246$ 1. the operator class for predicates, cl_pred, has been split into
247$ two classes, cl_pred1 and cl_pred2, such that membership tests
248$ (q1_in and q1_notin) are in cl_pred1, and the remaining predi-
249$ cates (q1_eq, q1_ne, q1_incs, etc.) are in cl_pred2. the purpose
250$ of this destinction is to be able to verify that membership tests
251$ are defined for plex objects subject to the constraint that the
252$ element has the proper form, while the other predicates are not
253$ defined for plex objects (eg. it is impossible to compare two
254$ plex objects for equality since it is impossible to iterate over
255$ plex objects).
256$ modules affected: start, fixup, and codgen.
257$ 2. we introduced a new global variable curmemb, giving the current
258$ member name (ie. the symbol table index of the current member).
259$ modules affected: start, gettab, ermsg, and codwrn.
260$ 3. the is_pre setting for q1_exp has been changed to no as there is
261$ no inline code available.
262$ module affected: start.
263$ 4. the operator class for q1_even and q1_odd has been corrected to
264$ cl_atom, as booleans are the blank atoms 0 and maxsi
265$ module affected: start.
266$ 5. we introduced three new q2 opcodes, and renamed one, to implement
267$ a first part of case map optimisation as outlined in nl. 215.
268$ the q2 opcodes for q1_case are q2_caset, q2_caselsm, q2_casersm,
269$ q2_caseusm.
270$ modules affected: start, intab1, gettab, fixup, codgen, incnst,
271$ and codwrn.
272$ 6. we introduced several new system global variables, in an effort
273$ start to implement a dynamic symbolic debugging system. most
274$ notably in this phase, we added a new control card parameter,
275$ debug=0/1, which controls the initialisation of the debugging
276$ features.
277$ modules affected: q1symtab, q2opcd, q2vars, codini, emdebg,
278$ inenv3, and codtrm.
279$ 7. we added the following initialisations to the spec_op map:
280$ for short integers: q1_min -----> q2_mini
281$ for map forms: q1_notin ---> q2_nins
282$ module affected: intab1.
283$ 8. we added the following initialisations to the of_op map:
284$ for smaps, for untyped based maps, for q1_of and q1_sof:
285$ select the appropriate inline opcode.
286$ module affected: intab1.
287$ 9. the file format of the sq1 file has been changed: constants of
288$ mode f_atom must be the booleans true and false (or symbols
289$ aliased to these). the sq1 entry for such a constant now is,
290$ indeed, a boolean.
291$ mudule affected: sgettb.
292$ 10. the tests for plex objects have been altered substantially, and
293$ it is hoped that the necessary tests are now performed to use
294$ plex objects safely.
295$ modules affected: fixup, fixasn, and emargi.
296$ 11. the mode backpropagation has been corrected to do backpropagation
297$ only when the mode to be backpropagated was not obtained by
298$ forward propagation to a temporary which is the result temporary
299$ for several conditionally selected blocks (eg. the forward propa-
300$ gation of the mode of can not necessarily safely be propa-
301$ gated back to in 'if then else end').
302$ module affected: fixasn.
303$ 12. we cannot merge typed and untyped temporaries, since the garbage
304$ collector must trace typed date, but may not trace untyped data.
305$ module affected: settmp.
306$ 13. we suppress the allocation of a sample value (ie. omega) for
307$ unbased maps with untyped range modes, since the semantic pass
308$ checks that no variable can be declared to have such a mode.
309$ we also suppress to allocate a sample value for the standard
310$ forms f_elmt and f_latom.
311$ module affected: alloc.
312$ 14. the initialisation of all symbol table entries has been moved
313$ from the alloc routine to the inenv2 routine.
314$ 15. we corrected the code generated for q2_free to pop the skip word
315$ of untyped parameters. the bug was that cl_free checked the form
316$ of the actual parameter, rather than the form of the formal para-
317$ meter, thus producing incorrect results if a conversion between
318$ typed and untyped data was emitted as part of the call.
319$ module affected: codgen.
320$ 16. we modified the code of the specin routine, without changing the
321$ code it generates. the new code calls the dertyp and emconv
322$ utilities rather than to execute equivalent code inline.
323$ 17. the emof and emofa routines have been modified to select q2_of
324$ and q2_ofa, resp., if the third argument cannot be converted to
325$ the map domain form, rather than to signal an error. the new
326$ choice reflects the strict setl semantics, the old choice indi-
327$ cated that such a retrieval always yields omega and thus is
328$ constant.
329$ 18. the emof routine has been modified to only select a share-op if
330$ the result's form is non-primitive.
331$ 19. the emsof routine has been modified to always call the library
332$ if the third argument is untyped, and the second argument not a
333$ local map. this is required since all other inline cases poten-
334$ tially call the library, and untyped data would be incorrect in
335$ that context.
336$ 20. the empush routine has been corrected so that is forces a copy
337$ (ie. a conversion) when local objects are passed as parameters.
338$ under an earlier semantic definition for formal parameters in
339$ setl, they could not be modified unless they were declared wr or
340$ rw. later this definition was changed, but this hidden optimi-
341$ sation was not adjusted accordingly.
342$ 21. the emconv routine has been corrected to handle cases where first
343$ a dereference operation is needed, followed by a primitive type
344$ check (eg. let the base b have an element mode of f_gen, let x.in
345$ have the form 'elmt b', and let x.out have the form f_int: after
346$ a one-level dereference, we still need to check that x is an
347$ integer. before this modification, this would have been flagged
348$ as an error).
349$ 22. the error message for failure to convert to a string has been
350$ corrected.
351$ modules affected: emconv and ermsg.
352$ 23. we modified the form dereference operation to stop with an
353$ element form if this element is an element of a plex base.
354$ modules affected: emconv and dertyp.
355$ 24. we allow a general form to be assigned to a element_of_plex_base
356$ form, subject to a run-time type check with fatal failure.
357$ modules affected: q2opcd and emconv.
358$ 25. we print a warning message for each unsatisfied external proce-
359$ dure reference found at the end of code generation.
360$ module affected: setlb1.
361$ 26. we print an error message if the input does not include a main
362$ program, ie. when s$main is undefined.
363$ module affected: inenv3.
364$ 27. the q2 data structure for long atom data blocks has been modified
365$ to include a field la_form pointing to the form table entry of
366$ its plex base.
367$ modules affected: s10q2f, s32q2f, s37q2f, s66q2f, q2flds, and
368$ insamp.
369$ 28. the standard form f_lab is initialised to a t_olab rather than to
370$ a t_oint. note the correspondence with the garbage collector:
371$ labels need not be traced since code is stored in the constant
372$ area, or is dead after machine code has been generated.
373$ module affected: insamp.
374$ 29. the module codwrn has been added after the module ermsg to print
375$ warning messages.
376
377
378$ 01/05/81 81005 s.tihor
379$
380$ 1. update q2 format, including magic number
381$ 03/20/81 81086 s. tihor
382$
383$ 1. add 20 new variables to the symbol table and code file
384$ to permit extensions without invalidating old code files.
385$
386$ 01/29/81 81029 s. freudenberger
387$
388$ 1. the specin routine has been extended to generate better code for
389$ based membership tests.
390$ 2. the embin routine has been modified to always copy strings
391$ before they are used.
392
393
394$ 12/02//80 80337 s. tihor
395$
396$ 1. supress dumps to terminal.
397$ 2. supress dumps when et=0.
398
399
400$ 12/02/80 80337 s. freudenberger
401$
402$ 1. 'cstmt_count', the cummulative statement counter, and
403$ 'ustmt_count', the cstmt_count at the start of the current
404$ compilation unit, have been initialized to zero (rather
405$ than one). this corresponds to a change in sem.
406$ 2. the setl q1 interface has been modified to account for
407$ the field overlap of ft_lim, ft_pos, and ft_tup.
408$ 3. the fixnot and fixpred routines have been modified to
409$ only fold temporaries, and not internal variables, which
410$ could be constant subexpressions as detected by the
411$ optimiser.
412$ 3. cl_not and cl_ifgo are handled somewhat more straight-forward
413$ during the codegen phase.
414$ 4. the emwith routine has been modified to account for the
415$ not-is_pre of q1_less.
416$ 5. the emlessf routine has been modified to account for the
417$ is_fmap of the result of the operation.
418$ 6. the optpack routine has been modified to save one word if
419$ the bit position for the next object is one.
420$ 7. the *yd directive in the insamp deck has been deleted.
421
422
423$ 11/05/80 80310 s. freudenberger
424$
425$ 1. the operator class cl_st2 has been introduced. it is used
426$ for the domain and range operators, which have been modified
427$ to allow arbitrary set modes as results. (previously, they
428$ generated an unbased set, which then had to be converted.)
429$ modules modified: start, fixup, fixasn, codegen
430$ module added: emst2
431$ 2. the operator table (optab) has been modified to include an
432$ ops_ovar flag. this flag marks operators which modify there
433$ first argument, and is intended to be used to implement the
434$ variable trace feature.
435$ 3. the initab1 routine has been modified to reflect the changes
436$ in the sequence of ft_type codes.
437$ 4. the temporary storage overlay routines have been modified to
438$ account for the fact that the optimizer performs this task.
439$ modules modified: fixup, settemp, freetemp, droptemp
440$ 5. the following routines have been modified to convert a set
441$ t a map: emof, emofa, emsof, emsofa
442$ 6. the following routines check for same_repr, and not for
443$ simillar_repr: seta2, seta3, seta4.
444$ 7. the optpack routine has been written. related changes to
445$ the insamp routine have been made. the basinfo routine
446$ became superflous, and has been deleted.
447$ 8. the packinfo routine has been updated to reflect the re-
448$ striction placed on packed integer ranges (integer i .. j
449$ implies i>0).
450$ 9. the form dump routine has been updated to reflect the
451$ form table changes described in compl.
452
453
454$ 09/08/80 80252 s. freudenberger
455$
456$ 1. the fixup and embin routines have been corrected to handle
457$ a1 := a2 <*binop> a3
458$ where a1 has not a set mode, and a2 is a local set/map.
459$ 2. the fixup routine has been modified so that the is_backpr flag
460$ is only set when the temporary is not repr'ed (as might be by
461$ the optimizer).
462$ 3. the dblock routine has been modified to print the first 14
463$ (rather than the first 10) characters of each q1 operand.
464
465
466$ 08/18/80 80231 s. freudenberger
467$
468$ 1. several fields which assumed memory initialization to zero have
469$ been set to zero explicitly.
470$ 2. the alloc routine checked a zero-table entry: an undefined
471$ operation in little. this has been corrected.
472$ 3. the setl q1 interface has been modified to handle strings
473$ properly (vlen for string constants was always set to 1).
474$ 4. the form propagation and assignment merging for local
475$ objects had several errors, all of which have been fixed.
476$ 5. the optimizer sets the copy flag for q1_next instructions,
477$ indicating when an unconditional copy of the first argu-
478$ ment is required. the codegen routine has been modified
479$ to interpret this field if the opt_flag is set.
480$ 6. the first input of cl_with and cl_lessf is used destruc-
481$ tively. unless the o-variable is the first i-variable,
482$ this requires unconditional copy.
483
484
485$ 08/01/80 80214 s. freudenberger
486$
487$ 1. initab1 and emofa have been modified to emit off-line code
488$ for q1_ofa on non-m-maps. (this corrects a bug, where an
489$ in-line code sequence was emitted for an s-map.)
490$ 2. the setting of sflag for cl_ssubst operators is never tested:
491$ drop the setting.
492$ 3. a new global variable has been introduced: stmt_tot. it is
493$ used to count the number of q2_stmt quadrupels emitted, and
494$ is printed with the q2 statistics upon completion of cod.
495$ 4. the new conditional assembly member of compl replace the
496$ corresponding section in member start.
497$ 5. the code pointer (codep) has been included into the nameset
498$ nsgparam. consequently no declaration is needed in member
499$ start anymore.
500$ 6. the pre_flag, long dead, has been eliminated.
501
502
503$ 07/10/80 80192 s. freudenberger
504$
505$ 1. the a_share_op and eq_op tables are initialized to zero, rather
506$ than rely on initial zero memory.
507$ 2. fixasn has been modified to propagate the dereferenced mode
508$ to the temporary of an enumerative set- or tuple former.
509$ this optimization was lost during the modifications of the
510$ last correction set.
511$ 3. the operator class for q1_incs has been changed to cl_pred. this
512$ required the introduction of the following q2 opcodes: q2_nincs
513$ and q2_gonincs.
514$ nb. q2_nincs currently is not emitted. generally, however, all
515$ predicates are available in four forms: positive and negated, as
516$ predicates and as control primitives.
517$ this change also required the introduction of the following
518$ q1 opcodes: q1_ifinc and q1_ifsub. they are used between the
519$ fixup and code generation phases to mark where control primitives
520$ should be used instead of predicates.
521$ 4. some code has been moved within the embin routine: the code
522$ generated there now passes the standard test library with
523$ reprs=1 and rem=4.
524$ 5. a q2_error instruction is now emitted for every q1_error
525$ instruction as well as for every error diagnosed in a
526$ procedure scope during this phase.
527$ 6. the number of reserved files for the library has been
528$ decreased to three (from five): the string file used by val
529$ str is not needed anymore by these routines, and the statis-
530$ tics file is currently not needed. should it be needed in
531$ the future, it can re-use the q2 file id.
532
533
534$ 07/08/80 80190 s. freudenberger
535$
536$ 1. the mode propagation mechanism has been revisited, and changed
537$ considerably. it now performs backpropagation only for the
538$ temporaries defined by set- and tuple formers. (the backpr flag
539$ is used to mark such temporaries.)
540$ 2. the mode propagation around mixed tuples has been corrected.
541$ 3. once again, efforts have been made to synchronize statement
542$ numbers between the parser, semantic pass, code generator,
543$ and the run-time library. this time it is done by recording
544$ the cummulative statement number of the q1_entry instruction,
545$ an resetting the cstmt_count to this number when a q1_entry
546$ is seen.
547$ 4. cl_asrt has been introduced. this allows us to generate the
548$ conversion which might be needed for the i-variable of the
549$ assert statement.
550$ 5. the get_addr macro has been modified to return 0 if the q1 symtab
551$ index is zero, rather than the address(0), which stricly speaking
552$ is an array reference out of bounds.
553$ 6. a bug in the genelmt routine has been corrected.
554$ 7. the incnst routine has been modified to detect errors in
555$ set- and tuple formers, such as an smap being multi-valued at
556$ some point.
557$ 8. the line "no errors..." is not echoed to the terminal anymore.
558$ 9. the layout of the title line has been changed.
559
560
561$ 06/20/80 80172 s. freudenberger
562$
563$ 1. a bug related to the global string specifiers has been corrected.
564$ 2. a bug in the code sequence generated for sinister subtrings has
565$ been corrected.
566$ 3. several inline code sequences are now being emitted. these
567$ opcodes had been included before, but were never (or rarely
568$ ever) emitted.
569$ 4. the emst routine has been modify to call the emconv routine if
570$ it can not assign the set/tuple to the output variable.
571$ (though it knows that the only legal conversion is a locate)
572
573
574$ 06/06/80 80158 s. freudenberger
575$
576$ 1. the is_pre flag has been re-introduced (after it had been dropped
577$ with version 79248). this time, however, it is tested at a more
578$ appropriate place, and proper code is emitted.
579$ 2. the code generated for cl_min has been corrected.
580$ 3. the code generated for 'increment integer' has been improved to
581$ avoid the generation of the '1' in the proper form.
582$ 4. the result of adding two known-length tuples has been corrected
583$ to 'tuple(general)'.
584
585
586$ 05/29/80 80150 s. freudenberger
587$
588$ 1. the hash table header data structure introduced with 80130 has
589$ been incorporated into the compiler and run-time environment.
590$ decks affected: insamp, getht
591$ 2. more fields are set to zero in 'insamp'. still, the work is
592$ incomplete. this work is done so that eventually there is no
593$ need to zero the heap.
594
595
596$ 05/27/80 80148 s. freudenberger
597$
598$ 1. the fixup routine has been modified to accept the cflag setting
599$ produced by the optimizer.
600
601
602$ 05/09/80 80130 s. freudenberger
603$
604$ 1. the is_ebfree flag has been eliminated.
605$ 2. equality tests on elements of the same base generate a
606$ pointer equality test rather than a value equality test.
607$ 3. the seta2 routine had a typo corrected, which tested the
608$ retrieval rather than the store operation when deciding
609$ whether the copy flag refers to the second argument.
610$ 4. the q1_query, q1_isprim, q2_query, and q2_isprim operators
611$ have been eliminated.
612
613
614$ 04/16/80 80107 s. freudenberger
615$
616$ when a setl q1 file is given, only the setl q1 file is opened and
617$ read, and the little q1 file is ignored. if no setl q1 file is
618$ given, the file given as little q1 file is opened and read.
619$
620$ the inienv1 routine assumes that the h-parameter is given in kilo
621$ words if it is less than 1024. the range test, however, checked
622$ for 0 < h ! h < 1024. this clearly should be 'and', and has been
623$ corrected accordingly.
624
625
626$ 04/11/80 80102 d. shields
627$
628$ 1. delete cdc update yankdeck directives.
629$ 2. support second argument to 'open' as described in user manual.
630$ this involves adding 'text-in', 'binary-out', etc.
631$ 3. avoid use of '0' null file. this needed since s10 env does
632$ not support this.
633
634
635$ 04/09/80 80100 s. freudenberger
636$
637$ 1. the mode propagation for map retrieval, map store, and parameter
638$ passing has been improved.
639$ 2. the string specifiers for the 'move-character' macro are allo-
640$ cated at a more appropriate place, namely after the heap has
641$ been allocated.
642$ 3. three errors around special casing on mixed tuples have been
643$ corrected: we do not emit inline code for with, fromb, and frome.
644$ we do, however, emit inline code for sof provided the index is
645$ constant and in range.
646
647
648$ 02/04/80 80035 s. freudenberger and d. shields
649$
650$ 1. implement unary operators acos, asin, atan, char, cos, exp,
651$ log, sin, sqrt, tan and tanh.
652$ 2. implement binary operators atan2 and interrogation (?).
653$ 3. implement type predicates is_atom, is_boolean, is_integer,
654$ is_map, is_real, is_set, is_string and is_tuple.
655$ change prim to is_primitive.
656$ 4. add procedure host() to provide means for adding
657$ implementation- or site-dependent features.
658$ 5. a new q1 operator code class has been added: cl_bool. it
659$ is used for operations which yield a boolean.
660$ 6. depending on the 'et' control card parameter, a message is
661$ printed at the start of each unit, stating the name of the
662$ unit.
663$ 7. 'fixup' and 'codegen' have been modified to reflect the absence
664$ of the cumulative statement count as the first argument of a
665$ q1_stmt instruction.
666$ 8. 'fixasn' has been corrected to use a form as argument to a form
667$ predicate.
668$ 9. the assignment after a q1_newat instruction is merged in 'fixasn'.
669$ 10. the forms propagated to the result temporary in 'fixnot' and
670$ 'fixpred' has been changed from f_gen to f_atom. note that
671$ the short atoms 0 and maxsi are used for true and false, resp.
672$ 11. 'initname' has been corrected to access the run-time names
673$ table properly when names are stored over several words.
674$ 12. the code sequences emitted for q1_with and q1_sof have been
675$ corrected for mixed tuples.
676$ 13. compile-time conversions between integer constants have been
677$ corrected. decks affected: okconv and convcon. (the problem
678$ found was improper handling of conversions to short integers.)
679$ 14. the run-time names entry in 'genelmt' is initialized.
680$ 15. addressability range checks have been included in 'uselab'
681$ and 'setlab'.
682
683
684$ 01/21/80 80021 s. freudenberger
685$
686$ 1. the form table limit has been increased for the s32.
687$ 2. addressability checks have been added to avoid field overflows
688$ for code- and symbol table pointers.
689
690
691$ 01/17/79 80017 s. freudenberger
692$
693$ the layout of the heap has been changed: snames has been integrated
694$ into the heap at the low core end, and the run-time symbol table has
695$ been allocated between the run-time names and the constant part of
696$ the heap. accordingly, a new parameter has been added to specify
697$ the initial size of the symbol table: st. note that we observe that
698$ the names table size is a function of the symbol table size; we thus
699$ waste actually less space than before, even if we waste it more vi-
700$ sibly.
701$ modules affected: start, codini, alloc, initname, genint, cnvcon,
702$ genelmt, bldpset, inienv1, inienv3, and codtrm.
703
704
705$ 01/16/79 80016 s. freudenberger
706$
707$ 1. all assert statements have been replace by calls to ermsg.
708$ 2. the dummy routines garbcol etc. have been updated to the current
709$ routine names.
710
711
712$ 01/15/79 80015 s. freudenberger
713$
714$ 1. the std_op-field of optab for q1_date has been corrected.
715$ 2. the domain forms are propagated to unrepred temporaries during
716$ fixup for the classes cl_of, cl_ofa, cl_sof, cl_sofa, and
717$ cl_argin.
718$ 3. codegen-case cl_stmt checks whether the next quadruple is a
719$ statement quadruple as well, and suppreses generation of the
720$ current quadruple if this condition is met.
721$ 4. emconv has been corrected to assign the proper omega if the
722$ input is sym_om.
723$ 5. the q2_share is suppressed for the third argument of q1_of and
724$ q1_ofa quadruples.
725
726
727$ 12/17/79 79351 s. freudenberger
728$
729$ 1. conditional assembly 'sq1' has been introduced, selecting the
730$ availability of the setl q1 interface.
731$ 2. the double negation for 'cl_if' has been eliminated.
732$ 3. 'speceq' has been amended to emit the recently introduced opcodes
733$ 'eqtrue', ...
734$ 4. 'insamp' now initialized more fields to zero than it did before.
735$ this work was started to eliminate the need to zero memory for the
736$ heap, but is not yet completed.
737
738
739$ 11/30/79 79334 s. freudenberger
740$
741$ 1. the special casing for equality tests on elements has been
742$ corrected.
743$ 2. four new q2 opcodes for equality testing have been introduced
744$ to handle booleans inline. code addition to actually emit
745$ these codes has not yet been added.
746$ 3. some minor bugs with the setl q1 interface have been corrected.
747$ 4. 'emconv' has been corrected to (a.) handle null set and null
748$ tuple conversions to f_elmt correctly, and to (b.) observe
749$ the proper copy semantic after dereferencing f_elmt's.
750$ 5. conditional code has been added to reset the initial heap
751$ dimension for statically allocated heaps (i.e. s32 and s37)
752$ if these values are improperly specfied by the user.
753$ 6. 'compntype' has been corrected to handle strings properly.
754
755
756$ 11/12/79 79316 s. freudenberger
757$
758$ 1. fr2.1.014 (debug rdump failure) has been fixed.
759$ 2. deck 'codini' has been cleaned up. the q1sd, q1cd, q2sd, q2cd
760$ control card parameters have been renamed cq1sd, cq1cd, cq2sd,
761$ and cq2cd, resp.
762$ 3. the h- and ca- control card parameters are now processed in
763$ inienv1. there phase heading line is printed there as well.
764$ 4. the setl binary i/o interface has been implemented.
765$ 5. the unit_xxx codes have been corrected.
766
767
768$ 09/13/79 79256 s. freudenberger
769$
770$ 1. logical file names are sized using 'filenamlen' (defined in
771$ cmnpl.sysmac)
772
773
774$ 09/05/79 79248 s. freudenberger
775$
776$
777$ this correction set installs setl 2.1
778$
779$
780$ 1. various tables have been updated to reflect the addition
781$ of q1 and q2 opcodes.
782$ 2. form propagation for 'from',... has been corrected.
783$ 3. the form propagation for iterators has been improved.
784$ 4. the 'is_pre' flag has been obliviated. this was necessary,
785$ since its use caused improper code to be generated.
786$ 5. the introduction of booleans means that we now have a number
787$ of special opcodes (such as goom) which are of questionable
788$ value. we do, however, emit proper code for constructs such as
789$ 'if then...'.
790$ 6. we now emit a q2_stmt at the beginning of each basic block if
791$ this block is inside the range over which measurements are
792$ being taken.
793$ 7. 'emfrom' has been updated to reflect that we now have 'from',
794$ 'fromb', and 'frome'.
795$ 8. 'emofa' has been corrected to select the proper inline sequence
796$ for variables which are not known to be multi-valued.
797$ 9. 'emsof' and 'emsofa' now emit the proper code sequence for
798$ any necessary left-hand side conversion.
799$ 10. the second argument for 'q2_checki1' is not an immediate operand
800$ anymore, since this caused problems when the garbage collector
801$ adjusted the heap size.
802$ 11. 's_types' now is initialized properly.
803
804
805$ 07/25/79 79206 s. freudenberger
806$
807$ 1. 'typetab' is initialized with a data statement rather than at
808$ run time.
809$ 2. 'emsof' converted the third operand to the improper form. this
810$ has been corrected.
811$ 3. the sample value for remote sets are allocated for 'rs_bpw-1'
812$ bits, since this is the smallest possible allocation, and 'rs_maxi'
813$ is set to this value.
814
815
816$ 07/20/79 79201 s. freudenberger
817$
818$ 1. 'optab' is initialized via a data statement, and not at the start
819$ of execution.
820$ 2. form propagation during both the fixup- and the code-generation
821$ phases has been corrected an improved. proper code is generated
822$ to assert run-time consistency between the form a variable and
823$ its value.
824$ 3. error messages on the s10 are written to the device 'tty:' rather
825$ than the file 'tty'. furthermore, they are preceded by '?', the
826$ standard error marker for the dec-10.
827$ 4. error messages on the s32 are written, by default, to 'sys$error'.
828$ 5. 'codini' prints a line 'start...' on the terminal.
829$ 6. a deck 'sixchar' has been added, mapping routine names into unique
830$ six character alphameric names which start with an alphabetic.
831
832
833$ 05/18/79 79138 s. freudenberger
834$
835$ 1. the symbol table is initialized to om, unless it is defined
836$ otherwise. this way it is not necessary to zero the heap.
837$ 2. more shared code has been moved into compl.
838$ 3. constant strings are allocated in the dynamic part of the heap,
839$ so that they can be shared properly.
840$ 4. in an if-expression, the result temporary is defined on first
841$ encounter.
842
843
844$ 04/27/79 79117 s. freudenberger
845$
846$ 1. the heap is written onto the q2 file in slices, skipping the
847$ uninitialized parts between the constant and the dynamic part,
848$ and between the heap and the stack/symbol table.
849$ 2. the q1 symbol table data structures and the form table data
850$ structures have been placed into a common library, since these
851$ definitions are shared between several phases of the compiler.
852$ they are now included from an inclusion library.
853$ 3. to further compact the output produced by this phase, no message
854$ is printed anymore at the start of each unit. corresponding
855$ change have been made so that error messages and dumps still
856$ can be identified.
857
858
859$ 04/12/79 79102 s. freudenberger and d. shields
860$
861$ the control card parameters -h- an -ca- are assumed to be given
862$ in k-words in the event that they are smaller than 1000.
863
864
865$ 04/10/79 79100 s. freudenberger
866$
867$ the dimension of the symbol table has been increased to 1500
868
869
870$ 04/03/79 79093 s. freudenberger
871$
872$ as a first step to remove prefix stropping, the pre control card
873$ parameter has been deleted, and the pre_flag initialized to
874$ reserved word stropping.
875
876
877$ 03/27/79 79086 s. freudenberger
878$
879$ 1. code will only be generated for units of type procedure.
880$ 2. -alloc- has been corrected so that the indices of arrays
881$ are defined before they are used.
882$ 3. the size of the -names- table has been increased to 1500.
883
884
885$ 03/15/79 79074 s. freudenberger
886$
887$ 1. the q1 tables are read in in the same sequence in which
888$ the optimizer writes them out (which, of course, is the
889$ same sequence in which the semantic pass writes them).
890$ 2. the name of constant pset-s are prefixed by -p.- rather than
891$ -pset.-.
892
893
894$ 03/05/79 79065 s. freudenberger
895$
896$ 1. the following changes have been made to the debug statement
897$ options:
898$
899$ 1.1 three new options have been introduced to allow local dumps
900$ during code generation:
901$ cq1cd q1 code dump during fixup
902$ cq1sd q1 symbol table dump during codegen
903$ cq2cd q2 code dump during code generation
904$ 1.2 two semantic pass options have been renamed:
905$ q1dump ----> sq1cd
906$ symdump ---> sq1sd
907$
908$ 2. the statement numbering has been cleaned up. hopefully error
909$ messages will print now the statement number corresponding to
910$ the source listing...
911
912
913$ 02/12/79 79043 a. grand and s. freudenberger
914
915$ 1. it moves the value of the dimension macro for the names table
916$ into a conditional assembly, cooresponding to the definition
917$ of names_dim in the semantic pass.
918$ 2. it inserts a notrace entry little directive before the first
919$ procedure so that no entry trace will be produced for the
920$ code generator.
921$ 3. it defines the temporary which is generated for the lhs of the with
922$ operation in -f@x\ with y-.
923
924
925$ 01/30/79 79030 a. grand and s. freudenberger
926
927$ 1. fix-up phase
928
929$ 1.1 the op-classes sof, sofa, and ssubst do not return the first
930$ argument anymore if it is a temporary, since this temporary
931$ is both input and output.
932$ 1.2 when we merge temporaries, we check whether we have seen this
933$ temporary before, and if so, we check whether the forms of the
934$ different occurrences are equal. if they are not, we propagate
935$ f_gen.
936
937$ 2. we changed the symdump routine to dump all fields.
938
939
940$ 12-27-78 78361 a. grand and d. shields
941
942$ this mod installs machine dependent code for the ibm-370, dec-10,
943$ and vax. it also fixes the following bugs:
944
945$ 1. the copy flags for binary operators are now set properly.
946$ 2. sample values for packed tuples and maps are built properly.
947$ 3. conversions to short integer are handled properly.
948
949
950$ 12/08/79 79342 a. grand
951
952$ 1. there were several questions involving union, with, and f@x\ := y
953$ on smaps. these bugs have all been cleaned up.
954$ 2. several bugs in the compile-time conversion of symbolic constants
955$ have been fixed.
956$ 3. conversions on primitive types are now done correctly and handle
957$ the case where the input is omega.
958$ 4. 'psets' used for string primitives are now represented as
959$ packed tuple(1 ... 1).
960$ 5. we fixed a bug in set_a1 which caused 'f(x) := f' to create
961$ a circular structure.
962$ 6. we added a parameter to set_a2 and set_a3.
963
964
965
966$ 11-15-78 78319 a. grand and s. freudenberger
967
968$ 1. fixup phase
969
970$ a. we have changes 'fixasn' so that we emit an unconditional
971$ copy for 'a := b + c' and a conditional copy for
972$ 'a := a + c'.
973$ b. we have changes the handling of 's := iterative-set-former'.
974$ we no longer eliminate the temporary yielded by the
975$ set former. we merely propagate the type of 's' back to
976$ the temporary and propagate the element type of 's' to
977$ the temporary used for the set's elements.
978
979$ 2. temporary allocation
980
981$ a. temporaries with their is_back field set are not merged.
982$ b. we have added a symbol table field 'is_alias' which is
983$ true for all temporaries t1 which are used as the alias
984$ of some other temporary t2.
985
986$ 3. code generation
987
988$ 1. embexit now emits a 'stop' instruction at the end of the
989$ main program.
990$ 2. we have fixed 'set_a1' to handle 'f(x) := f' and
991$ 'f@x\ := f' properly.
992
993$ 4. we have fixed the treatment of statement numbers in the q1 code.
994
995$ 5. we have cleaned up the printing of control card parameters on
996$ the listing.
997
998
1 .=member sixchar
2
3
4$ this deck maps routine names into unique six character names
5$ starting with an alphabetic, and consisting of alphamerics only.
6
7 +* initab1 = intab1 **
8 +* initab2 = intab2 **
9 +* fixpred = fxpred **
10 +* temptab = tmptab **
11 +* set_temp = settmp **
12 +* free_temp = fretmp **
13 +* drop_temp = drptmp **
14 +* clear_temps = clrtmp **
16 +* fsclass = fclass **
17 +* codegen = codgen **
18 +* spec_eq = speceq **
19 +* spec_in = specin **
20 +* spec_pred = specpr **
21 +* ementry = ement **
22 +* embentry = embent **
23 +* embexit = embexi **
24 +* emsucceed = emsced **
25 +* emlessf = emlsf **
26 +* emnewat = emnewt **
27 +* emargin = emargi **
28 +* emargout = emargo **
29 +* emsubst = emsubs **
30 +* emssubst = emssub **
smfd 15 +* can_conv = cancnv **
31 +* ok_conv = okconv **
32 +* convcon = convcn **
33 +* genelmt = genelt **
34 +* bldpset = bldpst **
35 +* can_assign = canasn **
smfb 87 +* match_repr = matchr **
37 +* set_a1 = seta1 **
38 +* set_a2 = seta2 **
39 +* set_a3 = seta3 **
40 +* set_a4 = seta4 **
41 +* emdebug = emdebg **
42 +* initcode = incode **
43 +* termcode = trmcod **
44 +* setlab1 = setlb1 **
45 +* inienv1 = inenv1 **
46 +* inienv2 = inenv2 **
47 +* optpack = optpck **
48 +* inienv3 = inenv3 **
49 +* packinfo = pckinf **
50 +* bin_type = bintyp **
smfa 18 +* deref_typ = ft_deref **
52 +* elmt_type = elmtyp **
53 +* dom_type = domtyp **
54 +* im_type = imtype **
55 +* cn_type = cntype **
56 +* compn_typ = comtyp **
57 +* rset_type = rsttyp **
58 +* arg_type = argtyp **
59 +* symdump = symdmp **
60 +* valdump = valdmp **
smfb 88 +* format_form = formfm **
61 +* dblock = dmpblk **
62 +* namesds = namsds **
63
64
1 .=member stlini
2 subr stlini;
3
4 .+set part1
5
6 .=include cndasm $ conditional assembly symbols
7 .=include sysmac $ machine parameters
8
9 .=include formtab $ form table
10
11 .=include q2flds $ q2 field definitions to access heap
12 .=include q2opcd $ q2 opcodes
13 .=include q2macs $ (general) q2 macros
14 .=include q2vars $ q2 variables
15 .=include binio $ setl binary i/o
mjsa 9 .=include lipkg $ long integer arithmetic package
16 .=include measpkg $ measurement package
17
18 end subr stlini;
1 .=member start
2 .+s10 prog stlcod;
3 .+s20 prog stlcod;
4 .+r32 prog stlcod;
5 .+s66 subr start;
6
7$ in this section we define all the data structures of the code
8$ generator. we begin with a few meta macros and utilities.
9
10 +* prog_level = $ program level(julian date of last fix)
bnda 8 'cod(85007) '
12 **
13
14
15
16
17$ q1 data structures
18$ ------------------
19
20$ the following data structures are used for q1.
21
22
23 .=include q1symtab
24 .=include q1code
25
26$ n.b. we do not include the form table into the following macro since
27$ it is relevant to both q1 and q2, and hence defined separately.
28
29 +* q1vars = $ namesets which define q1
30 nssymtab, $ - q1 symbol table
31 nsq1code $ - q1 code table
32 **
33
34$ the code generator uses some additional q1 opcodes between the
35$ fixup- and code generation phases. define these additional codes
36$ here
37
38 macdrop(q1_maximum)
39
40 defc(q1_ifeq) $ if a2 = a3 goto a1
41 defc(q1_ifne) $ if a2 /= a3 goto a1
42 defc(q1_ifge) $ if a2 ge a3 goto a1
43 defc(q1_iflt) $ if a2 lt a3 then goto a1
44 defc(q1_ifin) $ if a2 in a3 then goto a1
45 defc(q1_ifnin) $ if a2 notin a3 then goto a1
46 defc(q1_ifinc) $ if a2 incs a3 goto a1
47 defc(q1_ifsub) $ if a2 subset a3 goto a1
48
49 +* q1_maximum = q1_ifsub ** $ maximum opcode
50
51
52 nameset nscod; $ nameset with variables for cod phase
53
54$ the opcodes are divided into classes depending on how they are
55$ handled by the code generator.
56
57 .=zzyorg z
58
59 defc(cl_simp) $ trivial cases
60 defc(cl_noop) $ noop
61 defc(cl_min) $ min and max
62 defc(cl_lessf) $ lessf
63 defc(cl_umin) $ unary minus
64 defc(cl_int) $ yield int
65 defc(cl_real) $ yield real
66 defc(cl_str) $ yield string
67 defc(cl_bool) $ yield boolean
68 defc(cl_uset) $ yield set(*)
69 defc(cl_not) $ not
70 defc(cl_rand) $ rand
71 defc(cl_arb) $ arb
72 defc(cl_stmt) $ statement number
73 defc(cl_call) $ calls
74 defc(cl_goto) $ goto
75 defc(cl_ifgo) $ conditional gotos
76 defc(cl_ifgo1) $ conditional gotos with two inputs
77 defc(cl_case) $ case jump
78 defc(cl_lab) $ labels
79 defc(cl_entry) $ routine entry
80 defc(cl_exit) $ roitine exitue
81 defc(cl_bin) $ binary operation +, -, *, /, and //
82 defc(cl_with) $ with and less
83 defc(cl_from) $ from
84 defc(cl_pred1) $ membership tests
85 defc(cl_pred2) $ binary predicates
86 defc(cl_asrt) $ test program assertion
87 defc(cl_nelt) $ nelt
88 defc(cl_newat) $ newat
89 defc(cl_of) $ f(x)
90 defc(cl_ofa) $ f<>
91 defc(cl_subst) $ subst and send
92 defc(cl_sof) $ f(x) := y
93 defc(cl_sofa) $ f<> := y
94 defc(cl_ssubst) $ ssubst and ssend
95 defc(cl_argin) $ argument push
96 defc(cl_argout) $ argument pop
97 defc(cl_push) $ q1_push
98 defc(cl_free) $ free stack space
99 defc(cl_asn) $ x := y
100 defc(cl_next) $ q1_next and q1_inext
101 defc(cl_nextd) $ nextd and inextd
102 defc(cl_st) $ enumerative set/tuple former
103 defc(cl_st1) $ set1 and tup1
104 defc(cl_st2) $ domain/range
105 defc(cl_ok) $ ok
106 defc(cl_fail) $ fail
107 defc(cl_succeed) $ succeed
108 defc(cl_debug) $ run time debugging requests
109
110
111 +* cl_minimum = cl_simp **
112 +* cl_maximum = cl_debug **
113
114
115$ there are several pointers to the q2 tables which are only needed
116$ at compile time:
117
118 size code_org(ps); $ pointer to start of current code block
119 data code_org = 0;
120
121 size code_tot(ps); $ total size of q2 code
122 data code_tot = 0;
123
124$
125$ the heap is organized as follows:
126$
127$ high core
128$
129$ t, savet --> (stack initially empty)
130$ h_lim -----> +---------+
131$ i/////////i
132$ i/////////i
133$ >=========< free storage
134$ i/////////i
135$ h ---------> i/////////i
136$ i i
137$ i i
138$ >=========< heap proper
139$ i i
140$ i i
141$ h_org -----> i i
142$ i/////////i
143$ i/////////i
144$ >=========< storage for constants and code
145$ i/////////i
146$ h_const ---> i/////////i
147$ i i
148$ >=========< constants and interpretable code
149$ i i
150$ ca_org ----> i i
151$ sym_end ---> i i
152$ i i
153$ >=========< symbol table
154$ i i
155$ sym_lim ---> i i
156$ i/////////i
157$ >=========< storage for symbol table
158$ sym_org ---> i/////////i
159$ snam_end --> i i
160$ i i
161$ >=========< run-time names table
162$ i i
163$ i i
164$ i/////////i
165$ >=========< storage for run-time names table
166$ i/////////i
167$ snam_org --> +---------+
168$
169$ the stack and heap both grow towards the middle of the free
170$ storage area. the garbage collector uses the gap between the
171$ stack and the heap as a work space. when this gap reaches the
172$ value 'min_gap' we call the garbage collector.
173$
174$ the symbol table contains one location for each variable, constant,
175$ and base. it also contains an entry for each unique data type
176$ which is used to store the standard representation for omega
177$ for that type.
178$
179$ the low order end of the heap is reserved for constants. a data
180$ block can be stored in the constants area if it meets three
181$ conditions:
182$
183$ 1. it is live throughout the entire program.
184$ 2. it is never modified during execution.
185$ 3. it contains no pointers into the remainder of the heap.
186$
187$ the constants area is ignored by the garbage collector, and is
188$ never compacted. pointers into this area are considered to be null
189$ and are never traced. this means that the null pointer at the end
190$ of a list need not be zero; it can be any small integer, say the size
191$ of an element block.
192$
193$ the code generator builds some blocks which can go in the constants
194$ area and some which cannot. the break down is as follows:
195$
196$ block type where stored why
197$ ---------- ------------ ---
198$
199$ code constants area never modified
200$ bases dynamic area modified at run time
201$
202$ primitive constants constants area never modified at run time
203$ constant sets + tuples dynamic area may point to bases
204$
205$ all omega values are typed, i.e. 'omega set', 'omega real' and are
206$ stored with the constants of the appropriate type.
207$
208$ there are two ways to build the heap:
209$
210$ 1. build all the blocks which go in the constants area then build
211$ all the blocks which go in the dynamic area. in order to do this
212$ we must either make two passes through the q1 file or keep the
213$ entire q1 symbol table in core through code generation.
214$
215$ 2. build all the blocks for one unit, then all the blocks for the
216$ second unit. in order to do this we must estimate the size of the
217$ constants area in advance and reserve space for it. if we run out
218$ of space we must abort.
219$
220$ we choose the second method since it is simpler and more efficient.
221$ experience will allow us to make good estimates. furthermore if we
222$ over estimate the size of the constants area we can always garbage
223$ collect the extra space.
224$
225$ there are several standard pointers into the heap:
226$
227$ t: points to top of stack
228$ h: points to next free word of heap
229$ h_org: points to first word of heap proper
230$ sym_org: points to first word of the symbol table
231$ sym_end: points to last word of symbol table
232$
233$ in addition we keep a pointer to the next free word of the
234$ constants area:
235
236 size h_const(ps);
237
238 +* get_const(n, p) = $ get n words in constants area
239 p = h_const;
240 h_const = h_const + n;
241 if (h_const > h_org) call overfl('constants area');
242 **
243
244 +* get_symtab(n) = $ get n symbol table entries
245 sym_lim = sym_lim - n;
246 if (sym_lim < sym_org) call overfl('run-time symbol table');
247 **
248
249 +* get_code(n, p) = $ allocate storage for code
250 if asm_flag then
251 if codep ^= 0 & codep + inst_nw ^= h then
252 call abort('compiler error - please report');
253 end if;
254 get_heap(n, p);
255 else
256 get_const(n, p);
257 end if;
258 **
smfb 90
smfb 91
smfb 92 size h_names1(ps); $ end of last names string block
smfb 93 size h_names2(ps); $ start of next block
259
260
261$ treatment of built in procedures
262$
263$ certain language primitives such as read and print are expressed
264$ as procedure calls, both at the source level and at the q1 level.
265$ during code generation calls to built in procedures are special
266$ cased to produce more efficient code.
267$
268$ each built in procedure xxx has a corresponding q2 opcode
269$ q2_xxx which calls the corresponding procedure in the run time
270$ library.
271$
272$ for the moment we pass arguments to built in procedures the same
273$ way we pass arguments to procedures written in setl, i.e. by
274$ a series of stack pushes and pops.
275$
276$ in the near future we will improve the calling sequence for
277$ non-recursive procedures so that the argin and argout assignments
278$ are made directly between the argument and the parameter, without
279$ using the stack. as a side effect, this will improve argument
280$ passage for built in procedures.
281$
282$ eventually we will add more special casing so that the
283$ instructions for built in procedure calls contain the arguments
284$ directly.
285$
286$ the array bip_op maps the names of built in procedures into
287$ the corresponding q2 opcode.
288
289 +* bip_op(nam) = a_bip_op(nam - sym_bip_min + 1) **
290
291 size a_bip_op(ps);
292 dims a_bip_op(sym_bip_max - sym_bip_min + 1);
293
294 data bip_op(sym_open) = q2_open: $ open
295 bip_op(sym_close) = q2_close: $ close
296 bip_op(sym_print) = q2_print: $ print
297 bip_op(sym_read) = q2_read: $ read
298 bip_op(sym_printa) = q2_printa: $ printa
299 bip_op(sym_reada) = q2_reada: $ reada
300 bip_op(sym_get) = q2_get: $ get
301 bip_op(sym_put) = q2_put: $ put
302 bip_op(sym_getb) = q2_getb: $ getb
303 bip_op(sym_putb) = q2_putb: $ putb
304 bip_op(sym_getk) = q2_getk: $ getk
305 bip_op(sym_putk) = q2_putk: $ putk
306 bip_op(sym_getf) = q2_getf: $ getf
307 bip_op(sym_callf) = q2_callf: $ callf
308 bip_op(sym_putf) = q2_putf: $ putf
309 bip_op(sym_rewind) = q2_rewind: $ rewind
310 bip_op(sym_eof) = q2_eof: $ .eof
311 bip_op(sym_eject) = q2_eject: $ eject
312 bip_op(sym_title) = q2_titl: $ title
313 bip_op(sym_getipp) = q2_getipp: $ getipp
314 bip_op(sym_getspp) = q2_getspp: $ getspp
315 bip_op(sym_getem) = q2_getem: $ getem
316 bip_op(sym_setem) = q2_setem: $ setem
317 bip_op(sym_host) = q2_host: $ host
318 bip_op(sym_span) = q2_span: $ span
319 bip_op(sym_break) = q2_break: $ break
320 bip_op(sym_match) = q2_match: $ match
321 bip_op(sym_lpad) = q2_lpad: $ lpad
322 bip_op(sym_len) = q2_len: $ len
323 bip_op(sym_any) = q2_any: $ any
324 bip_op(sym_notany) = q2_notany: $ notany
325 bip_op(sym_rspan) = q2_rspan: $ rspan
326 bip_op(sym_rbreak) = q2_rbreak: $ rbreak
327 bip_op(sym_rmatch) = q2_rmatch: $ rmatch
328 bip_op(sym_rpad) = q2_rpad: $ rpad
329 bip_op(sym_rlen) = q2_rlen: $ rlen
330 bip_op(sym_rany) = q2_rany: $ rany
331 bip_op(sym_rnotany) = q2_rnotany; $ rnotany
332
333
334
335
336
337$ attributes of current instruction
338
339 size curmemb(ps); $ name of current member
340 size currout(ps); $ name of current routine
341 size curunit(ps); $ name of current scope
342
343 size unit_type(ps); $ type of current unit
344
345$ the codes for unit_type are:
346
347 .=zzyorg z
348
349 defc(unit_sys) $ system scope
350 defc(unit_lib) $ library
351 defc(unit_dir) $ directory
352 defc(unit_prog) $ program
353 defc(unit_mod) $ module
354 defc(unit_proc) $ procedure
355 defc(unit_end) $ end of compilation
356
357 +* unit_min = unit_sys **
358 +* unit_max = unit_end **
359
360
361$ variables are divided into the following storage classes:
362
363 .=zzyorg z
364
stra 11 defc(scl_untyped) $ constants and untyped values
stra 12 defc(scl_param) $ formal parameters
stra 13 defc(scl_static) $ static typed variables and bases
stra 14 defc(scl_stacked) $ stacked typed variables
369
stra 15 +* scl_min = scl_untyped ** $ minimum class
stra 16 +* scl_max = scl_stacked ** $ maximum class
372
373
374$ there are two maps on storage classes:
375
376$ blocklen: gives the length of each block for the current scope
377$ blockorg: gives the origin of each block for the current scope
378
379 size blocklen(ps);
stra 17 dims blocklen(scl_max);
381
382 size blockorg(ps);
stra 18 dims blockorg(scl_max);
384
385
386$ we keep three statement counters:
387$
388$ cstmt_count: the cummulative statement count
389$ ustmt_count: the cstmt_count at the start of the current unit
390$ estmt_count: the cstmt_count of the q1_entry instruction. note that
391$ this count is only set for procedure scopes.
392$
393$ the current statement number is equal to cstmt_count - ustmt_count + 1
394
395 +* stmt_count = (cstmt_count - ustmt_count + 1) **
396
397 size cstmt_count(ps); data cstmt_count = 0;
398 size ustmt_count(ps); data ustmt_count = 0;
399 size estmt_count(ps); data estmt_count = 0;
400$
401$ in addition, we keep a count of the number of q2 statements generated,
402$ for statistical purposes.
403$
404 size stmt_tot(ps); $ total number of statements
405 data stmt_tot = 0;
406
407 size error_count(ps); $ error count
408 data error_count = 0;
409
410 size eof_flag(1); $ indicates eof on q1 file
411 data eof_flag = no;
smfa 20
smfa 21
smfa 22 size rnames(ps); $ pointer to run-time names tuple
smfa 23
412
413
414 size prev(ps); $ points to previous instruction
415 size now(ps); $ points to curent instruction
416
417 +* op = opcode(now) ** $ current opcode
418 +* a1 = arg1(now) ** $ current arg1
419 +* a2 = arg2(now) ** $ current arg2
420 +* a3 = arg3(now) ** $ current arg3
421 +* a4 = arg4(now) ** $ current arg4
422
423 +* fm1 = form(a1) ** $ their types
424 +* fm2 = form(a2) **
425 +* fm3 = form(a3) **
426 +* fm4 = form(a4) **
427
428 size addr_a1(ps), $ their run time addresses
429 addr_a2(ps),
430 addr_a3(ps),
431 addr_a4(ps);
432
433$ the following macros give the addresses of the standard
434$ temporaries used for copies and conversions.
435
436 +* addr_t1 = address(sym_t1_) **
437 +* addr_t2 = address(sym_t2_) **
438 +* addr_t3 = address(sym_t3_) **
439 +* addr_t4 = address(sym_t4_) **
440
441
442
443$ utility macros
444
445 +* symtype(nam) = $ type of symbol
446 ft_type(form(nam))
447 **
448
449 +* symval(nam) = $ first word of value
450 val(vptr(nam))
451 **
452
453 +* get_addr(addr, nam) = $ get address of symbol
454 size zzza(ps);
455
456 zzza = nam;
457 if (alias(zzza) ^= 0) zzza = alias(zzza);
458
459 addr = 0;
460 if (zzza ^= 0) addr = address(zzza);
461 **
462
463
464 +* code_loop = $ standard loop over q1 code
465 size zzza(ps);
466
467
468 do zzza = blocktab_org+1 to blocktabp;
469
470 prev = 0;
471 now = b_first(zzza);
472
473 while now ^= 0;
474 **
475
476
477 +* cont_loop = $ continue
478 go to nxt_lab;
479 **
480
481
482 +* quit_loop = $ quit
483 quit do;
484 **
485
486
487 +* end_loop = $ end
488 /nxt_lab/
489 prev = now;
490 now = next(now);
491 end while;
492 end do;
493 **
494
495
496 +* lines_max = $ no. of lines between headings on dumps
497 20
498 **
499
500
501$ code for backtracking
502$ ---------------------
503$
504$ the opcodes for backtracking fall into two categories:
505$
506$ 1. opcodes which save environments
507$ 2. opcodes which restore environments
508$
509$ the instructions in group (1) build 'environment blocks' on
510$ the stack; the instructions in group (2) pop them. each
511$ environment block contains a pointer to the appropriate
512$ restore instruction.
513$
514$ the block types and their appropriate instructions are:
515$
516$ environment type save instruction restore instruction
517$ ---------------- ---------------- -------------------
518$
519$ entry block q2_entry q2_dexit
520$ exit block q2_exit q2_undo
521$ ok block q2_ok q2_fail2
522$
523$ each routine contains a single dexit, undo, and fail2 instruction.
524$ these instructions are located at the beginning of the procedure.
525$ thus a procedure prologue looks like:
526$
527$ entry instruction
528$ branch to body
529$
530$ dexit, undo, and fail2 instructions
531$
532$ body
533$
534$ we keep global pointers to the undo and fail2 instructions since
535$ they are needed as arguments to the exit and fail instructions
536$ respectively.
537
538 size undo_addr(ps),
539 fail2_addr(ps);
540
541
542
543
544
545$ o p t a b
546$ ---------
547$
548$ the array 'optab' gives information on q1 opcodes. its fields are:
549$
550$ class: code cl_xxx giving class of instruction
551$ std_op: standard q2 opcode
552$ if_op: maps predicate into branch on true
553$ ifn_op: maps predicate into branch on false
554$ is_pre: see below
555$
556$ when we have a code pattern such as:
557$
558$ t := b op c;
559$ a := t;
560$
561$ we have two choices:
562$
563$ 1. give t a type which is a function of op, b, and c.
564$ then convert on the assignment if necessary
565$
566$ 2. give t the type of a. if necessary convert b and c before
567$ applying 'op'.
568$
569$ the choice we make is a function of op. the map is_pre(op)
570$ is true for opcodes where we use case (2).
571
572 size optab(32);
573 dims optab(q1_maximum);
574
575 +* class(i) = .f. 01, 06, optab(i) **
576 +* ops_ovar(i) = .f. 07, 01, optab(i) **
577 +* is_pre(i) = .f. 08, 01, optab(i) **
578 +* if_op(i) = .f. 09, 07, optab(i) **
579 +* ifn_op(i) = .f. 16, 07, optab(i) **
580 +* std_op(i) = .f. 23, 10, optab(i) **
581
582
583 data
584
585 +* s(op, cl, std, if, ifn, ovar, pre) =
586 optab(op) = std * 4b'00400000'
587 + ifn * 4b'00008000'
588 + if * 4b'00000100'
589 + pre * 4b'00000080'
590 + ovar * 4b'00000040'
591 + cl * 4b'00000001'
592 **
593
594$ op class std_op if_op ifn_op ovar pre
595
596 s(q1_in, cl_pred1, q2_in, q1_ifin, q1_ifnin, yes, no ):
597 s(q1_notin, cl_pred1, q2_nin, q1_ifnin, q1_ifin, yes, no ):
598 s(q1_incs, cl_pred2, q2_incs, q1_ifinc, q1_ifsub, yes, no ):
599 s(q1_lt, cl_pred2, q2_lt, q1_iflt, q1_ifge, yes, no ):
600 s(q1_ge, cl_pred2, q2_ge, q1_ifge, q1_iflt, yes, no ):
smfb 94 s(q1_pos, cl_pred2, 0, 0, 0, yes, no ):
601 s(q1_eq, cl_pred2, q2_eq, q1_ifeq, q1_ifne, yes, no ):
602 s(q1_ne, cl_pred2, q2_ne, q1_ifne, q1_ifeq, yes, no ):
603 s(q1_with, cl_with, q2_with, 0, 0, yes, yes):
604 s(q1_less, cl_with, q2_less, 0, 0, yes, no ):
605 s(q1_lessf, cl_lessf, q2_lessf, 0, 0, yes, no ):
606 s(q1_npow, cl_uset, q2_npow, 0, 0, yes, no ):
607 s(q1_min, cl_min, q2_min, 0, 0, yes, no ):
608 s(q1_max, cl_min, q2_max, 0, 0, yes, no ):
609 s(q1_add, cl_bin, q2_add, 0, 0, yes, yes):
610 s(q1_sub, cl_bin, q2_sub, 0, 0, yes, yes):
611 s(q1_mult, cl_bin, q2_mult, 0, 0, yes, yes):
612 s(q1_slash, cl_bin, q2_slash, 0, 0, yes, yes):
613 s(q1_div, cl_bin, q2_div, 0, 0, yes, yes):
614 s(q1_mod, cl_bin, q2_mod, 0, 0, yes, yes):
615 s(q1_atan2, cl_real, q2_atan2, 0, 0, yes, no ):
616 s(q1_exp, cl_bin, q2_exp, 0, 0, yes, no ):
617
618$ op class std_op if_op ifn_op ovar pre
619
620 s(q1_not, cl_not, q2_not, 0, 0, yes, no ):
621 s(q1_even, cl_bool, q2_even, 0, 0, yes, no ):
622 s(q1_odd, cl_bool, q2_odd, 0, 0, yes, no ):
623 s(q1_isint, cl_bool, q2_isint, 0, 0, yes, no ):
624 s(q1_isreal, cl_bool, q2_isreal, 0, 0, yes, no ):
625 s(q1_isstr, cl_bool, q2_isstr, 0, 0, yes, no ):
626 s(q1_isbool, cl_bool, q2_isbool, 0, 0, yes, no ):
627 s(q1_isatom, cl_bool, q2_isatom, 0, 0, yes, no ):
628 s(q1_istup, cl_bool, q2_istup, 0, 0, yes, no ):
629 s(q1_isset, cl_bool, q2_isset, 0, 0, yes, no ):
630 s(q1_ismap, cl_bool, q2_ismap, 0, 0, yes, no ):
631 s(q1_arb, cl_arb, q2_arb, 0, 0, yes, no ):
632 s(q1_dom, cl_st2, q2_domain, 0, 0, yes, no ):
633 s(q1_range, cl_st2, q2_range, 0, 0, yes, no ):
634 s(q1_pow, cl_uset, q2_pow, 0, 0, yes, no ):
635 s(q1_nelt, cl_nelt, q2_nelt, 0, 0, yes, no ):
636 s(q1_abs, cl_umin, q2_abs, 0, 0, yes, no ):
637 s(q1_char, cl_str, q2_char, 0, 0, yes, no ):
638 s(q1_umin, cl_umin, q2_umin, 0, 0, yes, no ):
639 s(q1_ceil, cl_int, q2_ceil, 0, 0, yes, no ):
640 s(q1_floor, cl_int, q2_floor, 0, 0, yes, no ):
641 s(q1_fix, cl_int, q2_fix, 0, 0, yes, no ):
642 s(q1_float, cl_real, q2_float, 0, 0, yes, no ):
643 s(q1_sin, cl_real, q2_sin, 0, 0, yes, no ):
644 s(q1_cos, cl_real, q2_cos, 0, 0, yes, no ):
645 s(q1_tan, cl_real, q2_tan, 0, 0, yes, no ):
646 s(q1_arcsin, cl_real, q2_arcsin, 0, 0, yes, no ):
647 s(q1_arccos, cl_real, q2_arccos, 0, 0, yes, no ):
648 s(q1_arctan, cl_real, q2_arctan, 0, 0, yes, no ):
649 s(q1_tanh, cl_real, q2_tanh, 0, 0, yes, no ):
650 s(q1_expf, cl_real, q2_expf, 0, 0, yes, no ):
651 s(q1_log, cl_real, q2_log, 0, 0, yes, no ):
652 s(q1_sqrt, cl_real, q2_sqrt, 0, 0, yes, no ):
653 s(q1_rand, cl_rand, q2_rand, 0, 0, yes, no ):
654 s(q1_sign, cl_int, q2_sign, 0, 0, yes, no ):
655 s(q1_type, cl_str, q2_type, 0, 0, yes, no ):
656 s(q1_str, cl_str, q2_str, 0, 0, yes, no ):
657 s(q1_val, cl_int, q2_val, 0, 0, yes, no ):
658
659 s(q1_newat, cl_newat, q2_newat1, 0, 0, yes, yes):
660 s(q1_time, cl_int, q2_time, 0, 0, yes, no ):
661 s(q1_date, cl_str, q2_date, 0, 0, yes, no ):
662 s(q1_na, cl_int, q2_na, 0, 0, yes, no ):
663
664 s(q1_set, cl_st, 0, 0, 0, yes, yes):
665 s(q1_set1, cl_st1, 0, 0, 0, yes, no ):
666 s(q1_tup, cl_st, 0, 0, 0, yes, yes):
667 s(q1_tup1, cl_st1, 0, 0, 0, yes, no ):
668
669 s(q1_from, cl_from, q2_from, 0, 0, yes, no ):
670 s(q1_fromb, cl_from, q2_fromb, 0, 0, yes, no ):
671 s(q1_frome, cl_from, q2_frome, 0, 0, yes, no ):
672
673 s(q1_next, cl_next, q2_next, 0, 0, yes, no ):
674 s(q1_nextd, cl_nextd, q2_nextd, 0, 0, yes, no ):
675 s(q1_inext, cl_next, q2_inext, 0, 0, yes, no ):
676 s(q1_inextd, cl_nextd, q2_inextd, 0, 0, yes, no ):
677
678 s(q1_of, cl_of, q2_of, 0, 0, yes, no ):
679 s(q1_ofa, cl_ofa, q2_ofa, 0, 0, yes, no ):
680 s(q1_end, cl_subst, q2_end, 0, 0, yes, no ):
681 s(q1_subst, cl_subst, q2_subst, 0, 0, yes, no ):
682
683 s(q1_sof, cl_sof, q2_sof, 0, 0, yes, no ):
684 s(q1_sofa, cl_sofa, q2_sofa, 0, 0, yes, no ):
685 s(q1_send, cl_ssubst, q2_send, 0, 0, yes, no ):
686 s(q1_ssubst, cl_ssubst, q2_ssubst, 0, 0, yes, no ):
687
688 s(q1_asn, cl_asn, q2_asn, 0, 0, yes, no ):
689 s(q1_argin, cl_argin, q2_push1, 0, 0, no, yes):
690 s(q1_argout, cl_argout, q2_pop1, 0, 0, yes, no ):
691 s(q1_push, cl_push, q2_push1, 0, 0, no, no ):
692 s(q1_free, cl_free, q2_free, 0, 0, no, no ):
693
694 s(q1_call, cl_call, q2_call, 0, 0, no, no ):
695 s(q1_goto, cl_goto, q2_goto, 0, 0, no, no ):
696 s(q1_if, cl_ifgo, 0, 0, 0, no, no ):
697 s(q1_ifnot, cl_ifgo, 0, 0, 0, no, no ):
smfb 95 s(q1_bif, cl_ifgo, 0, 0, 0, no, no ):
smfb 96 s(q1_bifnot, cl_ifgo, 0, 0, 0, no, no ):
698 s(q1_case, cl_case, q2_caseusm, 0, 0, no, no ):
699 s(q1_stop, cl_simp, q2_stop, 0, 0, no, no ):
700
701 s(q1_entry, cl_entry, 0, 0, 0, no, no ):
702 s(q1_exit, cl_exit, 0, 0, 0, no, no ):
703
704 s(q1_ok, cl_ok, q2_ok, 0, 0, no, no ):
705 s(q1_lev, cl_int, q2_lev, 0, 0, no, no ):
706 s(q1_fail, cl_fail, q2_fail1, 0, 0, no, no ):
707 s(q1_succeed, cl_succeed, q2_succeed, 0, 0, no, no ):
708
709 s(q1_asrt, cl_asrt, q2_asrt, 0, 0, no, no ):
smfb 97 s(q1_ifasrt, cl_asrt, q2_ifasrt, 0, 0, no, no ):
710 s(q1_stmt, cl_stmt, q2_stmt, 0, 0, no, no ):
711 s(q1_label, cl_lab, q2_lab, 0, 0, no, no ):
712 s(q1_tag, cl_lab, q2_tag, 0, 0, no, no ):
713 s(q1_debug, cl_debug, 0, 0, 0, no, no ):
714 s(q1_trace, cl_debug, 0, 0, 0, no, no ):
715 s(q1_notrace, cl_debug, 0, 0, 0, no, no ):
716 s(q1_error, cl_simp, q2_error, 0, 0, no, no ):
717 s(q1_noop, cl_noop, 0, 0, 0, no, no ):
718
719 s(q1_ifeq, cl_ifgo1, q2_goeq, 0, 0, no, no ):
720 s(q1_ifne, cl_ifgo1, q2_gone, 0, 0, no, no ):
721 s(q1_ifge, cl_ifgo1, q2_goge, 0, 0, no, no ):
722 s(q1_iflt, cl_ifgo1, q2_golt, 0, 0, no, no ):
723 s(q1_ifin, cl_ifgo1, q2_goin, 0, 0, no, no ):
724 s(q1_ifnin, cl_ifgo1, q2_gonin, 0, 0, no, no ):
725 s(q1_ifinc, cl_ifgo1, q2_goincs, 0, 0, no, no ):
726 s(q1_ifsub, cl_ifgo1, q2_gonincs, 0, 0, no, no );
727
728 macdrop(s)
729
730
731$ special casing
732$ --------------
733$
734$ one of the main tasks of the 'codegen' phase is to perform special
735$ casing of each instruction based on the types of its inputs.
736$
737$ each q1 primitive has one 'crucial' argument whose type is
738$ particularly useful in special casing the instruction. for example,
739$ when we special case 'a1(a2) := a3', we are most interested in
740$ the type of a1.
741$
742$ mapping a q1 opcode into the proper q2 opcode is done in three
743$ steps:
744$
745$ 1. find the 'crucial' argument and see if the other arguments
746$ are compatible with its type.
747$
748$ 2. if the types are compatible, then look up the appropriate
749$ opcode in 'spec_op'. spec_op is a map from pairs [q1 opcode,
750$ form of crucial argument] to q2 opocdes.
751$
752$ if spec_op indicates zero, then there is no special case
753$ opcode available, and we proceed to step 3.
754$
755$ 3. if the argument types are incompatible or there is no
756$ special case, then we will use the standard q2 opcode,
757$ which is given by std_op(q1 opcode).
758
759
760 +* opsz = $ size of q1 opcode - should divide word size
suna 15 .+r32 16
suna 16 .+r36 12
761 .+s66 10
767 **
768
769 +* spec_op(op, form) =
770 .f. 1 + ft_type(form) * opsz, opsz, a_spec_op(op)
771 **
772
773 size a_spec_op((f_max+1) * opsz);
774 dims a_spec_op(q1_maximum);
775 data a_spec_op = 0(q1_maximum);
776
777
778
779$ in order to special case 'of' and 'sof' operations on maps we must
780$ look at both the ft_type and ft_mapc fields of the map. this is done
781$ by the table 'of_op'.
782
783 +* of_op(op, tp, mapc) =
784 .f. 1 + (tp * ft_max + mapc-1) * opsz, opsz,
785 a_of_op(op - q1_of + 1)
786 **
787
788 size a_of_op((f_max + 1) * ft_max * opsz);
789 dims a_of_op(q1_sofa - q1_of + 1);
790 data a_of_op = 0(q1_sofa - q1_of + 1);
791
792$ the table 'share_op' maps retrivel operations which do not
793$ set share bits into those which do.
794
795 +* share_op(op) =
796 a_share_op(op - q2_of + 1)
797 **
798
799 size a_share_op(ps);
800 dims a_share_op(q2_ofarmm - q2_of + 1);
801 data a_share_op = 0(q2_ofarmm - q2_of + 1);
802
803$ there are various special opcodes for testing a variable for
804$ equality with a system constant. the table 'eq_op' gives
805$ the special opcodes for each system constant. it has the
806$ following fields:
807
808$ eqop: gives special case for q1_eq
809$ neop: gives special case for q1_ne
810$ ifeqop: gives special case for q1_ifeq
811$ ifneop: gives special case for q1_ifne
812
813 size eq_op(4 * opsz);
814 dims eq_op(sym_maximum);
815 data eq_op = 0(sym_maximum);
816
817 +* eqop(i) = .f. 1 + 0*opsz, opsz, eq_op(i) **
818 +* neop(i) = .f. 1 + 1*opsz, opsz, eq_op(i) **
819 +* ifeq_op(i) = .f. 1 + 2*opsz, opsz, eq_op(i) **
820 +* ifne_op(i) = .f. 1 + 3*opsz, opsz, eq_op(i) **
821
822
823
824$ typetab
825$ -------
826
827$ the array typetab maps ft_type codes into type codes and htype
828$ codes. its fields are:
829
830$ tmap: maps code f_xxx into code t_xxx
831$ htmap: maps code f_xxx into code h_xxx
832
833 +* tmap(i) = .f. 01, 16, typetab(i) **
834 +* htmap(i) = .f. 17, 16, typetab(i) **
835
836 defzero(typetab, a_typetab);
837
838 size a_typetab(32);
839 dims a_typetab(f_max+1);
840 data
841
842 +* s(fm, tp, ht) =
843 typetab(fm) = ht * 4b'00010000' + tp
844 **
845
846 s(f_gen, t_oint, 0 ):
847 s(f_sint, t_oint, 0 ):
848 s(f_sstring, t_ostring, 0 ):
849 s(f_atom, t_oatom, 0 ):
850 s(f_latom, t_olatom, h_latom ):
851 s(f_elmt, t_oelmt, 0 ):
852 s(f_int, t_olint, h_lint ):
853 s(f_string, t_oistring, h_lstring ):
854 s(f_real, t_oreal, h_real ):
855 s(f_ituple, t_ostuple, h_ituple ):
856 s(f_rtuple, t_ostuple, h_rtuple ):
857 s(f_ptuple, t_ostuple, h_ptuple ):
858 s(f_tuple, t_otuple, h_tuple ):
859 s(f_mtuple, t_otuple, h_tuple ):
860 s(f_uset, t_oset, h_uset ):
861 s(f_lset, t_oset, h_lset ):
862 s(f_rset, t_oset, h_rset ):
863 s(f_umap, t_omap, h_umap ):
864 s(f_lmap, t_omap, h_lmap ):
865 s(f_rmap, t_omap, h_rmap ):
866 s(f_lpmap, t_omap, h_lpmap ):
867 s(f_limap, t_omap, h_limap ):
868 s(f_lrmap, t_omap, h_lrmap ):
869 s(f_rpmap, t_omap, h_rpmap ):
870 s(f_rimap, t_omap, h_rimap ):
871 s(f_rrmap, t_omap, h_rrmap ):
872 s(f_base, t_set, h_base ):
873 s(f_pbase, t_olatom, h_latom ):
874 s(f_error, t_oerror, 0 );
875
876 macdrop(s)
877
878
879$ the following parameters are read from the control card:
880
881 size q1_title(.sds. filenamlen); $ little q1 file
882 size sq1_title(.sds. filenamlen); $ setl q1 file
883 size q2_title(.sds. filenamlen); $ q2 file
884 size term_title(.sds. filenamlen); $ terminal file
885
886 size rem(ps); $ run-time error mode
887 size cel(ps); $ code generator error limit
888 size sym_lim(ps); $ current extend of symbol table
889 size ca_lim(ps); $ dimension of constants area
890 size asm_flag(1); $ on if producing assembly code
891 size sif_flag(1); $ save intermediate files
892 size tre_flag(1); $ on if entry trace desired
893 size et_flag(1); $ on if error trace desired
894 size q1cd_flag(1); $ q1 code dumps after 'fixup'
895 size q1sd_flag(1); $ q1 symtab dumps after 'alloc'
896 size q2cd_flag(1); $ q2 code dumps after 'codegen'
897 size q2sd_flag(1); $ q2 storage dump after 'inienv2'
sunb 12 size lcp_flag(1); $ listing control: program parameters
sunb 13 size lcs_flag(1); $ listing control: program statistics
898 size opt_flag(1); $ on if global optimizer in use
smfb 98 size rpr_flag(ps); $ on to generate conversion messages
899 size stmt_flag(2); $ on to generate q2 statement quadruples
900
901$ utility functions
902
903 size symsds(sds_sz); $ returns symtab entry as sds
904 size namesds(sds_sz); $ returns names entry as sds
905 size can_assign(1); $ true if assignment is trivial
906 size simp_type(ps); $ result type of simple operation
907 size bin_type(ps); $ result type of binary op
909 size elmt_type(ps); $ element type
910 size dom_type(ps); $ domain type
911 size im_type(ps); $ image type
912 size compn_typ(ps); $ type of n-th component
913 size rset_type(ps); $ range set type
914 size arg_type(ps); $ argument type for procedure
915
916
917$ i-o macros
918$ ----------
919
920
921$ file numbers
922
923 .=zzyorg z
924
925 defc(in_file) $ input
926 defc(out_file) $ output
927 defc(q1_file) $ little q1 file
928 defc(sq1_file) $ setl q1 file
929 defc(q2_file) $ q2
930
931
932 end nameset nscod;
933
934
935
936
937
938$ begin execution
939
940 call stlini; $ initialise the q2 tables.
941 call codini; $ initialize
942 call inienv1; $ start building heap
943
944 while 1;
945 call gettab;
946 if (eof_flag) quit;
947
948 if (unit_type = unit_proc) call fixup;
949 call alloc;
950 if (unit_type = unit_proc) call codegen;
951 call inienv2;
952 end while;
953
954 call codtrm(0); $ normal termination
955
956 .+s66 end subr start;
957 .+r32 end prog stlcod;
958 .+s10 end prog stlcod;
959 .+s20 end prog stlcod;
960
961
962 .+tr trace entry; $ entry trace for code generator
963
964
1 .=member codini
2 subr codini;
3
4$ this routine is called to initialize the code generator. there
5$ are three types of initialization performed:
6$
7$ 1. read control card parameters
8$ 2. open files
9$ 3. initialize tables used for special casing.
10
11
12 size ret(ps); $ return code from dropsio and namesio
13 size timestr(.sds. 30); $ current time
14 size termh_flag(1); $ print phase heading on terminal
15
16 runtime_flag = no; $ indicates compile time
17
18 access q1vars; $ access global q1 variables.
19 access nscod; $ access variables global to cod.
20
21
22$ read control card options
23
24 .+s10.
25 call getspp(q1_title, 'q1=q1/q1'); $ q1 file
26 call getspp(sq1_title, 'sq1=/sq1'); $ setl q1 file
27 call getspp(q2_title, 'q2=q2/q2'); $ q2 file
28 ..s10
29 .+s20.
30 call getspp(q1_title, 'q1=q1/q1'); $ q1 file
31 call getspp(sq1_title, 'sq1=/sq1'); $ setl q1 file
32 call getspp(q2_title, 'q2=q2/q2'); $ q2 file
33 ..s20
34
35
36 .+s32.
37 call getspp(q1_title, 'q1=q1.tmp/'); $ q1 file
38 call getspp(sq1_title, 'sq1=/sq1.tmp'); $ setl q1 file
39 call getspp(q2_title, 'q2=q2.tmp/'); $ q2 file
40 ..s32
41
42 .+s37cms.
43 call getspp(q1_title, 'q1=q1/q1'); $ q1 file
44 call getspp(sq1_title, 'sq1=/sq1'); $ setl q1 file
45 call getspp(q2_title, 'q2=q2/q2'); $ q2 file
46 ..s37cms
47 .+s37mts.
48 call getspp(q1_title, 'q1=-setlq1/'); $ little q1 file
49 call getspp(sq1_title, 'sq1=/-setlsq1'); $ setl q1 file
50 call getspp(q2_title, 'q2=q2/q2'); $ q2 file
51 ..s37mts
52 .+s47.
53 call getspp(q1_title, 'q1=q1/q1'); $ q1 file
54 call getspp(sq1_title, 'sq1=/sq1'); $ setl q1 file
55 call getspp(q2_title, 'q2=q2/q2'); $ q2 file
56 ..s47
57
58 .+s66.
59 call getspp(q1_title, 'q1=q1/q1'); $ q1 file
60 call getspp(sq1_title, 'sq1=/sq1'); $ setl q1 file
61 call getspp(q2_title, 'q2=q2/q2'); $ q2 file
62 ..s66
suna 17
suna 18 .+s68.
suna 19 call getspp(q1_title, 'q1=setl.lq1/'); $ little q1 file
suna 20 call getspp(sq1_title, 'sq1=/setl.sq1'); $ setl q1 file
suna 21 call getspp(q2_title, 'q2=setl.q2/'); $ q2 file
suna 22 ..s68
63
64 call getipp(h_lim, 'h=0/0'); $ heap dimension
65 call getipp(ca_lim, 'ca=0/0'); $ constant area dims
66 call getipp(sym_lim, 'st=0/0'); $ symbol table dims
67 call getipp(cel, 'cel=1000/1000'); $ cod error limit
68 call getipp(rem, 'rem=2/2'); $ runtime error mode
69 call getipp(opt_flag, 'opt=0/1'); $ global optimization
smfb 99 call getipp(rpr_flag, 'reprs=1/1'); $ conversion messages
70 call getipp(stmt_flag, 'stmt=1/2'); $ q2_stmt quadruples
71 call getipp(back_flag, 'back=0/1'); $ backtracking
72 call getipp(asm_flag, 'asm=0/1'); $ produce assembly code
73 call getipp(sif_flag, 'sif=0/1'); $ save q1 files
74 call getipp(debug_flag, 'debug=0/1'); $ initialise debugger
75 call getipp(termh_flag, 'termh=0/1'); $ print phase heading
asca 9 .+ascebc.
asca 10 call getipp(ascebc_flag, 'ascii=0/1'); $ebcdic-to-ascii conv
asca 11 ..ascebc
76
77 $ compiler debugging options
78 call getipp(tre_flag, 'ctre=0/1'); $ little entry trace
79 call getipp(q1cd_flag, 'cq1cd=0/1'); $ q1 code dumps
80 call getipp(q1sd_flag, 'cq1sd=0/1'); $ q1 symtab dumps
81 call getipp(q2cd_flag, 'cq2cd=0/1'); $ q2 code dumps
82 call getipp(q2sd_flag, 'cq2sd=0/1'); $ q2 storage dumps
83 call getipp(et_flag, 'et=0/1'); $ error trace
84
85 $ options for execution statistic package
86 call getipp(st_lo, 'stlo=1/1'); $ first stmt for stats
87 call getipp(st_hi, 'sthi=0/0'); $ last stmt for stats
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
88
89 st_no = st_hi - st_lo + 1;
90
91$ the code generator operates with the library error mode set to
92$ err_off. library errors can only occur while we are initializing
93$ the values of constants. when an error occurs the library will
94$ set the constant's value to omega. the code generator will check
95$ for this and issue its own error message.
96
97 err_mode = err_off;
98
99 err_limit = cel;
100
asca 12 .+ascebc.
asca 13 if (ascebc_flag) call aeinit; $ initialise conversion tables
asca 14 ..ascebc
asca 15
101 $ initialize little trace
102 if tre_flag then
103 monitor entry, limit = 10000;
104 else
105 monitor noentry;
106 end if;
107
108 $ open all files
109 if .len. sq1_title then
110 file sq1_file access = read, title = sq1_title;
111 .+s66 rewind sq1_file;
112 else
113 file q1_file access = read, title = q1_title;
114 .+s66 rewind q1_file;
115 end if;
116 file q2_file access = write, title = q2_title;
117 .+s66 rewind q2_file;
118
119 $ indicate which files can be deleted upon completion of cod
120 if ^ sif_flag then
121 if .len. sq1_title then
122 call dropsio(sq1_file, ret);
123 else
124 call dropsio(q1_file, ret);
125 end if;
126 end if;
127
128 $ initialize listing control
129 call contlpr( 6, yes); $ start paging
130 call contlpr( 7, yes); $ enable titling
131 call lstime(timestr); $ get current time
132 call etitlr(0, 'cims.setl.' .cc. prog_level, 1, 0);
133 call etitlr(0, timestr, 41, 0);
134 call etitlr(0, 'page', 71, 0);
135 call contlpr( 8, 76); $ set page number in column 76
136 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
137
sunb 36 if lcp_flag then $ print phase heading
sunb 37 put ,'parameters for this compilation: ' ,skip
140 ,skip ,'little q1 file: q1 = ' :q1_title ,a ,'. '
141 ,'setl q1 file: sq1 = ' :sq1_title ,a ,'. '
142 ,skip ,'q2 file: q2 = ' :q2_title ,a ,'. '
143 ,'save interm files: sif = ' :sif_flag ,i ,'. '
144 ,skip ,'codegen error limit: cel = ' :cel ,i ,'. '
asca 16$$-- ,'codegen error file: term = ' :term_title ,a ,'. '
asca 17$$-- since term_title not initialized
146 ,skip ,'global optimisation: opt = ' :opt_flag ,i ,'. '
147 ,'backtracking: back = ' :back_flag ,i ,'. '
148 ,skip ,'run-time error mode: rem = ' :rem ,i ,'. '
149 ,'assembly code: asm = ' :asm_flag ,i ,'. '
150 ,skip;
sunb 38 end if;
151
152 if termh_flag then
153 $ the following line is printed on the terminal file only
154 call contlpr(26, no); call contlpr(27, yes);
155 put ,' start cims.setl.' ,prog_level :timestr ,a ,skip;
156 call contlpr(26, yes); call contlpr(27, no);
157 end if;
158
159 .-sq1.
160 if .len. sq1_title then
161 call abort('setl q1 inteface not available');
162 end if;
163 ..sq1
164
165 call initab1; $ initialize tables
166 call initab2;
167
168
169 end subr codini;
1 .=member initab1
2 subr initab1;
3
4$ this routine initializes various tables which handle special
5$ casing.
6
7
8 size j(ps); $ loop index
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
14$ some of the tables which we must initialize are maps on the standard
15$ types f_xxx. before we can initialize these we must initialize the
16$ standard formtab entries. for now all that matters is that their
17$ ft_type codes be correct.
18
19 do j = f_min to f_max;
20 ft_type(j) = j;
21 end do;
22
23
24$ we begin by initializing spec_op. this table maps pairs
25$ [q1 opcode, type] into special q2 opcodes which are performed
26$ inline.
27
28
29 +* s(q1, tp, q2) = $ utility to initialize spec_op
30 spec_op(q1, tp) = q2;
31 **
32
33 s(q1_case, f_tuple, q2_caset )
34 s(q1_case, f_lmap, q2_caselsm)
35 s(q1_case, f_rmap, q2_casersm)
36 s(q1_case, f_umap, q2_caseusm)
37$
38$ if we plan to run the program with full error checking, then cannot
39$ emit inline code. if we leave the remaining entries of 'spec_op'
40$ zero, then we achieve just that. note that the q1_case cases above
41$ represent an inline sequence which is generated under the exclusive
42$ control of the compiler. consequently no error should ever occur.
43$
44 if (rem = err_full) return;
45
46 s(q1_add, f_sint, q2_addi )
47 s(q1_add, f_int, q2_addli )
48 s(q1_add, f_string, q2_addstr )
49 s(q1_add, f_tuple, q2_addtup )
50 s(q1_add, f_uset, q2_unset )
51 s(q1_add, f_lset, q2_unlset )
52 s(q1_add, f_rset, q2_unrset )
53
54 do j = f_umap to f_rpmap;
55 s(q1_add, j, q2_union);
56 end do;
57
58 s(q1_add, f_uint, q2_addui )
59 s(q1_add, f_ureal, q2_addur )
60
61 s(q1_div, f_sint, q2_divi )
62$$-- due to mode propagation problem
63$ s(q1_div, f_int, q2_divli )
64 s(q1_div, f_uint, q2_divui )
65
66 do j = f_sint to f_latom;
67 s(q1_eq, j, q2_eqv);
68 end do;
69
70 do j = f_int to f_rpmap;
71 s(q1_eq, j, q2_eq);
72 end do;
73
74 s(q1_eq, f_uint, q2_eq1 )
75 s(q1_eq, f_ureal, q2_eq1 )
76
77 do j = f_sint to f_latom;
78 s(q1_ne, j, q2_nev);
79 end do;
80
81 do j = f_int to f_rpmap;
82 s(q1_ne, j, q2_ne);
83 end do;
84
85 s(q1_ne, f_uint, q2_ne1 )
86 s(q1_ne, f_ureal, q2_ne1 )
87
88
89 s(q1_ge, f_sint, q2_gei )
90 s(q1_ge, f_uint, q2_geui )
91 s(q1_ge, f_ureal, q2_geur )
92
93 s(q1_lt, f_sint, q2_lti )
94 s(q1_lt, f_uint, q2_ltui )
95 s(q1_lt, f_ureal, q2_ltur )
96
97 s(q1_in, f_uset, q2_inu )
98 s(q1_in, f_lset, q2_inl )
99 s(q1_in, f_rset, q2_inr )
100
101 do j = f_umap to f_rpmap;
102 s(q1_in, j, q2_ins)
103 end do;
104
105 s(q1_notin, f_lset, q2_ninl )
106 s(q1_notin, f_rset, q2_ninr )
107
108 s(q1_less, f_lset, q2_lessls )
109 s(q1_less, f_rset, q2_lessrs )
110
111 s(q1_lessf, f_lmap, q2_lessflm)
112 s(q1_lessf, f_limap, q2_lessflm)
113 s(q1_lessf, f_lrmap, q2_lessflm)
114 s(q1_lessf, f_rmap, q2_lessfrm)
115 s(q1_lessf, f_rimap, q2_lessfrm)
116 s(q1_lessf, f_rrmap, q2_lessfrm)
117
118 s(q1_max, f_sint, q2_maxi )
119 s(q1_max, f_uint, q2_maxui )
120 s(q1_max, f_ureal, q2_maxur )
121
122 s(q1_min, f_sint, q2_mini )
123 s(q1_min, f_uint, q2_minui )
124 s(q1_min, f_ureal, q2_minur )
125
126 s(q1_mod, f_sint, q2_modi )
127 s(q1_mod, f_int, q2_modli )
128
129 do j = f_uset to f_rpmap;
130 s(q1_mod, j, q2_setmod);
131 end do;
132
133 s(q1_mod, f_uint, q2_modui )
134
135 s(q1_mult, f_sint, q2_multi )
136 s(q1_mult, f_int, q2_multli )
137 s(q1_mult, f_uset, q2_inset )
138 s(q1_mult, f_lset, q2_inlset )
139 s(q1_mult, f_rset, q2_inrset )
140
141 do j = f_umap to f_rpmap;
142 s(q1_mult, j, q2_inter);
143 end do;
144
145 s(q1_mult, f_uint, q2_multui )
146 s(q1_mult, f_ureal, q2_multur )
147
148 s(q1_slash, f_sint, q2_slashi )
149 s(q1_slash, f_uint, q2_slashui)
150 s(q1_slash, f_ureal, q2_slashur)
151
152 s(q1_sub, f_sint, q2_subi )
153 s(q1_sub, f_int, q2_diffli )
154 s(q1_sub, f_uset, q2_difset )
155 s(q1_sub, f_lset, q2_diflset)
156 s(q1_sub, f_rset, q2_difrset)
157
158 do j = f_umap to f_rpmap;
159 s(q1_sub, j, q2_setdiff);
160 end do;
161
162 s(q1_sub, f_uint, q2_subui )
163 s(q1_sub, f_ureal, q2_subur )
164
165 s(q1_with, f_uset, q2_withus )
166 s(q1_with, f_lset, q2_withls )
167 s(q1_with, f_rset, q2_withrs )
168 s(q1_with, f_tuple, q2_witht )
169 s(q1_with, f_ituple, q2_withut )
170 s(q1_with, f_rtuple, q2_withut )
171
172 do j = f_umap to f_rpmap;
173 s(q1_with, j, q2_withs);
174 end do;
175
176
177 s(q1_abs, f_sint, q2_absi )
178 s(q1_abs, f_uint, q2_absui )
179 s(q1_abs, f_ureal, q2_absur )
180
181 /* must first assert that fixup does proper mode propagation
182 s(q1_ceil, f_ureal, q2_ceilur )
183 s(q1_floor, f_ureal, q2_floorur)
184 s(q1_fix, f_ureal, q2_fixur )
185 s(q1_float, f_uint, q2_floatui)
186 */
187
188 do j = f_uset to f_rpmap;
189 s(q1_arb, j, q2_arbs);
190 end do;
191
192 s(q1_arb, f_ituple, q2_arbut )
193 s(q1_arb, f_rtuple, q2_arbut )
194 s(q1_arb, f_mtuple, q2_arbt )
195 s(q1_arb, f_tuple, q2_arbt )
196
197
198 s(q1_nelt, f_string, q2_neltic )
strb 8 s(q1_nelt, f_sstring, q2_neltic )
200
201 do j = f_ituple to f_rpmap;
202 s(q1_nelt, j, q2_neltst)
203 end do;
204
205 s(q1_umin, f_sint, q2_umini )
206 s(q1_umin, f_uint, q2_uminui )
207 s(q1_umin, f_ureal, q2_uminur )
208
209 s(q1_even, f_sint, q2_eveni )
210 s(q1_even, f_uint, q2_evenui )
211
212 s(q1_odd, f_sint, q2_oddi )
213 s(q1_odd, f_uint, q2_oddui )
214
215 do j = f_umap to f_rpmap;
216 s(q1_notin, j, q2_nins)
217 end do;
218
219 s(q1_fromb, f_ituple, q2_frombt )
220 s(q1_fromb, f_rtuple, q2_frombt )
221 s(q1_fromb, f_tuple, q2_frombt )
222
223 s(q1_frome, f_ituple, q2_fromet )
224 s(q1_frome, f_rtuple, q2_fromet )
225 s(q1_frome, f_tuple, q2_fromet )
226
227 do j = f_uset to f_rpmap;
228 s(q1_from, j, q2_froms);
229 end do;
230
231 s(q1_next, f_uset, q2_nextus )
232 s(q1_next, f_lset, q2_nextls )
233 s(q1_next, f_rset, q2_nextrs )
234
235 s(q1_next, f_ituple, q2_nextut )
236 s(q1_next, f_rtuple, q2_nextut )
237 s(q1_next, f_mtuple, q2_nextt )
238 s(q1_next, f_tuple, q2_nextt )
239
240 do j = f_umap to f_rpmap;
241 s(q1_next, j, q2_nexts);
242 end do;
243
244 do j = f_ituple to f_tuple;
245 s(q1_inext, j, q2_inextt);
246 s(q1_inextd, j, q2_inextd);
247 end do;
248
249 do j = f_uset to f_rset;
250 s(q1_inext, j, q2_inexts);
251 end do;
252
253 do j = f_umap to f_rpmap;
254 s(q1_inextd, j, q2_inextd);
255 end do;
256
strb 9 s(q1_of, f_sstring, q2_ofcl )
258 s(q1_of, f_string, q2_ofcl )
259 s(q1_of, f_tuple, q2_oft )
260 s(q1_of, f_mtuple, q2_oft )
261 s(q1_of, f_rtuple, q2_oft )
262 s(q1_of, f_ituple, q2_oft )
263 s(q1_of, f_umap, q2_ofum )
264 s(q1_of, f_lmap, q2_oflm )
265 s(q1_of, f_rmap, q2_ofrm )
266
strb 10 s(q1_sof, f_sstring, q2_sofcl )
268 s(q1_sof, f_string, q2_sofcl )
269 s(q1_sof, f_tuple, q2_soft )
270 s(q1_sof, f_mtuple, q2_soft )
271 s(q1_sof, f_lmap, q2_soflm )
272 s(q1_sof, f_rmap, q2_sofrm )
273
274 do j = f_sint to f_latom;
275 s(q1_ifeq, j, q2_goeqv);
276 end do;
277
278 do j = f_int to f_rpmap;
279 s(q1_ifeq, j, q2_goeq);
280 end do;
281
282 s(q1_ifeq, f_uint, q2_goeq1 )
283 s(q1_ifeq, f_ureal, q2_goeq1 )
284
285 s(q1_ifge, f_sint, q2_gogei )
286 s(q1_ifge, f_uint, q2_gogeui )
287 s(q1_ifge, f_ureal, q2_gogeur )
288
289 s(q1_ifin, f_uset, q2_goinus )
290 s(q1_ifin, f_lset, q2_goinl )
291 s(q1_ifin, f_rset, q2_goinr )
292
293 do j = f_umap to f_rpmap;
294 s(q1_ifin, j, q2_goins);
295 end do;
296
297 s(q1_iflt, f_sint, q2_golti )
298 s(q1_iflt, f_uint, q2_goltui )
299 s(q1_iflt, f_ureal, q2_goltur )
300
301 do j = f_sint to f_latom;
302 s(q1_ifne, j, q2_gonev);
303 end do;
304
305 do j = f_int to f_rpmap;
306 s(q1_ifne, j, q2_gone);
307 end do;
308
309 s(q1_ifne, f_uint, q2_gone1 )
310 s(q1_ifne, f_ureal, q2_gone1 )
311 s(q1_ifnin, f_uset, q2_goninus)
312 s(q1_ifnin, f_lset, q2_goninl )
313 s(q1_ifnin, f_rset, q2_goninr )
314
315 do j = f_umap to f_rpmap;
316 s(q1_ifnin, j, q2_gonins);
317 end do;
318
319 macdrop(s)
320
321
322 end subr initab1;
1 .=member initab2
2 subr initab2;
3
4$ this routine continues the initiazation.
5
6
7 size j(ps); $ loop index
8
9 access q1vars; $ access global q1 variables.
10 access nscod; $ access variables global to cod.
11
12
13 +* s(q1, tp, mapc, q2) = $ utility to set 'of_op'
14 of_op(q1, tp, mapc) = q2;
15 **
16
17 s(q1_of, f_umap, ft_smap, q2_ofusm )
18 s(q1_of, f_lmap, ft_smap, q2_oflsm )
19 s(q1_of, f_rmap, ft_smap, q2_ofrsm )
20 s(q1_of, f_limap, ft_smap, q2_oflsm )
21 s(q1_of, f_lrmap, ft_smap, q2_oflsm )
22 s(q1_of, f_rimap, ft_smap, q2_ofrsm )
23 s(q1_of, f_rrmap, ft_smap, q2_ofrsm )
smfb 100
smfb 101 s(q1_of, f_umap, ft_map, q2_ofum )
smfb 102 s(q1_of, f_lmap, ft_map, q2_oflm )
smfb 103 s(q1_of, f_rmap, ft_map, q2_ofrm )
24
25 s(q1_ofa, f_umap, ft_mmap, q2_ofaumm )
26 s(q1_ofa, f_lmap, ft_mmap, q2_ofalmm )
27 s(q1_ofa, f_rmap, ft_mmap, q2_ofarmm )
28
29 s(q1_sof, f_lmap, ft_smap, q2_soflm )
30 s(q1_sof, f_rmap, ft_smap, q2_sofrm )
31 s(q1_sof, f_limap, ft_smap, q2_soflm )
32 s(q1_sof, f_lrmap, ft_smap, q2_soflm )
33 s(q1_sof, f_rimap, ft_smap, q2_sofrm )
34 s(q1_sof, f_rrmap, ft_smap, q2_sofrm )
35
36 $ start by assuming that all sets and maps use 'q2_sofas',
37 $ then change the entries for local and remote mmaps.
38 do j = f_uset to f_rpmap;
39 s(q1_sofa, j, ft_smap, q2_sofas);
40 s(q1_sofa, j, ft_map, q2_sofas);
41 s(q1_sofa, j, ft_mmap, q2_sofas);
42 end do;
43
44 s(q1_sofa, f_lmap, ft_mmap, q2_sofalmm);
45 s(q1_sofa, f_rmap, ft_mmap, q2_sofarmm);
46
47 macdrop(s)
48
49
50 +* s(op1, op2) = share_op(op1) = op2; **
51
52 s(q2_ofusm, q2_ofusms )
53 s(q2_oflsm, q2_oflsms )
54 s(q2_ofrsm, q2_ofrsms )
55
56 s(q2_ofum, q2_ofums )
57 s(q2_oflm, q2_oflms )
58 s(q2_ofrm, q2_ofrms )
59
60 s(q2_ofaumm, q2_ofaumms)
61 s(q2_ofalmm, q2_ofalmms)
62 s(q2_ofarmm, q2_ofarmms)
63
64 s(q2_oft, q2_ofts )
smfb 104 s(q2_oftok, q2_oftoks )
65
66 macdrop(s)
67
68
69 +* s(sym, eq, ne, ifeq, ifne) = $ macro to set eq_op
70 eqop(sym) = eq;
71 neop(sym) = ne;
72 ifeq_op(sym) = ifeq;
73 ifne_op(sym) = ifne;
74 **
75
76 s(sym_zero, q2_zr, q2_nz, q2_gozr, q2_gonz )
77 s(sym_om, q2_eqom, q2_neom, q2_goom, q2_gonom )
78 s(sym_nullset, q2_eqnl, q2_nenl, q2_gonl, q2_gonnl )
79 s(sym_nulltup, q2_eqnult, q2_nenult, q2_gonult, q2_gonnult)
80
81 macdrop(s)
82
83
84 end subr initab2;
1 .=member gettab
2 subr gettab;
3
4$ this routine reads in a page of q1.
5
6 size n(ps); $ number of arguments
7 size j(ps); $ loop index
8 size str(sds_sz); $ unit name as sds
9
10 size getsbi(ws); $ reads setl binary integer
11 size getsbs(ps); $ reads setl binary string
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16
17$
18$ read the unit identifying record
19$
20 if .len. sq1_title then $ read from setl q1 file
21 unit_type = getsbi(0);
22 curunit = getsbs(0); str = '';
23 curunit = getsbi(0);
24 n = getsbi(0);
25 ustmt_count = getsbi(0);
26 estmt_count = getsbi(0);
27
28 else
29 read q1_file,
30 unit_type, str, curunit, n, ustmt_count, estmt_count;
31 end if;
32$
33$ set cstmt_count to the statement number at the beginning of the unit.
34$
35 cstmt_count = ustmt_count;
36
37 if unit_type = unit_end then
38 eof_flag = yes;
39 curmemb = 0;
40 currout = 0;
41 call setlab1; $ process all labels which are still undefin
42 return;
43 end if;
44
45 if .len. sq1_title then call sgettb; else call lgettb; end if;
46
47 if et_flag then
smfa 28 put ,'compiling ' :symsds(curunit),a ,skip;
49 end if;
50
51 if ft_type(form(curunit)) = f_memb then curmemb = curunit;
52 elseif ft_type(form(curunit)) = f_proc then currout = curunit;
53 end if;
54
55$ clear all those symtab fields which are used differently by the
56$ semantic pass.
57
58 do j = symtab_org+1 to symtabp;
59 address(j) = 0;
60 labval(j) = 0;
61 is_seen(j) = no;
62 is_alias(j) = no;
63 is_ldef(j) = no;
64 is_backpr(j) = no;
65 is_casemap(j) = no;
66 end do;
67
68$ clear all altrep fields. this is necessary since the altrep
69$ field of a global symtab entry may point to a local one.
70
71 do j = 1 to symtabp;
72 altrep(j) = 0;
73 end do;
74
75$ clear the ft_samp fields of formtab. this is necessary because
76$ this field is used differently during the semantic pass.
77
78 do j = formtab_org + 1 to formtabp;
79 ft_samp(j) = 0;
80 end do;
81
82
83 end subr gettab;
1 .=member lgettb
2 subr lgettb;
3
4$ this routine reads a page of q1 from the little q1 file.
5
6 access q1vars; $ access global q1 variables.
7 access nscod; $ access variables global to cod.
8
9 +* getr(ara, org, last, str) = $ read array
10 read q1_file, org, last;
11 if (org < last) read q1_file, ara(org+1) to ara(last);
12
13 if (filestat(q1_file, error)) call abort('getr err '.cc.str);
14 if (filestat(q1_file, end)) call abort('getr end '.cc.str);
15 **
16
17 getr(mttab, mttab_org, mttabp, 'mttab');
18 getr(formtab, formtab_org, formtabp, 'formtab');
19 getr(names, names_org, namesp, 'names');
20 getr(val, val_org, valp, 'val');
21 getr(symtab, symtab_org, symtabp, 'symtab');
22 getr(blocktab, blocktab_org, blocktabp, 'blocktab');
23 getr(argtab, argtab_org, argtabp, 'argtab');
24 getr(codetab, codetab_org, codetabp, 'codetab');
25
26 macdrop(getr)
27
28
29 end subr lgettb;
1 .=member sgettb
2 subr sgettb;
3
4$ this routine reads a page of q1 from the setl q1 file.
5
6
7 .-sq1 call abort('setl q1 inteface not available');
8
9 .+sq1.
10
11 size fm(ps); $ form
12 size hdr(ws); $ binary header word
13 size i(ps); $ loop index
14 size j(ps); $ inner loop index
15
16 size ft_low_(ps); $ ft_low field of form table
17 size ft_lim_(ps); $ ft_lim field of form table
18 size ft_pos_(ps); $ ft_pos field of form table
19
20 size getsbi(ws); $ utilities to read setl binary values
21 size getsbr(ws);
22 size getsbb(1);
23 size getsbs(ps);
24
25 access q1vars; $ access global q1 variables.
26 access nscod; $ access variables global to cod.
27
28
29$
30$ form table
31$
32 $ get extend of current slice
33 formtab_org = getsbi(0); formtabp = getsbi(0);
34
35 $ compute current value for mttab_org and mttabp
36 mttabp = 0;
37
38 do j = 0 to formtab_org;
39 if ft_type(j) = f_mtuple ! ft_type(j) = f_proc then
40 if ft_elmt(j) >= mttabp then
41 mttabp = ft_elmt(j) + ft_lim(j);
42 end if;
43 end if;
44 end do;
45
46 mttab_org = mttabp;
47
48 $ read form table
49 do i = formtab_org+1 to formtabp;
50 formtab(i) = 0;
51
52 read sq1_file, hdr;
53
54 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
55 call ermsg(14, 0);
56 end if;
57
58 ft_type(i) = getsbi(0);
59 ft_mapc(i) = getsbi(0);
60 ft_elmt(i) = getsbi(0);
61 ft_dom(i) = getsbi(0);
62 ft_im(i) = getsbi(0);
63 ft_imset(i) = getsbi(0);
64 ft_base(i) = getsbi(0);
65 ft_deref(i) = getsbi(0);
66 ft_low_ = getsbi(0);
67 ft_lim_ = getsbi(0);
68 ft_pos_ = getsbi(0);
69 ft_hashok(i) = getsbb(0);
70 ft_neltok(i) = getsbb(0);
71
72 $ account for field overlays in form table
73 if is_floc(i) then
74 ft_pos(i) = ft_pos_;
75 else
76 ft_low(i) = ft_low_;
77 ft_lim(i) = ft_lim_;
78 end if;
79
80 read sq1_file, hdr;
81
82 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
83 call ermsg(14, 0);
84 end if;
85
86 if ft_type(i) = f_mtuple ! ft_type(i) = f_proc then
87 if (mttabp + ft_lim(i) > mttab_lim) call overfl('mttab');
88
89 do j = 1 to ft_lim(i);
90 mttab(mttabp+j) = getsbi(0);
91 end do;
92
93 ft_elmt(i) = mttabp;
94 mttabp = mttabp + ft_lim(i);
95
96 elseif is_fbase(i) then
97 ft_num(i, f_lset) = getsbi(0);
98 ft_num(i, f_lmap) = getsbi(0);
99 ft_num(i, f_lpmap) = getsbi(0);
100 ft_num(i, f_limap) = getsbi(0);
101 ft_num(i, f_lrmap) = getsbi(0);
102
103 elseif is_fmap(i) & is_frem(i) then
104 ft_tup(i) = getsbi(0);
105 end if;
106
107 read sq1_file, hdr;
108
109 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
110 call ermsg(15, 0);
111 end if;
112
113 read sq1_file, hdr;
114
115 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
116 call ermsg(15, 0);
117 end if;
118 end do;
119$
120$ symbol table
121$
122 $ read extent of current slice
123 symtab_org = getsbi(0); symtabp = getsbi(0);
124
125 $ compute new origines for val and names
126 valp = 0; namesp = 0;
127
128 do j = 1 to symtab_org;
129 if vptr(j) > valp then
130 valp = vptr(j) + vlen(j)-1;
131 end if;
132
133 if name(j) > namesp then
134 namesp = name(j) + (n_sorg(name(j))/ws)-1;
135 end if;
136 end do;
137
138 val_org = valp; names_org = namesp;
139
140 $ read symbol table
141 do i = symtab_org+1 to symtabp;
142 symtab(i) = 0;
143
144 read sq1_file, hdr;
145
146 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
147 call ermsg(14, 0);
148 end if;
149
150 name(i) = getsbs(i);
151 form(i) = getsbi(0);
152 alias(i) = getsbi(0);
153 is_repr(i) = getsbb(0);
154 is_temp(i) = getsbb(0);
155 is_stk(i) = getsbb(0);
156 is_read(i) = getsbb(0);
157 is_write(i) = getsbb(0);
158 is_param(i) = getsbb(0);
159 is_store(i) = getsbb(0);
160 is_init(i) = getsbb(0);
161 is_seen(i) = getsbb(0);
162 is_back(i) = getsbb(0);
163 is_rec(i) = getsbb(0);
164
165 fm = form(i);
166
167 if getsbb(0) then $ entry has a value
168 vlen(i) = getsbi(0);
169
170 if (valp + vlen(i) > val_lim) call overfl('val');
171 read sq1_file, hdr;
172
173 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
174 call ermsg(14, 0);
175 end if;
176
177 if is_fint(fm) then
178 val(valp+1) = getsbi(0);
179
180 elseif is_freal(fm) then
181 val(valp+1) = getsbr(0);
182
183 elseif is_fstr(fm) then
184 vptr(i) = getsbs(-i);
185
186 elseif ft_type(fm) = f_atom then
187 $ recall that booleans are the only legal constants
188 $ with form f_atom.
189 if getsbb(0) then
190 val(valp+1) = 0;
191 else
192 val(valp+1) = maxsi;
193 end if;
194
195 else
196 do j = 1 to vlen(i);
197 val(valp+j) = getsbi(0);
198 end do;
199 end if;
200
201 read sq1_file, hdr;
202
203 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
204 call ermsg(15, 0);
205 end if;
206
207 vptr(i) = valp + 1;
208 valp = valp + vlen(i);
209 end if;
210
211 read sq1_file, hdr;
212
213 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
214 call ermsg(15, 0);
215 end if;
216 end do;
217$
218$ block table
219$
220 blocktab_org = getsbi(0); blocktabp = getsbi(0);
221
222 do i = blocktab_org+1 to blocktabp;
223 b_first(i) = getsbi(0);
224 end do;
225$
226$ code table
227$
228 codetab_org = getsbi(0); codetabp = getsbi(0);
229
230 argtab_org = 0;
231 argtabp = 0;
232
233 do i = codetab_org+1 to codetabp;
234 codetab(i) = 0;
235
236 read sq1_file, hdr;
237
238 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
239 call ermsg(14, 0);
240 end if;
241
242 opcode(i) = getsbi(0);
243 blockof(i) = getsbi(0);
244 next(i) = getsbi(0);
245 cflag(i) = getsbi(0);
246 sflag(i) = getsbi(0);
247
248 nargs(i) = getsbi(0);
249
250 read sq1_file, hdr;
251
252 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
253 call ermsg(14, 0);
254 end if;
255
256 if (argtabp+nargs(i) > argtab_lim) call overfl('argtab');
257
258 do j = 1 to nargs(i);
259 argtab(argtabp+j) = getsbi(0);
260 end do;
261
262 argp(i) = argtabp;
263 argtabp = argtabp + nargs(i);
264
265 read sq1_file, hdr;
266
267 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
268 call ermsg(15, 0);
269 end if;
270
271 read sq1_file, hdr;
272
273 if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
274 call ermsg(15, 0);
275 end if;
276 end do;
277
278 ..sq1
279
280
281 end subr sgettb;
1 .=member getsbi
2 fnct getsbi(dummy);
3
4$ this routine reads a setl binary integer from the setl q1 file.
smfc 11$
smfc 12$ n.b. the code here corresponds to the code of the getintli and getbli
smfc 13$ routines in the run-time library. it does depend on the exact repre-
smfc 14$ sentation of setl long integers. strictly speaking, we simulate the
smfc 15$ sequence
smfc 16$
smfc 17$ getbli(sq1_file, spec); get_intval(getsbi, spec);
smfc 18$
smfc 19$ without using the heap.
5
6
7 size dummy(1); $ dummy argument
8
9 size getsbi(ws); $ return value
10
11 .-sq1 call abort('setl q1 inteface not available');
12
13 .+sq1.
14
15 size hdr(ws); $ binary header word
16 size word(ws); $ binary data word
smfc 20 size sign(1); $ sign of result
17
18 access q1vars; $ access global q1 variables.
19 access nscod; $ access variables global to cod.
20
21
smfd 16 read sq1_file, hdr;
smfd 17
smfd 18 if bh_typ_ hdr = bt_sint then
smfd 19 getsbi = bh_val_ hdr;
smfd 20 return;
smfd 21
smfd 22 elseif bh_typ_ hdr = bt_int then
smfd 23 read sq1_file, word;
smfd 24
smfd 25 else
smfd 26 call ermsg(16, 0);
smfd 27 end if;
smfc 22
smfc 23 sign = .f. ws, 1, word; $ li_sign
smfc 24 getsbi = .f. 1, dds, word; $ li_ddigit
smfc 25
smfc 26 if bh_val_ hdr = 2 then
smfc 27
smfc 28 read sq1_file, word;
smfc 29
smfc 30 .f. dds+1, ws-dds-1, getsbi = .f. 1, dds, word;
smfc 31
smfc 32 elseif bh_val_ hdr ^= 1 then
smfc 33 call ermsg(16, 0);
smfc 34 end if;
smfc 35
smfc 36 if (sign) getsbi = -getsbi;
29
30 ..sq1
31
32
33 end fnct getsbi;
1 .=member getsbr
2 fnct getsbr(dummy);
3
4$ this routine reads a setl binary realfrom the setl q1 file.
5
6
7 size dummy(1); $ dummy argument
8
9 size getsbr(ws); $ real returned as bitstring
10
11 .-sq1 call abort('setl q1 inteface not available');
12
13 .+sq1.
14
15 size hdr(ws); $ binary header word
16 size word(ws); $ binary data word
17
18 access q1vars; $ access global q1 variables.
19 access nscod; $ access variables global to cod.
20
21
22 read sq1_file, hdr, word;
23
24 if ^ (bh_typ_ hdr = bt_real & bh_val_ hdr = 1) then
25 call ermsg(17, 0);
26 end if;
27
28 getsbr = word;
29
30 ..sq1
31
32
33 end fnct getsbr;
1 .=member getsbb
2 fnct getsbb(dummy);
3
4$ this routine reads a setl boolean from the setl q1 file.
5
6
7 size dummy(1); $ dummy argument
8
9 size getsbb(1); $ little 'boolean' returned
10
11 .-sq1 call abort('setl q1 inteface not available');
12
13 .+sq1.
14
15 size hdr(ws); $ binary header word
16 size word(ws); $ binary data word
17
18 access q1vars; $ access global q1 variables.
19 access nscod; $ access variables global to cod.
20
21
22 read sq1_file, hdr, word;
23
24 if ^ (bh_typ_ hdr = bt_bool & bh_val_ hdr = 1) then
25 call ermsg(18, 0);
26 end if;
27
28 if ^ (word = 0 ! word = 1) then
29 call ermsg(19, 0);
30 end if;
31
32 getsbb = word;
33
34 ..sq1
35
36
37 end fnct getsbb;
1 .=member getsbs
2 fnct getsbs(p);
3
4$ this routine reads the string value for symbol table entry 'p'
5$ from the setl q1 file.
6
7
8 size p(ws); $ symbol table pointer
9
10 size getsbs(ps); $ pointer returned
11
stra 19 .-sq1.
stra 20 call abort('setl q1 interface not available');
14 .+sq1.
15
16 size hdr(ws); $ binary header word
17 size word(ws); $ binary data word
18 size str(sds_sz); $ string
19 size org(ps); $ sds origin of string
20 size len(ps); $ number of characters in string
21 size words(ps); $ number of data words
22 size j(ps); $ loop index
23
24 access q1vars; $ access global q1 variables.
25 access nscod; $ access variables global to cod.
26
27
28$
29$ read and interpret header word
30$
31 read sq1_file, hdr;
stra 21
stra 22 if ^ (bh_typ_ hdr = bt_char ! bh_typ_ hdr = bt_string) then
33 call ermsg(20, 0);
34 end if;
35
stra 23 if bh_typ_ hdr = bt_char then
stra 24 len = sc_max;
stra 25 else $ bh_typ_ hdr = bt_string
stra 26 len = bh_val_ hdr;
stra 27 end if;
37$
38$ read the setl binary string and format it into an sds string
39$
40 $ initialize the sds string
41 str = 0;
42 org = .sds. len + 1;
43
44 $ compute number of data words to be read
45 if len = 0 then
46 words = 0;
47 else
48 words = ((len-1) / cpw) + 1;
49 end if;
50
51 $ read string
stra 28 if bh_typ_ hdr = bt_char then
stra 29 .f. org-cs, cs, str = bh_val_ hdr;
stra 30 else $ bh_typ_ hdr = bt_string
stra 31 do j = 1 to words;
stra 32 read sq1_file, word;
stra 33 .f. org-j*ws, ws, str = word;
stra 34 end do;
stra 35 end if;
55
56 $ form proper sds
57 slen str = len;
58 sorg str = org;
59$
60$ store the string into the compiler table
61$
62 words = org/ws; $ number of words needed for sds
63
64 if p > 0 then $ str is name(p)
65 if len > 0 then
66 if (namesp + words > names_lim) call overfl('names');
67
68 do j = 1 to words;
69 names(namesp+j) = .f. 1+(j-1)*ws, ws, str;
70 end do;
71
72 getsbs = namesp + 1;
73 namesp = namesp + words;
74
75 else $ internal variable
76 getsbs = 0;
77 end if;
78
79 elseif p = 0 then $ str is name of current scope
80 getsbs = 0;
81
82 else $ str is value of string constant
83 do j = 1 to words;
84 val(valp+j) = .f. 1+(j-1)*ws, ws, str;
85 end do;
86
87 vlen(-p) = words;
88 getsbs = valp + 1;
89 end if;
90
91 ..sq1
92
93 end fnct getsbs;
1 .=member fixup
2 subr fixup;
3
4$ this routine performs local optimizations when the global optimizer
5$ is not available. it makes a single pass through the code doing
6$ five things:
7
8$ 1. if looks for patterns such as:
9
10$ t := b op c;
11$ a := t;
12
13$ where t is a temporary, and replaces them with a := b op c.
14
15$ 2. it types temporaries by looking at the opcode and input types
16$ of the instruction which defines them.
17
18$ 3. if converts q1_set and q1_tup instructions into a series of
19$ push instructions followed by a q1_set1 or q1_tup instruction.
20
21$ 4. it optimizes various patterns involving conditional branches.
22
23$ 5. it initializes the copy and share flags.
24
25 size fm(ps); $ form of result
26 size arg(ps); $ argument
27 size j(ps); $ loop index
smfb 105 size dummy(ps); $ dummy argument
smfb 106 size in2(ps), in3(ps); $ local copies of operands
28
29 size shrtct(ps); $ short-cuts branches to branches
30
31 access q1vars; $ access global q1 variables.
32 access nscod; $ access variables global to cod.
33
34
35 call clear_temps; $ reinitialize for temporary allocation
36
37
38 code_loop; $ iterate over program
39
40 go to case(class(op)) in cl_minimum to cl_maximum;
41
42
43 /case(cl_simp)/
44
45 /case(cl_noop)/
46
47 cont_loop;
48
49 /case(cl_min)/ $ min and max
50
51 fm = bin_type(op, fm2, fm3);
52 go to esac1;
53
54 /case(cl_lessf)/
55
56 fm = deref_typ(fm2);
57
58 $ if a2 is a plex object, a3 must be an element of the domain
59 if is_fplex(fm) & deref_typ(fm3) ^= ft_dom(fm) then
60 call ermsg(11, a2);
61 end if;
62
63 if (is_floc(fm)) fm = f_uset;
64 if ( ^ opt_flag) cflag(now) = copy_yes;
65 go to esac1;
66
67
68 /case(cl_with)/
69
70 if ^ opt_flag then
71 cflag(now) = copy_yes;
72 if (op = q1_with) sflag(now) = yes;
73 end if;
74
75 fm = deref_typ(fm2);
76
77 $ if a2 is a plex object, a3 must be an element of the base
78 if is_fplex(fm) & deref_typ(fm3) ^= ft_elmt(fm) then
79 call ermsg(11, a2);
80 end if;
81
82 if is_floc(fm) then fm = f_uset;
smfa 29$$-- elseif op = q1_with &
smfa 30$$-- is_fmap(fm) &
smfa 31$$-- ft_mapc(fm) = ft_smap then fm = f_umap;
83 elseif ft_type(fm) = f_mtuple then fm = f_tuple;
84 end if;
85
86 go to esac1;
87
88 /case(cl_from)/ $ from
89
90 if ^ opt_flag then
91 cflag(now) = copy_test;
92 end if;
93
94 fm = deref_typ(fm2); if (is_fplex(fm)) call ermsg(11, a2);
95
96 if is_temp(a2) then
97 fm2 = fm; is_repr(a2) = yes;
98 end if;
99
100 if is_internal(a1) then
101 fm1 = elmt_type(fm); is_repr(a1) = yes;
102 end if;
103
104 cont_loop;
105
106 /case(cl_umin)/ $ unary minus
107
108 fm = deref_typ(fm2);
109 if ft_type(fm) = f_sint then fm = f_int; end if;
bnda 9 if op = q1_abs & is_fstr(fm) then fm = f_sint; end if;
110
111 go to esac1;
112
113 /case(cl_int)/ $ things yielding int
114
115 fm = f_int;
116 go to esac1;
117
118 /case(cl_real)/ $ yield real
119
120 fm = f_real;
121 go to esac1;
122
123 /case(cl_str)/ $ things yielding strings
124
125 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
126 fm = f_string;
127 go to esac1;
128
129 /case(cl_bool)/ $ yield boolean
130 $
131 $ note that booleans are the short atoms 0 and maxsi
132 $
133 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
134 fm = f_atom;
135 go to esac1;
136
137 /case(cl_uset)/ $ yield set(*)
138
139 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
140 fm = f_uset;
141 go to esac1;
142
143 /case(cl_not)/ $ not
144
145 call fixnot;
146 cont_loop;
147
148 /case(cl_rand)/ $ random
149
150 fm = deref_typ(fm2); if (is_fplex(fm)) call ermsg(11, a2);
151 if ^ is_fprim(fm) then fm = elmt_type(fm); end if;
152 go to esac1;
153
154 /case(cl_arb)/ $ arb
155
156 fm = deref_typ(fm2); if (is_fplex(fm)) call ermsg(11, a2);
157 fm = elmt_type(fm);
158 go to esac1;
159
160 /case(cl_stmt)/
161
162 cstmt_count = cstmt_count + 1;
163 cont_loop;
164
165 /case(cl_call)/
166
167 cont_loop;
168
169 /case(cl_goto)/
170
171 call fixgo;
172 cont_loop;
173
174 /case(cl_ifgo)/
smfb 107
smfb 108 if op = q1_bif then op = q1_if;
smfb 109 elseif op = q1_bifnot then op = q1_ifnot;
smfb 110 end if;
smfb 111
smfb 112 $ fall through to case(cl_ifgo1).
175
176 /case(cl_ifgo1)/
177
178 argn(now, nargs(now)) = shrtct(argn(now, nargs(now)));
179 go to esac2;
180
181 /case(cl_case)/
182
183 is_casemap(a1) = yes;
184 if (alias(a1) ^= 0) is_casemap(alias(a1)) = yes;
185
186 go to esac2;
187
188 /case(cl_lab)/
189
190 go to esac2;
191
192 /case(cl_entry)/
193
194 cstmt_count = estmt_count;
195 go to esac2;
196
197 /case(cl_exit)/
198
199 go to esac2;
200
201 /case(cl_bin)/ $ binary operators
202
203$ this operations could be generated by 'a +:= b' or 'a -:= b'. in
204$ either case we must check that 'a' is not a plex type.
205
206 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
207 if (is_fplex(deref_typ(fm3))) call ermsg(11, a3);
smfb 113
smfb 114 in2 = a2; call match_repr(dummy, in2, fm3); a2 = in2;
smfb 115 in3 = a3; call match_repr(dummy, in3, fm2); a3 = in3;
208
209 fm = bin_type(op, fm2, fm3);
210
211$ set the copy flag. there are four possibilities
212
213$ 1. we are doing a := b + c and b is a constant. we will always
214$ have to copy b.
215
216$ 2. we are doing a := b + c and b is local. dont copy it.
217
218$ 3. we are doing a := a + b. copy a if its shared.
219
220$ 4. otherwise we are doing a := b + c. copy b.
221
222 if ^ opt_flag then
223 if is_const(a2) then
224 cflag(now) = copy_yes;
225
226 elseif a1 = a2 then
227 cflag(now) = copy_test;
228
229 else
230 cflag(now) = copy_yes;
231 end if;
232 end if;
233
234 go to esac1;
235
236 /case(cl_nelt)/ $ nelt
237
238 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
239 fm = f_sint;
240 go to esac1;
241
242 /case(cl_newat)/ $ newat
243
244 is_backpr(a1) = yes;
245 fm = f_atom;
246 go to esac1;
247
248 /case(cl_pred1)/ $ membership tests
249
250 fm = deref_typ(fm3);
251
252 $ if a3 is a plex object, a2 must be an element of the base
253 if is_fplex(fm) & deref_typ(fm2) ^= ft_elmt(fm) then
254 call ermsg(11, a3);
255 end if;
256
257 call fixpred;
258 cont_loop;
259
260
261 /case(cl_pred2)/ $ binary predicates
262
263 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
264 if (is_fplex(deref_typ(fm3))) call ermsg(11, a3);
smfb 116
smfb 117 if op = q1_pos then op = q1_lt; swap(a2, a3); end if;
265
266 call fixpred;
267 cont_loop;
268
269 /case(cl_asrt)/
270
smfb 118 if op = q1_ifasrt then a1 = shrtct(a1); end if;
271 go to esac2;
272
273 /case(cl_of)/ $ a1 := a2(a3)
274
275 fm = deref_typ(fm2);
276
277 if is_backpr(a3) then
278 fm3 = dom_type(fm); is_repr(a3) = yes;
279 end if;
280
281 fm = compn_typ(fm, a3);
282
283 if (^ opt_flag & ^ is_funt(fm)) sflag(now) = yes;
284
285 go to esac1;
286
287 /case(cl_ofa)/ $ a1 := a2<>
288
289 if (^ opt_flag) sflag(now) = yes;
290
291 fm = deref_typ(fm2);
292
293 if is_backpr(a3) then
294 fm3 = dom_type(fm); is_repr(a3) = yes;
295 end if;
296
297 fm = rset_type(fm);
298
299 go to esac1;
300
301
302 /case(cl_subst)/ $ a1 := a2(a3...a4)
303
304 fm = deref_typ(fm2);
305 if (ft_type(fm) = f_mtuple) fm = f_tuple;
306
307 go to esac1;
308
309 /case(cl_sof)/ $ a1(a2) := a3
310
311 fm = deref_typ(fm1);
312
313 if is_backpr(a2) then
314 fm2 = dom_type(fm); is_repr(a2) = yes;
315 end if;
316
317 if is_backpr(a3) then
318 fm3 = compn_typ(fm, a2); is_repr(a3) = yes;
319 end if;
320
321 if ^ opt_flag then
322 cflag(now) = copy_test; sflag(now) = yes;
323 end if;
324
325 go to esac3;
326
327
328 /case(cl_sofa)/ $ a1<> := a3
329
330 fm = deref_typ(fm1);
331
332 if is_backpr(a2) then
333 fm2 = dom_type(fm); is_repr(a2) = yes;
334 end if;
335
336 if is_backpr(a3) then
337 fm3 = rset_type(fm); is_repr(a3) = yes;
338 end if;
339
340 if ^ opt_flag then
341 cflag(now) = copy_test; sflag(now) = yes;
342 end if;
343
344 go to esac3;
345
346
347 /case(cl_ssubst)/ $ a1(a2...a3) := a4
348
349 if (^ opt_flag) cflag(now) = yes;
350
351 go to esac3;
352
353 /case(cl_argin)/
354
355 if is_backpr(a1) then
356 fm1 = arg_type(a2, symval(a3));
357 end if;
358
359 go to esac2;
360
361 /case(cl_argout)/ $ stack pop
362
363 fm = arg_type(a2, symval(a3));
364 go to esac1;
365
366
367 /case(cl_push)/ $ push element for set former
368
369$ note that the input to the push instruction also appears as an input
370$ to the setformer, so we do not free the temporary yet.
371
372 cont_loop;
373
374 /case(cl_free)/
375
376 cont_loop;
377
378
379 /case(cl_asn)/ $ a1 = a2
380
381
382 call fixasn;
383 cont_loop;
384
385 /case(cl_st)/ $ set and tuple formers
386
387 /case(cl_st1)/
388
389 /case(cl_st2)/ $ q1_dom and q1_range
390
391 if (is_temp(a1) & ^ is_repr(a1)) is_backpr(a1) = yes;
392 fm = f_gen;
393 go to esac1;
394
395
396 /case(cl_next)/
397
398 fm = deref_typ(fm3); if (is_fplex(fm)) call ermsg(11, a3);
399
400 $ if a3 is an internal variable, it will have been
401 $ set to the form of the object we want to iterate
402 $ over. at this point we can improve the form
403 $ propagation by assigning the dereferenced mode
404 $ to a1.
405 if is_internal(a3) then
406 fm3 = fm; is_repr(a3) = yes;
407 end if;
408
409 $ if a1 is an internal variable, give it the element
410 $ type of a3
411 if is_internal(a1) then
412 fm1 = elmt_type(fm); is_repr(a1) = yes;
413 end if;
414
415 cont_loop;
416
417 /case(cl_nextd)/
418
419 fm = deref_typ(fm3); if (is_fplex(fm)) call ermsg(11, a3);
420
421 if is_internal(a3) then
422 fm3 = fm; is_repr(a3) = yes;
423 end if;
424
425 $ if a1 is an internal variable, give it the domain type
426 $ of a3
427 if is_internal(a1) then
428 fm1 = dom_type(fm); is_repr(a1) = yes;
429 end if;
430
431 cont_loop;
432
433 /case(cl_ok)/
434
435 /case(cl_fail)/
436
437 /case(cl_succeed)/
438
439 if (^ back_flag) call ermsg(13, 0);
440 cont_loop;
441
442 /case(cl_debug)/
443
444 if (a1 = sym_cq1cd) call q1dump;
445
446 cont_loop;
447
448
449 /esac1/
450
451$ we reach here for all instructions which define new temporaries.
452$ reserve a temporary for the output and free the temporaries for
453$ the inputs.
454
455 if (opt_flag) cont_loop;
456
457 if (is_temp(a1)) call set_temp(a1, fm);
458
459 do j = 2 to nargs(now);
460 arg = argn(now, j);
461
462 if (is_temp(arg)) call free_temp(arg);
463 end do;
464
465 cont_loop;
466
467
468 /esac2/
469
470$ we reach here for instructions which do not define new temporaries.
471$ free all the temporaries used for inputs.
472
473 if (opt_flag) cont_loop;
474
475 do j = 1 to nargs(now);
476 arg = argn(now, j);
477
478 if (is_temp(arg)) call free_temp(arg);
479 end do;
480
481 cont_loop;
482
483
484 /esac3/
485
486$ this exit is executed if the first argument is both an input and
487$ an output: return all remaining temporaries.
488
489 if (opt_flag) cont_loop;
490
491 do j = 2 to nargs(now);
492 arg = argn(now, j);
493
494 if (is_temp(arg)) call free_temp(arg);
495 end do j;
496
497 end_loop;
498
499 if (q1cd_flag) call q1dump; $ dump modified q1 if desired
500
501
502 end subr fixup;
1 .=member fixasn
2 subr fixasn;
3
4$ this routine cleans up simple assignments.
5
6$ we begin by looking for the case
7
8$ t := b op c;
9$ a := t;
10
11$ where the temporary 't' is unnecessary. this is true if either:
12
13$ 1. 'a' is local and either:
14
15$ a. we are doing +, *, or - and 'a', 'b', and 'c' have
16$ similar reprs and 'a' and 'c' are not the same variable.
17$ note that we are prepared to commute the operands of
18$ + and * so that the assignment can be merged.
19
20$ b. we are doing an enumerative set former.
21
22$ c. we are doing 't := b; a := t;' and 'a' and 'b' have the same
23$ reprs.
24$
25$ 2. 't' has a type (or mode) that can be assigned to 'a' without
26$ conversion.
27$
28$ we also look for the case:
29
30$ t := iterrative set former;
31$ a := t;
32
33$ and propagate the type of 'a' back to 't'.
34
35 size xop(ps); $ previous opcode
36 size xa1(ps); $ previous arg1
37 size xa2(ps); $ previous arg2
38 size xa3(ps); $ previous arg3
39 size fm(ps); $ dereferenced form
40
41 access q1vars; $ access global q1 variables.
42 access nscod; $ access variables global to cod.
43
44 xop = opcode(prev);
45 xa1 = arg1(prev);
46 xa2 = arg2(prev);
47 xa3 = arg3(prev);
48
49$ see if we can merge the assignment.
50
51 if ^ is_temp(a2) ! a2 ^= xa1 then
52 go to nmerge;
53
54 elseif is_floc(fm1) then
55 if xop = q1_add ! xop = q1_mult ! xop = q1_sub then
56 if (^ similar_repr(fm1, form(xa2))) go to nmerge;
57 if (^ similar_repr(fm1, form(xa3))) go to nmerge;
58
59 if a1 = xa2 then
60 go to merge;
61
62 elseif a1 = xa3 & xop ^= q1_sub then
63 swap(arg2(prev), arg3(prev));
64 go to merge;
65 end if;
66
67 go to nmerge;
68
69 elseif xop = q1_with ! xop = q1_less ! xop = q1_lessf then
70 if a1 = xa2 then
71 if xop = q1_with & is_backpr(xa3) then
72 form(xa3) = elmt_type(fm1); is_repr(xa3) = yes;
73 end if;
74
75 go to merge;
76 end if;
77
78 go to nmerge;
79
80 elseif xop = q1_set ! xop = q1_dom ! xop = q1_range then
81 go to merge;
82
83 elseif xop = q1_set1 then
84 go to set1;
85
86 elseif xop = q1_asn then
87 if (same_repr(fm1, form(xa2))) go to merge;
88 go to nmerge;
89
90 else
91 go to nmerge;
92 end if;
93
94 else
95 if ^ is_temp(a1) ! ^ is_seen(a1) then
96 $ we can attempt to propagate forms backwards
97
98 fm = deref_typ(fm1);
99
100 if class(xop) = cl_st ! class(xop) = cl_st2 then
101 fm2 = fm;
102 go to merge;
103
104 elseif xop = q1_newat
105 & ft_type(fm1) = f_elmt
106 & ft_type(ft_base(fm1)) = f_pbase then
107 fm2 = fm1;
smfb 119
smfb 120 elseif ft_type(fm) = f_sint then
smfb 121 if rem ^= err_full & fm = fm1 & fm = form(xa2) then
smfb 122 if (class(xop) = cl_umin) go to merge;
smfb 123 if class(xop) = cl_bin ! class(xop) = cl_min then
smfb 124 if (fm = form(xa3)) go to merge;
smfb 125 end if;
smfb 126 end if;
108
109 elseif is_pre(xop) & ft_type(fm) ^= f_mtuple then
110 fm2 = fm;
111
112 if is_backpr(xa2) &
113 (xop = q1_with ! class(xop) = cl_bin) then
114 form(xa2) = fm; is_repr(xa2) = yes;
115 end if;
116 if is_backpr(xa3) then
117 if xop = q1_with then
118 form(xa3) = elmt_type(fm);
119 is_repr(xa3) = yes;
120 elseif class(xop) = cl_bin then
121 form(xa3) = fm; is_repr(xa3) = yes;
122 end if;
123 end if;
124 end if;
125 end if;
126
127 if is_internal(a1) & is_seen(a1) then
128 $ we attempt a forward propagation step before we test
129 $ whether we can merge the assignment. this will catch
130 $ cases where the temporary has received a more specific
131 $ form previously, and for this reason we cannot assign
132 $ the temporary to the internal variable. the code here
133 $ is identical to the code below.
134 if is_fint(fm2) then $ case (c) below
135 fm = f_int;
136 elseif is_floc(fm2) then $ should never happen
137 fm = f_uset; $ cannot introduce a new local object
138 else
139 fm = fm2;
140 end if;
141
142 if (fm ^= form(a1) & a2 ^= sym_om) form(a1) = f_gen;
143 end if;
144
145 if (can_assign(fm1, fm2)) go to merge;
146 if (class(xop) = cl_st1) go to set1;
147 go to nmerge;
148 end if;
149
150/merge/ $ merge assignment
151
152 arg1(prev) = a1;
153 next(prev) = next(now);
154
155$ if we are merging 't := a op b; a := t' then we may be able to
156$ change an unconditional copy of 'a' to a conditional one.
157
158 if (a1 = xa2 & cflag(prev) = copy_yes) cflag(prev) = copy_test;
159
160 if is_temp(a1) then
161 if is_floc(fm2) then $ cannot introduce a new local object
162 call set_temp(a1, f_uset);
163 else
164 call set_temp(a1, fm2);
165 end if;
166 end if;
167
168 call drop_temp(a2); $ temp not needed
169
170 $ the next statement is justified for the following reason:
171 $ this routine only returns to the cl_asn case in fixup. it
172 $ is followed by a cont_loop, which will set prev to now, and
173 $ now to next(now). by resetting now here, we account for the
174 $ instruction we just deleted.
175 now = prev;
176
177 return;
178
179
180/set1/ $ iterative set former
181
182 if is_temp(a1) & is_seen(a1) then
183 fm1 = f_gen;
184 else
185 fm2 = deref_typ(fm1); is_repr(a2) = yes;
186 end if;
187
188 if (is_fplex(fm2)) call ermsg(11, a1);
189
190 call free_temp(a2);
191 return;
192
193/nmerge/ $ dont merge
194
195 $ make sure we are not assigning from or to a plex object
196 if (is_fplex(deref_typ(fm1))) call ermsg(11, a1);
197 if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
198
199 if (^ opt_flag) sflag(now) = yes;
200 if (is_temp(a2)) call free_temp(a2);
201
202
203$ next we handle two special cases:
204
205$ 1. if we are assigning to a temporary, call set_temp.
206$ note that we never assign a temporary a local type. instead
207$ we assign it set(*).
208
209$ 2. assignments to unreprd internal variables. there are
210$ three cases where this will arise:
211
212$ a. before we do a multiple assignment [a, b, c] = rhs we
213$ assign rhs to an internal variable. in this case we can
214$ give the internal variable the same type as 'rhs'.
215
216$ b. before we start the iteration 'x _ s' we assign 's' to an
217$ internal variable. once again we can give the variable the
218$ type of the rhs.
219
220$ c. we a shadow variable for 'i' in '! i = e1 ... e2'. in this
221$ case the shadow variable is defined twice, once at the top
222$ of the loop and once at the bottom. here we cannot give
223$ i the type of e1. the most we can say is that it is an integer.
224
225 if is_temp(a1) then
226 if is_floc(fm2) then
227 call set_temp(a1, f_uset);
228 else
229 call set_temp(a1, fm2);
230 end if;
231
232 elseif is_internal(a1) then
233 if is_fint(fm2) then $ case (c) above
234 fm = f_int;
235 elseif is_floc(fm2) then $ cannot introduce a new local object
236 fm = f_uset;
237 else
238 fm = fm2;
239 end if;
240
241 if is_seen(a1) then
242 if (fm ^= form(a1) & a2 ^= sym_om) form(a1) = f_gen;
243 elseif ^ is_repr(a1) then
244 form(a1) = fm; is_repr(a1) = yes; is_seen(a1) = yes;
245 end if;
246 end if;
247
248 return;
249
250 end subr fixasn;
1 .=member fixgo
2 subr fixgo;
3
4$ this routine processes unconditional gotos. we look for three special
5$ cases:
6
7$ 1. branches to the next instruction, i.e. 'go to l; l:'
8
9$ 2. successive branches to the same instruction, i.e.
10$ 'go to l1; l2: go to l1;'
11
12$ 3. branches to a label followed by another goto.
13
14 size block(ps); $ block after current block
15 size first(ps); $ first instruction of block
16 size p(ps); $ code pointers
17 size targ(ps); $ target of goto
18
19 size shrtct(ps); $ short-cuts branches to branches
20
21 access q1vars; $ access global q1 variables.
22 access nscod; $ access variables global to cod.
23
24$ look for case 1 and get a pointer to the next instruction.
25
26 if next(now) = 0 then $ goto is at end of block
27 block = blockof(now) + 1;
28 first = b_first(block);
29 p = next(first);
30
31 if arg1(first) = a1 then $ delete goto
32 next(prev) = 0;
33 return;
34 end if;
35
36 else
37 p = next(now);
38 end if;
39
40$ look for case 2
41 if stmt_flag < 2 then $ can skip statement quadruples
42 while p ^= 0; if (opcode(p) ^= q1_stmt) quit while p;
43 p = next(p);
44 end while;
45 end if;
46
47 if opcode(p) = q1_goto & arg1(p) = a1 then $ delete first goto
48 next(prev) = next(now);
49 return;
50 end if;
51
52 $ look for branches to a label followed by an unconditional branch
53 arg1(now) = shrtct(arg1(now));
54
55 return;
56
57 end subr fixgo;
1 .=member fixnot
2 subr fixnot;
3
4$ this routine is called to fix up 'not' instructions. it
5$ replaces 'if not not a' with 'if a'.
6
7 size p(ps); $ pointer to next instruction
8 size op1(ps); $ its opcode
9 size arg(ps); $ argument
10 size even(1); $ indicates even number of 'nots'
11
12 access q1vars; $ access global q1 variables.
13 access nscod; $ access variables global to cod.
14
15 even = no;
16 arg = arg1(now);
17 p = next(now);
18
19 while opcode(p) = q1_not & is_temp(arg) & arg2(p) = arg;
20 arg = arg1(p);
21 p = next(p);
22 even = ^ even;
23 end while;
24
25$ if p points to a branch instruction then we do four things:
26
27$ a. delete all the 'not' instructions and set the argument of
28$ the branch to the argument of the first 'not'.
29
30$ b. if there are an odd number of 'not' instructions, compliment
31$ the branch.
32
33$ c. advance 'now' to point to the branch instruction, dropping
34$ all the temporaries used by the 'not' instructions.
35
36$ d. free the temporary used by the branch.
37
38$ otherwise we process the 'not' instruction like any other unary
39$ operator.
40
41 op1 = opcode(p);
smfb 127
smfb 128 if op1 = q1_bif then op1 = q1_if;
smfb 129 elseif op1 = q1_bifnot then op1 = q1_ifnot;
smfb 130 end if;
smfb 131
smfb 132 opcode(p) = op1;
42
43 if class(op1) = cl_ifgo & is_temp(arg) & arg1(p) = arg then
44 $ delete the not's
45 arg1(p) = arg2(now);
46
47 if ^ even then $ flip the branch
48 if op1 = q1_if then
49 opcode(p) = q1_ifnot;
50 else
51 opcode(p) = q1_if;
52 end if;
53 end if;
54
55$ reset now and drop all the unused temporaries.
56 until now = p;
57 call drop_temp(arg1(now));
58 now = next(now);
59 end until;
60
61 next(prev) = now;
62
63 if (is_temp(a1)) call free_temp(a1);
64
65 else $ treat as normal unary operatororary
66 call set_temp(a1, f_atom);
67 if (is_temp(a2)) call free_temp(a2);
68 end if;
69
70
71 end subr fixnot;
1 .=member fixpred
2 subr fixpred;
3
4$ this routine is called during the fixup pass whenever we
5$ see a predicate such as '=' or '<'. we see whether the
6$ predicate is used in a branch instruction, and perform
7$ various peephole optimizations.
8
9 size p(ps); $ pointer to next instruction
10 size p1(ps); $ pointer to instruction after p
11 size p2(ps); $ pointer to target of goto
12 size pp(ps); $ extra pointer
13 size even(1); $ indicates even number of 'nots'
14 size arg(ps); $ argument of 'not' instruction
15 size op1(ps); $ next opcode
16 size t2(ps); $ a temporary
17 size l1(ps); $ a label
18 size l3(ps); $ another label
19 size i(ps); $ the instruction after l1
20
21 size getlab(ps); $ gets new label
22 size shrtct(ps); $ short-cuts branches to branches
23
24 access q1vars; $ access global q1 variables.
25 access nscod; $ access variables global to cod.
26
27$ we begin by seeing whether the predicates is followed by a series
28$ of 'not' instructions.
29
30 even = yes; $ indicates even number of 'not-s'
31 arg = a1; $ output of previous instruction
32 p = next(now);
33
34 while opcode(p) = q1_not & is_temp(arg) & arg2(p) = arg;
35 arg = arg1(p);
36 p = next(p);
37 even = ^ even;
38 end while;
39
40$ now see if the expression is used in a branch
41
42 op1 = opcode(p);
smfb 133
smfb 134 if op1 = q1_bif then op1 = q1_if;
smfb 135 elseif op1 = q1_bifnot then op1 = q1_ifnot;
smfb 136 end if;
smfb 137
smfb 138 opcode(p) = op1;
43
44 if class(op1) = cl_ifgo & is_temp(arg) & arg1(p) = arg then
45
46$ drop the temporaries defined by the predicate and the 'not'
47$ instructions.
48 pp = now;
49
50 until pp = p;
51 if (is_temp(arg1(pp))) call drop_temp(arg1(pp));
52 pp = next(pp);
53 end until;
54
smfb 139$ change the predicate to a branch instruction
56 if (even & op1 = q1_if) ! (^ even & op1 = q1_ifnot) then
57 op = if_op(op);
58 else
59 op = ifn_op(op);
60 end if;
61
62 opcode(now) = op; $ change predicate to branch
63 arg1(now) = arg2(now);
64 arg2(now) = arg3(now);
65 arg3(now) = arg2(p);
66
67$ delete the original branch
68 next(now) = next(p);
69
70$ free the inputs of the branch
71 if (is_temp(a1)) call free_temp(a1);
72 if (is_temp(a2)) call free_temp(a2);
73
74 $ look for branches to a label followed by an unconditional
75 $ branch
76 arg3(now) = shrtct(arg3(now));
77
78 return;
79 end if;
80
81$ otherwise process the predicate like any binary operator
82 call set_temp(a1, f_atom);
83
84 if (is_temp(a2)) call free_temp(a2);
85 if (is_temp(a3)) call free_temp(a3);
86
87
88 end subr fixpred;
1 .=member shrtct
2 fnct shrtct(arg);
3$
4$ this routine returns the label of the first non-empty block that can
5$ reached from the label arg.
6$
7 size shrtct(ps); $ label of first non-emtpy block
8
9 size arg(ps); $ symtab pointer of block label
10
11 size i1(ps), i2(ps); $ q1 code pointers
12 size j(ps); $ counter to limit transitive closure
13 size lab(ps); $ symtab pointer of block label
14
15 access q1vars; $ access global q1 variables.
16 access nscod; $ access variables global to cod.
17
18
19 lab = arg; $ copy argument
20
21 do j = 1 to 10; $ for at most ten branches to branches
suna 23 if symtype(lab) ^= f_lab then
suna 24 put ,'symtype(lab) = ' :symtype(lab),i ,', lab = ' :lab,i
suna 25 ,skip;
suna 26 call ermsg(27, 0);
suna 27 end if;
23 i1 = symval(lab); $ q1_label or q1_tag instruction
suna 28 if opcode(i1) ^= q1_label & opcode(i1) ^= q1_tag then
bnda 10 put ,'arg = ' :arg,i ,', lab = ' :lab,i ,', i1 = ' :i1,i
bnda 11 ,', opcode(i1) = ' :opcode(i1),i ,skip;
suna 30 call ermsg(28, 0);
suna 31 end if;
25 i2 = next(i1); $ instruction after label
26
27 if stmt_flag < 2 then $ can skip statement quadruples
28 while i2 ^= 0; if (opcode(i2) ^= q1_stmt) quit while;
29 i2 = next(i2);
30 end while;
31 end if;
32
33 if i2 = 0 then $ implicit goto at end of block
34 i2 = b_first(blockof(i1) + 1);
suna 32 if (i2 = 0) call ermsg(29, 0);
suna 33 if opcode(i1) ^= q1_label & opcode(i1) ^= q1_tag then
suna 34 put ,'opcode(i2) = ' :opcode(i2),i ,skip;
suna 35 call ermsg(30, 0);
suna 36 end if;
36 elseif opcode(i2) ^= q1_goto then
37 quit do j;
38 end if;
39 lab = arg1(i2);
40 end do j;
41
42 shrtct = lab;
43
44
45 end fnct shrtct;
1 .=member settemp
2 subr set_temp(t1, fm);
3
4$ this routine is called during the fixup pass to process each
5$ instruction which defines a temporary. t1 is the temporary and
6$ fm is its type. we do two things:
7
8$ 1. set the form of t1 to fm.
9
10$ 2. see if there are any free temps available. if so, we make
11$ t1 an alias for one of the free temps.
12
13$ some temporaries, such as those yielded by conditional
14$ expressions, are defined several times. the first time we process
15$ such a temporary, we set its is_seen flag. the next time, we
16$ simply return.
17
18$ we maintain a stack called 'temptab' containing all currently
19$ available temporaries.
20
21$ temporaries are divided into to categories: those which are saved
22$ during backtracking and those which aren't. we cannot store
23$ temporaries of different classes in the same list. since
24$ backtracked temporaries are very rare, we do not even try to
25$ merge them.
26$
27$ also note that we can not alias a typed and an untyped variable, as
28$ this would derail the garbage collector. we assume, for simplicity,
29$ that untyped temporaries are rare, and do not attempt to find free
30$ untyped temporaries.
31
32
33 nameset temptab;
34 +* temptab_lim = 500 **
35
36 size temptab(ps);
37 dims temptab(temptab_lim);
38
39 size temptabp(ps); $ pointer to last entry used
40 data temptabp = 0;
41
42 end nameset;
43
44 size t1(ps), $ original temp
45 fm(ps); $ its type
46
47 size t2(ps); $ free temp
48
49 access q1vars; $ access global q1 variables.
50 access nscod; $ access variables global to cod.
51
52
53 if (opt_flag) return;
54
55$ if the temporary is defined twice with different types, set
56$ its type to general.
57
58 if is_seen(t1) then
59 if (fm ^= form(t1)) form(t1) = f_gen;
60 return;
61 end if;
62
63
64 form(t1) = fm; $ install type
65 is_repr(t1) = yes;
66 is_seen(t1) = yes;
67
68 if (is_back(t1) & back_flag) return;
69 if (is_funt(fm)) return;
70
71 if (temptabp = 0) return; $ no free temps
72
73 t2 = temptab(temptabp); $ get first free temp
74 temptabp = temptabp - 1;
75
76 alias(t1) = t2; $ make t1 an alias for t2
77 is_store(t1) = no;
78
79$ indicate that there is an alias for t2
80 is_alias(t2) = yes;
81
82
83 end subr set_temp;
1 .=member freetemp
2 subr free_temp(t1);
3
4$ this routine frees a temporary 't1'. this is done in two steps:
5
6$ 1. set t2 = t1. if t2 is an alias, set t2 = alias(t2).
7$ 2. add t2 to temptab.
8
9 size t1(ps); $ original temporary
10
11 size t2(ps); $ possible alias
12
13 access temptab;
14 access q1vars; $ access global q1 variables.
15 access nscod; $ access variables global to cod.
16
17
18 if (opt_flag) return;
19
20 if (is_back(t1) & back_flag) return;
21
22 t2 = t1;
23 if (alias(t2) ^= 0) t2 = alias(t2);
24
25 countup(temptabp, temptab_lim, 'temptab');
26 temptab(temptabp) = t2;
27
28
29 end subr free_temp;
1 .=member droptemp
2 subr drop_temp(t1);
3
4$ this routine is called when we reserve a temporary for 't1' and
5$ then discover that it is not actually needed. there are three
6$ possibilities:
7
8$ 1. t1 is an alias for t2. add t2 to temptab.
9
10$ 2. there is an alias for t1. add t1 to temptab.
11
12$ 3. otherwise clear t1's is_store bit.
13
14 size t1(ps); $ original temp
15
16 access temptab;
17 access q1vars; $ access global q1 variables.
18 access nscod; $ access variables global to cod.
19
20
21 if (opt_flag) return;
22
23 if (is_back(t1) & back_flag) return;
24
25 if alias(t1) ^= 0 then
26 countup(temptabp, temptab_lim, 'temptab');
27 temptab(temptabp) = alias(t1);
28
29 elseif is_alias(t1) then
30 countup(temptabp, temptab_lim, 'temptab');
31 temptab(temptabp) = t1;
32
33 else
34 is_store(t1) = no;
35 end if;
36
37
38 end subr drop_temp;
1 .=member cltemps
2 subr clear_temps;
3
4$ this routine reinitializes temptab
5
6 access temptab;
7 access q1vars; $ access global q1 variables.
8 access nscod; $ access variables global to cod.
9
10 temptabp = 0;
11 return;
12
13 end subr clear_temps;
1 .=member alloc
2 subr alloc;
3
4$ this routine allocates storage in the run time symbol
5$ table.
6
7$ the following types of symbols require storage
8
9$ 1. variables
10$ 2. constants
11$ 3. bases
12
13$ in addition each distinct data type requires a symbol table
14$ entry which is used to store the standard representation of
15$ omega for that type.
16
17$ the symbol table is located at the high end of the heap.
18$ the variable 'sym_end' points to the end of the symbol
19$ table. every time we adjust sym_end we must check that
20$ we have not gone into the area used for code, etc.
21
22$ symbol table entries may be divided into storage classes
23$ based on whether the symbol is typed or untyped, static
24$ or stacked, etc. the symbols for each scope are stored
25$ contiguously, sorted by storage class.
26
27$ storage allocation is done in four steps:
28
29$ 1. iterate over the current page of symtab, assigning each symbol
30$ which requires storage an offset within the appropriate block.
31$ as we allocate offsets, we build a map 'blocklen' sending
32$ each block into its length.
33
34$ during this pass we also check whether we are using untyped
35$ integers or reals while the library is in the full error
36$ checking mode. if so, we issue a diagnostic.
37
38$ constant bases recieve two symbol table entries. the first is
39$ used for the base itself. the second is used for a tuple
40$ containing all the elements of the base in order of their
41$ ebindx. this tuple is used to unpack values stored in packed
42$ maps and tuples.
43
44$ set the ft_samp field of bases to point to the base.
45
46
47$ 2. iterate over the current page of formtab, assigning each
48$ sample within the appropriate block.
49
50$ there are four cases in which we do not allocate storage for
51$ a separate sample value:
52
53$ a. standard based types
54
55$ the types f_lset, f_rset, etc. are never used as reprs for
56$ actual variables, and do not receive sample values.
57
58$ b. local types with ft_pos = 0.
59
60$ each time the semantic pass processes a repr for a local
61$ object it creates a copy of the original formtab entry
62$ with a unique ft_pos. the original entry has an ft_pos
63$ of zero. since it is never used as the type of any variable,
64$ it does not require storage.
65
66$ c. standard packed tuple
67
68$ the type f_ptuple is never used as repr for any actual variable,
69$ and therefor does not receive a sample value.
70
71$ d. bases:
72
73$ the ft_samp field of a base points to the base itself rather
74$ than a separate sample value.
75
76$ 3. allocate a skip word and initialize it.
77
78$ 4. integrate blocklen and produce a map blockorg giving the
79$ origin of each block.
80
81$ 6. make a second pass through symtab and formtab, mapping offsets
82$ into addresses, and build the run time names table.
83$ when we iterate through formtab, we set the ft_samp field
84$ of each base to the address of the base.
85
86
87 size cl(ps); $ storage class
88 size fm(ps); $ form of variable
89 size len(ps); $ length of block
90 size org(ps); $ origin of block
91 size addr(ps); $ final address
92 size j(ps); $ loop index
93
94 size skip_offs(ps); $ offset of skip word
95 size skip_addr(ps); $ address of skip word
96 size skip_valu(ps); $ value of skip word
97
98 size sclass(ps); $ functions called
99 size fsclass(ps);
100
101 access q1vars; $ access global q1 variables.
102 access nscod; $ access variables global to cod.
103
104
stra 36 do j = scl_min to scl_max; $ initialise blocklen
106 blocklen(j) = 0;
107 end do;
108
109$ assign offsets within blocks
110 do j = symtab_org+1 to symtabp;
111
112 fm = form(j);
113 if (is_funt(fm) & err_mode = err_full) call ermsg(12, j);
114
115 if (^ is_store(j)) cont;
116
117 cl = sclass(j);
118 address(j) = blocklen(cl);
119 blocklen(cl) = blocklen(cl) + 1;
120
121 $ allocate a skip word after untyped parameters
stra 37 if cl = scl_param & is_funt(fm) then
123 blocklen(cl) = blocklen(cl) + 1;
124 end if;
125
126 if is_fbase(fm) then
127 ft_samp(fm) = j; $ points back to base
128
129 if is_const(j) then $ allocate extra word
130 blocklen(cl) = blocklen(cl) + 1;
131 end if;
132 end if;
133 end do;
134
135 do j = formtab_org+1 to formtabp;
136 if (is_fbsd(j) & j <= f_max) cont; $ f_lset, etc.
137 if (is_floc(j) & ft_pos(j) = 0) cont;
138 if (j = f_latom ! j = f_elmt) cont; $ no elmt *
139 if (j = f_ptuple) cont; $ no packed tuple(*)
140 if (is_fbase(j)) cont;
141
142 if is_fmap(j) then
143 if ( ^ is_fbsd(j) & is_funt(ft_im(j))) cont;
144 end if;
145
146 cl = fsclass(j);
147 ft_samp(j) = blocklen(cl);
148 blocklen(cl) = blocklen(cl) + 1;
149 end do;
150
151$ add room at the end of the untyped block for a skip word.
stra 38 skip_offs = blocklen(scl_untyped);
stra 39 blocklen(scl_untyped) = blocklen(scl_untyped) + 1;
154
155$ assign origins to new blocks
stra 40 do cl = scl_min to scl_max;
157 blockorg(cl) = sym_lim-1; get_symtab(blocklen(cl));
158 end do;
159
160$ adjust addresses and build run time names entries
161
162 do j = symtab_org+1 to symtabp;
163 if (^ is_store(j)) cont;
164
165 org = blockorg(sclass(j));
166 addr = org - address(j);
167
168 address(j) = addr;
smfa 32 call iname('', j, addr);
170
171 $ we allocate two consecutive symbol table entries for each
172 $ constant base: initialise the second names entry
173 if is_fbase(form(j)) & is_const(j) then
smfa 33 call iname('c$', j, addr-1);
175 end if;
176 end do;
177
178 do j = formtab_org+1 to formtabp;
179 if (is_fbsd(j) & j <= f_max) cont; $ no sample
180 if (is_floc(j) & ft_pos(j) = 0) cont;
181 if (j = f_latom ! j = f_elmt) cont;
182 if (j = f_ptuple) cont;
183
184 if is_fmap(j) then
185 if ( ^ is_fbsd(j) & is_funt(ft_im(j))) cont;
186 end if;
187
188 if is_fbase(j) then $ use value as sample
189 if (ft_samp(j) ^= 0) ft_samp(j) = address(ft_samp(j));
190
191 else
192 org = blockorg(fsclass(j));
193 addr = org - ft_samp(j);
194
195 ft_samp(j) = addr;
smfa 34 call iname('.om', 0, addr);
197
198 if (j = f_pair) s_pair = addr; $ save address of std pair
199 end if;
200 end do;
201
202$ initialize the skip word
203
stra 41 skip_addr = blockorg(scl_untyped) - skip_offs;
stra 42 skip_valu = blocklen(scl_untyped);
206 build_spec(heap(skip_addr), t_skip, skip_valu);
stra 43 assert scl_min = scl_untyped; $ make sure trick still works
smfa 36 call iname('', curunit, skip_addr);
208
209 if (q1sd_flag) call sdump; $ dump tables
210
211
212 end subr alloc;
1 .=member initname
smfa 37 subr iname(s1, nam, addr);
smfa 38
smfa 39$ this routine initialises the run-time names table.
smfa 40
smfa 41 size s1(sds_sz); $ prefix string to be used
smfa 42 size nam(ps); $ q1 symbol table pointer
smfa 43 size addr(ps); $ run-time symbol table address
smfa 44
smfa 45 size s2(sds_sz); $ symbol name as sds string
smfa 46 size l1(ps), l2(ps); $ respective lengths of strings
smfa 47 size len(ps); $ length of string
smfa 48 size card(ps); $ cardinality of run-time names tuple
smfa 49 size maxi(ps); $ maximum index of run-time names tuple
smfa 50 size spec(hs); $ temporary for setl specifier
smfa 51 size ss1(ssz); $ string specifier for long char block
smfa 52 size ptr(ps); $ pointer to long character block
smfa 53 size leng(ps); $ length of string block
smfa 54 size word(ps); $ pointer to current word long char block
smfa 55 size offs(ps); $ offset in current word long char block
smfa 56 size j(ps); $ loop index
smfa 57
smfa 58 size init(1); $ flags initial entry
smfa 59 data init = yes;
smfa 60
smfa 61 access q1vars; $ access global q1 variables.
smfa 62 access nscod; $ access variables global to cod.
smfa 63
smfa 64
smfa 65 if init then $ first entry to routine
smfa 66 init = no;
smfa 67
smfa 68 $ allocate the tuple to hold the run-time names.
smfa 69 get_heap(talloc(4), rnames);
smfa 70 htype(rnames) = h_tuple; hlink(rnames) = 0;
smfa 71 hform(rnames) = f_tuple;
smfa 72 is_hashok(rnames) = no; is_neltok(rnames) = yes;
smfa 73 maxindx(rnames) = 4; maxi = 4; nelt(rnames) = 0; card = 0;
smfa 74
smfa 75 $ allocate the zero'th string block.
smfa 76 build_ss(ss1, 0, 0, 0); leng = 0;
smfa 77 get_heap(lcalloc(0), ptr); lc_nwords(ptr) = lcalloc(0);
smfa 78 htype(ptr) = h_lstring; hlink(ptr) = 0;
smfa 79 ss_ptr(ss1) = ptr;
smfa 80 build_spec(spec, t_oistring, ss1); is_shared_ spec = yes;
smfa 81 do j = 0 to maxi; tcomp(rnames, j) = spec; end do;
smfa 82
smfa 83 word = ptr + hl_lchars; offs = chorg;
smfa 84 end if;
smfa 85
smfa 86 $ set scope flags, if appropriate.
smfa 87 if nam = curmemb then rn_memb(addr) = yes; end if;
smfa 88 if nam = currout then rn_proc(addr) = yes; end if;
smfa 89
smfa 90 l1 = slen s1;
smfa 91
smfa 92 $ get symbol name.
smfa 93 if nam ^= 0 then
smfa 94 if name(nam) ^= 0 then
smfa 95 s2 = namesds(name(nam));
smfa 96 else $ an internal name.
smfa 97 if l1 = 0 then $ store q1 symbol table index.
smfa 98 rn_indx(addr) = 0; rn_offs(addr) = nam;
smfa 99 return;
smfa 100 else $ generate name here.
smfa 101 s2 = 't$' .pad. 7; len = nam;
smfa 102 do j = 7 to 3 by -1;
smfa 103 .ch. j, s2 = charofdig(mod(len, 10));
smfa 104 len = len / 10;
smfa 105 end do;
smfa 106 end if;
smfa 107 end if;
smfa 108 l2 = slen s2;
smfa 109 else
smfa 110 l2 = 0;
smfa 111 end if;
smfa 112
smfa 113 len = l1 + l2;
smfa 114
smfa 115 if ss_len(ss1)+len > leng then
smfa 116 if card = maxi then
smfa 117 $ we will have to fix this some day.
smfa 118 call overfl('run-time names table');
smfa 119 end if;
smfa 120
smfa 121 $ allocate the next string block.
smfa 122 build_ss(ss1, 0, 0, 0);
smfa 123 leng = (sym_end-sym_org+1)*4;
smfa 124 if (leng > max_ic_len) leng = max_ic_len;
smfa 125 get_heap(lcalloc(leng), ptr); lc_nwords(ptr) = lcalloc(leng);
smfa 126 htype(ptr) = h_lstring; hlink(ptr) = 0;
smfa 127 ss_ptr(ss1) = ptr;
smfa 128 build_spec(spec, t_istring, ss1);
smfa 129 card = card + 1; nelt(rnames) = card;
smfa 130 tcomp(rnames, card) = spec;
smfa 131
smfa 132 word = ptr + hl_lchars; offs = chorg;
smfa 133 end if;
smfa 134
smfa 135 $ initialise the compressed string specifier for this entry.
smfa 136 rn_indx(addr) = card;
smfa 137 rn_offs(addr) = ss_len(ss1) + 1;
smfa 138 rn_len(addr) = len;
smfa 139
smfa 140 $ update then run-time names string descriptor.
smfa 141 ss_len(ss1) = ss_len(ss1) + len;
smfa 142 value_ tcomp(rnames, card) = ss1;
smfa 143
smfa 144 do j = 1 to l1;
smfa 145 .f. offs, chsiz, heap(word) = .ch. j, s1;
smfa 146
smfa 147 if offs = chlst then
smfa 148 word = word + 1; offs = chorg;
smfa 149 else
smfa 150 offs = offs + chinc;
smfa 151 end if;
smfa 152 end do;
smfa 153
smfa 154 do j = 1 to l2;
smfa 155 .f. offs, chsiz, heap(word) = .ch. j, s2;
smfa 156
smfa 157 if offs = chlst then
smfa 158 word = word + 1; offs = chorg;
smfa 159 else
smfa 160 offs = offs + chinc;
smfa 161 end if;
smfa 162 end do;
smfa 163
smfa 164
smfa 165 end subr iname;
1 .=member sclass
2 fnct sclass(j);
3
4$ returns sclass of a symtab entry. see comments in subr alloc.
5
6$ we assign symtab entries a storage class based on whether they are
7$ parameters and on whether they are typed or untyped. it is
8$ possible to special case typed constants, and assign them
9$ an sclass of sc_untyped, since they will never contain
10$ pointers to the collectable part of the heap. this special
11$ casing speeds up the garbage collector. however we omit it
12$ for the moment since it also makes heap dumps slightly less
13$ readable.
14
stra 44 size sclass(ps); $ code scl_xxx returned
16
17 size j(ps); $ symtab pointer
18
19 size tp(ps); $ ft_type
20
21 access q1vars; $ access global q1 variables.
22 access nscod; $ access variables global to cod.
23
24
25 if is_param(j) then $ parameter block
stra 45 sclass = scl_param;
27
28 else
29 tp = symtype(j);
30
31 if tp = f_uint ! tp = f_ureal then
stra 46 sclass = scl_untyped;
33
34 elseif is_stk(j) then
stra 47 sclass = scl_stacked;
36
37 else
stra 48 sclass = scl_static;
39 end if;
40 end if;
41
42
43 end fnct sclass;
1 .=member fsclass
2 fnct fsclass(fm);
3
4$ this routine is similar to sclass, but decides where to allocate
5$ the sample value for a given form.
6
7 size fm(ps); $ a form
8
stra 49 size fsclass(ps); $ code scl_xxx returned
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14 if fm = f_uint ! fm = f_ureal then $ used untyped block
stra 50 fsclass = scl_untyped;
16
17 else
stra 51 fsclass = scl_static;
19 end if;
20
21
22 end fnct fsclass;
1 .=member genint
2 fnct genint(n);
3
4$ this routine allocates and initializes an integer constant.
5$ it is called on the fly when one of the emission routines
6$ discovers that the constant is necessary.
7
8$ we return a symbol table pointer to the integer.
9
10
11 size n(ps); $ value of integer
12
13 size genint(ps); $ q2 symbol table pointer returned
18
19 access q1vars; $ access global q1 variables.
20 access nscod; $ access variables global to cod.
21
22
23 if n <= 9 then $ use standard value
24 genint = address(sym_zero + n);
25 return;
26 end if;
27
28$ otherwise build new entry
29 get_symtab(1); genint = sym_lim;
30 build_spec(heap(genint), t_int, n);
smfa 166 call iname('', 0, genint);
43
44
45 end fnct genint;
1 .=member codegen
2 subr codegen;
3
4$ this is the top routine for actual code generation. we begin
5$ by calling an initialization routine which builds a data
6$ block for the code we are about to emit, then iterate over the
7$ program processing q1 instructions.
8
9 size opc(ps); $ q2 opcode
10 size addr(ps); $ misc. address
11 size n(ps); $ counter
12 size addr1(ps); $ run-time address of a1
13 size addr2(ps); $ run-time address of a2
14 size addr3(ps); $ run-time address of a3
15 size stmt_pending(1); $ statement quadruple pending
16
17 size genint(ps); $ allocates integer constant
18
19 access q1vars; $ access global q1 variables.
20 access nscod; $ access variables global to cod.
21
22
23 call initcode;
24 stmt_pending = no;
25
26
27 code_loop; $ iterate over code
28
29 get_addr(addr_a1, a1); $ get addresses of operands
30 get_addr(addr_a2, a2);
31 get_addr(addr_a3, a3);
32
33 go to case(class(op)) in cl_minimum to cl_maximum;
34
35 /case(cl_noop)/ $ noop
36
37 cont_loop;
38
39 /case(cl_simp)/
40
41 /case(cl_umin)/ $ unary minus
42
43 /case(cl_int)/ $ fix, top, bot
44
45 /case(cl_real)/ $ yield real
46
47 /case(cl_str)/ $ things yielding strings
48
49 /case(cl_bool)/ $ yield boolean
50
51 /case(cl_uset)/ $ yield set(*)
52
53 /case(cl_not)/ $ q1_not
54
55 /case(cl_rand)/ $ random
56
57 /case(cl_arb)/ $ arb
58
59
60 opc = spec_op(op, fm2);
61
62 if opc = 0 then
63 opc = std_op(op);
64
65 if nargs(now) >= 2 then
66 call typea2;
67 else
68 addr_a2 = 0;
69 end if;
70
71 if nargs(now) = 3 then
72 call typea3;
73 else
74 addr_a3 = 0;
75 end if;
76 end if;
77
78 call em2(opc, addr_a1, addr_a2, addr_a3);
79 cont_loop;
80
81
82 /case(cl_lessf)/ $ lessf
83
84 call emlessf;
85 cont_loop;
86
87 /case(cl_stmt)/ $ statement trace
88
89 cstmt_count = cstmt_count + 1;
90 stmt_tot = stmt_tot + 1;
91
92 if (stmt_flag = 0) cont_loop;
93
94 if next(now) ^= 0 then
95 opc = opcode(next(now));
96 if (opc = q1_stmt) cont_loop;
97 if opc = q1_goto ! opc = q1_exit ! opc = q1_stop then
98 stmt_pending = yes;
99 cont_loop;
100 end if;
101 else $ next(now) = 0, i.e. the end of a basic block
102 stmt_pending = yes;
103 cont_loop;
104 end if;
105
106 call em2(q2_stmt, address(currout), stmt_count, cstmt_count);
107 stmt_pending = no;
108
109 cont_loop;
110
111
112 /case(cl_call)/ $ calls
113
114 if is_bip(a1) then $ call to built in procedure
115 get_addr(addr, symval(a1)); $ temp used for result
116
117 call em2(bip_op(a1), addr, addr_a1, addr_a2);
118
119 else
120 if back_flag then
121 opc = q2_bcall;
122 else
123 opc = q2_call;
124 end if;
125
126 call em2(opc, labval(a1), addr_a1, addr_a2);
127 call uselab(a1);
128
129 if (stmt_flag < 2) cont_loop;
130 if next(now) ^= 0 then
131 if (opcode(next(now)) = q1_stmt) cont_loop;
132 end if;
133 call em2(q2_stmt,address(currout),stmt_count,cstmt_count);
134 call sa4(yes);
135 end if;
136
137 cont_loop;
138
139 /case(cl_goto)/ $ goto
140
141 call em2(q2_goto, labval(a1), 0, 0);
142 call uselab(a1);
143
144 cont_loop;
145
146
147 /case(cl_ifgo)/ $ conditional branches
148
149 if op = q1_if then
150 opc = q2_gotrue;
151 else
152 opc = q2_gofalse;
153 end if;
154
155 call em2(opc, labval(a2), addr_a1, 0);
156 call uselab(a2);
157
158 cont_loop;
159
160 /case(cl_ifgo1)/ $ branches on binary predicate
161
162 if op = q1_ifeq ! op = q1_ifne then
163 call spec_eq(opc, addr1, addr2, op, a1, a2);
164
165 elseif op = q1_ifin ! op = q1_ifnin then
166 call spec_in(opc, addr1, addr2, op, a1, a2);
167
168 else
169 call spec_pred(opc, addr1, addr2, op, a1, a2);
170 end if;
171
172 call em2(opc, labval(a3), addr1, addr2);
173 call uselab(a3);
174
175 cont_loop;
176
177 /case(cl_case)/ $ case jump
178
179
180 call typea2;
181
182 opc = spec_op(op, fm1);
183 call em2(opc, addr_a1, addr_a2, 0);
184 cont_loop;
185
186
187 /case(cl_lab)/ $ label
188
189 call setlab(a1);
190
191 if (asm_flag) call em2(std_op(op), labval(a1), 0, 0);
192
193 if (stmt_flag = 0) cont_loop;
194
195 if next(now) ^= 0 then
196 if (opcode(next(now)) = q1_stmt) cont_loop;
197 end if;
198
199 if stmt_pending then
200 call em2(q2_stmt,address(currout),stmt_count,cstmt_count);
201 stmt_pending = no;
202 end if;
203
204 cont_loop;
205
206 /case(cl_entry)/ $ routine entry
207
208 cstmt_count = estmt_count;
209 if ^ asm_flag then
210 call em2(q2_stmt,address(currout),stmt_count,cstmt_count);
211 end if;
212 stmt_tot = stmt_tot + 1;
213
214 if back_flag then
215 call embentry;
216 else
217 call ementry;
218 end if;
219
220 cont_loop;
221
222 /case(cl_exit)/ $ routine exit
223
224 if back_flag then
225 call embexit;
226 else
227 call emexit;
228 end if;
229
230 cont_loop;
231
232
233 /case(cl_min)/ $ binary operators min, max
234
235 /case(cl_bin)/ $ binary operations +, -, *, /, and mod
236
237 call embin;
238 cont_loop;
239
240
241 /case(cl_with)/ $ with and less
242
243 call emwith;
244 cont_loop;
245
246 /case(cl_from)/ $ from
247
248 call emfrom;
249 cont_loop;
250
251 /case(cl_pred1)/ $ membership tests
252
253 call spec_in(opc, addr2, addr3, op, a2, a3);
254 call em2(opc, addr_a1, addr2, addr3);
255 cont_loop;
256
257 /case(cl_pred2)/ $ binary predicates
258
259 if op = q1_eq ! op = q1_ne then
260 call spec_eq(opc, addr2, addr3, op, a2, a3);
261
262 else
263 call spec_pred(opc, addr2, addr3, op, a2, a3);
264 end if;
265
266 call em2(opc, addr_a1, addr2, addr3);
267 cont_loop;
268
269
270 /case(cl_asrt)/ $ test program assertion
271
smfb 140 if op = q1_ifasrt then
smfb 141 call em2(q2_ifasrt, labval(a1), 0, 0);
smfb 142 call uselab(a1);
smfb 143 cont_loop;
smfb 144 end if;
smfb 145
272 if ^ can_assign(f_atom, fm1) then
273 call emconv(sym_t1_, a1, f_atom, no);
274 addr_a1 = addr_t1;
275 end if;
276
277 call em2(q2_asrt, addr_a1, address(currout), stmt_count);
278 cont_loop;
279
280 /case(cl_nelt)/ $ nelt
281
282 call emnelt;
283 cont_loop;
284
285 /case(cl_newat)/ $ newat
286
287 call emnewat;
288 cont_loop;
289
290 /case(cl_of)/ $ y := f(x)
291
292 call emof;
293 cont_loop;
294
295 /case(cl_ofa)/ $ y := f<>
296
297 call emofa;
298 cont_loop;
299
300 /case(cl_subst)/ $ y := s(i..j)
301
302 call emsubst;
303 cont_loop;
304
305 /case(cl_sof)/ $ f(x) := y
306
307 call emsof;
308 cont_loop;
309
310 /case(cl_sofa)/ $ f<> := y
311
312 call emsofa;
313 cont_loop;
314
315 /case(cl_ssubst)/ $ s(i..j) := y
316
317 call emssubst;
318 cont_loop;
319
320 /case(cl_argin)/ $ procedure argument
321
322 call emargin;
323 cont_loop;
324
325 /case(cl_push)/ $ stack push
326
327$ push a1, converting it to the element type of the set or tuple
328 call empush(a1, elmt_type(fm2));
329
330 cont_loop;
331
332 /case(cl_free)/
333
334 n = 0;
335 while 1;
336 n = n + 1;
337 $ if we pushed an untyped value, we must pop a skip word
338 if (is_funt(arg_type(a2, symval(a3)))) n = n + 1;
339
340 if (next(now) = 0) quit while;
341 if (class(opcode(next(now))) ^= cl_free) quit while;
342 prev = now; now = next(now);
343 end while;
344
345 addr = genint(n);
346
347 if back_flag & ^ is_bip(a2) then
348 call em2(q2_bfree, addr, 0, 0);
349 elseif n = 1 then
350 call em2(q2_free1, 0, 0, 0);
351 else
352 call em2(q2_free, addr, 0, 0);
353 end if;
354
355 cont_loop;
356
357
358 /case(cl_argout)/ $ argout
359
360 call emargout;
361 cont_loop;
362
363
364 /case(cl_asn)/ $ x := y
365
366 call emasn;
367 cont_loop;
368
369
370 /case(cl_st)/ $ enumerative set/tuple former
371
372 call emst;
373 cont_loop;
374
375 /case(cl_st1)/ $ iterative set/tuple former
376
377 call emst1;
378 cont_loop;
379
380 /case(cl_st2)/ $ q1_dom and q1_range
381
382 call emst2;
383 cont_loop;
384
385
386 /case(cl_debug)/ $ debugging options
387
388 call emdebug;
389 cont_loop;
390
391 /case(cl_next)/
392
393 /case(cl_nextd)/
394
395 if (^ can_assign(fm3, deref_typ(fm3))) call ermsg(3, a3);
396
397 opc = spec_op(op, fm3);
398 if (opc = 0) opc = std_op(op);
399
smfb 146 call set_a1; $ copy_flag might be set for next on maps
400 call em2(opc, addr_a1, addr_a2, addr_a3);
401 cont_loop;
402
403 /case(cl_ok)/
404
405 call emok;
406 cont_loop;
407
408 /case(cl_fail)/
409
410 call emfail;
411 cont_loop;
412
413 /case(cl_succeed)/
414
415 call emsucceed;
416 cont_loop;
417
418
419 end_loop;
420
421 call termcode; $ finish off code block
422
423
424 end subr codegen;
1 .=member speceq
2 subr spec_eq(opc, addr1, addr2, op1, in1, in2);
3
4$ this routine special cases equality tests. its inputs are:
5
6$ op1: q1 opcode
7$ in1: symtab pointer for first input
8$ in2: symtab pointer for second input
9
10$ its outputs are:
11
12$ opc: q2 opcode
13$ addr1: address of first input
14$ addr2: address of second input
15
16$ it is fairly likely that in2 is a constant. we do two types of special
17$ casing here:
18
19$ first, we look for an alternate representation of in2 which has the
20$ same type as in1. this may allow us to do an inline test.
21
22$ second, we see whether in2 is a constant such as .nl or .om
23$ if so, we use a special equality test.
24
25$ if in2 is not one of the special constants we choose a q2 opcode
26$ based on the types of in1 and in2. if this winds up being a
27$ a library call we generate conversions to make sure that
28$ in1 and in2 are not untyped.
29
30 size op1(ps), $ q1 opcode
31 in1(ps), $ first input
32 in2(ps); $ second input
33
34 size opc(ps), $ q2 opcode
35 addr1(ps), $ address for in1
36 addr2(ps); $ address for in2
37
smfb 147 size f1(ps), f2(ps); $ forms of inputs
smfb 148 size t1(ps), t2(ps); $ form types of inputs
40
41 access q1vars; $ access global q1 variables.
42 access nscod; $ access variables global to cod.
43
44$ get addresses and find matching repr for in2
45 get_addr(addr1, in1);
46 get_addr(addr2, in2);
47
48 call match_repr(addr2, in2, form(in1));
smfb 149 call match_repr(addr1, in1, form(in2));
smfb 150
smfb 151 f1 = form(in1); t1 = ft_type(f1);
smfb 152 f2 = form(in2); t2 = ft_type(f2);
49
50 if (in2 = sym_om ) go to special;
55 if (in2 = sym_true ) go to special;
56 if (in2 = sym_false) go to special;
57
smfb 153 if (is_fint(f1) & is_fint(f2)) go to special;
smfb 154 if (is_ftup(f1) & is_ftup(f2)) go to special;
smfb 155 if (is_fset(f1) & is_fset(f2)) go to special;
61
smfb 156 if t1 = f_elmt & t2 = f_elmt & ft_base(f1) = ft_base(f2) then
65 $ both inputs are elements of the same base: check
66 $ pointer equality instead of value equality.
67 if op1 = q1_eq then opc = q2_eqv; return;
68 elseif op1 = q1_ne then opc = q2_nev; return;
69 elseif op1 = q1_ifeq then opc = q2_goeqv; return;
70 elseif op1 = q1_ifne then opc = q2_gonev; return;
71 end if;
72 end if;
73
74 go to standard;
75
76
77
78
79/special/ $ look for special case
80
smfb 157 if in2 <= sym_maximum & is_funt(f1) = 0 & is_funt(f2) = 0 then
smfb 158 $ may be system constant. note that since we do not include
smfb 159 $ type information into the tests which follow we must exclude
smfb 160 $ untyped data.
82
83 if op1 = q1_eq then
84 opc = eqop(in2);
85
86 elseif op1 = q1_ne then
87 opc = neop(in2);
88
89 elseif op1 = q1_ifeq then
90 opc = ifeq_op(in2);
91
92 else
93 opc = ifne_op(in2);
94 end if;
95
96 if opc ^= 0 then addr2 = 0; return; end if;
97 end if;
98
smfb 161 if t1 = t2 then
smfb 162 opc = spec_op(op, t1); if (opc ^= 0) return;
smfb 163 end if;
101
102/standard/ $ use standard op1ode
103
104 opc = std_op(op);
105
106 if is_funt(form(in1)) then
107 call emconv(sym_t1_, in1, f_gen, no);
108 addr1 = addr_t1;
109 end if;
110
111 if is_funt(form(in2)) then
112 call emconv(sym_t2_, in2, f_gen, no);
113 addr2 = addr_t2;
114 end if;
115
116 return;
117
118 end subr spec_eq;
1 .=member specin
2 subr spec_in(opc, addr1, addr2, op1, in1, in2);
3
4$ this routine special cases membership tests. its inputs are:
5
6$ op1: q1 opcode
7$ in1: symtab pointer for first input
8$ in2: symtab pointer for second input
9
10$ its outputs are:
11
12$ opc: q2 opcode
13$ addr1: address of first input
14$ addr2: address of second input
15
16$ if in1 is a constant we try to find a representation of it
17$ with the element type of in2.
18
19
20 size op1(ps), $ q1 opcode
21 in1(ps), $ first input
22 in2(ps); $ second input
23
24 size opc(ps), $ q2 opcode
25 addr1(ps), $ address for in1
26 addr2(ps); $ address for in2
27
28 size f1(ps); $ form of element
29 size f2(ps); $ form of string/tuple/set/map
30 size n1(ps); $ number of dereferences for element
31 size t2(ps); $ element form of second operand
32
33 access q1vars; $ access global q1 variables.
34 access nscod; $ access variables global to cod.
35
36$ get addresses and find matching repr for in2
37 get_addr(addr1, in1);
38 get_addr(addr2, in2);
39
smfb 164 call match_repr(addr1, in1, elmt_type(ft_deref(form(in2))));
41
42 f1 = form(in1); n1 = 0;
43 f2 = deref_typ(form(in2));
44
45 t2 = elmt_type(f2);
46
47 while ft_type(f1) = f_elmt & f1 ^= t2;
48 f1 = ft_elmt(ft_base(f1)); n1 = n1 + 1;
49 end while;
50
51 if (f1 ^= t2) go to standard;
52
53 opc = spec_op(op1, f2); if (opc = 0) go to standard;
54
55 if n1 = 1 then
56 call em2(q2_deref1, addr_t1, addr1, 0);
57 addr1 = addr_t1;
58 elseif n1 > 1 then
59 call em2(q2_deref, addr_t1, addr1, n1);
60 addr1 = addr_t1;
61 end if;
62
63 if f2 ^= form(in2) then
64 call emconv(sym_t2_, in2, f2, no); addr2 = addr_t2;
65 end if;
66
67 return;
68
69
70/standard/ $ use standard op1ode
71
72 opc = std_op(op);
73
74 if is_funt(f1) then
75 call emconv(sym_t1_, in1, f_gen, no);
76 addr1 = addr_t1;
77 end if;
78
79 return;
80
81 end subr spec_in;
1 .=member specpred
2 subr spec_pred(opc, addr1, addr2, op1, in1, in2);
3
4$ this routine special cases binary predicates such as <, >, etc.
5$ where it is desirable for the two inputs to have the same repr.
6$ the inputs to the routine are:
7
8$ op1: q1 opcode
9$ in1: symtab pointer for first input
10$ in2: symtab pointer for second input
11
12$ its outputs are:
13
14$ opc: q2 opcode
15$ addr1: address of first input
16$ addr2: address of second input
17
18$ if in2 is a constant we look for a representation of it with
19$ the same repr as in1.
20
21
22 size op1(ps), $ q1 opcode
23 in1(ps), $ first input
24 in2(ps); $ second input
25
26 size opc(ps), $ q2 opcode
27 addr1(ps), $ address for in1
28 addr2(ps); $ address for in2
29
30 size t1(ps), $ types of inputs
31 t2(ps);
32
33 access q1vars; $ access global q1 variables.
34 access nscod; $ access variables global to cod.
35
36$ get addresses and find matching repr for in2
37 get_addr(addr1, in1);
38 get_addr(addr2, in2);
39
40 call match_repr(addr2, in2, form(in1));
smfb 165 call match_repr(addr1, in1, form(in2));
41
42 t1 = form(in1);
43 t2 = form(in2);
44
45 if t1 = t2 then
46 opc = spec_op(op1, t2);
47 if (opc ^= 0) return;
48 end if;
49
50/standard/ $ use standard op1ode
51
52 opc = std_op(op);
53
54 if is_funt(t1) then
55 call emconv(sym_t1_, in1, f_gen, no);
56 addr1 = addr_t1;
57 end if;
58
59 if is_funt(t2) then
60 call emconv(sym_t2_, in2, f_gen, no);
61 addr2 = addr_t2;
62 end if;
63
64 return;
65
66 end subr spec_pred;
1 .=member ementry
2 subr ementry;
3
4$ this routine emits code for procedure entries. this is
5$ done in three steps:
6
7$ 1. call setlab to perform relocation.
8
9$ 2. if we plan to generate assembly code then set the value of the
10$ procedure to point to the code block and emit a q2_entry or
11$ q2_mentry instruction.
12
13$ 3. emit a series of move instructions. these instructions depend
14$ on whether the routine is recursive or not. if the routine
15$ is recursive emit:
16
17$ a. q2_swap swap the new values of the formal parameters,
18$ which are now in the stack, with the old values,
19$ which are now in the symbol table. this saves
20$ their old values.
21
22$ b. q2_savel get a stack block and save all the local stacked
23$ variables and temporaries.
24
25$ otherwise emit:
26
27$ a. q2_loadp copy the new values of the parameters into
28$ the symbol table
29
30$ 4. emit code to initialize all stacked local variables.
31$ note that we do not initialize temporaries since they
32$ never be used before they are defined.
33
34
35
36 size j(ps), $ loop index
37 fm(ps); $ form
38
39 access q1vars; $ access global q1 variables.
40 access nscod; $ access variables global to cod.
41
42 call setlab(currout); $ relocate entry point
43
44 if asm_flag then
45 value(address(currout)) = labval(currout);
46
47 if currout = sym_main_ then
48 call em2(q2_mentry, 0, 0, 0);
49 else
50 call em2(q2_pentry, labval(currout), 0, 0);
51 end if;
52 end if;
53
54
55$ emit appropriate move instructions, depending on whether routine
56$ is recursive.
57
58 if is_rec(currout) then $ recursive case
stra 52 call emmove(q2_swap, scl_param);
stra 53 call emmove(q2_savel, scl_stacked);
61
62 else $ non recursive
stra 54 call emmove(q2_loadp, scl_param);
64 end if;
65
66$ emit code to initialize stacked variables
67 do j = symtab_org+1 to symtabp;
68 if (^ is_store(j) ! is_temp(j) ) cont;
69 if (^ is_stk(j) ! is_param(j)) cont;
70
71 if (is_internal(j)) cont; $ ishadow variable
72
73 fm = form(j);
74 call em2(q2_asn, address(j), ft_samp(fm), 0);
75 end do;
76
77
78 end subr ementry;
1 .=member emexit
2 subr emexit;
3
4$ this routine emits the code for an exit block. this consists of two
5$ things:
6
7$ 1. a series of move instructions. if the routine is recursive
8$ we emit:
9
10$ a. q2_resetl move the old values of the stacked local
11$ variables back to the symbol table and free
12$ the stack space used to save them.
13
14$ b. q2_swap restore parameters
15
16$ otherwise we emit:
17
18$ a. q2_clearl set all local stacked variables to zero, thus
19$ freeing the data blocks they point to.
20
21
22$ b. q2_resetp restore parameters
23
24$ 2. if this is the main program emit a stop instruction; otherwise
25$ emit a return.
26
27 access q1vars; $ access global q1 variables.
28 access nscod; $ access variables global to cod.
29
30 if is_rec(currout) then
stra 55 call emmove(q2_resetl, scl_stacked);
stra 56 call emmove(q2_swap, scl_param);
33 else
stra 57 call emmove(q2_clearl, scl_stacked);
stra 58 call emmove(q2_resetp, scl_param);
36 end if;
37
38$ emit stop or return
39 if a1 = sym_main_ then
40 call em2(q2_stop, 0, 0, 0);
41 else
42 call em2(q2_retn, 0, 0, 0);
43 end if;
44
45
46 end subr emexit;
1 .=member embentry
2 subr embentry;
3
4$ this routine emits code for procedure entries when backtracking
5$ is enabled. this code consists of:
6
7$ entry instruction
8$ branch to body
9
10$ dexit, undo, and fail2 instructions
11
12$ body
13
14$ the q2_entry instruction has the following arguments:
15
16$ a1: address of 0-th parameter
17$ a2: length of parameter block
18$ a3: address of 0-th local variable
19$ a4: length of local variables block
20$ a5: address of dexit instruction
21
22 size xa1(ps), $ a1
23 xa2(ps), $ a2
24 xa3(ps), $ a3
25 xa4(ps), $ a4
26 xa5(ps);
27
28 size p1(ps); $ code pointers
29 size p2(ps);
30 size dexit_addr(ps); $ address of q2_dexit instruction
31 size addr(ps); $ run-time address of backtracked variable
32 size n(ps); $ number of saved variables
33 size j(ps); $ loop index
34
35 access q1vars; $ access global q1 variables.
36 access nscod; $ access variables global to cod.
37
38 call setlab(currout); $ do label relocation
39
40 if asm_flag then
41 value(address(currout)) = labval(currout);
42
43 if currout = sym_main_ then
44 call em2(q2_mentry, 0, 0, 0);
45 else
46 call em2(q2_pentry, labval(currout), 0, 0);
47 end if;
48 end if;
49
stra 59 xa1 = blockorg(scl_param) - (blocklen(scl_param)-1);
stra 60 xa2 = blocklen(scl_param);
stra 61 xa3 = blockorg(scl_stacked) - (blocklen(scl_stacked)-1);
stra 62 xa4 = blocklen(scl_stacked);
54 xa5 = codep + 4 * inst_nw;
55
56 call em2(q2_entry, xa5, xa1, xa2);
57 call em2(q2_noop, xa3, xa4, 0);
58
59$ emit goto and save a pointer to it so we can fill in its argument late
60 call em2(q2_goto, 0, 0, 0);
61 p1 = codep;
62
63$ emit dexit instruction. this has four arguments which are the same
64$ as the first four arguments of the entry instruction.
65
66 dexit_addr = codep + inst_nw;
67 if (asm_flag) call em2(q2_lab, dexit_addr, 0, 0);
68
69 call em2(q2_dexit, xa1, xa2, xa3);
70 call em2(q2_noop, xa4, 0, 0);
71
72$ set global pointer to 'undo' instruction. this address is needed as
73$ an argument to the q2_exit instruction.
74
75 undo_addr = codep + inst_nw;
76 if (asm_flag) call em2(q2_lab, undo_addr, 0, 0);
77
78$ emit the 'undo' instruction with the usual four arguments then
79$ set a5 to point back to the 'dexit' instruction.
80
81 xa5 = dexit_addr;
82 call em2(q2_undo, xa5, xa1, xa2);
83 call em2(q2_noop, xa3, xa4, 0);
84
85$ set global pointer to q2_fail instruction. this is needed as an
86$ argument to q2_ok instruction.
87
88 fail2_addr = codep + inst_nw;
89 if (asm_flag) call em2(q2_lab, fail2_addr, 0, 0);
90
91$ emit 'fail2' instruction. this instruction has one argument
92$ which gives the number of variables being saved, and is followed
93$ by a series of noops containing the addresses of the saved
94$ variables.
95
96 call em2(q2_fail2, 0, 0, 0);
97
98 n = 0; $ number of saved variables
99 p2 = codep;
100
101 do j = 1 to symtabp;
102 if (^ is_back(j)) cont;
103
104 n = n + 1;
105
106 get_addr(addr, j);
107 call em2(q2_noop, addr, 0, 0);
108 end do;
109
110 codea2(p2) = n;
111
112$ fill in address of body in the goto instruction
113 p2 = codep + inst_nw;
114 codea1(p1) = p2;
115 if (asm_flag) call em2(q2_lab, p2, 0, 0);
116
117
118 end subr embentry;
1 .=member embexit
2 subr embexit;
3
4$ this routine emits procedure exits when backtracking is enabled. this
5$ consists of a single q2_exit instruction with:
6
7$ a1: address of 0-th parameter
8$ a2: length of parameter block
9$ a3: address of 0-th local variable
10$ a4: length of local variables block
11$ a5: address of undo instruction
12
13 size xa1(ps), $ a1
14 xa2(ps), $ a2
15 xa3(ps), $ a3
16 xa4(ps), $ a4
17 xa5(ps);
18
19 access q1vars; $ access global q1 variables.
20 access nscod; $ access variables global to cod.
21
22$ if this is the main program, simply emit a 'stop' instruction.
23
24 if a1 = sym_main_ then
25 call em2(q2_stop, 0, 0, 0);
26 return;
27 end if;
28
29$ otherwise emit 'exit' instruction.
30
stra 63 xa1 = blockorg(scl_param) - (blocklen(scl_param)-1);
stra 64 xa2 = blocklen(scl_param);
stra 65 xa3 = blockorg(scl_stacked) - (blocklen(scl_stacked)-1);
stra 66 xa4 = blocklen(scl_stacked);
35 xa5 = undo_addr;
36
37 call em2(q2_exit, xa5, xa1, xa2);
38 call em2(q2_noop, xa3, xa4, 0);
39
40
41 end subr embexit;
1 .=member emok
2 subr emok;
3
4$ this routine emits the code for 'ok'. this constist of a q2_ok
5$ instruction with:
6
7$ a1: address of q2_fail2 instruction
8$ a2: number of saved variables
9
10$ this is followed by a series of q2_noop instructions with:
11
12$ a1: address of saved variable
13
14 size p(ps), $ code pointer
15 addr(ps), $ address
16 j(ps), $ loop index
17 n(ps); $ number of saves variabled
18
19 access q1vars; $ access global q1 variables.
20 access nscod; $ access variables global to cod.
21
22 call em2(q2_ok, fail2_addr, 0, 0);
23
24 n = 0;
25 p = codep;
26
27 do j = 1 to symtabp;
28 if (^ is_back(j)) cont;
29
30 n = n + 1;
31
32 get_addr(addr, j);
33 call em2(q2_noop, addr, 0, 0);
34 end do;
35
36 codea2(p) = n;
37
38
39 end subr emok;
1 .=member emfail
2 subr emfail;
3
4$ this routine emits the code for 'fail'
5
6 call em2(q2_fail1, 0, 0, 0);
7
8 end subr emfail;
1 .=member emsucceed
2 subr emsucceed;
3
4$ this routine emits the code for 'succeed'.
5
6 call em2(q2_succeed, 0, 0, 0);
7
8 end subr emsucceed;
1 .=member emmove
2 subr emmove(opc, cl);
3
4$ this routine emits various move instructions as part of routine
5$ prologues and epilogs. these instructions all have:
6
7$ a1: address of first word of block
8$ a2: length of block
9$ a3: unused(zero)
10$
11$ n.b. symbols are allocated from high-address to low-address. hence
12$ 'blockorg' points to the high-address of the block. we adjust here
13$ so that the first argument of the move instruction points to the
14$ lowest-address word to be moved.
15
16
17 size opc(ps), $ opcode for move
18 cl(ps); $ storage class being moved
19
20 size addr(ps), $ starting address of block
21 len(ps); $ length of block
22
23 access q1vars; $ access global q1 variables.
24 access nscod; $ access variables global to cod.
25
26
27 addr = blockorg(cl) - (blocklen(cl)-1);
28 len = blocklen(cl);
29
30 if (len ^= 0) call em2(opc, addr, len, 0);
31
32
33 end subr emmove;
1 .=member embin
2 subr embin;
3
4$ this routine emits the standard binary operators, namely +, -,
5$ *, /, and mod.
6
7 size opc(ps); $ q2 opcode
smfb 166
smfb 167 size ok_conv(1); $ checks for legal conversions
8
9 access q1vars; $ access global q1 variables.
10 access nscod; $ access variables global to cod.
11
12$ we begin by checking whether we are calling a general library
13$ routine. if so, we will not emit any copy instructions, but will
14$ pass 'cflag' onto the library.
15
16 opc = spec_op(op, fm1);
17$
18$ for sets we require that a1 and a2 have the same repr and that a3
19$ have a similar repr.
20$
21$ note that operations yielding local objects always have the form
22$ 'a := a <*binop> b'. if b is not local we must convert both 'a'
23$ and to set(*), perform the operation and convert the result back.
24$
25 if is_fset(fm1) then
26 if is_floc(fm1) & ^ similar_repr(fm1, fm3) then
27 call set_a2(f_uset, yes); call set_a3(f_uset, yes);
28
29 opc = spec_op(op, f_uset);
30 if (opc = 0) opc = std_op(op);
31
32 call em2(opc, addr_t1, addr_a2, addr_a3);
33
34 form(sym_t1_) = f_uset;
35 call emconv(a1, sym_t1_, fm1, no);
36 form(sym_t1_) = f_gen;
37
suna 37 elseif ok_conv(fm1, fm3) ! op = q1_add then
suna 38 call set_a2(fm1, yes); call set_a3(fm1, yes);
suna 39 if (opc = 0) opc = std_op(op);
suna 40 call em2(opc, addr_a1, addr_a2, addr_a3);
suna 41
suna 42 else
suna 43 call set_a2(f_uset, yes); call set_a3(f_uset, yes);
suna 44 opc = spec_op(op, f_uset);
suna 45 if (opc = 0) opc = std_op(op);
suna 46 call em2(opc, addr_t1, addr_a2, addr_a3);
suna 47 form(sym_t1_) = f_uset;
suna 48 call emconv(a1, sym_t1_, fm1, no);
suna 49 form(sym_t1_) = f_gen;
42 end if;
43
44 elseif opc = 0 then $ general case
45 $ if the first input is a local object which might have to
46 $ be copied, we first convert it to a f_uset.
47 if is_floc(fm2) & cflag(now) ^= copy_no then
48 call set_a2(f_uset, yes);
49 else
50 call typea2; $ make sure the input is typed
51 end if;
52
53 call typea3;
54
55 call em2(std_op(op), addr_a1, addr_a2, addr_a3);
56 call sa4(cflag(now));
57
58 else $ special case. emit conversions and copies.
59 $ special case 'i +:= 1' on short and untyped ints
60 if opc = q2_addi & a1 = a2 & a3 = sym_one then
61 opc = q2_inci; addr_a2 = 0; addr_a3 = 0;
62 elseif opc = q2_addui & a1 = a2 & a3 = sym_one then
63 opc = q2_incui; addr_a2 = 0; addr_a3 = 0;
64 else
65 if (opc = q2_addstr) cflag(now) = copy_yes;
66 call set_a2(fm1, no); call set_a3(fm1, no);
67 end if;
68
69 call em2(opc, addr_a1, addr_a2, addr_a3);
70 end if;
71
72
73 end subr embin;
1 .=member emwith
2 subr emwith;
3
4$ this routine emits code for the setl 'with' and 'less' operators.
5$ there are two possibilities:
6
7$ 1. we are doing a simple case, such as the statement 's with x'.
8$ in this case a1 = a2.
9
10$ 2. we are doing one of the more complex cases, i.e. 's1 := s with x'
11$ or 'f(x) with y'. in both these cases the a1 is an internal
12$ variable with type general.
13
14$ n.b. we call 'set_a3' before 'set_a2' in order to assure proper
15$ share bit setting at run time.
16
17
18 size opc(ps); $ q2 opcode
19 size fm(ps); $ dereferenced form of a2
smfb 174
smfb 175 size ok_conv(1); $ checks for legal conversions
20
21 access q1vars; $ access global q1 variables.
22 access nscod; $ access variables global to cod.
23
24
25 if is_pre(op) then
26 fm = deref_typ(fm1);
27
28 elseif is_floc(fm2) & a1 ^= a2 then
29 fm = f_uset;
30 else
31 fm = deref_typ(fm2);
32 end if;
36
37 opc = spec_op(op, fm);
smfb 176
smfb 177 if is_pre(op) ! ok_conv(elmt_type(fm), fm3) then
smfb 178 call set_a3(elmt_type(fm), no);
smfb 179 else
smfb 180 opc = 0;
smfb 181 end if;
smfb 182
smfb 183 call set_a2(fm, yes);
38
39 if opc = 0 ! (op = q1_with & ft_type(fm) = f_mtuple) then
40 opc = std_op(op);
41 end if;
42
43 if can_assign(fm1, fm) then
44 call em2(opc, addr_a1, addr_a2, addr_a3);
45
46 else
47 form(sym_t1_) = fm;
48 call em2(opc, addr_t1, addr_a2, addr_a3);
49 call emconv(a1, sym_t1_, fm1, no);
50 form(sym_t1_) = f_gen;
51 end if;
52
53
54 end subr emwith;
1 .=member emfrom
2 subr emfrom;
3
4$ this routine emits code for 'a1 from a2'. if does not have
5$ the same type as the elements of a2 then we emit
6$ 't1_ from a2; a1 = t1_' and convert on the assignment.
7
8
9 size opc(ps); $ q2 opcode
10 size fm(ps); $ element form of a2
11
12 access q1vars; $ access global q1 variables.
13 access nscod; $ access variables global to cod.
14
15
16 fm = elmt_type(fm2);
17
18 opc = spec_op(op, fm2);
19
20 if opc ^= 0 then
21 if cflag(now) = copy_yes then
22 call em2(q2_copy, addr_a2, addr_a2, 0);
23 elseif cflag(now) = copy_test then
24 call em2(q2_ccopy, addr_a2, addr_a2, 0);
25 end if;
26
27 else
28 opc = std_op(op);
29 end if;
30
31 if can_assign(fm1, fm) then
32 call em2(opc, addr_a1, addr_a2, 0);
33
34 else
35 form(sym_t1_) = fm;
36 call em2(opc, addr_t1, addr_a2, 0);
37 call emconv(a1, sym_t1_, fm1, no);
38 form(sym_t1_) = f_gen;
39 end if;
40
41
42 end subr emfrom;
1 .=member emlessf
2 subr emlessf;
3
4$ this routine emits code for 'lessf'. like 'with' and 'less'
5$ either a1 = a2 or a1 is an internal variable with type general.
6
7
8 size opc(ps); $ q2 opcode
9 size fm(ps); $ dereferenced form of a2
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14
15 fm = deref_typ(fm2);
16 if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
17
18 call set_a2( fm, yes);
19 call set_a3(dom_type(fm), no );
20
21 opc = spec_op(op, fm);
22 if (opc = 0) opc = std_op(op);
23$$-- disable for the sake of generated code
24 if (is_fplex(fm)) opc = std_op(op);
25$$-- end disabled section
26
27 if can_assign(fm1, fm) then
28 call em2(opc, addr_a1, addr_a2, addr_a3);
29
30 else
31 form(sym_t1_) = fm;
32 call em2(opc, addr_t1, addr_a2, addr_a3);
33 call emconv(a1, sym_t1_, fm1, no);
34 form(sym_t1_) = f_gen;
35 end if;
36
37
38 end subr emlessf;
1 .=member emnelt
2 subr emnelt;
3
4$ this routine emits a1 := ? a2. we look for the special case where
5$ the nelt of a set or tuple is being maintained.
6
7 size opc(ps); $ q2 opcode
8
9 access q1vars; $ access global q1 variables.
10 access nscod; $ access variables global to cod.
11
12
13 opc = spec_op(q1_nelt, fm2);
14
15 if opc = 0 then $ general case
16 opc = q2_nelt;
17
18 elseif opc = q2_neltst then $ set or tuple
19 if (ft_neltok(fm2)) opc = q2_neltok;
20 end if;
21
22 call em2(opc, addr_a1, addr_a2, 0);
23
24
25 end subr emnelt;
1 .=member emnewat
2 subr emnewat;
3
4$ this routine processes 'a1 := newat;'. we catch the case where
5$ a1 is an element of a plex base.
6
7 size bform(ps), $ form of base
8 baddr(ps); $ address of base
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
14 if ft_type(fm1) = f_elmt then
15 bform = ft_base(fm1);
16 baddr = ft_samp(bform);
17
18 if ft_type(bform) = f_pbase then
19 call em2(q2_newat2, addr_a1, baddr, 0);
20
21 elseif ft_elmt(bform) = f_atom ! ft_elmt(bform) = f_gen then
22 call em2(q2_newat1, addr_t1, 0, 0);
23 call em2(q2_locate, addr_a1, addr_t1, baddr);
24
25 else $ no other type is possible
26 call ermsg(2, 0);
27 end if;
28
29 elseif ft_type(fm1) = f_atom ! fm1 = f_gen then
30 call em2(q2_newat1, addr_a1, 0, 0);
31
32 else $ illegal type for a1
33 call ermsg(2, 0);
34 end if;
35
36
37 end subr emnewat;
1 .=member emof
2 subr emof;
3
4$ this routine processes 'a1 := a2(a3)'.
5
6
7 size opc(ps); $ q2 opcode
8 size opc1(ps); $ q2 opcode
9 size fm(ps); $ dereferenced form of a2
smfb 184 size f3(ps); $ dereferenced form of a3
10
11 size ok_conv(1); $ checks for legal conversions
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16
17 fm = deref_typ(fm2);
18 if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
19
20 if is_fmap(fm) then
21 opc = of_op(q1_of, ft_type(fm), ft_mapc(fm));
22 else
23 opc = spec_op(q1_of, fm);
24 end if;
25
26 if (opc = 0) opc = q2_of;
27
28 $ select special opcode to set share bit
29 if sflag(now) & ^ is_fprim(compn_typ(fm, a3)) then
30 opc1 = share_op(opc);
31 if (opc1 ^= 0) opc = opc1;
32 end if;
33
34 call set_a2( fm, yes);
35
36 if ok_conv(dom_type(fm), fm3) then
smfb 185 if opc = q2_oft ! opc = q2_ofts then
smfb 186 f3 = ft_deref(fm3);
smfb 187 if ft_type(f3) = f_sint then
smfb 188 if ft_lim(f3) ^= 0 & ft_lim(f3) <= ft_lim(fm) then
smfb 189 if opc = q2_oft then
smfb 190 opc = q2_oftok;
smfb 191 else
smfb 192 opc = q2_oftoks;
smfb 193 end if;
smfb 194 elseif is_const(a3) then
smfb 195 if symval(a3) <= ft_lim(fm) then
smfb 196 if opc = q2_oft then
smfb 197 opc = q2_oftok;
smfb 198 else
smfb 199 opc = q2_oftoks;
smfb 200 end if;
smfb 201 end if;
smfb 202 end if;
smfb 203 end if;
smfb 204 call set_a3(f_int, no);
smfb 205 else
smfb 206 call set_a3(dom_type(fm), no);
smfb 207 end if;
38 else
39 opc = q2_of;
40 end if;
41
42 call em2(opc, addr_a1, addr_a2, addr_a3);
43
44
45 end subr emof;
1 .=member emofa
2 subr emofa;
3
4$ this routine emits 'a1 := a2<>'.
5
6
7 size opc(ps); $ q2 opcode
8 size opc1(ps); $ q2 opcode
9 size fm(ps); $ dereferenced form of a2
10
11 size ok_conv(1); $ checks for legal conversions
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16
17 fm = deref_typ(fm2);
18 if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
19
20 if is_fmap(fm) then
21 opc = of_op(q1_ofa, ft_type(fm), ft_mapc(fm));
22 else
23 opc = spec_op(q1_ofa, fm);
24 end if;
25
26 if (opc = 0) opc = q2_ofa;
27
28 $ select special opcode to set share bit
29 if sflag(now) then
30 opc1 = share_op(opc);
31 if (opc1 ^= 0) opc = opc1;
32 end if;
33
34 call set_a2( fm, yes);
35
36 if ok_conv(dom_type(fm), fm3) then
37 call set_a3(dom_type(fm), no);
38 else
39 opc = q2_ofa;
40 end if;
41
42 call em2(opc, addr_a1, addr_a2, addr_a3);
43
44
45 end subr emofa;
1 .=member emsof
2 subr emsof;
3
4$ this routine emits a1(a2) := a3. we begin by converting a2 and a3
5$ to the desired type, then select the proper opcode. if we are
6$ are emitting in-line code then we must also emit an inline copy.
7$ otherwise we allow the libraries 'sof' routine to perform the
8$ copy.
9
10
11 size opc(ps); $ q2 opcode
12 size fm(ps); $ dereferenced form of a1
smfb 208 size f2(ps); $ dereferenced form of a2
13
14 access q1vars; $ access global q1 variables.
15 access nscod; $ access variables global to cod.
16
17
18 fm = deref_typ(fm1);
19 if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
20
21 if is_fmap(fm) then
22 opc = of_op(q1_sof, ft_type(fm), ft_mapc(fm));
23 else
24 opc = spec_op(q1_sof, fm);
25 end if;
26
29 if is_funt(compn_typ(fm, a2)) & ^ is_floc(fm) then
30 $ until we fix this in the interpreter so that we can
31 $ do it inline
32 call typea3; opc = q2_sof;
33 else
34 call set_a3(compn_typ(fm, a2), no);
35 end if;
36
37 if opc = 0 then
38 opc = q2_sof;
39 elseif ft_type(fm) = f_mtuple then
smfb 209 if is_const(a2) & ft_type(ft_deref(fm2)) = f_sint then
41 if (symval(a2) > ft_lim(fm)) call ermsg(21, a1);
42 else
43 opc = q2_sof;
44 end if;
45 end if;
smfb 210
smfb 211 if opc = q2_soft then
smfb 212$$-- must update nelt correctly - since this is not done at the moment
smfb 213$$-- we cannot emit the q2_softok.
smfb 214$$-- f2 = ft_deref(fm2);
smfb 215$$-- if ft_type(f2) = f_sint then
smfb 216$$-- if ft_lim(f2) ^= 0 & ft_lim(f2) <= ft_lim(fm) then
smfb 217$$-- opc = q2_softok;
smfb 218$$-- elseif is_const(a2) then
smfb 219$$-- if (symval(a2) <= ft_lim(fm)) opc = q2_softok;
smfb 220$$-- end if;
smfb 221$$-- end if;
smfb 222 call set_a2(f_int, no);
smfb 223 else
smfb 224 call set_a2(dom_type(fm), no);
smfb 225 end if;
46
47 if can_assign(fm1, fm) then
48 call set_a1;
49 call em2(opc, addr_a1, addr_a2, addr_a3);
50
51 else
52 form(sym_t1_) = fm;
53 call emconv(sym_t1_, a1, fm, cflag(now));
54
55 call em2(opc, addr_t1, addr_a2, addr_a3);
56
57 call emconv(a1, sym_t1_, fm1, no);
58 form(sym_t1_) = f_gen;
59 end if;
60
61
62 end subr emsof;
1 .=member emsofa
2 subr emsofa;
3
4$ this routine emits 'a1<> := a3'.
5
6
7 size opc(ps); $ q2 opcode
8 size fm(ps); $ dereferenced form of a1
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
14 fm = deref_typ(fm1);
15 if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
16
17 if is_fmap(fm) then
18 opc = of_op(q1_sofa, ft_type(fm), ft_mapc(fm));
19 else
20 opc = spec_op(q1_sofa, fm);
21 end if;
22
23 if (opc = 0) opc = q2_sofa;
24
25 call set_a2( dom_type(fm), no);
26 call set_a3(rset_type(fm), no);
27
28 if can_assign(fm1, fm) then
29 call set_a1;
30 call em2(opc, addr_a1, addr_a2, addr_a3);
31
32 else
33 form(sym_t1_) = fm;
34 call emconv(sym_t1_, a1, fm, cflag(now));
35
36 call em2(opc, addr_t1, addr_a2, addr_a3);
37
38 call emconv(a1, sym_t1_, fm1, no);
39 form(sym_t1_) = f_gen;
40 end if;
41
42
43 end subr emsofa;
1 .=member emst
2 subr emst;
3
4$ this routine processes enumerative set and tuple formers.
5$ there are two opcodes for sets and two for tuples
6
7$ q2_set1: output is type general; decide at run time whether
8$ to build set or map.
9$ q2_set2: all elements are proper type
10
11$ q2_tup1: all elements are proper type
12$ q2_tup2: mixed tuple, elements require conversion
13
14$ note that q2_tup2 is only used for iterative tuple formers
15$ where the result is a mixed tuple.
16
17$ these instructions all have:
18
19$ arg1: pointer to result
20$ arg2: form of result
21$ arg3: pointer to short integer giving number of elements
22
23
24 size j(ps), $ loop index
25 n(ps); $ number of elements
26
27 size elmt(ps); $ set/tuple element
28
29 size st_form(ps), $ form of set/tuple
30 elmt_form(ps); $ form of set/tuple element
31
32 size opc(ps), $ q2 opcode
33 count_addr(ps); $ address of counter
34
35 size genint(ps); $ allocates integer
36
37 access q1vars; $ access global q1 variables.
38 access nscod; $ access variables global to cod.
39
40
41 $ get the form of the set/tuple
42 st_form = deref_typ(fm1);
43
44 $ generate code to push the set/tuple components
45 n = nargs(now);
46 do j = 2 to n;
47 elmt = argn(now, j);
48
49 if ft_type(st_form) = f_mtuple then
50 elmt_form = mttab(ft_elmt(st_form)-1+j);
51 else
52 elmt_form = ft_elmt(st_form);
53 end if;
54
55 call empush(elmt, elmt_form);
56 end do;
57
58 $ allocate a constant for the number of elements
59 count_addr = genint(n-1);
60
61 $ select proper opcode
62 if op = q1_set then
63 if st_form = f_gen then
64 opc = q2_set1; st_form = f_uset;
65 else
66 opc = q2_set2;
67 end if;
68
69 else
70 if (st_form = f_gen) st_form = f_tuple;
71 opc = q2_tup1;
72 end if;
73
74 $ see whether a conversion is necessary
75 if can_assign(fm1, st_form) then
76 call em2( opc, addr_a1, st_form, count_addr);
77 else
78 call em2( opc, addr_t1, st_form, count_addr);
79
80 form(sym_t1_) = st_form;
81 call emconv(a1, sym_t1_, fm1, no);
82 form(sym_t1_) = f_gen;
83 end if;
84
85
86 end subr emst;
1 .=member emst1
2 subr emst1;
3
4$ this routine processes iterative set and tuple formers.
5$ it is similar to emst, above.
6
7 size fm(ps), $ result type
8 opc(ps); $ q2 opcode
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
14 fm = fm1;
15
16 if op = q1_set1 then
17 if fm = f_gen then
18 fm = f_uset;
19 opc = q2_set1;
20 else
21 opc = q2_set2;
22 end if;
23
24 else
25 if fm = f_gen then
26 fm = f_tuple;
27 opc = q2_tup1;
28 elseif ft_type(fm) = f_mtuple then
29 opc = q2_tup2;
30 else
31 opc = q2_tup1;
32 end if;
33 end if;
34
35 call em2(opc, addr_a1, fm, addr_a3);
36
37
38 end subr emst1;
1 .=member emst2
2 subr emst2;
3$
4$ this routine processes the domain and range operations.
5$ it is simillar to emst1, above.
6$
7 size fm(ps); $ result set mode
8
9 access q1vars; $ access global q1 variables.
10 access nscod; $ access variables global to cod.
11
12
13 fm = fm1;
14
smfb 226 if (fm = f_gen) fm = f_uset; if (^is_fset(fm)) call ermsg(22, a1);
17
18 call em2(std_op(op), addr_a1, addr_a2, fm);
19
20
21 end subr emst2;
1 .=member emargin
2 subr emargin;
3
4$ this routine emits argin assignments. we convert the argument to
5$ the proper type if necessary.
6
7$ we handle two special cases for build in procedures:
8
9$ 1. if the second argument of a string primitive is a constant
10$ we build a pattern set and pass the set instead.
11
12$ 2. if the formal parameter type of a built in procedure is
13$ type general and the argument type is anything other than
14$ untyped integer or untyped real, we pass it without
15$ conversion.
16
17
18 size fm(ps), $ desired type
19 j(ps); $ loop index
20
21 size mrouts(ps); $ gives names of pattern matching routines
22 dims mrouts(8);
23
24 data mrouts = sym_span, sym_break, sym_any, sym_notany,
25 sym_rspan, sym_rbreak, sym_rany, sym_rnotany;
26
27 size bldpset(ps); $ builds a pattern set and returns its address
28
29 access q1vars; $ access global q1 variables.
30 access nscod; $ access variables global to cod.
31
32
33$ decide whether to build a pset
34 if (^ is_const(a1)) go to not_pset;
35 if (a3 ^= sym_two) go to not_pset;
36
37 do j = 1 to 8;
38 if (a2 = mrouts(j)) go to pset;
39 end do;
40
41 go to not_pset;
42
43
44 /pset/ $ push pset
45
46 call em2(q2_push1, bldpset(a1), 0, 0);
47 return;
48
49
50 /not_pset/ $ convert if necessary then push
51
52 fm = arg_type(a2, symval(a3));
53
54 if is_bip(a2) & fm = f_gen & ^ is_funt(fm1) then
55 if (is_fplex(deref_typ(fm1))) call ermsg(11, a1);
56 call em2(q2_push1, addr_a1, 0, 0);
57
58 else
59 call empush(a1, fm);
60 end if;
61
62 return;
63
64 end subr emargin;
1 .=member emargout
2 subr emargout;
3
4$ this routine emits argout assignments.
5
6 size fm(ps), $ form of parameter
7 back(1); $ on if push must be backtracked
8
9 access q1vars; $ access global q1 variables.
10 access nscod; $ access variables global to cod.
11
12
13 fm = arg_type(a2, symval(a3));
14
15 back = (back_flag & ^ is_bip(a2));
16
17 call empop(a1, fm, back);
18
19
20 end subr emargout;
1 .=member empush
2 subr empush(arg, fm);
3
4$ this routine emits code to convert 'arg' to type 'fm' and push
5$ it on the stack.
6
7 size arg(ps), $ item to be pushed
8 fm(ps); $ desired form
9
10 size xfm(ps), $ original form
11 addr(ps); $ address
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16
17 xfm = form(arg);
18 get_addr(addr, arg);
19
20 if can_assign(fm, xfm) then
21 if is_funt(fm) then $ untyped
22 call em2(q2_push1u, addr, 0, 0);
23 else
24 call em2(q2_push1, addr, 0, 0);
25 end if;
26
27 else $ convert argument
28 call emconv(sym_t1_, arg, fm, no);
29
30 if is_funt(fm) then $ untyped
31 call em2(q2_push1u, addr_t1, 0, 0);
32 else
33 call em2(q2_push1, addr_t1, 0, 0);
34 end if;
35 end if;
36
37
38 end subr empush;
1 .=member empop
2 subr empop(arg, fm, back);
3
4$ this routine emits code to pop 'arg' from the stack. 'fm' is
5$ the type of the stack entry.
6
7$ note that if the stack entry is an untyped integer or real we assumr
8$ that it is preceeded by a skip word which must be popped first.
9
10 size arg(ps), $ variable to be popped
11 fm(ps), $ form of stack entry
12 back(1); $ on if pop must be backtracked
13
14 size xfm(ps), $ form of arg
15 addr(ps); $ address of arg
16
17 access q1vars; $ access global q1 variables.
18 access nscod; $ access variables global to cod.
19
20
21 xfm = form(arg);
22 get_addr(addr, arg);
23
24 if can_assign(xfm, fm) then
25 if back then
26 if (is_funt(fm)) call em2(q2_bfree, address(sym_one),0,0);
27 call em2(q2_bpop1, addr, 0, 0);
28 else
29 if (is_funt(fm)) call em2(q2_free, address(sym_one),0,0);
30 call em2(q2_pop1, addr, 0, 0);
31 end if;
32
33 else $ pop value into t1_ then convert
34
35 if back then
36 if (is_funt(fm)) call em2(q2_bfree, address(sym_one),0,0);
37 call em2(q2_bpop1, addr_t1, 0, 0);
38
39 else
40 if (is_funt(fm)) call em2(q2_free, address(sym_one),0,0);
41 call em2(q2_pop1, addr_t1, 0, 0);
42 end if;
43
44 form(sym_t1_) = fm; $ pretend for now
45
46 call emconv(arg, sym_t1_, xfm, no);
47
48 form(sym_t1_) = f_gen; $ reset
49 end if;
50
51
52 end subr empop;
1 .=member emsubst
2 subr emsubst;
3
4 access q1vars; $ access global q1 variables.
5 access nscod; $ access variables global to cod.
6
7
8 call typea2;
9 call typea3;
10
11 if op = q1_end then
12 call em2(q2_end, addr_a1, addr_a2, addr_a3);
13
14 else $ q1_subst
15 call em2(q2_subst, addr_a1, addr_a2, addr_a3);
16
17 a4 = arg4(now);
18 get_addr(addr_a4, a4);
19
20 if (is_funt(form(a4))) call emconv(a4, a4, f_int, no);
21
22 call em2(q2_noop, addr_a4, 0, 0);
23 end if;
24
25
26 end subr emsubst;
1 .=member emssubst
2 subr emssubst;
3
4$ this routine emits 'a1(a2...a3) := a4' and 'a1(a2...) := a3'.
5
6
7 size fm(ps); $ dereferenced form of a1
8 size need_conv(1); $ conversion of result is needed
9 size result(ps); $ alias for a1
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14
15 fm = deref_typ(fm1);
16 if (ft_type(fm) = f_mtuple) fm = f_tuple;
17 need_conv = ^ can_assign(fm1, fm);
18
19 if need_conv then
20 form(sym_t1_) = fm; call emconv(sym_t1_, a1, fm, no);
21
22 result = addr_t1;
23 else
24 result = addr_a1;
25 end if;
26
27
28 call typea2;
29
30 if op = q1_send then
31 call set_a3(fm, no);
32 call em2( q2_send, result, addr_a2, addr_a3);
33
34 else $ q1_ssubst
35 call typea3;
36
37 a4 = arg4(now);
38 get_addr(addr_a4, a4);
39 call set_a4(fm, no);
40
41 call em2( q2_ssubst, result, addr_a2, addr_a3);
42 call em2( q2_noop, addr_a4, 0, 0);
43 end if;
44
45 if need_conv then
46 call emconv(a1, sym_t1_, fm1, no); form(sym_t1_) = f_gen;
47 end if;
48
49
50 end subr emssubst;
1 .=member emasn
2 subr emasn;
3
4
5$ this routine processes simple assignments. assignments fall
6$ into three categories
7
8$ 1. a1 := om. there are two subcases:
9
10$ a. a1 is a local set or map. here we emit two instructions.
11$ the first sets a1 to its sample value, and the second
12$ nulls out the appropriate base fields.
13
14$ b. otherwise we simple set a1 to its sample value.
15
16$ 2. a1 = a2, where a1 and a2 have compatible types. here we
17$ must check whether copying is necessary.
18
19$ 3. a1 = a2 where a1 and a2 have incompatible types. this case
20$ is processed by emconv.
21
22
23 size fm(ps), $ form of null set or tuple
24 opc(ps); $ q2 opcode
25
26 access q1vars; $ access global q1 variables.
27 access nscod; $ access variables global to cod.
28
29
30 if a2 = sym_om then
31 call em2(q2_asn, addr_a1, ft_samp(fm1), 0);
32 if (is_floc(fm1)) call em2(q2_asnnl, addr_a1, fm1, 0);
33
34 elseif can_assign(fm1, fm2) then
35
36$ emit code based on copy flags
37 go to case(cflag(now)) in copy_min to copy_max;
38
39 /case(copy_no)/
40
41 if sflag(now) then
42 opc = q2_asnsb;
43 else
44 opc = q2_asn;
45 end if;
46
47 go to esac;
48
49 /case(copy_yes)/
50
51 opc = q2_copy;
52 go to esac;
53
54 /case(copy_test)/
55
56 opc = q2_ccopy;
57 go to esac;
58
59
60 /esac/
61
62 call em2(opc, addr_a1, addr_a2, 0);
63
64 else $ conversion
smfb 227 call emconv(a1, a2, fm1, cflag(now));
66 end if;
67
69
70 end subr emasn;
1 .=member emconv
2 subr emconv(output, input, oform, copy);
3
4$ this routine emits all conversions. its arguments are
5
6$ output symtab pointer to result of conversion
7$ input symtab pointer to input of conversion
8$ oform formtab pointer for result type
9$ copy copy option, see below.
10
11$ 'output' has type general or type ofrom.
12
13$ 'input' has type general or a type different from oform.
14
15$ if 'input' has type general then we will emit a test to see
16$ whether a conversion is really necessary. if the conversion
17$ proves unnecessary, we have two options:
18
19$ 1. set input's share bit and assign it to output.
20
21$ 2. copy input and assign the copy to output.
22
23$ the argument 'copy' is true if we desire option (2).
24
25
26 size output(ps); $ symtab pointer for output
27 size input(ps); $ symtab pointer for input
28 size oform(ps); $ desired mode for output
29 size copy(2); $ desired copy action
30
31 size iform(ps); $ mode of input
32 size otyp(ps); $ ft_type of output
33 size ityp(ps); $ ft_type of input
34 size oaddr(ps); $ address of output
35 size iaddr(ps); $ address of input
36
37 size n(ps); $ number of dereferences
38 size f(ps); $ dereferenced form
39 size bform(ps); $ form of base
40 size baddr(ps); $ address of base
41 size opc(ps); $ q2 opcode
42 size min(ps); $ lower bound of value
43 size max(ps); $ upper bound of value
44 size laddr(ps); $ address of label for skip instructions
smfb 228 size spec(hs); $ specifier for form table repr string
smfb 229 size tstart(ps); $ local copy of stack pointer
smfb 230 size hstart(ps); $ local copy of heap pointer
45
46 size convcon(ps); $ converts constant
smfd 34 size can_conv(1); $ checks for legal conversions
48 size genint(ps); $ generates integer constant
smfb 231 size format_form(hs); $ formats formtab entry into repr string
smfb 232
smfb 233 size retpt(ps); $ return address for local subroutine
49
50 access q1vars; $ access global q1 variables.
51 access nscod; $ access variables global to cod.
smfb 234
smfb 235 .=zzyorg a $ counter for return labels of local subr
52
53
54$ we begin by getting information about the input and
55$ the output.
56 iform = form(input);
57
58 otyp = ft_type(oform);
59 ityp = ft_type(iform);
60
61 get_addr(oaddr, output);
62 get_addr(iaddr, input);
63
64$ if 'input' is a constant, we will usually build an extra copy of it
65$ with type 'oform' rather than doing a run time conversion. note that
66$ conversions to local set or map must be done at run time since they
67$ involve changing output's base fields.
68
69$ if 'input' is the null set(tuple) we emit a special q2 instruction
70$ which builds a null set(tuple) with type oform.
71
72 if input = sym_om then $ assign proper omega
73 call em2(q2_asn, oaddr, ft_samp(oform), 0);
74 return;
75
76 elseif input = sym_nullset then $ generate proper << >>
77
78 if is_fset(oform) then
79 call em2(q2_asnnl, oaddr, oform, 0);
80 return;
81
82 elseif oform = f_gen then
83 call em2(q2_asnnl, oaddr, f_uset, 0);
84 return;
85
86 end if;
87
88 elseif input = sym_nulltup then $ generate proper (/ /)
89
90 if is_ftup(oform) then
91 call em2(q2_asnnult, oaddr, oform, 0);
92 return;
93
94 elseif oform = f_gen then
95 call em2(q2_asnnult, oaddr, f_tuple, 0);
96 return;
97
98 end if;
99
100 elseif is_const(input) & ^ is_floc(oform) then
101 input = convcon(input, oform);
102 get_addr(iaddr, input);
103
104 if copy ^= copy_no & ^ is_fprim(oform) then
105 call em2(q2_copy, oaddr, iaddr, 0);
106 else
107 call em2(q2_asn, oaddr, iaddr, 0);
108 end if;
109
110 return;
111 end if;
112
113
114$ see if we can dereference iform to get the type of oform.
115
116 n = 0; $ no. of derefs
117 f = iform;
118
119 while ft_type(f) = f_elmt & f ^= oform;
120 if (ft_type(ft_base(f)) = f_pbase) quit while;
121 f = ft_elmt(ft_base(f));
122 n = n+1;
123 end while;
124
125 if oform = f ! (otyp ^= f_elmt & n > 0) then
126 $ emit proper dereference operation
127 if n = 1 then opc = q2_deref1; else opc = q2_deref; end if;
128
129 call em2(opc, oaddr, iaddr, n);
130
131 if copy ^= copy_no then
132 if copy = copy_yes then
133 opc = q2_copy;
134 else
135 opc = q2_ccopy;
136 end if;
137
138 call em2(opc, oaddr, oaddr, 0);
139 end if;
140
141 if (oform = f) return;
142
143 iform = f;
144 ityp = ft_type(iform);
145 iaddr = oaddr;
146 end if;
147
148$ otherwise jump on otyp
149
150 go to case(otyp) in f_min to f_max;
151
152/case(f_gen)/ $ general
153
154$ most cases of 'general := declared' can be treated as simple
155$ assignments. these trivial cases are always handled before calling
156$ emconv.
157
158$ 'general := untyped int' is treated as 'int := untyped int'
159 if (ityp = f_uint) go to case(f_int);
160
161$ 'general := untyped real' is treated as 'real := untyped real'
162 if (ityp = f_ureal) go to case(f_real);
163
164
165$ suppose we have 'general := set(real)'. once the set of reals
166$ has been assigned to an undeclared variable, we can perform any
167$ set operation on it, for example 'general with 1'. therefore we
168$ have no way of knowing whether it will remain a set of reals;
169$ all we can say is that it remains a set.
170
171$ this means that we must treat 'general := set(mode)' as a
172$ conversion to set(general). we must perform similar conversions
173$ for maps and tuples.
174
175 if is_ftup(iform) then
176 f = f_tuple;
177
178 elseif is_fmap(iform) then
179 f = f_umap;
180
181 else
182 f = f_uset;
183 end if;
184
185 call em2(q2_convert, oaddr, iaddr, f);
186
187 return;
188
189/case(f_sint)/ $ integer
190
191$ there are four legal conversions here:
192
193$ 1. input is an untyped integer
194$ 2. input is a 'long integer'. this really means union(long, short).
195$ 3. input is type general
196$ 4. input is a short integer with a different range.
197
198 if ityp = f_uint then
199 call em2(q2_tint1, oaddr, iaddr, 0);
200
smfb 236 elseif ityp = f_int then
smfb 237 min = ft_low(oform);
smfb 238 max = ft_lim(oform); if (max = 0) max = maxsi;
smfb 239 call em2(q2_asn, oaddr, iaddr, 0 );
smfb 240 call em2(q2_checki1, oaddr, genint(min), genint(max));
smfb 241 return;
smfb 242
smfb 243 elseif ityp = f_gen then
202 call em2(q2_checktp, oaddr, iaddr, oform);
203
204 elseif ityp = f_sint then
205 call em2(q2_asn, oaddr, iaddr, 0);
206 if ft_low(oform) <= ft_low(iform) then
207 max = ft_lim(oform); if (max = 0) max = maxsi;
208 if (max >= ft_lim(iform) & ft_lim(iform) > 0) return;
209 end if;
210
211 else
212 call ermsg(7, 0);
213 return;
214 end if;
215
216 if (can_assign(oform, iform)) return;
217 min = ft_low(oform);
218 max = ft_lim(oform); if (max = 0) max = maxsi;
219 if (min = 0 & max = maxsi) return;
220 call em2(q2_checki1, oaddr, genint(min), genint(max));
221
222 return;
223
224/case(f_sstring)/
225
stra 67 $ need to insert code to handle f_sstring := f_string.
stra 68 $ currently handled by patch code in q2_checktp.
226 if ityp = f_gen then
227 call em2(q2_checktp, oaddr, iaddr, oform);
228 else
229 call ermsg(24, 0);
230 end if;
231
232 return;
233
234
235/case(f_atom)/
236
237 if ityp = f_elmt then
238 call em2(q2_asn, oaddr, iaddr, 0);
239 elseif ityp = f_gen then
240 call em2(q2_chkatom, oaddr, iaddr, 0);
241 else
242 call ermsg(25, 0);
243 end if;
244
245 return;
246
247
248/case(f_latom)/ $ long atom
249
250 $ should never reach here - f_latom are elements of plex bases,
251 $ but they will always end up in the f_elmt case, below.
252 call abort('compiler error - f_latom in emconv');
253
254
255/case(f_int)/ $ integer
256
257 if ityp = f_sint then
258 call em2(q2_asn, oaddr, iaddr, 0);
259
260 elseif ityp = f_gen then
261 call em2(q2_checki2, iaddr, 0, 0);
262 call em2(q2_asn, oaddr, iaddr, 0);
263
264 elseif ityp = f_uint then
265 call em2(q2_tint2, oaddr, iaddr, 0);
266
267 else
268 call ermsg(7, 0);
269 end if;
270
271 return;
272
273
274/case(f_elmt)/ $ element
275
276$ see if 'input' is already the proper element type; if so
277$ emit a locate.
278
279 bform = ft_base(oform); $ get form and address of base
280 baddr = ft_samp(bform);
281
282 if ft_type(bform) = f_pbase then
283 if iform = f_gen ! ityp = f_atom then
284 call em2(q2_eqform4, oaddr, iaddr, bform);
285 else
286 call ermsg(11, 0);
287 end if;
288 return;
289 elseif ft_elmt(bform) = iform then
290 call em2(q2_locate, oaddr, iaddr, baddr);
291 return;
292 end if;
293
294 go to full;
295
296
297/case(f_uint)/
298
299$ there are three legal conversions:
300
301$ 1. input is a short int
302$ 2. input is a long int
303$ 3. input is general
304 if ityp = f_sint then
305 call em2(q2_uint1, oaddr, iaddr, 0);
306
307 elseif ityp = f_int .or. ityp = f_gen then
308 call em2(q2_uint2, oaddr, iaddr, 0);
309
310 else
311 call ermsg(7, 0);
312 end if;
313
314 return;
315
316
317/case(f_ureal)/
318
319$ there are two legal conversions:
320
321$ 1. input is real
322$ 2. input is general
323 if ityp = f_real then
324 call em2(q2_ureal1, oaddr, iaddr, 0);
325
326 elseif ityp = f_gen then
327 call em2(q2_ureal2, oaddr, iaddr, 0);
328
329 else
330 call ermsg(8, 0);
331 end if;
332
333 return;
334
335
336/case(f_string)/
337
stra 69 if ityp = f_sstring then
stra 70 call em2(q2_asn, oaddr, iaddr, 0);
stra 71
stra 72 elseif ityp = f_gen then
stra 73 $ need to introduce new opcode to check if a1 is string.
stra 74 $ currently handled by patch code in q2_checktp.
339 call em2(q2_checktp, oaddr, iaddr, f_string);
340 else
341 call ermsg(1, 0);
342 end if;
343
344 return;
345
346
347/case(f_real)/ $ reals
348
349$ there are two legal conversions:
350
351$ 1. input is an untyped real
352$ 2. input is general
353
354 if ityp = f_ureal then
355 call em2(q2_treal, oaddr, iaddr, 0);
356
357 elseif ityp = f_gen then
358 call em2(q2_checktp, oaddr, iaddr, f_real);
359
360 else
361 call ermsg(8, 0);
362 end if;
363
364 return;
365
366
367/case(f_error)/ $ error
368
369$ the only valid conversion here is 'error := general', which is
370$ merely a type check.
371
372 if ityp = f_gen then
373 call em2(q2_checktp, oaddr, iaddr, f_error);
374
375 else
376 call ermsg(8, 0);
377 end if;
378
379 return;
380
381
382/case(f_tuple)/ $ tuples
383
384/case(f_ptuple)/
385
386/case(f_ituple)/
387
388/case(f_rtuple)/
389
390/case(f_mtuple)/
391
392
393/case(f_uset)/
394
395/case(f_umap)/
396
397/case(f_lset)/
398
399/case(f_rset)/
400
401/case(f_lmap)/
402
403/case(f_rmap)/
404
405/case(f_lpmap)/
406
407/case(f_limap)/
408
409/case(f_lrmap)/
410
411/case(f_rpmap)/
412
413/case(f_rimap)/
414
415/case(f_rrmap)/
416
417
418 go to full;
419
420
421/full/ $ full conversion
422
423$ check that conversion is legal.
smfd 35 if ^ can_conv(oform, iform) then
425 call ermsg(3, 0);
426
427 if et_flag then $ print trace information
428 put, skip, 'forms are: ': oform, i, x(1): iform, i, skip;
429 call sdump;
430 end if;
431
432 return;
433 end if;
434
435
436 if ityp = f_gen then $ emit test to see if conversion is necessar
437
438 if otyp = f_elmt then $ test for elements on same base
439 call em2(q2_eqform1, oaddr, iaddr, ft_base(oform));
440
441 elseif copy ^= copy_no then $ test, copy if forms match
442 call em2(q2_eqform2, oaddr, iaddr, oform);
443
444 else $ test, set share bit
445 call em2(q2_eqform3, oaddr, iaddr, oform);
446 end if;
447 end if;
448
449 call em2(q2_convert, oaddr, iaddr, oform);
450
smfd 36 if asm_flag & (ityp = f_gen) then
smfd 37 $ generate a label for the skip instruction just generated
smfd 38 laddr = codep + inst_nw; call em2(q2_lab, laddr, 0, 0);
smfd 39 end if;
smfb 244
smfb 245 if rpr_flag > 1 then l_call(print_message); end if;
455
456 return;
457
458
459/case(f_base)/
460
461/case(f_pbase)/
462
463 call abort('illegal attempt to convert base');
464
465
466/case(f_proc)/ $ procedures, etc
467
468/case(f_memb)/
469
470/case(f_lab)/
471
472/case(f_uimap)/
473
474/case(f_urmap)/
475
476 call abort('attempt to convert to invalid type');
477
478/error/
479
480 call ermsg(9, 0);
481 return;
smfb 246
smfb 247
smfb 248/print_message/ $ local subr to print conversion message
smfb 249
smfb 250 tstart = t; hstart = h; $ save environment parameters
smfb 251 get_addr(s_rnames, sym_rnames); $ set run-time names tuple
smfb 252 build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
smfb 253
smfb 254 put ,skip;
smfb 255 if ^ is_internal(output) then
smfb 256 put ,'convert ' :symsds(output),a ,x;
smfb 257 elseif ^ is_internal(input) then
smfb 258 put ,'convert ' :symsds(input),a ,x;
smfb 259 else
smfb 260 put ,'insert conversion ';
smfb 261 end if;
smfb 262
smfb 263 spec = format_form(iform);
smfb 264 if filestat(out_file, column) + ss_len(value_ spec) > 75 then
smfb 265 put ,skip ,column(5);
smfb 266 end if;
smfb 267 put ,'from '; call print2(out_file, spec);
smfb 268
smfb 269 spec = format_form(oform);
smfb 270 if filestat(out_file, column) + ss_len(value_ spec) > 77 then
smfb 271 put ,skip ,column(5);
smfb 272 end if;
smfb 273 put ,'to '; call print2(out_file, spec);
smfb 274
smfb 275 put ,skip ,column(5);
smfb 276 put ,'at ' :symsds(curmemb),a ,'.' :symsds(currout),a
smfb 277 ,'.' :stmt_count,i ,'.' ,skip;
smfb 278
smfb 279 t = tstart; h = hstart; $ restore run-time environment
smfb 280
smfb 281 go to rlab(retpt) in 1 to zzya; $ return from local subroutine
482
483
484 end subr emconv;
1 .=member okconv
2 fnct ok_conv(t1, t2);
3
smfd 40$ this routine does a recursive test to see whether the conversion
smfd 41$ from t2 to t1 could cause a run-time error.
smfd 42
smfd 43 size t1(ps); $ type of output
smfd 44 size t2(ps); $ type of input
smfd 45
smfd 46 size ok_conv(1); $ flag returned
smfd 47
smfd 48 size f1(ps), f2(ps); $ copies of arguments
smfd 49 size n(ps); $ length of mixed tuple
smfd 50 size j(ps); $ loop index
smfd 51 size tstart(ps); $ initial value of 't'
smfd 52
smfd 53 size cn_type(ps); $ special version of 'compn_typ'
19
20 access q1vars; $ access global q1 variables.
21 access nscod; $ access variables global to cod.
22
23$ push the original types onto the stack then use a work pile
24$ technique.
25
26 tstart = t;
27 push2(t1, t2);
28
29 while t ^= tstart;
30 pop2(f2, f1);
31
smfd 54 if (f1 = f2) cont; $ no conversion necessary.
smfd 55
smfd 56 $ dereference element types.
smfd 57 if ft_type(f1) = f_elmt then
smfd 58 if (ft_lim(ft_base(f1)) ^= 0) go to error; $ const base
smfd 59 f1 = deref_typ(f1);
smfd 60 end if;
smfd 61
34 if (ft_type(f2) = f_elmt) f2 = deref_typ(f2);
35
36 if (f1 = f2) cont; $ no conversion necessary.
37
smfd 62 $ conversions between plex types are illegal.
39 if (is_fplex(f1) ! is_fplex(f2)) go to error;
40
smfd 63 if (f1 = f_gen) cont;
smfd 64
smfd 65 if ft_type(f1) = f_sint then
smfd 66 if ft_type(f2) = f_sint then
smfd 67 if (ft_low(f1) > ft_low(f2)) go to error;
smfd 68 if (ft_lim(f1) = 0) cont;
smfd 69 if (ft_lim(f2) = 0) go to error;
smfd 70 if (ft_lim(f1) < ft_lim(f2)) go to error;
smfd 71 cont;
smfd 72 else
smfd 73 go to error;
smfd 74 end if;
smfd 75 end if;
42
43 if (is_fint(f1) & is_fint(f2)) cont;
44 if (is_freal(f1) & is_freal(f2)) cont;
45 if (is_fstr(f1) & is_fstr(f2)) cont;
46
smfd 76 $ any remaining primitive types are incompatible.
48 if (is_fprim(f1) ! is_fprim(f2)) go to error;
49
50
51 if is_fset(f1) & is_fset(f2) then $ two sets
52 push2(ft_elmt(f1), ft_elmt(f2));
53 cont;
54
55 elseif ft_type(f1) = f_mtuple ! ft_type(f2) = f_mtuple then
smfd 77
smfd 78 if ft_type(f1) = f_mtuple then
smfd 79 if ft_type(f2) = f_mtuple then
smfd 80 if (ft_lim(f1) < ft_lim(f2)) go to error;
smfd 81 else
smfd 82 go to error;
smfd 83 end if;
smfd 84 end if;
56 n = ft_lim(f1);
57 if (n < ft_lim(f2)) n = ft_lim(f2);
58
59 do j = 1 to n;
60 push2(cn_type(f1, j), cn_type(f2, j));
61 end do;
62
63 cont;
64
65 elseif is_ftup(f1) & is_ftup(f2) then $ two homogeneous tuple
66 push2(ft_elmt(f1), ft_elmt(f2));
67 cont;
68
69 else $ set and tuple
70 go to error;
71 end if;
72
73 end while;
74
75 ok_conv = yes;
76
77 return; $ valid conversion
78
79/error/
80
81 t = tstart; $ restore;
82
83 ok_conv = no;
84
85 return;
86
87 end fnct ok_conv;
smfd 85 fnct can_conv(t1, t2);
smfd 86
smfd 87$ this routine does a recursive test to see whether the conversion from
smfd 88$ t2 to t1 is legal, i.e. whether a run-time conversion can succeed.
smfd 89
smfd 90 size t1(ps); $ type of output
smfd 91 size t2(ps); $ type of input
smfd 92
smfd 93 size can_conv(1); $ flag returned
smfd 94
smfd 95 size f1(ps), f2(ps); $ copies of arguments
smfd 96 size n(ps); $ length of mixed tuple
smfd 97 size j(ps); $ loop index
smfd 98 size tstart(ps); $ initial value of 't'
smfd 99
smfd 100 size cn_type(ps); $ special version of 'compn_typ'
smfd 101
smfd 102 access q1vars; $ access global q1 variables.
smfd 103 access nscod; $ access variables global to cod.
smfd 104
smfd 105$ push the original types onto the stack then use a work pile
smfd 106$ technique.
smfd 107
smfd 108 tstart = t;
smfd 109 push2(t1, t2);
smfd 110
smfd 111 while t ^= tstart;
smfd 112 pop2(f2, f1);
smfd 113
smfd 114 $ dereference element types.
smfd 115 if (ft_type(f1) = f_elmt) f1 = deref_typ(f1);
smfd 116 if (ft_type(f2) = f_elmt) f2 = deref_typ(f2);
smfd 117
smfd 118 if (f1 = f2) cont; $ no conversion necessary.
smfd 119
smfd 120 $ conversions to or from plex types are illegal.
smfd 121 if (is_fplex(f1) ! is_fplex(f2)) go to error;
smfd 122
smfd 123 if (f1 = f_gen ! f2 = f_gen) cont;
smfd 124
smfd 125 if (is_fint(f1) & is_fint(f2)) cont;
smfd 126 if (is_freal(f1) & is_freal(f2)) cont;
smfd 127 if (is_fstr(f1) & is_fstr(f2)) cont;
smfd 128
smfd 129 $ any remaining primitive types are incompatible
smfd 130 if (is_fprim(f1) ! is_fprim(f2)) go to error;
smfd 131
smfd 132
smfd 133 if is_fset(f1) & is_fset(f2) then $ two sets
smfd 134 push2(ft_elmt(f1), ft_elmt(f2));
smfd 135 cont;
smfd 136
smfd 137 elseif ft_type(f1) = f_mtuple ! ft_type(f2) = f_mtuple then
smfd 138 n = ft_lim(f1);
smfd 139 if (n < ft_lim(f2)) n = ft_lim(f2);
smfd 140
smfd 141 do j = 1 to n;
smfd 142 push2(cn_type(f1, j), cn_type(f2, j));
smfd 143 end do;
smfd 144
smfd 145 cont;
smfd 146
smfd 147 elseif is_ftup(f1) & is_ftup(f2) then $ two homogeneous tuple
smfd 148 push2(ft_elmt(f1), ft_elmt(f2));
smfd 149 cont;
smfd 150
smfd 151 else $ set and tuple
smfd 152 go to error;
smfd 153 end if;
smfd 154
smfd 155 end while;
smfd 156
smfd 157 can_conv = yes;
smfd 158
smfd 159 return; $ valid conversion
smfd 160
smfd 161
smfd 162/error/
smfd 163
smfd 164 t = tstart; $ restore;
smfd 165
smfd 166 can_conv = no;
smfd 167
smfd 168 return;
smfd 169
smfd 170 end fnct can_conv;
1 .=member convcon
2 fnct convcon(nam, fm);
3
4$ this is the top level routine for converting constants. we
5$ check whether 'nam' can be given a type 'fm' then call cnvcon
6$ to do further processing. there are five possibilities:
7
8$ 1. nam already has a representation as fm, so we return it.
9
10$ 2. fm and nam seem compatible. that is they are both
11$ sets, both tuples, etc. in this case we accept the repr, and
12$ defer further checking until later.
13
14$ 3. fm is general. there are two possibilities here:
15
16$ a. nam is a primitve type or a standard type such as 'set(*)'.
17$ in this case we simply return.
18
19$ b. nam has a more specific set or tuple type. this will
20$ arise in 'a := [1, 2]' where a is undeclared and the
21$ tuple former is typed tuple(int) by the compiler.
22
23$ in this case we must reset nam's form to a more general
24$ type, i.e. tuple(*). this is necessary so that a later
25$ assignment 'a(1) := 1.0' can be done without resetting
26$ a's type.
27
28$ 4. fm is type element.
29
30$ 5. otherwise we issue an error message.
31
32$ note that convcon will never be called to convert 'nam' to a local
33$ set or map. these conversions must be done at run time since they
34$ involve resetting the fields of the variable to which the constant
35$ is being assigned.
36
37 size nam(ps), $ name of symbolic constant
38 fm(ps); $ desired type
39 size convcon(ps); $ new symtab pointer
40
41 size ifm(ps), $ form of input
42 ofm(ps), $ form of output
43 elmt(ps); $ new entry of type element
smfb 282 size v(ws); $ value of integer constant
44
45 size cnvcon(ps), $ lower level conversion function
46 genelmt(ps); $ generates constant of type element
47
48 access q1vars; $ access global q1 variables.
49 access nscod; $ access variables global to cod.
50
51$ find the input and output types. note that if 'fm' is general
52$ we will determine the output type from the input type.
53 ifm = form(nam);
54 ofm = fm;
55
56 if ofm = f_gen then
57 if is_ftup(ifm) then
58 ofm = f_tuple;
59 elseif is_fmap(ifm) then
60 ofm = f_umap;
61 elseif is_fset(ifm) then
62 ofm = f_uset;
63 else
64 ofm = ifm;
65 end if;
66 end if;
67
68$ see if nam already has a representation 'ofm'.
69
70 convcon = nam;
71
72 while convcon ^= 0;
73 if (form(convcon) = ofm) return;
74
75 convcon = altrep(convcon);
76 end while;
77
78$ otherwise see if ofm and ifm are compatible
79
smfb 283 if ft_type(ofm) = f_sint & is_fint(ifm) then
smfb 284 v = symval(nam);
smfb 285 if ft_low(ofm) <= v & $ range check needed
smfb 286 (v <= ft_lim(ofm) ! ft_lim(ofm) = 0 & v <= maxsi) then
smfb 287 convcon = cnvcon(nam, ofm);
smfb 288 else
smfb 289 call ermsg(07, 0);
smfb 290 end if;
smfb 291
smfb 292 elseif ofm = f_int & ft_type(ifm) = f_sint then
smfb 293 convcon = nam;
smfb 294
smfb 295 elseif (is_fint(ofm) & is_fint(ifm)) ! $ two integers
81 (is_freal(ofm) & is_freal(ifm)) ! $ two reals
82 (is_ftup(ofm) & is_ftup(ifm)) ! $ two tuples
83 (is_fset(ofm) & is_fset(ifm)) then $ two sets (maps)
84
85 convcon = cnvcon(nam, ofm);
86
87 elseif ft_type(ofm) = f_elmt then
88 convcon = genelmt(nam, ofm);
89
90 else
91 call ermsg(10, nam);
92 end if;
93
94
95 end fnct convcon;
1 .=member cnvcon
2 fnct cnvcon(nam, fm);
3
4$ this is the lower level function for converting constants.
5$ at this point we know that 'nam' can be given a type of
6$ 'fm'. there are two possibilities:
bnda 12$
8$ 1. nam is an internally generated constant. this means
9$ that it is only used by one instruction. we merely
10$ reset its form field so that it is built with type fm.
bnda 13$
12$ 2. nam appears in the source program. this means that it
13$ can be used more than once and may have several reprs.
14$ we generate a new symtab entry for this repr and assign
15$ it storage then proceed as in (1).
16
bnda 14 size nam(ps); $ symtab index of constant
bnda 15 size fm(ps); $ formtab index of constant
19
bnda 16 size cnvcon(ps); $ new symtab index returned
21
22 access q1vars; $ access global q1 variables.
23 access nscod; $ access variables global to cod.
24
25
bnda 17 if is_internal(nam) & is_seen(nam) = no then
bnda 18 is_seen(nam) = yes;
27 cnvcon = nam;
28
29 else
30 countup(symtabp, symtab_lim, 'symtab');
31 cnvcon = symtabp;
32
33 symtab(cnvcon) = symtab(nam);
34 name(cnvcon) = 0;
smfb 296
smfb 297 if ft_type(form(nam)) = f_sint & ft_type(fm) = f_sint then
smfb 298 $ no new run-time symbol table entry is needed
smfb 299 alias(cnvcon) = nam; is_store(cnvcon) = no;
smfb 300 if (alias(nam) ^= 0) alias(cnvcon) = alias(nam);
smfb 301
smfb 302 else
smfb 303 $ create a new run-time symbol table entry
smfb 304 alias(cnvcon) = 0; is_store(cnvcon) = yes;
smfb 305
smfb 306 get_symtab(1); address(cnvcon) = sym_lim;
smfb 307 call iname('', 0, sym_lim);
smfb 308
smfb 309 if is_funt(fm) then $ allocate skip word
smfb 310 get_symtab(1); build_spec(heap(sym_lim), t_skip, 2);
smfb 311 call iname('', 0, sym_lim);
smfb 312 end if;
smfb 313 end if;
smfb 314
smfb 315 $ link new entry into alternate representation chain
smfb 316 altrep(cnvcon) = altrep(nam); altrep(nam) = cnvcon;
47 end if;
48
49 form(cnvcon) = fm;
50
51
52 end fnct cnvcon;
1 .=member genelmt
2 fnct genelmt(nam, fm);
3
4$ this routine generates a constant of type element. v is the
5$ constants value and fm is its form.
6
7
8 size nam(ps), $ original constant
9 fm(ps); $ type of element
10
11 size genelmt(ps); $ pointer returned
12
13 size nam1(ps); $ local copy of original constant
14
15 access q1vars; $ access global q1 variables.
16 access nscod; $ access variables global to cod.
17
18
19 nam1 = alias(nam); if (nam1 = 0) nam1 = nam;
20
21 countup(symtabp, symtab_lim, 'symtab');
22 genelmt = symtabp;
23
24 symtab(genelmt) = 0;
25
26 is_repr(genelmt) = yes;
27 is_read(genelmt) = yes;
28 is_store(genelmt) = yes;
29
30 form(genelmt) = fm;
31
32 altrep(genelmt) = altrep(nam); $ link into chain
33 altrep(nam) = genelmt;
34
35 get_symtab(1); address(genelmt) = sym_lim;
smfa 169 call iname('', 0, sym_lim);
37
38 countup(valp, val_lim, 'val');
39 val(valp) = nam1;
40
41 vptr(genelmt) = valp;
42 vlen(genelmt) = 1;
43
44
45 end fnct genelmt;
1 .=member bldpset
2 fnct bldpset(nam);
3
4$ this routine builds a set whose elements are the characters
5$ contained in a given string. these sets are called psets and
6$ are represented as 'packed tuple(1...1)' whose i-th component is
7$ 1 if the character with code 'i' is in the set and 0 otherwise.
8$ (note that 0 is the packed representation of omega.)
9
10$ psets are built on the fly during code generation. this means that
11$ the run time value of 'nam' has not yet been built.
12
13 size nam(ps); $ symtab pointer for string
14
15 size bldpset(ps); $ run time symbol table address
16
17 size tup(ps), $ specifier for tuple
18 p(ps), $ pointer to tuple
19 j(ps), $ loop index
20 str(sds_sz), $ nam as sds, including surrounding quotes
21 c(cs); $ character
22 size old(ps); $ pointer to sample value
23 size len(ps); $ total allocation
24 size spec(hs); $ specifier for pattern set
25
26 access q1vars; $ access global q1 variables.
27 access nscod; $ access variables global to cod.
28
29
30$ get run time symbol table entry
31 get_symtab(1); bldpset = sym_lim;
smfa 170 call iname('', 0, bldpset);
32
33$ get null tuple then set its value
34
35$ if we generate code in the dynamic part of the heap, we must allocate
36$ this tuple in the constant area. we can do this since psets are live
37$ for the duration of execution, and their components are primitive.
38
39 old = value(ft_samp(f_pset));
40 len = palloc(old, cs_sz-1);
41
42 if asm_flag then get_const(len, p); else get_heap(len, p); end if;
43
44 do j = 0 to hl_ptuple-1; heap(p+j) = heap(old+j); end do;
45 do j = hl_ptuple to len-1; heap(p+j) = 0; end do;
46
47 maxindx(p) = cs_sz-1;
48 nelt(p) = cs_sz-1;
49
50 build_spec(spec, t_stuple, p); heap(bldpset) = spec;
51
52
53$ get the value of the string as an sds
54
55 str = 0;
56
57 do j = 0 to vlen(nam) - 1;
58 .f. 1 + j*ws, ws, str = val(vptr(nam) + j);
59 end do;
asca 18 .+ascebc if (ascebc_flag) call ascsds(str); $ convert to ascii
60
61$ set the bit corresponding to each character in the string
62
63 do j = 1 to .len. str;
64 c = .ch. j, str;
65 psetcomp(p, c) = 1;
66 end do;
72
73
74 end fnct bldpset;
1 .=member canasn
2 fnct can_assign(f1, f2);
3
4$ this function returns true if an object of type f2 can be assigned
5$ to a variable of type f1, i.e. if the assignment 'f1 := f2' can
6$ be done without a conversion.
7
8 size f1(ps), $ target type
9 f2(ps); $ input type
10
11 size can_assign(1);
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16
17 if (f1 = f2) go to pass; $ types match
18
19 if (ft_type(f1) = f_int & ft_type(f2) = f_sint) go to pass;
20
21 if ft_type(f1) = f_sint & ft_type(f2) = f_sint then
22 if (ft_low(f1) > ft_low(f2)) go to fail;
23 if (ft_lim(f1) = 0) go to pass;
24 if (ft_lim(f2) = 0) go to fail;
25 if (ft_lim(f1) < ft_lim(f2)) go to fail;
26 go to pass;
27 end if;
28
29 if (ft_type(f1) = f_string & ft_type(f2) = f_sstring) go to pass;
30
31 if (f1 ^= f_gen) go to fail; $ target not general
32
33 go to case(ft_type(f2)) in f_min to f_max;
34
35/case(f_gen)/ $ general
36
37/case(f_sint)/ $ short int
38
39/case(f_sstring)/ $ short string
40
41/case(f_atom)/ $ short atom
42
43/case(f_latom)/ $ 'long' atom
44
45/case(f_elmt)/ $ element
46
47/case(f_error)/
48
49 go to pass;
50
51/case(f_uint)/ $ untyped int
52
53/case(f_ureal)/ $ untyped real
54
55 go to fail;
56
57/case(f_int)/ $ long or short integer
58
59/case(f_string)/ $ long or short chars
60
61/case(f_real)/ $ real
62
63 go to pass;
64
65/case(f_ituple)/ $ integer tuple
66
67/case(f_rtuple)/ $ real tuple
68
69/case(f_ptuple)/ $ packed tuple
70
71 go to fail;
72
73/case(f_tuple)/ $ std. tuple
74
75 if (ft_elmt(f2) = f_gen) go to pass;
76 go to fail;
77
78/case(f_mtuple)/ $ mixed tuple
79
80 go to fail;
81
82/case(f_uset)/ $ standard set
83
84 if (ft_elmt(f2) = f_gen) go to pass;
85 go to fail;
86
87/case(f_lset)/ $ local subset
88
89 go to fail;
90
91/case(f_rset)/ $ remote subset
92
93 if (ft_elmt(ft_base(f2)) = f_gen) go to pass;
94 go to fail;
95
96/case(f_umap)/ $ standard map
97
98 if (ft_elmt(f2) = f_gen) go to pass;
99 go to fail;
100
101/case(f_lmap)/ $ local map
102
103 go to fail;
104
105/case(f_rmap)/ $ remote map
106
107/case(f_lpmap)/ $ local packed map
108
109/case(f_limap)/ $ local integer map
110
111/case(f_lrmap)/ $ local real map
112
113/case(f_rpmap)/ $ remote packed map
114
115/case(f_rimap)/ $ remote integer map
116
117/case(f_rrmap)/ $ remote real map
118
119/case(f_base)/ $ base
120
121/case(f_pbase)/ $ plex base
122
123/case(f_uimap)/
124
125/case(f_urmap)/
126
127/case(f_proc)/ $ procedure or operator
128
129/case(f_memb)/ $ member
130
131/case(f_lab)/ $ label
132
133 go to fail;
134
135/pass/ $ return true
136
137 can_assign = yes;
138 return;
139
140/fail/ $ return false
141
142 can_assign = no;
143 return;
144
145 end fnct can_assign;
1 .=member matchr
2 subr match_repr(addr, arg, fm);
3
4$ this routine tries to find an alternate representation of
5$ 'arg' with type 'fm'.
6
7$ on input we have:
8
9$ arg: symtab pointer to a variable or constant
10$ addr: its address
11$ fm: desired type
12
13$ if arg is a constant and it has an alternate repr of type fm
14$ we reset arg and addr to point to the alternate repr.
15
16 size addr(ps), $ address
17 arg(ps), $ symtab pointer
18 fm(ps); $ form
19
smfb 317 size p(ps); $ pointer through alternate repr chain
smfb 318 size v(ws); $ value of integer constant
smfb 319
smfb 320 size convcon(ps); $ converts constant
21
22 access q1vars; $ access global q1 variables.
23 access nscod; $ access variables global to cod.
24
25
26 if (^ is_const(arg)) return;
27
28 if (fm = f_gen ! fm = form(arg)) return;
29
30 p = altrep(arg);
31
32 while p ^= 0;
33 if form(p) = fm then
34 arg = p;
35 get_addr(addr, arg);
36 return;
37 end if;
38
39 p = altrep(p);
40 end while;
41
smfb 321 if ft_type(fm) = f_sint & is_fint(form(arg)) then
smfb 322 v = symval(arg);
smfb 323 if ft_low(fm) <= v & $ range check needed
smfb 324 (v <= ft_lim(fm) ! ft_lim(fm) = 0 & v <= maxsi) then
smfb 325 arg = convcon(arg, fm); get_addr(addr, arg);
smfb 326 end if;
smfb 327 elseif is_fint(fm) & is_fint(form(arg)) !
smfb 328 is_freal(fm) & is_freal(form(arg)) then
smfb 329 arg = convcon(arg, fm); get_addr(addr, arg);
smfb 330 end if;
smfb 331
43
44 end subr match_repr;
1 .=member seta1
2 subr set_a1;
3
4$ this routine is called before using a1 as an input, for example
5$ in 'a1(a2) := a3' . we emit any necessary copy.
6$ if addr_a1 = addr_a3 then we are doing 'f(x) := f'. before we
7$ can emit a copy, we must emit 't3_ := a3' and set
8$ addr_a3 = addr_t3.
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13 if addr_a1 = addr_a3 & cflag(now) ^= copy_no then
14 call em2(q2_asnsb, addr_t3, addr_a3, 0);
15 addr_a3 = addr_t3;
16 end if;
17
18
19 go to case(cflag(now)) in copy_no to copy_test;
20
21/case(copy_no)/ $ no copy
22
23 return;
24
25/case(copy_yes)/ $ unconditional copy
26
27 call em2(q2_copy, addr_a1, addr_a1, 0);
28 return;
29
30/case(copy_test)/ $ conditional copy
31
32 if (fm1 = f_string) go to case(copy_yes); $ always copy
33
34 if (is_floc(fm1)) return; $ never shared
35
36 call em2(q2_ccopy, addr_a1, addr_a1, 0);
37 return;
38
39 end subr set_a1;
1 .=member seta2
2 subr set_a2(fm, exact);
3
4$ this routine is called before using a2 as an input, for example
5$ in 'a1 := a2 + a3'. its arguments are:
6
7$ fm: the desired form for a2
8
9$ exact: 1 if we require a2 to have exactly this type
10$ 0 if we allow a2 to have a more specific type
11
12$ we perform any necessary copying and conversion.
13
14 size fm(ps), $ desired form
15 exact(1); $ indicates form must be exactly 'fm'.
16
17 size opc(ps); $ q2 opcode
18
19 access q1vars; $ access global q1 variables.
20 access nscod; $ access variables global to cod.
21
22
23 if a2 = sym_om then $ use desired omega
24 addr_a2 = ft_samp(fm);
25 if (is_floc(fm)) call em2(q2_asnnl, addr_a2, fm, 0);
26 return;
27 end if;
28
29$ see if conversion is required
30
31 if exact then
32 if (same_repr(fm, fm2)) go to copy;
33 else
34 if (can_assign(fm, fm2)) go to copy;
35 end if;
36
37/conv/ $ conversion necessary
38
smfd 171 if op = q1_sof ! op = q1_sofa ! op = q1_ssubst ! op = q1_send then
smfd 172 $ cflag refers to a1.
smfd 173 call emconv(sym_t2_, a2, fm, copy_no);
smfd 174 else
smfd 175 call emconv(sym_t2_, a2, fm, cflag(now));
smfd 176 end if;
40 addr_a2 = addr_t2;
41
42 return;
43
44/copy/ $ copy if necessary
45
46$ if the current opcode is q1_sof, etc. then the copy flag refers
47$ to a1, and we can make a direct return.
48
49 if (op = q1_sof ! op = q1_sofa) return;
50 if (op = q1_ssubst ! op = q1_send) return;
51
52$ otherwise copy a2 if it is long and used destructively
53 if (is_fnum(fm2)) return;
54
55 go to case(cflag(now)) in copy_no to copy_test;
56
57/case(copy_no)/
58
59 return;
60
61/case(copy_yes)/
62
63 opc = q2_copy;
64 go to esac;
65
66/case(copy_test)/
67
68 if (fm2 = f_string) go to case(copy_yes); $ always copy
69
70 if (is_floc(fm2)) return; $ never shared
71
72 opc = q2_ccopy;
73
74/esac/
75
76 call em2(opc, addr_t2, addr_a2, 0);
77 addr_a2 = addr_t2;
78
79 return;
80
81 end subr set_a2;
1 .=member seta3
2 subr set_a3(fm, exact);
3
4$ this routine is called before using a3 as an input, for example
5$ in 'a1 := a2 + a3'. its arguments are:
6
7$ fm: the desired form for a3
8
9$ exact: 1 if we require a3 to have exactly this type
10$ 0 if we allow a3 to have a more specific type
11
12$ we perform any necessary share bit setting and conversion.
13
14 size fm(ps), $ desired form
15 exact(1); $ indicates form must be exactly 'fm'.
16
17 access q1vars; $ access global q1 variables.
18 access nscod; $ access variables global to cod.
19
20
21 if a3 = sym_om then $ use desired omega
22 addr_a3 = ft_samp(fm);
23 return;
24 end if;
25
26$ see if conversion is required
27
28 if exact then
29 if (same_repr(fm, fm3)) go to set;
30 else
31 if (can_assign(fm, fm3)) go to set;
32 end if;
33
34/conv/ $ conversion necessary
35
36 call emconv(sym_t3_, a3, fm, no);
37 addr_a3 = addr_t3;
38
39 return;
40
41/set/ $ set share bit if necessary
42
43 if (is_const(a3)) return;
44 if (is_fprim(fm3)) return;
45 if (is_floc(fm3)) return;
46 if (op = q1_of) return;
47 if (op = q1_ofa) return;
48
49 if (sflag(now) = no) return;
50
51 call em2(q2_share, addr_a3, 0, 0);
52 return;
53
54 end subr set_a3;
1 .=member seta4
2 subr set_a4(fm, exact);
3
4$ this routine is called before using a4 as an input, for example
5$ in 'a1(a2 ... a3) := a4'. its arguments are:
6
7$ fm: the desired form for a4
8
9$ exact: 1 if we require a4 to have exactly this type
10$ 0 if we allow a4 to have a more specific type
11
12$ we perform any necessary conversion.
13
14 size fm(ps), $ desired form
15 exact(1); $ indicates form must be exactly 'fm'.
16
17 access q1vars; $ access global q1 variables.
18 access nscod; $ access variables global to cod.
19
20
21 if a4 = sym_om then $ use desired omega
22 addr_a4 = ft_samp(fm);
23 return;
24 end if;
25
26$ see if conversion is required
27
28 if exact then
29 if (same_repr(fm, fm4)) return;
30 else
31 if (can_assign(fm, fm4)) return;
32 end if;
33
34 call emconv(sym_t4_, a4, fm, no);
35 addr_a4 = addr_t4;
36
37
38 end subr set_a4;
1 .=member typea1
2 subr typea1;
3
4$ this routine is called before emitting a q2 instruction which
5$ might pass a1 to the run time library. it checks that a1 is
6$ a typed quantity; if not it makes the appropriate conversion.
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11 if fm1 = f_uint then
12 call set_a1(f_int, no);
13 call emconv(sym_t1_, a1, f_int, no);
14
15 elseif fm1 = f_ureal then
16 call set_a1(f_real, no);
17 call emconv(sym_t1_, a1, f_real, no);
18 end if;
19
20 return;
21
22 end subr typea1;
1 .=member typea2
2 subr typea2;
3
4$ this routine is called before emitting a q2 instruction which
5$ might pass a2 to the run time library. it checks that a2 is
6$ a typed quantity; if not it makes the appropriate conversion.
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11 if fm2 = f_uint then
12 call set_a2(f_int, no);
13
14 elseif fm2 = f_ureal then
15 call set_a2(f_real, no);
16 end if;
17
18 return;
19
20 end subr typea2;
1 .=member typea3
2 subr typea3;
3
4$ this routine is called before emitting a q2 instruction which
5$ might pass a3 to the run time library. it checks that a3 is
6$ a typed quantity; if not it makes the appropriate conversion.
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11 if fm3 = f_uint then
12 call set_a3(f_int, no);
13
14 elseif fm3 = f_ureal then
15 call set_a3(f_real, no);
16 end if;
17
18 return;
19
20 end subr typea3;
1 .=member typea4
2 subr typea4;
3
4$ this routine is called before emitting a q2 instruction which
5$ might pass a4 to the run time library. it checks that a4 is
6$ a typed quantity; if not it makes the appropriate conversion.
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11 if fm4 = f_uint then
12 call set_a4(f_int, no);
13
14 elseif fm4 = f_ureal then
15 call set_a4(f_real, no);
16 end if;
17
18
19 end subr typea4;
1 .=member emdebug
2 subr emdebug;
3
4$ this routine emits the various run time debugging operations. we
5$ simply look up a1 in a table 'debug_ops'.
6
smfa 171 size spec(hs); $ specifier to build run-time names entry
smfa 172
7 +* debug_op(op) = a_debug_op(op - sym_cdebug_max) **
8
9 size a_debug_op(ps);
10 dims a_debug_op(sym_debug_max - sym_cdebug_max);
11
12 data debug_op(sym_rtre0) = q2_notre:
13 debug_op(sym_rtre1) = q2_tre:
14 debug_op(sym_rtrc0) = q2_notrc:
15 debug_op(sym_rtrc1) = q2_trc:
16 debug_op(sym_rtrg0) = q2_notrg:
17 debug_op(sym_rtrg1) = q2_trg:
18 debug_op(sym_rgcd0) = q2_nogdump:
19 debug_op(sym_rgcd1) = q2_gdump:
20 debug_op(sym_rdump) = q2_dump:
21 debug_op(sym_rgarb) = q2_garb;
22
23 access q1vars; $ access global q1 variables.
24 access nscod; $ access variables global to cod.
25
26
27 if op = q1_trace then
28 if a1 = sym_calls then
29 call em2(q2_trccalls, address(sym_one), 0, 0);
30 elseif a1 = sym_stmts then
31 call em2(q2_trcstmts, address(sym_one), 0, 0);
32 else
33 call em2(q2_trcsym, addr_a1, address(sym_one), 0);
34 end if;
35
36 elseif op = q1_notrace then
37 if a1 = sym_calls then
38 call em2(q2_trccalls, address(sym_zero), 0, 0);
39 elseif a1 = sym_stmts then
40 call em2(q2_trcstmts, address(sym_zero), 0, 0);
41 else
42 call em2(q2_trcsym, addr_a1, address(sym_zero), 0);
43 end if;
44
45 else
46 if a1 > sym_cdebug_max then
47 call em2(debug_op(a1), 0, 0, 0);
48
49 else
50 go to case(a1) in sym_cdebug_min to sym_cdebug_max;
51
52 /case(sym_cq1cd)/ $ q1 code dump --- already done
53
54 go to esac;
55
56
57 /case(sym_cq1sd)/ $ q1 symbol table dump
58
59 call sdump;
60 go to esac;
61
62
63 /case(sym_cq2cd)/ $ q2 code dump
64
65$ note that the routine q2dump assumes that it is called after the
66$ routine termcode has been executed. at this point, the length of
67$ the current code block has not been filled in yet, so start by
68$ setting codenw to the current value.
69
70 codenw(code_org) = h_const - code_org;
smfa 173 get_addr(s_rnames, sym_rnames);
smfa 174 build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
71
72 call q2dump;
73 go to esac;
74
75
76 /esac/
77
78 end if;
79
80 end if;
81
82
83 end subr emdebug;
1 .=member initcode
2 subr initcode;
3
4$ this routine is called before the start of actual code generation.
5$ allocate a data block for the code for this routine and
6$ initialize it.
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11
12 get_code(hl_code, code_org);
13 htype(code_org) = h_code;
14 hlink(code_org) = 0;
15
16 $ point to the 'zero-th' instruction
17 codep = code_org + hl_code - inst_nw;
18
19$ reset cstmt_count to its value at the start of the unit.
20 cstmt_count = ustmt_count;
21
22
23 end subr initcode;
1 .=member em2
2 subr em2(opc, v1, v2, v3);
3
4$ this routine emits a q2 instruction. we do this by extending the
5$ current code block and setting its fields.
6
7
8 size opc(ps), $ op code
9 v1(ps), $ operands
10 v2(ps),
11 v3(ps);
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16 get_code(inst_nw, codep);
17
18 codeop(codep) = opc;
19 codea1(codep) = v1;
20 codea2(codep) = v2;
21 codea3(codep) = v3;
22
23
24 end subr em2;
1 .=member sa4
2 subr sa4(v);
3
4$ this routine sets codea4 of the current quadruple
5
6 size v(ps);
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11 codea4(codep) = v;
12
13
14 end subr sa4;
1 .=member termcode
2 subr termcode;
3
4$ this routine is called when we finish generating code for a
5$ procedure. we fill in the length of the code block.
6
smfa 175 size spec(hs); $ specifier to build run-time names entry
smfa 176
7 access q1vars; $ access global q1 variables.
8 access nscod; $ access variables global to cod.
9
10 if (h_const > max_code_address)
11 call abort('addressability exceeded');
12
13 codenw(code_org) = codep + inst_nw - code_org;
14
15 code_tot = code_tot + codenw(code_org);
16
17$ dump code for this routine if desired
smfa 177 if q2cd_flag then
smfa 178 get_addr(s_rnames, sym_rnames);
smfa 179 build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
smfa 180 call q2dump;
smfa 181 end if;
19
20$ zero code_org and codep. this indicates to the dump routines
21$ that we are not currently generating code.
22 code_org = 0;
23 codep = 0;
24
25
26 end subr termcode;
1 .=member uselab
2 subr uselab(lab);
3
4$ this routine is called after generating a q2 instruction which
5$ uses a label.
6
7$ if the label has been defined, we merely return. otherwise
8$ we build a chain of all the forward references to the label.
9$ this chain starts in the labels 'labval' field and threads
10$ the codea1 fields of the instructions which use it.
11
12 size lab(ps); $ symtab pointer for label
13
14 access q1vars; $ access global q1 variables.
15 access nscod; $ access variables global to cod.
16
17
18 if (is_ldef(lab)) return;
19
20 codea1(codep) = labval(lab);
21
22 if (codep > max_code_address)
23 call abort('label address too big for labval in uselab');
24 labval(lab) = codep;
25
26
27 end subr uselab;
1 .=member setlab
2 subr setlab(lab);
3
4$ this routine is called whenever a procedure or label is
5$ defined. we adjust all forward references to the label.
6$
7$ if 'lab' is a procedure then we have just initialized a new
8$ code block, and codep points to its header.
9$
10$ if 'lab' is a label then we are in the middle of a code block
11$ and codep points to the previous instruction.
12
13
14 size lab(ps); $ label
15
16 size p(ps), $ code pointer
17 p1(ps), $ code pointer
18 lval(ps); $ final value of label
19
20 access q1vars; $ access global q1 variables.
21 access nscod; $ access variables global to cod.
22
23
24$
25$ find the value of the label
26$
27 if symtype(lab) = f_proc then
28 lval = code_org + hl_code;
29 else
30 lval = codep + inst_nw;
31 end if;
32
33 if (lval > max_code_address)
34 call abort('label address too big for labval in setlab');
35$
36$ adjust forward references
37$
38 p = labval(lab); $ head of chain
39
40 while p ^= 0;
41 p1 = codea1(p);
42 codea1(p) = lval;
43 p = p1;
44 end while;
45
46 labval(lab) = lval;
47 is_ldef(lab) = yes;
48
49
50 end subr setlab;
1 .=member setlab1
2 subr setlab1;
3
4$ this routine is called after we have seen all the units in the
5$ compilation. it processes all labels which are still undefined.
6
7$ the semantic pass catches most cases of undefined labels. there is
8$ only one case which must be handled by the code generator:
9
10$ the symbol table entries for exported procedures are built when
11$ we compile the directory. the semantic pass writes out the table
12$ entries for the directory before we know whether the exported procedur
13$ are included in the compilation. there is no way for the semantic
14$ pass to diagnose unsatisfied references to exported procedures.
15
16$ if a compilation contains a directory, then the directory is still
17$ in core at the end of compilation. missing external procedures are
18$ the only symbol table entries with:
19
20$ is_ldef: no
21$ labval: non-zero
22
23$ the labval field of these entries contains the head of a list of
24$ calls to the procedure.
25
26$ we find all such calls and change their opcodes to q2_ucall(call
27$ unsatisfied external).
28
29 size i(ps), $ symtab index
30 p(ps), $ q2 pointer
31 p1(ps); $ q2 pointer
32
33 access q1vars; $ access global q1 variables.
34 access nscod; $ access variables global to cod.
35
36 do i = 1 to symtabp;
37 if (is_ldef(i) ! labval(i) = 0) cont;
38
39 call codwrn(01, i);
40
41 p = labval(i); $ first reference to label
42
43 while p ^= 0;
44 p1 = codea1(p); $ next reference
45
46 codeop(p) = q2_ucall;
47 codea1(p) = 0;
48
49 p = p1;
50 end while;
51 end do;
52
53 end subr setlab1;
1 .=member inienv1
2 subr inienv1;
3
4$ this is the first of several routines used to build the heap. it
5$ is called at the start of code generation, before we generate
6$ code for the first procedure.
7
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
14$
15$ we assume a minimum heap size of 1024 words, and assume that
16$ if h_lim is less than this value, it specifies the heap size in
17$ kilo-words.
18$
19 if (0 < h_lim & h_lim < 1024) h_lim = h_lim * 1024;
20
21 if (h_lim = 0) h_lim = default_h;
22
23 call getspace(h_lim, yes);
24$
25$ the same assumption is made for the constant area size parameter.
26$ if we obtain an unreasonable value, we reset it to the minimum of
27$ h_lim/2 and dafault_ca.
28$
29 if (0 < ca_lim & ca_lim < 1024) ca_lim = ca_lim * 1024;
30
31 if ca_lim = 0 ! ca_lim > h_lim then
32 ca_lim = h_lim / 2;
33 if (ca_lim > default_ca) ca_lim = default_ca;
34 end if;
35$
36$ try to find some reasonable estimate for the run-time symbol table
37$ size
38$
39 if (0 < sym_lim & sym_lim < 1024) sym_lim = sym_lim * 1024;
40
41 if sym_lim = 0 ! sym_lim > max_symtab then
42 sym_lim = h_lim / 8;
43 if (sym_lim > default_sym) sym_lim = default_sym;
44 end if;
45$
46$ print final values of h and ca in phase heading
47$
sunb 39 if lcp_flag then $ continue phase heading
sunb 40 put ,'symbol table size: st = ' :sym_lim ,i ,'. '
sunb 41 ,'constants area size: ca = ' :ca_lim ,i ,'. ' ,skip
sunb 42 ,'initial heap size: h = ' :h_lim ,i ,'. ' ,skip;
sunb 43 end if;
52$
53$ set the global heap pointers
54$
55 h = 1; t = h_lim + 1;
56
smfa 182 get_heap(sym_lim, snam_org);
58 snam_end = h - 1;
59
60 get_heap(sym_lim, sym_org);
61 sym_end = h - 1; sym_lim = h;
62
63 get_heap(ca_lim, ca_org);
smfa 183 h_const = ca_org; h_org = h;
65
66 if (sym_end > max_symtab)
67 call abort('symbol table addressability exceeded');
68
69
70 end subr inienv1;
1 .=member inienv2
2 subr inienv2;
3
4$ this routine initializes all constants and static variables in
5$ the current scope. this is done in three steps:
6
7$ 1. reassign new ft_pos values to all packed local maps to
8$ allow for optimal packing.
9
10$ 2. iterate over all the forms in this scope, calling 'insamp'
11$ to build their standard omegas.
12
13$ note that certain types such as f_lset do not have sample
14$ values, so these values are not initialized.
15
16$ 3. iterate over all symbols in this scope. set each static
17$ variable to the proper omega, and build the value for
18$ each constant.
19
20$ note that we donot initialize temporaries since they will
21$ always be used before they are defined.
22
23
24 size j(ps), $ loop index
25 addr(ps); $ address
26
27 access q1vars; $ access global q1 variables.
28 access nscod; $ access variables global to cod.
29
30
31 call optpack; $ do optimal packing
32
33 do j = formtab_org+1 to formtabp;
34 if (ft_samp(j) ^= 0) call insamp(j);
35 end do;
36
37 do j = symtab_org+1 to symtabp;
38 if ( ^ is_store(j)) cont;
39
40 heap(address(j)) = heap(ft_samp(form(j)));
41
42 if (vptr(j) ^= 0) call incnst(j);
43 end do;
44
45
46 end subr inienv2;
1 .=member optpack
2 subr optpack;
3
4$ this routine does optimal packing for local objects.
5
6
7 size base(ps); $ pointer to current base
8 size f1(ps); $ pointer to current local object
9 size tp(ps); $ ft_type of f1
10 size f2(ps); $ pointer to packed range
11
12 size lsw(ps); $ value for ls_word
13 size lsb(ps); $ value for ls_bit
14 size lsw0(ps); $ initial value for lsw
15 size bits(ps); $ number of bits for packed object
16
17 size j(ps); $ index
18 size k(ps); $ current parent
19 size m(ps); $ child to be promoted
20 size lson(ps); $ left child of current parent
21 size rson(ps); $ right child of current parent
22 size n(ps); $ number of packed objects
23
24 size aux_bits(ps);
25 dims aux_bits(2*ft_num_max);
26
27 size aux_form(ps);
28 dims aux_form(2*ft_num_max);
29
30 access q1vars; $ access global q1 variables.
31 access nscod; $ access variables global to cod.
32
33
34 do base = formtab_org+1 to formtabp;
35 if (^ is_fbase(base)) cont do base;
36 if (ft_samp(base) = 0) cont do base;
37 assert base > f_max;
38
39 if ft_type(base) = f_pbase then
40 lsw0 = hl_latom - 1;
41 else
42 lsw0 = hl_ebb - 1;
43 end if;
44
45 n = 0;
46
47 do f1 = base to formtabp;
48 if (^ is_floc(f1)) cont do f1;
49 if (ft_pos(f1) = 0) cont do f1;
50 if (ft_base(f1) ^= base) cont do f1;
51
52 tp = ft_type(f1);
53
54 if tp = f_lset then
55 bits = 1;
56
57 elseif tp = f_lpmap then
58 f2 = ft_im(f1);
59 if (ft_type(f2) = f_elmt) f2 = ft_base(f2);
60
61 bits = .fb. ft_lim(f2);
62
63 else
64
65 lsw = lsw0;
66
67 do j = f_lmap to tp - 1;
68 lsw = lsw + ft_num(base, j);
69 end do;
70
71 ft_pos(f1) = lsw + ft_pos(f1);
72 ft_bit(f1) = 1;
73
74 cont do f1;
75 end if;
76
77 n = n + 1;
78 aux_form(n) = f1;
79 aux_bits(n) = bits;
80 end do f1;
81
82 $ next we sort the packed local maps, using heap sort
83 do j = n/2 to 1 by -1;
84 k = j; lson = k + k;
85 while lson <= n;
86 if lson < n then
87 rson = lson + 1;
88 if aux_bits(lson) < aux_bits(rson) then
89 m = rson;
90 else
91 m = lson;
92 end if;
93 else
94 m = lson;
95 end if;
96
97 if aux_bits(k) < aux_bits(m) then
98 swap(aux_bits(k), aux_bits(m));
99 swap(aux_form(k), aux_form(m));
100 k = m; lson = k + k;
101 else
102 quit while lson;
103 end if;
104 end while lson;
105 end do;
106
107 lsw = lsw0 + 1;
108 lsb = 1;
109
110 do j = f_lmap to f_lrmap;
111 lsw = lsw + ft_num(base, j);
112 end do;
113
114 j = n;
115 while j >= 1;
116 k = 1;
117 while k <= j;
118 if lsb + aux_bits(k) > hs + 1 then
119 k = k + 1; cont while k;
120 end if;
121
122 ft_pos(aux_form(k)) = lsw;
123 ft_bit(aux_form(k)) = lsb;
124 lsb = lsb + aux_bits(k);
125
126 aux_bits(k) = aux_bits(j);
127 aux_form(k) = aux_form(j);
128 j = j - 1;
129
130 lson = k + k;
131 while lson <= j;
132 if lson < j then
133 rson = lson + 1;
134 if aux_bits(lson) < aux_bits(rson) then
135 m = rson;
136 else
137 m = lson;
138 end if;
139 else
140 m = lson;
141 end if;
142
143 if aux_bits(k) < aux_bits(m) then
144 swap(aux_bits(k), aux_bits(m));
145 swap(aux_form(k), aux_form(m));
146 k = m; lson = k + k;
147 else
148 quit while lson;
149 end if;
150 end while;
151
152 cont while j >= 1;
153 end while k;
154
155 lsw = lsw + 1; lsb = 1;
156 end while j >= 1;
157
158 if lsb = 1 then
159 ft_bit(base) = lsw;
160 else
161 ft_bit(base) = lsw + 1;
162 end if;
163
164 end do base;
165
166
167 if (q1sd_flag) call fmdump;
168 end subr optpack;
1 .=member inienv3
2 subr inienv3;
3
4$ this routine completes the initialization of the environment
5$ after the entire program has been compiled.
6
7
8 size j(ps), $ loop index
9 addr(ps), $ address
10 spec(hs), $ specifier
11 gapn(ps); $ size of gap between h_const and h_org
12 size ss1(ssz); $ global string specifier
13
14 size nulltup(hs); $ returns specifier for null tuple
15 size nulllc(ssz); $ returns string specifier for null string
16
17 access q1vars; $ access global q1 variables.
18 access nscod; $ access variables global to cod.
19
20$ the array type_syms maps type codes t_xxx into the symbol entries
21$ for '.atom', etc.
22
23 defzero(type_syms, a_type_syms);
24
25 size a_type_syms(ps);
26 dims a_type_syms(t_lmax + 1);
27
28 data type_syms(t_int) = sym_int:
29 type_syms(t_string) = sym_string:
30 type_syms(t_atom) = sym_atom:
31 type_syms(t_error) = sym_om:
32 type_syms(t_proc) = sym_om:
33 type_syms(t_lab) = sym_om:
34 type_syms(t_latom) = sym_atom:
35 type_syms(t_elmt) = sym_om:
36 type_syms(t_lint) = sym_int:
37 type_syms(t_istring)= sym_string:
38 type_syms(t_real) = sym_real:
39 type_syms(t_tuple) = sym_tuple:
40 type_syms(t_stuple) = sym_tuple:
41 type_syms(t_set) = sym_set:
42 type_syms(t_map) = sym_set:
43 type_syms(t_skip) = sym_om;
44
45$ allocate a tuple to store the run time statistics
46
47$ note that the second argument to 'nulltup' is the expected nelt of
48$ the tuple; nulltup adds a breath factor of 1/3 to this before
49$ allocating the tuple. since the tuple for keeping statistic will never
50$ grow, there is no need for this breath space. we request less space
51$ than we will actually need so that it comes out correct when the
52$ breath space is added.
53
54
55 if st_no > 0 then
56 addr = address(sym_stat);
57 heap(addr) = nulltup(f_ituple, (2*st_no*st_max+2)/3 );
58
59 nelt(value(addr)) = st_no + 1;
60 end if;
61
62$ at this point we have set all the environment parameters except
63$ savet and codep. we begin by setting them.
64
65 savet = t;
66 codep = labval(sym_main_);
67 sym_org = sym_lim;
smfa 184 snam_org = snam_end - (sym_end-sym_org);
69
70 if (codep = 0) call ermsg(23, 0);
71
72$ if there is extra space in the constants area then we will
73$ adjust h_org and let the extra space be reclaimed during the
74$ first garbage collection.
75
76$ if we adjust h_org we must reformat the extra space to look like
77$ a valid heap block. we format it as a real tuple.
78
79
80 gapn = h_org - h_const;
81 if (gapn > max_nelt) call abort('constant area too large.');
82
83 if gapn > talloc(0) then $ build tuple
84 htype(h_const) = h_rtuple;
85 hform(h_const) = f_rtuple;
86 nelt(h_const) = 0;
87 maxindx(h_const) = gapn - (hl_tuple + 1);
88
89 h_org = h_const;
90 h_const = h_const + hl_tuple;
91 end if;
smfa 185
smfa 186$ likewise we truncate the last run-time names string block.
smfa 187
smfa 188 ss1 = value_ tcomp(rnames, nelt(rnames));
smfa 189 addr = ss_ptr(ss1);
smfa 190 gapn = lc_nwords(addr) - lcalloc(ss_len(ss1));
smfa 191 if gapn > talloc(0) then $ build tuple.
smfa 192 lc_nwords(addr) = lc_nwords(addr) - gapn;
smfa 193 addr = addr + lc_nwords(addr);
smfa 194 htype(addr) = h_rtuple; hlink(addr) = 0;
smfa 195 hform(addr) = f_rtuple;
smfa 196 nelt(addr) = 0; maxindx(addr) = gapn - (hl_rtuple + 1);
smfa 197 is_hashok(addr) = no; is_neltok(addr) = no;
smfb 332 h_names1 = addr + hl_rtuple; h_names2 = addr + tuplen(addr);
smfa 198 end if;
92
93$ save the adresses various symbol table entries.
94
95 get_addr(s_true, sym_true);
96 get_addr(s_false, sym_false);
97 get_addr(s_okval, sym_okval);
98 get_addr(s_fid, sym_fid);
99 get_addr(s_free, sym_free);
100 get_addr(s_fmax, sym_fmax);
101 get_addr(s_fmode, sym_fmode);
102
103 get_addr(s_io1, sym_io1);
104 get_addr(s_io2, sym_io2);
105
106 get_addr(s_stat, sym_stat);
107
108 get_addr(s_ss1, sym_ss1);
109 get_addr(s_ss2, sym_ss2);
110
111 build_spec(ss1, t_istring, nulllc(0)); heap(s_ss1) = ss1;
112 build_spec(ss1, t_istring, nulllc(0)); heap(s_ss2) = ss1;
113
114 get_addr(s_ovar, sym_ovar);
115 get_addr(s_scopes, sym_scopes);
116 get_addr(s_rnspec, sym_rnspec);
117 get_addr(s_rnames, sym_rnames);
smfa 199 build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
118
119 get_addr(s_intf, sym_intf);
120 heap(s_intf) = nulltup(f_tuple, 0);
121
122$ prepare other heap entries for expansion symbols
123
124 get_addr(s_spare2, sym_spare2);
125 get_addr(s_spare3, sym_spare3);
126 get_addr(s_spare4, sym_spare4);
127 get_addr(s_spare5, sym_spare5);
128 get_addr(s_spare6, sym_spare6);
129 get_addr(s_spare7, sym_spare7);
130 get_addr(s_spare8, sym_spare8);
131 get_addr(s_spare9, sym_spare9);
132 get_addr(s_sparea, sym_sparea);
133 get_addr(s_spareb, sym_spareb);
134 get_addr(s_sparec, sym_sparec);
135 get_addr(s_spared, sym_spared);
136 get_addr(s_sparee, sym_sparee);
137 get_addr(s_sparef, sym_sparef);
138 get_addr(s_spareg, sym_spareg);
139 get_addr(s_spareh, sym_spareh);
140 get_addr(s_sparei, sym_sparei);
141 get_addr(s_sparej, sym_sparej);
142 get_addr(s_sparek, sym_sparek);
143
146$ build the map s_types from type codes to addresses of type
147$ constants.
148
149 do j = t_min to t_lmax;
150 if type_syms(j) = sym_om then
151 s_types(j) = ft_samp(f_string);
152 else
153 get_addr(s_types(j), type_syms(j));
154 end if;
155 end do;
156
157$ process undefined types
158 do j = t_lmax+1 to t_max;
159 s_types(j) = ft_samp(f_string);
160 end do;
161
162 $ 's_types' has one additonal entry, which holds the
163 $ string 'boolean'.
164 get_addr(s_types(t_max+1), sym_bool);
165
166$ initialize run time io
167 call initio;
smfb 333
smfb 334 $ initialise the setl debugger if requested
smfb 335 if (debug_flag) call inidbg;
168
169
170 end subr inienv3;
1 .=member insamp
2 subr insamp(fm);
3
4$ this routine builds a sample value for a form 'fm'. sample
5$ values are defines as follows:
6
7$ if fm is 'base(mode)' then the sample value is a null base.
8$ otherwise the sample value is an omega of the proper type.
9
10$ omega values are just like any other values except that their
11$ is_om bits are set. this means that omegas can take up an
12$ arbritrarily large amount of storage. when we build an omega
13$ for use as a sample value, we always build the smallest
14$ possible omega for that type.
15
16$ the representation of a standard omega is a function of its
17$ type:
18
19$ short types:
20
21$ for all short types the minimal omega is a specifier
22$ with the proper type code and a value of zero.
23
24$ strings:
25
26$ the omega for an indirect string is a specifier with:
27
28$ type: indicates t_oistring
29$ value: string specifier for null string
30
31$ tuples:
32
33$ the omega for a tuple is a specifier with:
34
35$ type: indicates t_otuple
36$ value: pointer to null tuple
37
38$ for mixed tuples the null tuple has a maxindx equal to
39$ the length of the tuple; otherwise it has maxindx of 1.
40
41$ sets, maps, and bases
42
43$ the omega for a set, map or base is a specifier with:
44
45$ type: indicates t_oset, etc.
46$ value: pointer to null set, etc.
47
48$ the null set has lognhedrs = 0.
49
50$ the sample values for sets, tuples, and bases are allocated in
51$ the dynamic part of the heap, while long strings, ints, and reals
52$ are allocated in the constants area.
53
54 size fm(ps); $ form to be processed
55
56 size tp(ps); $ ft_type
57 size spec(hs); $ specifier for sample value
58 size p(ps); $ heap pointer
59 size n(ps); $ number of tuple elements
60 size tup_form(ps); $ tuple form
61 size ebsz(ps); $ size of ebs
62 size sz(ps); $ block size
63 size nl(ps); $ nlmaps
64 size im(hs); $ map image
65 size mapc(ps); $ map code ft_xxx
66 size base(ps); $ pointer to base
67 size om_val(hs); $ omega value
68 size j(ps); $ loop index
69 size ht(ps); $ pointer to hash table
70 size tmp(ps); $ pointer to template
71 size lsw(ps); $ ls_word value
72 size lsb(ps); $ ls_bit value
73 size bits(ps); $ number of bits for packed object
74 size vals(ps); $ number of values for packed tuple
75 size key_val(hs); $ value of key for packed tuples
76 size key_addr(ps); $ address of key
77 size elmt(hs); $ specifier for element
78 size p1(ps); $ heap pointer
79 size p2(ps); $ heap pointer
80
81 size nulllc(ssz); $ returns null string
82 size getht(ps); $ gets hash table
83
84 access q1vars; $ access global q1 variables.
85 access nscod; $ access variables global to cod.
86
87
88$ begin by initializing a specifier 'spec' with the proper
89$ type code, etc. then jump on its type to fill in its value.
90
91$ note that omegas always have their share bits set. this way if the
92$ programmer tries to use them destructively, we will enter the copy
93$ routine and abort.
94
95 tp = ft_type(fm);
96
97 build_spec(spec, tmap(tp), 0); $ initialize specifier
98 is_shared_ spec = yes;
99
100 go to case(tp) in f_min to f_max;
101
102/case(f_gen)/ $ general
103
104 go to esac;
105
106/case(f_sint)/ $ short int
107
108 value_ spec = ft_low(fm);
109 go to esac;
110
111/case(f_sstring)/ $ short chars
112
113/case(f_atom)/ $ short atom
114
115 go to esac;
116
117
118/case(f_latom)/ $ 'long' atom
119
120$ strangely enough, we should never reach this label. the only
121$ objects stored as long atoms are elements of plex bases; their
122$ form always indicates f_elmt.
123
124 go to bad_type;
125
126/case(f_elmt)/ $ element
127
128 base = ft_base(fm); $ form of base
129 p1 = value(ft_samp(base)); $ pointer to base
130
131 if ft_type(base) = f_base then
smfd 177 p1 = template(p1);
134
135 else $ plex base
smfd 178 otype_ spec = t_olatom;
137 end if;
smfd 179 value_ spec = p1;
smfd 180
138
139 go to esac;
140
141/case(f_int)/
142
mjsa 10 spec = putintli(om_int);
mjsa 11 is_shared_ spec = yes;
152 go to esac;
153
154
155/case(f_string)/
156
157 value_ spec = nulllc(0);
158 go to esac;
159
160/case(f_real)/ $ real
161
162 get_const(real_nw, p);
163
164 htype(p) = h_real;
165 hlink(p) = 0;
166 rval(p) = om_real;
167
168 value_ spec = p;
169
170 go to esac;
171
172/case(f_uint)/ $ untyped int
173
174 spec = om_int;
175 go to esac;
176
177/case(f_ureal)/ $ untyped real
178
179 spec = om_real;
180 go to esac;
181
182/case(f_tuple)/ $ standard tuple
183
184/case(f_ituple)/
185
186/case(f_rtuple)/
187
188 n = 1; $ number of elements for tuple
189 if (ft_lim(fm) ^= 0) n = ft_lim(fm);
190
191 get_heap(talloc(n), p);
192
193 htype(p) = htmap(tp);
194 hlink(p) = 0;
195
196 hform(p) = fm;
197
198 maxindx(p) = n;
199 is_range(p) = no;
200
201 set_nelt(p, 0);
202 set_hash(p, hc_tuple);
203
204 om_val = heap(ft_samp(ft_elmt(fm)));
205
206 do j = 0 to n;
207 tcomp(p, j) = om_val;
208 end do;
209
210 value_ spec = p;
211
212 go to esac;
213
214
215/case(f_ptuple)/ $ packed tuple
216
217 n = 1; $ number of elements for tuple
218 if (ft_lim(fm) ^= 0) n = ft_lim(fm);
219
220$ get packing information. if this is a packed tuple of ints, then
221$ packinfo will set:
222
223$ key_val: value of pt_key field
224$ key_addr: 0
225
226$ we will simply store key_val.
227
228$ if this is a packed tuple of elements of b then packinfo will set:
229
230$ key_val: 0
231$ key_addr: address of symbol table entry for key
232
233$ the key itself will not be available until the base is
234$ initialized, so we will build a list of the heap words which need
235$ the key.
236
237 call packinfo(bits, vals, key_val, key_addr, fm);
238
239 sz = (n-1)/vals + 1 + hl_ptuple;
240 get_heap(sz, p);
241
242 htype(p) = h_ptuple;
243 hlink(p) = 0;
244
245 hform(p) = fm;
246
247 maxindx(p) = n;
248 is_range(p) = no; $ should never be tested
249
250 ptbits(p) = bits;
251 ptvals(p) = vals;
252
253 if key_addr = 0 then
254 ptkey(p) = key_val;
255 else
256 ptkey(p) = heap(key_addr);
257 heap(key_addr) = p + off_ptkey;
258 end if;
259
260 set_nelt(p, 0);
261 set_hash(p, hc_tuple);
262
263 do j = 0 to n;
264 pcomp(p, j) = 0; $ nb. zero corresponds to omega
265 end do;
266
267 value_ spec = p;
268
269 go to esac;
270
271
272/case(f_mtuple)/ $ mixed tuple
273
274 n = ft_lim(fm);
275
276 get_heap(talloc(n), p);
277
278 htype(p) = h_tuple;
279 hlink(p) = 0;
280
281 hform(p) = fm;
282
283 maxindx(p) = n;
284 is_range(p) = no; $ should never be tested
285
286 set_nelt(p, 0);
287 set_hash(p, hc_tuple);
288
289 tcomp(p, 0) = heap(ft_samp(f_gen));
290
291 p1 = ft_elmt(fm); $ mttab pointer
292
293 do j = 1 to n;
294 tcomp(p, j) = heap(ft_samp(mttab(p1+j)));
295 end do;
296
297 value_ spec = p;
298
299 go to esac;
300
301/case(f_uset)/ $ standard set
302
303 get_heap(hl_uset, p); $ build set header
304
305 htype(p) = h_uset;
306 hlink(p) = 0;
307 hform(p) = fm;
308
309 is_based(p) = no;
310 is_elset(p) = no;
311 is_map(p) = no;
312 is_smap(p) = no;
313 is_mmap(p) = no;
314
315 if (ft_type(ft_elmt(fm)) = f_elmt) is_elset(p) = yes;
316
317 set_nelt(p, 0);
318 set_hash(p, hc_set);
319
320 ebsz = hl_eb + 1;
321 hashtb(p) = getht(ebsz, h_ebs); $ get hash table
322
323$ store omegas in eb-s.
324 ebspec(template(p)) = heap(ft_samp(ft_elmt(fm)));
325
326 value_ spec = p;
327
328 go to esac;
329
330/case(f_umap)/ $ standard map
331
332 get_heap(hl_umap, p); $ build set header
333
334 htype(p) = h_umap;
335 hlink(p) = 0;
336 hform(p) = fm;
337
338 is_based(p) = no;
339 is_elset(p) = no;
340 is_map(p) = yes;
341 is_smap(p) = no;
342 is_mmap(p) = no;
343
344 set_nelt(p, 0);
345 set_hash(p, hc_set);
346
347 ebsz = hl_eb + 2; $ ebsize
348 hashtb(p) = getht(ebsz, h_ebm); $ get hash table
349
350$ store omegas in eb-s.
351 ebspec(template(p)) = heap(ft_samp(ft_dom(fm)));
352
353 if (ft_type(ft_dom(fm)) = f_elmt) is_elset(p) = yes;
354
355 mapc = ft_mapc(fm);
356 im = heap(ft_samp(ft_im(fm)));
357
358 if mapc = ft_smap then
359 is_smap(p) = yes;
360
361 elseif mapc = ft_mmap then
362 is_mmap(p) = yes;
363 is_multi_ im = yes;
364 is_om_ im = no;
365 end if;
366
367 ebimag(template(p)) = im;
368
369 value_ spec = p;
370
371 go to esac;
372
373/case(f_lset)/ $ local subset
374
375 assert fm > f_max;
376
377 get_heap(hl_lset, p);
378
379 htype(p) = h_lset;
380 hlink(p) = 0;
381 hform(p) = fm;
382
383 is_elset(p) = yes;
384 is_based(p) = yes;
385 is_map(p) = no;
386 is_smap(p) = no;
387 is_mmap(p) = no;
388
389 set_nelt(p, 0);
390 set_hash(p, hc_set);
391
392 base = value(ft_samp(ft_base(fm)));
393
394 if ^ is_fplex(fm) then $ point to base
395 tmp = template(base);
396 hashtb(p) = hashtb(base);
397 end if;
398
399$ set ls_word and ls_bit
400
401$ objects are stored in element blocks in the following order:
402
403$ 1. local maps
404$ 2. local untyped integer maps
405$ 3. local untyped real maps
406$ 4. local packed maps
407$ 5. local sets
408
409$ note that 1-4 correspond to the order of ft_type codes for
410$ local maps.
411
412 ls_word(p) = ft_pos(fm);
413 ls_bit(p) = ft_bit(fm);
414
415 if is_fplex(fm) then
416 .f. ls_bit(p), 1, heap(base+ls_word(p)) = 0;
417 else
418 .f. ls_bit(p), 1, heap(tmp+ls_word(p)) = 0;
419 end if;
420
421 value_ spec = p;
422
423 go to esac;
424
425/case(f_lmap)/
426
427/case(f_limap)/ $ local integer map
428
429/case(f_lrmap)/ $ local real map
430
431 assert fm > f_max;
432
433 get_heap(hl_lset, p);
434
435 htype(p) = htmap(tp);
436 hlink(p) = 0;
437 hform(p) = fm;
438
439 is_elset(p) = yes;
440 is_based(p) = yes;
441 is_map(p) = yes;
442 is_smap(p) = no;
443 is_mmap(p) = no;
444
445 set_nelt(p, 0);
446 set_hash(p, hc_set);
447
448 base = value(ft_samp(ft_base(fm)));
449
450 if ^ is_fplex(fm) then $ point to base
451 tmp = template(base);
452 hashtb(p) = hashtb(base);
453 end if;
454
455 ls_word(p) = ft_pos(fm);
456 ls_bit(p) = ft_bit(fm);
457
458$ fill in image in base
459 im = heap(ft_samp(ft_im(fm))); $ omega image
460
461 mapc = ft_mapc(fm);
462
463 if (mapc = ft_smap) is_smap(p) = yes;
464
465 if mapc = ft_mmap then
466 is_mmap(p) = yes;
467 is_multi_ im = yes;
468 is_om_ im = no;
469 end if;
470
471 if is_fplex(fm) then
472 heap(base + ls_word(p)) = im;
473 else
474 heap(tmp + ls_word(p)) = im;
475 end if;
476
477 value_ spec = p;
478
479 go to esac;
480
481
482/case(f_lpmap)/ $ local packed map
483
484 assert fm > f_max;
485
486 get_heap(hl_lpmap, p);
487
488 call packinfo(bits, vals, key_val, key_addr, fm);
489
490 htype(p) = htmap(tp);
491 hlink(p) = 0;
492 hform(p) = fm;
493
494 is_elset(p) = yes;
495 is_based(p) = yes;
496 is_map(p) = yes;
497 is_smap(p) = yes;
498 is_mmap(p) = no;
499
500 ls_bits(p) = bits;
501
502 if key_addr = 0 then
503 ls_key(p) = key_val;
504 else
505 ls_key(p) = heap(key_addr);
506 heap(key_addr) = p + off_ls_key;
507 end if;
508
509 set_nelt(p, 0);
510 set_hash(p, hc_set);
511
512 base = value(ft_samp(ft_base(fm)));
513
514 if ^ is_fplex(fm) then $ point to base
515 tmp = template(base);
516 hashtb(p) = hashtb(base);
517 end if;
518
519 ls_word(p) = ft_pos(fm);
520 ls_bit(p) = ft_bit(fm);
521
522 $ nb. a pack index of zero indicates omega
523 if is_fplex(fm) then
524 .f. ls_bit(p), bits, heap(base+ls_word(p)) = 0;
525 else
526 .f. ls_bit(p), bits, heap(tmp+ls_word(p)) = 0;
527 end if;
528
529 value_ spec = p;
530
531 go to esac;
532
533/case(f_rset)/
534
535 assert fm > f_max;
536
537 $ allocate a remote set with a one-word bit string
538 get_heap(rsalloc(rs_bpw-1), p);
539
540 htype(p) = h_rset;
541 hlink(p) = 0;
542 hform(p) = fm;
543
544 is_based(p) = yes;
545 is_elset(p) = yes;
546 is_map(p) = no;
547 is_smap(p) = no;
548 is_mmap(p) = no;
549
550 rs_maxi(p) = rs_bpw - 1;
551 rsword(p, 1) = 0;
552
553 set_nelt(p, 0);
554 set_hash(p, hc_set);
555
556 base = value(ft_samp(ft_base(fm)));
557 hashtb(p) = hashtb(base);
558
559 value_ spec = p;
560
561 go to esac;
562
563/case(f_rmap)/
564
565/case(f_rimap)/
566
567/case(f_rrmap)/
568
569 assert fm > f_max;
570
571 get_heap(hl_rmap, p);
572
573 htype(p) = htmap(tp);
574 hlink(p) = 0;
575 hform(p) = fm;
576
577 is_based(p) = yes;
578 is_elset(p) = yes;
579 is_map(p) = yes;
580 is_smap(p) = no;
581 is_mmap(p) = no;
582
583 base = value(ft_samp(ft_base(fm)));
584 hashtb(p) = hashtb(base);
585
586 set_nelt(p, 0);
587 set_hash(p, 0);
588
589 mapc = ft_mapc(fm);
590
591 if (mapc = ft_smap) is_smap(p) = yes;
592 if (mapc = ft_mmap) is_mmap(p) = yes;
593
594
595$ get a pointer to the sample for the embedded tuple and copy it.
596
597 p1 = value(ft_samp(ft_tup(fm)));
598
599 sz = tuplen(p1); $ size of tuple
600 get_heap(sz, p2);
601
602 do j = 0 to sz-1; $ copy data block
603 heap(p2 + j) = heap(p1 + j);
604 end do;
605
606$ if this is an mmap, iterate over the tuples components, clearing
607$ their is_om bits and setting their is_multi bits.
608
609 if mapc = ft_mmap then
610 do j = 0 to maxindx(p2);
611 is_om_ tcomp(p2, j) = no;
612 is_multi_ tcomp(p2, j) = yes;
613 end do;
614 end if;
615
616 value_ spec = p;
617
618 go to esac;
619
620
621/case(f_rpmap)/ $ remote packed map
622
623 assert fm > f_max;
624
625 get_heap(hl_rmap, p);
626
627 htype(p) = htmap(tp);
628 hlink(p) = 0;
629 hform(p) = fm;
630
631 is_based(p) = yes;
632 is_elset(p) = yes;
633 is_map(p) = yes;
634 is_smap(p) = yes;
635 is_mmap(p) = no;
636
637 base = value(ft_samp(ft_base(fm)));
638 hashtb(p) = hashtb(base);
639
640 set_nelt(p, 0);
641 set_hash(p, 0);
642
643$ get a pointer to the sample for the embedded tuple and copy it.
644
645 p1 = value(ft_samp(ft_tup(fm)));
646
647 sz = ptuplen(p1); $ size of tuple
648 get_heap(sz, p2);
649
650 do j = 0 to sz-1; $ copy data block
651 heap(p2 + j) = heap(p1 + j);
652 end do;
653
654 value_ spec = p;
655
656 go to esac;
657
658
659/case(f_pbase)/ $ plex base
660
661 assert fm > f_max;
662
663 sz = ft_bit(fm);
664 nl = ft_num(fm, f_lmap);
665
666 get_heap(sz, p);
667
668 htype(p) = h_latom;
669 hlink(p) = 0;
670 la_form(p) = fm;
671 la_nwords(p) = sz;
672 la_nlmaps(p) = nl;
673
674 value_ spec = p;
675
676 go to esac;
677
678
679/case(f_base)/ $ base
680
681 assert fm > f_max;
682
683 get_heap(hl_base, p); $ build set header
684
685 htype(p) = h_base;
686 hlink(p) = 0;
687 hform(p) = fm;
688
689 set_nelt(p, 0);
690 set_hash(p, hc_set);
691
692 ebsz = ft_bit(fm);
693 nl = ft_num(fm, f_lmap);
694
695 blink(p) = 0;
696 rlink(p) = 0;
697 nlmaps(p) = nl;
698
699 hashtb(p) = getht(ebsz, h_ebb);
700
701 tmp = template(p);
702
703 elmt = heap(ft_samp(ft_elmt(fm)));
704
705 ebspec(tmp) = elmt;
706 ebhash(tmp) = 0;
707 ebform(tmp) = fm;
708 ebindx(tmp) = 1;
709
710 if (ft_lim(fm) ^= 0) heap(ft_samp(fm)-1) = 0;
711
712 value_ spec = p;
713
714 go to esac;
715
716
717/case(f_error)/ $ error
718
719 go to esac;
720
721
722
723
724/case(f_lab)/ $ label
725
726 build_spec(spec, t_olab, 0);
727 go to esac;
728
729
730/case(f_proc)/
731
732 build_spec(spec, t_proc, 0);
733 go to esac;
734
735
736
737/case(f_memb)/
738
739/case(f_uimap)/
740
741/case(f_urmap)/
742
743/bad_type/
744
745$ we reach here if objects of type 'fm' are allowed to appear in the
746$ heap. there are two possibilities:
747
748$ 1. fm is one of the standard types f_xxx. we simply give it a
749$ sample value of 0.
750
751$ 2. fm is something else. this indicates a compiler error.
752
753 if fm <= f_max then
754 spec = 0;
755 go to esac;
756
757 else
758 call abort('insamp found illegal type');
759 end if;
760
761
762/esac/ $ end of case statement
763
764$ install spec and return
765 heap(ft_samp(fm)) = spec;
766
767
768 end subr insamp;
1 .=member getht
2 fnct getht(ebsz, ebtp);
3
4$ this routine builds a hash table and returns a pointer to it.
bnda 19$ the hash table has one single hash header. the arguments to
6$ the routine are:
7
8$ ebsz: size of eb-s
9$ ebtp: htype of eb-s
10
11
bnda 20 size ebsz(ps); $ value for element-block-size (ebsz)
bnda 21 size ebtp(ps); $ value for heap-block-header-type (htype)
14
bnda 22 size getht(ps); $ pointer to hash table (returned)
16
bnda 23 size tmp(ps); $ pointer to template block
bnda 24 size hdr(ps); $ pointer to hash header
19
20 access q1vars; $ access global q1 variables.
21 access nscod; $ access variables global to cod.
22
23
24 get_heap(hl_ht + ebsz + hl_htb, getht); $ get heap block
25
26 htype(getht) = h_ht;
27 hlink(getht) = 0;
28 neb(getht) = 0;
29 lognhedrs(getht) = 0;
30
31 tmp = getht + hl_ht; $ point to template
32 hdr = tmp + ebsz; $ single hash header
33
34 htype(tmp) = ebtp;
35 hlink(tmp) = 0;
36 is_ebhedr(tmp) = yes; $ set template
37 is_ebtemp(tmp) = yes;
38 eblink(tmp) = hdr;
39 ebsize(tmp) = ebsz;
40
41 htype(hdr) = h_htb;
42 hlink(hdr) = 0;
43 is_ebhedr(hdr) = yes; $ set hash header
44 is_ebtemp(hdr) = no;
45 eblink(hdr) = tmp;
46
47
48 end fnct getht;
1 .=member packinfo
2 subr packinfo(bits, vals, key_val, key_addr, fm);
3
4$ this routine finds out various information about a packed object
5$ from its form.
6
7 size bits(ps), $ set to ptbits or ls_bits of object
8 vals(ps), $ set to ptvals of object
9 key_val(hs), $ key for packed ints
10 key_addr(ps), $ address of key for packed elements
11 fm(ps); $ form of object
12
13 size ptyp(ps), $ type of packed value
14 base(ps), $ type of base
15 mx(ps); $ maximim packed value
16
17 access q1vars; $ access global q1 variables.
18 access nscod; $ access variables global to cod.
19
20
21 if ft_type(fm) = f_ptuple then
22 ptyp = ft_elmt(fm);
23 else
24 ptyp = ft_im(fm);
25 end if;
26
27 if ft_type(ptyp) = f_sint then
28 build_spec(key_val, t_int, 0);
29 key_addr = 0;
30
31 mx = ft_lim(ptyp);
32 bits = .fb. mx;
33
34 else $ element of constant base
35 base = ft_base(ptyp);
36
37 key_val = 0;
38 key_addr = ft_samp(base) - 1;
39
40 mx = ft_lim(base);
41 bits = .fb. mx;
42 end if;
43
44 vals = hs / bits;
45
46 return;
47
48 end subr packinfo;
1 .=member incnst
2 subr incnst(nam);
3
4$ this routine initializes the run time value of a constant 'nam'.
5$ the symbol table entry for the constant has already been
6$ initialized to the proper omega; we call various library
7$ routines to build the run time value.
8
9$ constant sets, tuples, and bases are built in the dynamic part
10$ of the heap, while strings, ints, and reals are built in the
11$ static area.
12
13$ when constants are first built by the semantic pass they are
14$ given very basic types such as 'set(*)'. named constants can
15$ be given more detailed types through the repr statement.
16
17$ when the semantic pass processes the repr for a constant, it
18$ does not do a complete check to see that the repr is consistent
19$ with the value; instead it does a 1 level check. this means that
20$ whenver we build a composite object we must check whether its
21$ elements have been built with the desired type and call the
22$ libraries convert routine if not.
23
24$ note that 'convert' always returns omega if it is unsuccessful.
25
26
27 size nam(ps); $ symbol to be processed
28
29 size fm(ps); $ its form
30 size addr(ps); $ its address
31 size vp(ps); $ val pointer
32 size vl(ps); $ val length
33
34 size j(ps); $ loop index
35 size s(ps); $ pointer to set
36 size len(ps); $ length of string
37 size str(sds_sz); $ value of string
38 size ss(ssz); $ string specifier
39 size p(ps), p1(ps); $ heap pointers
40 size nam1(ps); $ symbol table pointer for element
41 size xfm(ps); $ element type
42 size elmt(hs); $ specifier for element
43 size comp(hs); $ specifier for tuple component
44 size spec(hs); $ specifier
45 size dom(hs); $ domain element
46 size im(hs); $ image
47 size im1(hs); $ old image
48 size v(ws); $ word of val entry
49 size tup(hs); $ tuple specifier
50 size bform(ps); $ form of base
51 size base(ps); $ pointer to base
52 size f1(ps); $ form of base element
53 size f2(ps); $ form of case map domain element
54 size j1(ps), j2(ps); $ loop indices
55 size card(ps); $ number of elements in set/map
56 size n(ps); $ number of dereference/locate operations
57
58 size tstart(ps); $ value of 't' at start of routine
59
60 size nulllc(ssz); $ allocates null string
61 size nulltup(hs); $ allocates null tuple
62 size fval(hs); $ retrieves map image
63 size rset2(hs); $ builds set of two elements
64 size withs(hs); $ adds element to set
65 size setform(hs); $ forms n-elenemt set of form fm
66 size tupform(hs); $ forms n-elenemt tuple of form fm
67 size convert(hs); $ general conversion utility
68 size err_val(hs); $ error value utility
69
70 access q1vars; $ access global q1 variables.
71 access nscod; $ access variables global to cod.
72
73
74 tstart = t;
75
76 fm = form(nam);
77 addr = address(nam);
78
79 vp = vptr(nam);
80 vl = vlen(nam);
81
82 is_om(addr) = no; $ clear is_om
83
84 go to case(ft_type(fm)) in f_min to f_max;
85
86/case(f_gen)/ $ general
87
88 call abort('reached bad label in incnst');
89
90/case(f_sint)/
91
92 value(addr) = val(vp);
93 return;
94
95/case(f_sstring)/ $ short string
96
97$ unpack val entry into sds string 'str'
98 str = 0;
99
100 do j = 0 to vl-1;
101 .f. 1 + j*ws, ws, str = val(vp+j);
102 end do;
asca 19 .+ascebc if (ascebc_flag) call ascsds(str); $ convert to ascii
103
104$ repack into setl short character string
105 sc_nchars_ heap(addr) = .len. str;
106
107 do j = 1 to .len. str;
stra 75 scchar(heap(addr), j) = .ch. j, str;
109 end do;
110
111 return;
112
113/case(f_atom)/ $ atom
114
115 $ the only constants of type 'f_atom' are 'true' and 'false'.
116 value(addr) = val(vp);
117 return;
118
119/case(f_latom)/ $ long atom
120
121 $ there should be no constant of this type.
122 go to fail;
123
124/case(f_elmt)/
125
126$ get a pointer to the base and convert the element to the right type,
127$ then do a locate.
128
129 bform = ft_base(form(nam)); $ form of base
130 base = value(ft_samp(bform)); $ pointer to base
131
132$ get element and convert to proper type if necessary.
133
134 nam1 = val(vp); $ symtab pointer for element
135 if (nam1 = sym_om) go to fail;
136
137 elmt = heap(address(nam1));
138
139 if ^ can_assign(ft_elmt(bform), form(nam1)) then
140 elmt = convert(elmt, ft_elmt(bform));
141 if (is_om_ elmt) go to fail;
142 end if;
143
144 call locate(p, elmt, base, yes);
145
146 value(addr) = p;
147
148 return;
149
150/case(f_int)/ $ long int
151
152$ try to build a short integer. if this is impossible, build a
153$ 1 word long int.
154
155 v = val(vp);
156
mjsa 12 put_intval(v, spec);
mjsa 13 heap(addr) = spec;
172 return;
173
174/case(f_string)/ $ indirect string
175
176$ unpack val entry into sds string 'str'
177 str = 0;
178
179 do j = 0 to vl-1;
180 .f. 1 + j*ws, ws, str = val(vp+j);
181 end do;
asca 20 .+ascebc if (ascebc_flag) call ascsds(str); $ convert to ascii
182
183$ repack into setl long string
184 len = .len. str;
stra 76
stra 77 if len <= sc_max then $ allocate short string
stra 78 if len = 0 then $ allocate null string
stra 79 build_spec(spec, t_string, 0);
stra 80 else
stra 81 spec = spec_char; $ one-character template
stra 82 scchar(spec, 1) = .ch. 1, str; $ copy character
stra 83 end if;
stra 84 heap(addr) = spec;
stra 85 return;
stra 86 end if;
stra 87
185 ss = nulllc(len);
186
187 ss_len(ss) = len;
188
189 do j = 1 to len;
190 icchar(ss, j) = .ch. j, str;
191 end do;
192
193 value(addr) = ss;
194 return;
195
196/case(f_real)/ $ real
197
198 get_const(real_nw, p);
199 htype(p) = h_real;
200
201 rval(p) = val(vp);
202
203 value(addr) = p;
204 return;
205
206/case(f_uint)/ $ untyped int and real
207
208/case(f_ureal)/
209
210 heap(addr) = val(vp);
211 return;
212
213/case(f_tuple)/ $ tuples
214
215/case(f_ptuple)/
216
217/case(f_mtuple)/
218
219/case(f_rtuple)/
220
221/case(f_ituple)/
222
223$ push the values of the components, then call the tuple former.
224
225$ there is one unusual context in which we build constant pairs:
226$ as elements of the maps used for case statements. in this case
227$ the labels do not recieve symbol table entries, and so we must
228$ look directly in symtab for their values.
229
230 do j = 0 to vl-1;
231 nam1 = val(vp+j); $ symtab pointer to component
232
233 if ft_type(fm) = f_mtuple then
234 xfm = mttab(ft_elmt(fm)+1+j);
235 else
236 xfm = ft_elmt(fm);
237 end if;
238
239 if nam1 = sym_om then
240 comp = heap(ft_samp(xfm));
241 push1(comp);
242
243 elseif symtype(nam1) = f_lab then
244 build_spec(comp, t_lab, labval(nam1));
245 push1(comp);
246
247 else
248 comp = heap(address(nam1));
249
250 if ^ can_assign(xfm, form(nam1)) then
251 if is_om_ comp then
252 comp = heap(ft_samp(xfm));
253
254 elseif xfm = f_ureal & form(nam1) = f_real then
255 comp = rval(value_ comp);
256
257 elseif xfm = f_uint & is_fint(form(nam1)) then
258 get_intval(comp, comp);
259
260 else
261 comp = convert(comp, xfm);
262 if (is_om_ comp) go to fail;
263 end if;
264 end if;
265
266 push1(comp);
267
268 if is_funt(xfm) then $ push skip word
269 build_spec(spec, t_skip, 2);
270 push1(spec);
271 end if;
272 end if;
273
274 end do;
275
276 heap(addr) = tupform(fm, vl);
277 is_shared(addr) = yes;
278
279 if (is_om(addr)) go to fail;
280
281 return;
282
283/case(f_uset)/ $ standard set
284
285/case(f_lset)/ $ local subset
286
287/case(f_rset)/ $ remote subset
288
289/case(f_umap)/ $ standard map
290
291/case(f_lmap)/ $ local map
292
293/case(f_rmap)/ $ remote map
294
295/case(f_lpmap)/ $ local packed map
296
297/case(f_limap)/ $ local integer map
298
299/case(f_lrmap)/ $ local real map
300
301/case(f_rpmap)/ $ remote packed map
302
303/case(f_rimap)/ $ remote integer map
304
305/case(f_rrmap)/ $ remote real map
306
307 xfm = ft_elmt(fm);
308
309 if is_fplex(fm) & is_fmap(fm) then $ local map(_ plex base)
310 do j = 0 to vl-1;
311 nam1 = val(vp+j);
312 elmt = heap(address(nam1));
313
314 if form(nam1) ^= xfm then
315 elmt = convert(elmt, xfm);
316 end if;
317
318 if (is_om_ elmt) go to fail;
319
320 dom = tcomp(value_ elmt, 1);
321 im = tcomp(value_ elmt, 2);
322
323 im1 = fval(value(addr), value_ dom, no);
324
325 if is_om_ im1 then
326 im1 = im;
327 elseif is_multi_ im1 then
328 im1 = withs(im1, im, yes);
329 is_multi_ im1 = yes;
330 else
331 im1 = rset2(im, im1);
332 is_multi_ im1 = yes;
333 end if;
334
335 call sfval(value(addr), value_ dom, im1);
336 end do;
337
338 elseif is_fplex(fm) then $ local set(_ plex base)
339 do j = 0 to vl-1;
340 nam1 = val(vp+j);
341 if (form(nam1) ^= xfm) go to fail;
342
343 elmt = heap(address(nam1));
344 call sfval(value(addr), value_ elmt, yes);
345 end do;
346
347 else $ any other set
348
349 card = 0;
350
351 do j = 0 to vl-1;
352 nam1 = val(vp+j); $ symtab pointer to element
353
354 if nam1 = sym_om then
355 go to fail;
356
357 else
358 elmt = heap(address(nam1)); $ value of element
359
360 if is_casemap(nam) & is_fbsd(form(nam)) then
361
362 f1 = ft_dom(fm); $ map domain form
363 f2 = form(val(vptr(nam1))); $ domain value form
364 n = 0;
365
366 while ft_type(f1) = f_elmt & f1 ^= f2;
367 if (ft_type(ft_base(f1)) = f_pbase) quit;
368 f1 = ft_elmt(ft_base(f1)); n = n + 1;
369 end while;
370
371 dom = tcomp(value_ elmt, 1); $ q2 domain element
372
373 if ^ can_assign(f1, f2) then
374 dom = convert(dom, f1);
375
376 if is_om_ dom then
377 call codwrn(02, val(vptr(nam1)));
378 cont do j;
379 end if;
380 end if;
381
382 do j1 = n to 1 by -1;
383 $ check whether map domain is in proper base
384 f1 = ft_dom(fm);
385 do j2 = 2 to j1;
386 f1 = ft_elmt(ft_base(f1));
387 end do;
388 f2 = ft_base(f1); $ form of base
389 base = value(ft_samp(f2)); $ pointer to base
390 call locate(p, dom, base, no);
391
392 if ^ loc_found & ft_lim(f2) > 0 then
393 call codwrn(03, val(vptr(nam1)));
394 cont do j;
395 end if;
396
397 build_spec(dom, t_elmt, p);
398 end do;
399 end if;
400
401 if ^ can_assign(xfm, form(nam1)) then
402 elmt = convert(elmt, xfm);
403 end if;
404
405 if is_om_ elmt then
406 if is_casemap(nam) then
407 call codwrn(04, val(vptr(nam1)));
408 cont do j;
409 else
410 go to fail;
411 end if;
412 end if;
413 end if;
414
415 push1(elmt); card = card + 1;
416 end do;
417
418 heap(addr) = setform(fm, card);
419 is_shared(addr) = yes;
420
421 if is_om(addr) then
422 if is_casemap(nam) then
423 call ermsg(26, 0);
424 tstart = t;
425 return;
426 else
427 go to fail;
428 end if;
429 end if;
430 end if;
431
432 return;
433
434/case(f_base)/ $ base
435
436$ building a constant base involves two things:
437
438$ 1. locating all the elements in the base
439
440$ 2. building a tuple containing the elements of the base in their
441$ order of insertion. the symbol table entry immediately after
442$ the entry for the base is set to contain a specifier for this
443$ tuple.
444
445$ note that the symbol table entry for the tuple now contains the
446$ head of a list of heap words which must be set to the specifier
447$ for the tuple.
448
449$ we begin by allocating the tuple then do steps (1) and (2) together.
450
451 tup = nulltup(f_tuple, vl);
452
453$ fill in all the heap words which refer to the tuple.
454 p = address(nam) - 1; $ first word to be filled in
455
456 while p ^= 0;
457 p1 = heap(p); $ next word to be filled in
458
459 heap(p) = tup;
460 p = p1;
461 end while;
462
463 p1 = value_ tup;
464 nelt(p1) = vl;
465
466 s = value(address(nam)); $ pointer to base
467
468 do j = 0 to vl-1;
469 nam1 = val(vp+j);
470 elmt = heap(address(nam1));
471
472 call locate(p, elmt, s, yes);
473
474 build_spec(comp, t_elmt, p);
475 tcomp(p1, ebindx(p)) = comp;
476 end do;
477
478 return;
479
480
481/case(f_pbase)/ $ plex base
482
483/case(f_proc)/ $ procedure
484
485/case(f_memb)/ $ member
486
487/case(f_lab)/ $ labels
488
489/case(f_error)/
490
491/case(f_uimap)/
492
493/case(f_urmap)/
494
495 return;
496
497/fail/ $ illegal repr for constant
498
499 call ermsg(10, nam);
500
501 t = tstart;
502
503 return;
504
505 end subr incnst;
1 .=member initio
2 subr initio;
3
4$ this routine initializes various sets and maps used by the
5$ run time i/o routines. these maps are:
6
7$ fid: sends file names into file numbers. its initial
8$ value is null.
9
10$ free: set of free file numbers. initially null.
11
12$ fmax: maximum file number allocated so far. initially 5.
13
14$ fmodes: maps file modes into io_xxx codes.
15
16
17 size str(hs), $ specifier for string
18 int(hs), $ specifier for int
19 tup(hs); $ specifier for tuple
20 size i(ps); $ loop index
21
22 size bldstr(hs), $ builds string from sds
23 tupform(hs), $ tuple former
24 setform(hs), $ set former
25 nullset(hs); $ builds null set
26
27 access q1vars; $ access global q1 variables.
28 access nscod; $ access variables global to cod.
29
30 +* fmodes_max = 13 **
31 size fmodes_str(.sds. 12); dims fmodes_str(fmodes_max);
32 size fmodes_typ(ps); dims fmodes_typ(fmodes_max);
33
34 .=zzyorg z
35
36 +* s(str,typ) = $ initialize map table
37 data fmodes_str(zzyz) = str;
38 data fmodes_typ(zzyz) = typ;
39 **
40
41 s('print', io_print)
42 s('coded', io_get)
43 s('binary', io_read)
44 s('coded-in', io_get)
45 s('coded-out', io_put)
46 s('binary-in', io_read)
47 s('binary-out', io_write)
48 s('text', io_get)
49 s('text-in', io_get)
50 s('text-out', io_put)
51 s('foreign', io_read)
52 s('foreign-in', io_read)
53 s('foreign-out', io_write)
54 macdrop(s)
55
56 $ build 'fid'
57 heap(s_fid) = nullset(f_umap, 0);
58
59
60$ build free
61 heap(s_free) = nullset(f_uset, 0);
62
63$ build fmax. note that the following file numbers are
64$ reserved
65
66$ 1: standard input file
67$ 2: standard output file
68$ 3: q2 file
69$ nb. this file is used as an "private" file by the library.
70$ for example, file id 3 is used to write the dynamic storage
71$ dump.
72$
73 build_spec(heap(s_fmax), t_int, 3)
74
75
76 .-mc.
77$ build fmode
78 do i = 1 to fmodes_max;
79 str = bldstr(fmodes_str(i));
80 build_spec(int, t_int, fmodes_typ(i));
81 push2(str,int);
82 tup = tupform(f_tuple, 2);
83 push1(tup);
84 end do;
85
86 heap(s_fmode) = setform(f_umap, fmodes_max);
87 .+mc.
88 $ here to build map for full lower and full upper case
89 size cases(hs);
90 do i = 1 to fmodes_max;
91 size cstr(.sds. 12);
92 cstr = fmodes_str(i);
93 do cases = 1 to 2;
94 if cases=1 then call stpc(cstr); $ primary case
95 else call stsc(cstr); end if;
asca 21 .+ascebc if (ascebc_flag) call ascsds(cstr); $ convert to ascii
96 str = bldstr(cstr);
97 build_spec(int, t_int, fmodes_typ(i));
98 push2(str,int);
99 tup = tupform(f_tuple, 2);
100 push1(tup);
101 end do;
102 end do;
103
104 heap(s_fmode) = setform(f_umap, 2*(fmodes_max));
105 ..mc
106
107 end subr initio;
1 .=member inidbg
2 subr inidbg;
3$
4$ this routine initialises various tables used by the debugging and
5$ trace package.
6$
7 size p(ps); $ pointer to tuple
8 size opc(ps); $ q2 opcode
9 size j1(ps); $ loop indices
10 size j2(ps);
11 size j3(ps);
12
13 size nulltup(hs); $ allocates null tuple
14
15 access q1vars; $ access global q1 variables.
16 access nscod; $ access variables global to cod.
17
18
19$ we start by initialising s_ovar, the packed tuple which flags opcodes
20$ with o-variables, i.e. the is_ovar predicate.
21$
22$ note that the second argument to nulltup is the expected nelt of the
23$ tuple; nulltup adds a breathing space of 1/3 to this before it allo-
24$ cates the tuple. since this tuple will never grow, we counter this
25$ otherwise wasted allocation by requesting less space than we actually
26$ need.
27$
28$ also note that we rely here on the fact that the components of packed
29$ tuples are initialised to omega, i.e. zero.
30
31 heap(s_ovar) = nulltup(f_pt11, (2*q2_maximum+2)/3);
32 p = value(s_ovar);
33
34 nelt(p) = q2_maximum;
35
36 do j1 = q1_minimum to q1_maximum;
37 if ( ^ ops_ovar(j1)) cont;
38
39 opc = std_op(j1); if (opc ^= 0) pt11comp(p, opc) = 1;
40
41 do j2 = f_min to f_max;
42 opc = spec_op(j1, j2); if (opc = 0) cont do j2;
43 pt11comp(p, opc) = 1;
44 end do;
45 end do;
46
47 do j1 = q1_of to q1_sofa;
48 do j2 = f_umap to f_rpmap;
49 do j3 = ft_min to ft_max;
50 opc = of_op(j1, j2, j3); if (opc = 0) cont do j3;
51 pt11comp(p, opc) = 1;
52 end do;
53 end do;
54 end do;
55
56 do j1 = q2_of to q2_ofarmm;
57 opc = share_op(j1); if (opc = 0) cont do j1;
58 pt11comp(p, opc) = 1;
59 end do;
60
61 pt11comp(p, q2_inci) = 1;
62 pt11comp(p, q2_newat2) = 1;
63 pt11comp(p, q2_set1) = 1; pt11comp(p, q2_set2) = 1;
64 pt11comp(p, q2_tup1) = 1; pt11comp(p, q2_tup2) = 1;
65
66
67 end subr inidbg;
1 .=member bintype
2 fnct bin_type(opc, form1, form2);
3
4$ this routine determines the result type for +, -, *, and mod.
5$ f1 and f2 are the forms of the inputs.
6
7 size opc(ps), $ q1 opcode
8 form1(ps), $ input forms
9 form2(ps);
10
11 size bin_type(ps); $ form of result
12
13 size f1(ps), $ dereferenced input forms
14 f2(ps);
15
16 access q1vars; $ access global q1 variables.
17 access nscod; $ access variables global to cod.
18
19
20 f1 = deref_typ(form1);
21 f2 = deref_typ(form2);
22
23 if opc = q1_slash then $ real or untyped real
24 if is_funt(f1) & is_funt(f2) then
25 bin_type = f_ureal;
26 else
27 bin_type = f_real;
28 end if;
29
30 elseif opc = q1_div then $ int or untyped int
31 if is_funt(f1) & is_funt(f2) then
32 bin_type = f_uint;
33 else
34 bin_type = f_int;
35 end if;
smfb 336 elseif is_fint(f1) & is_fint(f2) then
smfb 337 if is_funt(f1) & is_funt(f2) then
smfb 338 bin_type = f_uint;
smfb 339 else
smfb 340 bin_type = f_int;
smfb 341 end if;
smfb 342
smfb 343 elseif is_freal(f1) & is_freal(f2) then
smfb 344 if is_funt(f1) & is_funt(f2) then
smfb 345 bin_type = f_ureal;
smfb 346 else
smfb 347 bin_type = f_real;
smfb 348 end if;
smfb 349
smfb 350 elseif is_fstr(f1) & is_fstr(f2) then
smfb 351 bin_type = f_string;
smfb 352
36
37 elseif f1 = f2 then
38$
39$ in general, a binary operation on two objects of type 'f1' will
40$ yield a result of type 'f1'. there are three exceptions:
41$
42$ 1. since the difference of two short ints may be a long int,
43$ we set bin_type = f_int.
44$
45$ 2. the union of two smaps may be a map or smap. since we dont
46$ know which we set the result to f_gen.
47$
48$ 3. the addition of two known-length tuples will be a known-length
49$ tuple, but of different length. since we do not have a specific
50$ form for the result available, we return f_tuple.
51$
52 if opc = q1_sub & ft_type(f1) = f_sint then
53 bin_type = f_int;
54 elseif opc = q1_add & ft_mapc(f1) = ft_smap then
55 bin_type = f_gen;
56 elseif opc = q1_add & is_ftup(f1) & ft_lim(f1) ^= 0 then
57 bin_type = f_tuple;
58 else
59 bin_type = f1;
60 end if;
61
71 elseif is_ftup(f1) & is_ftup(f2) then
72 bin_type = f_tuple;
73
74 elseif is_fset(f1) & is_fset(f2) then
75 bin_type = f_uset;
76
77 elseif opc = q1_mult then $ look for string * int
78
79 if is_fstr(f1) & is_fint(f2) then
80 bin_type = f_string;
81 elseif is_fint(f1) & is_fstr(f2) then
82 bin_type = f_string;
83 elseif is_ftup(f1) & is_fint(f2) then $ look for tuple * int
84 bin_type = f_tuple;
85
86 elseif is_fint(f1) & is_ftup(f2) then $ look for int * tuple
87 bin_type = f_tuple;
88
89 else
90 bin_type = f_gen;
91 end if;
92
93 else $ error
94 bin_type = f_gen;
95 end if;
96
97
98 end fnct bin_type;
1 .=member dereftyp
1 .=member elmttype
2 fnct elmt_type(f);
3
4$ this routine returns the element type of a form
5
6 size f(ps); $ form of set, etc
7
8 size elmt_type(ps); $ result
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
14 if ft_type(f) = f_mtuple then
15 elmt_type = f_gen;
16
17 elseif is_fset(f) ! is_ftup(f) then
18 elmt_type = ft_elmt(f);
19
20 elseif is_fstr(f) then
21 elmt_type = f_string;
22
23 else
24 elmt_type = f_gen;
25 end if;
26
27
28 end fnct elmt_type;
1 .=member domtype
2 fnct dom_type(f);
3
4$ this routine returns the domain type of a form. for the moment
5$ we consider tuples to be maps on integers.
6
7 size f(ps); $ form of set, etc
8
9 size dom_type(ps); $ result
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14
15 if is_fset(f) then
16 dom_type = ft_dom(f);
17
18 elseif is_ftup(f) ! is_fstr(f) then
19 dom_type = f_sint;
20
21 else
22 dom_type = f_gen;
23 end if;
24
25
26 end fnct dom_type;
1 .=member imtype
2 fnct im_type(f);
3
4$ this routine determines the image type of an object, i.e. the
5$ type returned if we apply f(x) to it.
6
7 size f(ps);
8
9 size im_type(ps);
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14
15 if is_fset(f) then
16 im_type = ft_im(f);
17 if (ft_mapc(f) = ft_mmap) im_type = elmt_type(im_type);
18
19 elseif ft_type(f) = f_mtuple then
20 im_type = f_gen;
21
22 elseif is_ftup(f) then
23 im_type = ft_elmt(f);
24
25 elseif is_fstr(f) then
26 im_type = f_string;
27
28 else
29 im_type = f_gen;
30 end if;
31
32
33 end fnct im_type;
1 .=member cntype
2 fnct cn_type(fm, i);
3
4$ this routine returns the type of the i-th component of a tuple
5
6 size fm(ps), $ form of tuple
7 i(ps); $ number of component
8
9 size cn_type(ps); $ form returned
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14
15 if ft_type(fm) = f_mtuple then
16 if i = 0 ! i > ft_lim(fm) then
17 cn_type = f_gen;
18 else
19 cn_type = mttab(ft_elmt(fm) + i);
20 end if;
21
22 else
23 cn_type = ft_elmt(fm);
24 end if;
25
26
27 end fnct cn_type;
1 .=member compntyp
2 fnct compn_typ(fm, x);
3
4$ this routine determines the result type of an 'of' operation
5$ y := f(x). its arguments are:
6
7$ fm: the type of f.
8$ x: symtab pointer to x.
9
10$ it is similar to im_type except that it catches the case where
11$ f is a mixed tuple and x is an integer constant.
12
13 size fm(ps), $ form of f
14 x(ps); $ symtab pointer to x
15
16 size compn_typ(ps); $ form returned
17
18 size v(ps); $ value of index
19
20 access q1vars; $ access global q1 variables.
21 access nscod; $ access variables global to cod.
22
23
24 if ft_type(fm) = f_mtuple then
25 if is_const(x) & is_fint(form(x)) then
26 v = symval(x);
27 if v <= ft_lim(fm) then
28 compn_typ = mttab(ft_elmt(fm) + v);
29 else
30 compn_typ = f_gen;
31 end if;
32 else
33 compn_typ = f_gen;
34 end if;
35
36 elseif is_fstr(fm) then
37 compn_typ = f_string;
38
39 elseif is_ftup(fm) then
40 compn_typ = ft_elmt(fm);
41
42 elseif is_fmap(fm) then
43 if ft_mapc(fm) = ft_mmap then
44 compn_typ = ft_elmt(ft_im(fm));
45 else
46 compn_typ = ft_im(fm);
47 end if;
48
49 else
50 compn_typ = f_gen;
51 end if;
52
53
54 end fnct compn_typ;
1 .=member rsettype
2 fnct rset_type(f);
3
4$ this routine determines the range set type of an object, i.e.
5$ the mode returned by applying f<> to it.
6
7 size f(ps);
8
9 size rset_type(ps);
10
11 access q1vars; $ access global q1 variables.
12 access nscod; $ access variables global to cod.
13
14
15 if is_fset(f) then
16 if ft_mapc(f) = ft_mmap then
17 rset_type = ft_im(f);
smfc 37 elseif ft_mapc(f) = ft_map then
smfc 38 rset_type = ft_imset(f);
18 else
19 rset_type = f_uset;
20 end if;
21
22 else
23 rset_type = f_gen;
24 end if;
25
26
27 end fnct rset_type;
1 .=member argtype
2 fnct arg_type(rout, n);
3
4$ this routine returns the type of a procedure argument. its arguments
5$ are:
6
7 size rout(ps), $ symtab pointer to routine
8 n(ps); $ argument number
9
10 size nn(ps), $ copy of n.
11 vp(ps), $ vptr for procedure
12 vary(1), $ true of procedure has variable number of args
13 na(1); $ number of arguments
14
15 size arg_type(ps); $ type returned
16
17 size fm(ps); $ type of routine
18
19 access q1vars; $ access global q1 variables.
20 access nscod; $ access variables global to cod.
21
22
23 fm = form(rout);
24
25 if fm = f_proc then
26 arg_type = f_gen;
27
28 else
29 vp = vptr(rout); $ look for variable number of arguments
30 vary = val(vp+1);
31 na = val(vp+2);
32
33 nn = n;
34 if (vary & nn > na) nn = na;
35
36 arg_type = mttab(ft_elmt(fm)+nn);
37 end if;
38
39
40 end fnct arg_type;
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 access q1vars; $ access global q1 variables.
26 access nscod; $ access variables global to cod.
27
28$ we begin by jumping on the error number to assign the proper string
29$ to 'string'. we use the following convenience macro:
30
31 +* er(n, str) =
32 /case(n)/ string = str; go to esac;
33 **
34
35
suna 50 +* max_case = 30 **
37 if ( ^ (1 <= n & n <= max_case)) n = 0;
38 go to case(n) in 0 to max_case;
39
40 er(00, 'valid error text')
41 er(01, 'valid target for conversion to string');
42 er(02, 'valid types for newat')
43 er(03, 'valid types for conversion')
44 er(04, 'to have proper number of arguments');
45 er(05, 'valid left hand side for -x := nl-');
46 er(06, 'valid left hand side for -x := nult-');
47 er(07, 'valid target for conversion to integer');
48 er(08, 'valid target for conversion to real');
49 er(09, 'no conversions to label or procedure');
50 er(10, 'constant to have desired type');
51 er(11, 'valid use of object based on plex base');
52 er(12, 'to be typed when using full run time error checking');
53 er(13, '-back- control card option');
54 er(14, 'setl binary tuple header')
55 er(15, 'setl binary tuple trailer')
56 er(16, 'setl binary integer')
57 er(17, 'setl binary real')
58 er(18, 'setl binary boolean')
59 er(19, 'valid setl binary boolean value')
60 er(20, 'setl binary string')
61 er(21, 'to be assigned only within its defined range')
62 er(22, 'to have a set mode')
63 er(23, 'a main program - code file cannot be executed')
64 er(24, 'valid source for conversion to string')
65 er(25, 'valid source for conversion to atom')
66 er(26, 'a valid case map (are all case tag values unique ?)')
suna 51 er(27, ': internal compiler error (symtype(lab) ^= lab)')
suna 52 er(28, ': internal compiler error (opcode(i1) ^= lab/tag)')
suna 53 er(29, ': internal compiler error (i2 = 0)')
suna 54 er(30, ': internal compiler error (opcode(i2) ^= lab/tag)')
67
68/esac/ $ print error message
69
70 put, skip; $ emit blank line, position next line
71 call contlpr(27, yes); $ start to echo to the terminal
72 .+s10 put, '?'; $ emit s10 error message marker
73 .+s20 put, '?'; $ emit s20 error message marker
74 put ,'*** error ' :n ,i;
75 if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
76 if (currout ^= 0) put ,'.' :symsds(currout) ,a;
77 if (curmemb ^= 0) put ,'.' :stmt_count ,i;
suna 55 if n < 27 ! 30 < n then put ,': expect '; end if;
79 if (nam ^= 0) put :symsds(nam) ,a ,x(1);
80 put: string, a, ' ***', skip;
81
82 call contlpr(27, no); $ stop to echo to the terminal
83
84 if et_flag then $ error trace desired
85 put, 'q1 address: ': now, il, skip;
86
87 if codep ^= 0 then
88 put, skip, 'last q2 instruction: ', skip;
89 call dinst(codep);
90 end if;
91 end if;
92
93 if unit_type = unit_proc then $ procedure scope
94 $ nb. if an error message is printed during fixup, etc., then
95 $ we should not insert this quadruple since we have not yet
96 $ started the code block. the result is an ill-formated heap.
97 call em2(q2_error, 0, 0, 0);
98 end if;
99
100 error_count = error_count + 1;
101
102 if error_count > cel then
103 call contlpr(27, yes);
104 put, '*** code generator error limit exceeded ***', skip;
105 call contlpr(27, no);
106
107 call codtrm(yes);
108
109 elseif 14 <= n & n <= 20 then
110 call abort('permanent i/o error in setl q1 interface');
suna 56
suna 57 elseif 27 <= n & n <= 30 then
suna 58 call codtrm(yes); $ abnormal termination
111 end if;
112
113 macdrop(max_case)
114
115
116 end subr ermsg;
1 .=member codwrn
2 subr codwrn(n, nam);
3$
4$ this routine is similar to ermsg, except that it prints warnings.
5$
6$ warnings have the form:
7$
8$ *** warning xxx at line yyy - zzz ***
9$
10$ where:
11$
12$ xxx is the warning number
13$ yyy is the current line number
14$ nam is a symbol table pointer
15$ zzz is the individual message
16$
17$ if 'nam' is non-zero, we print the name of the symbol table entry.
18$
19 size n(ps); $ message number
20 size nam(ps); $ optional symtab pointer
21
22 size string(sds_sz); $ string for message
23
24 access q1vars; $ access global q1 variables.
25 access nscod; $ access variables global to cod.
26$
27$ we begin by jumping on the error number to assign the proper string
28$ to 'string'. we use the following convenience macro:
29$
30 +* wa(n, str) =
31 /case(n)/ string = str; go to esac;
32 **
33
34
35 +* max_case = 04 **
36 if ( ^ (1 <= n & n <= max_case)) n = 0;
37 go to case(n) in 0 to max_case;
38
39 wa(00, 'valid warning text')
40 wa(01, 'is an unsatisfied external procedure')
41 wa(02, 'is an unreachable case tag')
42 wa(03, 'is an unreachable case tag')
43 wa(04, 'is an unreachable case tag')
44
45/esac/ $ print warning
46
47 put ,skip;
48 call contlpr(27, yes); $ start to echo to the terminal
49 .+s10 put ,':'; $ emit standard s10 warning character
50 .+s20 put ,':'; $ emit standard s20 warning character
51 put ,'*** warning ' :n ,i;
52 if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
53 if (currout ^= 0) put ,'.' :symsds(currout) ,a;
54 if (curmemb ^= 0) put ,'.' :stmt_count ,i;
55 put ,': ';
56 if (nam ^= 0) put :symsds(nam) ,a ,x(1);
57 put :string ,a ,' ***' ,skip;
58 call contlpr(27, no); $ stop to echo to the terminal
59
60
61
62 end subr codwrn;
1 .=member sdump
2
3
4 .+tr notrace entry;
5
6
7 subr sdump;
8
9$ this routine dumps symtab and various related tables.
10
11
12 call symdump; $ dump symtab
13 call valdump; $ dump val
14 call fmdump; $ dump formtab
15 call mtdump; $ dump mttab
16
17
18 end subr sdump;
1 .=member symdump
2 subr symdump;
3
4$ this routine dumps symtab. the dump is formatted in columns,
5$ with a series of column headings printed at standard intervals.
6
7
8 size j(ps), $ loop index
9 str(sds_sz), $ symbol name as sds
10 lines(ps); $ number of lines since last heading
11
12 access q1vars; $ access global q1 variables.
13 access nscod; $ access variables global to cod.
14
15
16 put, skip(2), column(7), 's y m t a b d u m p - ':
17 symsds(curunit), a, skip(2);
18
19 lines = lines_max; $ set to force new heading
20
21 do j = 1 to symtabp;
22 lines = lines + 1;
23
24 if lines > lines_max then $ print heading
25 put, skip(2), column(7),
26 'index name vptr vlen alias form ',
27 'addr labval altrep rp tm sk rd wr pm st ld re ',
28 'mb sn al bk',
29 skip, column(7),
30 '------------------------------------------------',
31 '------------------------------------------------',
32 '-----------',
33 skip(2);
34
35 lines = 1;
36 end if;
37
38 str = symsds(j);
39 if (.len. str > 10) .len. str = 10;
40
41 put, column(007): j, i,
42 column(014): str, a,
43 column(027): vptr(j), i,
44 column(034): vlen(j), i,
45 column(041): alias(j), i,
46 column(048): form(j), i,
47 column(055): address(j), i,
48 column(062): labval(j), i,
49 column(069): altrep(j), i,
50 column(076): is_repr(j), i,
51 column(079): is_temp(j), i,
52 column(082): is_stk(j), i,
53 column(085): is_read(j), i,
54 column(088): is_write(j), i,
55 column(091): is_param(j), i,
56 column(094): is_store(j), i,
57 column(097): is_ldef(j), i,
58 column(100): is_rec(j), i,
59 column(103): is_memb(j), i,
60 column(106): is_seen(j), i,
61 column(109): is_alias(j), i,
62 column(112): is_back(j), i,
63 skip;
64 end do;
65
66
67 end subr symdump;
1 .=member valdump
2 subr valdump;
3
4$ this routine dumps 'val'. we dump val in byte format, three
5$ entries per line. the first column contains the first third of
6$ val, the second column the next third, etc.
7
8
9 size rows(ps), $ number of rows in dump
10 tab(ps), $ current tab position
11 i(ps), $ index over rows
12 j(ps), $ index over columns
13 indx(ps); $ index over val
14
15 access q1vars; $ access global q1 variables.
16 access nscod; $ access variables global to cod.
17
18
19 put, skip(2), column(7), 'v a l d u m p - ':
20 symsds(curunit), a, skip(2);
21
22 rows = (valp-1)/3 + 1; $ number of rows
23
24 do i = 1 to rows;
25 do j = 1 to 3;
26 indx = (j-1) * rows + i;
27 tab = 7 + (j-1) * 35;
28
29 put, column(tab): indx, i, '.',
30 column(tab+7): val(indx), bl;
31 end do;
32
33 put, skip;
34 end do;
35
36 put, skip(2);
37
38
39 end subr valdump;
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 access q1vars; $ access global q1 variables.
63 access nscod; $ access variables global to cod.
64
65
66 put ,skip(4)
67 ,'f o r m t a b d u m p - '
68 :symsds(curunit) ,a
69 ,skip(2);
70
71
72 lines = lines_max; $ set to force new heading
73
74 do fm = 0 to formtabp;
75
76 lines = lines + 1;
77
78 if lines > lines_max then $ print heading
79 put ,skip(2)
80 ,'index type mapc elmt dom im imset '
81 ,'base deref low lim hsh nlt samp'
82 ,skip
83 ,'-------------------------------------------'
84 ,'-------------------------------------'
85 ,skip;
86
87 lines = 1;
88 end if;
89
90 put ,column(01) :fm ,i
91 ,column(07) :ftname(ft_type(fm)) ,a;
92
93 if (is_fmap(fm)) put ,column(15) :mname(ft_mapc(fm)) ,a;
94
95 put ,column(20) :ft_elmt(fm) ,i
96 ,column(26) :ft_dom(fm) ,i
97 ,column(32) :ft_im(fm) ,i
98 ,column(38) :ft_imset(fm) ,i
99 ,column(44) :ft_base(fm) ,i
100 ,column(50) :ft_deref(fm) ,i;
101
102 put ,column(56);
103 if (ft_type(fm) = f_sint) put :ft_low(fm) ,i;
104 if (is_floc(fm) ! is_fbase(fm)) put :ft_bit(fm) ,i;
105
106 put ,column(62);
107 if (ft_type(fm) = f_sint) put :ft_lim(fm) ,i;
108 if (ft_type(fm) = f_proc) put :ft_lim(fm) ,i;
109 if (is_ftup(fm) ! is_fbase(fm)) put :ft_lim(fm) ,i;
110 if (is_floc(fm)) put :ft_pos(fm) ,i;
111 if (is_frem(fm) & is_fmap(fm)) put :ft_tup(fm) ,i;
112
113 put ,column(68);
114 if (is_ftup(fm) ! is_fset(fm)) put :ft_hashok(fm) ,i;
115
116 put ,column(72);
117 if (is_ftup(fm) ! is_fset(fm)) put :ft_neltok(fm) ,i;
118
119 put ,column(76) :ft_samp(fm) ,i;
120
121 if is_fbase(fm) then
122 put ,column(86);
123 do j1 = f_lset to f_lpmap; if ( ^ is_floc(j1)) cont do j1;
124 put :ft_num(fm, j1) ,i(5);
125 end do;
126 end if;
127
128 put ,skip;
129 end do;
130
131
132 end subr fmdump;
1 .=member mtdump
2 subr mtdump;
3
4$ this routine dumps 'mttab'. we dump mttab in byte format, three
5$ entries per line. the first column contains the first third of
6$ mttab, the second column the next third, etc.
7
8
9 size lines(ps); $ number of lines since last heading
10 size j1(ps), j2(ps); $ loop indices
11
12 access q1vars; $ access global q1 variables.
13 access nscod; $ access variables global to cod.
14
15
16 put, skip(2), column(7), 'm t t a b d u m p - ':
17 symsds(curunit), a, skip(2);
18
19 lines = lines_max; $ set to force new heading
20
21 do j1 = 0 to (mttabp+9)/10;
22 lines = lines + 1;
23 if lines > lines_max then
24 put ,skip(2)
25 ,'index ...0 ...1 ...2 ...3 ...4'
26 ,' ...5 ...6 ...7 ...8 ...9'
27 ,skip
28 ,'-------------------------------------------'
29 ,'-----------------------------------'
30 ,skip;
31 lines = 1;
32 end if;
33
34 put :j1 ,i(5) ,'. ';
35
36 do j2 = 0 to 9; if (j1*10+j2 > mttabp) quit do j1;
37 if j1*10+j2 = 0 then put ,x(7); cont do j2; end if;
38 put :mttab(j1*10+j2) ,i(6) ,x;
39 end do;
40
41 put ,skip;
42
43 end do;
44
45 put ,skip(2);
46
47
48 end subr mtdump;
1 .=member formfm
2 fnct format_form(frm);
3
4$ this function formats a form table entry into a human-readable string.
5
6 size frm(ps); $ form table pointer
7
8 size format_form(hs); $ specifier for result string
9
10 size fm(ps); $ parameter to recursive part of function
11 size j(ps); $ loop index
12 size new(ps); $ junk pointer to get extra heap word
13 size len(ps); $ current length of str
14 size ss1(ssz); $ string specifier
15 size p(ps); $ pointer to long string data block
16 size ptr1(ps); $ pointer to current word
17 size ofs1(ps); $ offset in current word
18 size c(chsiz); $ character code to be written
19 size int1(ws); $ integer
20 size int2(ws); $ integer
21 size int3(ws); $ integer
22 size str1(sds_sz); $ sds to be written
23 size ret_sds(ps); $ return address for write_sds subroutine
24 size ret_int(ps); $ return address for write_int subroutine
25
26
27 .=zzyorg b $ reset counter for stack offsets
28 size tstart(ps); $ initial recursion stack pointer
29 local(retpt); $ return pointer
30 local(f1); $ form table pointer
31 local(j1); $ loop index
32 local(n1); $ loop limit
33
34 size nulllc(ssz); $ allocates null string
35 size var_id(sds_sz); $ returns symbol table name as sds
36
37 access q1vars; $ access global q1 variables.
38 access nscod; $ access variables global to cod.
39
40
41 ss1 = nulllc(1);
42 p = ss_ptr(ss1); ptr1 = p + hl_lchars; ofs1 = chorg; len = 0;
43
44
45 .=zzyorg a $ reset counter for return label
46 fm = frm; $ copy parameter
47 tstart = t; $ save recusion stack pointer
48
49/entry/ $ recursive entry pointer
50 r_entry; $ increament recursion stack
51
52 go to case(ft_type(fm)) in f_gen to f_lab;
53
54
55/case(f_gen)/ $ general
56
57 str1 = 'general'; l_call(write_sds);
58 go to exit;
59
60
61/case(f_sint)/ $ short integer
62
63 str1 = 'integer '; l_call(write_sds);
64 int1 = ft_low(fm); l_call(write_int);
65 str1 = '..'; l_call(write_sds);
66 if ft_lim(fm) = 0 then int1 = maxsi; else int1 = ft_lim(fm); end;
67 l_call(write_int);
68 go to exit;
69
70
71/case(f_sstring)/ $ short character string
72
73/case(f_string)/ $ long character string
74
75 str1 = 'string'; l_call(write_sds);
76 go to exit;
77
78
79/case(f_atom)/ $ short atom
80
81/case(f_latom)/ $ long atom
82
83 str1 = 'atom'; l_call(write_sds);
84 go to exit;
85
86
87/case(f_elmt)/ $ element-of-base
88
89 str1 = 'elmt '; l_call(write_sds);
90 str1 = var_id(ft_samp(ft_base(fm)), 0); l_call(write_sds);
91 go to exit;
92
93
94/case(f_uint)/ $ untyped integer
95
96 str1 = 'untyped integer'; l_call(write_sds);
97 go to exit;
98
99
100/case(f_ureal)/ $ untyped real
101
102 str1 = 'untyped real'; l_call(write_sds);
103 go to exit;
104
105
106/case(f_int)/ $ long or short integer
107
108 str1 = 'integer'; l_call(write_sds);
109 go to exit;
110
111
112/case(f_real)/ $ real
113
114 str1 = 'real'; l_call(write_sds);
115 go to exit;
116
117
118/case(f_ptuple)/ $ packed tuple
119
120 str1 = 'packed '; l_call(write_sds);
121
122
123/case(f_ituple)/ $ tuple(untyped integer)
124
125/case(f_rtuple)/ $ tuple(untyped real)
126
127/case(f_tuple)/ $ standard tuple
128
129 str1 = 'tuple('; l_call(write_sds);
130 f1 = fm; fm = ft_elmt(f1);
131 r_call;
132 if ft_lim(f1) ^= 0 then
133 str1 = ')('; l_call(write_sds);
134 int1 = ft_lim(f1); l_call(write_int);
135 end if;
136 c = 1r); l_call(write_char);
137 go to exit;
138
139
140/case(f_mtuple)/ $ mixed tuple
141
142 str1 = 'tuple('; l_call(write_sds);
143 f1 = fm; n1 = ft_lim(fm); j1 = 1;
144 while j1 <= n1;
145 fm = mttab(ft_elmt(f1)+j1);
146 r_call;
147 if j1 < n1 then str1 = ', '; l_call(write_sds); end if;
148 j1 = j1 + 1;
149 end while;
150 c = 1r); l_call(write_char);
151 go to exit;
152
153
154/case(f_uset)/ $ standard set
155
156 f1 = fm; fm = ft_elmt(fm);
157 if ft_type(fm) = f_elmt then
158 str1 = 'sparse set(';
159 else
160 str1 = 'set(';
161 end if;
162 l_call(write_sds);
163 r_call;
164 c = 1r); l_call(write_char);
165 go to exit;
166
167
168/case(f_lset)/ $ local subset
169
170 str1 = 'local set('; l_call(write_sds);
171 f1 = fm; fm = ft_elmt(fm);
172 r_call;
173 c = 1r); l_call(write_char);
174 go to exit;
175
176
177/case(f_rset)/ $ remote subset
178
179 str1 = 'remote set('; l_call(write_sds);
180 f1 = fm; fm = ft_elmt(fm);
181 r_call;
182 c = 1r); l_call(write_char);
183 go to exit;
184
185
186/case(f_umap)/ $ standard map
187
188 f1 = fm; fm = ft_dom(fm);
189 if ft_type(fm) = f_elmt then
190 str1 = 'sparse '; l_call(write_sds);
191 end if;
192 if ft_mapc(f1) = ft_map then str1 = 'map(';
193 elseif ft_mapc(f1) = ft_smap then str1 = 'smap(';
194 elseif ft_mapc(f1) = ft_mmap then str1 = 'mmap<';
195 else assert 0;
196 end if;
197 l_call(write_sds);
198 r_call;
199 if ft_mapc(f1) = ft_mmap then str1 = '! '; else str1 = ') '; end;
200 l_call(write_sds);
201 fm = ft_im(f1);
202 r_call;
203 go to exit;
204
205
206/case(f_lpmap)/ $ local packed map
207
208 str1 = 'packed '; l_call(write_sds);
209
210
211/case(f_limap)/ $ local integer map
212
213/case(f_lrmap)/ $ local real map
214
215/case(f_lmap)/ $ local map
216
217 str1 = 'local '; l_call(write_sds);
218 if ft_mapc(fm) = ft_map then str1 = 'map(';
219 elseif ft_mapc(fm) = ft_smap then str1 = 'smap(';
220 elseif ft_mapc(fm) = ft_mmap then str1 = 'mmap<';
221 else assert 0;
222 end if;
223 l_call(write_sds);
224 f1 = fm; fm = ft_dom(f1);
225 r_call;
226 if ft_mapc(f1) = ft_mmap then str1 = '! '; else str1 = ') '; end;
227 l_call(write_sds);
228 fm = ft_im(f1);
229 r_call;
230 go to exit;
231
232
233/case(f_rpmap)/ $ remote packed map
234
235 str1 = 'packed '; l_call(write_sds);
236
237
238/case(f_rimap)/ $ remote integer map
239
240/case(f_rrmap)/ $ remote real map
241
242/case(f_rmap)/ $ remote map
243
244 str1 = 'remote '; l_call(write_sds);
245 if ft_mapc(fm) = ft_map then str1 = 'map(';
246 elseif ft_mapc(fm) = ft_smap then str1 = 'smap(';
247 elseif ft_mapc(fm) = ft_mmap then str1 = 'mmap<';
248 else assert 0;
249 end if;
250 l_call(write_sds);
251 f1 = fm; fm = ft_dom(f1);
252 r_call;
253 if ft_mapc(f1) = ft_mmap then str1 = '! '; else str1 = ') '; end;
254 l_call(write_sds);
255 fm = ft_im(f1);
256 r_call;
257 go to exit;
258
259
260/case(f_base)/ $ base
261
262 f1 = fm; fm = ft_elmt(f1);
263 str1 = 'base('; l_call(write_sds);
264 r_call;
265 c = 1r); l_call(write_char);
266 go to exit;
267
268
269/case(f_pbase)/ $ plex base
270
271 str1 = 'plex base'; l_call(write_sds);
272 go to exit;
273
274
275/case(f_uimap)/ $ unbased untyped integer map
276
277/case(f_urmap)/ $ unbased untyped real map
278
279 str1 = '(illegal form)'; l_call(write_sds);
280 go to exit;
281
282
283/case(f_error)/ $ error
284
285 str1 = 'error'; l_call(write_sds);
286 go to exit;
287
288
289/case(f_proc)/ $ procedure or operator
290
291 f1 = fm; n1 = ft_lim(fm);
292 if n1 = 0 then
293 str1 = 'procedure'; l_call(write_sds);
294 else
295 str1 = 'procedure('; l_call(write_sds);
296 j1 = 1;
297 while 1;
298 fm = mttab(ft_elmt(f1)+j1);
299 r_call;
300 if (j1 = n1) quit while;
301 if j1 < n1-1 then str1 = ', '; else str1 = ') '; end if;
302 l_call(write_sds);
303 j1 = j1 + 1;
304 end while;
305 end if;
306 go to exit;
307
308
309/case(f_memb)/ $ member
310
311 str1 = 'member'; l_call(write_sds);
312 go to exit;
313
314
315/case(f_lab)/ $ label
316
317 str1 = 'label'; l_call(write_sds);
318 go to exit;
319
320
321/exit/ $ recursive exit point
322
323 r_exit; $ pop recursion stack
324
325 if t ^= tstart then $ return to previous invocation
326 go to rlab(retpt) in 1 to zzya;
327 end if;
328
329 ss_len(ss1) = len;
330 build_spec(format_form, t_istring, ss1);
331 return;
332
333
334/write_sds/ $ local subroutine to write sds
335
336 ret_sds = retpt;
337 do j = 1 to .len. str1;
338 c = .ch. j, str1; l_call(write_char);
339 end do;
340
341 go to rlab(ret_sds) in 1 to zzya;
342
343
344/write_int/ $ local subroutine to write unsigned int
345
346 ret_int = retpt;
347
348 if int1 = 0 then
349 c = 1r0; l_call(write_char);
350 else
351 int2 = int1 / 10; int3 = 1;
352 while int2 > 0;
353 int2 = int2 / 10; int3 = int3 * 10;
354 end while;
355 while int3 > 0;
356 c = charofdig(int1 / int3); l_call(write_char);
357 int1 = int1 - (int1 / int3) * int3; int3 = int3 / 10;
358 end while;
359 end if;
360
361 go to rlab(ret_int) in 1 to zzya;
362
363
364/write_char/ $ local subroutine to write single char
365
366 .f. ofs1, chsiz, heap(ptr1) = c; len = len + 1;
367 if ofs1 = chlst then
368 assert p + lc_nwords(p) = h;
369 assert lcalloc(len) = lc_nwords(p);
370 get_heap(1, ptr1); ofs1 = chorg;
371 lc_nwords(p) = lc_nwords(p) + 1;
372 else
373 ofs1 = ofs1 + chinc;
374 end if;
375
376 go to rlab(retpt) in 1 to zzya;
377
378
379 end fnct format_form;
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
9 size j(ps), $ loop index
10 str(sds_sz); $ routine name as sds
11
12 access q1vars; $ access global q1 variables.
13 access nscod; $ access variables global to cod.
14
15
16 put, skip(2), column(7), 'c o d e d u m p - ':
17 symsds(curunit), a, skip(2);
18
19 do j = 1 to blocktabp;
20
21 put, skip(2), $ print heading
22 column(07), 'block: ': j, i,
23 column(25), 'first: ': b_first(j), i,
24 skip;
25
26 call dblock(b_first(j)); $ print instructions
27 end do;
28
29
30 end subr q1dump;
1 .=member q2dump
2 subr q2dump;
3
4$ this routine dumps the current code block.
5
6 size p1(ps); $ pointer to instruction
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11 put, skip, column(7), 'code for ': symsds(curunit), a,
12 ' address = ': labval(curunit), i, skip(2);
13
14 p1 = code_org + hl_code;
15
16 while p1 < code_org + codenw(code_org);
17 call dinst(p1);
18 p1 = p1 + inst_nw;
19 end while;
20
21
22 end subr q2dump;
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 opc(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_exp) = 'exp':
25 opname(q1_eq) = 'eq':
26 opname(q1_ge) = 'ge':
27 opname(q1_lt) = 'lt':
smfb 353 opname(q1_pos) = 'pos':
28 opname(q1_in) = 'in':
29 opname(q1_incs) = 'incs':
30 opname(q1_less) = 'less':
31 opname(q1_lessf) = 'lessf':
32 opname(q1_max) = 'max':
33 opname(q1_min) = 'min':
34 opname(q1_mod) = 'mod':
35 opname(q1_atan2) = 'atan2':
36 opname(q1_mult) = 'mult':
37 opname(q1_ne) = 'ne':
38 opname(q1_notin) = 'notin':
39 opname(q1_npow) = 'npow':
40 opname(q1_slash) = 'slash':
41 opname(q1_sub) = 'sub':
42 opname(q1_with) = 'with':
43 opname(q1_not) = 'not':
44 opname(q1_even) = 'even':
45 opname(q1_odd) = 'odd':
46 opname(q1_isint) = 'is_int':
47 opname(q1_isreal) = 'is_real':
48 opname(q1_isstr) = 'is_str':
49 opname(q1_isbool) = 'is_bool':
50 opname(q1_isatom) = 'is_atom':
51 opname(q1_istup) = 'is_tuple':
52 opname(q1_isset) = 'is_set':
53 opname(q1_ismap) = 'is_map':
54 opname(q1_arb) = 'arb':
55 opname(q1_dom) = 'dom':
56 opname(q1_range) = 'range':
57 opname(q1_pow) = 'pow':
58 opname(q1_nelt) = 'nelt':
59 opname(q1_abs) = 'abs':
60 opname(q1_char) = 'char':
61 opname(q1_ceil) = 'ceil':
62 opname(q1_floor) = 'floor':
63 opname(q1_fix) = 'fix':
64 opname(q1_float) = 'float':
65 opname(q1_sin) = 'sin':
66 opname(q1_cos) = 'cos':
67 opname(q1_tan) = 'tan':
68 opname(q1_arcsin) = 'arcsin':
69 opname(q1_arccos) = 'arccos':
70 opname(q1_arctan) = 'arctan':
71 opname(q1_tanh) = 'tanh':
72 opname(q1_expf) = 'expf':
73 opname(q1_log) = 'log':
74 opname(q1_sqrt) = 'sqrt':
75 opname(q1_rand) = 'rand':
76 opname(q1_sign) = 'sign':
77 opname(q1_type) = 'type':
78 opname(q1_str) = 'str':
79 opname(q1_val) = 'val':
80 opname(q1_end) = 'end':
81 opname(q1_subst) = 'subst':
82 opname(q1_newat) = 'newat':
83 opname(q1_time) = 'time':
84 opname(q1_date) = 'date':
85 opname(q1_na) = 'na':
86 opname(q1_set) = 'set':
87 opname(q1_set1) = 'set1':
88 opname(q1_tup) = 'tup':
89 opname(q1_tup1) = 'tup1':
90 opname(q1_from) = 'from':
91 opname(q1_fromb) = 'fromb':
92 opname(q1_frome) = 'frome':
93 opname(q1_next) = 'next':
94 opname(q1_nextd) = 'nextd':
95 opname(q1_inext) = 'inext':
96 opname(q1_inextd) = 'inextd':
97 opname(q1_of) = 'of':
98 opname(q1_ofa) = 'ofa':
99 opname(q1_argin) = 'argin':
100 opname(q1_argout) = 'argout':
101 opname(q1_asn) = 'asn':
102 opname(q1_push) = 'push':
103 opname(q1_free) = 'free':
104 opname(q1_sof) = 'sof':
105 opname(q1_sofa) = 'sofa':
106 opname(q1_send) = 'send':
107 opname(q1_ssubst) = 'ssubst':
108 opname(q1_call) = 'call':
109 opname(q1_goto) = 'goto':
110 opname(q1_if) = 'if':
111 opname(q1_ifnot) = 'ifnot':
smfb 354 opname(q1_bif) = 'bif':
smfb 355 opname(q1_bifnot) = 'bifnot':
smfb 356 opname(q1_ifasrt) = 'ifasrt':
112 opname(q1_case) = 'case':
113 opname(q1_stop) = 'stop':
114 opname(q1_entry) = 'entry':
115 opname(q1_exit) = 'exit':
smfb 357 opname(q1_ok) = 'ok':
smfb 358 opname(q1_lev) = 'lev':
smfb 359 opname(q1_fail) = 'fail':
smfb 360 opname(q1_succeed) = 'succeed':
120 opname(q1_asrt) = 'asrt':
121 opname(q1_stmt) = 'stmt':
122 opname(q1_label) = 'label':
smfb 361 opname(q1_tag) = 'tag':
124 opname(q1_debug) = 'debug':
125 opname(q1_trace) = 'trace':
126 opname(q1_notrace) = 'notrace':
127 opname(q1_error) = 'error':
128 opname(q1_noop) = 'noop':
129 opname(q1_ifeq) = 'ifeq':
130 opname(q1_ifge) = 'ifge':
131 opname(q1_iflt) = 'iflt':
132 opname(q1_ifin) = 'ifin':
133 opname(q1_ifnin) = 'ifnin':
134 opname(q1_ifinc) = 'ifincs':
135 opname(q1_ifsub) = 'ifsubs':
136 opname(q1_ifne) = 'ifne';
137
138 access q1vars; $ access global q1 variables.
139 access nscod; $ access variables global to cod.
140
141
142
143 p = first;
144 lines = lines_max;
145
146 while p ^= 0;
147 lines = lines + 1;
148
149 if lines > lines_max then
150 lines = 1;
151
152 put, skip(2), column(7),
153 'index opcode args',
154 skip, column(7),
155 '----- ------ ----',
156 skip;
157 end if;
158
159 opc = opcode(p);
160
161 put, column(07): p, i,
162 column(15): opname(opc), a;
163
164 tab = 15;
165
166 do j = 1 to nargs(p); $ print arguments
167 tab = tab + 15;
168
169 if tab > 60 then
170 put, skip;
171 tab = 30;
172 end if;
173
174 if opc = q1_stmt then
175 put, column(tab): argn(p, j), i;
176
177 else
178 str = symsds(argn(p, j));
179 if (.len. str > 14) .len. str = 14;
180
181 put, column(tab): str, a;
182 end if;
183
184 end do;
185
186 put, skip;
187 p = next(p);
188 end while;
189
190
191 end subr dblock;
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 namesds(sds_sz); $ gets string from names ptr
12
13 size n(ps), $ integer to be converted
14 j(ps); $ loop index
15
16 access q1vars; $ access global q1 variables.
17 access nscod; $ access variables global to cod.
18
19 if p = 0 then
20 symsds = '';
21
22 elseif is_internal(p) then
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
32 else
33 symsds = namesds(name(p));
34 end if;
35
36
37 end fnct symsds;
1 .=member namesds
2 fnct namesds(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 namesds(sds_sz);
9
10 size j(ps), $ loop index
11 words(ps); $ number of words in names entry
12
13 access q1vars; $ access global q1 variables.
14 access nscod; $ access variables global to cod.
15
16
17 if (nam = 0) go to error;
18
19 words = n_sorg(nam)/ws;
20 if (words = 0) go to error;
21
22 do j = 0 to words-1;
23 .f. 1+j*ws, ws, namesds = names(nam+j);
24 end do;
25
26 return;
27
28/error/
29
30 namesds = '';
31
32
33 end fnct namesds;
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 size msg(.sds. 50); $ message string
8
9 access q1vars; $ access global q1 variables.
10 access nscod; $ access variables global to cod.
11
12
13 put ,skip; $ emit blank line
14 call contlpr(27, yes); $ start to echo to the terminal
15 put, '*** compiler table overflow - ': msg, a, ' ***', skip;
16 call contlpr(27, no); $ stop to echo to the terminal
17
18 error_count = error_count + 1;
19 call codtrm(yes); $ abnormal termination
20
21 end subr overfl;
1 .=member abort
2 subr abort(msg);
3
4 $ prints error message and terminates execution
5
6 size msg(.sds. 50);
7
8 access q1vars; $ access global q1 variables.
9 access nscod; $ access variables global to cod.
10
11
12 put ,skip; $ emit blank line
13 call contlpr(27, yes); $ start to echo to the terminal
14 put, '*** ': msg, a, ' ***', skip;
15 call contlpr(27, no); $ stop to echo to the terminal
16
17 error_count = error_count + 1;
18 call codtrm(yes); $ abnormal termination
19
20
21 end subr abort;
1 .=member codtrm
2 subr codtrm(abort);
3
4$ this routine terminates execution of the code generator. the flag
5$ 'abort' indicates whether normal or abnormal termination is in place.
6
7
8 size abort(1); $ flags abnormal termination
9
10 access q1vars; $ access global q1 variables.
11 access nscod; $ access variables global to cod.
12
13
sunb 44 if lcs_flag then $ print statistics
sunb 45 put ,skip; $ emit blank line
15
sunb 46 if error_count = 0 then
sunb 47 put, 'no errors were detected.', skip;
sunb 48 else
sunb 49 put, 'number of errors detected = ': error_count, i, skip;
sunb 50 end if;
sunb 51 end if;
21
22 if abort then
sunb 52 if (lcs_flag) put ,skip ,'abnormal termination.' ,skip;
24
25 if et_flag then
26 call sdump;
27 call q1dump;
28 call dumpds1;
29 end if;
30 call ltlfin(1,0);
31 end if;
32
33$ otherwise finish the environnment and write out q2.
34
35 call inienv3; $ finish initialisation of environment
36
37 err_mode = rem; $ copy error mode into environment block
38
39 write q2_file, q2_checkw, current_q2;
40 call wrheap1(q2_file); $ write the environment block
41
42 +* put_slice(file, table, first, last) =
43 write file, first, last;
44 if (first <= last) write file, table(first) to table(last);
45 **
46
47 put_slice(q2_file, heap, snam_org, snam_end)
48 put_slice(q2_file, heap, sym_org, sym_end)
49 put_slice(q2_file, heap, ca_org, h_const)
smfb 362 put_slice(q2_file, heap, ca_org+ca_lim, h_names1)
smfb 363 put_slice(q2_file, heap, h_names2, h-1)
51 put_slice(q2_file, heap, savet, h_lim)
52 put_slice(q2_file, a_formtab, 1, formtabp+1)
53 put_slice(q2_file, mttab, 1, mttabp)
54
55 macdrop(put_slice);
56
57
58
sunb 53 if lcs_flag then $ print q2 statistics
59 put ,skip ,'q2 statistics:'
60 ,skip ,'min symtab size = ' :sym_end-sym_org+1 ,i ,'. '
61 ,'min constants area = ' :h_const-ca_org ,i ,'. '
62 ,'min dynamic heap = ' :h-ca_org-ca_lim ,i ,'. '
63 ,skip ,'q2 code size = ' :code_tot ,i ,'. '
64 ,'initial heap size = ' :h-ca_org ,i ,'. '
smfa 200 ,'min heap size = ' :2*(sym_end-sym_org+1)
66 + h_const-ca_org
smfb 364 + h_names1-ca_org-ca_lim+1
smfb 365 + h-h_names2 ,i ,'. '
68 ,skip ,'exec statements = ' :stmt_tot ,i ,'. '
69 ,'q2 instructions = ' :code_tot/inst_nw ,i ,'. '
70 ,'q2 format date = ' :current_q2 ,i ,'. '
71 ,skip;
72
73 put ,skip ,'normal termination.' ,skip;
sunb 54 end if;
74
75 if .len. sq1_title then
76 file sq1_file access = release;
77 else
78 file q1_file access = release;
79 end if;
80
81 file q2_file access = release;
82
83 call ltlterm(3, 0);
84
85
86 end subr codtrm;
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 access q1vars; $ access global q1 variables.
8 access nscod; $ access variables global to cod.
9
10 put, skip(2), column(7),
11 '*** fatal error detected by system at line ':
12 stmt_count, i, skip(2);
13
14 if (^ et_flag) return; $ trace not requested
15
16 call sdump; $ dump symtab
17 call q1dump; $ dump q1
18
19
20 end subr usratp;
1 .=member grbcol
2
3$ this deck contains routines for a dummy garbage collector.
4
5 subr grbcol;
6
7
8 call abort('insufficient main storage');
9
10
11 end subr grbcol;
12
13 +* d(rout) = $ dummy routine
14 subr rout;
15 end subr rout;
16 **
17
18 d(grbmrk)
19 d(grbadj)
20 d(grbcmp)
21 d(gbcmp)
22 d(gbcmpc)
23 d(gbcmp1)
24 d(gbcmp2)
25 d(gbcmp3)
26 d(gbcmp4)
27 d(gbcmp5)
28 d(grbtrm)
29 d(envrsi)
30 d(blksz)
31 d(dumpds1)
32 d(checkptr)
33 d(snap)