Forgot your password?
Document Actions
LIB: Runtime library.
LIB: Runtime library. stllib.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$ ll iiiiiiiiii bbbbbbbbb
15$ ll iiiiiiiiii bbbbbbbbbb
16$ ll ii bb bb
17$ ll ii bb bb
18$ ll ii bbbbbbbbb
19$ ll ii bbbbbbbbb
20$ ll ii bb bb
21$ ll ii bb bb
22$ llllllllll iiiiiiiiii bbbbbbbbbb
23$ llllllllll iiiiiiiiii bbbbbbbbb
24$
25$
26$ t h e s e t l r u n t i m e l i b r a r y
27$
28$ p a r t o n e
29$
30$
31$
32$ this software is part of the setl programming system
33$ address queries and comments to
34$
35$ setl project
36$ department of computer science
37$ new york university
38$ courant institute of mathematical sciences
39$ 251 mercer street
40$ new york, ny 10012
41$
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 the dotted line below, and change the macro
19$ 'prog_level' to the current julian date.
20
21$ ......................................................................
smff 1
smff 2
smff 3$ 01/07/85 85007 s. freudenberger
smff 4$
smff 5$ 1. correct the domain check for acos and asin.
smff 6$ module affected: relf.
smff 7$ 2. correct the carry computation in valli.
smff 8$ module affected: valli.
strb 1
strb 2
strb 3$ 07/24/84 84206 s. freudenberger
strb 4$
strb 5$ 1. fix several small bugs of correction set stra.
strb 6$ modules affected: intrp2, printa, reada, putr, getr, subst,
strb 7$ substs, and ssubst.
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: interp, intrp2, intrp3, eqprim, eqstr, add,
stra 7$ addstr, mult, multstr, member, of, sof, next,
stra 8$ inext, inextd, print2, readstr, putb1, getb1,
stra 9$ getf1, putf1, bldsds, bldstr, gethash, getnelt,
stra 10$ subst, substs, ssubst, ssubsts, lt, valli, sabs,
stra 11$ schar, break, span, match, lpad, len, any,
stra 12$ notany, rbreak, rspan, rmatch, rpad, rlen, rany,
stra 13$ rnotany, str, and convert.
sunb 1
sunb 2
sunb 3$ 07/24/84 84206 s. freudenberger
sunb 4$
sunb 5$ 1. introduce -vadvise- program parameter for s68, to advise unix
sunb 6$ about the expected paging behaviour. bit 1 sets anomalous
sunb 7$ behaviour during garbage collections, bit 2 set anomalous
sunb 8$ behaviour during execution. default is 1, i.e. anomalous during
sunb 9$ garbage collection and normal during program execution.
sunb 10$ modules affected: stlini, libini, interp, and grbcol.
sunb 11$ 2. implement the foreign interface for s68.
sunb 12$ module affected: putf1.
sunb 13$ 3. change the semantic of the title function: -title- now never
sunb 14$ causes a page eject but resets the title line and positions the
sunb 15$ line pointer to the last line of the current page. this implies
sunb 16$ that the next line printed will cause the page eject, and that
sunb 17$ -title- can be invoked as often as one wants without generating
sunb 18$ any actual output.
sunb 19$ module affected: stltitle.
asca 1
asca 2
asca 3$ 03/05/84 84065 d. shields
asca 4$
asca 5$ 1. for s37, add option ascii=0/1 such that ascii=1 causes the
asca 6$ library to maintain strings within the heap in ascii. this
asca 7$ feature is needed to support the nyu ada/ed ada compiler. this
asca 8$ mod is conditioned by ascebc, which should be enabled for s37.
asca 9$ modules affected: libini, print2, readnum, readstr, rdname, putr,
asca 10$ getr, bldsds, bldstr, valli, strli, lpad, rpad,
asca 11$ and str.
asca 12$ modules added: ascstr and ebcstr (after getr).
suna 1
suna 2
suna 3$ 02/05/84 84065 s. freudenberger
suna 4$
suna 5$ 1. support motorola mc68000 microprocessor on sun workstation.
suna 6$ modules affected: stlini, stllib, stlint, libini, intrp2, and
suna 7$ grbcol.
suna 8$ 2. fix a bug for equality routine in the packed/unpacked tuples.
suna 9$ module affected: equal.
suna 10$ 3. support programmable interface for s32u.
suna 11$ module affected: callf1.
suna 12$ 3. correct and error in the long integer division that generated
suna 13$ a negative zero.
suna 14$ module affected: divli.
smfd 1
smfd 2
smfd 3$ 09/01/83 83244 s. freudenberger
smfd 4$
smfd 5$ 1. expand the q2_witht interpreter case.
smfd 6$ module affected: intrp1.
smfd 7$ 2. correct a typo in the interpreter case q2_soft.
smfd 8$ module affected: intrp2.
smfd 9$ 3. use the new short integer binary file format.
smfd 10$ modules affected: putb1 and getb1.
smfd 11$ 4. correct the conversion to mixed tuple: check that the mixed tuple
smfd 12$ is not expanded beyond its length.
smfd 13$ module affected: convert.
smfe 1$ 5. fix a bug when reading negative reals.
smfe 2$ module affected: readnum.
smfc 1
smfc 2
smfc 3$ 09/01/83 83244 s. freudenberger
smfc 4$
smfc 5$ 1. allocate range sets of the proper form for ambiguous maps.
smfc 6$ modules affected: union, withs, ofa, and convsm.
smfc 7$ 2. correct the set intersection routine to follow the copy semantics
smfc 8$ of the optimiser.
smfc 9$ module affected: intersect.
smfc 10$ 3. fix several small bugs in the long integer package.
smfc 11$ modules affected: intrp1, callf1, putf1, getbli, intad2, intsb1,
smfc 12$ intsb2, and intdiv.
smfc 13$ 4. revise the algorithm used for fixli and floatli.
smfc 14$ modules affected: floatli, fixli, ceil, and floor.
smfc 15$ 5. add the missing code in str to handle the new long integer format.
smfc 16$ module affected: str.
smfc 17$ 6. fix a bug in the iteration over based subsets.
smfc 18$ module affected: convsm.
mjsa 1
mjsa 2
mjsa 3$ 08/08/83 83220 s. freudenberger and m. smosna
mjsa 4$
mjsa 5$ 1. implement arbitrary precision integer arithmetic.
mjsa 6$ modules affected: intrp1, intrp2, intrp3, eqprim, print2, readnum,
mjsa 7$ putb1, getb1, gethash, lt, ge, even, addli,
mjsa 8$ diffli, divli, modli, multli, umin, sabs, ceil,
mjsa 9$ floor, sfix, sfloat, rand, sign, and sexp.
mjsa 10$ modules added: uminli, equalli, ltli, evenli, floatli, fixli,
mjsa 11$ hashli, valli, strli, putbli, getbli, putintli,
mjsa 12$ getintli, intad1, intad2, intsb1, intsb2,
mjsa 13$ intdiv, and trlint.
mjsa 14$ modules deleted: readint and eqlint.
mjsa 15$ 2. replace calls to the setl -ge- function in the interpreter by
mjsa 16$ calls to the setl -lt- function, negating the result.
mjsa 17$ modules affected: intrp1 and intrp3.
mjsa 18$ module deleted: ge.
smfb 1
smfb 2
smfb 3$ 08/08/83 83220 s. freudenberger
smfb 4$
smfb 5$ 1. add a new program parameter that gives the maximum size to which
smfb 6$ the heap may grow: the new program parameter is
smfb 7$ max_heap=0/0 limit the growth of the heap by this value
smfb 8$ module affected: libini.
smfb 9$ 2. read and write an additional heap slice. initially, the
smfb 10$ additional slice excludes the dead block following the last run-
smfb 11$ time names string block. otherwise, it is a zero-length dummy
smfb 12$ slice.
smfb 13$ modules affected: rdhea2 and wrhea2.
smfb 14$ 3. generalise the interpreter cases for q2_oft, q2_ofts, q2_soft, and
smfb 15$ q2_caset: the modified code can handle any integer, not only
smfb 16$ short integers. this modification was made possible after the
smfb 17$ implementation restricted tuple indeces to short integers.
smfb 18$ modules affected: intrp2 and intrp3.
smfb 19$ 4. sem fills in the complete jump table for case maps represented as
smfb 20$ tuples. this simplifies the q2_caset interpreter case.
smfb 21$ module affected: intrp3.
smfb 22$ 5. add a new conditional branch q2_ifasrt with the semantics to
smfb 23$ branch to a1 if getipp('assert=1/2') = 0.
smfb 24$ modules affected: intrp2 and opnam1.
smfb 25$ 6. eliminate a redundant share bit test in less and lessf.
smfb 26$ modules affected: less and lessf.
smfb 27$ 7. set the is_multi and is_om bits correctly for trivial mmap results
smfb 28$ for less and from.
smfb 29$ modules affected: less and froms.
smfb 30$ 8. expand the cardinality update for tuples inline, since the
smfb 31$ okneltr routine is very slow on long tuples.
smfb 32$ modules affected: frome and sof.
smfb 33$ 9. modify mixed tuples correctly: move omega specifier, not symbol
smfb 34$ table index.
smfb 35$ module affected: frome.
smfb 36$ 10. include a type check for the first argument of a membership test
smfb 37$ for indirect strings.
smfb 38$ module affected: member.
smfb 39$ 11. correct an error for 'str 9.99....9' where the real was not
smfb 40$ checked for range after rounding.
smfb 41$ module affected: str.
smfb 42$ 12. correct an error in the coversion routine for conversions between
smfb 43$ odd tuples. also, do not reset the share bit after conversion
smfb 44$ from element-of-base format.
smfb 45$ module affected: convert.
smfb 46$ 13. include a length test for tuples whose ft_lim is non-zero:
smfb 47$ a tuple t1 whose minimum length is less than the minimum length of
smfb 48$ some other tuple t2 is not more general than t2.
smfb 49$ module affected: moregen.
smfb 50$ 14. compact the printed output for error messages: skip only one line
smfb 51$ before and after the error message; print the error message in
smfb 52$ one line.
smfb 53$ modules affected: err_q2 and err_proc.
smfb 54$ 15. insert the missing initialisation for q2_trccalls and q2_trcsym in
smfb 55$ the operator names table.
smfb 56$ module affected: opnam2.
smfb 57$ 16. delete the obsolete code in varid since code files are
smfb 58$ incompatible.
smfb 59$ module affected: varid.
smfa 1
smfa 2
smfa 3$ 12/16/82 82350 s. freudenberger
smfa 4$
smfa 5$ 1. run-time names are stored differently: see compl for an explana-
smfa 6$ tion. this version is upwards compatible for all implementations.
smfa 7$ module affected: errproc and varid.
smfa 8$ 2. the leading character for long atoms on output has been corrected.
smfa 9$ module affected: print2.
smfa 10$ 3. the semantic of the npow1 routine has been changed: it now
smfa 11$ returns a count of the number of specifiers it pushed onto the
smfa 12$ stack, and relies on npow and pow to form the proper set. this
smfa 13$ avoids using set-unions in the pow routine.
smfa 14$ modules affected: pow, npow, and npow1.
22
23
24$ 08/12/82 82224 s. freudenberger
25$
26$ 1. the q2 interface has been changed: several environment variables
27$ not included in the past have been included, so that all variables
28$ needed to resume execution after a dump has been written are now
29$ part of the q2 file. this required that several variables were
30$ moved from nsintp to nsgparam.
31$ modules affected: rdhea1, rdhea2, interp, intrp3, and intrp4.
32$ 2. the q2 opcodes have been updated: all aliases and unused codes
33$ have been eliminated.
34$ module affected: intrp1, intrp3, intrp4, opnam1, and opnam2.
35$ 3. procedure linkage has been modified: the relevant opcodes specify
36$ the low-core address of the block to be moved, instead of the
37$ high-core address.
38$ module affected: intrp4.
39$ 4. the statement trace prints its message starting in column 1
40$ instead of column 7.
41$ module affected: intrp4.
42$ 5. remote set union expands the first set to the length of the second
43$ if so required, and not to the length of the second operand + 1.
44$ module affected: unrset.
45$ 6. the binary read routine test the binary header code for validity
46$ and prints an error message if it is found to be invalid. in the
47$ past, this would yield a little bad goto error.
48$ module affected: getb1 and errfatal.
49$ 7. the argument sequence for the q2_entry, q2_exit, and q2_undo
50$ instructions has been changed: the code address now occupies the
51$ codea1 field of the first quadruple (recall that all other code
52$ addresses use this field, which is larger than the remaining
53$ fields).
54$ module affected: intrp4.
55
56
57$ 06/15/82 82166 s. freudenberger
58$
59$ 1. code sequences for setl division check for zero divisor.
60$ modules affected: interp1, div, and slash.
61$ 2. the variable len has been removed from the nsintp (interpreter)
62$ nameset, since it caused naming conflicts with the setl len
63$ function in connection with machine code generation. uses of len
64$ have been replaced by temp.
65$ modules affected: interp and interp2.
66$ 3. the pageof macro for the dec vax vms implementation (s32) has been
67$ corrected to reflect the fact that little allocates array(0), even
68$ though it defines arrays to be one-origined.
69$ module affected: (remote text inclusion).
70
71
72$ 06/01/82 82152 s. freudenberger
73$
74$ 1. the interpreter has been modified to eliminate common
75$ subexpressions for q2_add and q2_lessls.
76$ module affected: intrp1.
77$ 2. the interpreter has been modified to attempt a short integer
78$ addition (subtraction) before calling the general add-long-integer
79$ (subtract-long-integer) routine.
80$ module affected: intrp1.
81$ 3. the interpreter has been modified to use the image of the template
82$ block, rather the the sample value of the image form, to delete
83$ the image for 'f' in 'f lessf x' where 'f' is a local map.
84$ (i.e. q2_lessflm.) this implies that local forms on plex bases
85$ cannot use this code.
86$ module affected: intrp1.
87$ 4. the interpreter has been modified to use the zero'th component of
88$ the image tuple of 'f' in 'f lessf x' where 'f' is a remote map.
89$ (i.e. q2_lessfrm.)
90$ module affected: intrp1.
91$ 5. we check the otype rather than the type of the index in the
92$ q2_ofcl interpreter case.
93$ module affected: intrp2.
94$ 6. the interpreter has been corrected to perform 's(x) := y'
95$ correctly if 's' and 'y' are strings, 'x' a short integer, and
96$ '#y' > 1. (i.e. q2_sofcl.)
97$ module affected: intrp3.
98$ 7. the semantics of the q2_checktp and q2_checki1 operations have
99$ been modified, to account for the use of ft_low.
100$ module affected: intrp3.
101$ 8. 'cur_stmt' is only set under 'st' conditional assembly symbol,
102$ since only code conditioned by 'st' uses this variable.
103$ (i.e. q2_stmt.)
104$ module affected: intrp4.
105$ 9. the member routine has been modified to use knuth's linear string-
106$ matching algorithm for string comparisons. this eliminates the
107$ restriction that #s1 = 1, type s1 = type s2 = string in 's1 in s2'
108$ module affected: member.
109$ 10. the 'read' routine allocates an f_uset for all set forms, since
110$ setform does not perform set/map test recursively, yet rset1/rset2
111$ do. this can lead to problems if what first looked like a map
112$ turns out to be a set.
113$ module affected: read.
114$ 11. the error messages for the fortran (foreign) interface have been
115$ added. they all used to be err_fatal.54: error in experimental
116$ feature.
117$ modules affected: getf, getf1, callf, callf1, callf2, putf, putf1,
118$ and err_fatal.
119$ 12. the 'convert' routine has been modified to reflect the change
120$ w.r.t. the ft_low/ft_nonzero field for short integer forms.
121$ module affected: convert.
122$ 13. the (never used) conditional assembly group 'simp' has been pulled
123$ out of the interpreter. where appropriate, and new conditional
124$ symbol 'dead' has been used to mark code which currently can never
125$ be reached.
126$ modules affected: intrp1, intrp2, intrp3, and withm.
127
128
129$ 03/16/82 82075 s. freudenberger
130$
131$ 1. several library routines have been renamed to remove problems they
132$ caused for various implementations. see compl.q2macs for details.
133$ 2. ltlini actually expects a parameter. this has been corrected.
134$ module affected: stlint.
135$ 3. the q2 opcodes q2_eqtrue, q2_eqfalse, q2_eqif, q2_eqifnot,
136$ q2_goif, and q2_goifnot are never emitted: a call to err_fatal
137$ has been inserted for the appropriate interpreter cases. these
138$ opcodes should be removed as time permits.
139$ modules affected: interp1 and interp3.
140$ 4. the interpreter case for untyped comparisons have been corrected.
141$ opcodes affected: q2_geui, q2_geur, and q2_ltur.
142$ module affected: interp1.
143$ 5. the range test for the q2_sofrm interpreter case has been
144$ corrected.
145$ module affected: interp2.
146$ 6. the backtracking opocodes have been revisited, and an interpro-
147$ cedural backtracking bug been corrected. this bug occurred if
148$ we failed back into a procedure which still had more than one
149$ ok block live.
150$ module affected: interp4.
151$ 7. currently, the is_neltok bit is never set: this bit is planned
152$ to be set by the optimiser, but this optimisation has not yet
153$ been implemented. since on several machines, the .nb. operator
154$ is quite expensive, we removed the code to compute the cardina-
155$ lity of the result for several remote-set routines.
156$ modules affected: unrset, inrset, and difrset.
157$ 8. during the marking phase, the garbage collector sets a flag if
158$ the heap contains base blocks. if not base blocks are found, we
159$ do not call the base compaction phase gbcmp.
160$ modules affected: grbcol and grbmrk.
161$ 9. the call to the little remarkl has been deleted from err_proc.
162$ module affected: errproc.
163$ 10. the opnames for the is_type operator have been corrected to follow
164$ the general convention to use the operator name without the
165$ 'q2_' prefix.
166$ module affected: opname1.
167$ 11. a new function opname has been added after opnam2. it returns
168$ for a given opcode the operation name as a sds-string with no
169$ trailing blanks.
170$ module affected: dinst.
171$ module added: opname.
172$ 12. var_id has been corrected to remove trailing blanks if its second
173$ argument equals zero.
174$ module affected: varid.
175
176
177$ 02/01/82 82032 s. freudenberger
178$
179$ 1. version 81300 introduced a bug into the sof routines for string
180$ operands. this has been corrected.
181$ module affected: sof.
182
183
184$ 02/01/82 82032 d. shields
185$
186$ use r32 conditional symbol for standard 32-bit fields.
187$ this replaces the field definitions for s32, s37 and s47.
188
189
190$ 01/29/82 82029 d. shields
191$
192$ 1. revise envmhl to support mhl_static, mhl_dynamic and
193$ mhl_s66. mhl_dynamic calls envdsl to get dynamic memory
194$ limit and envdsa to allocate dynamic storage.
195$ for s32v, envdsv is needed as well.
196$ 2. delete '.=include s32q2f', etc., as part of r32 edit.
197
198
199$ 01/20/82 82015+ d. shields
200$
201$ 1. delete extra declaration for getapp_len for s47.
202$ 2. fix misplaced vadvise declaration for s32u.
203$ 3. rename open to sopen, close to sclose, any to sany, and
204$ rand to srand. this is needed to avoid conflicts with c
205$ library procedures for s47, and is harmless to other
206$ implementations.
207$ 4. use envssi in little for s47.
208$ (these corrections fix minor errors in 82015 version, so i did
209$ not change program_level).
210
211
212$ 01/15/82 82015 s. freudenberger & d. shields
213$
214$ 1. libini has been modified to print the phase header to the terminal
215$ whenever the new control card parameter 'termh=0/1' is set.
216$ new control card parameter:
217$ termh=0/1 print phase header on the terminal file
218$ module affected: libini.
219$ 2. the backtracking pointers are initialised to zero, thus avoiding
220$ potential problems if storage is not initialised to zero by
221$ default.
222$ module affected: interp.
223$ 3. backtracking interpreter cases have been corrected to initially
224$ reserve all the storage they need, thus causing garbage collection
225$ to occur before the instruction is started.
226$ module affected: intrp4.
227$ 4. the 'less' routine has been corrected for 'map less non-pair'.
228$ the original code would pick-up arbitrary memory locations in
229$ this case.
230$ module affected: less.
231$ 5. the 'dumpds1' routine has been enhanced to check for the '0'
232$ file title, and to avoid the writing of a heap image to the sink.
233$ module affected: dumpds1.
234$ 6. add option 'socase=0/0' to select output case returned for
235$ strings. socase=0 requests the default case, socase=1 requests
236$ lower case, and socase=2 requests upper case. currently this is
237$ implemented only for the 'type' operator, though later extension
238$ to formatted output may be desirable. this option only has meaning
239$ in mixed-case implementations.
240$ 7. add option 'vadvise=0/1' for s32u to describe paging behavior to
241$ vadvise. if bit 1 is set, va_anom will be set during garbage
242$ collections; if bit 2 is set, va_anom will be be outside garbage
243$ collections. otherwise, va_norm is used.
244$ 8. use same envmhl text for both s32u and s32v.
245
246
247$ 11/29/81 81333 d.shields
248$
249$ 1. support s47: amdahl uts (universal timesharing system).
250$ this implementation runs on s37 architecture using an operating
251$ system very close to unix (v7), and uses the ascii character set.
252
253
254$ 10/27/81 81300 s. freudenberger and d. shields
255$
256$ 1. the q2 interface has been formalized: a total of six routines
257$ read and write a standard q2 file, and a seventh routine
258$ checks a q2 file to determine whether it is in the correct
259$ format.
260$ the routines rdheap, rdheap1, and rdheap2 read the entire
261$ heap, the environment block, and the heap slices, resp.
262$ the routine chkq2f checks the q2 file format.
263$ the routines wrheap, wrheap1, and wrheap2 write the entire
264$ heap, the environment block, and the heap slices, resp.
265$ modules affected: libini and dumpds1.
266$ modules added: rdheap, rdheap1, rdheap2, chkq2f, wrheap,
267$ wrheap1, and wrheap2.
268$ 2. for the dec vax vms version we now allocate the heap dynamically.
269$ the initial 'prog lib' containing all global declarations has
270$ been canged into the subroutine stlini.
271$ the new main program has also been renamed to stllib, to
272$ avoid a logical name conflict on the local vax.
273$ to determine the amount of space available for the heap without
274$ using space needed to allocate i/o buffers, the following
275$ control card parameter has been introduced:
276$ nof=5/5 number of open user files
277$ modules affected: libini and getspace.
278$ module deleted: lib.
279$ modules added: stlini and stllib.
280$ 3. the setl-fortran interface has been implemented for the
281$ s32, s37, and s66 versions.
282$ the interface uses a communication area which is kept as a
283$ tuple in the setl heap as the symbol intf: s_intf replaces
284$ s_spare1.
285$ the actual call to fortran is done by the new built-in function
286$ callf, for which a new q2 opcode was needed.
287$ the new conditional assembly symbol defenv_envfor marks the
288$ relevant code.
289$ modules affected: stlini, rdheap1, wrheap1, interp4,
290$ getf, putf, err_fatal, and opnam2.
291$ modules added: stlint, getf1, callf, callf1, callf2,
292$ and putf1.
293$ 4. for the dec vax vms version (s32), using the vms crmpsc system
294$ service, we provide the option to create and use file formats
295$ which allow to map the heap image directly into the virtual
296$ address space, thus eliminating the need to read the heap before
297$ execution starts. this work introduced the following new control
298$ card parameters:
299$ q2init=0/1 initialisation type:
300$ 0: standard initialisation: read heap
301$ 1: use mapped heap
302$ 2: create mapped heap and section files
303$ q2e=q2e/ name of q2 environment file
304$ q2h=q2h/ name of q2 heap file
305$ hftrace=0/1 trace relevant procedures
306$ this work introduced the new conditional symbol hf, used to mark
307$ the code related to the heap file option.
308$ see compl.mhfpkg for a more detailed account.
309$ modules affected: stlini, libini, and errfatal.
310$ modules added: hfcrst and hfmapr.
311$ 5. the nameset io has been renamed to nameset nsio, to follow the
312$ standard practice to start all nameset names with the letters ns.
313$ module affected: stlini.
314$ 6. the sof routine case for indirect character strings has been
315$ corrected, after the last correction set corrupted it: the
316$ variable t is the stack top pointer and should never be used
317$ as the variable name of a temporary.
318$ module affected: sof.
319$ 7. eof now works after get and getb statements.
320$ modules affected: stlini, getr, and getb.
321$ 8. the cardinality operator inside error messages has been changed
322$ from its old syntax, namely ?, to its current syntax, namely #.
323$ modules affected: errom, errtype, and errmisc.
324$ 9. the errproc routine has been modified to check more carefully
325$ that a heap image actually exists (has been read) before trying
326$ to retrieve information from it (which might cause an access
327$ violation if the heap has not yet been allocated).
328$ modules affected: libini, and errproc.
329$ 10. the reserved words 'spec' and 'unspec' have been deleted.
330$ modules affected: interp4 and opnam2.
331$ modules deleted: specr and unspec.
332$ 11. move the string primitive definition section from module
333$ libpl.stlini to compl.strpkg.
334$ module affected: stlini.
335
336
337$ 06/24/81 81175 s. freudenberger
338$
339$ 1. we implemented part of a dynamic symbolic debugging feature.
340$ for this purpose, we added three control card parameters:
341$ debug=0/1 enables/disables the debugging feature.
342$ strace=0/1 is equivalent to an initial trace statements, and
343$ also sets the debug flag.
344$ ctrace=0/1 is equivalent to an initial trace calls, and also
345$ sets the debug flag.
346$ modules affected: lib, libini, interp, interp4, and dumpds1.
347$ 2. the interpreter cases for of on tuples, ie. q2_oftoks, q2_oftok,
348$ q2_oft, and q2_ofts, have been corrected disallow a2 to be omega.
349$ module affected: interp2.
350$ 3. we added the code for the new q2 opcodes (see compl for a list
351$ and explanations).
352$ modules affected: interp3, interp4, errtype, opnam1, and opnam2.
353$ 4. the member routine has been corrected not to assume that the nelt
354$ field of a tuple data block and the ss_len field of an indirect
355$ string data block have the same position within the data block.
356$ 5. some corrections were misplaced in the of and sof routines w.r.t.
357$ the dereference operation for the tuple index. this has been
358$ taken care of.
359$ 6. we modified the convert routine to allow conversions from general
360$ to element_of_plex_base, provided the input actually is an
361$ element of the proper plex base.
362$ 7. we corrected the convert routine to reset the stack pointer after
363$ an error has occured.
364$ 8. the putvar routine has been modified to check for plex objects
365$ before it calls the print routine: this is needed, because we
366$ cannot iterate over a plex object, and thus cannot print it.
367$ 9. the putvar routine has been modified so that no warnings for
368$ temporary overflow will be printed anymore by little.gen.
369
370
371$ 08/20/81 81232 s. tihor
372$
373$ 1. adjust even and odd so that untyped cases and the even routine
374$ handle negative numbers correctly.
375
376
377$ 09/04/81 81043 s. freudenberger
378$
379$ 1. the addition routine has been modified to always copy strings.
380$ 2. the multiplication routine has been stripped of an incorrect
381$ optimisation: if # i2 < # i1, the sets used to be swapped for
382$ greater efficiency. this violated assumptions made by the
383$ code generator w.r.t. the setting of the copy flag, and under
384$ special conditions no copy occured though it was needed.
385$ 3. the tuple index needed to be dereferenced in the of and sof
386$ routines.
387$ 4. the conversion routine (convert) has been corrected to do the
388$ range check for short integers correctly. namely, if the ft_lim
389$ field of the form table entry is zero, we can not check that the
390$ the value does not exceed the range.
391$ 5. the moregen routine has been modified to handle element-of-base
392$ forms and mmap forms correctly.
393
394
395$ 04-09-81 81099 s. tihor
396$
397$ 1. update the q2 format to include the magic number and time stamp as
398$ integers. move error messages to separate error routine err_q2.
399$ add deck err_q2 containing same.
400$ 2. add 20 spare variables for future expansions
401$ 3. add q2 op code q2_goif, q2_goifnot, q2_eqif, q2_eqifnot for boolean
402$ test/if split.
403$ 4. add q2 ops q2_nins, q2_ninu.
404$ 5. split q2_lessflm into q2_lessflsm and q2_lessflmm
405$ 6. split q2_lessfrm into q2_lessfrsm and q2_lessfrmm
406
407
408$ 11/24/80 80308 s.tihor and d.shields
409$
410$ 1. make open a boolean function which returns true for
411$ successful open and false for failure.
412$ 2. get the terminal (error log) file name from little via namesio
413$ 3. check code file date stamp
414
415
416$ 12/05/80 80340 d. shields
417$
418$ 1. change lc code to mc code general master case correction
419
420
421
422$ 12/02/80 80337 s. freudenberger
423$
424$ 1. the interpreter cases for q2_lessflm and q2_lessfrm as well
425$ as the lessf routine have been corrected to treat the omega-
426$ image for based m-maps correctly. (ie. reset the is_om bit,
427$ set the is_multi bit of the om_image(form)).
428$ 2. the set member ship routine map cases dereferences the pair as
429$ appropriate. it also checks the components for not-omega.
430$ 3. the getr routine has been corrected to store the string
431$ specifier back into the argument specifier after a record
432$ has been read.
433$ 4. the endop and send routines have been modified to dereference
434$ their argument, if required.
435$ 5. an error in the correction of 80310.14 has been corrected.
436$ (update of err_proc routine to prevent recursive call to snap)
437
438
439$ 11/05/80 80310 s. freudenberger
440$
441$ 1. the interpreter cases for q2_lessflm and q2_lessfrm have
442$ been corrected to set the image to the proper omega value.
443$ 2. the interpreter cases for q2_dom and q2_range have been
444$ modified to pass the form of the result set (ie. the third
445$ argument) to the corresponding library routines.
446$ 3. the interpreter cases for q2_savel, q2_clearl, and q2_entry
447$ have been corrected to set the local variables to omega.
448$ 4. the interpreter case for q2_dexit has been corrected to
449$ swap the routine parameters from the proper stack offset.
450$ 5. the equality routine general map case has been corrected
451$ to to branch on the proper test for null range sets of
452$ multi-valued maps.
453$ 6. the equality routine based map case has been corrected
454$ to save the pointer to the second set in the stacked
455$ variables before starting the comparison.
456$ 7. the union routine add_image case has been corrected to
457$ check for declared single-valuedness of the first map
458$ if the second map image is multi-valued.
459$ 8. the sof and sofa routines has been changed to assume that the
460$ first argument (the map) can be used destructively.
461$ 9. the fval and sfval routines had their packed map cases
462$ corrected.
463$ 10. the tupform routine has been modified so that is does not
464$ call the sof routine anymore.
465$ 11. the domain and range routines have been modified to accept
466$ any map type, and to return any set type. the form of the
467$ result is passed as a second argument.
468$ 12. the grbcol routine has been corrected so that the variable
469$ gitotal is word-sized.
470$ 13. the static heap menagement routine (envmhl) has been modi-
471$ fied so that it checks the variable max_heap_dim for the
472$ maximum heap dimension, rather than to use the constant
473$ heap_dims. to check a variable in the external nameset
474$ nsheap allows this nameset to be changed easily to provide
475$ for different maximum heap sizes, and thus for different
476$ sizes of the setl system.
477$ 14. the error processing routine err_proc has been modified
478$ to check and update the global variable eitotal. this
479$ prevents repeated (recursive and hence undefined) calls
480$ to this routine when we abort due to insufficient heap
481$ space (-main storage pool exhausted-).
482$ 15. the snap routine had its local variable prev_snapno dele-
483$ ted. after change (14) above, it should not be needed.
484
485
486$ 09/08/80 80252 s. freudenberger
487$
488$ 1. the sof routine has been corrected to store the range set
489$ of a multi-valued map in the required form.
490
491
492$ 08/18/80 80231 s. freudenberger
493$
494$ 1. the q2_withus interpreter case has been corrected: it was
495$ wrong for a1 = a2.
496$ 2. the terminal output for error messages has been shortened.
497
498
499$ 08/01/80 80214 s. freudenberger
500$
501$ 1. the code pointer (codep) has been moved into the nameset
502$ nsgparam. consequently no declaration is needed in member
503$ lib anymore.
504$ 2. the conditional assembly section has been moved into compl,
505$ and is included into member lib.
506$ 3. several small errors have been corrected in the new str
507$ routine.
508$ 4. a systematic bug in the conversion routine has been
509$ corrected: conversion where the difference of the forms
510$ was restricted to the setting of the ft_hashok and/or
511$ ft_neltok bits were done incorrectly. also, conversions
512$ between s- and m-maps with equal ft_type- and ft_elmt-
513$ fields were not handled properly.
514$ 5. the setting of hashs and nelts during conversion also
515$ has been cleaned up (ie. corrected where found to be done
516$ improperly.)
517$ 6. a misplaced line in member errfatal has been moved to its
518$ proper place.
519
520
521$ 07/10/80 80192 s. freudenberger
522$
523$ 1. conditional assemblies env_gss and env_pss have been intro-
524$ duced, indicating whether the routines envgss and envpss are
525$ defined in the environment. the setl get and put functions
526$ have been implemented using the envgss and envpss routines.
527$ if these two routines are not defined, a fatal error message
528$ 'feature not implemented' is printed.
529$ 2. the globals cb_string and sb_string (for curley-braces and
530$ square-brackets) have been renamed sb_string and tb_string
531$ (for set braces and tuple brackets). also, the (related)
532$ globals lxx_string and rxx_string have been redefined to
533$ lyy_char and ryy_char, resp.
534$ 3. if the title control card parameter is selected, an initial
535$ line is printed on the terminal file: "start cims.setl.lib.."
536$ 4. the q2_file is released immediately after it is read (in
537$ libini).
538$ 5. the following interpreter cases have been added:
539$ q2_nincs, q2_gonincs, and q2_error
540$ 6. the following interpreter cases have been eliminated:
541$ q2_goimp and q2_gonimp
542$ 7. the string file has been eliminated.
543$ 8. the str routine has been implemented newly.
544
545
546$ 07/08/80 80190 s. freudenberger
547$
548$ 1. the ssbstt routine has been corrected so that, if the length
549$ of the result tuple is less than the length of the input tuple,
550$ and the input tuple is used destructively, then the length of
551$ the result tuple is set properly.
552$ 2. the interpreter case for q2_type has been corrected to handle
553$ t_elmt specifiers correctly.
554$ 3. the interpreter case for q2_gonnl has been corrected to return
555$ after the code pointer is updated, rather than to branch to
556$ the nxt label (where the code pointer would be updated, thus
557$ skipping the first instruction after the jump).
558$ 4. the intepreter cases for q2_ge, q2_lt, q2_goge, and q2_golt have
559$ been corrected to check for omega-integers before branching to
560$ the respective integer inline cases.
561$ 5. the interpreter case for q2_locate has been corrected to return
562$ a t_oelmt specifier for omega values.
563$ 6. the interpreter case for q2_time has been modified to return
564$ an integer, rather than a short integer, to avoid the problem
565$ of overflow.
566$ 7. the addition and multiplication routines have been modified to
567$ handle mixed tuples properly.
568$ 8. the withs routine has been modified to signal an error on
569$ omega sets.
570$ 9. the sof routine has been modified to treat str1(i) := str2 as
571$ str(i..i) := str2 if #str2 /= 1.
572$ 10. the title function has been revised to implement the new
573$ semantic definition.
574$ 11. the cardinality for the result tuple in tup(i..j) is set
575$ properly.
576$ 12. a check has been added to the ssubst routine to assert
577$ 1 <= a2 <= a3+1 <= #a1+1 for strings.
578
579
580$ 06/20/80 80172 s. freudenberger
581$
582$ 1. a call to the dumpds1 routine has been added in the errproc
583$ routine for s32 to circumvent poor exception handling of s32
584$ little system.
585$ 2. the find_stmt routine has been corrected to look up to ca_org for
586$ the next stmt quadrupel.
587$ 3. a test has been added to the nullp routine to check for the
588$ possibility of insufficient heap space for garbage collection.
589$ thought this condition should never arise, let's play it save.
590$ 4. the blksz routine has been modified to abort on invalid htype's.
591$ 5. a bug related to the global string specifiers has been corrected.
592$ 6. since the valr routine tends to execute forever, the system now
593$ aborts on entry to valr.
594$ 7. the snap routine has been modified to only attempt to print the
595$ variable values if the heap is properly formed, ie. not during
596$ a garbage collection.
597$ 8. the gethash routine has been modified to truncate the hash code
598$ to hcsz bits before it returns. this is needed since little's
599$ attitude that a size statement specifies a minimum size does
600$ not have the desired result.
601$ 9. a test has been added to the expand routine to check that
602$ (a.) the lognhedrs field does not overflow, and (b.) at most
603$ 2 ** hcsz hash headers are allocated.
604$ 10. the interpreter case for q2_host has been corrected.
605$ 11. several routines have been modified to actually execute a little
606$ assert statement when the (implicit) assumption is made that
607$ long integers are exactly one word long.
608$ 12. the printa, reada, put, and get routines now interpret the
609$ nullstring as the file name for the standard output and
610$ input files, resp.
611$ nb. no changes have been made to the open and close routines,
612$ so one should expect problems when these routines are called
613$ with a nullstring as file name. the result of such a call is
614$ undefined.
615$ 13. the lexclass for alphabetics has been initialized to read_name.
616$ 14. the interpreter cases for q2_inr and q2_ninr have been corrected.
617
618
619$ 05/29/80 80150 s. freudenberger
620$
621$ 1. the hash table header data structure introduced with 80130 has
622$ been incorporated into the compiler.
623$ decks affected: equal, copy1, delete, nullset, expand,
624$ contract, dom, grbmrk
625$ 2. hash table contraction for bases has been enabled, a consequence
626$ of hashing changes done 79351.
627$ deck affected: gbcmp3
628
629
630$ 05/27/80 80148 s. freudenberger
631$
632$ 1. the checkptr routine has been corrected to scan only
633$ the heap proper, skipping the symbol table and the like.
634$ 2. the following interpreter cases have been corrected to
635$ use the proper field extract macros:
636$ q2_eqform1, q2_eqform2, q2_eqform3, q2_deref, q2_deref1
637$ 3. the q2_locate interpreter case has been modified to handle
638$ the omega case properly.
639$ 4. the equal and eqsub routines have been modified: eqsub has
640$ been renamed to eqlrs (equality of local-remote sets),
641$ restricting the arguments such that the first argument has
642$ to be the local set, and the second argument the remote set.
643$ the loop body in this routine has been rewritten, avoiding
644$ two calls to the fval routine. this should speed up subset
645$ equality tests considerably.
646$ 5. the equality routine has been modified to avoid unneeded
647$ computations of hash and nelts: hash fields are only compared
648$ if they are available (is_hashok = yes), and the cardinality
649$ is not computed for based sets and maps if they are based on
650$ the same base. the needed adjustments to the eqrs have been
651$ made as well.
652
653
654$ 05/09/80 80130 s. freudenberger
655$
656$ 1. the interpreter cases q2_nextt and q2_nextut have been
657$ changed so that they don't skip embedded omegas in
658$ tuples. this change results in equivalent executions
659$ of the interpreter cases mentioned and the corresponding
660$ cases in the next routine.
661$ 2. the variable om in the frome routine has been renamed
662$ om_val. the old name, for some unknown reason, caused the
663$ setl system constant om to be destroyed.
664$ 3. the len and rlen routines have been modified to use newly
665$ allocated string specifiers for the result. this problem
666$ would only occur on machines which store string specifiers
667$ indirectly, and only if the string specifier was shared.
668$ 4. two error messages in the err_om routine were corrected.
669$ five error messages in the err_type routine were corrected.
670$ 5. the is_ebfree flag has been deleted.
671$ 6. the q2_query and q2_isprim operators have been eliminated.
672$ 7. the modes for which the setl from and arb operators are
673$ defined has been restricted to set_modes.
674
675
676$ 04/11/80 80102 d. shields
677$
678$ 1. if appropriate, permit tab in addition to blank as separator
679$ on text input.
680$ 2. implement is_xxx predicates.
681$ 3. if appropriate, permit lower case in identifier input.
682$ 4. fix error in initializing mvc1 and mvc1 specifiers.
683$ 5. supply missing 'ctuc' declaratinon in 'rdbool'.
684$ 6. add miscellaneous changes to get setl running on s10.
685$ 7. modify heap allocation strategy so that heap allocated from
686$ large 'static' array on all implementations except s66.
687$ 8. modify getr to reflect available routines for reading in
688$ text line. this area somewhat confused due to uncertainty
689$ when i/o will be cleaned up.
690$ 9. provide figures on garbage collector in performance (lcs)
691$ statistics.
692$ 10. delete cdc update yankdeck directives.
693$ 11. fix error in random routine.
694$ 12. delete 'part 5' used to build 'student' version.
695$ this was used only for s66, and is no longer appropriate.
696
697
698$ 04/09/80 80100 s. freudenberger
699$
700$ 1. the set << [om, 1] >> is considered legal, but not convertible
701$ to a map. this required additional tests in the withs, rset1,
702$ rset2, setf1, and isamap routines.
703$ 2. there was an uninitialized flag in arbs which caused the result
704$ of arbs << [1, 2] >> to be omega.
705$ 3. the frome routine did not store the proper omega into the dele-
706$ ted component of a mixed tuple. also, the nelt of mixed tuples
707$ was not updated correctly.
708$ 4. the sof routine did not update the nelt of a tuple correctly in
709$ t(#t) := om;
710$ 5. the ssbsts routine (sinister string substring) incorrectly
711$ specified the length for the third move to the 'move-character'
712$ macro.
713$ 6. the share bit of the embedded component is set in the initnpow
714$ routine.
715
716
717$ 02/04/80 80035 s. freudenberger and d. shields
718$
719$ 1. implement unary operators acos, asin, atan, char, cos, exp,
720$ log, sin, sqrt, tan and tanh.
721$ 2. implement binary operators atan2 and interrogation (?).
722$ 3. implement type predicates is_atom, is_boolean, is_integer,
723$ is_map, is_real, is_set, is_string and is_tuple.
724$ change prim to is_primitive.
725$ 4. add procedure host() to provide means for adding
726$ implementation- or site-dependent features.
727$ 5. change the name of the set bracket control card parameter from
728$ 'cb' (curley bracket) to 'sb' (set braces), and the name of the
729$ tuple bracket control card parameter from 'sb' (square bracket)
730$ to 'tb' (tuple bracket).
731$ 6. a conditional assembly 'lc' has been added to control upper/lower
732$ case equivalency.
733$ 7. two routines have been added to read identifier-type strings and
734$ booleans: rdname and rdbool.
735$ 8. two control card parameters have been added to control listing
736$ options: 'lcp' to identify the setl system on the terminal file
737$ as well as print the complete parameter string on the standard
738$ output file; and 'lcs' to print final execution statistics.
739$ 9. the default for the snap control card parameter has been set to 0.
740$ 10. the interpreter case for q2_dump has been changed to increment
741$ the code pointer before the dump is written. this allows for
742$ a crude 'save' feature, as the file written is compatible with
743$ the q2 file, and thus can be read as code file.
744$ 11. 'sfval' has been corrected for local packed maps.
745$ 12. 'with' has been corrected to handle mixed tuples correctly.
746$ 13. atoms are preceded by a number sign (instead of a question mark).
747$ 14. sinister substrings on strings are done using the 'move-character'
748$ macro.
749$ 15. some clean-up changes have been made to 'getspace' and 'libterm'.
750$ 16. a sizing error has been corrected in 'dumpds1': the title of the
751$ dump file is now correctly sized.
752$ 17. 'varid' has been updated to access the run-time names table
753$ correctly if names are stored accross several words.
754$ 18. several error messages have been added, corresponding to changes
755$ mentioned above.
756
757
758$ 01/21/80 80021 s. freudenberger
759$
760$ 1. the form table limit has been increased for the s32. corresponding
761$ changes have been made for the s32 q2 fields.
762$ 2. long character string access has been parameterized differently to
763$ account for the peculiar way the s32 stores bytes in words.
764
765
766$ 01/17/80 80017 s. freudenberger
767$
768$ the layout of the heap has been changed: snames has been integrated
769$ into the heap at the low core end, and the run-time symbol table has
770$ been allocated between the run-time names and the constant part of
771$ the heap.
772$ modules affected: libini, grbmrk, adjcode (deleted), dumpds1,
773$ getspace, snap, putvar, dinst, and varid.
774
775
776$ 01/16/80 80016 s. freudenberger
777$
778$ 1. all external names of the library are now unique within the first
779$ six characters.
780$ 2. 'unrset' had a correction misplaced. this has been taken care of.
781$ 3. 's1(i) := s2' has been modified to check is_string(s2) * #s2 = 1.
782
783
784$ 01/15/80 80015 s. freudenberger
785$
786$ 1. the statement trace has been shorthened to one line.
787$ 2. 'eqprim', 'lt', and 'ge' have been modified to use the new
788$ compare-logical-character macro (clc).
789$ 3. the handling of omega has been updated according to the language
790$ definition in the routines of, ofa, and sofa.
791$ 4. exptup has been modified to reset the share bit if it had to copy
792$ the tuple.
793$ 5. gethash has been modified to use the hash-code-seed macro. note
794$ that the current hashing function still is rather ad-hoc, and
795$ should be subject to review.
796$ 6. 'ssubsts' and 'ssubstt' have been renamed 'ssbsts' and 'ssbstt',
797$ resp. the only remaining external names which are not unique
798$ when truncated to six characters are thus 'getippr' and 'getsppr',
799$ which conflict with coresponding external names in the little
800$ library.
801$ 7. some optimization has been done in the 'ssbstt' routine, to avoid
802$ unnecessary copies.
803$ 8. error messages have been updated and added in correspondence with
804$ other changes.
805$ 9. 'sabs' has been augmented for string arguments, and 'schar' has
806$ been added to the library.
807
808
809$ 12/17/79 79351 s. freudenberger
810$
811$ 1. the following routines have been renamed to make their names
812$ unique within the first six characters:
813$ interp1 ---> intrp1 ... interp4 ---> intrp4
814$ nsinterp ---> nsintp
815$ opname1ns ---> nsopn1 ... opname2ns ---> nsopn2
816$ this leaves, to the best of my knowledge, the following names
817$ non-unique within six characters:
818$ ssubst, ssubsts, ssubstt
819$ getippr, getsppr (they conflict with little routine names)
820$ 2. extensible hashing has been implemented. the following routines
821$ have been changed substantially to do so:
822$ equal, locate, augment, expand, contract,
823$ note that 'gethash' properbly should be modified as well, and that
824$ further changes should clean up this first crude approach. further
825$ more, the duocumentation in the equality routine needs to be
826$ updated (obsolete comment marked as such)
827$ 3. the exponetiation routine ('sexp') has been corrected to
828$ dereference inputs of type element.
829$ 4. 'lessf' has been corrected to observe the proper copy semantic.
830$ 5. 'of' has been changed according to the language change that it
831$ is illegal to index omega.
832$ 6. 'sof' has been corrected to set the is_multi_ bit for the image
833$ set of an mmap.
834$ 7. 'putvar' has been changed to not attempt to print bases. this
835$ used to cause a bad go to index in the print routine.
836$ 8. 'opname1' and 'opname2' have been updated to include the 'eqtrue',.
837$ etc. cases.
838
839
840$ 11/30/79 79334 s. freudenberger
841$
842$ 1. four cases have been added to the interpreter, special handling
843$ equality test on booleans.
844$ 2. set/map equality has been corrected in 'equal'.
845$ 3. 'with' and 'less' have been corrected to observe the proper copy
846$ semantic on 't_elmt's.
847$ 4. 'sof' has been corrected to check the type of the second argument
848$ in the t_istring-case.
849$ 5. 'putb1' has been enhanced to allow writing of based objects.
850$ 6. 'augment' has been changed to (a.) never use the hash header of
851$ a base, and (b.) keep the clash lists of bases sorted. this
852$ change became neccessary to allow extensible hashing on bases.
853$ 7. remote set expansion ('exprset') has been corrected to set rs_maxi
854$ properly.
855$ 8. 'gethash' has been corrected to compute the hash code of
856$ (a.) t_elmt's, and (b.) h_rset's correctly.
857$ 9. 'arbs <> = om' has been asserted.
858$ 10. the error cases for 'domain' and 'range' have been refined.
859$ 11. various albeit missing error messages have been added.
860$ 12. 'dumpds1' writes the dump file in the same format as the q2 file.
861$ 13. 'match' and 'rmatch' have been corrected - another ssi-error !
862$ also, their deck names have (finally) changed to match the
863$ routine names.
864
865
866$ 11/12/79 79316 s. freudenberger
867$
868$ 1. true and false are printed as #t and #f, resp.
869$ 2. the binary i/o has been extended to include booleans.
870$ 3. remote set union has been corrected (fr2.1.012).
871$ 4. map conversion has been cleaned up.
872$ 5. 'match' and 'rmatch' have been implemented more efficiently.
873$ 6. the sizing of 'acs' in fileid has been corrected.
874$ 7. negative reals are read correctly (fr2.1.015).
875
876
877$ 09/27/79 79269 s. freudenberger
878$
879$ 1. missing goto's have been inserted into the interpreter cases for
880$ q2_fromb..q2_fromeut.
881$ 2. 'ssubstt' has been corrected to dereference the pointer before
882$ indexing the tuple header in the case that #result /= #tuple.
883$ 3. the condition for not reallocating a new hash table in 'expand'
884$ has been strengthened to account for the call to 'gethash', which
885$ is a recursive routine and thus requires additional stack space.
886$ 4. 'lpad(str, n)' and 'rpad(str, n)' return str rather than error if
887$ #str > n.
888
889
890$ 09/17/79 79259 s. freudenberger
891$
892$ 1. the interpreter cases for 'ok' and 'fail' have been corrected to
893$ return 'true' and 'false', resp.
894
895
896$ 09/13/79 79256 s. freudenberger
897$
898$ 1. 'from' emits a message when used on tuples, then calls 'frome'.
899$ the code which used to handle tuples has been deleted.
900$ 2. 'fromb' and 'frome' have been modified to copy their second
901$ argument if it is shared.
902$ 3. 'print2' has been modified to print 'true' and 'false' for the
903$ corresponding boolean values.
904$ 4. 'eof' has been modified to return true or false, as appropriate.
905$ 5. logical file names are sized using 'filenamlen' ( defined in
906$ cmnpl.sysmac)
907$ 6. 'expand' has been modified to only expand the hash table if this
908$ won't cause a garbage collection.
909$ 7. 'arbs' has been modified to return a proper omega when its
910$ argument is a nullset with correct cardinality fields.
911
912
913$ 09/06/79 79250 s. freudenberger
914$
915$ 1. the deck 'macros' has been incorporated into the deck 'lib'. this
916$ has the advantage that we read only once trough 'cmnpl'.
917$ 2. the 'getr' routine has been rewritten, using the newly provided
918$ little 'getvsio' routine to directly read a variable length record
919$ into a setl string.
920
921
922$ 09/05/79 79248 s. freudenberger
923$
924$
925$ this correction set installs setl 2.1
926$
927$
928$ 1. the interpreter has been updated to reflect the language
929$ changes.
930$ 2. the set union routines 'union' and 'unset' were corrected to
931$ set share bits of the second input's components when they were
932$ included into the result.
933$ 3. 'unrset' was corrected to compute the cardinality of the result
934$ properly.
935$ 4. the 'sofa' routine has been corrected so that is copies 'f' before
936$ it modifies it. the erroneous code worked properly in the unbased
937$ case since it would always convert 'f' to a 'f_umap' before it
938$ used it.
939$ 5. the sizing of 'nulllc' in 'lpad' and 'rpad' has been corrected.
940$ 6. 'sfix', 'sfloat', 'ceil', and 'floor' have been modified to
941$ (1.) perform the necessary type checks
942$ (2.) compute the correct result
943$ 7. several bugs have been fixed around the index compaction of
944$ element base blocks.
945$ 8. a (suspected) bug has been fixed in 'getspace', when pointers
946$ in environment blocks are updated.
947$ 9. 'top' and 'bot' have been replaced by 'ceil' and 'floor'.
948$ 10. the routine 'interp' (finally) became an individual member (or
949$ deck, for s66). it is not part of member 'interp1' anymore.
950$ 11. the library routines for the 'fromb' and 'frome' operaotrs
951$ were added.
952$ 12. the library routines for the 'len' and 'rlen' string primitives
953$ were added.
954$ 13. as a short cut, several new error messages have not been added to
955$ the error routines. this is considered a bug, and will be
956$ corrected as time permits.
957
958
959$ 07/25/79 79206 s. freudenberger
960
961$ 1. the interpreter case 'q2_nextus' has been modified so that the
962$ share bit of the specifier retrieved is set.
963$ 2. locate has been corrected so that 'loc_prev' is always set on
964$ inequality in the search loop.
965$ 3. augment has been corrected to check overflow of the ebindx-field
966$ correctly.
967$ 4. contract has been corrected to update the pointer of the last
968$ element of the clash list of the new last hash header correctly.
969
970
971$ 07/20/79 79201 s. freudenberger
972
973$ 1. the remaining code shared between the code generator and the
974$ library has been moved into the common library.
975$ 2. 'read_cntr' and 'getb_cntr' are initialized properly.
976$ 3. the s32 starts the interpreter via an environment routine.
977$ 4. error messages on the s10 are written on the device 'tty:' rather
978$ than the file 'tty'.
979$ 5. error messages on the s32 are written on 'sys$error' by default.
980$ 6. set braces are given as octal constants for the s10.
981$ 7. the interpreter's 'q2_witht' and 'q2_withut' cases have been
982$ corrected to handle omega properly.
983$ 8. the interpreter's 'q2_inext' case has been corrected to account
984$ for proper dereferencing of 's'.
985$ 9. the comparison routines 'eqprim', 'lt', and 'ge' have been
986$ modified to compare reals correctly.
987$ 10. -real .div real- has been prohibited, and yields an error message.
988$ 11. 'mult' now performs the correct copy action after swapping the
989$ input sets and before calling 'intersect'.
990$ 12. 'lessf' has been modified to attempt to convert a set to a map.
991$ (it used to convert a set to a set....)
992$ 13. 'of' and 'ofa' have been modified to check whether the conversion
993$ of a set to a map was successful.
994$ 14. 'nextd' now jumps on the otype_ rather than the type_.
995$ 15. 'getr' has been modified to circumvent little fr2.3.109
996$ 16. some small errors have been corrected in the binary i/o
997$ 17. 'gethash' has been corrected so that firstly, the hash of a null
998$ string is defined, and secondly, the hash of a tuple is only
999$ computed up to the nelt of the tuple.
1000$ 18. the garbage collector now expands the heap only in junks of
1001$ ten percent (as opposed to 25 percent). it also prints a
1002$ 'gtrace' message if and when it expands the heap.
1003$ 19. several errors have been corrected in the conversion routines.
1004$ all of them were due to pointers being updated, but not replaced
1005$ in their respective specifiers or recursive counterparts.
1006
1007
1008$ 05/18/79 79138 s. freudenberger and d. shields
1009
1010$ 1. the binary read has been re-designed, and the appropriate changes
1011$ made.
1012$ 2. two new conditional assembly options have been added
1013$ 2.1 'defenv_envmhl' controls heap management
1014$ 2.2 'defenv_envrsi' defines how the interpreter is restarted after
1015$ a garbage collection.
1016$ 3. a number of garbage collector routines have been renamed
1017$ garbcolns ---> nsgarbcol
1018$ garbadj -----> gadjust
1019$ garbcomp ----> gcompact
1020$ gbcomp1 -----> gbcmp1
1021$ gbcomp2 -----> gbcmp2
1022$ ... ...
1023$ gbcomp5 -----> gbcmp5
1024$ 4. the instruction format for the dec 10 has been revised.
1025$ 5. 'bldsds' has been modified so that all unused bits are zero.
1026
1027
1028$ 04/27/79 79117 s. freudenberger
1029
1030$ 1. the heap is written by the code generator in slices, skipping
1031$ the two undefined blocks between the constant and the dynamic
1032$ part of the heap, and between the heap and the stack.
1033$ 2. since the form table is shared between the semantic pass, code
1034$ generator, and the library, it has been placed into a common
1035$ library, and is included as an inclusion member.
1036$ 3. 'str < str' and 'str >= str' check their second arguments for
1037$ omega.
1038$ 4. the default set bracket character for s10 on output has been
1039$ changed to set braces.
1040$ 5. the heap has been placed into a nameset 'nsheap', which also
1041$ contains a variable 'cur_heap_dims' giving the current actual
1042$ available size of the heap. (well, it eventually will... for
1043$ this version it is just an undefined variable which is never
1044$ used.)
1045$ n.b. for s66, a macro maps 'nsheap' into 'blank', fortran blank
1046$ common.
1047$ 6. 'getspace' has been modified as to claim as much space as
1048$ possible, even if it is less than requested. it now only aborts
1049$ if the abort flag is set.
1050$ this change means that, if your current run field length limit
1051$ would permit you to acquire 1000 more words of memory, and your
1052$ job requests, let's say 1500 more words, your job will get the
1053$ 1000 words. up to now, your job would have aborted with
1054$ 'insufficient main storage'.
1055$ 7. the standard read routines have been modified so that they
1056$ resume execution properly after they have been interrupted by a
1057$ garbage collection.
1058$ 8. 'getem' and 'setem' have been made functions rather than
1059$ subroutines, since that is the way the interpreter calls them.
1060
1061
1062$ 04/12/79 79102 s. freudenberger and d. shields
1063
1064$ 1. the binary read has been corrected so that it restarts correctly
1065$ after a garbage collection.
1066$ 2. an option has been added to echo all error messages to the
1067$ file specified by the -term- control card parameter.
1068$ 3. the heap size can be specified in kilowords: every h-value less
1069$ than 1000 is assumed to specify a heap size in kilowords.
1070$ 4. for the s32, curley brackets will print as curley brackets, unless
1071$ specified differently.
1072
1073
1074$ 04/10/79 79100 s. freudenberger
1075
1076$ 1. some of the form table fields for the 6600 have been
1077$ redefined so that the -ft_pos- field does not cross a
1078$ word boundery.
1079$ 2. the nameset used by the interpreter has been renamed to -nsinterp-.
1080$ 3. the interpreter cases for -q2_nextt- and -q2_nextut- have been
1081$ corrected so that the iteration block will be executed for the
1082$ last component of the tuple.
1083$ 4. tuple retrievels have been corrected so that omega is returned
1084$ if the index exceeds the tuple-s nelt.
1085$ 5. the check for omega component in -intersect- has been corrected.
1086$ 6. first corrections have been made to the -getb- routine to handle
1087$ interupts by the garbage collector correctly. at this point,
1088$ some problems remain.
1089
1090
1091$ 04/03/79 79093 s. freudenberger and d. shields
1092
1093$ 1. the form predicates have been implemented in a different way, so
1094$ that machines with a wordsize less than 35 bits will get the
1095$ correct results. (the new implementation also should be more
1096$ efficient)
1097$ 2. when iterating over a map, -nexts- does not update the domain
1098$ element of both the iterator and the value until it has checked
1099$ whether an range iteration step is necessary. this change is
1100$ the result of (nyu-cims) bug 24, which showed that elements
1101$ were skipped if -nexts- was interupted by a garbage collection.
1102$ 3. -getb- only looks up the little file identifier (via call to
1103$ -file_id-) when it is entered for the first time. if it is
1104$ called after a garbage collection, it merely continues at the
1105$ point at which it was interupted.
1106$ 4. the same change (3. above) has been made to -reada-.
1107
1108
1109$ 03/27/79 79086 s. freudenberger
1110
1111$ 1. the macro for -hl_code- has been corrected in the s10, s32,
1112$ and s37 field definitions.
1113$ 2. -inextd- has been corrected to attempt to convert a set to
1114$ a map before the start of the iteration.
1115$ 3. the test for q2_gonins has been corrected.
1116$ 4. -of- and -sof- return error values if the conversion from
1117$ set to map fails.
1118$ 5. q2_subst and q2_ssubst don-t increment the code pointer until
1119$ they return from the library, so that the interpreter is re-
1120$ started correctly after a garbage collection.
1121$ 6. the predicates on forms have been reviewed and corrected where
1122$ necessary.
1123$ 7. the semantics of substrings has been changed:
1124$ s(i...j) := y <===> s := s(...i-1) + y + s(j+1...)
1125$ y := s(i...j) <===> y := +/[ a(k) : k := i...j ]
1126$ 8. -rset2- has been corrected to set is_multi_ bits correctly.
1127$ 9. -getf-, -putf-, and -spec- have been corrected.
1128$ 10. various namesets have been renamed:
1129$ formtab ---> nsformtab
1130$ sname -----> nssname
1131$ std -------> nsstd
1132$ 11. the definitions of -om_int- and -om_real- have been
1133$ reviewed.
1134
1135
1136$ 03/15/79 79074 s. freudenberger
1137
1138$ 1. mixed mode arithmetic has been abandoned.
1139$ 2. -specr- has been corrected to handle negative integers
1140$ correctly.
1141$ 3. the minimum gap for the garbage collector had to be increased,
1142$ and -nullp- has been corrected so that is does use only the
1143$ space needed for the recursion stack; long integers and reals
1144$ are not compared via a call to -fval-, but rather compared in-
1145$ line.
1146$ 4. -convsm- has been modified to de-reference element types before
1147$ it uses them.
1148$ 5. -snap- has been made totally controlled by the -snap- control
1149$ card parameter.
1150
1151
1152$ 03/05/79 79065 s. freudenberger
1153
1154$ 1. after base index compaction during garbage collection, remote
1155$ objects now are updated correctly.
1156$ 2. the call of snap during a debug rdmp has been made dependent of the
1157$ setting of the snap control card parameter.
1158$ 3. snap has been changed to print the q2 instruction rather then the
1159$ index of the q2 instruction.
1160
1161
1162$ 02/12/79 79043 a. grand and s. freudenberger
1163
1164$ 1. the interpreter case q2_ge now tests the types of the
1165$ second and third argument before calling the library.
1166$ 2. the index of the last character of the result subject string
1167$ of -rmatch- now is a setl specifier.
1168$3 3. on end-of-file, newliner now returns an eof character rather than
1169$ the first character of the last line.
1170
1171
1172$ 01/30/79 79030 a. grand and s. freudenberger
1173
1174$ 1. we fixed the -npow- and -initnpow- routines so that the -nelt-
1175$ macro uses the correct field.
1176$ 2. we changed the value of om_int for s37 and s32 to the maximum
1177$ negative number.
1178$ 3. we changed the name of the q2 file for the s32 to -q2.tmp-.
1179$ 4. throughout the equality routines, we have replaced the parameter
1180$ names -a1- and -a2- by -arg1- and -arg2-, resp.
1181$ 5. we corrected various field definition which were found erroneous
1182$ during our work on the vax.
1183$ 6. we changed the name of the garbage collector nameset to
1184$ -garbcolns-.
1185$ 7. we corrected the print routine to print reals in e-format.
1186$ 8. we fixed the read routine to accept reals in e-format.
1187
1188
1189$ 12-27-78 78361 a. grand and d. shields
1190
1191$ this mod installs machine dependent code for the ibm-370, dec-10,
1192$ and vax. it also fixes a bug in tuple iterators.
1193
1194
1195
1196$ 12-8-78 78342 a. grand
1197
1198$ 1. the measurement package has been cleaned up. there is now
1199$ a conditional assembly option 'sti' in which the time spent
1200$ in the interpreter is not counted in the total library time.
1201$ this gives us a much better picture of the ratio of library
1202$ to nubbin time.
1203$ we have added a feature which prints the number of times each
1204$ q2 opcode is executed. we also print the total execution time
1205$ and the percentage of time spent in nubbins.
1206$ 2. we now print a dayfile message giving the time and date of the
1207$ last library change.
1208$ 3. we fixed bugs in the < and >= tests so that they generate an error
1209$ message when the user tries to compare a real with omega.
1210$ 4. the om_image macro now works through formtab rather than calling
1211$ fval.
1212$ 5. double angled brackets are now read correctly in << a, 1, 2 >>.
1213$ 6. we have added a control card option snap=1/1 which prints a snap
1214$ after each error message.
1215$ 7. we have added a control card parameter assert=1/2 which controls
1216$ the assert statement. its values are:
1217$ 0: ignore all assertions
1218$ 1: print error message for assertions which fail
1219$ 2: also print message for assertions which work
1220$ 8. we fixed a bug in the declarations for 'opname2'. this is
1221$ one of the arrays which contains the names of q2 opcodes.
1222$ 9. we moved some macros out of the member 'q2_macs' so that the
1223$ little compiler doesn't overflow when we compile the code
1224$ generator.
1225$ 10. we fixed a variety of bugs in the union, intersection and set
1226$ difference routines. these include miscellaneous coding bugs,
1227$ and incorrect treatment of smaps which become multivalued.
1228$ 11. we fixed several bugs in the equality routine invloving based
1229$ sets and maps.
1230$ 12. we fixed a bug in copying sets.
1231$ 13. we changed 'match' and 'rmatch' to have the correct semantics.
1232$ 14. the foriegn i/o, spec, and unspec routines now access packed
1233$ tuples correctly. psets are also represented as packed tuple(1...1
1234
1235
1236$ 11-15-78 78319 a. grand and s. freudenberger
1237
1238$ 1. it fixes 'lt' and 'ge' to handle mixed long and short
1239$ integers correctly.
1240$ 2. it fixes the q2 dump to print the q2_lev operator properly.
1241$ 3. it fixes the eof operator. this includes both changes to 'eof'
1242$ itself and changes to the buffers used by the 'read' routines.
1243
1244
1245
1246
1 .=member stlini
2 subr stlini;
3$
4$ this is the root module for the setl run time system. it contains
5$ the table declarations which define q2, plus some initialisation
6$ code.
7$
8 +* prog_level = $ program level(julian date of last fix)
smff 9 'lib(85007) '
10 **
11
12
13 .=include cndasm $ conditional assembly
14 .=include sysmac $ machine parameters
15
16 .=include formtab $ form table
17
18 .=include q2flds $ q2 fields to access heap
19
20 .=include q2opcd $ q2 opcodese q2opcd
21 .=include q2macs $ (general) q2 macros
22 .=include q2vars $ global variables
23
24 .=include binio $ definitions for setl binary i/o
mjsa 19 .=include lipkg $ long integer arithmetic package
25 .=include measpkg $ measurement package
26 .=include strpkg $ string primitives
27 .=include mhfpkg $ mapped heap file package
28
29
30 $ define codes for is_xxx operators
31
32 .=zzyorg z
33
34 defc(ist_int) $ integer
35 defc(ist_rea) $ real
36 defc(ist_str) $ string
37 defc(ist_boo) $ boolean
38 defc(ist_ato) $ atom
39 defc(ist_pri) $ primitive
40 defc(ist_tup) $ tuple
41 defc(ist_set) $ set
42 defc(ist_map) $ map
43
44 +* ist_max = ist_map ** $ maximum ist_ value
45
46
47
48
49$ codes for real elementary functions
50$ ----- --- ---- ---------- ---------
51
52$ several of the real elementary functions are implemented in a
53$ single routine. the following codes are used to distinguish the
54$ various functions.
55
56 .=zzyorg z
57
58 defc(relf_acos) $ acos
59 defc(relf_asin) $ asin
60 defc(relf_atan) $ atan
61 defc(relf_cos) $ cos
62 defc(relf_exp) $ exp
63 defc(relf_log) $ log
64 defc(relf_sin) $ sin
65 defc(relf_sqrt) $ sqrt
66 defc(relf_tan) $ tan
67 defc(relf_tanh) $ tanh
68
69 +* relf_min = relf_acos ** $ first
70 +* relf_max = relf_tanh ** $ last
71
72
73$ the reserved files for the library are:
74
75 .=zzyorg z
76
77 defc(in_file) $ input file
78 defc(out_file) $ output file
79 defc(q2_file) $ q2 file
80 .+hf defc(q2e_file) $ q2 environment file
81$
82$ nb. file 3, the q2_file, is 'private' to the library in the sense
83$ that setl programs will never use this file identifier.
84$ file 4, the q2e_file, is not private, and must therefore be used
85$ in a manner which will avoid conflicts with the executing setl
86$ program.
87$
88
89
90
91$ modes for assert statement
92
93 .=zzyorg z
94
95 defc0(assert_off) $ ignore assertions
96 defc0(assert_part) $ print message on failure
97 defc0(assert_full) $ print message on success/failure
98
99
100
101
102$ begin execution by initializing all debugging aids.
103 .+tr monitor noentry, nostores;
104
105
106 nameset nsio; $ globals used for i/o
107
108 size buffer(buffer_size);
109 dims buffer(file_max);
110
111 data buffer = blank_buffer(file_max);
112
113 size cursor(ps); $ array of cursors for above
114 dims cursor(file_max);
115
116 data cursor = 1(file_max); $ to force new lines
117
118 size rd_char(cs); $ current character being read
119
120 size catab(catab_sz); $ character attribute table
121 dims catab(cs_sz);
122 .-s10.
123$ catab should by default be initialized in data statement.
124$ this not possible for s10 due to little compiler restriction
125$ in length of data statement that shows up here in that 512 distinct
126$ values cannot be initialized. as only s10 will probably have such
127$ a large character set size, we use data statement 'by default' and
128$ use initialization by code for s10 only.
129
130 data catab = 0(cs_sz);
131 ..s10
132
133
134 size last_id(ps); $ number of last input file accessed
135 data last_id = 0;
136
137$ the following variables give the strings used to represent
138$ square brackets and curley brackets in the print routine. these
139$ are selected by control card options.
140
141 size sb_string(.sds. 2); $ string for set braces
142 size lsb_char(chsiz); $ left set brace
143 size rsb_char(chsiz); $ right set brace
144
145 size tb_string(.sds. 2); $ string for tuple brackets
146 size ltb_char(chsiz); $ left tuple bracket
147 size rtb_char(chsiz); $ right tuple bracket
148
149$ -setl_digit- is a zero origined array mapping 0-9 into the
150$ corresponding integers.
151 defzero(setl_digit, a_setl_digit);
152 size a_setl_digit(hs);
153 dims a_setl_digit(10);
154
155$ -rdigit- maps 0-9 into 0.0 to 9.0
156 defzero(rdigit, a_rdigit);
157 real a_rdigit;
158 dims a_rdigit(10);
159
160$ we will need some loop indices, etc. to initialize the above. we
161$ give them unlikely names.
162 size jjj(ps); $ loop index
163 size ccc(ps); $ character code
164
165 .+mc size ctsc(cs); $ converts character to secondary case
166 end nameset nsio;
167
168
169 nameset nsread; $ static variables for coded read
170
171 size read_file(ps), $ little file identifier
172 read_indx(ps); $ index of current argument in arglist
173
174 size read_case(ps); $ code read_xxxx
175 data read_case = read_init;
176
177 size read_key(hs); $ key to distinct sets and tuples
178
179 size read_cntr(hs); $ number of components read so far
180 data read_cntr = 0;
181
182 size read_flag(1); $ flags reading string
183 data read_flag = no;
184
185 size read_len(ps), $ length of string
186 read_ss(ssz); $ string specifier for result
187
188 size read_t1(ps), $ stack pointer at initial entry
189 read_t2(ps); $ local reference stack pointer
190
191 end nameset nsread;
192
193
194 nameset nsgetb; $ static variables for binary read
195
196 size getb_file(ps), $ little file identifier
197 getb_indx(ps); $ index of current argument in arg list
198
199 size getb_case(ps); $ code getb_xxxx
200 data getb_case = getb_init;
201
202 size getb_spec(hs), $ current specifier
203 getb_word(hs), $ last word read
204 getb_ss(ssz); $ string specifier for bt_string
205
206 size getb_cntr(hs); $ number of components read so far
207 data getb_cntr = 0;
208
209 size getb_typ(ps), $ type of header block
210 getb_val(ps), $ value of header block
211 getb_ptr(ps); $ pointer to heap block
212
213 size getb_t1(ps), $ stack pointer at initial entry
214 getb_t2(ps); $ local reference stack pointer
215
216 end nameset nsgetb;
217
218
219 nameset nsintf; $ nameset for fortran interface
220
221 size intf_extadr(ws); $ address of external entry vector
222 size intf_extlen(ws); $ its length
223 data intf_extadr = 0;
224 data intf_extlen = 0;
225
226 size intf_case(ps); $ code intf_xxxx
227 data intf_case = intf_init;
228
229 size intf_parm(ps); $ pointer to start of parameter list
230 size intf_t2(ps); $ pointer to start of auxiliary storage
231 size intf_na(ps); $ length of external parameter list
232 size intf_indx(hs); $ index of current argument
233 size intf_argp(hs); $ index of external parameter
234 size intf_spec(hs); $ specifier
235
236 end nameset nsintf;
237
238 .+s32u.
239 nameset nsvadv;
240 size vadvise(hs); $ switch for vadvise
241 end nameset;
242 ..s32u
sunb 21 .+s68.
sunb 22 nameset nsvadv;
sunb 23 size vadvise(hs); $ switch for vadvise
sunb 24 end nameset;
sunb 25 ..s68
243
244
245$ initialize catab
suna 16 .+r36.
247$ initialize catab for s10 (see comments before near data statement
248$ for catab to see why this must be done).
249 do jjj=1 to cs_sz; catab(jjj) = 0; end do;
suna 17 ..r36
257
258
259$ begin by setting all lexical classes to the error case, then reset
260$ the valid ones.
261 do jjj = 0 to cs_sz-1;
262 lexclass(jjj) = read_error;
263 end do;
264
265$ initialize digits
266 do jjj = 1 to 10;
267 ccc = .ch. jjj, '0123456789';
268
269 alphameric(ccc) = yes;
270 numeric(ccc) = yes;
271 lexclass(ccc) = read_num;
272 dig_val(ccc) = jjj-1;
273 end do;
274
275 do jjj = 1 to 26;
276 ccc = .ch. jjj, 'abcdefghijklmnopqrstuvwxyz';
277
278 alphameric(ccc) = yes;
279 lexclass(ccc) = read_name;
280 .+mc.
281 ccc = ctsc(ccc); $ if secondary case available
282 alphameric(ccc) = yes;
283 lexclass(ccc) = read_name;
284 ..mc
285 end do;
286
287 alphameric(1r^) = yes;
288
289$ initialize classes of special characters
290 lexclass(1r-) = read_num;
291 lexclass(1r#) = read_bool;
292 lexclass(1r+) = read_num;
293 lexclass(1r ) = read_blank;
294 lexclass(1r') = read_str;
295
296 .+s10 lexclass(123) = read_set1; $ left set brace
297 .+s20 lexclass(123) = read_set1; $ left set brace
298 .+s32 lexclass(123) = read_set1; $ left set brace
299 .+s37 lexclass(192) = read_set1; $ left set brace
300 .+s47 lexclass(123) = read_set1; $ left set brace
301 .+s66 lexclass(1r@) = read_set1; $ at sign
suna 18 .+s68 lexclass(123) = read_set1; $ left set brace
302
303 lexclass(1r<) = read_set2;
304 lexclass(1r[) = read_tup1;
305 lexclass(1r() = read_tup2;
306
307 .+s10 lexclass(125) = read_set3; $ right set brace
308 .+s20 lexclass(125) = read_set3; $ right set brace
309 .+s32 lexclass(125) = read_set3; $ right set brace
310 .+s37 lexclass(208) = read_set3; $ right set brace
311 .+s47 lexclass(125) = read_set3; $ right set brace
312 .+s66 lexclass(1r\) = read_set3; $ reverse slant
suna 19 .+s68 lexclass(125) = read_set3; $ right set brace
313
314 lexclass(1r>) = read_set4;
315 lexclass(1r]) = read_tup3;
316 lexclass(1r)) = read_tup3;
317 lexclass(1r/) = read_tup4;
318 lexclass(1r*) = read_om;
319 lexclass(eof_char) = read_eof;
320
321
322$ initialize setl_digit and rdigit
323
324 setl_digit(0) = zero;
325
326 do jjj = 1 to 9;
327 setl_digit(jjj) = setl_digit(jjj-1);
328 add1(setl_digit(jjj));
329 end do;
330
331 data rdigit(0) = 0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0;
332
333
334 nameset nsperf;
335
336 size lcs_flag(1); $ list statistics
337
338 size stm_exe(ws); $ statements executed
339 data stm_exe = 0;
340
341 size grb_tim(ws); $ garbage collection time
342 data grb_tim = 0;
343
344 size grb_tot(ws); $ number of garbage collections
345 data grb_tot = 0;
346
347 size grb_rec(ws); $ number of words recovered
348 data grb_rec = 0;
349
350 size init_heap_len(ws); $ initial heap length
351 data init_heap_len = 0;
352
353 end nameset nsperf;
354
355
356 end subr stlini;
1 .=member stllib
2 prog stllib;
3$
4$ this is the default setl interpreter, for historical reasons known
5$ as stllib (or lib). it merely initialises the setl run time system
6$ by calling stlini, then initialises the environment by calling
7$ libini, an then starts interpreting. since this is a little main
8$ program, this routine implicitly call ltlini to initialise the
9$ little run time system.
10$
11 call stlini; $ initialise the setl library
12
13 call libini; $ read the control card parameters and
14 $ the heap
15
16 $ call the interpreter
17 .+s10 call interp;
18 .+s20 call interp;
19 .+s32 while 1; call envssi; end while;
20 .+s37 call interp;
21 .+s47 call interp;
22 .+s66 call interp;
suna 20 .+s68 call envssi;
23
24$ nb. we never return from the interpreter; instead, execution is
25$ terminated when we reach a q2_stop instruction.
26
27
28 end prog stllib;
1 .=member stlint
2
3
4 .+defenv_envfor.
5
6
7 subr stlint(extvec, extlen);
8
9
10 size extvec(ws); $ external entry vector
11 size extlen(ws); $ length of external entry vector
12
13 size pimadr(ws); $ returns absolute memory address
14
15 access nsintf;
16
17
18 intf_extadr = pimadr(extvec);
19 intf_extlen = extlen;
20
21$
22$ this is the fortran callable setl interpreter. it is identical to
23$ the default interpreter as far as the interpretation of the setl
24$ code is concerned, but in addition contains the code to initialise
25$ the little run time system and with set up communication to fortran.
26$
27 call ltlini(0); $ initialise the little library
28
29 call stlini; $ initialise the setl library
30
31 call libini; $ read the control card parameters and
32 $ the heap
33
34 $ call the interpreter
35 .+s10 call interp;
36 .+s20 call interp;
37 .+s32 while 1; call envssi; end while;
38 .+s37 call interp;
39 .+s47 while 1; call envssi; end while;;
40 .+s66 call interp;
suna 21 .+s68 call envssi;
41
42$ nb. we never return from the interpreter; instead, execution is
43$ terminated when we reach a q2_stop instruction.
44
45
46 end subr stlint;
47
48
49 ..defenv_envfor
50
51
52
53 .+tr trace entry;
54
55 .+part1.
56
57
1 .=member libini
2 subr libini;
3
4$ this routine is called to initialize the environment. it performs
5$ three types of initialization:
6
7$ 1. initialize the listing file
8
9$ 2. read control card parameters
10
11$ 3. read the environment from the q2 file and initialize all
12$ related variables.
13
14
15 size q2_title(.sds. filenamlen); $ q2 file
16 size term_title(.sds. filenamlen); $ terminal file
17
18 size ret(ws); $ return value from namesio
19 size ih_lim(ps); $ initial value of h_lim
smfb 61 size mh_lim(ps); $ maximum value for h_lim
20 .+tr size e_flag(1); $ trace entry flag
21 .+tr size s_flag(1); $ trace stores flag
22 size d_flag(1); $ flags initial dump request
23 size t_flag(1); $ on if standard titling desired
24 size len(ps); $ length of bracket string
25 size cur_dim(ws); $ current heap dimension
26 size max_dim(ws); $ maximum heap dimension
27 size max_nf(ps); $ maximum number of open user files
28 size timestr(.sds. 30); $ current time
29 size termh_flag(1); $ print phase heading on terminal
30 .+mc.
31 $ socase is case of string results, such as produced by 'type'
32 $ operator:
33 $ 0 no change (default)
34 $ 1 lower case
35 $ 2 upper case
36 $
37 size socase(ps); $ select output case
38 ..mc
39 size lcp_flag(1); $ list control card parameters
40
41 $ the following two variables are needed to read the form table
42 $ in conjunction with the hf option. the form table should
43 $ eventually be included into the heap, at which point these two
44 $ variables can be deleted.
45 size first(ps); $ first entry of table
46 size last(ps); $ last entry of table
47
48
49 +* getapp_len =
50 .+s10 128
51 .+s20 128
52 .+s32 240
53 .+s37 128
54 .+s47 240
55 .+s66 128
suna 22 .+s68 240
56 **
57
58 size app(.sds. getapp_len);
59 call getapp(app, getapp_len); $ get full parameter string.
60
61$ read control card parameters
62 .+s32u.
63 call getipp(vadvise,'vadvise=0/1');
64 ..s32u
sunb 26 .+s68.
sunb 27 call getipp(vadvise, 'vadvise=1/1');
sunb 28 ..s68
65
66 .+s10 call getspp(q2_title, 'q2=q2/'); $ q2 file
67 .+s20 call getspp(q2_title, 'q2=q2/'); $ q2 file
68 .+s32 call getspp(q2_title, 'q2=q2.tmp/q2.tmp'); $ q2 file
69 .+s37 call getspp(q2_title, 'q2=q2/'); $ q2 file
70 .+s47 call getspp(q2_title, 'q2=q2/'); $ q2 file
71 .+s66 call getspp(q2_title, 'q2=q2/'); $ q2 file
suna 23 .+s68 call getspp(q2_title, 'q2=setl.q2/'); $ q2 file
72
73 term_title='';
74 call namesio(max_no_files,ret,term_title,filenamlen); $ error file
75 if (ret > 1) term_title = ''; $ namesio unavailable or no term
76
77
78 .+tr call getipp(e_flag, 'entry=0/1'); $ trace entry flag
79 .+tr call getipp(s_flag, 'stores=0/1'); $ trace stores flag
80 call getipp(d_flag, 'idump=0/1'); $ initial dump
81 call getipp(t_flag, 'title=0/1'); $ default titling
82 call getipp(assert_mode, 'assert=1/2'); $ assert mode
83 call getipp(debug_flag, 'debug=0/1'); $ run with debugger on
84 call getipp(trace_stmts, 'strace=0/1'); $ trace statements no.s
85 call getipp(trace_calls, 'ctrace=0/1'); $ trace procedure calls
86 call getipp(snap_flag, 'snap=0/1'); $ give snaps for errors
87 call getipp(termh_flag, 'termh=0/1'); $ print phase header
88 call getipp(lcp_flag, 'lcp=0/1'); $ list control parameter
89 call getipp(lcs_flag, 'lcs=0/1'); $ list control statistics
90
91 .+gt call getipp(gtrace, 'gtrace=0/1');
92 .+gt call getipp(gdump, 'gdump=0/1');
93
94 $ if we trace statements or calls globally, we automatically
95 $ enable the trace package
96 if (trace_stmts ! trace_calls) debug_flag = yes;
97$
98$ we assume a minimum heap size of 1024 words, and assume that if
99$ ih_lim is less than this value, it specifies the heap size in
100$ kilo-words. note that the algorithm used here is identical to
101$ the algorithm used in cod.
102$
103 call getipp(ih_lim, 'h=0/0'); $ initial heap length
104 if (0 < ih_lim & ih_lim < 1024) ih_lim = ih_lim * 1024;
105 if (ih_lim = 0) ih_lim = default_h;
smfb 62
smfb 63 call getipp(mh_lim, 'max_heap=0/0'); $ maximum heap length
smfb 64 if (0 < mh_lim & mh_lim < 1024) mh_lim = mh_lim * 1024;
106
107 call getipp(err_limit, 'rel=0/0'); $ runtime error limit
108
asca 13 .+ascebc.
asca 14 call getipp(ascebc_flag, 'ascii=0/1'); $ ebcdic-to-ascii conv
asca 15 if (ascebc_flag) call aeinit; $ initialise conversion tables
asca 16 ..ascebc
109
110 call getspp(tb_string, 'tb=[]/()'); $ tuple brackets
111
112
113 .+s10.
114 $ use ascii set braces as default set delimiter
115 size sb_parm_string(.sds. 8);
116 data sb_parm_string = 'sb= /';
117 .ch. 4, sb_parm_string = 3b'173';
118 .ch. 5, sb_parm_string = 3b'175';
119 call getspp(sb_string, sb_parm_string); $ set braces
120 ..s10
121
122 .+s20.
123 $ use ascii set braces as default set delimiter
124 size sb_parm_string(.sds. 8);
125 data sb_parm_string = 'sb= /';
126 .ch. 4, sb_parm_string = 3b'173';
127 .ch. 5, sb_parm_string = 3b'175';
128 call getspp(sb_string, sb_parm_string); $ set braces
129 ..s20
130
131
132 .+s32.
133 size sb_parm_string(.sds. 8);
134 data sb_parm_string = 'sb= /';
135 .ch. 4, sb_parm_string = 4b'7b';
136 .ch. 5, sb_parm_string = 4b'7d';
137 call getspp(sb_string, sb_parm_string); $ set braces
138 ..s32
139
140 .+s37 call getspp(sb_string, 'sb=/'); $ set braces
141 .+s47.
142 size sb_parm_string(.sds. 8);
143 data sb_parm_string = 'sb= /';
144 .ch. 4, sb_parm_string = 4b'7b';
145 .ch. 5, sb_parm_string = 4b'7d';
146 call getspp(sb_string, sb_parm_string); $ set braces
147 ..s47
148
149 .+s66 call getspp(sb_string, 'sb=/'); $ set braces
suna 24
suna 25 .+s68.
suna 26 size sb_parm_string(.sds. 8);
suna 27 data sb_parm_string = 'sb= /';
suna 28 .ch. 4, sb_parm_string = 4b'7b';
suna 29 .ch. 5, sb_parm_string = 4b'7d';
suna 30 call getspp(sb_string, sb_parm_string);
suna 31 ..s68
150
151
152 lsb_char = .ch. 1, sb_string; rsb_char = .ch. 2, sb_string;
153 ltb_char = .ch. 1, tb_string; rtb_char = .ch. 2, tb_string;
154
155
156$ turn on trace code if requested
157 .+tr if (e_flag) monitor entry, limit = 10000;
158 .+tr if (s_flag) monitor stores, limit = 10000;
159$
160$ set up initial title if desired
161$
162 if t_flag then
163 call stltitle(yes, 'cims.setl.' .cc. prog_level);
164 end if;
165
166 if termh_flag then
167 $ the following line is printed on the terminal file only
168 call contlpr(26, no); call contlpr(27, yes);
169 call lstime(timestr); $ get current time
170 put, ' start cims.setl.', prog_level: timestr, a, skip;
171 call contlpr(26, yes); call contlpr(27, no);
172 end if;
173
174 if lcp_flag then
175 if (.len. app) then $ if parameters specified.
176 put: app, a, skip(2);
177 end if;
178 end if;
179
180
181 .+mhl_dynamic. $ dynamic heap management
182$
183$ initially allocate a zero-length heap to set up address registers.
184$
185 .+s32v. $ must allocate room for buffers in vms
186 $ first find out how many files the user intends to open:
187 call getipp(max_nf, 'nof=5/5'); $ number of open files
188 ..s32v
189
190 $ then inquire how many words can be allocated:
191 call envmhl(1, cur_dim, max_dim);
192
193 $ then determine what size heap to allocate: this is the minimum
194 $ of the space available minus buffer space for i/o routines, and
smfb 65 $ the initial heap size mh_lim (the h control card parameter).
196 cur_dim = 0;
197 .+s32v.
198 max_dim = max_dim - (max_nf*220*512/4);
199 ..s32v
200 if (max_dim <= 0) call err_fatal(41);
smfb 66 if (0 < mh_lim & mh_lim < max_dim) max_dim = mh_lim;
202
203 $ allocate a zero-length heap which can be expanded to max_dim.
204 call envmhl(2, cur_dim, max_dim);
205 ..mhl_dynamic
206
207
208 .-hf. $ standard system: read q2 file
209$
210$ open the q2 file, check its format, and read it
211$
212 file q2_file access = read, title = q2_title;
213
214 .+s66 rewind q2_file;
215
216 call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
217 call rdheap(q2_file);
218
219 file q2_file access = release;
220
221
222 .+hf. $ heap file mapped to paging file
223 .+s32. $ - for the vax under vms
224
225 call getspp(q2h_title, 'q2h=q2h/'); $ q2 h file
226 call getspp(q2e_title, 'q2e=q2e/'); $ q2 e file
227 call getipp(q2_init_type, 'q2init=0/1'); $ initialisation
228 call getipp(hf_trace, 'hftrace=0/1'); $ trace initialisation
229
230
231 if q2_init_type = 0 then $ standard initialisation
232
233 file q2_file access = read, title = q2_title;
234 call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
235 call rdheap(q2_file); $ read the standard q2 file
236 file q2_file access = release;
237
238 elseif q2_init_type = 1 then $ mapped initialisation
239
240 file q2e_file access = read, title = q2e_title;
241 call chkq2f(q2e_file, q2e_checkw, oldest_q2e, newest_q2e);
242 call rdheap1(q2e_file); $ read the environment block
243
244 $ read the section table from the q2 e file
245 read q2e_file, first, last;
246 read q2e_file, hftab_first(first) to hftab_first(last);
247 read q2e_file, first, hftabp;
248 read q2e_file, hftab_last(first) to hftab_last(hftabp);
249
250 $ map the q2 h file into the paging table
251 call getspace(h_lim, yes);
252 call hfmapr(no);
253
254 $ the form table really should be integrated into the heap.
255 +* get_slice(file, table, first, last) =
256 read file, first, last;
257 if first <= last then
258 read file, table(first) to table(last);
259 end if;
260 **
261
262 get_slice(q2e_file, a_formtab, 1, formtabp+1)
263 get_slice(q2e_file, mttab, 1, mttabp)
264
265 macdrop(get_slice)
266
267 file q2e_file access = release;
268
269 elseif q2_init_type = 2 then $ build mapped files
270
271 $ open the standard q2 file and check its format
272 file q2_file access = read, title = q2_title;
273 call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
274
275 $ create the q2 e file
276 file q2e_file access = write, title = q2e_title;
277 write q2e_file, q2e_checkw, current_q2e;
278
279 call rdheap1(q2_file); $ read the environment block
280 call getspace(h_lim, yes); $ allocate a heap of proper size
281 call hfcrst; $ build the section table
282 call hfmapr(yes); $ open section file for creation
283
284 $ read the heap again to copy it to the section file
285 rewind q2_file;
286 call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
287 call rdheap(q2_file);
288
289 $ finally write the environment file
290 call wrheap1(q2e_file); $ write the environment block
291
292 $ write the section table to the q2 e file
293 write q2e_file, 1, hftabp;
294 write q2e_file, hftab_first(1) to hftab_first(hftabp);
295 write q2e_file, 1, hftabp;
296 write q2e_file, hftab_last(1) to hftab_last(hftabp);
297
298 $ the form table really should be integrated into the heap.
299 +* put_slice(file, table, first, last) =
300 write file, first, last;
301 if first <= last then
302 write file, table(first) to table(last);
303 end if;
304 **
305
306 put_slice(q2e_file, a_formtab, 1, formtabp+1)
307 put_slice(q2e_file, mttab, 1, mttabp)
308
309 macdrop(put_slice)
310
311 file q2_file access = release;
312 file q2e_file access = release;
313
314 call libterm(0);
315 end if;
316
317 ..s32
318 ..hf
319
320
321 $ increase the heap size if so desired
322 call getspace(ih_lim, no);
323 init_heap_len = h_lim;
324
325
326 .+mc.
327 call getipp(socase,'socase=0/0');
328 if (socase) call fixcas(socase); $ adjust case for type
329 ..mc
330 $ dump the initial heap image if so requested
331 if (d_flag) call dumpds1;
332
333 $ execution starts now:
334 runtime_flag = yes;
335
336
337 end subr libini;
338
339 .+tr notrace entry; $ do not trace entry for interpreter
340
1 .=member rdheap
2 subr rdheap(id);
3$
4$ this routine reads the q2 file from file id.
5$
6 size id(ps); $ little file identifier for q2 file
7
8
9 call rdheap1(id); $ read the environment block
10 if (filestat(id, end)) return;
11 call rdheap2(id); $ read the heap proper
12
13
14 end subr rdheap;
1 .=member rdheap1
2 subr rdheap1(id);
3$
4$ this routine reads the environment block from file id.
5$
6 size id(ps); $ little file identifier for q2 file
7
8
9 $ read environment parameters
10 read id,
11 snam_org, snam_end, $ names table
12 sym_org, sym_end, $ symbol table
13 ca_org, h_org, h, $ heap
14 t, savet, h_lim, $ stack
15 formtabp, mttabp, $ form table
16 codep, $ program counter
17 cur_na, $ number of arguments for the current proc
18 back_flag, $ back tracking allowed
19 last_env, $ pointer to last environment block
20 cur_arg, $ pointer to current stack argument
21 ok_lev, $ number of ok's currently being saved
22 spare9, spare8, $ space for future expansion
23 spare7, spare6, spare5, spare4,
24 spare3, spare2, spare1, spare0;
25
26 $ check for end-of-file
27 if (filestat(id, end)) return;
28
29 $ read addresses of standard values
30 read id,
31 err_mode, back_flag, s_true, s_false, s_okval,
32 s_fid, s_free, s_fmax, s_fmode, s_io1, s_io2,
33 s_pair, s_stat, s_ss1, s_ss2,
34 s_ovar, s_scopes, s_rnspec, s_rnames,
35 s_intf,
36 a_s_types, st_lo, st_hi, st_no;
37
38 $ read spares for expansion
39 read id,
40 s_spare2,
41 s_spare3,
42 s_spare4,
43 s_spare5,
44 s_spare6,
45 s_spare7,
46 s_spare8,
47 s_spare9,
48 s_sparea,
49 s_spareb,
50 s_sparec,
51 s_spared,
52 s_sparee,
53 s_sparef,
54 s_spareg,
55 s_spareh,
56 s_sparei,
57 s_sparej,
58 s_sparek;
59
60
61 end subr rdheap1;
1 .=member rdheap2
2 subr rdheap2(id);
3$
4$ this routine read the heap proper from the file id.
5$
6 size id(ps); $ little file identifier for the q2 file
7
8 size first(ps); $ first component of table
9 size last(ps); $ last component of table
10
11
12$
13$ allocate a heap the same size as the one built by the code generator.
14$
15 call getspace(h_lim, yes);
16$
17$ read the heap
18$
19$ we read the total dynamic storage in the following slices:
20$ - the run time names table
21$ - the symbol table
22$ - the constant area
23$ - the heap proper
24$ - the stack
25$ - the form table (formtab and mttab)
26$
27 +* get_slice(file, table, first, last) =
28 read file, first, last;
29 if (first <= last) read file, table(first) to table(last);
30 **
31
32 get_slice(id, heap, first, last)
33 get_slice(id, heap, first, last)
34 get_slice(id, heap, first, last)
35 get_slice(id, heap, first, last)
smfb 67 get_slice(id, heap, first, last)
36 get_slice(id, heap, first, last)
37 get_slice(id, a_formtab, first, last)
38 get_slice(id, mttab, first, last)
39
40 macdrop(get_slice)
41
42
43 end subr rdheap2;
1 .=member chkq2f
2 subr chkq2f(id, file_check, oldest_date, newest_date);
3$
4$ this routine checks the file format of the q2 file, and report any
5$ errors.
6$
7 size id(ps); $ little file identifier for the q2 file
8 size file_check(ws); $ check word
9 size oldest_date(ws); $ oldest valid date
10 size newest_date(ws); $ newest valid date
11
12
13 if (filestat(id, end)) call libterm(0);
14
15 read id, check_word;
16 if (check_word ^= file_check) call err_q2(1);
17 if (filestat(id, end)) call err_q2(2);
18
19 read id, date_stamp;
20 if (date_stamp < oldest_date) call err_q2(3);
21 if (date_stamp > newest_date) call err_q2(3);
22 if (filestat(id, end)) call err_q2(2);
23
24
25 end subr chkq2f;
1 .=member wrheap
2 subr wrheap(id);
3$
4$ this routine writes the q2 file to file id.
5$
6 size id(ps); $ little file identifier for q2 file
7
8
9 call wrheap1(id); $ write environment block
10 call wrheap2(id); $ write heap proper
11
12
13 end subr wrheap;
1 .=member wrheap1
2 subr wrheap1(id);
3$
4$ this routine writes the environment block of the q2 file to file id.
5$
6 size id(ps); $ little file identifier for the q2 file
7
8
9 $ write environment parameters
10 write id,
11 snam_org, snam_end, $ names table
12 sym_org, sym_end, $ symbol table
13 ca_org, h_org, h, $ heap
14 t, savet, h_lim, $ stack
15 formtabp, mttabp, $ form table
16 codep, $ program counter
17 cur_na, $ number of arguments for the current proc
18 back_flag, $ back tracking allowed
19 last_env, $ pointer to last environment block
20 cur_arg, $ pointer to current stack argument
21 ok_lev, $ number of ok's currently being saved
22 spare9, spare8, $ space for future expansion
23 spare7, spare6, spare5, spare4,
24 spare3, spare2, spare1, spare0;
25
26 $ write various standard values
27 write id,
28 err_mode, back_flag, s_true, s_false, s_okval,
29 s_fid, s_free, s_fmax, s_fmode, s_io1, s_io2,
30 s_pair, s_stat, s_ss1, s_ss2,
31 s_ovar, s_scopes, s_rnspec, s_rnames,
32 s_intf,
33 a_s_types, st_lo, st_hi, st_no;
34
35 $ write spares for future expansions
36 write id,
37 s_spare2,
38 s_spare3,
39 s_spare4,
40 s_spare5,
41 s_spare6,
42 s_spare7,
43 s_spare8,
44 s_spare9,
45 s_sparea,
46 s_spareb,
47 s_sparec,
48 s_spared,
49 s_sparee,
50 s_sparef,
51 s_spareg,
52 s_spareh,
53 s_sparei,
54 s_sparej,
55 s_sparek;
56
57
58 end subr wrheap1;
1 .=member wrheap2
2 subr wrheap2(id);
3$
4$ this routine writes the heap to the file id.
5$
6 size id(ps); $ little file identifier
7
8
9 $ write the heap and related tables
10
11 +* put_slice(file, table, first, last) =
12 write file, first, last;
13 if (first <= last) write file, table(first) to table(last);
14 **
15
16 put_slice(id, heap, snam_org, snam_end) $ names table
17 put_slice(id, heap, sym_org, sym_end) $ symbol table
18 put_slice(id, heap, ca_org, h_org-1) $ constants
19 put_slice(id, heap, h_org, h-1) $ heap proper
smfb 68 put_slice(id, heap, h, h-1) $ dummy slice
20 put_slice(id, heap, savet, h_lim) $ stack
21
22 put_slice(id, a_formtab, 1, formtabp+1) $ form table
23 put_slice(id, mttab, 1, mttabp) $ ...
24
25 macdrop(put_slice)
26
27
28 end subr wrheap2;
1 .=member hfcrst
2
3
4 .+hf. $ heap file mapped to paging file
5 .+s32. $ - for the vax under vms
6
7
8 subr hfcrst;
9$
10$ this routine computes the page indices for the heap slices by
11$ reading though the heap slice portion of the q2 file. thus it
12$ assumes that rdheap1 has been called prior to this routine.
13$
14 access nshf;
15$
16$ obtain heap indices for slice, skip over data.
17$ then convert heap indices to page offsets. report error
18$ if slice begins before end of prior slice. if slice begins
19$ at same page as end of prior slice, must extend the prior
20$ slice. otherwise, build a new table entry.
21$ nb. a page can be mapped once and only once, so it is not an
22$ optimisation to note if the first page p2 of a slice s2 equals the
23$ last page p1 of the preceding slice s1. it is, however, an
24$ optimisation to note that two pages p1 and p2 are contiguous, i.e.
25$ that p2 = p1+1.
26
27 size first(ps); $ first entry of table
28 size last(ps); $ last entry of table
29 size pagcnt(ws); $ page count for slice
30 size total_pages(ps); $ total number of pages mapped
31 size i(ps); $ loop index over heap slices
32
33
34 do i = 1 to hf_slices; $ number of slices
35
36 read q2_file, first, last;
37 if (first > last) cont do i; $ empty slice
38
39 $ skip over the slice
40 read q2_file, heap(first) to heap(last);
41
42 if hf_trace then
43 put ,'hfcrst heap indices: ' :first :last ,nil(10) ,skip;
44 end if;
45
46 $ convert to page offsets
47 first = pageof(first); last = pageof(last);
48
49 if hftabp = 0 then $ if first slice
50 hftabp = 1;
51 hftab_first(hftabp) = first;
52 hftab_last(hftabp) = last;
53
54 elseif first < hftab_last(hftabp) then
55 $ pages overlap: fatal error
56 call err_fatal(56);
57
58 elseif first <= hftab_last(hftabp)+1 then
59 $ if slice contiguous to prior one,just extend prior one
60 hftab_last(hftabp) = last;
61
62 else
63 $ create a new slice
64 hftabp = hftabp + 1;
65 hftab_first(hftabp) = first;
66 hftab_last(hftabp) = last;
67 end if;
68 end do;
69
70 if hf_trace then
71 total_pages = 0; $ total number of pages mapped
72
73 put ,skip
74 ,'page section table:' ,skip(2)
75 ,'index first last length' ,skip
76 ,'----- ----- ---- ------' ,skip(2);
77
78 do i = 1 to hftabp;
79 pagcnt = hftab_last(i) - hftab_first(i) + 1;
80 total_pages = total_pages + pagcnt;
81
82 put :i,i(5) ,x
83 :hftab_first(i),i(8) ,x
84 :hftab_last(i),i(8) ,x
85 :pagcnt,i(8) ,x
86 ,' (' :(pagcnt*512),i(10) ,'.)'
87 ,skip;
88 end do;
89
90 put ,skip
91 ,'mapping ' :total_pages,i ,' pages of the heap.' ,skip;
92 end if;
93
94
95 end subr hfcrst;
1 .=member hfmapr
2 subr hfmapr(rw);
3$
4$ this routine interfaces to vms to map the heap file. the parameter
5$ rw indicates whether the heap file is read (rw=0) or created (rw=1).
6$
7 access nshf;
8
9$ map heap to file. rw is zero if reading the section file,
10$ nonzero to write (create) it.
11
12 size rw(ps); $ flags creation mode
13
14 size rc(ws); $ return code
15
16 size inadr(ws); $ array containing the starting and
17 dims inadr(2); $ ending virtual addresses in the
18 $ process's virtual address space into
19 $ which the section is to be mapped.
20 size retadr(ws); $ array to receive the starting and
21 dims retadr(2); $ ending virtual addresses of the pages
22 $ into which the section was actually
23 $ mapped
24 size chan(ws); $ vms number of the channel on which the
25 $ file has been accessed.
26 size pagcnt(ws); $ number of pages in the section
27 size vbn(ws); $ virtual block number in the file that
28 $ marks the beginning of the section
29
30 size nara(ws); $ file name as vms string
31 dims nara(20);
32
33 size totpages(ws); $ total number of pages to be mapped
34 size i(ps); $ loop index
35
36 size c(cs),wp(ps),cp(cs);
37
38 $ assuming byte addressing, 4 bytes/word, 512 bytes/page, get
39 $ the actual heap address.
40 hf_heap_adr = mptr(heap) * 4;
41 hf_heap_nsadr = hf_heap_adr;
42
43 .f. 1, 9, hf_heap_nsadr = 0; $ get address of start of nameset
44 hf_org = mod(hf_heap_adr, 512);
45
46 $ convert little sds-string into a format acceptable to the
47 $ vms rms open system service.
48 wp = 0; cp = ws+1;
49 do i = 1 to .len. q2h_title;
50 if cp = ws+1 then wp = wp + 1; cp = 1; nara(wp) = 0; end if;
51 .f. cp, 8, nara(wp) = .ch. i, q2h_title; cp = cp + 8;
52 end do;
53
54 $ determine the total number of pages mapped
55 totpages = 0; vbn = 1;
56 do i = 1 to hftabp;
57 totpages = totpages + hftab_last(i) - hftab_first(i) + 1;
58 end do;
59
60 $ open the heap file
61 call hfopen(rc, chan, rw, totpages, nara, (.len. q2h_title));
62 if .f. 1, 1, rc ^= 1 then
63 put ,'error opening mapped heap file ' :q2h_title,a ,skip;
64 put ,'return code ' :rc,b(12,4),skip;
65 call libterm(0);
66 end if;
67
68 $ map each heap slice
69 if hf_trace then
70 put ,skip
71 ,'heap section table:' ,skip(2)
72 ,'index pages disk vbn channel '
73 ,' base last length'
74 ,skip
75 ,'----- ----- -------- ------- '
76 ,' ---- ---- ------'
77 ,skip;
78 end if;
79 do i = 1 to hftabp;
80 inadr(1) = hf_heap_nsadr + 512 * (hftab_first(i)-1);
81 inadr(2) = hf_heap_nsadr + 512 * (hftab_last(i) - 1) + 511;
82 pagcnt = hftab_last(i) - hftab_first(i) + 1;
83 if hf_trace then
84 put ,skip
85 :i,i(5) ,x
86 :pagcnt,i(5) ,x
87 :vbn,i(8) ,x
88 :chan,i(7) ,x
89 :inadr(1),b(8,4) ,x
90 :inadr(2),b(8,4) ,x
91 :pagcnt*512,b(8,4) ,' (' :pagcnt*512,i(10) ,'.)'
92 ,skip;
93 end if;
94
95 call hfcrms(rc, retadr, rw, chan, inadr, pagcnt, vbn);
96
97 if hf_trace then
98 put ,x(29)
99 :retadr(1),b(8,4) ,x
100 :retadr(2),b(8,4) ,x
101 :pagcnt*512,b(8,4) ,' (' :pagcnt*512,i(10) ,'.)'
102 ,skip;
103 end if;
104
105 if .f. 1, 1, rc ^= 1 then
106 put ,'error mapping heap file',skip;
107 put ,'return code ' :rc,b(12,4),skip;
108 call libterm(0);
109 end if;
110
111 vbn = vbn + pagcnt;
112 end do;
113
114 rc = 0;
115
116
117 end subr hfmapr;
118
119
120 macdrop(pageof) macdrop(mptr) macdrop(hf_slices)
121
122
123 ..s32
124 ..hf
125
126 .+tr notrace entry; $ do not trace entry for interpreter
127
1 .=member interp
2 subr interp; $ main interpreter
3
4$ this is the main routine of the interpreter. it is originally
5$ called from -lib-, and is driven by the -q2- quadruples. each
6$ of the cases below corresponds to a -q2- primitive which will
7$ eventually be generated as inline code. a few of them call
8$ the library; the remainder do their work completely in line.
9
10$ due to the limited size of the little compiler, this routine is
11$ sub-divided into four routines, called -interp1- ... -interp4-.
12$ the top-level routine -interp- merely decodes the current
13$ instruction, and then calls the approrpiate subroutine.
14
15$ interface with the garbage collector
16
17$ garbage collections may result either from storage requests within
18$ -interp- or from requests in the library routines it calles. the
19$ latter case poses special problems since library routines may
20$ have assigned pointers to local variables before the garbage
21$ collection takes place. in order to avoid these problems, we
22$ assume that the library never runs out of space, and use
23$ backtracking to make sure our assumption is correct.
24$ more specificly: the garbage collector may be called either from
25$ the interpreter or the library, however it never executes a return.
26$ instead it backs up the interpreter by one instruction and
27$ reactivates it. the library routines which ran out of space are
28$ performed a second time, and thus have no need to hold onto
29$ any pointers.
30
31$ the garbage collector will always restore the recursion stack to
32$ its status prior to entering the library. this means that the
33$ value of -t- must be saved at the beginning of executiion and
34$ every time it is adjusted by the interpreter.
35
36
37$ the interpreter includes various trace features. these are all
38$ part of the condtional assembly group 'ct'(c-ode t-race).
39
40
41$ the current quadruple pointer -codep- is global. thus allows
42$ both the garbage collector and various dump routines to access
43$ it. the remaining variables used by the interpreter are stored
44$ in a seperate nameset. this allows them to be accessed by interp2.
45
46 nameset nsintp;
47
48 size a1(ps), $ arguments of current quadruple
49 a2(ps),
50 a3(ps);
51
52 size a4(ps), $ additional arguments, gotten from the next qu
53 a5(ps), $ quadruple
54 a6(ps);
55
56 size op(ps); $ current opcode
57
58 size t1(hs), $ temporaries used to achieve value return on
59 t2(hs), $ library calls. heap entries cant be passed
60 t3(hs), $ directly if value return is desired
61 t4(hs),
62 t5(hs),
63 t6(hs);
64
65 size p(ps), $ misc. pointer
66 p1(ps),
67 pos(ps); $ pointer returned by locate
68
69 size j(ps), $ loop index
70 indx(ps), $ tuple index
71 card(ps), $ cardinality (or nelt) of tuple
72 ss(ssz), $ string specifier
73 lsw(ps), $ ls_word of local set
74 lsb(ps), $ ls_bit value
75 ebb(ps), $ ls_bit of local set
76 temp(hs); $ heap sized temporary
77
78$ there are three variables used for backtracking:
79
80$ cur_env: points to current environment when tracing thru stack
81$ prev_env: points to previous environment
82$ cur_arg: points to current argument when doing q2_bpop, etc.
83
84 size cur_env(ps); $ pointer to current environment block
85 size prev_env(ps); $ pointer to previous environment block
86
87 data cur_env = 0;
88 data prev_env = 0;
89
90 .+ct size ctrace(1); $ on if tracing interpreter
91 .+ct data ctrace = no;
92
93
94 size init(1); $ flags first call to interpreter
95 data init = yes;
96
97 size entry_time(ws); $ cpu time on first entry to library
98
99 real real1, $ real temporaries
100 real2;
101
102 end nameset nsintp;
103
104
105
106$ we enter the interpreter under one of two conditions:
107
108$ 1. we are about to start the main program. in this case we
109$ initialize the meaurements.
110
111$ 2. we have just done a garbage collection, and we simply
112$ continue where we left off.
113
114 if init then
115 init = no;
116
117 call letime(entry_time);
118 end if;
119
120 .+s32u.
121 if (vadvise&2) call _vadvice(1);
122 ..s32u
sunb 29 .+s68.
sunb 30 if (vadvise&2) call _vadvice(1);
sunb 31 ..s68
123
124 while 1; $ main loop. this loop is terminated
125 $ by a call to libterm in one of the
126 $ interpreter routines.
127
128 itotal = itotal + 1;
129
130 .+ct if (ctrace) call dinst(codep);
131
132 .+ic if (codep = 0) call err_fatal(2);
133
134$ unpack the current instruction
135
136 op = codeop(codep);
137
138 a1 = codea1(codep);
139 a2 = codea2(codep);
140 a3 = codea3(codep);
141
142$ initialize measurements
143
144 .+st add_stat(st_nubbin, op_time(op));
145
146
147$ check op range and branch to appropriate interpreter routine
148
stra 14 if op <= q2_ssubst then
stra 15 if op <= q2_ninr then
stra 16 .+ic if (op < q2_minimum) call err_fatal(3);
stra 17 call intrp1;
stra 18 else $ op > q2_ninr
stra 19 call intrp2;
stra 20 end if;
stra 21 else $ op > q2_ssubst
stra 22 if op <= q2_nextd then
stra 23 call intrp3;
stra 24 else $ op > q2_nextd
stra 25 .+ic if (op > q2_maximum) call err_fatal(3);
stra 26 call intrp4;
stra 27 end if;
stra 28 end if;
164
165 .+st save_time(st_lib);
166
167$ we will sometimes compile the library with the 'icr' option
168$ turned on for all routines except the interpreter. when we do this,
169$ the st_lib category will include all the time spent in general library
170$ routines, excluding the interpreter.
171
172$ each of the four interpreter routines begins with the macro
173$ 'init_time(st_lib)'. this initializes the counter for library
174$ time to icr_zero. icr_zero is a negative number equal to 0 -
175$ the cost of the calls to icrsel, icrput, and icrget which occur
176$ in the interpreter.
177
178$ when we compile the interpreter with the icr option off, we will
179$ not charge for these calls. this may cause the library time to
180$ appear negative. we include conditional code to correct for this.
181
182 .+sti add_stat(st_lib, - icr_zero);
183
184
185 end while;
186
187
188 end subr interp;
1 .=member intrp1
2 subr intrp1;
3
4
5 access nsintp;
6
7 size add(hs), addli(hs), addstr(hs), addtup(hs),
8 diff(hs), diffli(hs),
9 mult(hs), multli(hs), multstr(hs), multtup(hs),
10 slash(hs),
11 div(hs), divli(hs),
12 smod(hs), modli(hs),
13 sexp(hs),
14 shiftl(hs),
15 shiftr(hs),
16 real_over(1),
17 real_under(1),
18 union(hs), unset(hs), unlset(hs), unrset(hs),
19 intersect(hs), inset(hs), inlset(hs), inrset(hs),
20 setdiff(hs), difset(hs), diflset(hs), difrset(hs),
21 setmod(hs),
22 member(1), memset(1),
23 incs(1),
24 lt(1),
26 equal(1), nullp(1),
27 with(hs), withs(hs), withm(hs),
28 less(hs),
29 lessf(hs),
30 npow(hs),
31 atan2f(hs),
32 smin(hs),
33 smax(hs),
34 copy1(hs), convert(hs);
35
36
37 .+st init_time(st_lib); $ start measuring library time
38
39 go to case(op) in q2_copy to q2_ninr;
40
41
42$ section 1: utilities
43$ ------- -- ---------
44
45/case(q2_copy)/ $ copy
46
47 heap(a1) = copy1(heap(a2));
48 go to nxt;
49
50
51
52/case(q2_ccopy)/ $ copy if share bit set.
53
54 heap(a1) = heap(a2);
55 maycopy(heap(a1));
56 go to nxt;
57
58
59/case(q2_share)/ $ set share bit of a1
60
61 is_shared(a1) = yes;
62 go to nxt;
63
64
65$ section 2: binary operators
66$ ------- -- ------ ---------
67
68$ these operations all take the form:
69
70$ a1 = a2 -op- a3
71
72
73
74
75$ general arithmetic: +, -, *, /, and // on undeclared variables
76
77$ these cases begin by trying to perform short integer arithmetic.
78$ if this yields an overflow, the inputs are probably not short ints,
79$ so we go off line. otherwise we have our answer.
80
81/case(q2_add)/ $ +
82
83 t2 = heap(a2);
84 t3 = heap(a3);
85 temp = otvalue_ t2 + otvalue_ t3;
86
87 if temp <= maxsi then
88 otvalue(a1) = temp;
89 else
90 heap(a1) = add(t2, t3, codea4(codep));
91 end if;
92
93 go to nxt;
94
95
96
97/case(q2_div)/ $ /
98
99 if otvalue(a2) > maxsi ! otvalue(a3) > maxsi then
100 heap(a1) = div(heap(a2), heap(a3));
101
102 elseif value(a3) = 0 then $ division by 0
103
104 call err_misc(1);
105 otvalue(a1) = err_val(f_gen);
106
107 else
108 otvalue(a1) = otvalue(a2) / otvalue(a3);
109 end if;
110
111 go to nxt;
112
113
114
115/case(q2_mult)/ $ *
116
117 if .fb. otvalue(a2) + .fb. otvalue(a3) > .fb. maxsi then
118 heap(a1) = mult(heap(a2), heap(a3), codea4(codep));
119 else
120 otvalue(a1) = otvalue(a2) * otvalue(a3);
121 end if;
122
123 go to nxt;
124
125
126
127/case(q2_sub)/ $ -
128
129 if otvalue(a2) > maxsi ! otvalue(a3) > maxsi then
130 heap(a1) = diff(heap(a2), heap(a3), codea4(codep));
131 else
132 temp = otvalue(a2) - otvalue(a3);
133
134 if temp < 0 then
135 heap(a1) = diffli(heap(a2), heap(a3));
136 else
137 otvalue(a1) = temp;
138 end if;
139 end if;
140
141 go to nxt;
142
143
144
145/case(q2_mod)/ $ //
146
mjsa 20 if otvalue(a2) <= maxsi & otvalue(a3) <= maxsi then
148 otvalue(a1) = mod(otvalue(a2), otvalue(a3)); $ little mod fun
149
150 else
151 heap(a1) = smod(heap(a2), heap(a3)); $ setl mod function
152 end if;
153
154 go to nxt;
155
156
157/case(q2_slash)/ $ division yielding real
158
159 if (otvalue(a2) <= maxsi & otvalue(a3) <= maxsi)
160 go to case(q2_slashi);
161
162 heap(a1) = slash(heap(a2), heap(a3));
163 go to nxt;
164
165
166
167 /case(q2_exp)/
168
169 heap(a1) = sexp(heap(a2), heap(a3));
170 go to nxt;
171
172
173
174 $ short integer arithmetic,
175
176$ these operations include no overflow checks. when such checks are
177$ needed we use the general purpose arithmetic operations.
178
179
180/case(q2_addi)/ $ +
181
182 otvalue(a1) = otvalue(a2) + otvalue(a3);
183 go to nxt;
184
185
186/case(q2_inci)/ $ increment counter
187
188 add1(heap(a1));
189
190 go to nxt;
191
192
193/case(q2_divi)/ $ a1 := a2 div a3
194
195 if otvalue(a3) = 0 then
196 call err_misc(2);
197 heap(a1) = err_val(f_gen);
198
199 else
200 otvalue(a1) = otvalue(a2) / otvalue(a3);
201 end if;
202
203 go to nxt;
204
205
206/case(q2_modi)/ $ //
207
208 otvalue(a1) = mod(otvalue(a2), otvalue(a3));
209
210 go to nxt;
211
212
213/case(q2_slashi)/ $ division yielding real
214
215 get_real(p);
216
217 real1 = float(ivalue(a2));
218 real2 = float(ivalue(a3));
219
220 if real2 = 0.0 then
221 call err_misc(01);
222 heap(a1) = err_val(f_gen);
223 else
224 rval(p) = real1 / real2;
225 end if;
226
227 build_spec(heap(a1), t_real, p);
228 go to nxt;
229
230
231
232
233
234/case(q2_multi)/
235
236 otvalue(a1) = otvalue(a2) * otvalue(a3);
237 go to nxt;
238
239
240
241/case(q2_subi)/ $ -
242
243 otvalue(a1) = otvalue(a2) - otvalue(a3);
244 go to nxt;
245
246
247
248/case(q2_shiftl)/ $ multiply by power of two
249 $ a3 is the number of places to shift.
250 otvalue(a1) = shiftl(otvalue(a2), a3);
251 go to nxt;
252
253
254
255/case(q2_shiftr)/ $ divide by power of 2
256
257 otvalue(a1) = shiftr(otvalue(a2), a3);
258 go to nxt;
259
260
261
262$ untyped integer arithmetic
263
264
265/case(q2_addui)/ $ +
266
267 heap(a1) = heap(a2) + heap(a3);
268 go to nxt;
269
270
271/case(q2_incui)/ $ increment counter
272
273 heap(a1) = heap(a1) + 1;
274
275 go to nxt;
276
277
278/case(q2_divui)/ $ /
279
280 if heap(a3) = 0 then
281 call err_misc(3);
282 heap(a1) = err_val(f_uint);
283 else
284 heap(a1) = heap(a2) / heap(a3);
285 end if;
286
287 go to nxt;
288
289
290/case(q2_multui)/ $ *
291
292 heap(a1) = heap(a2) * heap(a3);
293
294 go to nxt;
295
296
297/case(q2_modui)/ $ //
298
mjsa 21 temp = mod(heap(a2), heap(a3));
smfc 20 if (temp < 0) temp = temp + iabs(heap(a3));
mjsa 23 heap(a1) = temp;
300 go to nxt;
301
302
303/case(q2_slashui)/ $ division yielding umtyped real
304
305 real1 = float(heap(a2));
306 real2 = float(heap(a3));
307
308 if real2 = 0.0 then
309 call err_misc(01);
310 heap(a1) = err_val(f_ureal);
311 else
312 heap(a1) = real1 / real2;
313 end if;
314
315 go to nxt;
316
317
318
319/case(q2_subui)/ $ -
320
321 heap(a1) = heap(a2) - heap(a3);
322 go to nxt;
323
324
325
326/case(q2_shiftlui)/ $ shift left
327
328 heap(a1) = shiftl(heap(a2), a3);
329 go to nxt;
330
331
332
333/case(q2_shiftrui)/
334
335 heap(a1) = shiftr(heap(a2), a3);
336 go to nxt;
337
338
339
340/case(q2_over)/
341
342 if (heap(a2) > maxsi) call err_misc(4);
343
344 go to nxt;
345
346
347
348/case(q2_under)/
349 $ short integer underflow
350 if (heap(a2) < 0) call err_misc(5);
351
352 go to nxt;
353
354
355
356 $ untyped real arithmetic
357
358$ these operations contain no overflow checks. seperate overflow
359$ check operations are provided.
360
361/case(q2_addur)/ $ +
362
363 real1 = heap(a2); $ assign to real temps.
364 real2 = heap(a3);
365 heap(a1) = real1 + real2;
366 go to nxt;
367
368
369
370/case(q2_multur)/ $ *
371
372 real1 = heap(a2);
373 real2 = heap(a3);
374 heap(a1) = real1 * real2;
375 go to nxt;
376
377
378/case(q2_slashur)/ $ -/- on untyped reals
379
380 real1 = heap(a2);
381 real2 = heap(a3);
382
383 if real2 = 0.0 then
384 call err_misc(01);
385 heap(a1) = err_val(f_ureal);
386 else
387 heap(a1) = real1 / real2;
388 end if;
389
390 go to nxt;
391
392
393
394/case(q2_subur)/ $ -
395
396 real1 = heap(a2);
397 real2 = heap(a3);
398 heap(a1) = real1 - real2;
399 go to nxt;
400
401
402
403/case(q2_rover)/ $ real overflow
404$ this is a no-op on machines with built in checking
405
406 if (real_over(heap(a2))) call err_misc(7);
407
408 go to nxt;
409
410
411
412/case(q2_runder)/ $ real underflow. see note above
413
414 if (real_under(heap(a2))) call err_misc(8);
415
416 go to nxt;
417
418
419
420
421
422
423
424 $ long arithmetic
425
426/case(q2_addli)/ $ add long integers
427
428 t2 = heap(a2);
429 t3 = heap(a3);
430 temp = otvalue_ t2 + otvalue_ t3;
431
432 if temp <= maxsi then
433 otvalue(a1) = temp;
434 else
435 heap(a1) = addli(t2, t3);
436 end if;
437
438 go to nxt;
439
440
441/case(q2_addtup)/ $ tuple concatenation
442
443 heap(a1) = addtup(heap(a2), heap(a3));
444 go to nxt;
445
446
447
448/case(q2_addstr)/ $ string concatenation
449
450 heap(a1) = addstr(heap(a2), heap(a3));
451 go to nxt;
452
453
454
455/case(q2_diffli)/ $ long integer subtraction
456
457 t2 = heap(a2); t4 = otvalue_ t2;
458 t3 = heap(a3); t5 = otvalue_ t3;
459
460 if t4 <= maxsi & t5 <= maxsi & t4 >= t5 then
461 otvalue(a1) = t4 - t5;
462 else
463 heap(a1) = diffli(t2, t3);
464 end if;
465
466 go to nxt;
467
468
469
470/case(q2_divli)/ $ long integer division
471
472 t2 = heap(a2); t4 = otvalue_ t2;
473 t3 = heap(a3); t5 = otvalue_ t3;
474
475 if t5 = 0 then
476 call err_misc(01);
477 heap(a1) = err_val(f_gen);
478 elseif t4 <= maxsi & t5 <= maxsi then
479 otvalue(a1) = t4 / t5;
480 else
481 heap(a1) = divli(t2, t3);
482 end if;
483
484 go to nxt;
485
486
487
488/case(q2_modli)/ $ modulo on long integers
489
490 heap(a1) = modli(heap(a2), heap(a3));
491 go to nxt;
492
493
494
495/case(q2_multli)/ $ long integer multiply
496
497 heap(a1) = multli(heap(a2), heap(a3));
498 go to nxt;
499
500
501
502 $ binary operators on sets
503
504
505$ the binary operations on sets assume that their arguments have
506$ compatible reprs and that their first arguments can be used
507$ destructively. the binary operations fall into two categories:
508$ first there are the operations +, -, *, and // which can also
509$ be normal arthmetic operations. here we call the set primitives
510$ directly only if we know the reprs of the output and the two
511$ inputs are the same. otherwise we will call one of the general
512$ arithmetic routines. these routines will coerce their arguments
513$ into matching types by calling the routine 'setup1'.
514
515$ other operations, such as 'with' can only apply to sets.
516$ we have at least two opcodes for each of these quadruples,
517$ one which calls the set primitive directly, and one which
518$ first calls a 'setup' routine to coerce the inputs into
519$ compatible reprs.
520
521$ all binary operations on sets use their first argument destructively.
522$ where necessary they are preceed by a seperate copy quadruple.
523
524/case(q2_union)/ $ union
525
526 heap(a1) = union(heap(a2), heap(a3), yes);
527 go to nxt;
528
529
530
531/case(q2_unset)/ $ union on unbased sets
532
533 heap(a1) = unset(heap(a2), heap(a3));
534 go to nxt;
535
536
537
538/case(q2_unlset)/ $ union on local sets
539
540 heap(a1) = unlset(heap(a2), heap(a3));
541 go to nxt;
542
543
544
545/case(q2_unrset)/ $ union on remote sets
546
547 heap(a1) = unrset(heap(a2), heap(a3));
548 go to nxt;
549
550
551
552/case(q2_inter)/ $ general intersection
553
554 heap(a1) = intersect(heap(a2), heap(a3));
555 go to nxt;
556
557
558/case(q2_inset)/ $ unbased set intersection
559
560 heap(a1) = inset(heap(a2), heap(a3));
561 go to nxt;
562
563
564
565/case(q2_inlset)/ $ local set intersection
566
567 heap(a1) = inlset(heap(a2), heap(a3));
568 go to nxt;
569
570
571
572/case(q2_inrset)/ $ remote set intersection
573
574 heap(a1) = inrset(heap(a2), heap(a3));
575 go to nxt;
576
577
578
579/case(q2_setdiff)/ $ set difference - general case
580
581 heap(a1) = setdiff(heap(a2), heap(a3));
582 go to nxt;
583
584
585/case(q2_difset)/ $ difference on unbased sets
586
587 heap(a1) = difset(heap(a2), heap(a3));
588 go to nxt;
589
590
591
592/case(q2_diflset)/ $ difference on local sets
593
594 heap(a1) = diflset(heap(a2), heap(a3));
595 go to nxt;
596
597
598
599/case(q2_difrset)/ $ difference on remote sets
600
601 heap(a1) = difrset(heap(a2), heap(a3));
602 go to nxt;
603
604
605
606/case(q2_setmod)/ $ // on sets
607
608 heap(a1) = setmod(heap(a2), heap(a3));
609 go to nxt;
610
611
612 $ with
613
614/case(q2_with)/ $ with - general case
615
616 heap(a1) = with(heap(a2), heap(a3));
617
618 go to nxt;
619
620
621
622/case(q2_withs)/ $ with on declared sets and maps
623
624 is_shared(a3) = yes;
625 heap(a1) = withs(heap(a2), heap(a3), yes);
626
627 go to nxt;
628
629
630
631/case(q2_withus)/ $ unbased sets - equivlent to a locate
632
633 p = value(a2);
634 t3 = heap(a3); $ may get its share bit set
635 call locate(pos, t3, p, yes);
636
637 heap(a1) = heap(a2);
638 value(a1) = p;
639
640 heap(a3) = t3;
641
642 go to nxt;
643
644
645
646/case(q2_withls)/ $ local sets
647
648 p = value(a2);
649 .f. ls_bit(p), 1, heap(value(a3) + ls_word(p)) = yes;
650
651 heap(a1) = heap(a2);
652 go to nxt;
653
654
655
656/case(q2_withrs)/ $ remote sets
657
658 indx = ebindx(value(a3)); $ get index of in2
659 p = value(a2);
660
661 if indx > rs_maxi(p) then
662 heap(a1) = withs(heap(a2), heap(a3), no);
663 else
664 rsbit(p, indx) = yes;
665 heap(a1) = heap(a2);
666 end if;
667
668 go to nxt;
669
670
671
672/case(q2_witht)/ $ with on tuples
673
smfd 14 if is_om(a3) = no then
smfd 15
smfd 16 p = value(a2);
smfd 17 card = nelt(p) + 1;
smfd 18
smfd 19 if card > maxindx(p) then
smfd 20 t2 = heap(a2);
smfd 21 call exptup(t2, card);
smfd 22 heap(a2) = t2; p = value_ t2;
smfd 23 end if;
smfd 24
smfd 25 is_shared(a3) = yes;
smfd 26 tcomp(p, card) = heap(a3);
smfd 27 nelt(p) = card;
smfd 28 end if;
smfd 29
smfd 30 heap(a1) = heap(a2);
smfd 31
smfd 32 go to nxt;
677
678
679
680/case(q2_withut)/ $ untyped tuples
681
682 p = value(a2);
683 card = nelt(p);
684
685 if heap(a3) ^= tcomp(p, 0) then $ a3 ^= om
686 card = card + 1;
687
688 if card > maxindx(p) then
689 t2 = heap(a2);
690 call exptup(t2, card);
691
692 heap(a2) = t2;
693 p = value(a2);
694 end if;
695
696 nelt(p) = card;
697 tcomp(p, card) = heap(a3);
698 end if;
699
700 heap(a1) = heap(a2);
701
702 go to nxt;
703
704
705
706/case(q2_withm)/ $ with on maps
707
708$ this case handles the case
709
710$ a1 = a2 with >> where a2 and a3 are
711$ n variate maps. rather than building the nested tuple and then
712$ throwing it away immediately, we simply push x1 ... xn+1 onto
713$ the stack and call a special version of the with routine.
714$ here a3 is an immediate operand and gives the value of n.
715
716 .+dead.
717
718 heap(a1) = withm(heap(a2), value(a3), codea4(codep));
719 go to nxt;
720
721 .-dead.
722 call err_fatal(57);
723 ..dead
724
725
726
727 $ less
728
729
730/case(q2_less)/ $ general case
731
732 heap(a1) = less(heap(a2), heap(a3));
733 go to nxt;
734
735
736
737/case(q2_lessls)/ $ local set
738
739 t2 = heap(a2); p = value_ t2;
740 .f. ls_bit(p), 1, heap(value(a3) + ls_word(p)) = no;
741 heap(a1) = t2;
742
743 go to nxt;
744
745
746
747/case(q2_lessrs)/ $ remote sets
748
749 indx = ebindx(value(a3)); $ get index of in2
750 p = value(a2);
751
752 if indx <= rs_maxi(p) then
753 rsbit(p, indx) = no;
754 end if;
755
756 heap(a1) = heap(a2);
757
758 go to nxt;
759
760 $ lessf
761
762/case(q2_lessf)/ $ general
763
764 heap(a1) = lessf(heap(a2), heap(a3));
765 go to nxt;
766
767
768
769/case(q2_lessflm)/ $ local map
770
771 p = value(a2);
772 lsw = ls_word(p);
773
774 heap(value(a3) + lsw) = heap(template(p) + lsw);
775
776 heap(a1) = heap(a2);
777 go to nxt;
778
779
780
781/case(q2_lessfrm)/ $ remote maps.
782
783 indx = ebindx(value(a3)); $ get index
784 p = value(a2) + hl_rmap;
785
786 if indx <= maxindx(p) then
787 tcomp(p, indx) = tcomp(p, 0);
788 end if;
789
790 heap(a1) = heap(a2); $ copy specifier
791 go to nxt;
792
793
794
795/case(q2_from)/ $ from
796
797 t2 = heap(a2);
798
799 call from(t1, t2);
800
801 heap(a2) = t2;
802 heap(a1) = t1;
803
804 go to nxt;
805
806
807/case(q2_froms)/ $ from on sets
808
809 t2 = heap(a2);
810
811 call froms(t1, t2);
812
813 heap(a2) = t2;
814 heap(a1) = t1;
815
816 go to nxt;
817
818
819
820/case(q2_fromb)/ $ fromb
821
822 t2 = heap(a2);
823
824 call fromb(t1, t2);
825
826 heap(a2) = t2;
827 heap(a1) = t1;
828
829 go to nxt;
830
831
832/case(q2_frombt)/ $ fromb on tuples
833
834 p = value(a2);
835 card = nelt(p);
836
837 if card > 0 then
838 heap(a1) = tcomp(p, 1);
839 nelt(p) = card - 1;
840 is_hashok(p) = no;
841
842 do indx = 2 to card;
843 tcomp(p, indx-1) = tcomp(p, indx);
844 end do;
845
846 tcomp(p, card) = tcomp(p, 0);
847
848 else
849 heap(a1) = tcomp(p, 0);
850 end if;
851
852 go to nxt;
853
854
855
856/case(q2_frome)/ $ frome
857
858 t2 = heap(a2);
859
860 call frome(t1, t2);
861
862 heap(a2) = t2;
863 heap(a1) = t1;
864
865 go to nxt;
866
867
868/case(q2_fromet)/ $ from - tuples
869
870 p = value(a2);
871 card = nelt(p);
872 temp = tcomp(p, 0);
873
874 if card > 0 then
875 heap(a1) = tcomp(p, card);
876 tcomp(p, card) = temp;
877 is_hashok(p) = no;
878
879 until card = 0;
880 card = card - 1;
881 if (tcomp(p, card) ^= temp) quit until;
882 end until;
883
884 nelt(p) = card;
885
886 else
887 heap(a1) = temp;
888 end if;
889
890 go to nxt;
891
892
893
894/case(q2_mini)/ $ min - short ints
895
896 if value(a2) <= value(a3) then
897 heap(a1) = heap(a2);
898 else
899 heap(a1) = heap(a3);
900 end if;
901
902 go to nxt;
903
904
905
906/case(q2_minui)/ $ .min for untyped ints
907
908 if heap(a2) < heap(a3) then
909 heap(a1) = heap(a2);
910 else
911 heap(a1) = heap(a3);
912 end if;
913
914
915 go to nxt;
916
917
918
919/case(q2_minur)/ $ min. for untyped reals
920
921 real1 = heap(a2);
922 real2 = heap(a3);
923
924 if real1 <= real2 then
925 heap(a1) = real1;
926 else
927 heap(a1) = real2;
928 end if;
929
930 go to nxt;
931
932
933
934/case(q2_min)/ $ min. general case
935
936 heap(a1) = smin(heap(a2), heap(a3));
937 go to nxt;
938
939
940
941/case(q2_maxi)/ $ max. for short ints
942
943 if value(a2) >= value(a3) then
944 heap(a1) = heap(a2);
945 else
946 heap(a1) = heap(a3);
947 end if;
948
949 go to nxt;
950
951
952
953/case(q2_maxui)/ $ .max for untyped ints
954
955 if heap(a2) > heap(a3) then
956 heap(a1) = heap(a2);
957 else
958 heap(a1) = heap(a3);
959 end if;
960
961 go to nxt;
962
963
964
965/case(q2_maxur)/ $ max for untyped reals
966
967 real1 = heap(a2);
968 real2 = heap(a3);
969
970 if real1 >= real2 then
971 heap(a1) = real1;
972 else
973 heap(a1) = real2;
974 end if;
975
976 go to nxt;
977
978
979
980/case(q2_max)/ $ general max
981
982 heap(a1) = smax(heap(a2), heap(a3));
983 go to nxt;
984
985
986
987/case(q2_npow)/
988
989 heap(a1) = npow(heap(a2), heap(a3));
990 go to nxt;
991
992
993
994/case(q2_atan2)/
995
996 heap(a1) = atan2f(heap(a2), heap(a3));
997 go to nxt;
998
999
1000
1001$ relational operators
1002$ ---------- ---------
1003
1004$ these primitives branch to either pass or fail, where we generate the
1005$ setl constants true and false.
1006
1007
1008 $ eq.
1009
1010
1011
1012/case(q2_eq1)/ $ 1 word test
1013
1014 if (heap(a2) .eq. heap(a3)) go to pass;
1015 go to fail;
1016
1017
1018
1019/case(q2_eqv)/ $ equal values and types
1020
1021 if (eq(heap(a2), heap(a3))) go to pass;
1022 go to fail;
1023
1024
1025/case(q2_eq)/ $ general test
1026
1027 if (eq(heap(a2), heap(a3))) go to pass;
1028 if (ne(heap(a2), heap(a3))) go to fail;
1029 if (equal(heap(a2), heap(a3))) go to pass;
1030
1031 go to fail;
1032
1033
1034
1035/case(q2_zr)/ $ test(a2) eq 0
1036
1037 if (ivalue(a2) = 0) go to pass;
1038 go to fail;
1039
1040
1041/case(q2_eqom)/ $ test for om
1042
1043 if (is_om(a2)) go to pass;
1044 go to fail;
1045
1046
1047/case(q2_eqnl)/ $ test set = nl
1048
1049 if (nullp(value(a2))) go to pass;
1050 go to fail;
1051
1052
1053/case(q2_eqnult)/ $ test tuple = nult
1054
1055 if (nelt(value(a2)) = 0) go to pass;
1056 go to fail;
1057
1058
1059 $ ge.
1060
1061/case(q2_gei)/ $ short integer
1062
1063 if (ivalue(a2) >= ivalue(a3)) go to pass;
1064 go to fail;
1065
1066
1067/case(q2_geui)/ $ untyped ints
1068
1069 if (heap(a2) >= heap(a3)) go to pass;
1070 go to fail;
1071
1072
1073/case(q2_geur)/ $ untyped reals
1074
1075 real1 = heap(a2); real2 = heap(a3);
1076
1077 if (real1 >= real2) go to pass;
1078 go to fail;
1079
1080
1081/case(q2_ge)/ $ general
1082
1083 if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_gei);
1084
mjsa 24 if (lt(heap(a2), heap(a3))) go to fail;
mjsa 25 go to pass;
1087
1088
1089/case(q2_incs)/ $ incs.
1090
1091 if (incs(heap(a2), heap(a3))) go to pass;
1092 go to fail;
1093
1094
1095/case(q2_in)/ $ in - general case
1096
1097 if (member(heap(a2), heap(a3))) go to pass;
1098 go to fail;
1099
1100
1101
1102/case(q2_ins)/ $ set or map
1103
1104 if (memset(heap(a2), heap(a3))) go to pass;
1105 go to fail;
1106
1107
1108
1109/case(q2_inu)/ $ unbased set
1110
1111 call locate(pos, heap(a2), value(a3), no); $ locate but dont add
1112 if (loc_found) go to pass;
1113 go to fail;
1114
1115
1116
1117/case(q2_inl)/ $ local subset
1118
1119 p = value(a3); $ pointer to local set
1120
1121 if (.f. ls_bit(p), 1, heap(value(a2)+ls_word(p))) go to pass;
1122 go to fail;
1123
1124
1125
1126/case(q2_inr)/ $ remote subset
1127
1128 indx = ebindx(value(a2)); $ base element block index
1129 p = value(a3); $ pointer to bit string
1130
1131 if (indx > rs_maxi(p)) go to fail;
1132
1133 if (rsbit(p, indx)) go to pass;
1134 go to fail;
1135
1136
1137
1138/case(q2_lti)/ $ short ints
1139
1140 if (ivalue(a2) < ivalue(a3)) go to pass;
1141 go to fail;
1142
1143
1144/case(q2_ltui)/ $ untyped ints
1145
1146 if (heap(a2) < heap(a3)) go to pass;
1147 go to fail;
1148
1149
1150
1151/case(q2_ltur)/ $ untyped reals
1152
1153 real1 = heap(a2); real2 = heap(a3);
1154
1155 if (real1 < real2) go to pass;
1156 go to fail;
1157
1158
1159/case(q2_lt)/ $ general case
1160
1161 if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_lti);
1162
1163 if (lt(heap(a2), heap(a3))) go to pass;
1164 go to fail;
1165
1166
1167/case(q2_ne1)/ $ 1 word test
1168
1169 if (heap(a2) ^= heap(a3)) go to pass;
1170 go to fail;
1171
1172
1173/case(q2_nev)/ $ test values and types
1174
1175 if (^ eq(heap(a2), heap(a3))) go to pass;
1176 go to fail;
1177
1178
1179/case(q2_ne)/ $ general case
1180
1181 if (eq(heap(a2), heap(a3))) go to fail;
1182 if (ne(heap(a2), heap(a3))) go to pass;
1183 if (equal(heap(a2), heap(a3))) go to fail;
1184 go to pass;
1185
1186
1187/case(q2_nz)/ $ test for nonzero
1188
1189 if (ivalue(a2) ^= 0) go to pass;
1190 go to fail;
1191
1192
1193/case(q2_neom)/ $ test for om
1194
1195 if (^ is_om(a2)) go to pass;
1196 go to fail;
1197
1198
1199/case(q2_nenl)/ $ test set ^= nl
1200
1201 if (^ nullp(value(a2))) go to pass;
1202 go to fail;
1203
1204
1205/case(q2_nenult)/ $ test tuple ^= nult
1206
1207 if (nelt(value(a2)) ^= 0) go to pass;
1208 go to fail;
1209
1210
1211/case(q2_nincs)/ $ a1 := not (a2 incs a3)
1212
1213 if ( ^ incs(heap(a2), heap(a3))) go to pass;
1214 go to fail;
1215
1216
1217
1218/case(q2_nin)/ $ general case - offline call
1219
1220 if (member(heap(a2), heap(a3))) go to fail;
1221 go to pass;
1222
1223
1224
1225/case(q2_nins)/ $ set or map
1226
1227 if (memset(heap(a2),heap(a3))) go to fail;
1228 go to pass;
1229
1230
1231
1232/case(q2_ninu)/ $ local subset
1233
1234 call locate(pos,heap(a2),value(a3),no); $ locate but dont add
1235 if (loc_found) go to fail;
1236 go to pass;
1237
1238
1239
1240/case(q2_ninl)/ $ local subset
1241
1242 p = value(a3); $ pointer to local set
1243
1244 if (.f. ls_bit(p), 1, heap(value(a2)+ls_word(p))) go to fail;
1245 go to pass;
1246
1247
1248
1249/case(q2_ninr)/ $ remote subset
1250
1251 indx = ebindx(value(a2)); $ base element block index
1252 p = value(a3); $ pointer to bit string
1253
1254 if (indx > rs_maxi(p)) go to pass;
1255 if (rsbit(p, indx)) go to fail;
1256 go to pass;
1257
1258
1259
1260/pass/ $ return true.
1261
1262 heap(a1) = heap(s_true); go to nxt;
1263
1264
1265/fail/ $ return false.
1266
1267 heap(a1) = heap(s_false); go to nxt;
1268
1269
1270/nxt/
1271
1272 codep = codep + inst_nw;
1273
1274
1275 end subr intrp1;
1 .=member intrp2
2 subr intrp2;
3
4$ this routine contains the second part of the interpreter. at
5$ this point the current quadruple has been unpacked, and we are
6$ ready to jump on its opcode.
7
8
9 size proc(sds_sz), $ name of current routine
10 stmt(ps); $ current statement
11
12 access nsintp;
13
14 size even(1);
15 size isamap(1);
16 size arb(hs), arbs(hs);
17 size dom(hs),
18 range(hs),
19 pow(hs),
20 getnelt(hs),
21 sabs(hs),
22 schar(hs),
23 ceil(hs),
24 floor(hs),
25 sfix(hs),
26 sfloat(hs),
27 srand(hs),
28 relf(hs),
29 sign(hs),
mjsa 26 umin(hs), uminli(hs),
31 str(hs),
32 valr(hs);
33 size nullset(hs), $ functions called
34 nulltup(hs),
35 sdate(hs),
36 endop(hs),
37 subst(hs),
38 send(hs),
39 ssubst(hs), ssbsts(hs),
40 setform(hs),
41 setf1(hs),
42 tupform(hs),
43 convert(hs),
44 copy1(hs);
45
46
47$ begin execution
48
49 .+st init_time(st_lib); $ start measuring library time
50
51 go to case(op) in q2_not to q2_ssubst;
52
53
54$ section 3 - unary operators
55$ ------- - - ----- ---------
56
57
58/case(q2_not)/ $ not - general case
59
60 if (eq(heap(a2), heap(s_false))) go to pass;
61 if (eq(heap(a2), heap(s_true))) go to fail;
62
63 call err_misc(51); heap(a1) = err_val(f_gen);
64
65 go to nxt;
66
67
68/case(q2_even)/ $ even - general case
69
70 if (otype(a2) = t_int) go to case(q2_eveni);
71
72 if (even(heap(a2))) go to pass;
73 go to fail;
74
75
76/case(q2_eveni)/ $ even - integer case
77
78 .+s10 if (^ .f. 1, 1, heap(a2)) go to pass;
79 .+s20 if (^ .f. 1, 1, heap(a2)) go to pass;
suna 32 .+r32 if (^ .f. 3, 1, heap(a2)) go to pass;
83 .+s66 if (^ .f. 1, 1, heap(a2)) go to pass;
84
85 go to fail;
86
87
88/case(q2_evenui)/ $ even - untyped integers
89
90 .+s10 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) < 0 ) ) go to pass;
suna 33 .+r32 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) < 0 ) ) go to pass;
94 .+s66 if (^ .f. 1, 1, heap(a2)) go to pass;
95 go to fail;
96
97
98/case(q2_odd)/ $ odd - general case
99
100 if (otype(a2) = t_int) go to case(q2_oddi);
101
102 if (^ even(heap(a2))) go to pass;
103 go to fail;
104
105
106/case(q2_oddi)/ $ odd - typed integers
107
108 .+s10 if (.f. 1, 1, heap(a2)) go to pass;
109 .+s20 if (.f. 1, 1, heap(a2)) go to pass;
suna 34 .+r32 if (.f. 3, 1, heap(a2)) go to pass;
113 .+s66 if (.f. 1, 1, heap(a2)) go to pass;
114
115 go to fail;
116
117
118/case(q2_oddui)/ $ odd - untyped integers
119
120 .+s10 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) >= 0 ) ) go to pass;
suna 35 .+r32 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) >= 0 ) ) go to pass;
suna 36
124 .+s66 if (.f. 1, 1, heap(a2)) go to pass;
125 go to fail;
126
127
128 /case(q2_isint)/
129 size istype(1);
130 t1 = istype(ist_int, heap(a2));
131 if (t1) go to pass;
132 go to fail;
133
134 /case(q2_isreal)/
135 t1 = istype(ist_rea, heap(a2));
136 if (t1) go to pass;
137 go to fail;
138
139 /case(q2_isstr)/
140 t1 = istype(ist_str, heap(a2));
141 if (t1) go to pass;
142 go to fail;
143
144 /case(q2_isbool)/
145 t1 = istype(ist_boo, heap(a2));
146 if (t1) go to pass;
147 go to fail;
148
149 /case(q2_isatom)/
150 t1 = istype(ist_ato, heap(a2));
151 if (t1) go to pass;
152 go to fail;
153
154 /case(q2_istup)/
155
156 t1 = istype(ist_tup, heap(a2));
157 if (t1) go to pass;
158 go to fail;
159
160 /case(q2_isset)/
161
162 t1 = istype(ist_set, heap(a2));
163 if (t1) go to pass;
164 go to fail;
165
166 /case(q2_ismap)/
167
168 t1 = istype(ist_map, heap(a2));
169 if (t1) go to pass;
170 go to fail;
171
172
173
174
175
176/pass/ $ return true.
177
178 heap(a1) = heap(s_true); go to nxt;
179
180
181/fail/ $ return false.
182
183 heap(a1) = heap(s_false); go to nxt;
184
185
186/case(q2_abs)/ $ abs - general case
187
188 heap(a1) = sabs(heap(a2));
189 go to nxt;
190
191
192/case(q2_absi)/ $ abs - short integers
193
194 build_spec(heap(a1), t_int, iabs(ivalue(a2)));
195 go to nxt;
196
197
198/case(q2_absui)/ $ abs - untyped integers
199
200 heap(a1) = iabs(heap(a2));
201 go to nxt;
202
203
204/case(q2_absur)/ $ abs - untyped reals
205
206 real1 = heap(a2);
207
208 heap(a1) = abs(real1);
209 go to nxt;
210
211
212/case(q2_char)/
213
214 heap(a1) = schar(heap(a2));
215 go to nxt;
216
217
218/case(q2_ceil)/ $ ceil - general case
219
220 heap(a1) = ceil(heap(a2));
221 go to nxt;
222
223
224/case(q2_ceilur)/ $ ceil - untyped reals
225
226 real2 = heap(a2);
227 t1 = ifix(real2); if (float(t1) < real2) t1 = t1 + 1;
228 heap(a1) = t1;
229
230 go to nxt;
231
232
233/case(q2_floor)/ $ floor - general case
234
235 heap(a1) = floor(heap(a2));
236 go to nxt;
237
238
239/case(q2_floorur)/ $ floor - untyped reals
240
241 real2 = heap(a2);
242 t1 = ifix(real2); if (float(t1) > real2) t1 = t1 - 1;
243 heap(a1) = t1;
244
245 go to nxt;
246
247
248/case(q2_fix)/ $ fix - general case
249
250 heap(a1) = sfix(heap(a2));
251 go to nxt;
252
253
254/case(q2_fixur)/ $ fix - untyped reals
255
256 real2 = heap(a2); heap(a1) = ifix(real2);
257 go to nxt;
258
259
260/case(q2_float)/ $ float - general case
261
262 heap(a1) = sfloat(heap(a2));
263 go to nxt;
264
265
266/case(q2_floatui)/ $ float - untyped integer
267
268 heap(a1) = float(heap(a2));
269 go to nxt;
270
271
272/case(q2_arb)/ $ arb
273
274 heap(a1) = arb(heap(a2));
275 go to nxt;
276
277
278/case(q2_arbs)/ $ arb on sets
279
280 heap(a1) = arbs(heap(a2));
281 go to nxt;
282
283
284
285/case(q2_arbt)/ $ tuples
286
287 p = value(a2);
288
289 is_shared_ tcomp(p, 1) = yes;
290 heap(a1) = tcomp(p, 1);
291
292 go to nxt;
293
294
295
296/case(q2_arbut)/ $ untyped tuples
297
298 p = value(a2);
299
300 heap(a1) = tcomp(p, 1);
301
302 go to nxt;
303
304
305
306/case(q2_asrt)/ $ test assertion
307
308 if eq(heap(a1), heap(s_false)) then $ failed
309 if (assert_mode ^= assert_off) call err_misc(9);
310
311 elseif ^ eq(heap(a1), heap(s_true)) then
312 call err_misc(52);
313
314 elseif assert_mode = assert_full then
315 call find_stmt(proc, stmt, codep);
316
317 put, 'assertion passed at statement ': stmt, i,
318 ' in procedure ': proc, a, skip;
319 end if;
320
321 go to nxt;
smfb 69
smfb 70
smfb 71/case(q2_ifasrt)/ $ check if assertions are evaluated
smfb 72
smfb 73 if assert_mode = assert_off then
smfb 74 codep = a1;
smfb 75 return;
smfb 76 end if;
smfb 77
smfb 78 go to nxt;
322
323
324/case(q2_val)/ $ .val
325
326 heap(a1) = valr(heap(a2));
327 go to nxt;
328
329
330
331/case(q2_domain)/ $ dom
332
333 heap(a1) = dom(heap(a2), a3);
334 go to nxt;
335
336
337/case(q2_range)/ $ range
338
339 heap(a1) = range(heap(a2), a3);
340 go to nxt;
341
342
343/case(q2_neltst)/ $ nelt on sets and tuples
344
345 ok_nelt(heap(a2)); $ update nelt.
346 build_spec(heap(a1), t_int, nelt(value(a2)));
347 go to nxt;
348
349
350/case(q2_neltok)/ $ sets and tuples, nelt valid
351
352 build_spec(heap(a1), t_int, nelt(value(a2)));
353 go to nxt;
354
355
356
357/case(q2_neltic)/ $ nelt on indirect chars
358
stra 29 $ fall through to q2_neltc case below.
363
364/case(q2_neltc)/ $ nelt - short chars.
365
stra 30 temp = 0; $ clear share bit, is_om bit, and set type to t_int
stra 31
stra 32 if otype(a2) = t_istring then
stra 33 ivalue_ temp = ss_len(value(a2));
stra 34 elseif otype(a2) = t_string then
stra 35 ivalue_ temp = sc_nchars(a2);
stra 36 else
stra 37 temp = spec_om;
stra 38 end if;
stra 39
stra 40 heap(a1) = temp;
stra 41
368 go to nxt;
369
370
371
372/case(q2_nelt)/ $ nelt - general
373
374 heap(a1) = getnelt(heap(a2));
375 go to nxt;
376
377
378
379/case(q2_pow)/ $ pow
380
381 heap(a1) = pow(heap(a2));
382 go to nxt;
383
384
385
386/case(q2_rand)/ $ random
387
388 heap(a1) = srand(heap(a2));
389 go to nxt;
390
391
392/case(q2_sin)/
393
394 heap(a1) = relf(relf_sin, heap(a2));
395 go to nxt;
396
397
398/case(q2_cos)/
399
400 heap(a1) = relf(relf_cos, heap(a2));
401 go to nxt;
402
403
404/case(q2_tan)/
405
406 heap(a1) = relf(relf_tan, heap(a2));
407 go to nxt;
408
409
410/case(q2_arcsin)/
411
412 heap(a1) = relf(relf_asin, heap(a2));
413 go to nxt;
414
415
416/case(q2_arccos)/
417
418 heap(a1) = relf(relf_acos, heap(a2));
419 go to nxt;
420
421
422/case(q2_arctan)/
423
424 heap(a1) = relf(relf_atan, heap(a2));
425 go to nxt;
426
427
428/case(q2_tanh)/
429
430 heap(a1) = relf(relf_tanh, heap(a2));
431 go to nxt;
432
433
434/case(q2_sqrt)/
435
436 heap(a1) = relf(relf_sqrt, heap(a2));
437 go to nxt;
438
439
440/case(q2_expf)/
441
442 heap(a1) = relf(relf_exp, heap(a2));
443 go to nxt;
444
445
446/case(q2_log)/
447
448 heap(a1) = relf(relf_log, heap(a2));
449 go to nxt;
450
451
452/case(q2_type)/ $ type
453
454 $ n.b. the boolean constants 'true' and 'false' are the two
455 $ blank atoms '0' and 'maxsi', resp.
456
457 temp = heap(a2); deref(temp); temp = otype_ temp;
458
459 if temp = t_atom & (ivalue(a2)=0 ! ivalue(a2)=maxsi) then
460 heap(a1) = heap(s_types(t_max+1));
461 else
462 heap(a1) = heap(s_types(temp));
463 end if;
464
465 go to nxt;
466
467
468/case(q2_umin)/ $ unary minus - general case
469
470 heap(a1) = umin(heap(a2));
471 go to nxt;
472
473
474/case(q2_umini)/ $ unary minus - typed integer case
475
mjsa 27 heap(a1) = uminli(heap(a2));
479
480 go to nxt;
481
482
483/case(q2_uminui)/ $ unary minus - untyped integer case
484
485 heap(a1) = - heap(a2);
486 go to nxt;
487
488
489
490/case(q2_uminur)/ $ unary minus - untyped real case
491
492 real1 =heap(a2);
493 heap(a1) = -real1;
494 go to nxt;
495
496
497
498/case(q2_str)/ $ integer to string conversion
499
500 heap(a1) = str(heap(a2));
501 go to nxt;
502
503
504/case(q2_sign)/ $ .sign
505
506 heap(a1) = sign(heap(a2));
507 go to nxt;
508
509/case(q2_end)/ $ s(i..)
510
511 heap(a1) = endop(heap(a2), heap(a3));
512 go to nxt;
513
514
515/case(q2_subst)/ $ s(i..j)
516
517 a4 = codea1(codep + inst_nw); $ get fourth argument
518
519 heap(a1) = subst(heap(a2), heap(a3), heap(a4));
520
521 codep = codep + 2*inst_nw;
522 return;
523
524
525/case(q2_newat1)/ $ newat - simple case
526
527$ this version of newat generates blank atoms with no extra fields for
528$ basing information. we only allow short atoms to be used for this
529$ purpose. the newat operation is handled by the newat1 macro.
530
531 newat1(heap(a1));
532 go to nxt;
533
534
535
536/case(q2_newat2)/ $ newat - based case
537
538$ allocate long atom with extra fields. a2 is a pointer to the sample
539$ value.
540
541 pos = value(a2); $ pointer to sample value
542 temp = la_nwords(pos); $ length of block
543
544 get_heap(temp, p);
545
546 do j = 0 to temp-1;
547 heap(p+j) = heap(pos+j);
548 end do;
549
550$ set la_value to 'next_latom', then build specifier.
551 la_value(p) = next_latom;
552 next_latom = next_latom + 1;
553
554 build_spec(temp, t_latom, p); heap(a1) = temp;
555
556 go to nxt;
557
558
559/case(q2_time)/ $ time function
560
561 call letime(temp);
562 temp = temp - entry_time; put_intval(temp, t1);
563 heap(a1) = t1;
564
565 go to nxt;
566
567
568/case(q2_date)/ $ date function
569
570 heap(a1) = sdate(0);
571 go to nxt;
572
573/case(q2_na)/ $ number of arguments for current procedure
574
575 build_spec(heap(a1), t_int, cur_na);
576 go to nxt;
577
578
579
580$ set formers
581
582$ the three setformers have:
583
584$ a1: pointer to result
585$ a2: form of result
586$ a3: pointer to short int giving number of elements
587
588$ note that we must always reset savet after these instructions since
589$ the setformer pops the stack.
590
591
592/case(q2_set1)/ $ set or map former
593
594$ build set or map, depending on whether elements are all
595$ pairs.
596
597 heap(a1) = setf1(value(a3));
598
599 savet = t;
600 go to nxt;
601
602/case(q2_set2)/ $ elements are all proper type
603 heap(a1) = setform(a2, value(a3));
604
605 savet = t;
606 go to nxt;
607
608
609
610
611
612
613
614$ tuple formers
615
616$ these have arguments just like the set formers.
617
618/case(q2_tup1)/ $ elements are proper type
619
620 heap(a1) = tupform(a2, value(a3));
621
622 savet = t;
623 go to nxt;
624
625
626/case(q2_tup2)/ $ mixed tuple, elements require conversion
627
628 p = value(a3); $ number of elements
629
630 do j = 1 to p;
631 stack_arg(j, p) = convert(stack_arg(j, p), a2);
632 end do;
633
634 heap(a1) = tupform(a2, p);
635
636 savet = t;
637
638 go to nxt;
639
640
641
642
643
644 $ section 5 - mappings
645
646$ these operations have the form a1 = a2(a3).
647
648 $ of - f(x)
649
650/case(q2_of)/ $ general case
651
652
653 t2 = heap(a2); $ may be converted to a map
654 call of(t1, t2, heap(a3));
655
656 heap(a2) = t2;
657 heap(a1) = t1;
658
659 go to nxt;
660
661
662
663/case(q2_ofcs)/ $ short character string
664
stra 42 $ fall through to q2_ofcl case below.
683
684/case(q2_ofcl)/ $ long chars. index is short int
685
686 indx = otvalue(a3); $ value of index
stra 43 t2 = heap(a2);
stra 44
stra 45 if otype_ t2 = t_istring then
stra 46 ss = value_ t2;
stra 47 if 0 < indx & indx <= ss_len(ss) then
stra 48 temp = spec_char; $ one-character template
stra 49 scchar(temp, 1) = icchar(ss, indx);
stra 50 else
stra 51 temp = heap(ft_samp(f_sstring));
stra 52 end if;
stra 53 elseif otype_ t2 = t_string then
stra 54 if 0 < indx & indx <= sc_nchars_ t2 then
stra 55 temp = spec_char; $ one-character template
stra 56 scchar(temp, 1) = scchar(t2, 1);
stra 57 else
stra 58 temp = heap(ft_samp(f_sstring));
stra 59 end if;
stra 60 end if;
stra 61
stra 62 heap(a1) = temp;
696
697 go to nxt;
698
699
700
701$ tuple cases
702
703/case(q2_oftoks)/ $ index in range, set share bit
704
705 is_shared_ tcomp(value(a2), ivalue(a3)) = yes;
706
707
708
709/case(q2_oftok)/ $ index is in range.
710
711 heap(a1) = tcomp(value(a2), ivalue(a3));
712
713 go to nxt;
714
715
716
717/case(q2_oft)/ $ index is short integer
718
719 p = value(a2); $ pointer to tuple
720
smfb 79 indx = otvalue(a3); $ index
722 if (indx > nelt(p)) indx = 0;
723
724 heap(a1) = tcomp(p, indx);
725
726 go to nxt;
727
728
729
730/case(q2_ofts)/ $ as above, but set share bit
731
732 p = value(a2);
733
smfb 80 indx = otvalue(a3); $ index
735 if (indx > nelt(p)) indx = 0;
736
737 is_shared_ tcomp(p, indx) = yes;
738 heap(a1) = tcomp(p, indx);
739
740 go to nxt;
741
742
743
744$ maps
745
746/case(q2_ofusms)/ $ unbased smap - set share bit
747
748 call locate(pos, heap(a3), value(a2), no);
749 is_shared_ ebimag(pos) = yes;
750 heap(a1) = ebimag(pos);
751
752 go to nxt;
753
754
755
756/case(q2_ofusm)/ $ unbased smap
757
758 call locate(pos, heap(a3), value(a2), no);
759 heap(a1) = ebimag(pos);
760 go to nxt;
761
762
763
764/case(q2_ofums)/ $ unbased, possibly multivalued map. set share bit
765
766 call locate(pos, heap(a3), value(a2), no);
767 is_shared_ ebimag(pos) = yes;
768 heap(a1) = ebimag(pos);
769
770 if (is_multi(a1)) call err_misc(10);
771
772 go to nxt;
773
774
775
776/case(q2_ofum)/ $ unbased map
777
778 call locate(pos, heap(a3), value(a2), no);
779 heap(a1) = ebimag(pos);
780
781 if (is_multi(a1)) call err_misc(11);
782
783 go to nxt;
784
785
786
787/case(q2_oflsms)/ $ local smap - set share bit
788
789 is_shared(value(a3) + ls_word(value(a2))) = yes;
790
791
792
793/case(q2_oflsm)/ $ local smap
794
795 heap(a1) = heap(value(a3)+ls_word(value(a2)));
796 go to nxt;
797
798
799
800/case(q2_oflms)/ $ local map - set share bit
801
802 is_shared(value(a3) + ls_word(value(a2))) = yes;
803
804
805
806/case(q2_oflm)/ $ local map, possibly multivalued
807
808 heap(a1) = heap(value(a3)+ls_word(value(a2)));
809
810 if (is_multi(a1)) call err_misc(12);
811
812 go to nxt;
813
814
815
816/case(q2_ofrsm)/ $ remote smap
817
818 indx = ebindx(value(a3)); $ get base index
819 p = value(a2) + hl_rmap;
820
821 if (indx > maxindx(p)) indx = 0; $ force index to be in range
822 heap(a1) = tcomp(p, indx);
823
824 go to nxt;
825
826
827
828/case(q2_ofrsms)/ $ as above, but set share bit
829
830 indx = ebindx(value(a3));
831 p = value(a2) + hl_rmap;
832
833 if (indx > maxindx(p)) indx = 0;
834
835 is_shared_ tcomp(p, indx) = yes;
836 heap(a1) = tcomp(p, indx);
837
838 go to nxt;
839
840
841
842/case(q2_ofrm)/ $ remote map
843
844 indx = ebindx(value(a3));
845 p = value(a2) + hl_rmap;
846
847 if (indx > maxindx(p)) indx = 0;
848
849 heap(a1) = tcomp(p, indx);
850
851 if (is_multi(a1)) call err_misc(13);
852
853 go to nxt;
854
855
856
857/case(q2_ofrms)/ $ same, but set share bit
858
859 indx = ebindx(value(a3));
860 p = value(a2) + hl_rmap;
861
862 if (indx > maxindx(p)) indx = 0;
863
864 is_shared_ tcomp(p, indx) = yes;
865 heap(a1) = tcomp(p, indx);
866
867 if (is_multi(a1)) call err_misc(14);
868
869 go to nxt;
870
871
872
873$ ofa - y := f<>
874
875/case(q2_ofa)/ $ general case
876
877 t2 = heap(a2); $ may be modified
878 call ofa(t1, t2, heap(a3));
879
880 heap(a2) = t2;
881 heap(a1) = t1;
882
883 go to nxt;
884
885
886
887/case(q2_ofaumms)/ $ unbased mmap - set share bit
888
889 call locate(pos, heap(a3), value(a2), no);
890 is_shared_ ebimag(pos) = yes;
891 heap(a1) = ebimag(pos);
892 is_multi(a1) = no;
893
894 go to nxt;
895
896
897
898/case(q2_ofaumm)/ $ unbased mmap
899
900 call locate(pos, heap(a3), value(a2), no);
901 heap(a1) = ebimag(pos);
902 is_multi(a1) = no;
903 go to nxt;
904
905
906
907/case(q2_ofalmms)/ $ local mmap - set share bit
908
909 is_shared(value(a3) + ls_word(value(a2))) = yes;
910
911
912
913/case(q2_ofalmm)/ $ local mmap
914
915 heap(a1) = heap(value(a3) + ls_word(value(a2)));
916 is_multi(a1) = no;
917 go to nxt;
918
919
920
921/case(q2_ofarmm)/ $ remote mmap
922
923 indx = ebindx(value(a3));
924 p = value(a2) + hl_rmap;
925
926 if (indx > maxindx(p)) indx = 0;
927
928 heap(a1) = tcomp(p, indx);
929 is_multi(a1) = no;
930
931 go to nxt;
932
933
934
935/case(q2_ofarmms)/ $ as above, but set share bit
936
937 indx = ebindx(value(a3));
938 p = value(a2) + hl_rmap;
939
940 if (indx > maxindx(p)) indx = 0;
941
942 is_shared_ tcomp(p, indx) = yes;
943 heap(a1) = tcomp(p, indx);
944
945 is_multi(a1) = no;
946
947 go to nxt;
948
949
950
951 $ section 8 - assignments
952
953$ these have the form a1 = a2.
954
955/case(q2_asn)/ $ simple case
956
957 heap(a1) = heap(a2);
958 go to nxt;
959
960
961
962/case(q2_asnsb)/ $ set share bit
963
964 is_shared(a2) = yes;
965 heap(a1) = heap(a2);
966 go to nxt;
967
968
969
970/case(q2_asnnl)/ $ a2 is form and a3 is size
971
972 heap(a1) = nullset(a2, a3);
973 go to nxt;
974
975
976
977/case(q2_asnnult)/ $ a1 = nult. similar to the above
978
979 heap(a1) = nulltup(a2, a3);
980 go to nxt;
981
982
983
984
985
986/case(q2_push)/ $ stack push
987
988$ a2 is the number of items to be pushed. a1 is the first item to
989$ be pushed; the remaining items to be pushed are in a1 of successive
990$ quadruples. note that whenever the interpreter adjusts the stack,
991$ it must save the new value of t.
992
993 get_stack(a2);
994 savet = t;
995
996 do j = 1 to a2;
997 is_shared(codea1(codep + (j-1) * inst_nw)) = yes;
998 heap(t+a2-j) = heap(codea1(codep + (j-1) * inst_nw));
999 end do;
1000
1001 codep = codep + a2 * inst_nw;
1002 return;
1003
1004
1005
1006/case(q2_pop)/ $ stack pop
1007
1008$ this is the reverse of the above.
1009
1010 do j = 1 to a2;
1011 heap(codea1(codep+ (j-1) * inst_nw)) = heap(t+a2-j);
1012 end do;
1013
1014 free_stack(a2);
1015 savet = t;
1016
1017 codep = codep + a2 * inst_nw;
1018 return;
1019
1020
1021
1022
1023/case(q2_push1)/ $ push a1
1024
1025 is_shared(a1) = yes;
1026
1027 push1(heap(a1));
1028 savet = t;
1029
1030 go to nxt;
1031
1032
1033/case(q2_push1u)/ $ push untyped integer
1034
1035 push1(heap(a1));
1036
1037 build_spec(temp, t_skip, 2);
1038 push1(temp);
1039
1040 savet = t;
1041
1042 go to nxt;
1043
1044
1045
1046/case(q2_pop1)/ $ pop a1
1047
1048 pop1(heap(a1));
1049 savet = t;
1050
1051 go to nxt;
1052
1053
1054
1055/case(q2_free)/ $ free stack space
1056
1057$ this operation is used after passing arguments to the library
1058$ through the stack. it frees value(a1) locations.
1059 free_stack(value(a1));
1060 savet = t;
1061 go to nxt;
1062
1063/case(q2_free1)/ $ free 1 location
1064
1065 free_stack(1);
1066 savet = t;
1067
1068 go to nxt;
1069
1070
1071
1072
1073 $ section 7 - sinister assignments
1074
1075$ these have the form a1(a2) = a3.
1076
1077 $ sof f(x) = y
1078
1079
1080
1081/case(q2_sof)/ $ general case
1082
1083 t1 = heap(a1);
1084
1085 call sof(t1, heap(a2), heap(a3));
1086
1087 heap(a1) = t1;
1088
1089 go to nxt;
1090
1091
1092
1093
1094/case(q2_sofcs)/ $ short chars inputs as above, but y is a 1 character s
1095
stra 63 $ fall through to q2_sofcl case below.
1114
1115/case(q2_sofcl)/ $ long chars. inputs as above
1116
stra 64 t1 = heap(a1); $ get specifier for left-hand side
stra 65 t2 = heap(a2); $ get specifier for index
stra 66 t3 = heap(a3); $ get specifier for right-hand side
stra 67 indx = ivalue_ t2; $ get value of index
1118
strb 8 until 1; $ exit when done.
strb 9 until 2; $ exit when error.
strb 10 if (indx < 1) quit until 2;
strb 11 until 3; $ exit when character in temp.
strb 12 until 4; $ exit if library call.
strb 13 until 5; $ exit if t3 is not a short string.
strb 14 if (otype_ t3 ^= t_string) quit until 5;
strb 15 if (sc_nchars_ t3 ^= 1) quit until 4;
strb 16 temp = scchar(t3, 1); $ get character.
strb 17 quit until 3;
strb 18 end until 5;
strb 19 if (otype_ t3 ^= t_istring) quit until 2;
strb 20 ss = value_ t3; $ get pointer to string block.
strb 21 if (ss_len(ss) ^= 1) quit until 4;
strb 22 temp = icchar(ss, 1);
strb 23 quit until 3;
strb 24 end until 4;
strb 25 t1 = ssubst(t1, t2, t2, t3);
strb 26 quit until 1;
strb 27 end until 3;
strb 28 until 3; $ exit if t1 is not short string.
strb 29 if (otype_ t1 ^= t_string) quit until 3;
strb 30 if (indx > sc_nchars_ t1) quit until 2;
strb 31 t1 = spec_char; scchar(t1, 1) = temp;
strb 32 quit until 1;
strb 33 end until 3;
strb 34 if (otype_ t1 ^= t_istring) quit until 2;
strb 35 ss = value_ t1;
strb 36 if (indx > ss_len(ss)) quit until 2;
strb 37 icchar(ss, indx) = temp;
strb 38 quit until 1;
strb 39 end until 2;
strb 40 t1 = err_val(f_sstring);
strb 41 end until 1;
stra 96
stra 97 heap(a1) = t1;
1128
1129 go to nxt;
1130
1131
1132
1133$ tuples
1134
1135/case(q2_softok)/ $ index assumed in range
1136
1137 tcomp(value(a1), ivalue(a2)) = heap(a3);
1138 go to nxt;
1139
1140
1141
1142/case(q2_soft)/
1143
smfd 33 indx = otvalue(a2); $ index
1145 p = value(a1);
1146
1147 if indx = 0 ! indx >= nelt(p) then $ go off line
1148 t1 = heap(a1);
1149 call sof(t1, heap(a2), heap(a3));
1150 heap(a1) = t1;
1151 else
1152 tcomp(p, indx) = heap(a3);
1153 end if;
1154
1155 go to nxt;
1156
1157
1158
1159$ maps
1160
1161/case(q2_soflm)/ $ local maps + smaps
1162
1163 heap(ls_word(value(a1)) + value(a2)) = heap(a3);
1164 go to nxt;
1165
1166
1167
1168/case(q2_sofrm)/ $ remote maps
1169
1170 indx = ebindx(value(a2)); $ get base index and pointer to tuple
1171 p = value(a1) + hl_rmap;
1172
1173 if indx <= maxindx(p) then $ in range
1174 tcomp(p, indx) = heap(a3);
1175 else
1176 t1 = heap(a1);
1177 call sof(t1, heap(a2), heap(a3)); $ must reallocate
1178 heap(a1) = t1;
1179 end if;
1180
1181 go to nxt;
1182
1183
1184
1185/case(q2_sofa)/ $ general case
1186
1187 t1 = heap(a1);
1188 call sofa(t1, heap(a2), heap(a3), no);
1189 heap(a1) = t1;
1190
1191 go to nxt;
1192
1193
1194
1195/case(q2_sofas)/ $ declared sets
1196
1197 t1 = heap(a1);
1198 call sofa(t1, heap(a2), heap(a3), yes);
1199 heap(a1) = t1;
1200 go to nxt;
1201
1202
1203
1204/case(q2_sofalmm)/ $ local mmap
1205
1206 heap(ls_word(value(a1)) + value(a2)) = heap(a3);
1207 is_multi(ls_word(value(a1)) + value(a2)) = yes;
1208 go to nxt;
1209
1210
1211
1212/case(q2_sofarmm)/ $ remote mmap
1213
1214 $ get index and pointer to tuple
1215 indx = ebindx(value(a2));
1216 p = value(a1) + hl_rmap;
1217
1218 if indx <= maxindx(p) then
1219 tcomp(p, indx) = heap(a3);
1220 is_multi_ tcomp(p, indx) = yes;
1221 else
1222 t1 = heap(a1);
1223 call sofa(t1, heap(a2), heap(a3), yes);
1224 heap(a1) = t1;
1225 end if;
1226
1227 go to nxt;
1228
1229
1230
1231/case(q2_send)/
1232
1233 heap(a1) = send(heap(a1), heap(a2), heap(a3));
1234 go to nxt;
1235
1236
1237
1238/case(q2_ssubst)/ $ the index of y is a1 of the next
1239 $ quadruple.
1240
1241 a4 = codea1(codep + inst_nw);
1242
1243 heap(a1) = ssubst(heap(a1), heap(a2), heap(a3), heap(a4));
1244
1245 codep = codep + 2*inst_nw;
1246 return;
1247
1248
1249
1250/nxt/ $ advance to code pointer and return
1251
1252 codep = codep+inst_nw;
1253
1254
1255 end subr intrp2;
1 .=member intrp3
2 subr intrp3;
3
4$ this is the third of four routines which make up the interpreter.
5$ at this point, the current quadruple has been unpacked, and we
6$ are ready to jump on its opcode.
7
8
9 access nsintp;
10
11 size copy1(hs);
12 size convert(hs);
13 size equal(1), $ functions called
14 nullp(1),
16 incs(1),
17 member(1),
18 memset(1),
19 var_id(sds_sz),
20 lt(1);
21
22
23$ begin exection
24
25 .+st init_time(st_lib); $ start measuring library time
26
27 go to case(op) in q2_eqform1 to q2_nextd;
28
29
30$ section 8: conversions
31$ ---------- -----------
32
33
34$ this section contains opcodes for conversions and related primitives.
35$
36$ we begin with a series of type tests. these are used to determine
37$ whether an undeclared variable already has a desired type or
38$ whether it must be converted. there are three tests:
39$
40$ 1. q2_eqform1
41$
42$ test whether a2 has form a3. if so assign it to a1 and skip
43$ the next instruction. here a3 is always '_ b'.
44$
45$ 2. q2_eqform2
46$
47$ test whether a2 has form a3. if so, copy it and assign the copy
48$ to a1. a3 is a set or tuple.
49$
50$ 3. q2_eqform3
51$
52$ this is like (2) but we set a2-s share bit and assign it to a1.
53$
54$ 4. q2_eqform4
55$
56$ test whether a2 is an element of the plex base a3. since we
57$ cannot compute the pointer if it is not, this yields an error.
58
59/case(q2_eqform1)/
60
61 if type(a2) = t_elmt then
62 if ebform(value(a2)) = a3 then
63 heap(a1) = heap(a2);
64 codep = codep + inst_nw;
65 end if;
66 end if;
67
68 go to nxt;
69
70
71/case(q2_eqform2)/
72
73 if ^ isprim(type(a2)) then
74 if hform(value(a2)) = a3 then
75 heap(a1) = copy1(heap(a2));
76 codep = codep + inst_nw;
77 end if;
78 end if;
79
80 go to nxt;
81
82
83/case(q2_eqform3)/
84
85 if ^ isprim(type(a2)) then
86 if hform(value(a2)) = a3 then
87 is_shared(a2) = yes;
88 heap(a1) = heap(a2);
89 codep = codep + inst_nw;
90 end if;
91 end if;
92
93 go to nxt;
94
95
96/case(q2_eqform4)/ $ check if a2 is element of plex base a3
97
98 temp = heap(a2); deref(temp);
99
100 if type_ temp = t_latom then
101 if la_form(value_ temp) = a3 then
102 heap(a1) = temp;
103 else
104 $ element of wrong plex base
105 call err_type(79);
106 heap(a1) = err_val(a3);
107 end if;
108 elseif is_om_ temp then
109 $ recall that the code generator emits this check only if the
110 $ input had the form f_gen
111 heap(a1) = heap(ft_samp(a3));
112 else
113 $ not an element of a plex base
114 call err_type(80);
115 heap(a1) = err_val(a3);
116 end if;
117
118 go to nxt;
119
120
121/case(q2_convert)/
122$ this opcode performs full conversions. its arguments are:
123
124$ a1: pointer to result
125$ a2: pointer to input
126$ a3: form of result
127
128 heap(a1) = convert(heap(a2), a3);
129
130 go to nxt;
131
132
133
134/case(q2_locate)/ $ locate
135
136$ this opcode locates a2 in a base a3 and returns a pointer to it.
137 if is_om(a2) then
138 temp = template(value(a3));
139 build_spec(heap(a1), t_oelmt, temp)
140 else
141 call locate(temp, heap(a2), value(a3), yes);
142 build_spec(heap(a1), t_elmt, temp)
143 end if;
144
145 go to nxt;
146
147
148
149/case(q2_deref)/ $ multi level dereference
150
151$ assign a1 = a2, then dereference it a3 times.
152
153 temp = heap(a2);
154
155 do j = 1 to a3;
156 deref1(temp);
157 end do;
158
159 heap(a1) = temp;
160
161 go to nxt;
162
163
164
165/case(q2_deref1)/ $ one level dereference
166
167 temp = heap(a2); deref1(temp); heap(a1) = temp;
168
169 go to nxt;
170
171
172
173$ so called 'primitive conversions' are really just type and/or range
174$ checks followed by an assignment. the various opcodes q2_checkxxx
175$ test the type or value of a1 against a2 and abort if the test
176$ fails. a2 is always an immediate argument, such as a type code
177$ or range limit.
178
179
180/case(q2_checktp)/
181
182$ a3 is a form. check that a2 has a type consistent with this form,
183$ then assign it to a1.
184
185 temp = heap(a2);
186
187 deref(temp);
188
189 if otype_ temp = type(ft_samp(a3)) then
190 heap(a1) = temp;
191
stra 98 elseif otype_ temp = t_string & a3 = f_string then $$$ patch $$$
stra 99 heap(a1) = temp; $$$ patch $$$
stra 100 $$$ patch $$$
stra 101 elseif otype_ temp = t_istring & a3 = f_sstring then $$$ patch $$$
stra 102 heap(a1) = temp; $$$ patch $$$
stra 103 $$$ patch $$$
192 else
193 if (^ is_om_ temp) call err_misc(17);
194 heap(a1) = heap(ft_samp(a3));
195 end if;
196
197 go to nxt;
198
199
200
201/case(q2_checki1)/ $ check that a1 is a short int <= a2
202
203 $ check that ivalue(a2) <= tvalue(a1) <= tvalue(a3). this test is
smfb 82 $ only performed on typed long or short integers.
205 t1 = tvalue(a1); t2 = ivalue(a2); t3 = ivalue(a3);
206 if ( ^ (t2 <= t1 & t1 <= t3)) call err_misc(18);
207
208 go to nxt;
209
210
211/case(q2_checki2)/ $ check that a1 is a long or short int
212
213 if (type(a1) = t_int) go to nxt;
214 if (type(a1) = t_lint) go to nxt;
215
216 call err_misc(19);
217
218 go to nxt;
219
220
221/case(q2_chkatom)/ $ check that a2 is a short or long atom
222
223 if type(a2) = t_atom ! type(a2) = t_latom then
224 heap(a1) = heap(a2);
225 else
226 call err_type(81);
227 heap(a1) = err_val(f_atom);
228 end if;
229
230 go to nxt;
231
232
233
234$ the opcodes q2_txxx are used to convert untyped values to typed
235$ values. the corresponding opcodes q2_uxxx are used to convert
236$ the other way.
237
238
239/case(q2_tint1)/ $ short int = untyped int
240
241 if heap(a2) = om_int then $ return om
242 heap(a1) = zero;
243 is_om(a1) = yes;
244
245 elseif heap(a2) < 0 ! heap(a2) > maxsi then
246
247 call err_misc(20);
248
249 else
250 build_spec(heap(a1), t_int, heap(a2));
251 end if;
252
253 go to nxt;
254
255
256/case(q2_tint2)/ $ long int = untyped int
257
258$ we give three possible results, depending on the value of a2:
259
260$ 1. if a2 is om, we yield an om integer 0.
261$ 2. if a2 is small enough, we yield a short integer.
262$ 3. otherwise we yield a 1 word long integer.
263
264 put_intval(heap(a2),heap(a1));
265
266 go to nxt;
267
268
269
270/case(q2_treal)/ $ real := untyped real
271
272 put_realval(heap(a2), heap(a1));
273
274 go to nxt;
275
276
277
278/case(q2_uint1)/ $ untyped int = short int
279
280 if is_om(a2) then
281 heap(a1) = om_int;
282
283 else
284 heap(a1) = ivalue(a2);
285 end if;
286
287 go to nxt;
288
289
290
291/case(q2_uint2)/ $ untyped int = long int
292
293 get_intval(heap(a1), heap(a2));
294
295 go to nxt;
296
297
298
299/case(q2_ureal1)/ $ untyped real = real
300
301 if is_om(a2) then
302 heap(a1) = om_real;
303
304 else
305 heap(a1) = rval(value(a2));
306 end if;
307
308 go to nxt;
309
310
311
312/case(q2_ureal2)/ $ untyped real := general
313
314 if type(a2) = t_real then
315 go to case(q2_ureal1);
316
317 else
318 call err_misc(23);
319
320 end if;
321
322 go to nxt;
323
324
325$ section 9: control primitives
326$ ---------- ------------------
327
328/case(q2_goto)/ $ goto
329
330 codep = a1;
331 return;
332
333
334
335$
336$ case statements: a1 is the case 'map', a2 the value of the
337$
338/case(q2_caset)/ $ a1 is the case tuple, a2 is an integer
339
340 p = value(a1); $ pointer to tuple
smfb 83 indx = otvalue(a2); $ index
342
smfb 84 if 0 < indx & indx <= nelt(p) then
smfb 85 codep = value_ tcomp(p, indx); $ retrieve label
smfb 86 return;
350 end if;
351
352 go to nxt;
353
354
355
356/case(q2_caselsm)/ $ a1 is a local smap, a2 a pointer
357
358 temp = heap(value(a2)+ls_word(value(a1)));
359
360 if ^ is_om_ temp then
361 codep = value_ temp;
362 return;
363 end if;
364
365 go to nxt;
366
367
368
369/case(q2_casersm)/ $ a1 is a remote smap, a2 a pointer
370
371 p = value(a1) + hl_rmap; $ pointer to embedded tuple
372 indx = ebindx(value(a2)); $ base index
373
374 if indx <= maxindx(p) then
375 temp = tcomp(p, indx); $ retrieve label
376
377 if ^ is_om_ temp then
378 codep = value_ temp;
379 return;
380 end if;
381 end if;
382
383 go to nxt;
384
385
386
387/case(q2_caseusm)/ $ a1 is an unbased smap, a2 any setl value
388
389 call locate(pos, heap(a2), value(a1), no); $ locate a2 in a1
390
391 if loc_found then
392 codep = value_ ebimag(pos);
393 return;
394 end if;
395
396 go to nxt;
397
398
399
400 $ branch on equality
401
402/case(q2_goeq1)/ $ one word test
403
404 if heap(a2) = heap(a3) then
405 codep = a1;
406 return;
407 end if;
408
409 go to nxt;
410
411
412
413/case(q2_goeqv)/ $ test value and type
414
415 if eq(heap(a2), heap(a3)) then
416 codep = a1;
417 return;
418 end if;
419
420 go to nxt;
421
422
423
424/case(q2_goeq)/ $ general test
425
426 if eq(heap(a2), heap(a3)) then
427 codep = a1;
428 return;
429
430 elseif ne(heap(a2), heap(a3)) then
431 go to nxt;
432
433 elseif equal(heap(a2), heap(a3)) then
434 codep = a1;
435 return;
436
437 else
438 go to nxt;
439 end if;
440
441
442
443/case(q2_gozr)/ $ branch if a2 = 0
444
445 if tvalue(a2) = 0 then
446 codep = a1;
447 return;
448 end if;
449
450 go to nxt;
451
452
453
454/case(q2_gotrue)/ $ if a2 = true then go to a1; end;
455
456 if (eq(heap(a2), heap(s_false))) go to nxt;
457
458 if eq(heap(a2), heap(s_true)) then
459 codep = a1;
460 return;
461 end if;
462
463 call err_type(64);
464 heap(a1) = err_val(f_gen);
465
466 go to nxt;
467
468
469/case(q2_gofalse)/ $ if a2 = false then go to a1; end;
470
471 if (eq(heap(a2), heap(s_true))) go to nxt;
472
473 if eq(heap(a2), heap(s_false)) then
474 codep = a1;
475 return;
476 end if;
477
478 call err_type(64);
479 heap(a1) = err_val(f_gen);
480
481 go to nxt;
482
483
484/case(q2_goom)/ $ if a2 = om goto a2
485
486 if is_om(a2) then
487 codep = a1;
488 return;
489 end if;
490
491 go to nxt;
492
493
494
495/case(q2_gonl)/ $ branch if heap(a2) = nl.
496 if nullp(value(a2)) then
497 codep = a1;
498 return;
499 end if;
500
501 go to nxt;
502
503
504/case(q2_gonult)/ $ go if tuple = nult
505
506 if nelt(value(a2)) = 0 then
507 codep = a1;
508 return;
509 end if;
510
511 go to nxt;
512
513
514
515/case(q2_gogei)/ $ branch on ge. - short ints.
516
517 if ivalue(a2) >= ivalue(a3) then
518 codep = a1;
519 return;
520 end if;
521
522 go to nxt;
523
524
525/case(q2_gogeui)/ $ untyped ints
526
527 if heap(a2) >= heap(a3) then
528 codep = a1;
529 return;
530 end if;
531
532 go to nxt;
533
534
535
536/case(q2_gogeur)/ $ untyped reals
537
538 real1 = heap(a2);
539 real2 = heap(a3);
540
541 if real1 >= real2 then
542 codep = a1;
543 return;
544 end if;
545
546 go to nxt;
547
548
549
550/case(q2_goge)/ $ branch on ge - general case
551
552 if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_gogei);
553
mjsa 28 if ^ lt(heap(a2), heap(a3)) then
555 codep = a1;
556 return;
557 end if;
558
559 go to nxt;
560
561
562
563/case(q2_goincs)/
564
565 if incs(heap(a2), heap(a3)) then
566 codep = a1;
567 return;
568 end if;
569
570 go to nxt;
571
572
573
574 $ branch on in
575
576
577
578
579/case(q2_goin)/ $ general case
580
581 if member(heap(a2), heap(a3)) then
582 codep = a1;
583 return;
584 end if;
585
586 go to nxt;
587
588
589
590/case(q2_goins)/ $ general set/map case
591
592 if memset(heap(a2), heap(a3)) then
593 codep = a1;
594 return;
595 end if;
596
597 go to nxt;
598
599
600
601/case(q2_goinus)/ $ unbased set
602
603 call locate(pos, heap(a2), value(a3), no);
604 if loc_found then
605 codep = a1;
606 return;
607 end if;
608
609 go to nxt;
610
611
612
613/case(q2_goinl)/ $ local set
614
615 p = value(a3);
616
617 if .f. ls_bit(p), 1, heap(value(a2)+ls_word(p)) then
618 codep = a1;
619 return;
620 end if;
621
622 go to nxt;
623
624
625
626/case(q2_goinr)/ $ remote set
627
628 indx = ebindx(value(a2)); $ get eb index and ptr to bit string
629 p = value(a3);
630
631 if indx > rs_maxi(p) then
632 go to nxt;
633
634 elseif rsbit(p, indx) then
635 codep = a1;
636 return;
637
638 else
639 go to nxt;
640 end if;
641
642
643
644/case(q2_golti)/ $ branch on lt - int
645
646 if ivalue(a2) < ivalue(a3) then
647 codep = a1;
648 return;
649 end if;
650
651 go to nxt;
652
653
654/case(q2_goltui)/ $ untyped ints
655
656 if heap(a2) < heap(a3) then
657 codep = a1;
658 return;
659 end if;
660
661 go to nxt;
662
663
664
665/case(q2_goltur)/ $ untyped reals
666
667 real1 = heap(a2);
668 real2 = heap(a3);
669
670 if real1 < real2 then
671 codep = a1;
672 return;
673 end if;
674
675 go to nxt;
676
677
678
679/case(q2_golt)/ $ branch on lt - general case
680
681 if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_golti);
682
683 if lt(heap(a2), heap(a3)) then
684 codep = a1;
685 return;
686 end if;
687
688 go to nxt;
689
690
691
692/case(q2_gone1)/ $ one word compare
693
694 if heap(a2) ^= heap(a3) then
695 codep = a1;
696 return;
697 end if;
698
699 go to nxt;
700
701
702
703/case(q2_gonev)/ $ compare value and type.
704
705 if ^ eq(heap(a2), heap(a3)) then
706 codep = a1;
707 return;
708 end if;
709
710 go to nxt;
711
712
713
714/case(q2_gone)/ $ general test
715
716 if (eq(heap(a2), heap(a3))) go to nxt;
717
718 if ne(heap(a2), heap(a3)) then
719 codep = a1;
720 return;
721 end if;
722
723 if (equal(heap(a2), heap(a3))) go to nxt;
724
725 codep = a1;
726 return;
727
728
729
730/case(q2_gonz)/ $ branch on non zero
731
732 if ivalue(a2) ^= 0 then
733 codep = a1;
734 return;
735 end if;
736
737 go to nxt;
738
739
740
741/case(q2_gonom)/ $ if a2 /= om then goto a2;;
742
743 if ^ is_om(a2) then
744 codep = a1;
745 return;
746 end if;
747
748 go to nxt;
749
750
751
752/case(q2_gonnl)/ $ branch on not nl
753
754 if ^ nullp(value(a2)) then
755 codep = a1;
756 return;
757 end if;
758
759 go to nxt;
760
761
762/case(q2_gonnult)/ $ branch if tuple ^= nult
763
764 if nelt(value(a2)) ^= 0 then
765 codep = a1;
766 return;
767 end if;
768
769 go to nxt;
770
771
772
773
774/case(q2_gonincs)/ $ if not a2 incs a3 then go to a1; end;
775
776 if ^ incs(heap(a2), heap(a3)) then
777 codep = a1;
778 return;
779 end if;
780
781 go to nxt;
782
783
784/case(q2_gonin)/ $ general case
785
786
787 if ^ member(heap(a2), heap(a3)) then
788 codep = a1;
789 return;
790 end if;
791
792 go to nxt;
793
794
795/case(q2_gonins)/ $ general set/map case
796
797 if ^ memset(heap(a2), heap(a3)) then
798 codep = a1;
799 return;
800 end if;
801
802 go to nxt;
803
804
805
806/case(q2_goninus)/ $ unbased set
807
808 call locate(pos, heap(a2), value(a3), no);
809
810 if ^ loc_found then
811 codep = a1;
812 return;
813 end if;
814
815 go to nxt;
816
817
818
819/case(q2_goninl)/ $ local subset
820
821 p = value(a3);
822
823 if ^ .f. ls_bit(p), 1, heap(value(a2)+ls_word(p)) then
824 codep = a1;
825 return;
826 end if;
827
828 go to nxt;
829
830
831
832/case(q2_goninr)/ $ remote subset
833
834 $ get index and pointer to bit string
835 indx = ebindx(value(a2));
836 p = value(a3);
837
838 if indx > rs_maxi(p) then
839 codep = a1;
840 return;
841
842 elseif ^ rsbit(p, indx) then
843 codep = a1;
844 return;
845 end if;
846
847 go to nxt;
848
849
850
851
852
853$ set iterators - (forall x in s)
854$ --- --------- ---------------
855
856$ this section contains opcodes for four primitives:
857
858$ 1. inext: initialize set iterator
859$ 2. next: advance set iterator
860$ 3. inextd: initialize domain iterator
861$ 4. nextd: advance domain iterator
862
863$ their arguments are:
864
865$ a1: pointer to bound variable
866$ a2: pointer to temporary used to hold place in set
867$ a3: pointer to set
868
869
870
871/case(q2_inexts)/ $ initialize next for set.
872
873 temp = template(value(a3)); $ point to template
874
875 heap(a1) = ebspec(temp);
876 build_spec(heap(a2), t_elmt, temp);
877
878 go to nxt;
879
880
881
882/case(q2_inextt)/ $ initialize next for tuple
883
884 heap(a2) = zero;
885 go to nxt;
886
887
888
889/case(q2_inext)/ $ general initialization
890
891 t3 = heap(a3);
892
893 call inext(t1, t2, t3);
894
895 heap(a1) = t1;
896 heap(a2) = t2;
897 heap(a3) = t3;
898
899 go to nxt;
900
901
902/case(q2_nextus)/ $ next on unbased sets
903
904 p = value(a2); $ get pointer into set
905
906 while 1;
907 p = eblink(p);
908 if (^ is_ebhedr(p)) quit; $ valid element
909 if (is_ebtemp(p)) quit;
910 end while;
911
912 value(a2) = p; $ install new pointer
913 if (is_ebtemp(p)) is_om(a2) = yes;
914
915 is_shared_ ebspec(p) = yes;
916 heap(a1) = ebspec(p);
917
918 go to nxt;
919
920
921
922/case(q2_nextls)/ $ next for local sets
923
924 lsw = ls_word(value(a3)); $ get word and bit position in base
925 lsb = ls_bit(value(a3));
926
927 p = value(a2); $ get pointer into base
928
929 while 1;
930 p = eblink(p);
931 if is_ebhedr(p) then
932 if (is_ebtemp(p)) quit;
933 cont;
934 end if;
935
936 if (.f. lsb, 1, heap(p+lsw)) quit; $ found next element
937 end while;
938
939 value(a2) = p;
940 if (is_ebtemp(p)) is_om(a2) = yes;
941
942 heap(a1) = heap(a2);
943
944 go to nxt;
945
946
947
948/case(q2_nextrs)/ $ next on remote sets
949
950 p = value(a2); $ get pointer into base
951 p1 = value(a3);
952
953 while 1;
954 p = eblink(p); $ advance in base
955 if is_ebhedr(p) then
956 if (is_ebtemp(p)) quit; $ end of set
957 cont;
958 end if;
959
960 $ check set membership
961 indx = ebindx(p);
962 if (indx > rs_maxi(p1)) cont; $ index out of range
963 if (rsbit(p1, indx)) quit; $ found next element
964 end while;
965
966 value(a2) = p; $ store new pointer
967 if (is_ebtemp(p)) is_om(a2) = yes;
968
969 heap(a1) = heap(a2);
970
971 go to nxt;
972
973
974
975/case(q2_nextt)/ $ next for tuples
976
977 indx = ivalue(a2) + 1; $ current index in tuple
978 p = value(a3);
979
980 if indx <= nelt(p) then
981 is_shared_ tcomp(p, indx) = yes;
982 heap(a1) = tcomp(p, indx);
983 ivalue(a2) = indx;
984
985 else
986 heap(a1) = tcomp(p, 0);
987 heap(a2) = spec_om;
988 end if;
989
990 go to nxt;
991
992
993/case(q2_nextut)/ $ untyped tuples
994
995 indx = ivalue(a2) + 1;
996 p = value(a3);
997
998 if indx <= nelt(p) then
999 heap(a1) = tcomp(p, indx);
1000 ivalue(a2) = indx;
1001
1002 else
1003 heap(a1) = tcomp(p, 0);
1004 heap(a2) = spec_om;
1005 end if;
1006
1007 go to nxt;
1008
1009
1010/case(q2_next)/ $ general case
1011
1012 t1 = heap(a1);
1013 t2 = heap(a2);
1014
1015 call next(t1, t2, heap(a3));
1016
1017 heap(a1) = t1;
1018 heap(a2) = t2;
1019
1020 go to nxt;
1021
1022
1023/case(q2_nexts)/ $ next for sets
1024
1025$ this is identical to the general case except that we call 'nexts'
1026$ directly.
1027
1028 t1 = heap(a1);
1029 t2 = heap(a2);
1030
1031 call nexts(t1, t2, heap(a3));
1032
1033 heap(a1) = t1;
1034 heap(a2) = t2;
1035
1036 go to nxt;
1037
1038
1039
1040/case(q2_inextd)/ $ initialize domain iterator
1041
1042 t3 = heap(a3);
1043
1044 call inextd(t1, t2, t3);
1045
1046 heap(a1) = t1;
1047 heap(a2) = t2;
1048 heap(a3) = t3;
1049
1050 go to nxt;
1051
1052
1053/case(q2_nextd)/ $ domain iterator
1054
1055$ this nubbin is very similar to q2_next. the test for the end of
1056$ the loop is a seperate instruction.
1057 t1 = heap(a1);
1058 t2 = heap(a2);
1059
1060 call nextd(t1, t2, heap(a3));
1061
1062 heap(a1) = t1;
1063 heap(a2) = t2;
1064
1065 go to nxt;
1066
1067
1068
1069
1070/nxt/
1071
1072 codep = codep + inst_nw;
1073
1074
1075 end subr intrp3;
1 .=member intrp4
2 subr intrp4;
3
4$ this is the final part of the interpreter.
5
6 access nsintp;
7
8 size var_id(sds_sz),
9 sopen(hs),
10 sclose(hs),
11 print(hs),
12 printa(hs),
13 readr(hs),
14 reada(hs),
15 getr(hs),
16 putr(hs),
17 getb(hs),
18 putb(hs),
19 getk(hs),
20 putk(hs),
21 getf(hs),
22 callf(hs),
23 putf(hs),
24 rewindr(hs),
25 eof(hs),
26 eject(hs),
27 title(hs),
28 shost(hs),
29 sgtipp(hs),
30 sgtspp(hs),
31 getem(hs),
32 setem(hs),
33 span(hs),
34 break(hs),
35 match(hs),
36 lpad(hs),
37 len(hs),
38 sany(hs),
39 notany(hs),
40 rspan(hs),
41 rbreak(hs),
42 rmatch(hs),
43 rpad(hs),
44 rlen(hs),
45 rany(hs),
46 rnotany(hs);
47
48 .+st init_time(st_lib); $ start measuring library time
49
50 go to case(op) in q2_call to q2_maximum;
51
52
53
54
55
56$ subroutine linkage
57
58
59$ each time we call a setl procedure, we stack:
60$ 1. the return address
61$ 2. the number of arguments of the current procedure (i.e. -na-)
62
63$ the following macro gives the number of words saved by each
64$ procedure call:
65
66 +* linkage_nwords = 2 ** $ codep and na
67
68
69/case(q2_call)/ $ call
70
71 build_spec(t1, t_lab, codep + inst_nw);
72 build_spec(t2, t_int, cur_na);
73
74 push2(t1, t2);
75 savet = t;
76
77 codep = a1;
78 cur_na = ivalue(a3);
79
80 return;
81
82
83/case(q2_ucall)/ $ call unsatisfied external
84
85 call err_misc(31);
86
87 cur_arg = 0; $ so 'bpop1' actually pops stack
88
89 go to nxt;
90
91
92/case(q2_retn)/ $ return
93
94 pop2(t2, t1);
95
96 codep = value_ t1;
97 cur_na = value_ t2;
98
99 savet = t;
100
101 return;
102
103$ the following opcodes are used only during assembly code generation, a
104$ are treated as noops:
105
106/case(q2_lab)/
107
108/case(q2_tag)/
109
110/case(q2_mentry)/
111
112/case(q2_pentry)/
113
114 go to nxt;
115
116
117
118
119$ in the opcodes for routine prologues and epilogues, a1 points
120$ to the beginning of a block in the symbol table and a2 is the
121$ length of the block.
122
123
124/case(q2_swap)/ $ swap parameters for recursive call
125
126 temp = t + linkage_nwords;
127 do j = 0 to a2-1;
128 swap( heap(a1+j), heap(temp+j) );
129 end do;
130
131 go to nxt;
132
133
134
135/case(q2_savel)/ $ save local variables on the stack
136
137 get_stack(a2); savet = t;
138
139 do j = 0 to a2-1;
140 heap(t+j) = heap(a1+j); heap(a1+j) = spec_om;
141 end do;
142
143 go to nxt;
144
145
146
147/case(q2_loadp)/ $ move parameters for non-recursive call
148
149 temp = t + linkage_nwords;
150 do j = 0 to a2-1;
151 heap(a1+j) = heap(temp+j);
152 end do;
153
154 go to nxt;
155
156
157
158/case(q2_resetp)/ $ restore params after non-recursive call
159
160 temp = t + linkage_nwords;
161 do j = 0 to a2-1;
162 heap(temp+j) = heap(a1+j);
163 end do;
164
165 go to nxt;
166
167
168
169/case(q2_clearl)/ $ set the local variables to omega
170
171 do j = 0 to a2-1;
172 heap(a1+j) = spec_om;
173 end do;
174
175 go to nxt;
176
177
178
179/case(q2_resetl)/ $ restore local variables from the stack
180
181 do j = 0 to a2-1;
182 heap(a1+j) = heap(t+j);
183 end do;
184
185 free_stack(a2); savet = t;
186
187 go to nxt;
188
189
190
191$ backtracking opcodes
192$ --------------------
193
194$ this section contains opcodes used for backtracking. some of them
195$ duplicate the code for primitives such as q2_swap, etc. which are
196$ generated as part of recursive routine prologues and epilogues. the
197$ compiler will generate one or the other set of instructions depending
198$ on whether backtracking is used.
199$
200$ backtracking operates by placing a series of 'environment blocks' on
201$ the stack. environment blocks have the following format:
202$
203$ word 1: code pointer to instruction to restore environment
204$ word 2: integer giving pointer to next environment block
205$ word 3: integer giving number of saved values
206$
207$ the remaining words contain specifiers for saved values.
208$
209$ there are three types of environment blocks:
210$
211$ 1. entry blocks
212$
213$ entry blocks are created be q2_entry instructions upon entry to a
214$ procedure, or are restored after a conditional return is followed
215$ by a fail, which will result in the execution of an q2_undo
216$ instructions. they are removed by q2_exit instructions, if the
217$ return is unconditional (i.e. no backtracking points remain in this
218$ invocation), or by the q2_dexit instruction after a fail returns
219$ control to a backtracking point before the current invocation.
220$
221$ 2. exit blocks
222$
223$ exit blocks are created whenever a return statement is executed
224$ (i.e. an q2_exit instruction) while there still remain ok blocks on
225$ the stack. this situation requires a conditional return, which can
226$ be reversed if a subsequent fail returns to an ok block of this
227$ procedure. exit blocks are changed back into entry blocks by
228$ q2_undo instructions.
229$
230$ 3. ok blocks
231$
232$ ok blocks are created by the q2_ok instruction and removed by the
233$ q2_succeed and q2_fail2 instructions. they represent the actual
234$ backtracking points to which fail statements return.
235
236
237$ the following global variables are used for backtracking:
238$
239$ 1. back_flag:
240$
241$ this variable is read in with the q2 code. it indicates whether the
242$ compiler generated code for backtracking or whether it used the
243$ standard opcodes for procedure linkage, etc.
244$
245$ 2. last_env:
246$
247$ this variable contains the head of a list of saved environments
248$
249$ 3. ok_lev:
250$
251$ this an integer giving the number of ok blocks currently being
252$ saved. when ok_lev = 0 we are not doing any backtracking, and
253$ procedure linkage is very similar to the code generated when
254$ backtracking is disabled.
255
256
257 +* push_env(codeptr, len) = $ push environment block
258 build_spec(t1, t_int, len);
259 build_spec(t2, t_int, last_env);
260 build_spec(t3, t_lab, codeptr);
261
262 push3(t1, t2, t3); savet = t;
263
264 last_env = t;
265 **
266
267
268/case(q2_bcall)/ $ backtracked procedure call
269
270$ this instruction is identical to q2_call.
271
272 build_spec(t1, t_lab, codep+inst_nw);
273 build_spec(t2, t_int, cur_na);
274
275 push2(t1, t2); savet = t;
276
277 codep = a1;
278 cur_na = value(a3);
279
280 return;
281
282
283/case(q2_entry)/ $ procedure entry
284
285$ the q2_entry instruction is a combination of all the instructions
286$ normally generated as part of a recursive routine prologue.
287$
288$ the values placed on the stack by a q2_entry instruction are known as
289$ an 'entry block'. they consist of the old values of the formal
290$ parameters, the old values of local variables, and a code pointer to
291$ the q2_dexit instruction for the routine.
292$
293$ the arguments of an q2_entry instruction are:
294$
295$ a1: pointer to q2_dexit instruction
296$ a2: address of 0-th formal parameter
297$ a3: length of formal parameter block
298$ a4: address of 0-th local variable
299$ a5: length of local variables block
300
301 $ get remaining arguments
302 a4 = codea1(codep + inst_nw);
303 a5 = codea2(codep + inst_nw);
304
305 reserve(a5 + 4); $ no garbage collection hereafter
306
307 $ swap parameters. this is identical to q2_swap.
308 temp = t + linkage_nwords;
309 do j = 0 to a3-1;
310 swap( heap(a2+j), heap(temp+j) );
311 end do;
312
313 $ save local variables. this is identical to q2_savel.
314 get_stack(a5);
315 do j = 0 to a5-1;
316 heap(t+j) = heap(a4+j); heap(a4+j) = spec_om;
317 end do;
318
319 $ push the extra word needed by the q2_undo instruction.
320 push1(zero);
321
322 $ push the new environment block.
323 push_env(a1, a3+a5+3);
324 $ ^^^^^^^----------------------------- a5+2+a3+1
325
326 codep = codep + 2 * inst_nw; $ two-word instruction
327 return;
328
329
330/case(q2_exit)/ $ procedure exit
331
332$ q2_exit contains the entire routine epilog used for backtracking. it
333$ restores the stack and symbol table, then performs the actual return.
334$
335$ there are two possibilities:
336$
337$ 1. the top environment block is an 'entry' block. this means that we
338$ have not done an 'ok' since the procedure was called. treat this
339$ like a normal return.
340$
341$ 2. otherwise the return is conditional, as in 'if ok then return'. we
342$ convert the entry block into an exit block, which in turn can be
343$ reversed by a q2_undo instruction.
344$
345$ the arguments of an q2_exit instruction are identical to the arguments
346$ of an q2_entry instruction, except that a1 points to the q2_undo
347$ instruction.
348
349 $ get remaining arguments
350 a4 = codea1(codep + inst_nw);
351 a5 = codea2(codep + inst_nw);
352
353 $ find last entry block
354 cur_env = last_env; prev_env = 0;
355 while codeop(value(cur_env)) ^= q2_dexit; $ entry block
356 prev_env = cur_env; cur_env = value(cur_env + 1);
357 end while;
358
359 if cur_env = t then $ return unconditionally: pop entry block
360
361 $ get next environment
362 last_env = value(cur_env+1);
363
364 $ free this environment block header, and throw away the extra
365 $ word needed by the q2_undo instruction.
366 free_stack(4);
367
368 $ reset the local variables.
369 do j = 0 to a5-1;
370 heap(a4+j) = heap(t+j);
371 end do;
372 free_stack(a5);
373
374 $ swap the parameters
375 temp = t + linkage_nwords;
376 do j = 0 to a3-1;
377 swap( heap(a2+j), heap(temp+j) );
378 end do;
379
380 $ set cur_arg = 0, indicating that stack pops are to be made
381 $ directly from the top of the stack.
382 cur_arg = 0;
383
384 $ pop codep and na then return
385 pop2(t2, t1); savet = t;
386
387 codep = value_ t1;
388 cur_na = value_ t2;
389
390 else $ return conditionally: change the entry to an exit block
391
392 $ swap local variables
393 temp = cur_env + 3 + 1;
394 do j = 0 to a5-1;
395 swap( heap(a4+j), heap(temp+j) );
396 end do;
397
398 $ get return address and na, the number of arguments.
399 codep = value(cur_env + a5 + 5);
400 cur_na = value(cur_env + a5 + 4);
401
402 $ swap parameters.
403 temp = cur_env + 4 + a5 + 2;
404 do j = 0 to a3-1;
405 swap( heap(a2+j), heap(temp+j) );
406 end do;
407
408 $ set cur_arg to point to the stack entry for the last
409 $ parameter.
410 cur_arg = cur_env+a5+6;
411 $ ^^^^----------------------- 3+1+a5+2
412
413 $ set top word of environment block to point to q2_undo rather
414 $ than q2_dexit instruction.
415 value(cur_env) = a1;
416
417 $ move the exit block to the end of list of environments of
418 $ the current routine.
419 if cur_env ^= last_env then
420 value(prev_env+1) = value(cur_env+1);
421 value(cur_env+1) = last_env;
422 value(cur_env+3) = prev_env;
423 last_env = cur_env;
424 end if;
425 end if;
426
427 return;
428
429
430/case(q2_bpop1)/ $ stack pop
431
432$ this opcode pops a procedure argument from the stack in the
433$ backtracking mode.
434$
435$ there are two possibilities:
436$
437$ cur_arg = 0: treat like a normal pop
438$ cur_arg ^= 0: set a1 = heap(cur_arg) and increment cur_arg.
439
440 if cur_arg = 0 then
441 pop1(heap(a1)); savet = t;
442 else
443 heap(a1) = heap(cur_arg);
444 cur_arg = cur_arg+1;
445 end if;
446
447 go to nxt;
448
449
450/case(q2_bpopu1)/ $ stack pop for untyped values
451
452 if cur_arg = 0 then
453 free_stack(1); $ skip word
454 pop1(heap(a1));
455 savet = t;
456 else
457 cur_arg = cur_arg+1; $ skip word
458 heap(a1) = heap(cur_arg);
459 cur_arg = cur_arg + 1;
460 end if;
461
462 go to nxt;
463
464
465/case(q2_bfree)/ $ free
466
467 if cur_arg = 0 then
468 free_stack(value(a1)); savet = t;
469 else
470 cur_arg = cur_arg + value(a1);
471 end if;
472
473 go to nxt;
474
475
476/case(q2_ok)/ $ ok
477
478$ this instruction is generated for an 'ok'. its arguments are:
479$
480$ a1: code pointer to q2_fail2 instruction
481$ a2: number of saved variables
482$
483$ it is followed by a series of q2_noop instructions whose arg1 fields
484$ contain pointers to the variables to be saved.
485
486 reserve(a2+4); $ no garbage collection hereafter
487
488 $ push saved values
489 get_stack(a2);
490
491 p = codep;
492
493 do j = 0 to a2-1;
494 p = p + inst_nw; p1 = codea1(p);
495
496 is_shared(p1) = yes;
497 heap(t+j) = heap(p1);
498 end do;
499
500 $ push a code pointer to the return address
501 build_spec(t1, t_lab, p+inst_nw);
502 push1(t1);
503
504 push_env(a1, a2+1);
505
506 ok_lev = ok_lev + 1;
507 heap(s_okval) = heap(s_true);
508
509 codep = p + inst_nw;
510 return;
511
512
513/case(q2_lev)/ $ get ok level
514
515 build_spec(heap(a1), t_int, ok_lev);
516 go to nxt;
517
518
519/case(q2_fail1)/ $ fail
520
521$ this instruction corresponds to the 'fail' statement. at this point
522$ the stack contains a series of blocks built by q1_exit, q1_entry, and
523$ q2_ok instructions. the top word of each block contains a code
524$ pointer to either:
525$
526$ q1_dexit: dummy return
527$ q2_undo: undoes a q2_exit instruction
528$ q2_fail2: undoes an ok
529$
530$ the q2_dexit and q2_undo instructions will continue to pop environment
531$ blocks from the stack; the q2_fail2 instruction will branch to the
532$ instruction after the last 'ok'.
533$
534$ when we reach a 'fail' statement the stack contains:
535$
536$ 1. an assortment ok, entry, and exit blocks.
537$ 2. the topmost ok block.
538$ 3. the entry blocks for all procedures called since the last ok.
539$
540$ the stack may also contain specifiers which were pushed onto the stack
541$ as part of setformers, etc. these specifiers are sandwiched between
542$ environment blocks.
543$
544$ when we do a q2_undo instruction we are converting an exit block back
545$ to an entry block. this means that the block we are working on is
546$ burried somewhere in the middle of the stack.
547$
548$ when we do a q2_dexit or q2_fail2 instruction we are always working on
549$ the top environment block.
550$
551$ when we remove an entry block as part of a q2_dexit instruction we not
552$ only remove the block itself, but also all the specifiers sandwiched
553$ between the entry block and the block beneath it.
554
555 if (ok_lev = 0) call err_fatal(47);
556 ok_lev = ok_lev - 1;
557
558 codep = value(last_env);
559 return;
560
561
562/case(q2_dexit)/ $ dummy exit
563
564$ this instruction performs a normal subroutine exit except that instead
565$ of branching to the return address, it branches back to q2_fail1.
566$
567$ the arguments of an q2_dexit instruction are:
568$
569$ a1: address of 0-th formal parameter.
570$ a2: length of formal parameter block.
571$ a3: address of 0-th local variable.
572$ a4: length of local variable block.
573
574 $ pop the environment block, and throw away the extra specifier
575 $ used by q2_undo instructions.
576 last_env = value(last_env+1);
577 free_stack(4);
578
579 $ get remaining arguments
580 a4 = codea1(codep + inst_nw);
581
582 $ reset local variables
583 do j = 0 to a4-1;
584 heap(a3+j) = heap(t+j);
585 end do;
586 free_stack(a4);
587
588 $ swap parameters
589 temp = t + linkage_nwords;
590 do j = 0 to a2-1;
591 swap( heap(a1+j), heap(temp+j) );
592 end do;
593
594 $ throw away codep, na, and the actual parameters.
595 free_stack(a2+2);
596
597 $ throw away all specifiers sandwiched between this block and the
598 $ next one.
599 t = last_env; savet = t;
600
601 codep = value(last_env);
602 return;
603
604
605/case(q2_undo)/ $ undo conditional return
606
607$ this instruction reverses the stack manipulation performed by q2_exit
608$ instructions as part of a conditional return.
609$
610$ note that when we execute this instruction the environment block we
611$ are working on is always burried somewhere deep in the stack.
612$
613$ the arguments for q2_undo are just like those for q2_exit except that
614$ a1 points to the q2_dexit instruction.
615
616 $ get remaining arguments
617 a4 = codea1(codep + inst_nw);
618 a5 = codea2(codep + inst_nw);
619
620 $ swap local variables
621 temp = last_env + 4;
622 do j = 0 to a5-1;
623 swap( heap(a4+j), heap(temp+j) );
624 end do;
625
626 $ swap parameters
627 temp = last_env + 4 + a5 + 2;
628 do j = 0 to a3-1;
629 swap( heap(a2+j), heap(temp+j) );
630 end do;
631
632 $ change the exit block back into an entry block
633 value(last_env) = a1;
634
635 $ now that we have converted the 'exit' block to an 'entry' block,
636 $ we must move it to the right place in the list of environments.
637
638 cur_env = last_env;
639 last_env = value(cur_env+1);
640 prev_env = value(cur_env+3);
641
642 value(cur_env+1) = value(prev_env+1);
643 value(cur_env+3) = 0;
644 value(prev_env+1) = cur_env;
645
646 codep = value(last_env);
647 return;
648
649
650/case(q2_fail2)/ $ fail
651
652$ this instruction pops the values saved by a q2_ok instruction and
653$ branches to the saved address.
654
655 $ pop environment block
656 last_env = value(last_env+1);
657 free_stack(3);
658
659 $ save the current code pointer
660 p = codep;
661
662 $ get the return address to the instruction after the q2_ok
663 pop1(t1);
664 codep = value_ t1;
665
666 $ restore the save variables
667 do j = 0 to a2-1;
668 p = p + inst_nw;
669 heap(codea1(p)) = heap(t+j);
670 end do;
671 free_stack(a2); savet = t;
672
673 $ that guess was not 'ok'
674 heap(s_okval) = heap(s_false);
675
676 return;
677
678
679/case(q2_succeed)/ $ succeed
680
681$ this opcode wipes out all saved environments up to and including the
682$ last 'ok'.
683
684 if (ok_lev = 0) call err_fatal(48);
685 ok_lev = ok_lev - 1;
686
687$ if we follow the chain of environments starting with last_env we will
688$ find:
689$
690$ 1. a series of entry and exit blocks
691$ 2. an ok block
692$ 3. another block
693$
694$ we proceed down the chain, deleting 'exit' and 'ok' blocks. when we
695$ find an 'ok' block, we quit the loop.
696$
697$ in the loop which follows we have:
698$
699$ cur_env: points to block being processed
700$ prev_env: points to previous environment
701$ last_env: points to head of list
702$
703$ t1: opcode for instruction at value(cur_env)
704$ t2: points to next block
705$ t3: number of saved specifiers in current block
706
707 cur_env = last_env;
708 prev_env = 0;
709
710 until t1 = q2_fail2; $ until we have processed the first ok
711
712 t1 = codeop(value(cur_env)); $ saved opcode
713 t2 = value(cur_env+1); $ next environment
714 t3 = value(cur_env+2); $ number of saved values
715
716 if t1 = q2_dexit then $ skip entry block
717 prev_env = cur_env; cur_env = t2;
718 cont until;
719 end if;
720
721 $ delete the block
722 do j = 1 to cur_env-t;
723 heap(cur_env+t3+3-j) = heap(cur_env-j);
724 end do;
725 free_stack(t3+3);
726
727 $ update pointers to next environment and previous environment
728 $ then link the previous environment to the next one.
729 if (t2 ^= 0 & t2 < cur_env) t2 = t2+t3+3;
730 if (prev_env^=0 & prev_env< cur_env then
739 last_env = last_env+t3+3;
740 end if;
741
742 $ now iterate over entire list of environments to insure that
743 $ all pointers are valid.
744 cur_env = last_env;
745 while cur_env ^= 0;
746 p1 = value(cur_env+1);
747 if (p1 ^= 0 & p1 < cur_env) value(cur_env+1) = p1+t3+3;
748 if t1 = q2_undo then
749 p1 = value(cur_env+3);
750 if (p1 < cur_env) value(cur_env+3) = p1+t3+3;
751 end if;
752
753 cur_env = value(cur_env+1);
754 end while;
755
756 $ advance to next block
757 cur_env = t2;
758 end until;
759
760 go to nxt;
761
762
763/case(q2_open)/
764
765 heap(a1) = sopen(value(a3));
766 go to nxt;
767
768
769/case(q2_close)/ $ close
770
771 heap(a1) = sclose(value(a3));
772 go to nxt;
773
774
775/case(q2_print)/ $ print
776
777 heap(a1) = print(value(a3));
778 go to nxt;
779
780
781/case(q2_read)/ $ read
782
783 heap(a1) = readr(value(a3));
784 go to nxt;
785
786
787/case(q2_printa)/ $ printa
788
789 heap(a1) = printa(value(a3));
790 go to nxt;
791
792
793/case(q2_reada)/ $ reada
794
795 heap(a1) = reada(value(a3));
796 go to nxt;
797
798
799/case(q2_get)/ $ get
800
801 heap(a1) = getr(value(a3));
802 go to nxt;
803
804
805/case(q2_put)/ $ put
806
807 heap(a1) = putr(value(a3));
808 go to nxt;
809
810
811/case(q2_getb)/ $ getb
812
813 heap(a1) = getb(value(a3));
814 go to nxt;
815
816
817/case(q2_putb)/ $ putb
818
819 heap(a1) = putb(value(a3));
820 go to nxt;
821
822
823/case(q2_getk)/ $ getk
824
825 heap(a1) = getk(value(a3));
826 go to nxt;
827
828
829/case(q2_putk)/ $ putk
830
831 heap(a1) = putk(value(a3));
832 go to nxt;
833
834/case(q2_getf)/ $ getf
835
836 heap(a1) = getf(value(a3));
837 go to nxt;
838
839/case(q2_callf)/ $ callf
840
841 heap(a1) = callf(ivalue(a3));
842 go to nxt;
843
844
845/case(q2_putf)/ $ putf
846
847 heap(a1) = putf(value(a3));
848 go to nxt;
849
850
851/case(q2_rewind)/ $ rewind
852
853 heap(a1) = rewindr(value(a3));
854 go to nxt;
855
856
857/case(q2_eof)/ $ eof
858
859 heap(a1) = eof(value(a3));
860 go to nxt;
861
862
863/case(q2_host)/
864
865 heap(a1) = shost(ivalue(a3));
866 go to nxt;
867
868
869/case(q2_eject)/ $ eject
870
871 heap(a1) = eject(value(a3));
872 go to nxt;
873
874
875/case(q2_titl)/ $ title
876
877 heap(a1) = title(value(a3));
878 go to nxt;
879
880
881/case(q2_getipp)/ $ get integer control card parameter
882
883 heap(a1) = sgtipp(value(a3));
884 go to nxt;
885
886
887/case(q2_getspp)/ $ get string control card parameter
888
889 heap(a1) = sgtspp(value(a3));
890 go to nxt;
891
892
893/case(q2_getem)/ $ get error mode and limit
894
895 heap(a1) = getem(value(a3));
896 go to nxt;
897
898
899/case(q2_setem)/ $ set error mode and limit
900
901 heap(a1) = setem(value(a3));
902 go to nxt;
903
904
905
906/case(q2_span)/ $ span
907
908 heap(a1) = span(value(a3));
909 go to nxt;
910
911
912/case(q2_break)/ $ break
913
914 heap(a1) = break(value(a3));
915 go to nxt;
916
917
918/case(q2_match)/ $ match
919
920 heap(a1) = match(value(a3));
921 go to nxt;
922
923
924/case(q2_lpad)/
925
926 heap(a1) = lpad(value(a3));
927 go to nxt;
928
929
930/case(q2_len)/ $ len
931
932 heap(a1) = len(ivalue(a3)); go to nxt;
933
934
935/case(q2_any)/ $ any
936
937 heap(a1) = sany(value(a3));
938 go to nxt;
939
940
941/case(q2_notany)/ $ notany
942
943 heap(a1) = notany(value(a3));
944 go to nxt;
945
946
947/case(q2_rspan)/ $ rspan
948
949 heap(a1) = rspan(value(a3));
950 go to nxt;
951
952
953/case(q2_rbreak)/ $ rbreak
954
955 heap(a1) = rbreak(value(a3));
956 go to nxt;
957
958
959/case(q2_rmatch)/ $ rmatch
960
961 heap(a1) = rmatch(value(a3));
962 go to nxt;
963
964
965/case(q2_rpad)/
966
967 heap(a1) = rpad(value(a3));
968 go to nxt;
969
970
971/case(q2_rlen)/ $ rlen
972
973 heap(a1) = rlen(ivalue(a3)); go to nxt;
974
975
976/case(q2_rany)/ $ rany
977
978 heap(a1) = rany(value(a3));
979 go to nxt;
980
981
982/case(q2_rnotany)/ $ rnotany
983
984 heap(a1) = rnotany(value(a3));
985 go to nxt;
986
987
988
989
990
991$ section 9 - debugging and monitor operations
992
993
994/case(q2_tre)/ $ enable/disable entry trace
995
996 monitor entry, limit = 10000;
997 go to nxt;
998
999
1000/case(q2_notre)/ $ disbale entry trace
1001
1002 monitor noentry;
1003 go to nxt;
1004
1005
1006/case(q2_trcstmts)/ $ trace statements: a1 indicates on/off
1007
1008 trace_stmts = ivalue(a1);
1009 go to nxt;
1010
1011
1012/case(q2_trccalls)/ $ trace calls: a1 indicates on/off
1013
1014 trace_calls = ivalue(a1);
1015 go to nxt;
1016
1017
1018/case(q2_trcsym)/ $ trace a1, a2 indicates on/off
1019
1020 if debug_flag & ^ is_om(s_rnspec) then
1021 pt11comp(value(s_rnspec), a1-sym_org+1) = ivalue(a2);
1022 end if;
1023 go to nxt;
1024
1025
1026/case(q2_trc)/ $ enable code trace
1027
1028 .+ct ctrace = yes;
1029 go to nxt;
1030
1031
1032/case(q2_notrc)/ $ disable code trace
1033
1034 .+ct ctrace = no;
1035 go to nxt;
1036
1037
1038/case(q2_trg)/ $ trace garbage collections
1039
1040 .+gt gtrace = yes;
1041 go to nxt;
1042
1043
1044/case(q2_notrg)/ $ disable garbage collecor trace
1045
1046 .+gt gtrace = no;
1047 go to nxt;
1048
1049
1050/case(q2_gdump)/ $ enable dumps during garbage collection
1051
1052 .+gt gdump = yes;
1053 go to nxt;
1054
1055
1056/case(q2_nogdump)/ $ disable dumps during garbage collection
1057
1058 .+gt gdump = no;
1059 go to nxt;
1060
1061
1062/case(q2_dump)/ $ dump storage
1063
1064 if (snap_flag) call snap(codep - 2*inst_nw);
1065
1066 codep = codep + inst_nw;
1067
1068 call dumpds1;
1069 return;
1070
1071
1072/case(q2_garb)/ $ invoke garbage collector
1073
1074
1075$ note that the garbage collector never returns to the point
1076$ where it was called; instead it reinvokes the interpreter,
1077$ which repeats its last instruction. this would be disasterous
1078$ here since it would cause us to loop over the garbage collector
1079$ call. thus before we call the garbage collector we must advance
1080$ the interpreter to its next instruction.
1081
1082 codep = codep + inst_nw;
1083
1084 call grbcol;
1085 assert 0;
1086
1087/case(q2_stmt)/ $ statement trace
1088
1089 if trace_stmts then
1090 put ,'start statement ' :a2,i ,' of ' :var_id(a1, 0),a ,skip;
1091 end if;
1092
1093 .+st add_stat(st_space, (h - stmt_h));
1094
1095 .+st cur_stmt = a3;
1096 .+st stmt_h = h;
1097
1098 .+st add_stat(st_count, 1);
1099
1100 stm_exe = stm_exe + 1; $ count statements executed
1101 go to nxt;
1102
1103
1104
1105
1106
1107$ and finally, since this madness cant go on forever....
1108
1109$ section 11 - termination
1110
1111/case(q2_abort)/ $ abort
1112
1113 call err_misc(24);
1114 go to case(q2_stop);
1115
1116
1117/case(q2_error)/ $ compile time error
1118
1119 call err_misc(48);
1120
1121
1122/case(q2_stop)/
1123
1124
1125$ calculate total execution time
1126 call letime(temp);
1127 temp = temp - entry_time;
1128
1129$ the measurement package will have to allocate a tuple to collect
1130$ frequency statistics. make sure there is space available before
1131$ leaving the interpreter. we will need room for a tuple with
1132$ q2_maximum elements.
1133
1134 .+st reserve(talloc(q2_maximum + breath_space(q2_maximum)));
1135
1136 call libterm(temp);
1137
1138
1139/case(q2_noop)/
1140
1141$ this opcode is used only for quadruples which hold extra
1142$ arguments for the previous instruction. intstructions
1143$ with more than three arguments should always skip over
1144$ the appropriate number of noop instructions, and thus
1145$ this opcode should never be executed.
1146
1147 call err_fatal(4);
1148
1149
1150/nxt/ $ advance code pointer and return
1151
1152 codep = codep+inst_nw;
1153
1154
1155 end subr intrp4;
1156
1157 .+tr trace entry; $ restore entry trace
1158
1159 ..part1
1 .=member equal
2 .+part2.
3
4
5 fnct equal(arg1, arg2);
6
7$ this routine compares a pair of setl values for equality. since
8$ setl data structures are themselves recursive, this routine
9$ provides its own recursion.
10
11$ results
12
13$ from a purists point of view, -equal- should return the setl
14$ constants -true- and -false-. however, equal will usually be
15$ called as part of a conditional branch. it is considerably faster
16$ to branch an zero/non-zero than it is to branch on these setl
17$ constants. for this reason we return 1 for true and 0 for false.
18$ for setl statements such as
19$
20$ a := b = c;
21$
22$ we will compile in-line code to convert 0-1 into false-true.
23
24
25$ inline tests
26
27$ certain tests are performed inline before calling the equality
28$ routine. these same tests are performed inline within the equality
29$ routine before making a recursive call. these consist of a comparison
30$ of the otvalue fields(using the -eq- macro) and a test for two
31$ short type codes(using the -ne- macro). these tests are decisive
32$ when comparing pairs of short items.
33
34
35$ algorithm
36
37$ upon reaching the label -entry- , a1 and a2 are specifiers for two
38$ values which are not trivially equal or unequal. we first
39$ dereference them and repeat the inline equality checks. if these
40$ are not decisive we check whether both inputs have matching
41$ primitive types. if so we call -eqprim- to compare them. other-
42$ wise if both are tuples we jump to 'case(eq_tup)'; if both are
43$ sets we jump to 'case(eq_set)'; otherwise we fail.
44
45
46 size equal(1); $ boolean value returned
47
48 size arg1(hs); $ specifier for first input
49 size arg2(hs); $ specifier for second input
50
51 size a1(hs); $ specifier for first argument
52 size a2(hs); $ specifier for second argument
53
54 size tstart(ps); $ pointer to recursion stack at start
55
56 size hashc(ps); $ hash code rerurned by init_probe
57 size head(ps); $ pointer returned by init_probe
58 size val(hs); $ packed value
59
60 size n(ps); $ nelt of tuples being compared
61
62 size t1(ps); $ types of things being compared
63 size t2(ps);
64
65 $ non-recursive variables for the first argument
66 size st1(ps); $ pointer to data block
67 size hash1(hcsz); $ hash code
68 size ht1(ps); $ pointer to hash table
69 size log1(ps); $ log(number of hash headers)
70 size tmp1(ps); $ pointer to template
71 size e1(ps); $ pointer to current element block
72
73 $ non-recursive variables for the second argument
74 size st2(ps); $ pointer to data block
75 size hash2(hcsz); $ hash code
76 size ht2(ps); $ pointer to hash table
77 size log2(ps); $ log(number of hash headers)
78 size tmp2(ps); $ pointer to template
79 size e2(ps); $ pointer to current element block
80
81 $ non-recursive variables for based set comparisons
82 size bit(ps); $ ls_bit of local set
83 size word(ps); $ ls_word of local set
84 size indx(ps); $ ebindx of remote set
85 size maxi(ps); $ rs_maxi of remote set
86
87 $ non-recursive variables for set/map case
88 size temp(hs); $ heap sized temporary
89 size p(ps); $ pointer to range set
90
91 $ subroutines to handle various special cases
92 size eqprim(1);
93 size eqtup1(1), eqtup2(1), eqtup3(1), eqtup4(1);
94 size eqrs(1), eqls(1), eqlrs(1);
95
96 size nullp(1);
97 size fval(hs); $ returns function value of mapping
98 size gethash(hcsz); $ computes hasc code
99 size convut(hs); $ converts untyped tuples
100 size arb1(hs); $ arbitrary element from range set
101
102$ stacked variables
103
104 .=zzyorg b $ reset counters for stack offsets
105
106 local(retpt); $ return pointer
107
108 local(p1); $ pointers to tuple components
109 local(p2);
110
111 local(plim); $ limit for p1 in tuple loops
112
113 local(bpos); $ bit position in packed tuple
114 local(pbits); $ bits per packed value
115 local(pkey) $ key for packed tuple
116
117 $ recursive variables for set and map comparisons
118 local(sameb); $ flags two sets on same base
119 local(dsize); $ difference in hash table sizes
120 local(dcntr); $ current difference
121
122 $ recursive variables for first set
123 local(set1); $ pointer to set
124 local(head1); $ pointer to hash header
125 local(elmt1); $ pointer to current element block
126 local(off1); $ word offsets in local map
127
128 $ recursive variables for second set
129 local(set2); $ pointer to set
130 local(head2); $ pointer to hash header
131 local(elmt2); $ pointer to current element block
132 local(off2); $ word offsets in local map
133
134 local(iter); $ specifier returned by -next-
135 local(map); $ specifier for map passed to nexts
136
137
138
139 a1 = arg1; a2 = arg2; $ copy arguments
140
141 tstart = t; $ initilize for recursion
142
143 .=zzyorg a $ reset counter for return labels
144
145
146/entry/ $ recursive entry point
147
148 r_entry; $ increment recursion stack
149
150
151$ the obvious thing to do upon entering the recursive routine is a
152$ jump on the types of the two operands. this hump, however, would
153$ be quite monsterous. there are 1024 combinations of type codes
154$ leading to a mere 6 cases in the equality routine. the best way
155$ to handle such a jump table would be to use an auxiliary matrix
156$ mapping types to cases. not only would this table be very large,
157$ but the whole correctness of the equality routine would depend
158$ on the accuracy with which it was initialized.
159$
160$ instead we do two smaller jumps. the first jump is on the number
161$ of inputs which have their is_om bits set. this weeds out enough
162$ cases so that the second jump can be on the cross product of long
163$ defined types. the matrix for this turns out to be fairly small,
164$ and more important, it can be initialized in a very simple, me-
165$ chanical fashion. this should result in much less bug prone code.
166
167 if (is_om_ a1 ^= is_om_ a2) go to fail;
168 if (is_om_ a1) go to pass;
169
170
171/switch/ $ jump on types
172
173 t1 = otype_ a1; t2 = otype_ a2;
174
175 go to case(eq_case(t1, t2)) in eq_fail to eq_set;
176
177
178/case(eq_fail)/ $ incompatible types
179
180 go to fail;
181
182
183/case(eq_prim)/ $ long objects of same primitive type
184
185 equal = eqprim(a1, a2); go to exit;
186
187
188/case(eq_elmt)/ $ two elements
189$
190$ if a1 and a2 point to element base blocks of the same base, then
191$ they must be unequal; otherwise, dereference and start anew.
192$
193 e1 = value_ a1; e2 = value_ a2;
194
195 if htype(e1) = h_ebb & htype(e2) = h_ebb then
196 if (ebform(e1) = ebform(e2)) go to fail;
197 end if;
198
199
200/case(eq_deref)/ $ dererence elements
201
202 deref(a1); deref(a2);
203
204 if (eq(a1, a2)) go to pass;
205 if (ne(a1, a2)) go to fail;
206
207 go to switch;
208
209
210$ r e c u r s i v e c a s e s
211$ ----------------- ---------
212
213
214/case(eq_tup)/ $ tuple cases
215
216$ we begin by comparing their lengths, then there hashes(if valid).
217$ if these agree, we compare their elements.
218
219 st1 = value_ a1; st2 = value_ a2;
220
221 n = nelt(st1); if (n ^= nelt(st2)) go to fail;
222
223 if is_hashok(st1) & is_hashok(st2) then
224 if (hash(st1) ^= hash(st2)) go to fail;
225 end if;
226
227$ special case by the types of the tuples.
228
229 t1 = htype(st1); t2 = htype(st2);
230
231 deflab(tc, h_tuple, h_rtuple); $ define labels for case jump
232
233 go to tc(t1, t2) in minlab to maxlab;
234
235
236/tc(h_tuple, h_tuple)/ $ tuple(*) = tuple(*)
237
238 p1 = st1 + compoffs(1); plim = st1 + compoffs(n);
239 p2 = st2 + compoffs(1);
240
241 while p1 <= plim;
242 a1 = heap(p1); p1 = p1 + 1;
243 a2 = heap(p2); p2 = p2 + 1;
244
245 if (eq(a1, a2)) cont while;
246 if (ne(a1, a2)) go to fail;
247 r_call;
248 if (^ equal) go to fail;
249 end while;
250
251 go to pass;
252
253
254/tc(h_ptuple, h_tuple)/ $ packed tuple(?) = tuple(*)
255
256 swap(st1, st2) $ - swap arguments, go to next case
257
258
259/tc(h_tuple, h_ptuple)/ $ tuple(*) = packed tuple(?)
260$
261$ packed tuples may contain integers and elements of constant ba-
262$ ses. since a constant base may have sets or tuples of constants
263$ as elements, we must be prepared to do recursive tests on packed
264$ objects.
265$
sunb 32 /****** disable code that causes ltlasm to abort ******
266 pkey = ptkey(st2); pbits = ptbits(st2);
267 p1 = st1 + compoffs(1); plim = st1 + compoffs(n);
suna 37 p2 = st2 + packoffs(st2, 1); bpos = 1;
269
270 while p1 <= plim;
271 a1 = heap(p1); p1 = p1 + 1;
272
suna 38 val = .f. bpos, pbits, heap(p2); unpack(pkey, val, a2);
273 bpos = bpos + pbits;
274 if bpos > bpos_max then p2 = p2 + 1; bpos = 1; end if;
276
277 if (eq(a1, a2)) cont while;
278 if (ne(a1, a2)) go to fail;
279 r_call;
280 if (^ equal) go to fail;
281 end while;
282
283 go to pass;
sunb 33 ******/
284
285
286
287$ the following cases are non-recursive and can be done offline.
288$ note that the comparison of two packed tuples is recursive if
289$ they do not have the same packing key.
290
291/tc(h_ptuple, h_ptuple)/ $ packed tuple(?) = packed tuple(?)
292
293 if ptkey(st1) = ptkey(st2) then $ do off line
294 equal = eqtup1(a1, a2);
295
296 else $ unpack a1 and start again.
297 a1 = convut(a1, f_tuple);
298 go to case(eq_tup);
299 end if;
300
301 go to exit;
302
303
304/tc(h_tuple, h_rtuple)/ $ tuple(*) = tuple(untyped real)
305
306 equal = eqtup2(a2, a1); go to exit;
307
308
309/tc(h_rtuple, h_tuple)/ $ tuple(untyped real) = tuple(*)
310
311 equal = eqtup2(a1, a2); go to exit;
312
313
314/tc(h_ituple, h_tuple)/ $ tuple(untyped integer) = tuple(*)
315
316 equal = eqtup3(a2, a1); go to exit;
317
318
319/tc(h_tuple, h_ituple)/ $ tuple(*) = tuple(untyped integer)
320
321 equal = eqtup3(a1, a2); go to exit;
322
323
324/tc(h_rtuple, h_rtuple)/ $ untyped tuples of same component mode
325
326/tc(h_ituple, h_ituple)/
327
328 equal = eqtup4(a1, a2); go to exit;
329
330
331/tc(h_rtuple, h_ituple)/ $ mismatched tuples
332
333/tc(h_ituple, h_rtuple)/
334
335 go to fail;
336
337
338/tc(h_ptuple, h_ituple)/ $ packed tuple(?) = tuple(untyped integer)
339
340/tc(h_ptuple, h_rtuple)/ $ packed tuple(?) = tuple(untyped real)
341
342$ convert a2 to a standard tuple, then use a more common case.
343$ note that we will call a conversion routine which does not in
344$ turn call the equality routine.
345
346 a2 = convut(a2, f_tuple);
347 go to tc(h_ptuple, h_tuple);
348
349
350/tc(h_ituple, h_ptuple)/ $ tuple(untyped integer) = packed tuple(?)
351
352/tc(h_rtuple, h_ptuple)/ $ tuple(untyped real) = packed tuple(?)
353
354 a1 = convut(a1, f_tuple);
355 go to tc(h_tuple, h_ptuple);
356
357
358
359
360/case(eq_set)/ $ set and map cases
361$
362$ our algorithm is as follows:
363$
364$ 1. test the cardinalities for equality
365$ 2. update and compare their hash codes
366$ 3. compare their elements recursively
367$
368 st1 = value_ a1; st2 = value_ a2;
369
370 if is_neltok(st1) & is_neltok(st2) then
371 if (nelt(st1) ^= nelt(st2)) go to fail;
372 end if;
373
374 if is_hashok(st1) & is_hashok(st2) then
375 if (hash(st1) ^= hash(st2)) go to fail;
376 end if;
377$
378$ separate various classes of element comparison
379$
380 t1 = htype(st1); t2 = htype(st2);
381
382 if (is_map(st1) ^= is_map(st2)) go to set_map;
383 if (is_map(st1)) go to map_case;
384$
385$ set cases
386$
387 $ special case two sets on a common base
388 sameb = is_elset(st1) & is_elset(st2) &
389 ft_elmt(hform(st1)) = ft_elmt(hform(st2));
390
391 if ^ (sameb = yes & is_based(st1) & is_based(st2)) then
392 if (^ is_neltok(st1)) call okneltr(a1);
393 if (^ is_neltok(st2)) call okneltr(a2);
394 if (nelt(st1) ^= nelt(st2)) go to fail;
395 end if;
396
397 deflab(sc, h_uset, h_rset);
398
399 if sameb then
400 go to sc(t1, t2) in minlab to maxlab;
401 end if;
402
403
404/general_set/ $ general set case
405$
406$ to compare two sets in general, we use the following algorithm:
407$
408$ 1. compare the size of the two hash tables, and interchange the
409$ the sets if the hash table of the second set is larger than
410$ the hash table of the first set.
411$
412$ 2. let dsize be the power of two of the difference of the loga-
413$ rithms of the respective hash table sizes. this number gives
414$ the number of clash lists in the larger hash table which cor-
415$ respond to each clash list in the smaller hash table.
416$
417$ 3. iterate over consequtive clash lists of the first set. if
418$ there does not exist a new clash list, go to step 6; other-
419$ wise, proceed with step 4.
420$
421$ 4. search for each element e1 in the clash list of the first set
422$ in the current clash list of the second set. return false if
423$ the element is not found.
424$
425$ 5. advance in the first set. if there exists an other element e1
426$ in the current clash list, go to step 4. otherwise, conditio-
427$ nally advance to the next clash list in the second set, and
428$ go to step 3.
429$
430$ 6. at this point, the two sets must be equal: return true.
431$
432 ht1 = hashtb(st1); ht2 = hashtb(st2);
433
434 log1 = lognhedrs(ht1); $ get log of hash table size
435 log2 = lognhedrs(ht2);
436
437 dsize = pow2(iabs(log1 - log2));
438 dcntr = dsize;
439
440 if log1 < log2 then
441 swap(st1, st2)
442 swap(ht1, ht2)
443 end if;
444
445 tmp1 = ht1 + hl_ht; $ pointer to template
446 e1 = eblink(tmp1); $ pointer to first hash header
447
448 tmp2 = ht2 + hl_ht; $ pointer to template of st2
449 head2 = eblink(tmp2); $ pointer to the first hash header
450
451 until is_ebtemp(e1);
452 until is_ebhedr(e1);
453 e1 = eblink(e1);
454
455 if (is_ebhedr(e1)) quit until;
456
457 if is_based(st1) then $ check subset membership
458 if (fval(st1, e1, no) = no) cont until;
459 end if;
460
461 equal = no; $ initialize for comparison
462 $
463 $ look for e1 in the second set
464 $
465 e2 = head2;
466 until is_ebhedr(e2);
467 e2 = eblink(e2);
468
469 if (is_ebhedr(e2)) quit until;
470
471 if is_based(st2) then $ check subset membership
472 if (fval(st2, e2, no) = no) cont until;
473 end if;
474
475 a1 = ebspec(e1); a2 = ebspec(e2);
476
477 if eq(a1, a2) then equal = yes; quit until; end;
478 if (ne(a1, a2)) cont until;
479 if (sameb) cont until;
480
481 set1 = st1; set2 = st2; elmt1 = e1; elmt2 = e2;
482 r_call;
483 st1 = set1; st2 = set2; e1 = elmt1; e2 = elmt2;
484
485 if (equal) quit until;
486 end until;
487
488 if (^ equal) go to fail;
489 end until;
490 $
491 $ we might have to update the hash header pointer into st2
492 $
493 if dcntr > 1 then
494 dcntr = dcntr - 1;
495 else
496 dcntr = dsize; head2 = head2 + hl_htb;
497 end if;
498
499 end until;
500
501 go to pass;
502
503
504
505$ special cases for sets on a common base
506
507/sc(h_uset, h_uset)/ $ sparse set(elmt b) = sparse set(elmt b)
508
509 go to general_set; $ - use general set loop
510
511
512/sc(h_rset, h_rset)/ $ remote set(elmt b) = remote set(elmt b)
513
514 equal = eqrs(a1, a2); go to exit;
515
516
517/sc(h_lset, h_lset)/ $ local set(elmt b) = local set(elmt b)
518
519 equal = eqls(a1, a2); go to exit;
520
521
522/sc(h_lset, h_rset)/ $ local set(elmt b) = remote set(elmt b)
523
524 equal = eqlrs(a1, a2); go to exit;
525
526/sc(h_rset, h_lset)/ $ remote set(elmt b) = local set(elmt b)
527
528 equal = eqlrs(a2, a1); go to exit;
529
530
531/sc(h_rset, h_uset)/ $ remote set(elmt b) = sparse set(elmt b)
532
533 swap(st1, st2) $ - swap and go on to next case
534
535
536/sc(h_uset, h_rset)/ $ sparse set(elmt b) = remote set(elmt b)
537
538$ iterate over unbased set, getting pointers into the base, and
539$ checking membership in the based set.
540
541 maxi = rs_maxi(st2);
542 next_loop(e1, st1);
543 indx = ebindx(value_ ebspec(e1)); if (indx > maxi) go to fail;
544 if (^ rsbit(st2, indx)) go to fail;
545 end_next;
546
547 go to pass;
548
549
550/sc(h_lset, h_uset)/ $ local set(elmt b) = sparse set(elmt b)
551
552 swap(st1, st2);
553
554
555/sc(h_uset, h_lset)/ $ sparse set(elmt b) = local set(elmt b)
556
557 bit = ls_bit(st2); word = ls_word(st2);
558
559 next_loop(e1, st1);
560 if ^ (.f. bit, 1, heap(value_ ebspec(e1) + word)) then
561 go to fail;
562 end if;
563 end_next;
564
565 go to pass;
566
567
568
569/map_case/ $ map cases
570
571$ map the types of the two maps into their maptype-s, which
572$ indicate unbased, local, or remote. then see whether both maps
573$ are on the same base. if so, jump to a special case.
574
575 sameb = is_elset(st1) & is_elset(st2) &
576 ft_dom(hform(st1)) = ft_dom(hform(st2));
577
578 if ^ (sameb = yes & is_based(st1) & is_based(st2)) then
579 if (^ is_neltok(st1)) call okneltr(a1);
580 if (^ is_neltok(st2)) call okneltr(a2);
581 if (nelt(st1) ^= nelt(st2)) go to fail;
582 end if;
583
584 deflab(mc, m_umap, m_lmap); $ define labels for special cases
585
586 if sameb then
587 t1 = maptype(t1);
588 t2 = maptype(t2);
589
590 go to mc(t1, t2) in minlab to maxlab;
591 end if;
592
593
594/general_map/ $ general case
595
596$ otherwise compare the hash tables of the two sets for matching
597$ elements.
598
599$ the loop which follows is similar to the general loop for comparing
600$ two sets. the difference is that having found two matching domain
601$ elements, we must go on to compare their images.
602
603$ commute arguments if necessary so set1 has the larger hash table
604
605 ht1 = hashtb(st1); $ get pointers to hash tables
606 ht2 = hashtb(st2);
607
608 log1 = lognhedrs(ht1); $ get log of hash table size
609 log2 = lognhedrs(ht2);
610
611 if log1 < log2 then
612 swap(st1, st2)
613 swap(ht1, ht2)
614 swap(log1, log2)
615 end if;
616
617 dsize = pow2(log1-log2);
618 dcntr = dsize;
619
620 tmp1 = ht1 + hl_ht; $ get pointers to templates
621 tmp2 = ht2 + hl_ht;
622
623 head1 = eblink(tmp1); $ get pointers to first hash headers
624 head2 = eblink(tmp2);
625
626 while ^ is_ebtemp(head1);
627 $
628 $ iterate over the clash list of the first set
629 $
630 probe_loop(e1, head1);
631
632 equal = no; $ initialize for comparison
633 $
634 $ look for e1 in then second set
635 $
636 probe_loop(e2, head2);
637
638 $
639 $ compare e1 and e2
640 $
641 a1 = ebspec(e1); $ get heap words
642 a2 = ebspec(e2);
643
644 if eq(a1, a2) then equal = yes; quit_probe; end;
645 if (ne(a1, a2)) cont_probe;
646 if (sameb) cont_probe;
647
648 set1 = st1; set2 = st2; elmt1 = e1; elmt2 = e2;
649 r_call;
650 st1 = set1; st2 = set2; e1 = elmt1; e2 = elmt2;
651
652 if (equal) quit_probe;
653
654 end_probe;
655 $
656 $ if e1 is not in the domain of st2, check whether the
657 $ image of e1 is non-trivial
658 $
659 if ^ equal then $ no match
660
661 a1 = fval(st1, e1, no);
662
663 if is_multi_ a1 then $ look for null range set
664 p = value_ a1;
665
666 if is_neltok(p) then
667 if (nelt(p) = 0) cont_probe;
668 else
669 if (nullp(p)) cont_probe;
670 end if;
671
672 else
673 if (is_om_ a1) cont_probe;
674 end if;
675
676 go to fail; $ image is defined
677 end if;
678 $
679 $ compare images of corresponding domain elements
680 $
681 a1 = fval(st1, e1, no); $ get images.
682 a2 = fval(st2, e2, no);
683
684 $ compare is_multi_ bits: standardize images
685 if is_multi_ a1 ^= is_multi_ a2 then
686 l_call(std); if (^ equal) go to fail;
687 end if;
688
689 $ is_multi_ bits match: compare values
690 if (eq(a1, a2)) cont_probe;
691 if (ne(a1, a2)) go to fail;
692
693 set1 = st1; set2 = st2; elmt1 = e1; elmt2 = e2;
694 r_call;
695 st1 = set1; st2 = set2; e1 = elmt1; e2 = elmt2;
696
697 if (^ equal) go to fail;
698
699 end_probe;
700 $
701 $ move to the next hash header in st1. conditionally move to
702 $ the next hash header in st2
703 $
704 head1 = e1; $ e1 points to the next hash header
705
706 if dcntr > 1 then
707 dcntr = dcntr - 1;
708 else
709 dcntr = dsize; head2 = head2 + hl_htb;
710 end if;
711
712 end while;
713
714 go to pass;
715
716
717
718
719$ special cases for maps
720
721
722/mc(m_umap, m_umap)/ $ two unbased maps
723
724 go to general_map; $ use general map case
725
726
727/mc(m_rmap, m_rmap)/ $ remote maps on same base
728$
729$ two compare two remote maps is equivalent to comparing their embedded
730$ tuples. these tuples, however, are unusual in two respects:
731$ a. their nelt field is not maintained
732$ b. their cardinality can not be computed using the okneltr routine
733$ (multi-valued maps might have different maxindx and trivial (null)
734$ range sets)
735$ we also must take into account the "mixed case" of comparing a
736$ single-valued map with a multi-valued map. rather than duplicating
737$ a fair amount of code here to handle all odd combinations, we sepa-
738$ rate single- and multi-valued cases: if both maps are single-valued,
739$ we update their nelt and compare their tuples; otherwise we use the
740$ general based-map case.
741$
742 if (is_mmap(st1)) go to based_map;
743 if (is_mmap(st2)) go to based_map;
744
745 $ build specifiers for the embedded tuples
746 st1 = st1 + hl_rmap; st2 = st2 + hl_rmap;
747
748 $ to actually compute the correct specifier types here
749 $ is somewhat of an overkill, since the type_ fields of
750 $ these specifiers should never be used.
751 $ (better careful now than sorry later...)
752 if htype(st1) = h_tuple then
753 t1 = t_tuple;
754 else
755 t1 = t_stuple;
756 end if;
757
758 if htype(st2) = h_tuple then
759 t2 = t_tuple;
760 else
761 t2 = t_stuple;
762 end if;
763
764 build_spec(a1, t1, st1); build_spec(a2, t2, st2);
765
766 $ compute the cardinality of the embedded tuples
767 if (^ is_neltok(st1)) call okneltr(a1);
768 if (^ is_neltok(st2)) call okneltr(a2);
769 if (nelt(st1) ^= nelt(st2)) go to fail;
770
771 go to case(eq_tup);
772
773
774
775
776
777/mc(m_lmap, m_lmap)/ $ local maps on same base
778
779$ this case treats only local typed maps. for all other local
780$ maps, we use the general based map case
781
782 if (htype(st1) ^= h_lmap ! htype(st2) ^= h_lmap)
783 go to based_map;
784
785$ loop through the base, comparing images
786
787 off1 = ls_word(st1);
788 off2 = ls_word(st2);
789
790 next_loop(e1, st1);
791
792 $ get images of e1
793 a1 = heap(e1+off1);
794 a2 = heap(e1+off2);
795
796 $ compare elements
797 if is_multi_ a1 ^= is_multi_ a2 then $ standardize images
798 l_call(std); if (^ equal) go to fail;
799 end if;
800
801 if (eq(a1, a2)) cont_next;
802 if (ne(a1, a2)) go to fail;
803
804 elmt1 = e1; $ save pointer across recursion
805 r_call;
806 e1 = elmt1; $ restore pointer
807
808 if (^ equal) go to fail;
809
810 end_next;
811
812 go to pass;
813
814
815/based_map/ $ all odd combinations of based maps
816
817/mc(m_rmap, m_lmap)/
818
819/mc(m_lmap, m_rmap)/
820$ loop over base comparing functional value
821
822
823 set1 = st1; set2 = st2; $ save in recursive variables
824
825 next_loop(e1, set1);
826
827 a1 = fval(set1, e1, no);
828 a2 = fval(set2, e1, no);
829
830 if is_multi_ a1 ^= is_multi_ a2 then $ standardize images
831 l_call(std); if (^ equal) go to fail;
832 end if;
833
834 if (eq(a1, a2)) cont_next;
835 if (ne(a1, a2)) go to fail;
836
837 elmt1 = e1; $ save pointer across recursion
838 r_call;
839 e1 = elmt1; $ restore pointer
840
841 if (^ equal) go to fail;
842
843 end_next;
844
845 go to pass;
846
847
848/mc(m_rmap, m_umap)/ $ based map(_b) * = unbased map(_b) *
849
850/mc(m_lmap, m_umap)/
851
852 swap(st1, st2) $ swap arguments, go to next case
853
854
855/mc(m_umap, m_lmap)/ $ sparse map(_b) * = local map(_b) *
856
857/mc(m_umap, m_rmap)/ $ sparse map(_b) * = remote map(_b) *
858
859$ iterate over the domain of the unbased map, getting pointers
860$ into the base, then compare images.
861
862 set1 = st1; set2 = st2; $ save in recursive variables
863
864 next_loop(e1, set1);
865
866 $ get images
867 a1 = ebimag(e1);
868 a2 = fval(set2, value_ ebspec(e1), no);
869
870 $ standardize images
871 if is_multi_ a1 ^= is_multi_ a2 then
872 l_call(std); if (^ equal) go to fail;
873 end if;
874
875 if (eq(a1, a2)) cont_next;
876 if (ne(a1, a2)) go to fail;
877
878 elmt1 = e1; $ save across recursion
879 r_call;
880 e1 = elmt1; $ restore pointer
881
882 if (^ equal) go to fail;
883
884 end_next;
885
886 go to pass;
887
888
889/set_map/ $ mixed set-map case
890
891 if (^ is_neltok(st1)) call okneltr(a1);
892 if (^ is_neltok(st2)) call okneltr(a2);
893 if (nelt(st1) ^= nelt(st2)) go to fail;
894$
895$ we handle the mixed set map case by iterating over the map and
896$ testing its elements for membership in the set. map iteration
897$ is very slow, but it avoids testing map membership, which would
898$ require great duplication of code.
899$
900$ when we iterate over the map, we must supply three arguments to
901$ the next routine:
902$
903$ e1: the previous element in standard format
904$ iter: the previous element in iterator format
905$ savea1: the specifier for the set.
906$
907$ since 'e1' and 'iter' are local variables which are reset by the
908$ next routine, we must pass them through temporaries. note that
909$ the third argument for the inext routine is a rw parameter as
910$ well.
911
912$ make set2 the set.
913
914 if is_map(st2) then
915 swap(a1, a2); swap(st1, st2);
916 end if;
917$
918$ iterate over the map, which at this point is 'a1'/'set1'
919$
920 call inext(e1, temp, a1);
921 iter = temp;
922 map = a1;
923
924 while 1;
925
926 $ advance in the map
927 temp = iter;
928 call nexts(e1, temp, map);
929 if (is_om_ temp) quit while 1;
930 iter = temp;
931
932 init_probe(e1, st2, hashc, head);
933
934 probe_loop(e2, head); $ iterate over clash list
935
936 if is_based(st2) then $ check subset membership
937 if (fval(st2, e2, no) = no) cont_probe;
938 end if;
939
940 a1 = e1; a2 = ebspec(e2);
941 $
942 $ the elements of the map must be pairs. furthermore,
943 $ the next routine returns new pairs. therefore they
944 $ cannot be trivially equal to pairs in the set. we
945 $ do an r_call without the usual preliminary tests.
946 $
947 elmt1 = e1; elmt2 = e2; set2 = st2;
948 r_call;
949 e1 = elmt1; e2 = elmt2; st2 = set2;
950
951 if (equal) cont while 1;
952
953 end_probe;
954
955 go to fail; $ e1 not element of proper clash list
956
957 end while 1;
958
959 go to pass;
960
961
962
963
964/std/ $ local routine to standardize images
965
966$ this routine is called when we are comparing two maps m1 and m2. we
967$ have found some element x in the domain of both maps and have set
968$ a1 = fval(m1, x) and a2 = fval(m2, x). one of these map images has
969$ its is_multi bit on; the other has its is_multi bit off. the images
970$ can only be equal if the image with is_multi on represents a
971$ singleton set.
972
973$ we determine which image has is_multi on, and apply arb1 to it. arb1
974$ will see if the image is a null or singleton set, and if so apply
975$ arb to it. otherwise it will return its argument, with its is_multi
976$ bit still set.
977
978$ equal has been set to yes before this routine is called. it is
979$ reset to no if the images cannot be standardized.
980
981 if is_multi_ a1 then $ a1 is multivalued.
982 a1 = arb1(a1);
983 if (is_multi_ a1) equal = no; $ still multivalued.
984
985 else $ a2 is multivalued
986 a2 = arb1(a2);
987 if (is_multi_ a2) equal = no; $ still multivalued
988 end if;
989
990 go to rlab(retpt) in 1 to zzya; $ return
991
992
993
994
995$ recursive return points.
996
997/fail/ $ return false
998
999 equal = no; go to exit;
1000
1001
1002/pass/ $ return true
1003
1004 equal = yes; go to exit;
1005
1006
1007/exit/ $ actual return point
1008
1009 r_exit; $ pop recursion stack
1010
1011 if t ^= tstart then $ return from recursive call.
1012 go to rlab(retpt) in 1 to zzya;
1013 else
1014 return;
1015 end if;
1016
1017
1018$ drop local variables
1019
1020 macdrop8(retpt, p1, p2, plim, bpos, pbits, pkey, sameb)
1021 macdrop8(dsize, dcntr, set1, head1, elmt1, off1, set2, head2)
1022 macdrop4(elmt2, off2, size2, iter)
1023 macdrop (map)
1024
1025 macdrop2(tc, sc) $ drop case labels
1026 macdrop(mc)
1027
1028
1029 end fnct equal;
1 .=member eqrs
2 fnct eqrs(arg1, arg2);
3
4$ this routine is called from -equal- to compare remote
5$ subsets on the same base. since it contains no test for hash
6$ or nelt, it should be called only from -equal-.
7
8
9 size eqrs(1); $ boolean value returned
10
11 size arg1(hs), $ specifiers for sets being compared
12 arg2(hs);
13
14 size p1(ps), $ pointers to the two sets
15 p2(ps);
16 size word1(ps); $ word offset for shorter argument
17 size word2(ps); $ word offset for longer argument
18 size len1(ps); $ number of words in shorter bit string
19 size len2(ps); $ number of words in longer bit string
20 size j(ps); $ loop index
21
22
23
24 p1 = value_ arg1;
25 p2 = value_ arg2;
26
27 len1 = rswords(p1); len2 = rswords(p2);
28
29 if len1 > len2 then
30 swap(len1, len2);
31 word1 = p2 + hl_rset; word2 = p1 + hl_rset;
32 else
33 word1 = p1 + hl_rset; word2 = p2 + hl_rset;
34 end if;
35
36 do j = 0 to len1-1;
37 if heap(word1+j) ^= heap(word2+j) then
38 eqrs = no;
39 return;
40 end if;
41 end do;
42
43 do j = len1 to len2-1;
44 if heap(word2+j) ^= 0 then
45 eqrs = no;
46 return;
47 end if;
48 end do;
49
50 eqrs = yes;
51
52
53 end fnct eqrs;
1 .=member eqls
2 fnct eqls(arg1, arg2);
3
4$ this routine is called from -equal- to test local subset equality
5$ since it does not test hashes or nelts, it should never be called
6$ directly from the interpreter.
7
8
9 size eqls(1); $ boolean value returned
10
11 size arg1(hs), $ specifiers for sets being compared
12 arg2(hs);
13
14 size word1(ps), $ word offsets of arguments
15 word2(ps),
16 bit1(ps), $ bit offsets of arguments
17 bit2(ps),
18 e(ps); $ pointer to current base element
19
20
21$ get word and bit positions for the
22$ two maps.
23 word1 = ls_word(value_ arg1);
24 bit1 = ls_bit(value_ arg1);
25
26 word2 = ls_word(value_ arg2);
27 bit2 = ls_bit(value_ arg2);
28
29$ loop through bases, comparing images.
30 next_loop(e, value_ arg1);
31 if .f. bit1,1,heap(e+word1) ^= .f. bit2, 1, heap(e+word2) then
32 eqls = no;
33 return;
34 end if;
35 end_next;
36
37 eqls = yes;
38
39
40 end fnct eqls;
1 .=member eqlrs
2 fnct eqlrs(arg1, arg2);
3$
4$ this routine evaluates the equality of a local and a remote
5$ subset of a common base.
6$
7
8$ this routine is called from -equal-. since it contains no tests
9$ for hashes and nelts, it should never be called from the interpreter
10$ its is only a seperate routine so that -equal- fits the little
11$ compiler.
12$
13$ assert isset(arg1) & isset(arg2);
14$ assert htype(value_ arg1) = h_lset;
15$ assert htype(value_ arg2) = h_rset;
16$ assert ft_elmt(hform(value_ arg1)) = ft_elmt(hform(value_ arg2));
17$
18 size eqlrs(1); $ boolean value returned
19
20 size arg1(hs); $ specifiers for two arguments
21 size arg2(hs);
22
23 size set1(ps); $ pointers to two sets
24 size set2(ps);
25 size e(ps); $ pointer to current base element
26 size eb(ps); $ pointer to base element block
27 size bit(ps); $ ls_bit of local set
28 size word(ps); $ ls_word of local set
29 size indx(ps); $ ebindx of remote set
30 size maxi(ps); $ rs_maxi of remote set
31
32 size fval(hs); $ function called
33
34
35 set1 = value_ arg1; $ get pointers to sets
36 set2 = value_ arg2;
37
38 bit = ls_bit(set1); word = ls_word(set1);
39 maxi = rs_maxi(set2);
40
41 next_loop(eb, set1); $ (forall eb in base)
42 indx = ebindx(eb); if (indx > maxi) indx = 0;
43
44 if .f. bit, 1, heap(eb+word) ^= rsbit(set2, indx) then
45 eqlrs = no;
46 return;
47 end if;
48 end_next;
49
50 eqlrs = yes;
51
52
53 end fnct eqlrs;
1 .=member eqtup1
2 fnct eqtup1(arg1, arg2); $ equality test for packed tuples
3
4$ this routine is called from -equal-. since it contains no tests
5$ for hashes and nelts, it should never be called from the interpreter
6$ its is only a seperate routine so that -equal- fits the little
7$ compiler.
8
9
10 size eqtup1(1); $ boolean value returned
11
12 size arg1(hs), $ specifiers for tuples being compared
13 arg2(hs);
14
15 size a1(hs), $ specifiers for components
16 a2(hs);
17
18 size tup1(ps), $ pointers to tuples
19 tup2(ps),
20 pbits1(ps), $ their ptbits fields
21 pbits2(ps),
22 ptkey1(hs), $ their key fields
23 ptkey2(hs);
24
25 size p1(ps), $ pointers to words for current components
26 p2(ps),
27 bpos1(ps), $ first bit positions of current components
28 bpos2(ps);
29
30 size j(ps), $ loop index
31 val(hs); $ packed value of current component
32
33
34 tup1 = value_ arg1; $ point to tuples
35 tup2 = value_ arg2;
36
37$ see if both tuples have the same ptkey and ptbits. if so, we
38$ can compare them using full word comparisons.
39
40 if ptkey(tup1) = ptkey(tup2) & ptbits(tup1) = ptbits(tup2) then
41 $ do full word test
42 eqtup1 = yes;
43
44 do j = 1 to packwords(tup1);
45 if packword(tup1, j) ^= packword(tup2, j) then
46 eqtup1 = no;
47 quit;
48 end if;
49 end do;
50
51 return;
52
53 end if;
54
55$ otherwise do element by element test. start by getting packing info.
56
57
58$ get packing information
59
60 pbits1 = ptbits(tup1); $ bits/entry
61 ptkey1 = ptkey(tup1);
62
63 pbits2 = ptbits(tup2);
64 ptkey2 = ptkey(tup2);
65
66
67$ initialize p1 and p2 to point to the word containing the zero-th
68$ component and bpos1 and bpos2 to the bit origin for this component
69 p1 = tup1 + hl_ptuple;
70 bpos1 = 1;
71
72 p2 = tup2 + hl_ptuple;
73 bpos2 = 1;
74
75 do j = 1 to nelt(tup1);
76
77 bpos1 = bpos1+pbits1;
78 if bpos1 > bpos_max then
79 p1 = p1+1;
80 bpos1 = 1;
81 end if;
82
83 val = .f. bpos1, pbits1, heap(p1); $ packed value_
84
85 if val < pack_max then
86 a1 = tcomp(ptkey1, val);
87 else
88 a1 = 0; $ build short integer
89 value_ a1 = val;
90 end if;
91
92
93 bpos2 = bpos2+pbits2; $ repeat for second tuple
94 if bpos2 > bpos_max then
95 p2 = p2+1; $ start new word
96 bpos2 = 1;
97 end if;
98
99 val = .f. bpos2, pbits2, heap(p2);
100
101 if val < pack_max then
102 a2 = tcomp(ptkey2, val);
103 else
104 a2 = 0;
105 value_ a2 = val;
106 end if;
107
108$ compare a1 and a2
109
110 if ^ eq(a1, a2) then
111 eqtup1 = no;
112 return;
113 end if;
114
115 end do;
116
117 eqtup1 = yes;
118
119 return;
120
121 end fnct eqtup1;
1 .=member eqtup2
2 fnct eqtup2(arg1, arg2); $ equality test for real tuple - tuple
3
4$ this routine is called from -equal-. since it contains no tests
5$ for hashes and nelts, it should never be called from the interpreter
6$ its is only a seperate routine so that -equal- fits the little
7$ compiler.
8
9
10 size eqtup2(1); $ boolean values returned
11
12 size arg1(hs), $ specifiers for tuples being compared
13 arg2(hs);
14
15 size a1(hs), $ specifiers for components
16 a2(hs);
17
18 size p1(ps), $ pointers to tuples
19 p2(ps);
20
21 size j(ps); $ loop index
22
23
24 p1 = value_ arg1; $ get pointers to tuples
25 p2 = value_ arg2;
26
27 do j = 1 to nelt(p1);
28
29 a1 = tcomp(p1, j);
30 a2 = tcomp(p2, j);
31
32$ see if both om.
33 if (a1 = om_real & is_om_ a2) cont;
34
35 if a1 ^= rval(value_ a2) then $ values unequal
36 eqtup2 = no;
37 return;
38 end if;
39
40 end do;
41
42 eqtup2 = yes;
43
44
45 end fnct eqtup2;
1 .=member eqtup3
2 fnct eqtup3(arg1, arg2); $ equality test for integer tuple - tupl
3
4$ this routine is called from -equal-. since it contains no tests
5$ for hashes and nelts, it should never be called from the interpreter
6$ its is only a seperate routine so that -equal- fits the little
7$ compiler.
8
9
10 size eqtup3(1); $ boolean value returned
11
12 size arg1(hs), $ specifiers for tuples being compared
13 arg2(hs);
14
15 size p1(ps), $ pointers to tuples
16 p2(ps); $ pointers to tuples
17
18 size a1(hs), $ specifiers for components
19 a2(hs);
20
21 size p(ps), $ pointer to long integer value
22 j(ps); $ loop index
23
24
25 p1 = value_ arg1; $ get pointers to tuples
26 p2 = value_ arg2;
27
28
29$ note - we assume that the maximum untyped
30$ integer can be stored as a 1 word long int.
31
32 do j = 1 to nelt(p1);
33
34 a1 = tcomp(p1, j);
35 a2 = tcomp(p2, j);
36
37 if is_om_ a1 then $ a2 must be om_int.
38 if (a2 ^= om_int) go to fail;
39
40 elseif type_ a1 = t_int then
41 if (ivalue_ a1 ^= a2) go to fail;
42
43 elseif type_ a1 = t_lint then $ long int vs. untyped
44 p = value_ a1;
45 if (li_nwords(p) ^= 2 ! liword(p, 1) ^= a2) go to fail;
46
47 else $ a1 some other type_
48 go to fail;
49 end if;
50
51 end do;
52
53
54/pass/ $ return true
55 eqtup3 = yes;
56 return;
57
58
59/fail/ $ return false
60 eqtup3 = no;
61 return;
62
63 end fnct eqtup3;
1 .=member eqtup4
mjsa 29 fnct eqtup4(a1, a2);
2
3$ this routine is called from -equal-. since it contains no tests
4$ for hashes and nelts, it should never be called from the interpreter
5$ its is only a seperate routine so that -equal- fits the little
6$ compiler.
7
8
9 size eqtup4(1); $ boolean value returned
10
11 size a1(hs), $ specifiers for tuples
12 a2(hs);
13
14 size p1(ps), $ pointers to tuples
15 p2(ps);
16
17 size j(ps); $ loop index
18
19
20 p1 = value_ a1; $ get pointers to tuples
21 p2 = value_ a2;
22
23 do j = 1 to nelt(p1);
24
25 if tcomp(p1, j) ^= tcomp(p2, j) then
26 eqtup4 = no;
27 return;
28 end if;
29
30 end do;
31
32 eqtup4 = yes;
33
34
35 end fnct eqtup4;
1 .=member eqprim
2 fnct eqprim(arg1, arg2);
3
4$ this routine tests the equality of primitive types
5
6
7 size eqprim(1); $ boolean value returned
8
9 size arg1(hs); $ specifiers for inputs
10 size arg2(hs);
11
12 size ss1(ssz); $ string specifiers for inputs
13 size ss2(ssz);
14 size len(ps); $ length of strings
15 size cc(ps); $ condition code, result of string comp
16
17 real real1, real2; $ real temporaries
18
mjsa 30 size equalli(1);
20 size eqstr(1);
21
22
stra 104 if (otype_ arg1 ^= otype_ arg2) go to mixed;
24
stra 105 go to case(otype_ arg1) in t_lint to t_real;
26
27
28/case(t_lint)/ $ long integers
29
mjsa 31 eqprim = equalli(arg1, arg2);
31
32 return;
33
34
35/case(t_istring)/ $ indirect character strings
36
37 ss1 = value_ arg1; ss2 = value_ arg2;
38
39 len = ss_len(ss1);
40
41 if len ^= ss_len(ss2) then
42 eqprim = no;
43 return;
44 end if;
45
46 clc(cc, ss1, ss2, len);
47
48 eqprim = (cc = 0);
49
50 return;
51
52
53/case(t_real)/ $ reals
54
55 real1 = rval(value_ arg1);
56 real2 = rval(value_ arg2);
57 eqprim = (real1 = real2);
58
59 return;
60
61
62/mixed/ $ mixed input types
63
64$ the only mixed case we allow is long vs. short string
65
stra 106 if otype_ arg1 = t_string & otype_ arg2 = t_istring then
67 eqprim = eqstr(arg2, arg1);
68
stra 107 elseif otype_ arg1 = t_istring & otype_ arg2 = t_string then
70 eqprim = eqstr(arg1, arg2);
71
72 else
73 eqprim = no;
74 end if;
75
76 return;
77
78
79 end fnct eqprim;
1 .=member eqstr
2 fnct eqstr(long, short);
3
4$ this routine compares a long string for equality with
5$ a short one.
6
7
8 size long(hs), $ specifier for long string
9 short(hs); $ specifier for short string
10
11 size eqstr(1); $ boolean value returned
12
13 size len(ps), $ length of strings
14 ss(ssz), $ specifier for long string
15 j(ps); $ loop index
16
17
18 eqstr = no; $ assume unequal
19
20 ss = value_ long;
21 len = ss_len(ss);
22
23 if (len ^= sc_nchars_ short) return;
24
25 do j = 1 to len;
stra 108 if (icchar(ss, j) ^= scchar(short, j)) return;
27 end do;
28
29 eqstr = yes; $ strings equal
30
31
32 end fnct eqstr;
1 .=member add
2 fnct add(a1, a2, cpy);
3
4$ this is the general setl addition function. it performs short addition
5
6$ 'cpy' is a flag indicating what copying actions must be
7$ performed on a1.
8$ in line and calls seperate lower level routines for each long type.
9
10
11 size a1(hs), $ specifiers for arguments
12 a2(hs),
13 cpy(ps); $ copy flag
14
15 size add(hs); $ specifier returned
16
17 size arg1(hs), $ local copies of arguments
18 arg2(hs);
19
20 size val(hs); $ temporary numeric value
21
22 real real1, $ real temporaries
23 real2;
24
25 size addli(hs), $ functions called
26 addstr(hs),
27 addtup(hs),
28 union(hs),
29 sfloat(hs),
30 copy1(hs),
31 convert(hs),
32 err_val(hs);
33
34
35 arg1 = a1; deref(arg1);
36 arg2 = a2; deref(arg2);
37
38
39$ do any necessary copying
40
41 go to c(cpy) in copy_min to copy_max;
42
43
44/c(copy_yes)/ $ copy arg1
45
46 arg1 = copy1(arg1);
47
48 go to esac;
49
50
51/c(copy_test)/ $ copy arg1 if -
52 $ - it is shared.
53 $ - it is a long character string.
54
55 if (is_shared_ arg1 ! otype_ arg1 = t_istring)
56 arg1 = copy1(arg1);
57
58 go to esac;
59
60
61/c(copy_no)/ $ no copy necessary
62
63 go to esac;
64
65
66/esac/ $ branch on omega-type field of -arg1-
67
68 go to case(otype_ arg1) in t_min to t_max;
69
70
71/case(t_int)/ $ short int
72
73$ this case will always be caught by a preliminary test in the
74$ interpreter, and is here only for completeness
75
76 val = otvalue_ arg1 + otvalue_ arg2;
77 if (val > maxsi) go to case(t_lint);
78
79 add = 0; $ assert t_int = 0, simplify build_spec
80 ivalue_ add = val;
81
82 return;
83
84
stra 109/case(t_string)/ $ short character string
stra 110
stra 111 if ^ (otype_ arg2 = t_string ! otype_ arg2 = t_istring) then
stra 112 go to error2;
stra 113 end if;
stra 114
stra 115 add = addstr(arg1, arg2);
stra 116
stra 117 return;
stra 118
86
stra 119/case(t_atom)/ $ error types
88
89/case(t_proc)/
90
91/case(t_lab)/
92
93/case(t_latom)/ $ error type - long atom
94
95/case(t_elmt)/ $ element - we should never reach here
96
97 go to error1;
98
99
100/case(t_lint)/ $ long integers
101
102 if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
103
104 add = addli(arg1, arg2);
105
106 return;
107
108
109/case(t_istring)/ $ long character strings
110
stra 120 if ^ (otype_ arg2 = t_string ! otype_ arg2 = t_istring) then
stra 121 go to error2;
stra 122 end if;
112
113 $ always copy strings before destructive use, regardless
114 $ of the setting of the copy flag.
115 if cpy = copy_no then arg1 = copy1(arg1); end if;
116
117 add = addstr(arg1, arg2);
118
119 return;
120
121
122/case(t_real)/ $ reals
123
124 if (otype_ arg2 ^= t_real) go to error2;
125
126 real1 = rval(value_ arg1);
127 real2 = rval(value_ arg2);
128
129 val = real1 + real2;
130 put_realval(val, add);
131
132 return;
133
134
135/case(t_tuple)/ $ tuples
136
137/case(t_stuple)/
138
139 if (otype_ arg2 ^= t_tuple & otype_ arg2 ^= t_stuple)
140 go to error2;
141
142 if ft_type(hform(value_ arg1)) = f_mtuple !
143 hform(value_ arg1) ^= hform(value_ arg2) then
144 arg1 = convert(arg1, f_tuple);
145 arg2 = convert(arg2, f_tuple);
146 end if;
147
148 add = addtup(arg1, arg2);
149
150 return;
151
152
153/case(t_set)/ $ sets and maps
154
155/case(t_map)/
156
157 if (^ isset(otype_ arg2)) go to error2;
158
159 add = union(arg1, arg2, no);
160
161 return;
162
163
164case_om $ omega ceses - treat as errors
165
166/error1/ $ invalid type for left operand
167
168 call err_type(2);
169 add = err_val(f_gen);
170
171 return;
172
173
174/error2/ $ incompatible argument types
175
176 call err_type(3);
177 add = err_val(f_gen);
178
179 return;
180
181
182 end fnct add;
1 .=member addstr
2 fnct addstr(arg1, arg2);
3
stra 123$ this routine concatenates two character strings. both operands may be
stra 124$ either a short or a long character string; the result will always be
stra 125$ a long character string. the first operand is used destructively.
7
8 size arg1(hs); $ specifier for first string
9 size arg2(hs); $ specifier for second string
10
11 size addstr(hs); $ specifier returned
12
13 size ss1(ssz); $ string specifiers
14 size ss2(ssz);
16 size len1(ps); $ lengths of strings
17 size len2(ps);
18 size tot(ps); $ total length
19 size j(ps); $ loop index
stra 126
stra 127 size nulllc(ssz); $ allocates null string
20
21
stra 128 if otype_ arg1 = t_string then
stra 129 len1 = sc_nchars_ arg1; $ get length of first operand
stra 130 ss1 = nulllc(len1); $ convert short string
stra 131 ss_len(ss1) = len1;
stra 132 if len1 then icchar(ss1, 1) = scchar(arg1, 1); end if;
stra 133 elseif otype_ arg1 = t_istring then
stra 134 ss1 = value_ arg1;
stra 135 len1 = ss_len(ss1); $ get length of first operand
stra 136 else
stra 137 addstr = err_val(f_string);
stra 138 return;
stra 139 end if;
stra 140
stra 141 if otype_ arg2 = t_string then
stra 142 len2 = sc_nchars_ arg2; $ get length of second operand
stra 143
stra 144 if len2 then
stra 145 tot = len1 + len2; $ compute length of result
stra 146
stra 147 call explc(ss1, tot); $ expand result string
stra 148 ss_len(ss1) = tot; $ set length of result
stra 149
stra 150 icchar(ss1, tot) = scchar(arg2, 1);
stra 151 end if;
stra 152
stra 153 elseif otype_ arg2 = t_istring then
stra 154 ss2 = value_ arg2; $ get string pointer to second operand
stra 155 len2 = ss_len(ss2); $ get length of second operand
stra 156
stra 157 tot = len1 + len2; $ compute length of result
stra 158
stra 159 call explc(ss1, tot); $ expand result string
stra 160 ss_len(ss1) = tot; $ set length of result
stra 161
stra 162 ss_ofs(ss1) = ss_ofs(ss1) + len1; $ point to end of string
stra 163 mvc(ss1, ss2, len2); $ copy the second string
stra 164 ss_ofs(ss1) = ss_ofs(ss1) - len1; $ reset to point to start
stra 165
stra 166 else
stra 167 addstr = err_val(f_string);
stra 168 return;
stra 169 end if;
stra 170
stra 171 build_spec(addstr, t_istring, ss1); $ build result specifier
41
42
43 end fnct addstr;
1 .=member addtup
2 fnct addtup(a1, a2);
3
4$ this routine 'adds' or concatenates two tuples. the first
5$ argument is used destructively.
6
7
8 size a1(hs), $ specifier for first tuple
9 a2(hs); $ specifier for second tuple
10
11 size addtup(hs); $ specifier returned
12
13 size p1(ps), $ pointers to tuples
14 p2(ps);
15
16 size len1(ps), $ length of a1
17 len2(ps), $ length of a2
18 tot(ps); $ total length
19
20 size j(ps); $ loop index
21
22
23 p1 = value_ a1; $ get pointers to arguments
24 p2 = value_ a2;
25
26 len1 = nelt(p1); $ get lengths
27 len2 = nelt(p2);
28
29 tot = len1 + len2;
30
31 addtup = a1; $ we will use a1 destructively.
32
33 if tot > maxindx(p1) then $ must expand result
34 call exptup(addtup, tot);
35 p1 = value_ addtup;
36 end if;
37
38 if htype(p1) = h_ptuple then
39 do j = 1 to len2;
40 pcomp(p1, len1+j) = pcomp(p2, j);
41 end do;
42
43 else
44 do j = 1 to len2;
45 tcomp(p1, len1+j) = tcomp(p2, j);
46 end do;
47 end if;
48
49 nelt(p1) = tot; $ set nelt of result
50
51
52 end fnct addtup;
1 .=member diff
2 fnct diff(a1, a2, cpy);
3
4$ this is the general setl subtraction function. it performs short
5$ subtraction in line and calls seperate lower level routines for eac
6$ long type
7
8$ 'cpy' is a flag indicating what copying actions must be
9$ performed on a1.
10
11
12 size diff(hs); $ specifier returned
13
14 size a1(hs), $ specifiers for arguments
15 a2(ps),
16 cpy(ps); $ copy flag
17
18 size arg1(hs), $ local copies of arguments
19 arg2(hs);
20
21 size val(hs), $ differencr of two ints
22 len(ps), $ length of bit strings
23 p(ps); $ pointer to real value
24
25 real real1, $ temporaries for real values
26 real2;
27
28 size diffli(hs), $ functions called
29 copy1(hs),
30 setdiff(hs);
31
32
33 arg1 = a1; $ copy specifiers for arguments
34 arg2 = a2;
35
36 deref(arg1); $ dereference if necessary
37 deref(arg2);
38
39
40$ do any necessary copying
41
42 go to c(cpy) in copy_min to copy_max;
43
44/c(copy_yes)/ $ copy arg1
45
46 arg1 = copy1(arg1);
47 go to esac;
48
49
50/c(copy_test)/ $ copy arg1 if shared
51
52 maycopy(arg1);
53 go to esac;
54
55
56/c(copy_no)/ $ no copy necessary
57
58
59 go to esac;
60
61/esac/
62
63
64 diff = 0; $ initialize, clearing eblink, etc.
65
66 $ branch on type of first arg
67
68 go to case(otype_ arg1) in t_min to t_max;
69
70
71/case(t_int)/ $ short int
72
73$ this case will be caught by the interpreter. it is here only for
74$ completeness. note that the underflow test also catches cases where
75$ the second argument is not a short int.
76
77 val = otvalue_ arg1 - otvalue_ arg2;
78 if (val < 0) go to case(t_lint);
79
80 otvalue_ diff = val;
81
82 return;
83
84
85/case(t_string)/ $ error types
86
87/case(t_atom)/
88
89/case(t_proc)/
90
91/case(t_lab)/
92
93/case(t_latom)/ $ error type - long atom
94
95/case(t_elmt)/ $ element - we should never reach here
96
97 go to error1;
98
99
100/case(t_lint)/ $ long integers
101
102 if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
103
104 diff = diffli(arg1, arg2);
105
106 return;
107
108
109/case(t_istring)/ $ error type - long chars
110
111 go to error1;
112
113
114/case(t_real)/ $ reals
115
116 if (otype_ arg2 ^= t_real) go to error2;
117
118 real1 = rval(value_ arg1);
119 real2 = rval(value_ arg2);
120
121 get_real(p);
122 build_spec(diff, t_real, p); $ build specifier
123
124 rval(p) = real1 - real2; $ do real diff
125
126 return;
127
128
129/case(t_tuple)/ $ error types - tuples
130
131/case(t_stuple)/
132
133 go to error1;
134
135
136/case(t_set)/ $ sets and maps
137
138/case(t_map)/
139
140 if (^ isset(otype_ arg2)) go to error2;
141
142 diff = setdiff(arg1, arg2);
143
144 return;
145
146
147case_om; $ om types - treat as errors
148
149/error1/ $ bad type for first argument
150
151 call err_type(4);
152 diff = err_val(f_gen);
153 return;
154
155
156/error2/ $ incompatible argument types
157
158 call err_type(5);
159 diff = err_val(f_gen);
160 return;
161
162
163 end fnct diff;
1 .=member div
2 fnct div(a1, a2);
3
4$ this is the general setl division function. it performs short division
5$ in line and calls seperate lower level routines for each long type.
6
7
8 size div(hs); $ specifier returned
9
10 size a1(hs), $ specifiers for arguments
11 a2(hs);
12
13 size arg1(hs), $ local copies of argemeunt
14 arg2(hs);
15
16 size val(hs); $ quotient of two integers
17
18 size divli(hs); $ functions called
19
20
21 arg1 = a1; deref(arg1);
22 arg2 = a2; deref(arg2);
23
24 go to case(otype_ arg1) in t_min to t_max;
25
26
27/case(t_int)/ $ short int
28
29$ this case will generally be caught in the interpreter, and is here
30$ only for completeness.
31
32 if (otype_ arg2 ^= t_int) go to case(t_lint);
33 if (otvalue_ arg2 = 0) go to error3;
34
35 val = otvalue_ arg1 / otvalue_ arg2;
36
37 div = 0; $ assert t_int = 0, simplify build_spec
38 otvalue_ div = val;
39
40 return;
41
42
43/case(t_string)/ $ error types
44
45/case(t_atom)/
46
47/case(t_proc)/
48
49/case(t_lab)/
50
51/case(t_latom)/
52
53/case(t_elmt)/ $ we should never reach here
54
55 go to error1;
56
57
58/case(t_lint)/ $ long integers
59
60 if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
61 if (otvalue_ arg2 = 0) go to error3;
62
63 div = divli(arg1, arg2);
64
65 return;
66
67
68/case(t_istring)/ $ error type - long chars
69
70/case(t_real)/ $ reals
71
72/case(t_tuple)/
73
74/case(t_stuple)/
75
76/case(t_set)/
77
78/case(t_map)/
79
80 go to error1;
81
82
83case_om; $ om types - treat as errors
84
85/error1/ $ bad type for first argument
86
87 call err_type(6);
88 div = err_val(f_gen);
89 return;
90
91
92/error2/ $ incompatible argument types
93
94 call err_type(7);
95 div = err_val(f_gen);
96 return;
97
98
99/error3/ $ division by zero
100
101 call err_misc(01);
102 div = err_val(f_gen);
103 return;
104
105
106 end fnct div;
1 .=member slash
2 fnct slash(a1, a2);
3
4$ this routine computes arg1 / arg2. it is similar to div except
5$ that it converts integers to reals before dividing them.
6
7
8 size slash(hs); $ specifier returned
9
10 size a1(hs), $ specifiers for arguments
11 a2(hs);
12
13 size arg1(hs), $ local copies of argemeunt
14 arg2(hs);
15
16 size val(hs), $ quotient of two ints
17 p(ps); $ pointer to real value
18
19 real real1, $ temporaries for real values
20 real2;
21
22 size sfloat(hs); $ setl float function
23
24
25 arg1 = a1; deref(arg1);
26 arg2 = a2; deref(arg2);
27
28 go to case(otype_ arg1) in t_min to t_max;
29
30
31/case(t_int)/ $ short int
32
33$ this case will generally be caught in the interpreter, and is here
34$ only for completeness.
35
36 if (otype_ arg2 ^= t_int) go to case(t_lint);
37 arg1 = sfloat(arg1);
38 arg2 = sfloat(arg2);
39
40 go to case(t_real);
41
42
43/case(t_string)/ $ error types
44
45/case(t_atom)/
46
47/case(t_proc)/
48
49/case(t_lab)/
50
51/case(t_latom)/
52
53/case(t_elmt)/ $ we should never reach here
54
55 go to error1;
56
57
58/case(t_lint)/ $ long integers
59
60 if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
61
62 arg1 = sfloat(arg1);
63 arg2 = sfloat(arg2);
64
65 go to case(t_real);
66
67
68/case(t_istring)/ $ error type - long chars
69
70 go to error1;
71
72
73/case(t_real)/ $ reals
74
75 if (otype_ arg2 ^= t_real) go to error2;
76
77 real1 = rval(value_ arg1);
78 real2 = rval(value_ arg2);
79
80 if (real2 = 0.0) go to error3;
81
82 val = real1 / real2;
83 put_realval(val, slash);
84
85 return;
86
87
88/case(t_tuple)/
89
90/case(t_stuple)/
91
92/case(t_set)/
93
94/case(t_map)/
95
96 go to error1;
97
98
99case_om; $ om types - treat as errors
100
101/error1/ $ bad type for first argument
102
103 call err_type(8);
104 slash = err_val(f_gen);
105 return;
106
107
108/error2/ $ incompatible argument types
109
110 call err_type(9);
111 slash = err_val(f_gen);
112 return;
113
114
115/error3/ $ division by zero
116
117 call err_misc(01);
118 slash = err_val(f_gen);
119 return;
120
121
122 end fnct slash;
1 .=member smod
2 fnct smod(a1, a2);
3
4$ this is the general setl modulo function. it performs short
5$ modulo in line and calls seperate lower level routines for eac
6$ long type
7
8
9 size smod(hs); $ specifier returned
10
11 size a1(hs), $ specifiers for arguments
12 a2(hs);
13
14 size arg1(hs), $ local copies of argemeunt
15 arg2(hs);
16
17 size len(ps); $ length of bit string
18
19
20 size modli(hs), $ functions called
21 modlb(hs),
22 setmod(hs);
23
24
25 arg1 = a1; $ copy specifiers for arguments
26 arg2 = a2;
27
28 deref(arg1); $ dereference if necessary
29 deref(arg2);
30
31 smod = 0; $ clear share bit, etc.
32
33 $ branch on type of first arg
34
35 go to case(otype_ arg1) in t_min to t_max;
36
37
38/case(t_int)/ $ short int
39
40$ this case is generally caught in line.
41 if (otype_ arg2 ^= t_int) go to case(t_lint);
42
43 otvalue_ smod = mod(otvalue_ arg1, otvalue_ arg2);
44
45 return;
46
47
48/case(t_string)/ $ error types
49
50/case(t_atom)/
51
52/case(t_proc)/
53
54/case(t_lab)/
55
56/case(t_latom)/ $ error type - long atom
57
58/case(t_elmt)/ $ we should never reach here
59
60 go to error1;
61
62
63/case(t_lint)/ $ long integers
64
65 if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
66
67 smod = modli(arg1, arg2);
68
69 return;
70
71
72/case(t_istring)/ $ error type - long chars
73
74/case(t_real)/ $ error - reals
75
76/case(t_tuple)/ $ error types - tuples
77
78/case(t_stuple)/
79
80 go to error1;
81
82
83/case(t_set)/ $ sets and maps
84
85/case(t_map)/
86
87 if (^ isset(otype_ arg2)) go to error2;
88
89 smod = setmod(arg1, arg2);
90
91 return;
92
93
94case_om; $ om types - treat as errors
95
96/error1/ $ bad type for first argument
97
98 call err_type(10);
99 smod = err_val(f_gen);
100 return;
101
102
103/error2/ $ incompatible argument types
104
105 call err_type(11);
106 smod = err_val(f_gen);
107 return;
108
109
110 end fnct smod;
1 .=member mult
2 fnct mult(a1, a2, cpy);
3
4$ this is the general setl multiplication function. it performs short
5$ multiplication in line and calls seperate lower level routines for eac
6$ long type
7
8$ 'cpy' is a flag indicating what copying actions must be
9$ performed on a1.
10
11
12 size a1(hs), $ specifiers for arguments
13 a2(hs),
14 cpy(ps); $ copy flag
15
16 size mult(hs); $ specifier returned
17
18 size arg1(hs), $ local copies of arguments
19 arg2(hs);
20
21 size val(hs); $ temporary numeric value
22
23 real real1, $ real temporaries
24 real2;
25
26 size copy1(hs), $ functions called
27 sfloat(hs),
28 multli(hs),
29 multstr(hs),
30 multtup(hs),
31 intersect(hs),
32 err_val(hs);
33
34
35 arg1 = a1; deref(arg1);
36 arg2 = a2; deref(arg2);
37
38
39$ do any necessary copying
40
41 go to c(cpy) in copy_min to copy_max;
42
43
44/c(copy_yes)/ $ copy arg1
45
46 arg1 = copy1(arg1);
47
48 go to esac;
49
50
51/c(copy_test)/ $ copy -arg1- if it is shared
52
53 maycopy(arg1);
54
55 go to esac;
56
57
58/c(copy_no)/ $ no copy necessary
59
60 go to esac;
61
62
63/esac/ $ branch on omega-type field of -arg1-
64
65 go to case(otype_ arg1) in t_min to t_max;
66
67
68/case(t_int)/ $ short integer
69
70 if otype_ arg2 = t_int then
71 if .fb. otvalue_ arg1 + .fb. otvalue_ arg2 > .fb. maxsi then
72 mult = multli(arg1, arg2);
73 else
74 build_spec(mult, t_int, ivalue_ arg1 * ivalue_ arg2)
75 end if;
76
77 elseif otype_ arg2 = t_lint then
78 mult = multli(arg1, arg2);
79
stra 172 elseif otype_ arg2 = t_string ! otype_ arg2 = t_istring then
81 mult = multstr(arg1, arg2);
82
83 elseif otype_ arg2 = t_tuple ! otype_ arg2 = t_stuple then
84 mult = multtup(arg1, arg2);
85
86 else $ incompatible argument types
87 go to error2;
88 end if;
89
90 return;
91
92
stra 173/case(t_string)/ $ short character string
stra 174
stra 175 if (otype_ arg2 ^= t_int) go to error2;
stra 176
stra 177 mult = multstr(arg2, arg1);
stra 178
stra 179 return;
94
stra 180/case(t_atom)/ $ error types
96
97/case(t_proc)/
98
99/case(t_lab)/
100
101/case(t_latom)/ $ error type - long atom
102
103/case(t_elmt)/ $ element - we should never reach here
104
105 go to error1;
106
107
108/case(t_lint)/ $ long integers
109
110 if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
111
112 mult = multli(arg1, arg2);
113
114 return;
115
116
117/case(t_istring)/ $ long character string
118
119 if (otype_ arg2 ^= t_int) go to error2;
120
121 mult = multstr(arg2, arg1);
122
123 return;
124
125
126/case(t_real)/ $ reals
127
128 if (otype_ arg2 ^= t_real) go to error2;
129
130 real1 = rval(value_ arg1);
131 real2 = rval(value_ arg2);
132
133 val = real1 * real2;
134 put_realval(val, mult);
135
136 return;
137
138
139/case(t_tuple)/ $ tuples
140
141/case(t_stuple)/
142
143 if (otype_ arg2 ^= t_int) go to error2;
144
145 mult = multtup(arg2, arg1);
146
147 return;
148
149
150/case(t_set)/ $ sets and maps
151
152/case(t_map)/
153
154 if (^ isset(otype_ arg2)) go to error2;
155
156 mult = intersect(arg1, arg2);
157
158 return;
159
160
161case_om $ omega ceses - treat as errors
162
163/error1/ $ illegal first argument type
164
165 call err_type(12);
166 mult = err_val(f_gen);
167
168 return;
169
170
171/error2/ $ incompatible argument types
172
173 call err_type(13);
174 mult = err_val(f_gen);
175
176 return;
177
178
179 end fnct mult;
1 .=member multstr
2 fnct multstr(a1, a2);
3
4$ this routine performs -a1 * a2-, where -a1- is a short integer and
5$ -a2- is a string. the result is a string obtained by concatenating
6$ -a2- to itself -a1- times. since this operation is rather rare,
7$ it is actually done by a series of concatenations.
8
9$ n.b. (1.) -a1- is the specifier for a short integer.
10$ (2.) -a2- is the specifier for a long character string.
11$ (3.) -a2- is not used destructively.
12
13
14 size a1(hs), $ specifier for integer
15 a2(hs); $ specifier for string
16
17 size multstr(hs); $ specifier returned
18
stra 181 size ss1(ssz); $ string specifier for result
stra 182 size ofs1(ps); $ offset in result
stra 183 size len1(ps); $ length of result
stra 184 size tp2(ps); $ otype of string operand
stra 185 size ss2(ssz); $ string specifier for string operand
stra 186 size len2(ps); $ length of string operand
stra 187 size c(cs); $ current character
stra 188 size n(ps); $ integer value of -a1-
stra 189 size j(ps); $ loop index
21
stra 190 size nulllc(ssz); $ allocates null string
25
26
stra 191 tp2 = otype_ a2;
stra 192
stra 193 if tp2 = t_string then $ string operand is short
stra 194 len2 = sc_nchars_ a2; $ get length of string operand
stra 195 c = scchar(a2, 1); $ get character
stra 196 elseif tp2 = t_istring then $ string operand is long
stra 197 ss2 = value_ a2; $ get string specifier
stra 198 len2 = ss_len(ss2); $ get length of string operand
stra 199 else $ illegal string operand
stra 200 multstr = err_val(f_string);
stra 201 return;
stra 202 end if;
28
stra 203 n = ivalue_ a1; $ get number of replications
stra 204 len1 = n * len2; $ compute length of result
stra 205
stra 206 if len1 = 0 then $ result is null string
stra 207 build_spec(multstr, t_string, 0);
stra 208 return;
stra 209 end if;
stra 210
stra 211 ss1 = nulllc(len1); $ allocate result string block
stra 212 ofs1 = ss_ofs(ss1); $ initial offset in result
30
stra 213 if tp2 = t_string then $ string operand is short
stra 214 do j = 1 to n; icchar(ss1, j) = c; end do;
stra 215 else $ string operand is long
stra 216 do j = 1 to n;
stra 217 mvc(ss1, ss2, len2); $ append string arg to result
stra 218 ofs1 = ofs1 + len2; ss_ofs(ss1) = ofs1; $ advance
stra 219 end do;
stra 220 ss_ofs(ss1) = ofs1 - len1; $ reset to point to start
stra 221 end if;
stra 222
stra 223 $ build result specifier
stra 224 ss_len(ss1) = len1; $ set length of result
stra 225 build_spec(multstr, t_istring, ss1); $ build specifier
34
35
36 end fnct multstr;
1 .=member multtup
2 fnct multtup(a1, a2);
3
4$ this routine performs -a1 * a2-, where -a1- is a short integer and
5$ -a2- is a tuple. the result is a tuple obtained by concatenating
6$ -a2- to itself -a1- times. since this operation is rather rare,
7$ it is actually done by a series of concatenations.
8
9$ n.b. (1.) -a1- is the specifier for a short integer.
10$ (2.) -a2- is the specifier for a tuple.
11$ (3.) -a2- is not used destructively.
12
13
14 size a1(hs), $ specifier for integer
15 a2(hs); $ specifier for tuple
16
17 size multtup(hs); $ specifier returned
18
19 size arg2(hs); $ local copy of -a2-
20 size val(ps), $ value of -a1-
21 j(ps); $ loop index
22
23 size addtup(hs), $ functions called
24 nulltup(hs),
25 err_val(hs);
26 size convert(hs); $ conversion utility
27
28
29 val = ivalue_ a1;
30
31 if ft_type(hform(value_ a2)) = f_mtuple then
32 multtup = nulltup(f_tuple, val); arg2 = convert(a2, f_tuple);
33 else
34 multtup = nulltup(hform(value_ a2), val); arg2 = a2;
35 end if;
36
37 do j = 1 to val;
38 multtup = addtup(multtup, arg2);
39 end do;
40
41
42 end fnct multtup;
1 .=member union
2 fnct union(arg1, arg2, decl);
3
4$ general set union function.
5
6$ union, intersection, and set difference are variations of the same
7$ algorithm. each of these primitives is relatively simple when
8$ applied to sets, subsets, packed maps, and untyped maps, but quite
9$ complex when applied to multi valued maps. for this reason operations
10$ on each of the simpler types are done from seperate routines which
11$ can be called from the general union (etc) routine or directly from
12$ the code. the general routines contain code to handle general maps
13$ plus code to call the lower level routines.
14
15$ adding two maps requires the following steps:
16
17$ 1. find some matching element x in the domain of set1 and set2.
18$ set a1 = set1(x) and a2 = set2(x). call the local routine
19$ add_im.
20
21$ 2. if either or both of its arguments are single valued, add_im
22$ will set 'union' to their union. in this
23$ process either a1 or a2 may become part of the result. for
24$ a1 this is no problem, since set1 is being used destructively
25$ anyway. if, however, a2 is included in the result, we must
26$ make a note to set its share bit in set2. this is done by
27$ setting the flag share2 = yes.
28
29$ 3. if both a1 and a2 are multivalued, add_im will copy a1 cond-
30$ itionally and jump to the recursive entry point. since this
31$ is a go to rather than a call, the recursive call will return
32$ directly to add_ims caller.
33
34$ 4. add_im must detect the special case where an smap is becoming
35$ multivalued. if the inputs are smaps we must convert them
36$ to general maps. this is possbible only if the inputs are
37$ undeclared (decl = no).
38
39$ 5. on return from add_im, we set set1(x) = union. if share2 is
40$ set, we also set the is_shared bit of set2(x).
41
42$ union is called in two contexts, as indicated by 'decl':
43
44$ 1. the returned value, arg1, and arg2 have all been declared
45$ to be of some common mode m.
46
47$ 2. the returned value, arg1, and arg2 are undeclared. their
48$ are two possibilities here:
49
50$ a. arg1 and arg2 have some common mode m, so we return a
51$ value of mode m.
52
53$ b. arg1 and arg2 have different modes. we convert both
54$ to unbased set(*) and return a result of unbased set(*).
55
56$ in both cases we assume that a1 can be used destructively.
57
58
59$ union computes the nelt of its result at every recursive level, and
60$ trusts the nelt field to be valid after a recursive return, regardless
61$ of the setting of is_neltok.
62
63
64 size arg1(hs); $ specifier for first input
65 size arg2(hs); $ specifier for second argument
66 size decl(1); $ indicates inputs are declared
67
68 size union(hs); $ specifier returned
69
70 size a1(hs); $ local copies of arguments, used for
71 size a2(hs); $ recursion.
72 size d2(hs); $ domain element of set2
73 size tstart(ps); $ pointer to recursion stack at start
74 size im_nelt(ps); $ the nelt of a map image
75 size pos(ps); $ value return argument to locate
76
77 size unset(hs), unlset(hs), unrset(hs);
78 size unlpm(hs), unlum(hs), unrpm(hs), unrum(hs);
79 size exprmap(ps);
80 size copy1(hs);
81 size withs(hs);
82 size equal(1);
83 size convert(hs);
84 size rset2(hs);
85
86$ stacked variables
87
88 .=zzyorg b $ reset counters for stack offsets
89
90 local(retpt); $ return pointer
91
92 local(set1); $ pointers to two sets.
93 local(set2);
94 local(card); $ cardinality of result
95 local(e); $ pointer to current eb
96 local(p1); $ pointer to an element of set1
97 local(p2); $ pointer to an element of set2
98 local(j); $ loop index over tuple
99 local(lsw1); $ ls_words of two local maps
100 local(lsw2);
101 local(share2); $ flags sharing of an element of set2.
102 local(tup1); $ pointers to tuples of remote maps
103 local(tup2);
104 local(len1); $ lengths of the tuples
105 local(len2);
106 local(min); $ minimum of p1 and p2
107
108
109 tstart = t; $ save initial stack pointer
110
111 .=zzyorg a $ reset counter for return labels
112
113 a1 = arg1; $ copy specifiers
114 a2 = arg2;
115
116
117/entry/ $ recursive entry point
118
119 r_entry; $ increment recursion stack
120
121 set1 = value_ a1; $ get pointers to sets
122 set2 = value_ a2;
123
124$ check that types match
125
126$ if the forms of the arguments are not similar, convert them to
127$ set(*).
128
129 if ^ similar_repr(hform(set1), hform(set2)) then
130 call convset(a1); set1 = value_ a1;
131 call convset(a2); set2 = value_ a2;
132 end if;
133
134
135 go to sc(htype(set1)) in h_uset to h_lrmap;
136
137
138/sc(h_uset)/ $ standard set
139
140 union = unset(a1, a2);
141 go to exit;
142
143
144/sc(h_umap)/ $ standard map
145
146$ we iterate over the domain of set2, locating corresponding domain
147$ elements in set1. we then add their images using the alogorithm
148$ described at the beginning of the routine.
149
150$ in most cases we can calculate the cardinality of the result as we
151$ go. however in this case we will not be iterating over both sets,
152$ so we must calculate nelt after we are done.
153
154 next_loop(p2, set2); $ (forall p2 in set2)
155 d2 = ebspec(p2);
156 call locate(pos, d2, set1, yes);
157 ebspec(p2) = d2; $ might have its share bit set
158 p1 = pos; $ save across recursion
159
160 a1 = ebimag(p1); $ get images
161 a2 = ebimag(p2);
162
163 l_call(add_im); $ add images
164
165$ if a2 is put into the image of set1, its share bit must be set.
166 if (share2) is_shared_ ebimag(p2) = yes;
167
168 ebimag(p1) = union; $ store image and adjust nelt
169 end_next;
170
171 is_hashok(set1) = no;
172
173 build_spec(union, t_map, set1); $ build result
174 ok_nelt(union); $ get the correct nelt
175
176 go to exit;
177
178
179/sc(h_lset)/ $ local subsets
180
181 union = unlset(a1, a2);
182 go to exit;
183
184
185/sc(h_rset)/ $ remote subset
186
187 union = unrset(a1, a2);
188 go to exit;
189
190
191/sc(h_lmap)/ $ local map
192
193$ we iterate over the common base, adding the images of each domain
194$ element.
195
196 lsw1 = ls_word(set1); $ get ls_words.
197 lsw2 = ls_word(set2);
198 card = 0; $ cardinality of result
199
200 next_loop(e, set1); $ (forall e in set1)
201
202 $ form union of images of e.
203 a1 = heap(e+lsw1);
204 a2 = heap(e+lsw2);
205 l_call(add_im);
206
207 $ set share bit of a2 in set2.
208 if (share2) is_shared(e+lsw2) = yes;
209
210 heap(e+lsw1) = union; $ store image and adjust nelt
211 card = card+im_nelt;
212
213 end_next;
214
215 set_nelt(set1, card);
216 is_hashok(set1) = no;
217
218 build_spec(union, t_map, set1); $ build result
219
220 go to exit;
221
222
223/sc(h_rmap)/ $ remote map
224
225$ iterate over the two maps, taking the union of corresponding
226$ tuple components.
227
228 card = 0; $ cardinality of result
229
230 tup1 = set1 + hl_rmap;
231 tup2 = set2 + hl_rmap;
232
233 $ get lengths of tuples, and make sure set1 is as long as set2
234 len1 = maxindx(tup1);
235 len2 = maxindx(tup2);
236
237 if len2 > len1 then $ tup1 is shorter
238 len1 = len2;
239 set1 = exprmap(set1, len2); tup1 = set1 + hl_rmap;
240 end if;
241
242 min = len1; $ length of shorter tuple
243 if (min > len2) min = len2;
244
245$ we will have two loops, first over the length of the shorter tuple,
246$ then over the remaining length of tup1. set the limits for these
247$ loops.
248
249 j = 1; $ loop index over components
250
251 while j <= min;
252 a1 = tcomp(tup1, j);
253 a2 = tcomp(tup2, j);
254
255 l_call(add_im); $ add images
256
257$ set share bit of a2 in set2.
258 if (share2) is_shared_ tcomp(tup2, j) = yes;
259
260 tcomp(tup1, j) = union; $ store image and adjust nelt
261 card = card+im_nelt;
262
263 j = j+1;
264 end while;
265
266
267$ add the remaining components of tup1 into nelt of result
268
269 while j <= maxindx(tup1);
270 a1 = tcomp(tup1, j);
271 j = j+1;
272
273 if is_multi_ a1 then
274 ok_nelt(a1);
275 card = card + nelt(value_ a1);
276
277 else
278 if (^ is_om_ a1) card = card+1;
279 end if;
280
281 end while;
282
283
284 set_nelt(set1, card);
285
286 is_hashok(set1) = no;
287
288
289 build_spec(union, t_map, set1); $ build result
290
291 go to exit;
292
293
294/sc(h_lpmap)/ $ local packed map
295
296 union = unlpm(a1, a2);
297 if (union = 0) go to smap; $ became multivalued
298 go to exit;
299
300
301/sc(h_limap)/ $ local untyped maps
302
303/sc(h_lrmap)/
304
305 union = unlum(a1, a2);
306 if (union = 0) go to smap; $ smap became multivalued
307 go to exit;
308
309
310/sc(h_rpmap)/ $ packed remote map
311
312 union = unrpm(a1, a2);
313 if (union = 0) go to smap; $ smap became multivalued
314 go to exit;
315
316
317/sc(h_rimap)/ $ remote untyped maps
318
319/sc(h_rrmap)/
320
321
322 union = unrum(a1, a2);
323 if (union = 0) go to smap; $ smap became multivalued
324 go to exit;
325
326
327
328
329
330/add_im/ $ local routine to add images
331
332$ this local routine adds two map images, a1 and a2, and places the
333$ result in -union-. it also calculates the nelt of the result and
334$ places it in -im_nelt-. it sets the flag -share2- to indicate
335$ whether or not a2 has been shared. this allows us to set the
336$ share bit in the map which contains a2.
337
338$ the code below tests for various cases which can be done without
339$ a recursive call. if a recursive call is necessary, we jump to
340$ the main recursive entry point.
341
342 share2 = no; $ assume a2 is not shared
343
344 if is_om_ a1 then $ a1 is om, so return a2
345 is_shared_ a2 = yes; share2 = yes;
346 union = a2;
347
348 elseif is_om_ a2 then $ a2 is om, so return a1
349 union = a1;
350
351 elseif is_multi_ a1 & ^ is_multi_ a2 then $ return a1 with a2
352
353 maycopy(a1);
354 is_shared_ a2 = yes; share2 = yes;
355
356 union = withs(a1, a2, no);
357 is_multi_ union = yes;
358
359 elseif is_multi_ a2 & ^ is_multi_ a1 then $ return a2 with a1
360 if (is_smap(set1)) go to smap; $ must convert smap
361
362 is_shared_ a1 = yes;
363 union = withs(copy1(a2), a1, no);
364 is_multi_ union = yes;
365
366 elseif is_multi_ a1 & is_multi_ a2 then $ both multivalued.
367 if eq(a1, a2) then $ trivially equal, i.e. both null
368 union = a1;
369 else
370 maycopy(a1);
371 go to entry;
372 end if;
373
374
375 elseif eq(a1, a2) then $ they-re equal, so return a1
376 union = a1;
377
378 elseif ne(a1, a2) then $ unequal
379 if (is_smap(set1)) go to smap; $ must convert smap
380
381 is_shared_ a2 = yes; share2 = yes;
382 union = rset2(a1, a2); $ return << a1, a2 >>
383 is_multi_ union = yes;
384
385 elseif equal(a1, a2) then $ equal, return a1
386 union = a1;
387
388 else $ unequal
389 if (is_smap(set1)) go to smap; $ convert smap
390
391 is_shared_ a2 = yes; share2 = yes;
392 union = rset2(a1, a2); $ return << a1, a2 >>
393 is_multi_ union = yes;
394 end if;
395
396$ get nelt of result
397 if is_multi_ union then
smfc 21 if is_mmap(set1) = no
smfc 22 & hform(value_ union) ^= ft_imset(hform(set1)) then
smfc 23 union = convert(union, ft_imset(hform(set1)));
smfc 24 is_multi_ union = yes;
smfc 25 end if;
398 ok_nelt(union);
399 im_nelt = nelt(value_ union);
400
401 elseif is_om_ union then
402 im_nelt = 0;
403
404 else
405 im_nelt = 1;
406 end if;
407
408
409 go to rlab(retpt) in 1 to zzya;
410
411
412/smap/ $ an smap is no longer single valued
413
414$ if the map was declared, abort. otherwise convert both
415$ inputs to standard maps, and try again.
416
417 if (decl) go to error_exit;
418
419$ build specifiers for the inputs, then convert
420 build_spec(a1, t_map, set1);
421 build_spec(a2, t_map, set2);
422
423 a1 = convert(a1, f_umap); set1 = value_ a1;
424 a2 = convert(a2, f_umap); set2 = value_ a2;
425
426 go to sc(h_umap); $ go to unbased map case
427
428
429/exit/ $ recursive return
430
431 r_exit; $ pop recursion stack
432
433 if t ^= tstart then
434 is_multi_ union = yes; $ set mmap bit of result
435 im_nelt = nelt(value_ union); $ nelt of image
436
437 go to rlab(retpt) in 1 to zzya;
438
439 else $ actual return
440 return;
441 end if;
442
443/error_exit/ $ error exit
444
445 call err_misc(25);
446
447 union = err_val(f_gen);
448
449 t = tstart;
450 return;
451
452
453
454$ drop local variables
455
456 macdrop8(retpt, set1, set2, card, p1, p2, lsw1, lsw2)
457 macdrop8(share2, tup1, tup2, len1, len2, min, j, e)
458
459 end fnct union;
1 .=member unset
2 fnct unset(arg1, arg2); $ union on standard sets
3
4
5 size unset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10
11 size set1(ps), $ pointers to two sets
12 set2(ps);
13
14 size p1(ps), $ pointers to current ebs of two sets
15 p2(ps);
16
17
18 set1 = value_ arg1; $ get pointers to sets
19 set2 = value_ arg2;
20$ set union is done by iterating over set2, adding elements to set1.
21$ if set2 is live then we must set share bits in set2 every time we
22$ add an element to set1.
23
24$ as we add elements to set1, we will increment its hash by the hash
25$ of the element. the hash is computed when we perform the locate, and
26$ is passed globally through loc_hash.
27
28 next_loop(p2, set2); $ (! p2 _ set2 )
29
30 call locate(p1, ebspec(p2), set1, yes);
31 $ if heap(p2) was added to set1, set share bit in set2.
32$ and increment the hash of set1.
33 if ^ loc_found then
34 is_shared_ ebspec(p2) = yes;
35 up_hash(set1, loc_hash);
36 end if;
37
38 end_next;
39
40 set_nelt(set1, neb(hashtb(set1)));
41
42 build_spec(unset, t_set, set1);
43
44
45 end fnct unset;
1 .=member unlset
2 fnct unlset(a1, a2); $ union on local sets
3
4
5 size unlset(hs); $ specifier returned
6
7 size a1(hs), $ specifiers for two sets
8 a2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps);
12
13 size lsw1(ps), $ their ls_words
14 lsw2(ps),
15 lsb1(ps), $ their ls_bits
16 lsb2(ps);
17
18 size bit1(1), $ current bit of set1
19 bit2(1), $ bit of set2
20 bit(1); $ bit of result
21
22 size card(ps), $ cardinality of result
23 hashc(ps); $ hash of result
24
25 size e(ps); $ pointer to current eb of base.
26
27
28 set1 = value_ a1; $ get pointers to sets
29 set2 = value_ a2;
30$ we iterate over the common base, or-ing the bits corresponding to
31$ each set element.as we add each element to set1, we get it hash from
32$ the base and add it to the hash of set1.
33
34 lsw1 = ls_word(set1); $ get ls_words and ls_bits.
35 lsb1 = ls_bit(set1);
36
37 lsw2 = ls_word(set2);
38 lsb2 = ls_bit(set2);
39
40
41 card = 0; $ cardinality of result.
42 hashc = hc_set; $ hash of null set
43
44 next_loop(e, set1); $ iterate over base
45
46 bit1 = .f. lsb1, 1, heap(e+lsw1);
47 bit2 = .f. lsb2, 1, heap(e+lsw2);
48
49 bit = (bit1 ! bit2);
50
51 card = card+bit;
52 if (bit) hashc = hashc + ebhash(e); $ add hash from base
53
54 .f. lsb1, 1, heap(e+lsw1) = bit;
55
56 end_next;
57
58 set_nelt(set1, card);
59 set_hash(set1, hashc);
60
61 build_spec(unlset, t_set, set1);
62
63
64 end fnct unlset;
1 .=member unrset
2 fnct unrset(arg1, arg2); $ union on remote sets
3
4
5 size unrset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps);
12
13 size p1(ps), $ pointers to their bit strings
14 p2(ps);
15
16 size len1(ps), $ lengths of bit strings
17 len2(ps);
18
19 size j(ps), $ loop index
20 word(hs); $ current word of bit string
21
22 size exprset(ps); $ function called
23
24
25 set1 = value_ arg1; $ get pointers to sets
26 set2 = value_ arg2;
27
28$ we begin by making set1 the longer bit string and then or in
29$ all the words of set2. we calculate -card- as the number of
30$ bits on in set1.
31
32$ unlike some of the other union routines, we do not update the hash
33$ of the set. this is not done since we do not look at each element
34$ individually.
35
36 len1 = rswords(set1);
37 len2 = rswords(set2);
38
39 if len1 < len2 then $ expand set1
40 set1 = exprset(set1, rs_maxi(set2)); len1 = len2;
41 end if;
42
43$ take the union
44
45 do j = 1 to len2;
46 word = (rsword(set1, j) ! rsword(set2, j));
47 rsword(set1, j) = word;
48 end do;
49
50 is_neltok(set1) = no;
51 is_hashok(set1) = no;
52
53 build_spec(unrset, t_set, set1);
54
55
56 end fnct unrset;
1 .=member unlpm
2 fnct unlpm(a1, a2); $ union on local packed maps
3
4$ this routine performs union on local packed maps. it returns 0
5$ if the result becomes multivalued.
6
7
8 size unlpm(hs); $ specifier returned
9
10 size a1(hs), $ specifiers for two sets
11 a2(hs);
12
13 size set1(ps), $ pointers to the sets
14 set2(ps);
15
16 size lsw1(ps), $ their ls_words
17 lsw2(ps),
18 lsb1(ps), $ their ls_bits
19 lsb2(ps);
20
21 size bits(ps), $ number of bits/value
22 card(ps), $ cardinality of result
23 e(ps); $ pointer to current eb of base
24
25 size v1(hs), $ current packed values
26 v2(hs);
27
28
29 set1 = value_ a1; $ get pointers to sets
30 set2 = value_ a2;
31$ iterate over base taking union of elements.
32
33 lsw1 = ls_word(set1); $ get ls_word and ls_bit values.
34 lsw2 = ls_word(set2);
35
36 lsb1 = ls_bit(set1);
37 lsb2 = ls_bit(set2);
38
39 bits = ls_bits(set1); $ bits per entry
40
41 card = 0; $ cardinality of result
42
43 next_loop(e, set1);
44
45 v1 = .f. lsb1, bits, heap(e+lsw1); $ get packed valu
46 v2 = .f. lsb2, bits, heap(e+lsw2);
47
48 if v1 = 0 & v2 = 0 then $ both om
49 cont;
50
51 elseif v1 = 0 then $ union is v2
52 .f. lsb1, bits, heap(e+lsw1) = v2;
53 card = card+1;
54
55 elseif v2 = 0 then $ union is v1, which is already in set1.
56 card = card+1;
57
58 elseif v1 = v2 then $ union is v1, which is already in set1
59 card = card+1;
60
61 else $ map would become multivalued.
62 unlpm = 0; $ flag becoming multivalued
63 return;
64 end if;
65 end_next;
66
67 set_nelt(set1, card);
68
69 is_hashok(set1) = no;
70
71 build_spec(unlpm, t_map, set1);
72
73
74 end fnct unlpm;
1 .=member unlum
2 fnct unlum(arg1, arg2);
3
4$ this routine performs union on local untyped maps. it returns 0
5$ if the result becomes multivalued.
6
7
8 size unlum(hs); $ specifier returned
9
10 size arg1(hs), $ specifiers for two sets
11 arg2(hs);
12
13 size a1(hs), $ tuple components
14 a2(hs);
15
16 size set1(ps), $ pointers to two sets
17 set2(ps);
18
19 size om_val(hs), $ proper om value for components
20 card(ps), $ cardinality of result
21 e(ps); $ pointer to current eb of base
22
23 size lsw1(ps), $ ls_words of the arguments
24 lsw2(ps);
25
26
27 set1 = value_ a1; $ get pointers to sets
28 set2 = value_ a2;
29
30
31 lsw1 = ls_word(set1); $ get ls_words
32 lsw2 = ls_word(set2);
33
34$ get om image as it would appear in map
35 om_val = heap(template(set1)+lsw1);
36
37 card = 0; $ cardinality of result
38
39 $ loop over base
40 next_loop(e, set1);
41
42 a1 = heap(e+lsw1);
43 a2 = heap(e+lsw2);
44
45 if a1 = om_val & a2 = om_val then
46 cont;
47
48 elseif a1 = om_val then $ union is a2.
49 heap(e+lsw1) = a2;
50 card = card+1;
51
52 elseif a2 = om_val then
53 card = card+1;
54
55 else $ map would become multivalued.
56 unlum = 0; $ flag becoming multivalued
57 return;
58 end if;
59 end_next;
60
61 set_nelt(set1, card);
62
63 is_hashok(set1) = no;
64
65 build_spec(unlum, t_map, set1);
66
67
68 end fnct unlum;
1 .=member unrpm
2 fnct unrpm(arg1, arg2); $ union on remote packed map
3
4$ this routine performs union on remote packed maps. it returns 0
5$ if the map becomes multivalued.
6
7
8 size unrpm(hs); $ specifier returned
9
10 size a1(hs), $ specifiers for two sets
11 a2(hs);
12
13 size set1(ps), $ pointers to two sets
14 set2(ps),
15 p1(ps), $ pointers to their tuples
16 p2(ps);
17
18 size len1(ps), $ lengths of the two tuples
19 len2(ps),
20 min(ps), $ minimum of len1 and len2
21 v1(ps), $ their packed values
22 v2(ps);
23
24 size bits(ps), $ bits/packed value
25 card(ps), $ cardinality of resut
26 j(ps), $ loop index over words of tuple
27 org(ps); $ loop index over bit origin in word
28
29 size exprmap(ps); $ function called
30
31
32 set1 = value_ a1; $ get pointers to sets
33 set2 = value_ a2;
34
35
36$ we use a double loop over the tuples, one for sucessive words and
37$ one for successive elements in a word.
38
39 card = 0; $ cardinality of result
40
41 p1 = set1 + hl_rpmap;
42 p2 = set2 + hl_rpmap;
43
44 len1 = maxindx(p1); $ get lengths
45 len2 = maxindx(p2);
46
47
48$ make sure that set1 has as long a tuple as set2, then set 'min' to
49$ the minimum length. the components 1 to min will be the union of
50$ the two sets; the components min+1 to length(set1) will be taken
51$ from set1.
52
53 if len1 < len2 then
54 len1 = len2;
55 set1 = exprmap(set1, len1);
56 end if;
57
58 min = len1;
59 if (min > len2) min = len2;
60
61 bits = ptbits(p1); $ bits/packed value
62
63$ take union over minimum length
64 do j = hl_ptuple to packoffs(p1, min);
65
66 do org = 1 to bpos_max by bits;
67
68 v1 = .f. org, bits, heap(p1+j);
69 v2 = .f. org, bits, heap(p2+j);
70
71 if v1 = 0 & v2 = 0 then $ union is om
72 cont;
73
74 elseif v1 = 0 then $ union is v2
75 .f. org, bits, heap(p1+j) = v2;
76 card = card+1;
77
78 elseif v2 = 0 then $ union is v1
79 card = card+1;
80
81 elseif v1 = v2 then $ union is a1
82 card = card+1;
83
84 else $ map is becoming multivalued.
85 unrpm = 0; $ flag becoming multivalued
86 return;
87 end if;
88 end do;
89 end do;
90
91$ increment cardinality by the remaining elements of set1.
92
93 do j = packoffs(p2, min)+1 to packoffs(p1, len1);
94 do org = 1 to bpos_max by bits;
95
96 if (.f. org, bits, heap(p1+j) ^= 0) card = card+1;
97
98 end do;
99 end do;
100
101 set_nelt(set1, card);
102
103 is_hashok(set1) = no;
104
105 build_spec(unrpm, t_map, set1);
106
107
108 end fnct unrpm;
1 .=member unrum
2 fnct unrum(arg1, arg2);
3
4$ this routine performs union on remote untyped maps. it returns 0
5$ if the result becomes multivalued.
6
7
8 size unrum(hs); $ specifier returned
9
10 size arg1(hs), $ specifiers for two sets
11 arg2(hs);
12
13 size set1(ps), $ pointers to the sets
14 set2(ps),
15 tup1(ps), $ pointers to their tuples
16 tup2(ps);
17
18 size len1(ps), $ length of the tuples
19 len2(ps),
20 min(ps); $ minimum of len1 and len2
21
22 size card(ps), $ cardinality of result
23 om_val(hs), $ om value
24 j(ps); $ loop index over tuple components
25
26 size a1(hs), $ tuple components
27 a2(hs);
28
29 size exprmap(ps); $ function called
30
31
32 set1 = value_ a1; $ get pointers to sets
33 set2 = value_ a2;
34
35 card = 0; $ cardinality of result
36
37 tup1 = set1+1; $ get pointers to tuples
38 tup2 = set1+1;
39
40 len1 = maxindx(tup1); $ get thier lengths.
41 len2 = maxindx(tup2);
42
43$ make sure set1 has as long a tuple as set2, then set min to the
44$ minimum length.
45 if len1 < len2 then
46 len1 = len2;
47 set1 = exprmap(set1, len1);
48 tup1 = set1 + hl_rmap;
49 end if;
50
51 min = len1;
52 if (min > len2) min = len2;
53
54$ get om image value as it would appear in the tuple
55 om_val = tcomp(tup1, 0);
56
57$ take union over length of shorter tuple
58 do j = 1 to min;
59
60 a1 = tcomp(tup1, j);
61 a2 = tcomp(tup2, j);
62
63 if a1 = om_val & a2 = om_val then $ union is om
64 cont;
65
66 elseif a1 = om_val then $ union is a2
67 tcomp(tup1, j) = a2;
68 card = card+1;
69
70 elseif a2 = om_val then $ union is a1
71 card = card+1;
72
73 elseif a1 = a2 then $ union is a1
74 card = card+1;
75
76 else $ map is becoming multivalued.
77 unrum = 0; $ flag becoming multivalued
78 return;
79 end if;
80 end do;
81
82$ increment cardinality by remaining elements of set1.
83
84 do j = min+1 to len1;
85
86 if (tcomp(tup1, j) ^= om_val) card = card+1;
87
88 end do;
89
90 set_nelt(set1, card);
91
92 is_hashok(set1) = no;
93
94 build_spec(unrum, t_map, set1);
95
96
97 end fnct unrum;
1 .=member intersect
2 fnct intersect(arg1, arg2);
3
4
5
6$ union, intersection, and set difference are variations of the same
7$ algorithm. each of these primitives is relatively simple when
8$ applied to sets, subsets, packed maps, and untyped maps, but quite
9$ complex when applied to multi valued maps. for this reason operations
10$ on each of the simpler types are done from seperate routines which
11$ can be called from the general union (etc) routine or directly from
12$ the code. the general routines contain code to handle general maps
13$ plus code to call the lower level routines.
14
15
16$ the intersection routine begins with a branch on type. the code
17$ for those types which may require recursion is contained in line;
18$ the code for other types is found in seperate routines.
19
20$ multiplying two maps requires the following steps:
21
22$ 1. find some matching element x in the domain of set1 and set2.
23$ set a1 = set1(x) and a2 = set2(x). call the local routine
24$ mult_im.
25
26$ 2. if either or both of its arguments are single valued, mult_im
27$ will set 'intersect' to their intersection. in this
28$ process either a1 or a2 may become part of the result. for
29$ a1 this is no problem, since set1 is being used destructively
30$ anyway. howeverif a2 is included in the result, we must
31$ make a note to set its share bit in set2. this is done by
32$ setting the flag share2 = yes.
33
34$ 3. if both a1 and a2 are multivalued, we jump to the take their
35$ intersection recursively. we do this by jumping to the recursive
36$ entry point. after the recursive call, we will return directly to
37$ mult_im-s caller.
38
39$ 4. on return from mult_im, we set set1(x) = intersect. if necessary,
40$ we also set the share bit of set2(x).
41
42$ inter is called in one of two contexts:
43
44$ 1. the returned value, arg1, and arg2 have all been declared
45$ to be of some common mode m.
46
47$ 2. the returned value, arg1, and arg2 are undeclared. their
48$ are two possibilities here:
49
50$ a. arg1 and arg2 have some common mode m, so we return a
51$ value of mode m.
52
53$ b. arg1 and arg2 have different modes. we convert both
54$ to unbased set(*) and return a result of unbased set(*).
55
56$ in both cases we assume that a1 can be used destructively.
57
58
59$ intersect computes the nelt of its result at every recursive level, an
60$ trusts the nelt field to be valid after a recursive return, regardless
61$ of the setting of is_neltok.
62
63 size intersect(hs); $ specifier returned
64
65 size arg1(hs); $ specifier for first input
66 size arg2(hs); $ specifier for second argument
67
68 size a1(hs), $ local copies of arguments, used for
69 a2(hs); $ recursion.
70
71
72 size tstart(ps); $ pointer to recursion stack at start of routin
73
74 size im_nelt(ps); $ nelt of map image. this is an auxilliary
75 $ output of the routine.
76
77 size pos(ps); $ value return parameter to locate
78
79 size inset(hs), $ functions called
80 inlset(hs),
81 inrset(hs),
82 inlpm(hs),
83 inlum(hs),
84 inrpm(hs),
85 inrum(hs),
86 fval(hs),
87 memset(1),
88 copy1(hs),
89 equal(1),
90 arbs(hs);
91
92
93$ stacked variables
94
95 .=zzyorg b $ reset counters for stack offsets
96
97 local(retpt); $ return pointer
98
99 local(set1); $ poiners to two sets.
100 local(set2);
101
102 local(card); $ cardinality of result
103
104 local(e); $ pointer to current eb.
105
106 local(p1); $ pointer to an element of set1
107 local(p2); $ pointer to element of set2
108
109 local(j); $ loop index
110
111 local(prev); $ pointer to last non-deleted eb
112
113 local(lsw1); $ ls_words of two local maps
114 local(lsw2);
115
116 local(share2); $ flags sharing of an element of set2.
117
118 local(tup1); $ pointers to tuples of remote maps
119 local(tup2);
120
121 local(len1); $ lengths of the tuples
122 local(len2);
123 local(min); $ minimum of len1 and len2
124
125
126/begin/ $ begin execution
127
128 tstart = t; $ save initial stack pointer
129
130 .=zzyorg a $ reset counter for return labels
131
132 a1 = arg1; $ make local copies of arguments.
133 a2 = arg2;
134
135
136
137/entry/ $ recursive entry point
138
139 r_entry; $ increment recursion stack
140
141 set1 = value_ a1; $ get pointers to sets
142 set2 = value_ a2;
143
144$ check that types match
145
146$ if the forms of the arguments are not similar, convert them to
147$ set(*).
148
149 if ^ similar_repr(hform(set1), hform(set2)) then
150 call convset(a1); set1 = value_ a1;
151 call convset(a2); set2 = value_ a2;
152 end if;
153
154$ branch on common type
155
156
157 go to sc(htype(set1)) in h_uset to h_lrmap;
158
159
160 /sc(h_uset)/ $ standard set
161
162 intersect = inset(a1, a2);
163 go to exit;
164
165
166 /sc(h_umap)/ $ standard map
167
168$ we iterate (! p1 _ domain set1), trying to locate a matching element
169$ -p2- in the domain of set2. if one is found we take the intersection
170$ of their images. if this is null we remove -p1- from the domain of
171$ set1. otherwise we store the intersection as its new image.
172$ set share bits in the domain of set1.
173
174$ when calling the delete routine, we do not automatically
175$ rehash set1. instead we do it when we are done iterating
176$ over it.
177
178 card = 0; $ cardinality of result
179
180
181 prev = 0; $ pointer to last non-deleted eb
182
183 next_loop(p1, set1); $ ( ! p1 _ domain. set1 )
184
185 call locate(pos, ebspec(p1), set2, no); $ see if its in domain
186 p2 = pos; $ save through recursion
187
188 if loc_found then $ it is. see if images match
189
190 a1 = ebimag(p1); $ get images
191 a2 = ebimag(p2);
192
193 l_call(mult_im); $ multiply images
194
195 if (share2) is_shared_ ebimag(p2) = yes;
196
197 if im_nelt = 0 then $ drop element
198 call delete(set1, prev, p1, no);
199
200 else $ store image and advance 'prev'
201 card = card+im_nelt;
202 ebimag(p1) = intersect;
203
204 prev = p1;
205 end if;
206
207 else $ not found
208 call delete(set1, prev, p1, no);
209 end if;
210
211 end_next;
212
213 maycontract(set1); $ rehash if necessary
214
215 nelt(set1) = card;
216 if (ft_neltok(hform(set1))) is_neltok(set1) = yes;
217
218 is_hashok(set1) = no;
219
220
221 build_spec(intersect, t_map, set1); $ build result
222
223 go to exit;
224
225
226/sc(h_lset)/ $ local subsets
227
228 intersect = inlset(a1, a2);
229 go to exit;
230
231
232
233
234 /sc(h_rset)/ $ remote subset
235
236 intersect = inrset(a1, a2);
237 go to exit;
238
239
240 /sc(h_lmap)/ $ local map
241
242$ we iterate over the eb-s of the base, taking the intersection
243$ of the images.
244
245 lsw1 = ls_word(set1); $ get ls_words.
246 lsw2 = ls_word(set2);
247
248 card = 0; $ cardinality of result
249
250 next_loop(e, set1); $ iterate over base
251 a1 = heap(e+lsw1);
252 a2 = heap(e+lsw2);
253
254 l_call(mult_im);
255$ if a2 has become part of the result, we must set its share bit in set2
256 if (share2) is_shared(e+lsw2) = yes;
257
258 card = card+im_nelt;
259 heap(e+lsw1) = intersect;
260
261 end_next;
262
263 set_nelt(set1, card);
264
265 is_hashok(set1) = no;
266
267
268 build_spec(intersect, t_map, set1); $ build result
269
270 go to exit;
271
272
273/sc(h_rmap)/ $ remote map
274
275$ we iterate over the tuples for the two maps, taking the intersection
276$ of corresponding elements. naturally we do this only for the length
277$ of the shorter tuple.
278
279 card = 0; $ cardinality of result
280
281 tup1 = set1 + hl_rmap;
282 tup2 = set2 + hl_rmap;
283
284 len1 = maxindx(tup1); $ get lengths
285 len2 = maxindx(tup2);
286
287 min = len1;
288 if (len1 > len2) min = len2;
289
290 j = 1; $ loop index over tuple components
291
292 while j <= min;
293 a1 = tcomp(tup1, j);
294 a2 = tcomp(tup2, j);
295
296 l_call(mult_im);
297$ if a2 has become part of the result, we must set its share bit in set2
298 if (share2) is_shared_ tcomp(tup2, j) = yes;
299
300 card = card+im_nelt;
301 tcomp(tup1, j) = intersect;
302
303 j = j+1;
304 end while;
305
306
307$ set remaining components of tup1 to match its template.
308
309 while j <= len1;
310 tcomp(tup1, j) = tcomp(tup1, 0);
311 j = j+1;
312 end while;
313
314 set_nelt(set1, card);
315
316 is_hashok(set1) = no;
317
318 build_spec(intersect, t_map, set1); $ build result
319
320 go to exit;
321
322
323
324/sc(h_lpmap)/ $ local packed map
325
326 intersect = inlpm(a1, a2);
327 go to exit;
328
329
330/sc(h_limap)/ $ local untyped maps
331
332/sc(h_lrmap)/
333
334 intersect = inlum(a1, a2);
335 go to exit;
336
337
338
339 /sc(h_rpmap)/ $ remote packed map
340
341 intersect = inrpm(a1, a2);
342 go to exit;
343
344
345
346
347 /sc(h_rrmap)/ $ remote real map
348
349 /sc(h_rimap)/ $ remote integer map
350
351 intersect = inrum(a1, a2);
352 go to exit;
353
354
355
356
357/mult_im/ $ local routine to multiply images
358
359$ this local routine multiplies two map images -a1- and -a2-. it has
360$ three outputs:
361
362$ intersect: the intersection of the images
363$ im_nelt: the nelt of intersect.
364$ share2: indicates whether we must set the share bit of a2 in the
365$ map it came from.
366
367$ non recursive cases are handled in line. if necessary, we jump to
368$ the recursive entry point.
369
370 share2 = no;
371
372 if is_om_ a1 ! is_om_ a2 then $ return proper omega
373 intersect = om_image(set1);
374
375 elseif is_multi_ a1 & ^ is_multi_ a2 then $ see if a2 _ a1
376
377 if memset(a2, a1) then $ yes, return a2.
378 intersect = a2;
379 share2 = yes;
380 else $ no, return om.
381 intersect = om_image(set1);
382 end if;
383
384 elseif is_multi_ a2 & ^ is_multi_ a1 then $ see if a1 _ a2
smfb 87
385 if memset(a1, a2) then $ yes, return a1
387 intersect = a1;
388 else $ no, return om
389 intersect = om_image(set1);
390 end if;
391
392 elseif is_multi_ a1 & is_multi_ a2 then $ both multivalued
smfc 26 $ see if a1 and a2 are trivially equal (e.g. both null); if
smfb 89 $ not, take intersection recursively.
395 if eq(a1, a2) then
396 intersect = a1;
397 else
smfc 27 a1 = copy1(a1); $ a1 cannot be used destructively
399 go to entry;
400 end if;
401
402 elseif eq(a1, a2) then $ equal, so return a1
403 intersect = a1;
404
405 elseif ne(a1, a2) then $ unequal, return om
406 intersect = om_image(set1);
407
408 elseif equal(a1, a2) then $ return a1
409 intersect = a1;
410
411 else $ return proper om
412 intersect = om_image(set1);
413 end if;
414
415$ get nelt of image.
416 if is_multi_ intersect then
417 ok_nelt(intersect);
418 im_nelt = nelt(value_ intersect);
419
420 elseif is_om_ intersect then
421 im_nelt = 0;
422
423 else
424 im_nelt = 1;
425 end if;
426
427
428 go to rlab(retpt) in 1 to zzya; $ return.
429
430
431/exit/ $ recursive return
432
433 r_exit; $ pop recursion stack
434
435 if t ^= tstart then
436
437 im_nelt = nelt(value_ intersect); $ find nelt
438 is_multi_ intersect = yes;
439
440$ if we are taking the intersection of two mmaps, we replace a null
441$ result with the nullset in the template block. otherwise we
442$ we remove singleton and null sets
443 if is_mmap(set1) then
444 if (im_nelt = 0) intersect = om_image(set1);
445 else
446 if (im_nelt <= 1) intersect = arbs(intersect);
447 end if;
448
449 go to rlab(retpt) in 1 to zzya;
450
451 else $ actual return
452 return;
453 end if;
454
455
456
457$ drop local variables
458
459 macdrop8(retpt, set1, set2, card, p1, p2, lsw1, lsw2)
460 macdrop8(share2, tup1, tup2, len1, len2, min, j, prev)
461 macdrop(e)
462
463 end fnct intersect;
1 .=member inset
2 fnct inset(arg1, arg2);
3
4
5 size inset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10
11 size set1(ps), $ pointers to two sets
12 set2(ps);
13
14 size p1(ps), $ pointers to current ebs of two sets
15 p2(ps);
16
17 size prev(ps); $ pointer to last non-deleted eb
18
19
20 set1 = value_ arg1; $ get pointers to sets
21 set2 = value_ arg2;
22
23$ we iterate (! p1 _ set1). if no matching element can be found in set
24$ we delete p1 from set1 and subtract its hash from that of set1.
25
26$ when we call the delete routine, we do not automatically rehash
27$ set1. instead we do it when we are done iterating over it.
28
29
30 prev = 0; $ pointer to last non-deleted eb
31
32 next_loop(p1, set1); $ (! p1 _ set1 )
33
34 call locate(p2, ebspec(p1), set2, no);
35
36 if ^ loc_found then
37 down_hash(set1, loc_hash);
38 call delete(set1, prev, p1, no);
39
40 else $ advance 'prev'
41 prev = p1;
42 end if;
43
44 end_next;
45
46 maycontract(set1); $ rehash if necessary
47
48
49 set_nelt(set1, neb(hashtb(set1)));
50
51 build_spec(inset, t_set, set1);
52
53
54 end fnct inset;
1 .=member inlset
2 fnct inlset(a1, a2); $ local subset intersection
3
4
5 size inlset(hs); $ specifier returned
6
7 size a1(hs), $ specifiers for two sets
8 a2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps);
12
13 size lsw1(ps), $ their ls_words
14 lsw2(ps),
15 lsb1(ps), $ their ls_bits
16 lsb2(ps);
17
18 size bit1(1), $ current bit of set1
19 bit2(1), $ bit of set2
20 bit(1); $ bit of result
21
22 size card(ps), $ nelt of result
23 hashc(ps); $ hash of result
24
25 size e(ps); $ pointer to current eb of base.
26
27
28 set1 = value_ a1; $ get pointers to sets
29 set2 = value_ a2;
30
31$ we iterate over the common base, and-ing the bits corresponding
32$ to the two sets. we also calculate the nelt and hash of the set as
33$ we go.
34
35 lsw1 = ls_word(set1); $ get ls_words and ls_bits.
36 lsb1 = ls_bit(set1);
37
38 lsw2 = ls_word(set2);
39 lsb2 = ls_bit(set2);
40
41 card = 0; $ cardinality of result
42 hashc = hc_set; $ hash code of null set
43
44 next_loop(e, set1); $ iterate over base
45
46 bit1 = .f. lsb1, 1, heap(e+lsw1);
47 bit2 = .f. lsb2, 1, heap(e+lsw2);
48
49 bit = (bit1 & bit2);
50
51 card = card+bit;
52 if (bit) hashc = hashc + ebhash(e); $ add hash from base
53
54 .f. lsb1, 1, heap(e+lsw1) = bit;
55
56 end_next;
57
58 set_nelt(set1, card);
59 set_hash(set1, hashc);
60
61 build_spec(inlset, t_set, set1);
62
63
64 end fnct inlset;
1 .=member inrset
2 fnct inrset(arg1, arg2); $ remote subset intersection
3
4
5 size inrset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps);
12
13 size p1(ps), $ pointers to their bit strings
14 p2(ps);
15
16 size len1(ps), $ kengths of bit strings
17 len2(ps),
18 min(ps); $ minimum of len1 and len2.
19
20 size j(ps); $ loop index
21 size word(hs); $ current word of bit string
22
23
24 set1 = value_ arg1; $ get pointers to sets
25 set2 = value_ arg2;
26
27
28$ we and together the bit stringds for the two subsets. natuarally
29$ we need do this only for the length of the shorter string.
30
31
32$ since we are not looking at set elements one at a time, we do not
33$ calculate the hash code of the set.
34
35 len1 = rswords(set1); $ get their lengths.
36 len2 = rswords(set2);
37
38 min = len1;
39 if (len1 > len2) min = len2;
40
41
42 $ take intersect over length of shorter string
43 do j = 1 to min;
44 word = (rsword(set1, j) & rsword(set2, j));
45 rsword(set1, j) = word;
46 end do;
47
48$ zero out remaining words of set1
49
50 do j = min+1 to len1;
51 rsword(set1, j) = 0;
52 end do;
53
54 is_neltok(set1) = no;
55 is_hashok(set1) = no;
56
57 build_spec(inrset, t_set, set1);
58
59
60 end fnct inrset;
1 .=member inlpm
2 fnct inlpm(a1, a2); $ local packed map intersection
3
4$ this routine finds the intersection of two local packed maps with
5$ the same repr. since they have the same repr, the two maps have
6$ the same ls_bits and ls_vect.
7
8
9 size inlpm(hs); $ specifier returned
10
11 size a1(hs), $ specifiers for two sets
12 a2(hs);
13
14 size set1(ps), $ pointers to the sets
15 set2(ps);
16
17 size lsw1(ps), $ their ls_words
18 lsw2(ps),
19 lsb1(ps), $ their ls_bits
20 lsb2(ps);
21
22 size bits(ps), $ number of bits/value
23 card(ps), $ cardinality of result
24 e(ps); $ pointer to current eb of base
25
26 size v1(hs), $ current packed values
27 v2(hs);
28
29
30 set1 = value_ a1; $ get pointers to sets
31 set2 = value_ a2;
32
33 lsw1 = ls_word(set1); $ get ls_word_ and ls_bit_ values.
34 lsw2 = ls_word(set2)+1;
35
36 lsb1 = ls_bit(set1);
37 lsb2 = ls_bit(set2);
38
39 bits = ls_bits(set1); $ bits per entry
40
41 card = 0; $ cardinality of result
42
43 next_loop(e, set1);
44 v1 = .f. lsb1, bits, heap(e+lsw1); $ get packed valu
45 v2 = .f. lsb2, bits, heap(e+lsw2);
46
47 if v1 = 0 then $ intersection is null
48 cont;
49
50 elseif v2 = 0 then $ intersection is again null
51 .f. lsb1, bits, heap(e+lsw1) = 0;
52
53 elseif v1 = v2 then $ intersection is v1, which is already in
54 card = card+1;
55
56 else $ images are unequal, so result is om.
57 .f. lsb1, bits, heap(e+lsw1) = 0;
58
59 end if;
60 end_next;
61
62 set_nelt(set1, card);
63
64 is_hashok(set1) = no;
65
66 build_spec(inlpm, t_map, set1);
67
68
69 end fnct inlpm;
1 .=member inlum
2 fnct inlum(arg1, arg2);
3
4$ this routine performs intersection on untyped local maps.
5
6
7 size inlum(hs); $ specifier returned
8
9 size arg1(hs), $ specifiers for two sets
10 arg2(hs);
11
12 size a1(hs), $ tuple components
13 a2(hs);
14
15 size set1(ps), $ pointers to two sets
16 set2(ps);
17
18 size om_val(hs), $ proper om value for components
19 card(ps), $ cardinality of result
20 e(ps); $ pointer to current eb of base
21
22 size lsw1(ps), $ ls_words of the arguments
23 lsw2(ps);
24
25
26 set1 = value_ a1; $ get pointers to sets
27 set2 = value_ a2;
28
29 lsw1 = ls_word(set1); $ get ls_words
30 lsw2 = ls_word(set2);
31
32 card = 0; $ cardinality of result
33
34$ get om image value as it appears in map
35 om_val = heap(template(set1)+lsw1);
36
37 $ loop over base
38 next_loop(e, set1);
39
40 a1 = heap(e+lsw1);
41 a2 = heap(e+lsw2);
42
43 if a1 = a2 then $ result is a1. adjust nelt
44 if (^ a1 ^= om_val) card = card+1;
45
46 else $ result is om.
47 heap(e+lsw1) = om_val;
48 end if;
49 end_next;
50
51 set_nelt(set1, card);
52
53 is_hashok(set1) = no;
54
55 build_spec(inlum, t_map, set1);
56
57
58 end fnct inlum;
1 .=member inrpm
2 fnct inrpm(a1, a2); $ remote packed map intersection
3
4$ this routine handles the intersection of two remote packed maps
5$ with the same repr. the tuples for the two sets have the same
6$ ptbits, ptvect, etc.
7
8
9 size inrpm(hs); $ specifier returned
10
11 size a1(hs), $ specifiers for two sets
12 a2(hs);
13
14 size set1(ps), $ pointers to two sets
15 set2(ps),
16 p1(ps), $ pointers to their tuples
17 p2(ps);
18
19 size len1(ps), $ lengths of the two tuples
20 len2(ps),
21 min(ps), $ minimum of len1 and len2.
22 v1(ps), $ their packed values
23 v2(ps);
24
25 size bits(ps), $ bits/packed value
26 card(ps), $ cardinality of resut
27 j(ps), $ loop index over words of tuple
28 org(ps); $ loop index over bit origin in word
29
30
31 set1 = value_ a1; $ get pointers to sets
32 set2 = value_ a2;
33$ we use a double loop over the tuples, one for sucessive words and
34$ one for successive elements in a word.
35
36 card = 0; $ cardinality of result
37
38 p1 = set1 + hl_rpmap;
39 p2 = set2 + hl_rpmap;
40
41 len1 = maxindx(p1); $ get lengths
42 len2 = maxindx(p2);
43
44 min = len1;
45 if (len1 > len2) min = len2;
46
47 bits = ptbits(p1); $ bits per entry
48
49
50 do j = hl_ptuple to packoffs(p1, min);
51
52 do org = 1 to bpos_max by bits;
53
54 v1 = .f. org, bits, heap(p1+j);
55 v2 = .f. org, bits, heap(p2+j);
56
57 if v1 = v2 then $ result is v1. adjust card
58 if (v1 ^= 0) card = card+1;
59 else $ result is om.
60 .f. org, bits, heap(p1+j) = 0;
61 end if;
62
63 end do;
64 end do;
65
66$ zero out remaining words of set1
67
68 do j = packoffs(p1, min)+1 to packoffs(p1, len1);
69 heap(p1+j) = 0;
70 end do;
71
72 set_nelt(set1, card);
73
74 is_hashok(set1) = no;
75
76 build_spec(inrpm, t_map, set1);
77
78
79 end fnct inrpm;
1 .=member inrum
2 fnct inrum(arg1, arg2);
3
4$ this routine performs intersection on untyped remote maps.
5
6
7 size inrum(hs); $ specifier returned
8
9 size arg1(hs), $ specifiers for two sets
10 arg2(hs);
11
12 size set1(ps), $ pointers to the sets
13 set2(ps),
14 tup1(ps), $ pointers to their tuples
15 tup2(ps);
16
17 size len1(ps), $ length of the tuples
18 len2(ps),
19 min(ps); $ minimum of above
20
21 size card(ps), $ cardinality of result
22 om_val(hs), $ untyped om value
23 j(ps); $ loop index over tuple components
24
25 size a1(hs), $ tuple components
26 a2(hs);
27
28
29 set1 = value_ a1; $ get pointers to sets
30 set2 = value_ a2;
31 $ set om_val to type_ of om value_ which
32 $ might appear in map.
33 card = 0; $ cardinality of result
34
35 tup1 = set1+1; $ get pointers to tuples
36 tup2 = set2+1;
37
38 len1 = maxindx(tup1); $ get thier lengths.
39 len2 = maxindx(tup2);
40
41 $ make set1 the smaller tuple
42 min = len1;
43 if (len1 > len2) min = len2;
44
45$ get om image as it appears in tuple
46 om_val = tcomp(tup1, 0);
47
48 do j = 1 to min;
49
50 a1 = tcomp(tup1, j);
51 a2 = tcomp(tup2, j);
52
53 if a1 ^= a2 ! a1 = om_val ! a2 = om_val then
54 tcomp(tup1, j) = om_val;
55
56 else
57 tcomp(tup1, j) = a1;
58 card = card+1;
59
60 end if;
61 end do;
62
63$ set remaining words of set1 to om_val.
64
65 do j = min+1 to len1;
66 tcomp(tup1, j) = om_val;
67 end do;
68
69
70
71 set_nelt(set1, card);
72
73 is_hashok(set1) = no;
74
75 build_spec(inrum, t_map, set1);
76
77
78 end fnct inrum;
1 .=member setdiff
2 fnct setdiff(arg1, arg2);
3
4
5$ union, intersection, and set difference are variations of the same
6$ algorithm. each of these primitives is relatively simple when
7$ applied to sets, subsets, packed maps, and untyped maps, but quite
8$ complex when applied to multi valued maps. for this reason operations
9$ on each of the simpler types are done from seperate routines which
10$ can be called from the general union (etc) routine or directly from
11$ the code. the general routines contain code to handle general maps
12$ plus code to call the lower level routines.
13
14$ the set difference routine begins with a branch on type. the code
15$ for those types which may require recursion is contained in line;
16$ the code for other types is found in seperate routines.
17
18$ subtracting two maps requires the following steps:
19
20$ 1. find some matching element x in the domain of set1 and set2.
21$ set a1 = set1(x) and a2 = set2(x). call the local routine
22$ diff_im.
23
24$ 2. if either or both of its arguments are single valued, diff_im
25$ will set 'setdiff' to their difference. in this
26$ process either a1 or a2 may become part of the result. for
27$ a1 this is no problem, since set1 is being used destructively
28$ anyway. however if a2 is included in the result, we must
29$ make a note to set its share bit in set2. this is done by
30$ setting the flag share2 = yes.
31
32$ 3. if both a1 and a2 are multivalued, we jump to the take their
33$ difference recursively. we do this by jumping to the recursive
34$ entry point. after the recursive call, we will return directly to
35$ diff_im-s caller.
36
37$ 4. on return from diff_im, we set set1(x) = setdiff. if necessary,
38$ we also set the share bit of set2(x).
39
40$ setdiff is called in one of two contexts:
41
42$ 1. the returned value, arg1, and arg2 have all been declared
43$ to be of some common mode m.
44
45$ 2. the returned value, arg1, and arg2 are undeclared. their
46$ are two possibilities here:
47
48$ a. arg1 and arg2 have some common mode m, so we return a
49$ value of mode m.
50
51$ b. arg1 and arg2 have different modes. we convert both
52$ to unbased set(*) and return a result of unbased set(*).
53
54$ in both cases we assume that a1 can be used destructively.
55
56$ setdiff computes the nelt of its result at every recursive level, an
57$ trusts the nelt field to be valid after a recursive return, regardless
58$ of the setting of is_neltok.
59
60 size setdiff(hs); $ specifier returned
61
62 size arg1(hs); $ specifier for first input
63 size arg2(hs); $ specifier for second argument
64
65 size a1(hs), $ local copies of arguments, used for
66 a2(hs); $ recursion.
67
68
69 size tstart(ps); $ pointer to recursion stack at start of routin
70
71 size im_nelt(ps); $ nelt of map image. this is an auxilliary
72 $ output of the routine.
73
74 size pos(ps); $ value return parameter of locate
75
76 size difset(hs), $ functions called
77 diflset(hs),
78 difrset(hs),
79 diflpm(hs),
80 diflum(hs),
81 difrpm(hs),
82 difrum(hs),
83 less(hs),
84 fval(hs),
85 memset(1),
86 copy1(hs),
87 equal(1),
88 arb1(hs),
89 arbs(hs);
90
91$ stacked variables
92
93 .=zzyorg b $ reset counters for stack offsets
94
95 local(retpt); $ return pointer
96
97 local(set1); $ poiners to two sets.
98 local(set2);
99
100 local(card); $ cardinality of result
101
102 local(p1); $ pointer to an element of set1
103 local(p2); $ pointer to an element of set2
104
105 local(j); $ loop index over tuple components
106
107 local(lsw1); $ ls_words of two local maps
108 local(lsw2);
109
110 local(share2); $ flags sharing of an element of set2.
111
112 local(tup1); $ pointers to tuples of remote maps
113 local(tup2);
114
115 local(len1); $ lengths of the tuples
116 local(len2);
117
118 local(prev); $ pointer to last non-deleted eb
119
120 local(min); $ length of shorter tuple
121
122 local(plima); $ limits for p1 over remote maps
123 local(plimb);
124
125
126
127/begin/
128
129 $ begin execution
130
131 tstart = t; $ save initial stack pointer
132
133 .=zzyorg a $ reset counter for return labels
134
135 a1 = arg1; $ copy arguments
136 a2 = arg2;
137
138
139
140/entry/ $ recursive entry point
141
142
143 r_entry; $ increment recursion stack
144
145 set1 = value_ a1; $ get pointers to set headers
146 set2 = value_ a2;
147
148$ check that types match
149
150$ if the forms of the arguments are not similar, convert them to
151$ set(*).
152
153 if ^ similar_repr(hform(set1), hform(set2)) then
154 call convset(a1); set1 = value_ a1;
155 call convset(a2); set2 = value_ a2;
156 end if;
157
158
159 go to sc(htype(set1)) in h_uset to h_lrmap;
160
161
162 /sc(h_uset)/ $ standard set
163
164 setdiff = difset(a1, a2);
165 go to exit;
166
167
168 /sc(h_umap)/ $ standard map
169
170$ we iterate (! p1 _ domain set1), trying to find a matching element
171$ -p2- in the domain of set2. if one is found, we take the difference
172$ of their images. if this is null, we delete -p1- from the domain of
173$ set1. otherwise we set its image to the difference of the images.
174
175$ when we call the delete routine, we do not automatically rehash
176$ set1. instead we rehash it when we are done iterating over it.
177
178 card = 0; $ cardinality of result
179 prev = 0; $ pointer to last non-deleted eb
180
181 next_loop(p1, set1); $ (forall p1 in set1)
182
183 call locate(pos, ebspec(p1), set2, no);
184 p2 = pos; $ save through recursion
185
186 if loc_found then
187 $ p1 is in both domains. get difference of images.
188 a1 = ebimag(p1); $ get images
189 a2 = ebimag(p2);
190
191 l_call(diff_im); $ take difference of images
192
193 if im_nelt = 0 then $ delete p1 from domain
194 call delete(set1, prev, p1, no);
195
196 else $ store image, add nelt, and advance 'prev'
197 ebimag(p1) = setdiff;
198 card = card+im_nelt;
199
200 prev = p1;
201 end if;
202
203 else $ get image of p1, add its nelt, and advance 'prev'
204 a1 = ebimag(p1);
205
206 if is_multi_ a1 then
207 ok_nelt(a1);
208 card = card + nelt(value_ a1);
209 else
210 card = card + 1;
211 end if;
212
213 prev = p1;
214
215 end if;
216
217 end_next;
218
219 maycontract(set1); $ rehash if necessary
220
221 set_nelt(set1, card);
222
223 is_hashok(set1) = no;
224
225
226 build_spec(setdiff, t_map, set1); $ build result
227
228 go to exit;
229
230
231 /sc(h_lset)/ $ local subsets
232
233 setdiff = diflset(a1, a2);
234 go to exit;
235
236
237/sc(h_rset)/ $ remote subset
238
239 setdiff = difrset(a1, a2);
240 go to exit;
241
242
243 /sc(h_lmap)/ $ local map
244
245$ iterate over the common base, taking the difference of the
246$ difference of the corresponding words in each eb.
247
248 lsw1 = ls_word(set1); $ get ls_words.
249 lsw2 = ls_word(set2);
250
251 card = 0; $ cardinality of result
252
253 next_loop(p1, set1);
254
255 $ form difference of images of e.
256 a1 = heap(p1+lsw1);
257 a2 = heap(p1+lsw2);
258
259 l_call(diff_im); $ take difference of images
260
261 card = card+im_nelt;
262 heap(p1+lsw1) = setdiff;
263
264 end_next;
265
266 set_nelt(set1, card);
267
268 is_hashok(set1) = no;
269
270
271 build_spec(setdiff, t_map, set1); $ build result
272
273 go to exit;
274
275
276
277 /sc(h_rmap)/ $ remote map
278
279$ iterate over the two tuples for the length of the shorter, taking
280
281$ nelt of the result the result to include the remaining elements of
282$ set1.
283
284$ we have two while loops, the first to take the difference of elements,
285$ and the second to adjust the nelt of the result
286 $ the logic here is similar to remote s
287 $ subsets.
288
289 card = 0; $ cardinality of result
290
291 tup1 = set1 + hl_rmap;
292 tup2 = set2 + hl_rmap;
293
294 len1 = maxindx(tup1); $ get lengths.
295 len2 = maxindx(tup2);
296
297 min = len1; $ find minimum length
298 if (min > len2) min = len2;
299
300
301 j = 1; $ loop over tuple components
302
303 while j <= min;
304 a1 = tcomp(tup1, j);
305 a2 = tcomp(tup2, j);
306
307 l_call(diff_im); $ take difference of images.
308
309 card = card+im_nelt;
310 tcomp(tup1, j) = setdiff;
311
312 j = j+1;
313 end while;
314
315
316 $ add remaining words of set1.
317
318 while j <= len1;
319 a1 = tcomp(tup1, j);
320 j = j+1;
321
322 if is_multi_ a1 then
323 ok_nelt(a1);
324 card = card + nelt(value_ a1);
325
326 else
327 if (^ is_om_ a1) card = card+1;
328 end if;
329
330 end while;
331
332 set_nelt(set1, card);
333
334 is_hashok(set1) = no;
335
336
337 build_spec(setdiff, t_map, set1); $ build result
338
339 go to exit;
340
341
342
343 /sc(h_lpmap)/ $ local packed map
344
345 setdiff = diflpm(a1, a2);
346 go to exit;
347
348
349/sc(h_limap)/ $ local untyped maps
350
351/sc(h_lrmap)/
352
353 setdiff = diflum(a1, a2);
354 go to exit;
355
356
357
358/sc(h_rpmap)/ $ remote packed map
359
360 setdiff = difrpm(a1, a2);
361 go to exit;
362
363
364
365
366/sc(h_rrmap)/ $ remote untyped maps
367
368/sc(h_rimap)/
369
370 setdiff = difrum(a1, a2);
371 go to exit;
372
373
374
375/diff_im/ $ local routine to subtract images
376
377$ this local routine takes the difference of two map images a1 and a2.
378$ its outputs are:
379
380$ im_nelt: nelt of the result
381$ share2: indicates that we should set the share bit of a2 in the
382$ map it came from.
383
384$ nonrecursive cases are handled below. if recursion is necessary,
385$ we jump to the recursive entry point.
386
387
388 share2 = no;
389
390 if is_om_ a1 ! is_om_ a2 then $ return a1
391 setdiff = a1;
392
393 elseif is_multi_ a1 & ^ is_multi_ a2 then $ return a1 less a2
394
395 maycopy(a1); $ copy if necessary
396 setdiff = less(a1, a2);
397 is_multi_ setdiff = yes;
398
399 if (^ is_mmap(set1)) setdiff = arb1(setdiff);
400
401 elseif is_multi_ a2 & ^ is_multi_ a1 then $ see if a1 _ a2
402
403 if memset(a1, a2) then $ it is, so return om.
404 setdiff = om_image(set1);
405 else $ return a1
406 setdiff = a1;
407 end if;
408
409 elseif is_multi_ a1 & is_multi_ a2 then $ both multivalued.
410 $ see if they are trivially equal(i.e. both null).
411 $ if not, take difference recursively
412 if eq(a1, a2) then
413 setdiff = om_image(set1);
414 else
415 maycopy(a1);
416 go to entry;
417 end if;
418
419 elseif eq(a1, a2) then $ return om or null range set
420 setdiff = om_image(set1);
421
422 elseif ne(a1, a2) then $ unequal, return a1
423 setdiff = a1;
424
425 elseif equal(a1, a2) then$ equal, return om. or null range set
426 setdiff = om_image(set1);
427
428 else $ unequal, return a1
429 setdiff = a1;
430 end if;
431
432$ get nelt of image
433 if is_multi_ setdiff then
434 ok_nelt(setdiff);
435 im_nelt = nelt(value_ setdiff);
436
437 elseif is_om_ setdiff then
438 im_nelt = 0;
439
440 else
441 im_nelt = 1;
442 end if;
443
444
445 go to rlab(retpt) in 1 to zzya; $ return.
446
447
448/exit/ $ recursive return
449
450 r_exit; $ pop recursion stack
451
452 if t ^= tstart then
453 $ recursive return. do extra bookkeeping
454
455 im_nelt = nelt(value_ setdiff); $ hold onto nelt
456 is_multi_ setdiff = yes;
457
458$ if we are taking the difference of two mmaps, we replace null results
459$ with the nullset in the template. otherwise we get rid of singleton
460$ and null range sets.
461 if is_mmap(set1) then
462 if (im_nelt = 0) setdiff = om_image(set1);
463 else
464 if (im_nelt <= 1) setdiff = arbs(setdiff);
465 end if;
466
467
468 go to rlab(retpt) in 1 to zzya;
469
470 else $ actual return
471 return;
472 end if;
473
474
475
476$ drop local variables
477
478 macdrop8(retpt, set1, set2, card, p1, p2, lsw1, lsw2)
479 macdrop8(share2, tup1, tup2, len1, len2, prev, min, j)
480
481 end fnct setdiff;
1 .=member difset
2 fnct difset(arg1, arg2); $ standard set difference
3
4
5 size difset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10
11 size set1(ps), $ pointers to two sets
12 set2(ps);
13
14 size p1(ps), $ pointers to current ebs of two sets
15 p2(ps);
16
17 size prev(ps); $ pointer to last non-deleted eb
18
19
20 set1 = value_ arg1; $ get pointers to sets
21 set2 = value_ arg2;
22
23
24$ we iterate over set1, deleting elements if a corresponding element
25$ can be found in set2. we adjust the hash of set1 as we delete elements
26
27$ rather than rehashing set1 as we delete elements, we do it when
28$ we are done iterating over it.
29
30 prev = 0; $ pointer to last non-deleted eb
31
32 next_loop(p1, set1); $ (! _ e set1 )
33
34 call locate(p2, ebspec(p1), set2, no);
35
36 if loc_found then $ delete element and adjust hash
37 down_hash(set1, loc_hash);
38 call delete(set1,prev, p1, no);
39
40 else $ advance 'prev'
41 prev = p1;
42 end if;
43
44 end_next;
45
46 maycontract(set1); $ rehash if necessary
47
48 set_nelt(set1, neb(hashtb(set1)));
49
50 build_spec(difset, t_set, set1);
51
52 return;
53
54 end fnct difset;
1 .=member diflset
2 fnct diflset(arg1, arg2); $ local subset difference
3
4
5 size diflset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps);
12
13 size lsw1(ps), $ their ls_words
14 lsw2(ps),
15 lsb1(ps), $ their ls_bits
16 lsb2(ps);
17
18 size bit1(1), $ current bit of set1
19 bit2(1), $ bit of set2
20 bit(1); $ bit of result
21
22 size card(ps), $ nelt of result
23 hashc(ps); $ hash of result
24 size e(ps); $ pointer to current eb of base.
25
26
27 set1 = value_ arg1; $ get pointers to sets
28 set2 = value_ arg2;
29
30$ iterate over the common base, taking the difference of the
31$ corresponding bits in each eb.
32
33$ we calculate the nelt and hash of the set as we go.
34
35 lsw1 = ls_word(set1); $ get ls_words and ls_bits.
36 lsb1 = ls_bit(set1);
37
38 lsw2 = ls_word(set2);
39 lsb2 = ls_bit(set2);
40
41 card = 0; $ cardinality of result
42 hashc = hc_set; $ hash of null set
43
44
45 next_loop(e, set1); $ iterate over base
46
47 bit1 = .f. lsb1, 1, heap(e+lsw1);
48 bit2 = .f. lsb2, 1, heap(e+lsw2);
49
50 bit = (bit1 & ^bit2);
51
52 card = card+bit;
53 if (bit) hashc = hashc + ebhash(e); $ add hash from base
54
55
56 .f. lsb1, 1, heap(e+lsw1) = bit;
57
58 end_next;
59
60
61
62 set_nelt(set1, card);
63 set_hash(set1, hashc);
64
65 build_spec(diflset, t_set, set1);
66
67 return;
68
69 end fnct diflset;
1 .=member difrset
2 fnct difrset(arg1, arg2); $ remote subset difference
3
4
5 size difrset(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps);
12
13 size p1(ps), $ pointers to their bit strings
14 p2(ps);
15
16 size len1(ps), $ kengths of bit strings
17 len2(ps),
18 min(ps); $ minimum of len1 and len2.
19
20 size j(ps); $ loop index
21 size word(hs); $ current word of bit string
22
23
24 set1 = value_ arg1;
25 set2 = value_ arg2;
26
27$ iterate over the two bit strings for the length of the shorter,
28$ taking the boolean difference of each word. then add the remaining
29$ words of the bit string for set1 (if any) into the nelt of the result
30$ since we are not looking at individual elements, we do not calculate
31$ the hash of the set.
32
33 len1 = rswords(set1);
34 len2 = rswords(set2);
35
36 min = len1; $ find shorter length
37 if (min > len2) min = len2;
38
39 do j = 1 to min;
40 word = rsword(set1, j) & ^ rsword(set2, j);
41 rsword(set1, j) = word;
42 end do;
43 $ add remaining words of set1
44 is_neltok(set1) = no;
45 is_hashok(set1) = no;
46
47 build_spec(difrset, t_set, set1);
48
49
50 end fnct difrset;
1 .=member diflpm
2 fnct diflpm(a1, a2); $ local packed map difference
3
4
5 size diflpm(hs); $ specifier returned
6
7 size a1(hs), $ specifiers for two sets
8 a2(hs);
9
10 size set1(ps), $ pointers to the sets
11 set2(ps);
12
13 size ebw1(ps), $ their ls_words
14 ebw2(ps),
15 ebb1(ps), $ their ls_bits
16 ebb2(ps);
17
18 size bits(ps), $ number of bits/value
19 card(ps), $ cardinality of result
20 e(ps); $ pointer to current eb of base
21
22 size v1(hs), $ current packed values
23 v2(hs);
24
25
26 set1 = value_ a1; $ get pointers to sets
27 set2 = value_ a2;
28
29$ iterate over base taking difference of elements.
30
31 ebw1 = ls_word(set1); $ get ls_word_ and ls_bit_ values.
32 ebw2 = ls_word(set2);
33
34 ebb1 = ls_bit(set1);
35 ebb2 = ls_bit(set2);
36
37 bits = ls_bits(set1); $ bits per entry
38
39 card = 0; $ cardinality of result
40
41 next_loop(e, set1);
42
43 v1 = .f. ebb1, bits, heap(e+ebw1); $ get packed valu
44 v2 = .f. ebb2, bits, heap(e+ebw2);
45
46 if v1 = 0 then $ difference is null
47 cont;
48
49 elseif v1 = v2 then $ difference is null
50 .f. ebb1, bits, heap(e+ebw1) = 0;
51
52 else $ difference is v1
53 card = card+1;
54
55 end if;
56 end_next;
57
58
59 set_nelt(set1, card);
60
61 is_hashok(set1) = no;
62
63 build_spec(diflpm, t_map, set1);
64
65
66 end fnct diflpm;
1 .=member diflum
2 fnct diflum(arg1, arg2);
3
4
5 size diflum(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10 size a1(hs), $ tuple components
11 a2(hs);
12
13 size set1(ps), $ pointers to two sets
14 set2(ps);
15
16 size om_val(hs), $ proper om value for components
17 card(ps), $ cardinality of result
18 e(ps); $ pointer to current eb of base
19
20 size ebw1(ps), $ ls_words of the arguments
21 ebw2(ps);
22
23
24 set1 = value_ a1; $ get pointers to sets
25 set2 = value_ a2;
26
27 $ set -om_val- to om value_ which might
28 $ appear in map.
29
30
31 ebw1 = ls_word(set1); $ get ls_words
32 ebw2 = ls_word(set2);
33
34 card = 0; $ cardinality of result
35
36$ get om image as it appears in map
37 om_val = heap(template(set1)+ebw1);
38
39 $ loop over base
40 next_loop(e, set1);
41
42 a1 = heap(e+ebw1);
43 a2 = heap(e+ebw2);
44
45 if a1 = om_val then $ difference is null
46 cont;
47
48 elseif a1 = a2 then $ difference is null
49 heap(e+ebw1) = om_val;
50
51 else $ difference is a1
52 card = card+1;
53
54 end if;
55 end_next;
56
57
58
59 set_nelt(set1, card);
60
61 is_hashok(set1) = no;
62
63 build_spec(diflum, t_map, set1);
64
65 return;
66
67 end fnct diflum;
1 .=member difrpm
2 fnct difrpm(a1, a2); $ remote packed map difference
3
4
5 size difrpm(hs); $ specifier returned
6
7 size a1(hs), $ specifiers for two sets
8 a2(hs);
9
10 size set1(ps), $ pointers to two sets
11 set2(ps),
12 p1(ps), $ pointers to their tuples
13 p2(ps);
14
15 size len1(ps), $ lengths of the two tuples
16 len2(ps),
17 min(ps), $ minimum of len1 and len2
18 v1(ps), $ their packed values
19 v2(ps);
20
21 size bits(ps), $ bits/packed value
22 card(ps), $ cardinality of resut
23 j(ps), $ loop index over words of tuple
24 org(ps); $ loop index over bit origin in word
25
26
27 set1 = value_ a1; $ get pointers to sets
28 set2 = value_ a2;
29
30$ we use a double loop over the tuples, one for sucessive words and
31$ one for successive elements in a word.
32
33 card = 0; $ cardinality of result
34
35 p1 = set1 + hl_rpmap;
36 p2 = set2 + hl_rpmap;
37
38 len1 = maxindx(p1); $ get lengths
39 len2 = maxindx(p2);
40
41 bits = ptbits(p1); $ bits per entry
42
43 $ make set1 the smaller tuple
44 min = len1; $ find minimum length
45 if (min > len2) min = len2;
46
47 do j = hl_ptuple to packoffs(p1, min);
48
49 do org = 1 to bpos_max by bits;
50
51 v1 = .f. org, bits, heap(p1+j);
52 v2 = .f. org, bits, heap(p2+j);
53
54 if v1 = 0 then $ difference is null
55 cont;
56
57 elseif v1 = v2 then $ difference is null
58 .f. org, bits, heap(p1+j) = 0;
59
60 else $ difference is v1
61 .f. org, bits, heap(p1+j) = v1;
62 card = card+1;
63 end if;
64
65 end do;
66 end do;
67
68 $ adjust -card- for remaining elements in set1
69
70 do j = packoffs(p1, min)+1 to packoffs(p1, len1);
71 do org = 1 to bpos_max by bits;
72
73 if (.f. org, bits, heap(p1+j) ^= 0) card = card+1;
74
75 end do;
76 end do;
77
78 set_nelt(set1, card);
79
80 is_hashok(set1) = no;
81
82 build_spec(difrpm, t_map, set1);
83
84 return;
85
86 end fnct difrpm;
1 .=member difrum
2 fnct difrum(arg1, arg2); $ remote untyped map difference
3
4
5 size difrum(hs); $ specifier returned
6
7 size arg1(hs), $ specifiers for two sets
8 arg2(hs);
9
10 size set1(ps), $ pointers to the sets
11 set2(ps),
12 tup1(ps), $ pointers to their tuples
13 tup2(ps);
14
15 size len1(ps), $ length of the tuples
16 len2(ps),
17 min(ps); $ minimum of len1 and len2
18
19 size card(ps), $ cardinality of result
20 om_val(hs), $ untyoed om
21 j(ps); $ loop index over tuple components
22
23 size a1(hs), $ tuple components
24 a2(hs);
25
26
27 set1 = value_ a1; $ get pointers to sets
28 set2 = value_ a2;
29
30 card = 0; $ cardinality of result
31
32 tup1 = set1 + hl_rmap;
33 tup2 = set2 + hl_rmap;
34
35$ get om image as it appears in tuples.
36 om_val = tcomp(tup1, 0);
37
38 len1 = maxindx(tup1); $ get its lengths.
39 len2 = maxindx(tup2);
40
41 $ make set1 the smaller tuple
42 min = len1; $ length of shorter tuple
43 if (min > len2) min = len2;
44
45 do j = 1 to min;
46
47 a1 = tcomp(tup1, j);
48 a2 = tcomp(tup2, j);
49
50 if a1 = om_val then $ result is null
51 cont;
52
53 elseif a1 = a2 then $ result is null
54 tcomp(tup1, j) = om_val;
55
56 else $ result is a1
57 card = card+1;
58 end if;
59 end do;
60
61$ adjust -card- to show remaining elements of set1
62
63 do j = min+1 to len1;
64
65 if (tcomp(tup1, j) ^= om_val) card = card+1;
66
67 end do;
68
69 set_nelt(set1, card);
70
71 is_hashok(set1) = no;
72
73 build_spec(difrum, t_map, set1);
74
75 return;
76
77 end fnct difrum;
1 .=member setmod
2 fnct setmod(arg1, arg2);
3
4$ this routine performs arg1//arg2 on two sets. its arguments are
5
6 size setmod(hs); $ specifier returned
7
8 size arg1(hs), $ specifiers for two arguments
9 arg2(hs);
10
11 size t1(hs), $ temporaries for result of a-b and b-a.
12 t2(hs);
13
14
15 size set1(ps), $ pointers to the sets
16 set2(ps);
17
18 size card(ps); $ cardinality of result
19
20$ variables used for setmod on local sets
21
22 size ebw1(ps), $ their ebwoeds
23 ebw2(ps),
24 ebb1(ps), $ their ls_bits
25 ebb2(ps),
26 bit1(1), $ current membership bits
27 bit2(1),
28 bit(1), $ exclusive or of bit1 and bit2
29 e(ps); $ pointer to current eb of base
30
31$ variables for remote sets
32
33 size p1(ps), $ pointers to their bit strings
34 p2(ps),
35 len1(ps), $ lengths of their typles
36 len2(ps),
37 min(ps), $ minimum of len1 and len2
38 j(ps), $ loop index over words of bit strings
39 word(hs); $ exor of current words of bit strings
40
41
42 size setdiff(hs), $ functions called
43 copy1(hs),
44 union(hs);
45
46/begin/ $ begin execution
47
48
49
50$ only subsets on the same base are handled in line. all other
51$ types are done by a brute force method using union and set difference.
52
53
54 set1 = value_ arg1; $ get pointers to sets
55 set2 = value_ arg2;
56
57 go to case(htype(set1)) in h_uset to h_lrmap;
58
59/case(h_uset)/ $ all types but subsets branch here
60/case(h_umap)/
61
62/case(h_lmap)/
63
64/case(h_rmap)/
65
66/case(h_lpmap)/
67
68/case(h_limap)/
69
70/case(h_lrmap)/
71
72/case(h_rpmap)/
73
74/case(h_rimap)/
75
76/case(h_rrmap)/
77
78
79 $ since symmetric difference is rather rare, we
80 $ treat a//b as (a-b) + (b-a).
81 t1 = setdiff(copy1(arg1), arg2);
82 t2 = setdiff(copy1(arg2), arg1);
83
84 setmod = union(t1, t2, no);
85
86 return;
87
88
89
90/case(h_lset)/ $ local subset
91
92
93
94 $ iterate over base, setting bits.
95
96 ebw1 = ls_word(set1); $ ls_word_ for arg1
97 ebw2 = ls_word(set2);
98
99 ebb1 = ls_bit(set1);
100 ebb2 = ls_bit(set2);
101
102 card = 0; $ cardinality of result
103
104 next_loop(e, set1); $ iterate over base
105
106 bit1 = .f. ebb1, 1, heap(e+ebw1);
107 bit2 = .f. ebb2, 1, heap(e+ebw2);
108
109 bit = bit1 .ex. bit2;
110
111 card = card+bit;
112 .f. ebb1, 1, heap(e+ebw1) = bit;
113
114 end_next;
115
116 set_nelt(set1, card);
117
118 is_hashok(set1) = no;
119
120 setmod = arg1;
121
122 return;
123
124
125
126/case(h_rset)/ $ remote subset
127
128 $ allocate a null set for result
129
130 $ get pointers to bit strings for arguments
131
132 len1 = rswords(set1);
133 len2 = rswords(set2);
134
135 $ make set1 the longer.
136 min = len1; $ get minimum length
137 if (min > len2) min = len2;
138
139 $ get nullset.
140 card = 0; $ cardinality of result.
141
142 do j = 1 to min;
143
144 word = rsword(set1, j) .ex. rsword(set2, j);
145 card = card + .nb. word;
146 rsword(set1, j) = word;
147
148 end do;
149
150 $ add rest of set1.
151 do j = min+1 to len1;
152
153 word = rsword(set1, j);
154 card = card + .nb. word;
155
156 end do;
157
158 set_nelt(set1, card);
159
160 is_hashok(set1) = no;
161
162 build_spec(setmod, t_set, set1);
163
164 return;
165
166 end fnct setmod;
167
168
169 ..part2
1 .=member with
2 .+part3.
3
4
5 fnct with(arg1, arg2);
6
7$ this is the top level routine for the 'with' operator. it is
8$ called when the type of its arguments are unknown.
9
10$ we assume that arg1 can be destructively used and that arg2 has its
11$ share bit set.
12
13
14 size arg1(hs), $ specifier for set or tuple
15 arg2(hs); $ specifier for element
16
17 size with(hs); $ specifier returned
18
19 size a1(hs), $ copoes of arguments
20 a2(hs);
21
22 size p(ps), $ pointer to tuple
23 indx(hs); $ tupe index as setl short int
24 size i(ps); $ tuple index
25 size fm(ps); $ tuple form
26
27 size withs(hs); $ function called
28 size copy1(hs); $ copy utility
29 size convert(hs); $ convertion utility
30
31
32 a1 = arg1; $ make local copies of arguments
33 a2 = arg2;
34
35 $ branch on type of first argument
36
37/switch/
38
39 go to case(otype_ a1) in t_min to t_max;
40
41
42/case(t_int)/
43
44/case(t_string)/
45
46/case(t_atom)/
47
48/case(t_proc)/
49
50/case(t_lab)/
51
52/case(t_latom)/
53
54/case(t_lint)/
55
56/case(t_istring)/
57
58/case(t_real)/
59
60 call err_type(14);
61
62 with = err_val(f_gen);
63
64 return;
65
66/case(t_elmt)/ $ element
67
68 deref(a1); maycopy(a1);
69
70 go to switch;
71
72/case(t_tuple)/
73
74 if is_om_ a2 then $ return a1
75 with = a1;
76 return;
77 end if;
78
79 p = value_ a1; fm = hform(p); i = nelt(p) + 1;
80
81 if ft_type(fm) = f_mtuple then
82 if i > ft_lim(fm) then
83 call err_misc(56); go to error;
84 end if;
85
86 fm = mttab(ft_elmt(fm)+i);
87 a2 = convert(a2, fm);
88 end if;
89
90 if i > maxindx(p) then
91 call exptup(a1, i); p = value_ a1;
92 end if;
93
94 tcomp(p, i) = a2; nelt(p) = i;
95
96 is_hashok(p) = no;
97
98 with = a1;
99
100 return;
101
102/case(t_stuple)/
103
104 if is_om_ a2 then
105 with = a1;
106 return;
107 end if;
108
109 p = value_ a1;
110
111 if nelt(p) = maxindx(p) then
112 call exptup(a1, nelt(p)+1);
113 p = value_ a1;
114 end if;
115
116 build_spec(indx, t_int, nelt(p)+1);
117
118 call sof(a1, indx, a2);
119
120 with = a1;
121
122 return;
123
124
125
126
127/case(t_set)/
128
129/case(t_map)/
130
131 with = withs(a1, a2, no);
132
133 return;
134
135case_om;
136
137 call err_om(1);
138 go to error;
139
140
141/error/
142
143 if isprim(type_ a1) then
144 with = err_val(f_gen);
145 else
146 with = err_val(hform(value_ a1));
147 end if;
148
149 return;
150
151
152 end fnct with;
1 .=member withs
2 fnct withs(set, elmt, decl);
3
4$ this routine performs the 'with' operation on sets and maps.
5$ we assume that 'set' can be used destructively and that
6$ the 'elmt' has its share bit set.
7
8$ 'decl' indicates that the inputs are declared and that the
9$ result must have the same type as 'set'.
10
11
12 size set(hs), $ actual parameters
13 elmt(hs),
14 decl(1); $ indicates declared inputs
15
16 size withs(hs); $ specifier for result
17
18 size st(hs), $ parameters to recursive part of routine
19 el(hs);
20
21 size added(1); $ auxialliary output. indicates if element was adde
22
23 size tstart(ps); $ pointer to recursion stack at start of routin
24
25 size hd(hs), $ first component of pair being inserted into map
26 tl(hs); $ second component of pair
27
smfc 28 size im(hs); $ current image of -hd- in map
smfc 29 size temp(hs); $ new image being set up
smfc 30 size ptr(ps); $ pointer to new image
smfc 31 size pos(ps); $ junk pointer for insert
29
30 size s(ps), $ pointer to set
31 p(ps); $ pointer to eb
32
smfc 32 size copy1(hs); $ copy utility
smfc 33 size convert(hs); $ conversion utility
smfc 34 size equal(1); $ equality utility
smfc 35 size fval(hs); $ retrieves map image
smfc 36 size nullset(hs); $ allocates nullset
38
39$ stacked variables
40
41 .=zzyorg b $ reset counters for stack offsets
42
43 local(retpt); $ return pointer
44
45 local(s1); $ copy of s
46 local(p1); $ copy of p
47 local(pair); $ pointer to pair being inserted into map
48
49
50
51
52/begin/ $ begin execution
53
54 if is_om_ elmt then
55 call err_om(2);
56 withs = set;
57 return;
58 end if;
59
60 if is_om_ set then
61 call err_om(01); withs = err_val(hform(value_ set));
62 return;
63 end if;
64
65
66 tstart = t; $ save initial stack pointer
67
68 .=zzyorg a $ reset counter for return labels
69
70 st = set; $ make local copies of arguments
71 el = elmt;
72
73
74
75/entry/ $ recursive entry point
76
77
78 r_entry; $ increment recursion stack
79
80 s = value_ st; $ get pointer to set header
81
82
83 if (^ is_map(s)) go to case_set; $ catch set case.
84
85
86/case_map/ $ maps
87
88$ begin by checking whether el is a pair. if not, then st and el
89$ must both be undeclared. in this case we convert st to a standard
90$ set.
91
92 if (otype_ el ^= t_tuple) go to conv;
93 if (nelt(value_ el) ^= 2) go to conv;
94 if (is_om_ tcomp(value_ el, 1)) go to conv;
95
96$ otherwise el is a pair, and we procedd to insert it into the
97$ map. this is done in four steps:
98
99$ 1. split el into a pair .
100
101$ 2. locate -hd- in its domain and set -im- to its image.
102
103$ 3. merge -tl- and -im-. set -added- to indicate whether -tl-
104$ was added to the image.
105
106$ 4. if -added- is set, store the new image and adjust the nelt
107$ and hash.
108
109 pair = value_ el; $ get pointer to pair
110
111 hd = tcomp(pair, 1);
112 tl = tcomp(pair, 2);
113
114
115 call locate(p, hd, s, yes); $ locate and insert head
116
117$ see if we are adding to hd-s image.
118
119 im = fval(s, p, no);
120
121 if is_multi_ im then $ multivalued. do -with- recursively
122 s1 = s; $ save across recursion
123 p1 = p;
124
125 st = im;
126 maycopy(st);
127
128 el = tl;
129 is_shared_ el = yes;
130
131 r_call;
132
133 im = withs; $ set up new image value
134 is_multi_ im = yes;
135
136 s = s1; $ restore sized variables
137 p = p1;
138
139 added = yes;
140
141 elseif is_om_ im then $ new image is tl
142 im = tl;
143 added = yes;
144
145 elseif eq(im, tl) then $ no change to image
146 added = no;
147
148 elseif ne(im, tl) then $ use << im, tl >>
149 if (is_smap(s)) go to smap; $ smap becoming multivalued
150
smfc 37 temp = nullset(ft_imset(hform(s)), 2); ptr = value_ temp;
smfc 38 call insert(pos, im, ptr); call insert(pos, tl, ptr);
smfc 39 value_ temp = ptr; is_multi_ temp = yes; im = temp;
153
154 added = yes;
155
156 elseif equal(im, tl) then $ no change
157 added = no;
158
159 else $ unequal. use << im, tl >>
160 if (is_smap(s)) go to smap; $ smap becoming multivalued
161
smfc 40 temp = nullset(ft_imset(hform(s)), 2); ptr = value_ temp;
smfc 41 call insert(pos, im, ptr); call insert(pos, tl, ptr);
smfc 42 value_ temp = ptr; is_multi_ temp = yes; im = temp;
164
165 added = yes;
166 end if;
167
168
smfc 43$ store the new image if necessary. note that adding a new image to a
smfc 44$ remote map may mean moving the set header and thus modifying s.
smfc 45
172 if added then
173 call sfval(s, p, im);
174 is_shared_ tcomp(pair, 2) = yes;
175
176 up_nelt(s, 1);
177 is_hashok(s) = no;
178 end if;
179
180 build_spec(withs, t_map, s);
181
182 go to exit;
183
184/smap/ $ smap becoming multivalued.
185
186 if decl then
187 call err_misc(26);
188 go to error_exit;
189 end if;
190
191 build_spec(st, t_map, s); $ convert st to standard map
192 st = convert(st, f_umap);
193 s = value_ st;
194
195 go to case_map;
196
197
198
199/conv/ $ convert set to map
200
201 if decl then
202 call err_misc(27);
203 go to error_exit;
204 end if;
205
206 call convset(st);
207 s = value_ st;
208
209/case_set/ $ set cases
210
211$ for sets we do a locate, adding the element if necessary.
212$ if -set- is based, we set the proper membership bit
213
214 call locate(p, el, s, yes);
215 added = (^ loc_found); $ flag added element
216
217 if (is_based(s)) call sfval(s, p, yes); $ set subset bit
218
219
220 if added then $ adjust nelt and hash
221 up_nelt(s, 1);
222 up_hash(s, loc_hash);
223 end if;
224
225 build_spec(withs, t_set, s); $ build specifier for result
226
227
228/exit/ $ recursive exit point
229
230 r_exit; $ pop recursion stack
231
232 if t ^= tstart then $ recursive return
233 go to rlab(retpt) in 1 to zzya;
234 else $ actual return
235 return;
236 end if;
237
238
239/error_exit/
240
241 withs = err_val(hform(value_ set));
242
243 t = tstart;
244 return;
245
246
247$ drop local variables
248
249 macdrop2(retpt, s1)
250 macdrop2(pair, p1)
251
252 end fnct withs;
1 .=member withm
2 fnct withm(set, n, decls);
3
4$ this is a special version of with used to insert pairs into maps.
5$ it is particularly useful when we desire to build a map as a set
6$ of pairs, i.e.
7
8$ f = << in f1 st c(x, y) >>;
9
10$ the user should not be discouraged from building maps in this way
11$ on the basis that it means building alot of pairs which are
12$ immediately thrown away. instead we use a special map former which
13$ builds a map by calling withm.
14
15$ withm is called to perform
16
17$ f = f with. >>
18
19$ where f has been declared an n variate map or smap.
20$ rather than passing withm a specifier for the nested object on the
21$ right hand side, we pass it x1 ... xn+1 directly. these are passed
22$ through the stack. xi is located at heap(t-1+i). as usual, withm
23$ uses these locations, but assumes that its caller pops the stack.
24$ pops the stack when its done.
25
26$ withm can force an smap to become multi valued. if this happens
27$ we either convert the smap to a general map or abort, depending
28$ on whether the map was declared singlevalued. this is given by
29$ the parameter 'decls'.
30
31$ there are two possibilities: either the map is declared an
32$ smap(decls = yes), in which case we abort, or it is declared
33$ general(decls = no), in which case we convert it to a standard
34$ map and try again.
35
36
37 size withm(hs); $ specifier returned
38
39 .-dead.
40 call err_fatal(57);
41 .+dead.
42
43 size set(hs), $ specifier for top level map
44 n(ps), $ number of arguments to mapping
45 decls(1); $ flags declared smap
46
47 size st(hs), $ parameters to recursive part of routine
48 argno(ps), $ current argument no
49 arg(hs); $ argument to mapping
50
51 size added(1); $ auxialliary output. indicates if element was adde
52
53 size tstart(ps); $ pointer to recursion stack at start of routin
54
55 size tl(hs), $ tail of innermost 'pair'
56 im(hs); $ current image of -arg- in map
57
58 size s(ps), $ pointer to set
59 p(ps); $ pointer to eb
60
61
62 size fval(hs), $ functions called
63 copy1(hs),
64 equal(1),
65 rset2(hs);
66
67$ stacked variables
68
69 .=zzyorg b $ reset counters for stack offsets
70
71 local(retpt); $ return pointer
72
73 local(s1); $ copy of s
74 local(p1); $ copy of p
75
76
77
78
79/begin/ $ begin execution
80
81 if ^ isset(otype_ s) then
82 call err_type(15);
83 withm = err_val(f_gen);
84 return;
85 end if;
86
87 tstart = t; $ save initial stack pointer
88
89 .=zzyorg a $ reset counter for return labels
90
91
92 st = set; $ make local copy oset f
93 argno = 0; $ initialize argno
94
95
96
97/entry/ $ recursive entry point
98
99
100 r_entry; $ increment recursion stack
101
102 s = value_ st; $ get pointer to set header
103
104 argno = argno+1; $ get next argument to mapping
105 arg = heap(tstart + argno - 1);
106
107
108 if (^ is_map(s)) go to case_set; $ catch set case.
109
110
111/case_map/ $ maps
112
113$ begin by locating arg in the domain and saving it through recursion
114 call locate(p, s, arg, yes);
115
116 if is_multi_ im then $ multivalued. do -with- recursively
117 s1 = s; $ save across recursion
118 p1 = p;
119
120 st = im;
121 maycopy(st);
122
123 r_call;
124
125 im = withm; $ set up new image value
126 is_multi_ im = yes;
127
128 s = s1; $ restore
129 p = p1;
130
131 added = yes;
132 else $ merge tail of innermost 'pair' with im
133 tl = heap(tstart-1 + (argno+1));
134
135 if is_om_ im then $ new image is tl
136 im = tl;
137 added = yes;
138
139 elseif eq(im, tl) then $ no change to image
140 added = no;
141
142 elseif ne(im, tl) then $ use << im, tl >>
143 if (is_smap(s)) go to smap; $ smap becoming multivalued
144
145 im = rset2(im, tl);
146 is_multi_ im = yes;
147
148 added = yes;
149
150 elseif equal(im, tl) then $ no change
151 added = no;
152
153 else $ unequal. use << im, tl >>
154 if (is_smap(s)) go to smap; $ smap becoming multivalued
155
156 im = rset2(im, tl);
157 is_multi_ im = yes;
158
159 added = yes;
160 end if;
161
162 end if;
163
164
165$ store the new image if necessary. note that adding a new image
166$ to a remote map may mean moving the set header and thus modifying
167$ s.
168 if added then
169 call sfval(s, p, im);
170
171 up_nelt(s, 1);
172 is_hashok(s) = no;
173 end if;
174
175 build_spec(withm, t_map, s);
176
177 go to exit;
178
179
180
181/smap/ $ smap becoming multivalued.
182
183 if (decls) go to error_exit;
184
185$ convert s to a standard map. note that this is a 1 level conversion.
186 build_spec(st, t_map, s);
187 call convset(st);
188
189 go to case_map;
190
191
192/case_set/ $ set cases
193
194$ set cases occur at the bottom level of a multivalued map.
195
196$ for sets we do a locate, adding the element if necessary.
197$ if -set- is based, we set the proper membership bit
198
199 call locate(p, arg, s, yes);
200 added = (^ loc_found); $ flag added element
201
202 if (is_based(s)) call sfval(s, p, yes); $ set subset bit
203
204
205 if added then $ adjust nelt and hash
206 up_nelt(s, 1);
207 up_hash(s, loc_hash);
208 end if;
209
210 build_spec(withm, t_set, s); $ build specifier for result
211
212
213/exit/ $ recursive exit point
214
215 r_exit; $ pop recursion stack
216
217 if t ^= tstart then $ recursive return
218 go to rlab(retpt) in 1 to zzya;
219 else $ actual return
220 free_stack(n+1);
221 return;
222 end if;
223
224
225/error_exit/ $ error exit
226
227 call err_misc(28);
228
229 withm = err_val(f_gen);
230
231 t = tstart;
232 return;
233
234
235$ drop local variables
236
237 macdrop (retpt)
238 macdrop2(s1, p1)
239
240 ..dead
241
242
243 end fnct withm;
1 .=member less
2 fnct less(set, elmt);
3
4$ this routine performs the -less- function. set and elmt are specifiers
5$ for the two inputs, and a specifier for the result is returned.
6
7$ the logic of -less- is very close to the logic of -with-.
8
9$ less destroys its first argument. we assume that by the time we
10$ reach the recursive entry point the set -st- can be modified.
11
12
13 size less(hs); $ specifier returned
14
15 size set(hs), $ specifiers for arguments to routine
16 elmt(hs);
17
18 size st(hs), $ arguments to recursive parts of routine
19 el(hs);
20
21 size found(1); $ auxilliary output. on if element found
22
23 size hd(hs), $ specifiers for components of pair
24 tl(hs);
25
26 size im(hs); $ current image of -hd-
27
28 size tstart(ps); $ initial recursion stack pointer
29
30 size pos(ps); $ value return parameter for locate
31
32
33 size fval(hs), $ functions called
34 copy1(hs),
35 arbs(hs),
36 equal(1);
37
38
39$ stacked variables
40
41 .=zzyorg b $ reset counters for stack offsets
42
43 local(retpt); $ return pointer
44
45 local(s); $ pointer to set
46 local(p); $ pointer returned by locate
47 local(prev); $ saved value of loc_prev
48 local(n); $ nelt of map image
49
50
51
52
53/begin/ $ begin execution
54
55 tstart = t; $ save initial stack pointer
56
57 .=zzyorg a $ reset counter for return labels
58
59
60 if is_om_ elmt then $ return original set
61 less = set;
62 return;
63 end if;
64
65 st = set; $ make local copies of arguments.
66 el = elmt;
67
68 if otype_ st = t_elmt then
smfb 90 deref(st); st = copy1(st);
70 end if;
71
72 if ^ isset(otype_ st) then
73 call err_type(16);
74 less = err_val(f_gen);
75 return;
76 end if;
77
78
79
80
81/entry/ $ recursive point
82
83
84 r_entry; $ increment recursion stack
85
86 s = value_ st; $ get pointer to set header.
87
88 go to case(htype(s)) in h_uset to h_lrmap;
89
90
91
92/case(h_uset)/ $ standard set
93
94 call locate(pos, el, s, no); $ try to locate el in s.
95 found = loc_found; $ delete element if found
96
97 if found then $ delete element
98 call delete(s, loc_prev, pos, yes);
99 down_nelt(s, 1);
100 down_hash(s, loc_hash);
101 end if;
102
103 build_spec(less, t_set, s);
104
105 go to exit;
106
107
108/case(h_lset)/ $ based sets
109
110/case(h_rset)/
111
112 call locate(pos, el, s, no); $ try to locate in base
113 found = fval(s, pos, no); $ delete if currently in set
114
115
116 if found then
117 call sfval(s, pos, no); $ turn off membership bit
smfb 91 down_nelt(s, 1);
smfb 92 down_hash(s, loc_hash);
120 end if;
121
122 build_spec(less, t_set, s);
123
124 go to exit;
125
126
127/case(h_umap)/ $ maps
128
129/case(h_lmap)/
130
131/case(h_rmap)/
132
133/case(h_lpmap)/
134
135/case(h_limap)/
136
137/case(h_lrmap)/
138
139/case(h_rpmap)/
140
141/case(h_rimap)/
142
143/case(h_rrmap)/
144
145
146$ the code here uses the same four steps described in the with routine
147
148 if (otype_ el ^= t_tuple) !
149 (nelt(value_ el) ^= 2) !
150 (is_om_ tcomp(value_ el, 1)) then
151 less = st;
152 go to exit;
153 end if;
154
155$ begin by splitting the pair into its head and tail, then locate
156$ the head in the domain of the map and get its image.
157
158 hd = tcomp(value_ el, 1);
159 tl = tcomp(value_ el, 2);
160
161$ locate head and save pointer through recursion.
162 call locate(pos, hd, s, no);
163 p = pos;
164 prev = loc_prev;
165
166$ set -im- to hd-s new image. at the same time set -n- to
167$ its nelt, and set -drop- if something is being removed from the map.
168
169 im = fval(s, pos, no); $ get old image.
170
171 if is_multi_ im then $ perform -less- recursively.
smfb 93 st = im; maycopy(st);
174 el = tl;
175
176 r_call;
177
178 im = less; $ process result
179 is_multi_ im = yes;
180
181 ok_nelt(im); $ get nelt and drop singletons if necessary
182 n = nelt(value_ im);
183
184 if n = 0 then $ replace with template
185 im = om_image(s);
smfb 94 if is_mmap(s) then
smfb 95 is_om_ im = no; is_multi_ im = yes;
smfb 96 end if;
smfb 97
186 elseif n = 1 & ^ is_mmap(s) then
187 im = arbs(im);
188 end if;
189
192 found = yes;
193
194 elseif eq(tl, im) then $ new image is om
195 im = om_image(s);
196 n = 0;
197 found = yes;
198
199 elseif ne(tl, im) then
200 found = no;
201
202 elseif equal(tl, im) then $ image is om
203 im = om_image(s);
204 n = 0;
205 found = yes;
206
207 else
208 found = no;
209 end if;
210
211
212 if found then $ modify map
213 if n = 0 & ^ is_based(s) then $ delete eb
214 call delete(s, prev, p, yes);
215 else $ store new image
216 call sfval(s, p, im);
217 end if;
218
219 is_hashok(s) = no;
220 down_nelt(s, 1);
221 end if;
222
223 build_spec(less, t_map, s);
224
225
226
227
228
229/exit/ $ recursive exit
230
231 r_exit; $ pop recusion stack
232
233 if t ^= tstart then $ local return
234 go to rlab(retpt) in 1 to zzya;
235 else $ actual return
236 return;
237 end if;
238
239
240
241$ drop local variables
242
243 macdrop2(s, p)
244 macdrop2(prev, n)
245 macdrop(retpt)
246
247 end fnct less;
1 .=member from
2 subr from(x, s);
3
4$ this routine performs 'x from s' when the type
5$ of its argument is not known.
6
7$ we copy the set or tuple if it is shared.
8
9
10 size x(hs); $ specifier for element extracted
11 size s(hs); $ specifier for set_mode
12
13 size fm(ps); $ form of s
14
15
16 deref(s);
17
18 if ^ isset(otype_ s) then
19 if is_om_ s then
20 call err_om(3);
21 else
22 call err_type(17);
23 end if;
24
25 if isprim(type_ s) then
26 x = err_val(f_gen);
27 s = err_val(f_gen);
28 else
29 fm = hform(value_ s);
30
31 if ft_type(fm) = f_mtuple then
32 x = err_val(f_gen);
33 else
34 x = err_val(ft_elmt(fm));
35 end if;
36
37 s = err_val(fm);
38 end if;
39
40 else
41 call froms(x, s);
42 end if;
43
44
45 end subr from;
1 .=member froms
2 subr froms(elmt, set);
3
4$ this routine performs the 'from' primitive on sets and maps.
5$ it is written in a style which is a cross between the 'arbs'
6$ and 'less' routines.
7
8$ 'froms' is naturally recursive in order to handle multi valued
9$ maps. the intuitive algorithm for treating maps is s follows:
10
11$ 1. iterate over the domain of the map, finding the first
12$ domain element 'x' for which the map is defined.
13
14$ 2. perform 'from' on f<> recursively, yielding some value
15$ 't'.
16
17$ 3. return the pair [x, t].
18
19$ this algorithm would remove an element from the bottom level
20$ map then make a recursive return and allocate a pair for the
21$ result of the top level map.
22
23$ the above algorithm is quite natural, but would throw off
24$ the garbage collector if we ran out of space between the
25$ time we modified the lower level map and the time we allocated
26$ the new pair. instead we must use a somewhat less intuitive
27$ algorithm which allocates the new pair at the end of step 1.
28
29$ at each level we must copy the set if it is shared.
30
31
32$ variable declarations
33
34 size elmt(hs), $ specifier for element returned
35 set(hs); $ specifier for set
36
37 size tstart(ps); $ recursion stack pointer at start of routine
38
39 size hd(hs), $ head of pair
40 tl(hs); $ tail of pair
41
42 size p(ps), $ pointer to pair
43 n(ps); $ 'nelt' of image.
44
45 size bit(ps), $ ls_bit of set
46 word(ps), $ ls_word
47 indx(ps); $ ebindx
48
49
50
51 size nullp(1), $ functions called
52 copy1(hs),
53 arbs(hs),
54 fval(hs);
55
56$ stacked variables
57
58 .=zzyorg b $ reset counters for stack offsets
59
60 local(retpt); $ return pointer
61
62 local(s); $ pointer to set
63
64 local(e); $ pointer to eb
65 local(prev); $ pointer to previous eb
66
67 local(pair); $ specifier for pair returned
68 local(im); $ image of head in map
69
70
71/begin/ $ begin execution
72
73 tstart = t; $ save initial recursion stack pointer
74
75 .=zzyorg a $ reset counter for return labels
76
77
78/entry/ $ recursive entry point
79
80 r_entry; $ increment recursion stack
81
82 maycopy(set);
83 s = value_ set;
84
85 if (^ is_map(s)) go to case_set; $ branch for sets
86
87
88/case_map/ $ map cases
89
90
91
92$ find domain element
93
94$ iterate over s till we find an element -e- whose image is defined.
95$ set -im- to its image.
96
97 prev = 0; $ initialize pointer to previous eb
98
99 next_loop(e, s);
100 im = fval(s, e, yes);
101
102 if is_mmap(s) then $ look for non-null image
103 p = value_ im; $ get pointer to range set
104
105 if is_neltok(p) then $ quit if range set is non-null.
106 if (nelt(p) ^= 0) quit;
107 else
108 if (^ nullp(p)) quit;
109 end if;
110 else $ look for defined image
111 if (^ is_om_ im) quit;
112 end if;
113
114 prev = e; $ save pointer to last eb
115
116 end_next;
117
118
119$ allocate a pair and store the domain element
120
121 get_pair(p);
122 build_spec(pair, t_tuple, p);
123
124 hform(p) = ft_elmt(hform(s)); $ put in full repr information
125
126 if is_based(s) then $ return pointer to base
127 build_spec(hd, t_elmt, e);
128 else $ return domain specifier
129 is_shared_ ebspec(e) = yes;
130 hd = ebspec(e);
131 end if;
132
133 tcomp(value_ pair, 1) = hd;
134 if (is_ebtemp(e)) is_om_ pair = yes; $ indicate end of set
135
136
137
138$ remove - tl from. im -
139
140$ set -tl- to an element of -im-, -im- to the reduced image, and
141$ -n- to its nelt.
142
143
144 if is_multi_ im then $ do -from- on image
145 set = im;
146
147 r_call;
148
149 tl = elmt;
150 im = set;
151 is_multi_ im = yes;
152
153 ok_nelt(im); $ get nelt of image.
154 n = nelt(value_ im);
155
156 if n = 0 then $ null result
157 im = om_image(s);
smfb 98 if is_mmap(s) then
smfb 99 is_om_ im = no; is_multi_ im = yes;
smfb 100 end if;
158 elseif n = 1 & ^ is_mmap(s) then $ remove singleton
159 im = arbs(im);
160 end if;
161
162 else $ image single valued
163 tl = im;
164 im = om_image(s);
165 n = 0;
166 end if;
167
168$ delete pair from map
169
170 if n = 0 & ^ is_based(s) then $ delete eb
171 call delete(s, prev, e, yes);
172 else $ store im
173 call sfval(s, e, im);
174 end if;
175
176 down_nelt(s, 1);
177 is_hashok(s) = no;
178
179
180
181$ store tl in pair and return
182
183 tcomp(value_ pair, 2) = tl;
184
185 elmt = pair;
186 build_spec(set, t_map, s);
187
188 go to exit;
189
190
191
192
193/case_set/ $ set cases
194
195 go to sc(htype(s)) in h_uset to h_rset; $ jump on type
196
197
198/sc(h_uset)/ $ unbased set
199
200$ look for the first element which is not a dummy hash header. we
201$ do this with a next_loop which quits the first time we enter
202$ the body of the loop.
203
204 next_loop(e, s);
205
206 quit;
207
208 end_next;
209
210 elmt = ebspec(e);
211
212 call delete(s, 0, e, yes);
213
214 down_nelt(s, 1); $ adjust nelt and hash
215 is_hashok(s) = no;
216
217 build_spec(set, t_set, s);
218
219 go to exit;
220
221
222
223/sc(h_lset)/ $ based sets
224
225/sc(h_rset)/
226
227 next_loop(e, s);
228
229 if (fval(s, e, no)) quit;
230
231 end_next;
232
233 call sfval(s, e, no); $ delete from set
234
235$ build specifier then adjust nelt and hash.
236
237 down_nelt(s, 1);
238 hash(s) = hash(s) - ebhash(e);
239
240 build_spec(elmt, t_elmt, e); $ value is element of base
241 if (is_ebtemp(e)) is_om_ elmt = yes;
242
243 build_spec(set, t_set, s);
244
245 go to exit;
246
247
248
249/exit/ $ recursive exit
250
251 r_exit; $ pop recursion stack
252
253 if t ^= tstart then $ recursive return
254 go to rlab(retpt) in 1 to zzya;
255
256 else
257 return;
258 end if;
259
260
261
262$ drop local variables
263
264 macdrop8(retpt, s, e, prev, hd, tl, im, ended)
265 macdrop(pair)
266
267 end subr froms;
1 .=member fromb
2 subr fromb(elmt, tuple);
3
4$ this routine computes 'elmt fromb tuple'.
5$
6$ we treat it as '[elmt, tuple] := [tuple(1), tuple(2..)]'.
7
8
9 size elmt(hs); $ specifier for left operand
10 size tuple(hs); $ specifier for right operand
11
12 size p(ps); $ pointer to tuple
13 size val(hs); $ untyped value
14 size card(ps); $ its cardinality
15 size indx(ps); $ loop index
16
17 size copy1(hs); $ function called
18
19
20 deref(tuple);
21
22 if ^ istuple(otype_ tuple) then
23 if is_om_ tuple then
24 call err_om(28);
25 else
26 call err_type(62);
27 end if;
28
29 elmt = err_val(f_gen);
30 tuple = err_val(f_gen);
31
32 return;
33 end if;
34
35 maycopy(tuple);
36
37 p = value_ tuple;
38 card = nelt(p);
39
40 if (htype(p) = h_ptuple) go to packed;
41
42
43 if card > 0 then
44 elmt = tcomp(p, 1);
45 nelt(p) = card - 1;
46 is_hashok(p) = no;
47
48 do indx = 2 to card;
49 tcomp(p, indx-1) = tcomp(p, indx);
50 end do;
51
52 tcomp(p, card) = tcomp(p, 0);
53
54 else
55 elmt = tcomp(p, 0);
56 end if;
57
58 return;
59
60
61/packed/
62
63 if card > 0 then
64 val = pcomp(p, 1);
65 nelt(p) = card - 1;
66 is_hashok(p) = no;
67
68 do indx = 2 to card;
69 pcomp(p, indx-1) = pcomp(p, indx);
70 end do;
71
72 pcomp(p, card) = 0;
73
74 else
75 val = 0;
76 end if;
77
78 unpack(ptkey(p), val, elmt);
79
80 return;
81
82
83 end subr fromb;
1 .=member frome
2 subr frome(elmt, tuple);
3
4$ this routine computes 'elmt frome tuple'.
5$
6$ we treat it as '[elmt, tuple] := [tuple(#tuple), tuple(1..#tuple-1)]'.
7$
8$ n.b. if t = [1, om, om, 4], then the result of 'x frome t' is
9$ x = 4, t = [1], since we don't save omegas at the end of
10$ the tuple.
11
12
13 size elmt(hs); $ specifier for left operand
14 size tuple(hs); $ specifier for right operand
15
16 size p(ps); $ pointer to tuple
17 size fm(ps); $ tuple form
18 size om_val(hs); $ proper omega for tuple component
19 size val(hs); $ untyped value
20 size card(ps); $ its cardinality
21
22 size copy1(hs); $ function called
23
24
25 deref(tuple);
26
27 if ^ istuple(otype_ tuple) then
28 if is_om_ tuple then
29 call err_om(29);
30 else
31 call err_type(63);
32 end if;
33
34 elmt = err_val(f_gen);
35 tuple = err_val(f_gen);
36
37 return;
38 end if;
39
40 maycopy(tuple);
41
42 p = value_ tuple;
43 card = nelt(p);
44
45 if (htype(p) = h_ptuple) go to packed;
46
47
48 om_val = tcomp(p, 0);
49
50 if card > 0 then
51 elmt = tcomp(p, card);
52 is_hashok(p) = no;
53
54 fm = hform(p);
55
56 if ft_type(fm) = f_mtuple then
smfb 101 om_val = heap(ft_samp(mttab(ft_elmt(fm)+card)));
smfb 102 end if;
smfb 103
smfb 104 tcomp(p, card) = om_val;
smfb 105
smfb 106 if otype_ tuple = t_tuple then
smfb 107 until card = 0;
smfb 108 card = card - 1;
smfb 109 if ( ^ is_om_ tcomp(p, card)) quit until;
smfb 110 end until;
smfb 111 else
smfb 112 until card = 0;
smfb 113 card = card - 1;
smfb 114 if (tcomp(p, card) ^= om_val) quit until;
smfb 115 end until;
smfb 116 end if;
smfb 117
smfb 118 nelt(p) = card;
63
64 else
65 elmt = om_val;
66 end if;
67
68 return;
69
70
71/packed/
72
73 if card > 0 then
74 val = pcomp(p, card);
75 pcomp(p, card) = 0;
76 is_hashok(p) = no;
77
78 until card = 0;
79 card = card - 1;
80 if (pcomp(p, card) ^= 0) quit until;
81 end until;
82
83 nelt(p) = card;
84
85 else
86 val = 0;
87 end if;
88
89 unpack(ptkey(p), val, elmt);
90
91 return;
92
93
94 end subr frome;
1 .=member lessf
2 fnct lessf(st, el);
3
4$ this routine performs the -lessf- function. set and elmt are specifier
5$ for the two inputs, and a specifier for the result is returned.
6
7
8 size lessf(hs); $ specifier returned
9
10 size st(hs), $ specifier for set
11 el(hs); $ specifier for domain element
12
13 size s(ps), $ pointer to set
14 pos(ps), $ pointer returned by locate
15 im(hs); $ image of el
16
17 size fval(hs), $ functions called
18 convsm(hs);
19 size copy1(hs); $ copy utility
20
21
22 lessf = st;
23
24 if otype_ lessf = t_elmt then
smfb 119 deref(lessf); lessf = copy1(lessf);
26 end if;
27
28 if (otype_ lessf = t_set) lessf = convsm(lessf, f_umap);
29
30 if otype_ lessf ^= t_map then
31 if is_om_ lessf then
32 call err_om(05);
33 else
34 call err_type(18);
35 end if;
36
37 lessf = err_val(f_gen);
38 return;
39 end if;
40
41 s = value_ lessf;
42
43 call locate(pos, el, s, no); $ do locate
44 if (^ loc_found) go to exit;
45
46 if is_based(s) then
47 im = om_image(s);
48
49 if is_mmap(s) then
50 is_om_ im = no; is_multi_ im = yes;
51 end if;
52
53 call sfval(s, pos, im);
54 else
55 call delete(s, loc_prev, pos, yes);
56 end if;
57
58
59/exit/
60
61 is_hashok(s) = no;
62 is_neltok(s) = no;
63
64
65 end fnct lessf;
1 .=member member
2 fnct member(arg1, arg2);
3
4$ this routine tests arg1 for membership in arg2. arg2 may be a
5$ set, tuple, character string or bit string.
6
7$ set membership is handled through a lower level routine -memset-.
8$ membership testing on all other types is very rare and is done
smfb 120$ through a very simple algorithm: we iterate from 1 to # arg2
10$ applying -of- and testing for equality with arg1. the f(x)
11$ operation is done by actually calling -of-. as a result the
12$ loop index must be a setl integer.
13
14$ the routine begins with a branch on type. for most types, we merely
smfb 121$ calculate # arg2 as a setl short integer and branch to the standard
16$ loop.
17
18
19 size member(1); $ boolean value returned
20
21 size arg1(hs); $ specifier for left operand
22 size arg2(hs); $ specifier for right operand
23
24 size a1(hs); $ local copies of operands
25 size a2(hs); $ ...
26 size ss1(ssz); $ string specifiers for operands
27 size ss2(ssz); $ ...
28 size len1(ps); $ length of first operand
29 size len2(ps); $ length of second operand
30 size j1(ps); $ indices
31 size j2(ps); $ ...
32 size indx(hs); $ specifier for loop index
33 size lim(hs); $ specifier for loop limit
34 size elmt(hs); $ specifier returned by -of- routine
35
36 size equal(1); $ equality routine
37 size memset(1); $ set membership routine
38
39
40 a1 = arg1; $ copy arguments
41 a2 = arg2;
42
43/switch/
44
45 go to case(otype_ a2) in t_min to t_max; $ branch on type_
46
47/case(t_int)/ $ short int
48
49 go to error;
50
51/case(t_string)/ $ short characters
52
smfb 122 build_spec(lim, t_int, sc_nchars_ a2); $ get # a2, then
54 go to loop;
55
56
57
58/case(t_atom)/ $ atom
59
60/case(t_proc)/
61
62/case(t_lab)/
63
64 go to error;
65
66/case(t_elmt)/ $ base element
67
68 deref(a2);
69 go to switch;
70
71
72/case(t_latom)/ $ long atom
73
74/case(t_lint)/ $ long int
75
76/case(t_real)/ $ real
77
78 go to error;
79
80
81
82/case(t_istring)/ $ long character string
83
84 +* before(i) = heap(t-1+i) **
stra 226
stra 227 ss2 = value_ a2; len2 = ss_len(ss2);
stra 228
stra 229 if otype_ a1 = t_string then
stra 230 build_spec(lim, t_int, len2);
stra 231 go to loop;
stra 232 end if;
smfb 123
smfb 124 if (otype_ a1 ^= t_istring) go to fail;
85
86 ss1 = value_ a1; len1 = ss_len(ss1);
88
89 if (len1 > len2) go to fail;
90$
91$ build the 'before' map for a1
92$
93 get_stack(len1); $ get space for the 'before' map
94 j1 = 0;
95 do j2 = 1 to len1;
96 while j1 > 0 & icchar(ss1, j1) ^= icchar(ss1, j2);
97 j1 = before(j1);
98 end while;
99 before(j2) = j1; j1 = j1 + 1;
100 end do;
101$
smfb 125$ then do comparison
103$
104 member = no; $ assume no match
105 j1 = 0;
106 do j2 = 1 to len2;
107 while j1 > 0 & icchar(ss1, j1+1) ^= icchar(ss2, j2);
108 j1 = before(j1);
109 end while;
110 if (icchar(ss1, j1+1) = icchar(ss2, j2)) j1 = j1 + 1;
111 if j1 >= len1 then member = yes; quit do j2; end if;
112 end do;
113 free_stack(len1); $ release storage for the 'before' map
smfb 126
114 macdrop(before);
115
116 return;
117
118
119/case(t_tuple)/ $ tuples
120
121/case(t_stuple)/
122
123$ the nelt of tuples is always valid. this is quite handy here.
124
125 build_spec(lim, t_int, nelt(value_ a2));
126 go to loop;
127
128
129
130/case(t_set)/ $ sets and maps
131
132/case(t_map)/
133
134 member = memset(a1, a2);
135 return;
136
137
138
139
140case_om; $ om types
141
142 call err_om(4);
143
144 member = no;
145
146 return;
147
148/error/ $ illegal type for a2
149
150 call err_type(19);
151
152 member = no;
153
154 return;
155
156
157/loop/ $ loop through a2 checking for agr1
158
159 indx = one; $ set index to setl one.
160
161 while le(indx, lim);
162
163 call of(elmt, a2, indx); $ get element of a2
164
165 if (eq(a1, elmt)) go to pass;
166 if ^ ne(a1, elmt) then
167 if (equal(a1, elmt)) go to pass;
168 end if;
169
170 add1(indx);
171
172 end while;
173
174/fail/
175
176 member = no; $ not found
177 return;
178
179
180
181/pass/ $ found
182
183 member = yes;
184 return;
185
186 end fnct member;
1 .=member memset
2 fnct memset(elmt, set);
3
4$ this function tests set membership. like all
5$ predicates in the library, it returns 1 or 0, rather than setl
6$ true or false.
7
8$ the routine is iterative rather than recursive.
9
10
11 size memset(1); $ boolean value returned
12
13 size elmt(hs), $ specifiers for arguments
14 set(hs);
15
16 size st(hs), $ local copies of arguments
17 el(hs);
18
19 size s(ps), $ pointer to set
20 pos(ps); $ pointer returned by locate
21
22 size hd(hs), $ components of pair
23 tl(hs),
24 im(hs); $ current image of hd.
25
26
27 size equal(1), $ functions called
28 fval(hs);
29
30
31 st = set; $ make local copies of arguments
32 el = elmt;
33
34
35/entry/ $ main entry point
36
37
38 s = value_ st; $ get pointer to set
39
40 go to case(htype(s)) in h_uset to h_lrmap;
41
42/case(h_uset)/ $ standard set
43
44 call locate(pos, el, s, no);
45 if (^ loc_found) go to nfound;
46
47 go to found;
48
49
50/case(h_umap)/ $ unbased map
51
52/case(h_lmap)/ $ local map
53
54/case(h_rmap)/ $ remote map
55
56/case(h_lpmap)/ $ local packed map
57
58/case(h_limap)/ $ local integer map
59
60/case(h_lrmap)/ $ local real map
61
62/case(h_rpmap)/ $ remote packed map
63
64/case(h_rimap)/ $ remote real map
65
66/case(h_rrmap)/ $ remote real map
67
68$ if el is a pair, split it into hd and tl. otherwise
69$ it cant be an element of a map.
70
71 deref(el);
72
73 if otype_ el = t_tuple then $ may be standard pair
74 if (nelt(value_ el) ^= 2) go to nfound;
75
76 hd = tcomp(value_ el, 1);
77 tl = tcomp(value_ el, 2);
78
79 elseif otype_ el = t_stuple then $ may be oddball pair
80
81 if (nelt(value_ el) ^= 2) go to nfound;
82
83 call of(hd, el, one);
84 call of(tl, el, two);
85
86 else $ not a pair
87 go to nfound;
88 end if;
89
90 if (is_om_ hd) go to nfound; $ el is not a pair
91 if (is_om_ tl) go to nfound;
92
93 call locate(pos, hd, s, no); $ locate hd in domain
94 if (^ loc_found) go to nfound;
95
96 $ get image
97 im = fval(s, pos, no);
98
99 if is_multi_ im then $ image is multivalued. apply membership
100 $ test for tl in. image
101 st = im;
102 el = tl;
103
104 go to entry;
105
106 else $ image is single valued. compare with tl
107 if (eq(im, tl)) go to found;
108 if (ne(im, tl)) go to nfound;
109 if (equal(im, tl)) go to found;
110 go to nfound;
111 end if;
112
113
114/case(h_lset)/ $ local subset
115
116/case(h_rset)/ $ remote subset
117
118 call locate(pos, el, s, no);
119
120 if loc_found then $ el is in base
121 if (fval(s, pos, no)) go to found;
122 end if;
123
124 go to nfound;
125
126
127
128/found/ $ found element. return true.
129
130 memset = yes;
131 return;
132
133
134
135/nfound/ $ element not found
136
137 memset = no;
138 return;
139
140 end fnct memset;
1 .=member of
2 subr of(out, f, x);
3$
4$ this is the general functional evaluation routine. it performs
5$ out = f(x), where out, f, and x are specifiers. note that this
6$ is written as a subroutine since -f- may be modified by converting
7$ a set to a map.
8$
9 size out(hs); $ specifier returned
10 size f(hs); $ specifier for map/tuple/string
11 size x(hs); $ specifier for index
12
13 size i(hs), $ integer index
14 p(ps), $ pointer to long object
15 n(ps); $ length of long object
16
17 size ss(ssz), $ original string specifier
18 ss1(ssz); $ new string specifier
19
20 size val(hs), $ packed value
21 newp(ps); $ pointer to new heap block
22
23 size map(ps), $ pointer to map.
24 pos(ps); $ pointer to eb
25
26
27 size fval(hs), $ functions called
28 convsm(hs),
29 arb1(hs);
30
31
32/begin/
33
34 go to case(otype_ f) in t_min to t_max;
35
36
37/case(t_int)/
38
39 go to error1;
40
41
42/case(t_string)/ $ short character string
43
44 i = x; deref(i); i = otvalue_ i;
45
48 if i = 0 ! i > sc_nchars_ f then
stra 233 build_spec(out, t_ostring, 0);
50 else
stra 234 out = spec_char; $ one-character template
stra 235 scchar(out, 1) = scchar(f, i);
52 end if;
53
54 return;
55
56
57/case(t_atom)/ $ short atom
58
59/case(t_proc)/
60
61/case(t_lab)/
62
63/case(t_latom)/ $ long atom
64
65/case(t_lint)/ $ long integer
66
67 go to error1;
68
69
70/case(t_elmt)/ $ element
71
72 deref(f);
73
74 go to begin;
75
76
77/case(t_istring)/ $ long character string
78
79 i = x; deref(i); i = otvalue_ i;
80
81 ss = value_ f;
82 n = ss_len(ss);
83
84 if i = 0 ! i > n then
stra 236 build_spec(out, t_ostring, 0);
86
87 else $ build new string specifier
stra 237 out = spec_char; $ one-character template
stra 238 scchar(out, 1) = icchar(ss, i);
90 end if;
91
92 return;
93
94
95
96/case(t_real)/ $ real
97
98 go to error1;
99
100
101/case(t_tuple)/ $ standart tuple
102
103 i = x; deref(i); i = otvalue_ i;
104 p = value_ f;
105
106 if (i > nelt(p)) i = 0;
107
108 is_shared_ tcomp(p, i) = yes;
109 out = tcomp(p, i);
110
111 return;
112
113
114/case(t_stuple)/ $ special tuple
115
116 i = x; deref(i); i = otvalue_ i;
117 p = value_ f;
118
119 if (i > nelt(p)) i = 0; $ give om result
120
121 go to tc(htype(p)) in h_ptuple to h_rtuple;
122
123
124/tc(h_ptuple)/ $ packed tuple
125
126 if i = 0 then
127 val = 0;
128 else
129 val = pcomp(p, i);
130 end if;
131
132 unpack(ptkey(p), val, out);
133
134 return;
135
136
137/tc(h_ituple)/ $ untyped integer tuple
138
139 val = tcomp(p, i);
140 put_intval(val, out);
141
142 return;
143
144
145/tc(h_rtuple)/ $ untyped real tuple
146
147 val = tcomp(p ,i);
148 put_realval(val, out);
149
150 return;
151
152
153/case(t_set)/
154
155 f = convsm(f, f_umap);
156
157 if otype_ f ^= t_map then $ conversion failed
158 out = err_val(f_gen);
159 return;
160 end if;
161
162
163/case(t_map)/ $ maps
164
165 map = value_ f;
166
167 call locate(pos, x, map, no);
168 out = fval(map, pos, yes);
169
170$ if the image is stored with its is_multi bit on, it may be a singleton
171$ set or it may actually be multivalued. we find out which by calling
172$ arb1, which removes singletons. if the image still has its is_multi
173$ bit set, then it is actually multivalued, and we abort.
174
175 if is_multi_ out then
176 out = arb1(out);
177
178 if is_multi_ out then
179 call err_misc(29);
180 out = err_val(f_gen);
181 end if;
182 end if;
183
184 return;
185
186
187
188case_om $ om types
189
190 call err_om(32);
191 go to error;
192
193
194/error1/ $ applying f(x) to illegal type
195
196 call err_type(20);
197
198
199/error/
200
201 if isprim(type_ f) then
202 out = err_val(f_gen);
203 else
204 out = err_val(ft_elmt(hform(value_ f)));
205 end if;
206
207
208 end subr of;
1 .=member ofa
2 subr ofa(out, f, x);
3
4$ this routine performs out = f<>. it is a subr rather than a fnct
5$ since it may modify f by converting a set to a map.
6
7
smfc 46 size out(hs); $ specifier returned (wr)
smfc 47 size f(hs); $ specifier for map (rw)
smfc 48 size x(hs); $ specifier for index (rd)
smfc 49
smfc 50 size map(ps); $ pointer to map data block
smfc 51 size pos(ps); $ pointer returned by locate/insert
smfc 52 size im(hs); $ specifier for range set
smfc 53 size s(ps); $ pointer to range set
smfc 54
smfc 55 size convsm(hs); $ converts set to map
smfc 56 size fval(hs); $ retrieves map image
smfc 57 size nullset(hs); $ returns null set
smfc 58 size rset1(hs); $ builds singleton set
21
22
23$ see if f is a set
24
25 deref(f);
26
27 if (otype_ f = t_set) f = convsm(f, f_umap);
28
29 if otype_ f ^= t_map then
30 if is_om_ f then
31 call err_om(33);
32 else
33 call err_type(21);
34 end if;
35
36 out = err_val(f_gen);
37
38 return;
39 end if;
40
41 map = value_ f;
42
43 call locate(pos, x, map, no);
44 out = fval(map, pos, yes); $ get image
45
smfc 59 if is_multi_ out then
smfc 60 is_multi_ out = no; $ clear before returning
smfc 61
smfc 62 elseif is_smap(map) then
smfc 63 out = rset1(out); $ build singleton set
smfc 64
smfc 65 else
smfc 66 im = nullset(ft_imset(hform(map)), 1);
smfc 67 if is_om_ out = no then
smfc 68 s = value_ im; call insert(pos, out, s); value_ im = s;
smfc 69 end if;
smfc 70 out = im;
smfc 71 end if;
48
49
50 end subr ofa;
1 .=member sof
2 subr sof(f, x, y);
3$
4$ this routine performs -f(x) := y-.
5$
6$ we assume that f can be used destructively, and that any necessary
7$ share bits for x and y were set by the caller.
8$
9 size f(hs); $ specifier for map/tuple/string
10 size x(hs); $ specifier for index
11 size y(hs); $ specifier for value
12
13 size x1(hs); $ local copy of x
14 size y1(hs); $ local copy of y
15
16 size ss1(ssz); $ string specifier for f
17 size ss2(ssz); $ string specifier for y
18 size fm(ps); $ form of object
19 size n(ps); $ cardinality of object
20 size p(ps); $ pointer to long object
21 size i(ps); $ integer index
22 size val(hs); $ packed value
smfb 127 size om_val(hs); $ proper omega for tuple component
23
24 size map(ps), $ pointer to map
25 pos(ps), $ pointer returned by locate
26 yy(hs); $ copy of y, used in map assignments
27
28 size retpt(ps); $ return pointer for l_call
29
30
31 size rset1(hs), $ functions called
32 ssbsts(hs),
33 convert(hs),
34 convsm(hs),
35 copy1(hs);
36
37 .=zzyorg a $ counter for return labels
38
39
40/begin/ $ begin execution
41
42 go to case(otype_ f) in t_min to t_max;
43
44/case(t_int)/ $ short integer
45
46 go to error1;
47
48
49/case(t_string)/ $ short character string
50
stra 239 x1 = x; deref(x1);
stra 240 y1 = y; deref(y1);
stra 241
stra 242 if (otype_ x1 ^= t_int) go to error4;
stra 243
stra 244 i = ivalue_ x1;
stra 245
stra 246 if ( ^ (1 <= i & i <= sc_nchars_ f)) go to error2;
stra 247
stra 248 if otype_ y1 = t_string then
stra 249 if sc_nchars_ y1 = 1 then
stra 250 scchar(f, i) = scchar(y1, 1);
stra 251 else
stra 252 f = ssbsts(f, x1, x1, y1);
stra 253 end if;
stra 254 elseif otype_ y1 = t_istring then
stra 255 ss2 = value_ y1;
stra 256 if ss_len(ss2) = 1 then
stra 257 scchar(f, i) = icchar(ss2, 1);
stra 258 else
stra 259 f = ssbsts(f, x1, x1, y1);
stra 260 end if;
stra 261 else
stra 262 go to error3;
stra 263 end if;
58
59 return;
60
61
62/case(t_atom)/ $ short atom
63
64/case(t_proc)/
65
66/case(t_lab)/
67
68 go to error1;
69
70
71/case(t_elmt)/ $ base element
72
73 deref(f);
74
75 go to begin;
76
77
78/case(t_latom)/ $ long atom
79
80/case(t_lint)/ $ long integer
81
82 go to error1;
83
84
85/case(t_istring)/ $ long character string
86
87 x1 = x; deref(x1);
88 y1 = y; deref(y1);
89
stra 264 if (otype_ x1 ^= t_int) go to error4;
stra 265
stra 266 i = ivalue_ x1;
stra 267 ss1 = value_ f;
stra 268
stra 269 if ( ^ ( 1 <= i & i <= ss_len(ss1))) go to error2;
stra 270
stra 271 if otype_ y1 = t_string then
stra 272 if sc_nchars_ y1 = 1 then
stra 273 f = copy1(f); ss1 = value_ f; $ always copy long strings
stra 274 icchar(ss1, i) = scchar(y1, 1);
stra 275 else
stra 276 f = ssbsts(f, x1, x1, y1);
stra 277 end if;
stra 278 elseif otype_ y1 = t_istring then
stra 279 ss2 = value_ y1;
stra 280 if ss_len(ss2) = 1 then
stra 281 f = copy1(f); ss1 = value_ f; $ always copy long strings
stra 282 icchar(ss1, i) = icchar(ss2, 1);
stra 283 else
stra 284 f = ssbsts(f, x1, x1, y1);
stra 285 end if;
stra 286 else
stra 287 go to error3;
stra 288 end if;
104
105 return;
106
107
108/case(t_real)/ $ real
109
110 go to error1;
111
112
113/case(t_tuple)/ $ standard tuple
114
115 i = x; deref(i); i = otvalue_ i;
116 p = value_ f;
117
118$ we begin by doing a preliminary range check against the nelt of the
119$ tuple (which is always valid). this test catches cases in which we
120$ are extending the tuple, and in which we are shortening it by
121$ setting t(?t) = om.
122
123 if i = 0 ! i > nelt(p) then l_call(expand_tup); end if;
124
125$ if the tuple is a mixed tuple, we must assure that -y- has the
126$ proper type.
127
128 fm = hform(p);
129
130 if ft_type(fm) = f_mtuple then
131 if i > ft_lim(fm) then
132 call err_misc(42);
133 go to error;
134 end if;
135
136 fm = mttab(ft_elmt(fm)+i);
137 y = convert(y, fm);
138 end if;
139
140 tcomp(p, i) = y;
141
142 is_hashok(p) = no; $ invalidate hash
smfb 128
smfb 129 if i = nelt(p) & is_om_ y then
smfb 130 until i = 0;
smfb 131 i = i - 1;
smfb 132 if ( ^ is_om_ tcomp(p, i)) quit until;
smfb 133 end until;
smfb 134 nelt(p) = i;
smfb 135 end if;
144
145 return;
146
147
148/case(t_stuple)/ $ special tuple
149
150 i = x; deref(i); i = otvalue_ i;
151 p = value_ f;
152 if i = 0 ! i > nelt(p) then l_call(expand_tup); end if;
153 is_hashok(p) = no; $ invalidate hash
154
155 go to tc(htype(p)) in h_ptuple to h_rtuple;
156
157
158/tc(h_ptuple)/ $ packed tuple
159
160 pack(ptkey(p), val, y);
161 pcomp(p, i) = val;
smfb 136
smfb 137 if i = nelt(p) & is_om_ y then
smfb 138 until i = 0;
smfb 139 i = i - 1;
smfb 140 if (pcomp(p, i) ^= 0) quit until;
smfb 141 end until;
smfb 142 nelt(p) = i;
smfb 143 end if;
163
164 return;
165
166
167/tc(h_ituple)/ $ integer tuple
168
169 get_intval(val, y);
170 tcomp(p, i) = val;
smfb 144
smfb 145 if i = nelt(p) & is_om_ y then
smfb 146 om_val = tcomp(p, 0);
smfb 147 until i = 0;
smfb 148 i = i - 1;
smfb 149 if (tcomp(p, i) ^= om_val) quit until;
smfb 150 end until;
smfb 151 nelt(p) = i;
smfb 152 end if;
172
173 return;
174
175
176/tc(h_rtuple)/ $ real tuple
177
178 get_realval(val, y);
179 tcomp(p, i) = val;
smfb 153
smfb 154 if i = nelt(p) & is_om_ y then
smfb 155 om_val = tcomp(p, 0);
smfb 156 until i = 0;
smfb 157 i = i - 1;
smfb 158 if (tcomp(p, i) ^= om_val) quit until;
smfb 159 end until;
smfb 160 nelt(p) = i;
smfb 161 end if;
181
182 return;
183
184
185/case(t_set)/ $ sets require conversion to maps
186
187 f = convsm(f, f_umap);
188
189 if (otype_ f ^= t_map) go to error; $ conversion failed
190
191
192/case(t_map)/
193
194 map = value_ f; $ get pointer to map
195
196 if is_om_ y & ^ is_based(map) then
197 $ delete element block
198 call locate(pos, x, map, no);
199 if (loc_found) call delete(map, loc_prev, pos, yes);
200
201 else $ store value_ in map.
202 $ build singleton set if this is an mmap.
203 yy = y;
204
205 if is_mmap(map) then
206 yy = rset1(yy); fm = ft_im(hform(map));
207 if (hform(value_ yy) ^= fm) yy = convert(yy, fm);
208 is_multi_ yy = yes;
209 end if;
210
211 call locate(pos, x, map, yes); $ locate x
212 call sfval(map, pos, yy);
213
214 end if;
215
216$ for the moment we invalidate the hash and nelt of the map. it might
217$ be better to update them, but only experimentation will tell.
218
219 is_hashok(map) = no;
220 is_neltok(map) = no;
221
222 value_ f = map; $ store new map value
223
224 return;
225
226
227
228
229case_om; $ om types
230
231 call err_om(6);
232 go to error;
233
234
235/error1/ $ error returns
236
237 call err_type(22);
238 go to error;
239
240
241/error2/
242
243 call err_misc(30);
244 go to error;
245
246
247/error3/ $ cannot assign -y- to -f-
248
249 call err_type(39);
250 go to error;
251
252
253/error4/
254
255 call err_misc(33);
256
257/error/ $ return proper .om
258
259 if isprim(type_ f) then
260 f = err_val(f_gen);
261 else
262 f = err_val(hform(value_ f));
263 end if;
264
265 return;
266
267
268
269/expand_tup/ $ expand tuple
270
271$ this local routine handles sinister assignments to tuples where the
272$ index is zero, or is greater than or equal to the nelt of the tuple.
273
274 if i = 0 then
275 call err_misc(32);
276 go to error;
277 end if;
278
279 if i > maxsi then $ illegal index
280 if (type_ i = t_lint) call err_fatal(6);
281
282 go to error4;
283 end if;
284
285 if i > maxindx(p) then
286 call exptup(f, i); p = value_ f;
287 end if;
288
289 if (^ is_om_ y) nelt(p) = i;
290
291 go to rlab(retpt) in 1 to zzya; $ local return
292
293 end subr sof;
1 .=member sofa
2 subr sofa(f, x, y, decl);
3$
4$ this routine performs -f<> := y-.
5$
6$ we assume that f can be used destructively, and that any necessary
7$ share bits for x and y were set by the caller. -decl- indicates
8$ that the arguments are declared.
9$
10 size f(hs), $ specifier for map
11 x(hs), $ specifier for argument to mapping
12 y(hs), $ specifier for rhs of assignment
13 decl(1); $ indicates arguments declared
14
15 size map(ps), $ pointer to map
16 n(ps), $ nelt of y
17 pos(ps), $ pointer returned by locate
18 yy(hs); $ copy of y
19
20
21 size arbs(hs),
22 merge_np(hs),
23 convsm(hs),
24 convmm(hs),
25 copy1(hs);
26
27
28 deref(f);
29
30 if (otype_ f = t_set) f = convsm(f, f_umap);
31
32 if otype_ f ^= t_map then
33 if is_om_ f then
34 call err_om(34);
35 else
36 call err_type(23);
37 end if;
38
39 f = err_val(f_gen);
40 return;
41 end if;
42
43 if ^ isset(otype_ y) then
44 call err_type(24);
45 f = err_val(f_gen);
46 return;
47 end if;
48
49 map = value_ f; $ get pointer to map
50
51$ take special action if we are storing a null or singleton set.
52 ok_nelt(y);
53 n = nelt(value_ y);
54
55
56 if n = 0 & ^ is_based(map) then
57$ delete eb
58 call locate(pos, x, map, no);
59 if (loc_found) call delete(map, loc_prev, pos, yes);
60
61 else $ store image
62 yy = y; $ set up image
63 is_multi_ yy = yes;
64
65$ handle special cases. these include sofa on smaps, and sofa where
66$ y is a null or singleton set.
67
68 if n > 1 then
69 if is_smap(map) then
70 if decl then
71 $ declared smap becomes multi-valued
72 call err_misc(34);
73 f = err_val(hform(map));
74
75 else
76 f = convsm(f, f_umap);
77 map = value_ f;
78 end if;
79 end if;
80
81 else $ yy is null or a singleton
82 if (^ is_mmap(map)) yy = arbs(yy);
83 end if;
84
85 call locate(pos, x, map, yes); $ locate x in domain
86
87 call sfval(map, pos, yy);
88 value_ f = map; $ store new set value_
89
90 end if;
91
92 is_hashok(map) = no; $ invalidate nelt and hash
93 is_neltok(map) = no;
94
95
96 end subr sofa;
1 .=member fval
2 fnct fval(map, eb, share);
3
4$ this is a very low level routine for retrieving map images.
5$ it is called after we have already found the coorresponding
6$ domain element in the hash table of the map. fval is never
7$ called from outside the library, but rather from routines
8$ such as 'of' and 'equal'. fval can also be applied to based sets.
9$ in this case it returns zero or one depending on whether the
10$ elements is in the set. fvals arguments are:
11
12$ map: a pointer to the map.
13$ eb: a pointer to the eb containing the functional information
14$ share: flag indicating whether we should set is_shared
15$ bit of map element.
16
17$ the returned value is a specifier with its is_multi bit
18$ appropriately set.
19
20
21 size fval(hs); $ specifier returned
22
23 size map(ps), $ pointer to map
24 eb(ps), $ pointer to eb of map
25 share(1); $ indicates that share bit should be set
26
27 size org(ps), $ first bit position in local packed map
28 off(ps), $ word offset
29 len(ps); $ length of packed value
30
31 size val(hs), $ untyped value
32 p(ps), $ pointer to new heap block
33 i(ps); $ ebindx for remote maps and sets
34
35
36 go to case(htype(map)) in h_uset to h_lrmap;
37
38
39/case(h_uset)/ $ unbased set
40
41$ we should never reach here
42
43 call err_fatal(7);
44
45
46/case(h_umap)/
47$ standard map.
48
49 if (share) is_shared_ ebimag(eb) = yes;
50 fval = ebimag(eb);
51
52 return;
53
54
55
56/case(h_lmap)/
57$ local map
58
59 if (share) is_shared(eb+ls_word(map)) = yes;
60 fval = heap(eb+ls_word(map));
61
62 return;
63
64
65/case(h_lpmap)/
66$ local packed map
67
68 org = ls_bit(map);
69 off = ls_word(map);
70 len = ls_bits(map);
71
72 val = .f. org, len, heap(eb+off);
73
74 unpack(ls_key(map), val, fval);
75
76 return;
77
78
79/case(h_limap)/ $ local integer map
80
81 val = heap(eb+ls_word(map));
82 put_intval(val, fval);
83
84 return;
85
86
87/case(h_lrmap)/ $ local real map
88
89 val = heap(eb+ls_word(map));
90 put_realval(val, fval);
91
92 return;
93
94
95/case(h_lset)/ $ local set
96
97$ for based sets, fval returns zero or one, indicating whether the
98$ elements membership bit is on.
99
100 fval = .f. ls_bit(map), 1, heap(eb+ls_word(map));
101 return;
102
103
104
105/case(h_rmap)/
106$ remote map.
107
108 i = ebindx(eb);
109 if (i > maxindx(map + hl_rmap)) i = 0;
110
111 if (share) is_shared_ tcomp(map + hl_rmap, i) = yes;
112 fval = tcomp(map + hl_rmap, i);
113
114 return;
115
116
117
118/case(h_rpmap)/ $ packed remote smap
119
120 i = ebindx(eb);
121
122 if i > maxindx(map + hl_rpmap) then
123 val = 0;
124 else
125 val = pcomp(map + hl_rpmap, i);
126 end if;
127
128 unpack(ptkey(map+hl_rpmap), val, fval);
129
130 return;
131
132
133/case(h_rimap)/
134$ remote integer smap
135
136 i = ebindx(eb);
137 if (i > maxindx(map + hl_rmap)) i = 0;
138
139 val = tcomp(map + hl_rmap, i);
140 put_intval(val, fval);
141
142 return;
143
144
145
146/case(h_rrmap)/
147$ remote real smap
148
149$ similar to remote integer map, above
150
151 i = ebindx(eb);
152 if (i > maxindx(map + hl_rmap)) i = 0;
153
154 val = tcomp(map + hl_rmap, i);
155 put_realval(val, fval);
156
157 return;
158
159
160
161/case(h_rset)/ $ remote set
162
163$ return the elements membership bit.
164
165$ get index, see if in range
166
167 i = ebindx(eb);
168
169 if i <= rs_maxi(map) then
170 fval = rsbit(map, i);
171 else
172 $ om, return no
173 fval = no;
174 end if;
175
176 return;
177
178 end fnct fval;
1 .=member sfval
2 subr sfval(map, eb, val);
3
4$ this is a very low level routine for functional storage. it assumes
5$ that we have already located the corresponding domain element in
6$ the hash table of the map. sfval is also used to set the membership
7$ bits of based maps. its arguments are:
8
9$ map: pointer to the map
10$ eb: pointer to element block for domain element
11$ val: specifier for value being stored, with is_multi bit
12$ properly set.
13
14
15 size map(ps), $ pointer to map
16 eb(ps), $ pointer to proper eb.
17 val(hs); $ specifier for value to be stored
18
19 size org(ps), $ bit origin in local packed map
20 off(ps), $ word offset
21 len(ps), $ length of packed value
22 pval(hs); $ packed value
23
24 size i(ps); $ ebindx for remote maps and sets
25
26 size nwords(ps); $ length of bit string for remote set
27
28 size exprmap(ps), $ functions called
29 exprset(ps);
30
31
32 go to case(htype(map)) in h_uset to h_lrmap;
33
34
35/case(h_uset)/ $ unbased set
36
37$ should never reach here
38
39 call err_fatal(8);
40
41
42/case(h_umap)/ $ standard map
43
44 ebimag(eb) = val;
45 return;
46
47
48
49/case(h_lmap)/ $ local map
50
51 heap(eb+ls_word(map)) = val;
52 return;
53
54
55
56/case(h_lpmap)/ $ packed local map
57
58 org = ls_bit(map);
59 off = ls_word(map);
60 len = ls_bits(map);
61
62 $ form packed value
63 pack(ls_key(map), pval, val);
64
65 .f. org, len, heap(eb+off) = pval;
66
67 return;
68
69
70
71/case(h_limap)/ $ local integer map
72
73 if is_om_ val then $ store om_int
74 heap(eb+ls_word(map)) = om_int;
75
76 elseif type_ val = t_int then $ short integer
77 heap(eb+ls_word(map)) = ivalue_ val;
78
79 else $ long int
80 if (liwords(value_ val) > 1) call err_fatal(9);
81 heap(eb+ls_word(map)) = liword(value_ val, 1);
82 end if;
83
84 return;
85
86
87/case(h_lrmap)/ $ local real map
88
89 heap(eb+ls_word(map)) = rval(value_ val);
90
91 return;
92
93
94/case(h_lset)/ $ local subset
95
96 .f. ls_bit(map), 1, heap(eb + ls_word(map)) = val;
97
98 return;
99
100
101/case(h_rmap)/ $ remote map
102
103 i = ebindx(eb);
104
105 if (i > maxindx(map + hl_rmap)) map = exprmap(map, i);
106 tcomp(map + hl_rmap, i) = val;
107
108 return;
109
110/case(h_rpmap)/ $ packed remote smap
111
112 i = ebindx(eb);
113
114 if (i > maxindx(map + hl_rpmap)) map = exprmap(map, i);
115
116 pack(ptkey(map + hl_rpmap), pval, val);
117
118 pcomp(map + hl_rpmap, i) = pval;
119 return;
120
121/case(h_rimap)/ $ remote integer map
122
123 i = ebindx(eb);
124
125 if (i > maxindx(map + hl_rmap)) map = exprmap(map, i);
126
127 $ we assume that val is no longer than 1 word
128
129 if is_om_ val then $ store om_int
130 tcomp(map + hl_rmap, i) = om_int;
131
132 elseif type_ val = t_int then $ short int
133 tcomp(map + hl_rmap, i) = ivalue_ val;
134
135 else $ long int
136 if (liwords(value_ val) > 1) call err_fatal(10);
137 tcomp(map + hl_rmap, i) = liword(value_ val, 1);
138 end if;
139
140 return;
141
142
143/case(h_rrmap)/ $ remote real map
144
145 i = ebindx(eb);
146
147 if (i > maxindx(map + hl_rmap)) map = exprmap(map, i);
148
149 if is_om_ val then $ store om_real
150 tcomp(map + hl_rmap, i) = om_real;
151
152 else $ store real value
153 tcomp(map + hl_rmap, i) = rval(value_ val);
154 end if;
155
156 return;
157
158
159
160
161
162/case(h_rset)/ $ remote subset
163
164 i = ebindx(eb); $ get index to bit string
165
166$ extend bit string if necessary
167 if (i > rs_maxi(map)) map = exprset(map, i);
168
169 rsbit(map, i) = val;
170
171 return;
172
173
174 end subr sfval;
1 .=member next
2 subr next(val, iter, arg);
3
4$ this is the top level routine for iterating over sets and
5$ tuples. tuple iteration is quite simple, and is handled
6$ inline, while set and map iteration are handled by a seperate
7$ routine.
8
9$ the arguments to the routine are:
10
11$ val: the value of the previous set or tuple element
12$ iter: the previous element in 'iterator format'
13$ arg: the set, map, or tuple being iterated over.
14
15$ iterator formats for sets and maps are described in the
16$ routine 'nexts'. iterators for tuples are simply short integers
17$ giving the index of the previous element.
18
19
20 size val(hs); $ iteration value
21 size iter(hs); $ pointer to iteration value
22 size arg(hs); $ specifier for string, tuple, set, or map
23
24 size p(ps); $ pointer to long value
25 size p1(ps); $ pointer to new string
26
27
31 p = value_ arg; $ get pointer to set, tuple, etc.
32
33 go to case(otype_ arg) in t_min to t_max;
34
35
36/case(t_int)/ $ error types
37
40/case(t_atom)/
41
42/case(t_proc)/
43
44/case(t_lab)/
45
46/case(t_latom)/
47
48/case(t_elmt)/
49
50/case(t_lint)/
51
52/case(t_real)/
53
54 call err_type(25);
55
56 val = err_val(f_gen);
57 iter = err_val(f_gen);
58
59 return;
stra 289
stra 290
stra 291/case(t_string)/ $ short character string
stra 292
stra 293 add1(iter);
stra 294
stra 295 if value_ iter > sc_nchars_ arg then
stra 296 is_om_ iter = yes;
stra 297 is_om_ val = yes;
stra 298 else
stra 299 val = arg; $ since sc_max = 1
stra 300 end if;
stra 301
stra 302 return;
60
61
62/case(t_istring)/
63
64 add1(iter);
65
66 if value_ iter > ss_len(p) then
67 is_om_ iter = yes;
68 is_om_ val = yes;
69
70 else
stra 303 val = spec_char; $ one-character template
stra 304 scchar(val, 1) = icchar(p, value_ iter);
73 end if;
74
75 return;
76
77
78/case(t_tuple)/ $ tuples
79
80 add1(iter); $ increment index and compare with nelt.
81
82 if value_ iter > nelt(p) then
83 is_om_ val = yes;
84 is_om_ iter = yes;
85
86 else
87 is_shared_ tcomp(p, value_ iter) = yes;
88 val = tcomp(p, value_ iter);
89 end if;
90
91 return;
92
93/case(t_stuple)/
94
95 add1(iter);
96
97 if value_ iter > nelt(p) then
98 is_om_ val = yes;
99 is_om_ iter = yes;
100
101 else
102 call of(val, arg, iter);
103 end if;
104
105 return;
106
107/case(t_set)/ $ sets
108
109/case(t_map)/ $ maps
110
111 call nexts(val, iter, arg);
112
113 return;
114
115case_om; $ om argument type
116
117 call err_om(7);
118
119 val = err_val(f_gen);
120 iter = err_val(f_gen);
121
122 return;
123
124 end subr next;
1 .=member nexts
2 subr nexts(valu, itera, set);
3
4$ this routine performs iteration over sets and maps. it is
5$ recursive in order to handle multivalued maps.
6
7$ the arguments to the routine are:
8
9$ valu: the value of the previous set element
10$ itera: the previous element in 'iterator' format.
11$ set: specifier for the set being iterated over.
12
13$ iterator format is a special way of representing elements
14$ of sets, maps, and tuples which allows us to find the
15$ next element.
16
17$ a set iterator has:
18
19$ type: t_elmt
20$ value: pointer to eb of current element
21
22$ note that for based sets, the representation of an iterator
23$ is the same as the representation for the elements of the set.
24
25$ a map iterator has:
26
27$ type: t_tuple
28$ value: pointer to standard pair
29
30$ the contents of the pair depend on whether we are currently at
31$ a multivalued point in the map. if so, then we must get the
32$ next element by advancing through the image of the current
33$ domain element; otherwise we must advance through the domain.
34
35$ if we are at a multivalued point the pair has:
36
37$ is_range: on to indicated advancing through range
38$ pair(1): set iterator for domain of map
39$ pair(2): set or map iterator for range set
40
41$ otherwise the pair has:
42
43$ is_range: off
44$ pair(1): set iterator for domain
45$ pair(2): image of domain element
46
47$ iteration over a set is quite simple. iteration over a map
48$ is more complex, and consists of five steps:
49
50$ 1. copy the iterator if it is shared since we will modify at least
51$ one of its components.
52
53$ 2. see if the current iterator is a pair where y is an
54$ element of the range set f<>. if so, advance y in the range set.
55
56$ 3. if we have reached the end of the range set, or if the current
57$ iterator is the pair then we must advance in the domain
58$ of the map until we find another point where the map is defined.
59
60$ 4. once we find this new point xx in the domain, we must see if its
61$ image is multivalued. if so, we initialize an iterator over this
62$ new range set and advance it.
63
64$ 5. finally we rebuild the pair.
65
66
67$ variable declarations
68
69
70$ actual arguments
71
72 size valu(hs), $ previous element value
73 itera(hs), $ prevoius iterator returned by next
74 set(hs); $ specifier for set we are iterating over
75
76$ arguments to recursive part of routine
77
78 size val(hs), $ previous element
79 iter(hs), $ iterator
80 st(hs); $ specifier for set
81
82 size tstart(ps); $ recursion stack pointer at start of routine
83
84 size im(hs); $ map image at cuurent point in domain
85
86 size s(ps), $ pointer to set
87 spec(hs); $ temporary specifier
88 size fm(ps); $ form of map
89
90 size bit(ps), $ ls_bit of local set
91 word(ps), $ ls_bit of local set
92 indx(ps); $ ebindx of remote set
93
94
95 size copy1(hs), $ functions called
96 fval(hs),
97 nullp(1);
98
99$ stacked variables
100
101 .=zzyorg b $ reset counters for stack offsets
102
103 local(retpt); $ return pointer
104 local(map); $ pointer to map we are iterating over
105 local(vpair); $ pointer to pair for map element value
106 local(ipair); $ pointer to pair for map iterator
107 local(pos); $ current position in domain
108
109 local(p); $ pointer to range set
110
111
112
113/begin/ $ begin execution
114
115 tstart = t; $ save initial recursion stack pointer
116
117 .=zzyorg a $ reset counter for return labels
118
119 val = valu; $ make local copies of arguments
120 iter = itera;
121 st = set;
122
123/entry/ $ recursive entry point
124
125 r_entry; $ increment recursion stack
126
127 s = value_ st; $ get pointer to set
128
129 if (^ is_map(s)) go to case_set; $ branch to set case
130
131/case_map/ $ map cases
132
133 map = s; $ save through recursion
134
135$ copy val if it is shared. there is no need to copy iter since it
136$ is never used by anyone other than the next routine.
137 maycopy(val);
138
139$ get pointer to pairs for both val and iter, then get current
140$ domain position
141
142 vpair = value_ val;
143 ipair = value_ iter;
144
145 pos = value_ tcomp(ipair, 1);
146
147 if is_range(ipair) then $ advance in range set
148
149 val = tcomp(vpair, 2);
150 iter = tcomp(ipair, 2); $ get range iterator
151 st = fval(map, pos, no);
152
153 r_call;
154
155$ if the returned value is non-om then rebuild 'val' and 'iter'
156$ and return.
157 if ^ is_om_ val then
158 tcomp(vpair, 2) = val;
159 tcomp(ipair, 2) = iter;
160
161 build_spec(val, t_tuple, vpair);
162 build_spec(iter, t_tuple, ipair);
163
164 go to exit;
165 end if;
166
167 end if;
168
169
170$ advance in domain
171
172$ advance in domain, skipping elements whose images are om.
173$ in mmaps we must also skip images which are null sets.
174
175$ note that -pos- still points to the current domain element
176 while 1;
177 pos = eblink(pos); $ advance
178
179 if is_ebhedr(pos) then $ skip hash table header blocks
180 if (is_ebtemp(pos)) quit;
181 cont;
182 end if;
183
184 im = fval(map, pos, yes); $ get image
185
186 if is_mmap(map) then $ look for non-null range set
187 p = value_ im;
188
189 if is_neltok(p) then
190 if (nelt(p) ^= 0) quit;
191 else
192 if (^ nullp(p)) quit;
193 end if;
194
195 else $ look for defined image
196 if (^ is_om_ im) quit;
197 end if;
198
199 end while;
200
201$ found new domain element
202
203$ if we have reached the end of the domain then we return:
204
205$ val: standard omega for element type of map
206$ iter: spec_om
207
208
209 if is_ebtemp(pos) then
210 fm = ft_elmt(hform(map));
211 val = heap(ft_samp(fm));
212
213 iter = spec_om;
214
215 go to exit;
216 end if;
217
218
219$ start new range iteration if necessary
220
221$ n.b. if -im- is multivalued it can never be a null range set
222$ (since we skip them in the above loop).
223
224 if is_multi_ im then $ start range iteration
225 call inext(val, iter, im);
226 st = im;
227
228 r_call; $ advance in new range set
229
230 tcomp(vpair, 2) = val;
231 tcomp(ipair, 2) = iter; $ store result
232 is_range(ipair) = yes;
233
234 else
235 tcomp(vpair, 2) = im; $ store image in vpair and iair
236 tcomp(ipair, 2) = im;
237 is_range(ipair) = no; $ indicate there is no range set
238 end if;
239
240
241$ store next domain element
242
243$ n.b. the first component of -vpair- will either be a pointer
244$ pointer to -pos- or its eb specifier, depending on whether
245$ -map- is based. however the first component of -ipair- is
246$ always a pointer.
247
248 if is_based(map) then
249 build_spec(spec, t_elmt, pos);
250 tcomp(vpair, 1) = spec;
251 else
252 is_shared_ ebspec(pos) = yes;
253 tcomp(vpair, 1) = ebspec(pos);
254 end if;
255
256 build_spec(spec, t_elmt, pos);
257 tcomp(ipair, 1) = spec;
258
259
260$ build specifier for result
261
262 build_spec(val, t_tuple, vpair);
263 build_spec(iter, t_tuple, ipair);
264
265 go to exit;
266
267
268
269
270
271/case_set/ $ set cases
272
273 s = value_ st;
274 pos = value_ iter; $ get current position in set
275
276 go to sc(htype(s)) in h_uset to h_rset; $ jump on type
277
278
279/sc(h_uset)/ $ unbased set
280
281 while 1; $ advance to next defined element
282 pos = eblink(pos); $ advance
283
284 if (^ is_ebhedr(pos)) quit;
285 if (is_ebtemp(pos)) quit;
286 end while;
287
288 go to done;
289
290
291
292/sc(h_lset)/ $ local based set
293
294$ find next element of base with membership bit on.
295
296 bit = ls_bit(s); $ get bit and word offset
297 word = ls_word(s);
298
299 while 1;
300 pos = eblink(pos); $ advance
301
302 if is_ebhedr(pos) then
303 if (is_ebtemp(pos)) quit; $ end of set
304 cont;
305 end if;
306
307 if (.f. bit, 1, heap(pos+word)) quit; $ in set
308 end while;
309
310 go to done;
311
312
313
314/sc(h_rset)/ $ remote based set
315
316$ advance in base looking for next element with membership bit on.
317
318 while 1;
319 pos = eblink(pos); $ advance
320
321 if is_ebhedr(pos) then
322 if (is_ebtemp(pos)) quit; $ end of set
323 cont;
324 end if;
325
326 indx = ebindx(pos); $ get base index
327 if (indx > rs_maxi(s)) cont; $ out of range
328
329 if (rsbit(s, indx)) quit; $ in set
330 end while;
331
332 go to done;
333
334
335
336/done/ $ build new set iterator
337
338 if is_based(s) then
339 build_spec(val, t_elmt, pos);
340
341 else
342 is_shared_ ebspec(pos) = yes;
343 val = ebspec(pos);
344 end if;
345
346 if (is_ebtemp(pos)) is_om_ val = yes;
347
348 if is_ebtemp(pos) then
349 iter = spec_om;
350 else
351 build_spec(iter, t_elmt, pos);
352 end if;
353
354
355
356/exit/ $ recursive exit
357
358 r_exit; $ pop recursion stack
359
360 if t ^= tstart then $ recursive return
361 go to rlab(retpt) in 1 to zzya;
362
363 else
364 valu = val; $ copy results to actual arguments
365 itera = iter;
366 return;
367 end if;
368
369
370
371$ drop local variables
372
373 macdrop4(retpt, map, vpair, ipair);
374 macdrop2(pos, p);
375 macdrop(ended);
376
377 end subr nexts;
1 .=member inext
2 subr inext(val, iter, arg);
3
4$ this routine initilaizes set, tuples, and map iterators.
5$ 'val' is set to the zero-th element of the set, etc. and
6$ 'iter' is set to point to the zero-th element.
7
8
9 size val(hs); $ iteration value
10 size iter(hs); $ pointer to iteration value
11 size arg(hs); $ specifier for string, tuple, set, or map
12
13 size p(ps); $ pointer to long value
14 size spec(hs); $ temporary specifier
15 size vpair(ps); $ pair for val
16 size ipair(ps); $ pair for iter
17 size tmp(ps); $ pointer to template
18
19 size fval(hs); $ map image retrieval utility
20
21
22/begin/ $ begin execution
23
24
25
26 p = value_ arg; $ get pointer to set, tuple, etc.
27
28 go to case(otype_ arg) in t_min to t_max;
29
30
31/case(t_int)/ $ error types
32
35/case(t_atom)/
36
37/case(t_proc)/
38
39/case(t_lab)/
40
41/case(t_latom)/
42
43/case(t_lint)/
44
45/case(t_real)/
46
47 call err_type(26);
48
49 val = err_val(f_gen);
50 iter = err_val(f_gen);
51
52 return;
53
54
55/case(t_elmt)/ $ element
56
57 deref(arg); go to begin;
58
59
stra 305/case(t_string)/ $ short character string
stra 306
60/case(t_istring)/ $ strings
61
62 iter = zero;
stra 307 val = heap(ft_samp(f_sstring));
64
65 return;
66
67
68/case(t_tuple)/ $ standard tuple
69
70 val = tcomp(p, 0);
71 iter = zero;
72
73 return;
74
75
76/case(t_stuple)/ $ special tuple
77
78 go to tc(htype(p)) in h_ptuple to h_rtuple;
79
80
81/tc(h_ptuple)/ $ packed tuple
82
83 unpack(ptkey(p), 0, val);
84
85 iter = zero;
86
87 return;
88
89
90/tc(h_ituple)/ $ untyped integer tuple
91
92 spec = tcomp(p, 0);
93 put_intval(spec, val);
94
95 iter = zero;
96
97 return;
98
99
100/tc(h_rtuple)/ $ untyped real tuple
101
102 spec = tcomp(p, 0);
103 put_realval(spec, val);
104
105 iter = zero;
106
107 return;
108
109
110/case(t_set)/ $ sets
111
112 tmp = template(p);
113
114 if is_based(p) then
115 build_spec(val, t_oelmt, tmp);
116 else
117 val = ebspec(tmp);
118 end if;
119
120 build_spec(iter, t_elmt, tmp);
121
122 return;
123
124
125/case(t_map)/ $ maps
126
127 get_pair(vpair); $ get pairs for val and iter
128 get_pair(ipair);
129
130 build_spec(val, t_tuple, vpair);
131 build_spec(iter, t_tuple, ipair);
132
133 tmp = template(p);
134
135$ build components for 'val'.
136 if is_based(p) then
137 build_spec(spec, t_elmt, template(p));
138 tcomp(vpair, 1) = spec;
139
140 else
141 is_shared_ ebspec(tmp) = yes;
142 tcomp(vpair, 1) = ebspec(tmp);
143 end if;
144
145 tcomp(vpair, 2) = om_image(p);
146
147$ build components for 'iter'.
148 build_spec(spec, t_elmt, tmp);
149
150 tcomp(ipair, 1) = spec;
151 tcomp(ipair, 2) = om_image(p);
152
153 is_range(ipair) = no;
154
155 return;
156
157
158case_om;
159
160 call err_om(8);
161
162 val = err_val(f_gen);
163 iter = err_val(f_gen);
164
165 return;
166
167
168 end subr inext;
1 .=member nextd
2 subr nextd(val, iter, arg);
3
4$ this routine advances a domain iterator over a string, tuple,
5$ or map.
6
7
8 size val(hs); $ specifier for previous value
9 size iter(hs); $ pointer to iteration value
10 size arg(hs); $ specifier for string, tuple, or map
11
12 size pos(ps); $ position in map domain
13 size map(ps); $ pointer to map
14 size im(hs); $ map image at current point in domain
15 size p(ps); $ pointer to range set
16 size indx(ps); $ index in string of tuple
17 size lim(ps); $ limit for string or tuple iteration
18
19 size nullp(1); $ null set predicate
20 size fval(hs); $ map image retrieval utility
21
22
23 go to case(otype_ arg) in t_min to t_max;
24
25
26/case(t_int)/ $ short int
27
28 go to error;
29
30
31/case(t_string)/ $ short character strings
32
33 lim = sc_nchars_ arg;
34
35 go to test;
36
37
38/case(t_atom)/ $ short atom
39
40/case(t_proc)/
41
42/case(t_lab)/
43
44/case(t_latom)/ $ long atom
45
46/case(t_elmt)/ $ element
47
48/case(t_lint)/ $ long integers
49
50 go to error;
51
52
53/case(t_istring)/ $ long chars
54
55 lim = ss_len(value_ arg);
56 go to test;
57
58
59/case(t_real)/ $ reals
60
61 go to error;
62
63
64/case(t_tuple)/ $ tuples
65
66/case(t_stuple)/ $ packed tuples
67
68 ok_nelt(arg);
69 lim = nelt(value_ arg);
70
71 go to test;
72
73
74/case(t_set)/ $ sets
75
76 go to error;
77
78
79/case(t_map)/ $ standard maps
80
81$ get pointer to map and position in domain
82 map = value_ arg;
83 pos = value_ iter;
84
85 while 1; $ advance in domain
86 pos = eblink(pos);
87
88 if is_ebhedr(pos) then
89 if (is_ebtemp(pos)) quit; $ end of map
90 cont;
91 end if;
92
93 im = fval(map, pos, no); $ get image
94
95$ skip points where image is om or null
96 if is_mmap(map) then $ skip null range sets
97 p = value_ im;
98
99 if is_neltok(p) then
100 if (nelt(p) ^= 0) quit;
101 else
102 if (^ nullp(p)) quit;
103 end if;
104
105 else $ skip om images
106 if (^ is_om_ im)quit;
107 end if;
108
109 end while;
110
111 if is_based(map) then
112 build_spec(val, t_elmt, pos);
113 else
114 is_shared_ ebspec(pos) = yes;
115 val = ebspec(pos);
116 end if;
117
118 if (is_ebtemp(pos)) is_om_ val = yes;
119
120 build_spec(iter, t_elmt, pos);
121 if (is_ebtemp(pos)) is_om_ iter = yes; $ flag end of set
122
123 return;
124
125
126
127/test/ $ test for end of tuple or string iteration
128
129 add1(iter); $ increment and check against limit
130 if (value_ iter > lim) is_om_ iter = yes;
131
132 val = iter; $ copy into val.
133
134 return;
135
136
137case_om; $ om types
138
139 call err_om(9);
140
141 val = err_val(f_gen);
142 iter = err_val(f_gen);
143
144 return;
145
146
147/error/ $ illegal type for arg
148
149 call err_type(27);
150
151 val = err_val(f_gen);
152 iter = err_val(f_gen);
153
154 return;
155
156
157 end subr nextd;
1 .=member inextd
2 subr inextd(val, iter, arg);
3
4$ this routine initializes domain iterators.
5$ 'val' is set to the zero-th element of the set, etc. and
6$ 'iter' is set to point to the zero-th element.
7
8
9 size val(hs); $ iteration value
10 size iter(hs); $ pointer to iteration value
11 size arg(hs); $ specifier for string, tuple, or map
12
13 size p(ps); $ pointer to long value
14 size vpair(ps); $ pointer to value pair
15 size ipair(ps); $ pointer to iterator pair
16 size spec(hs); $ temporary specifier
17 size tmp(ps); $ pointer to template
18
19 size convsm(hs); $ converts set to map
20
21
22/begin/ $ begin execution
23
24
25 p = value_ arg; $ get pointer to set, tuple, etc.
26
27 go to case(otype_ arg) in t_min to t_max;
28
29
30/case(t_int)/ $ error types
31
34/case(t_atom)/
35
36/case(t_proc)/
37
38/case(t_lab)/
39
40/case(t_latom)/
41
42/case(t_lint)/
43
44/case(t_real)/
45
46 call err_type(28);
47
48 go to error;
49
50
51/case(t_elmt)/ $ element
52
53 deref(arg); go to begin;
54
55
stra 308/case(t_string)/ $ short character string
stra 309
56/case(t_istring)/
57
58/case(t_tuple)/ $ tuples
59
60/case(t_stuple)/
61
62 iter = zero;
63 val = zero;
64
65 return;
66
67
68/case(t_set)/ $ sets
69
70 arg = convsm(arg, f_umap);
71 if (otype_ arg ^= t_map) go to error; $ conversion failed
72
73
74/case(t_map)/ $ maps
75
76 p = value_ arg;
77 tmp = template(p);
78
79 if is_based(p) then
80 build_spec(val, t_elmt, tmp);
81 else
82 is_shared_ ebspec(tmp) = yes;
83 val = ebspec(tmp);
84 end if;
85
86 build_spec(iter, t_elmt, tmp);
87
88 return;
89
90
91case_om; $ om argument type
92
93 call err_om(10);
94
95
96/error/
97
98 val = err_val(f_gen);
99 iter = err_val(f_gen);
100
101 return;
102
103
104 end subr inextd;
1 .=member intro2
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$ ll iiiiiiiiii bbbbbbbbb
15$ ll iiiiiiiiii bbbbbbbbbb
16$ ll ii bb bb
17$ ll ii bb bb
18$ ll ii bbbbbbbbb
19$ ll ii bbbbbbbbb
20$ ll ii bb bb
21$ ll ii bb bb
22$ llllllllll iiiiiiiiii bbbbbbbbbb
23$ llllllllll iiiiiiiiii bbbbbbbbb
24$
25$
26$ t h e s e t l r u n t i m e l i b r a r y
27$
28$ p a r t t w o
29$
30$
31$ this software is part of the setl programming system
32$ address queries and comments to
33$
34$ setl project
35$ department of computer science
36$ new york university
37$ courant institute of mathematical sciences
38$ 251 mercer street
39$ new york, ny 10012
40$
1 .=member open
2 fnct sopen(na);
3
4$ this is the setl 'open' routine. we map the arguments into
5$ a little file identifier and file mode, then call the
6$ little file statement.
7
8 size na(ps); $ number of arguments on stack
9
10 size sopen(hs); $ returned value
11
12 size name(hs); $ file name
13 size mode(hs); $ mode name
14 size id(ps); $ file identifier
15 size str(sds_sz); $ file name as sds
16 size acs(ps); $ access code
17 size rc(hs); $ return code for eretsio
18
19 size bldsds(sds_sz); $ converts string to sds
20 size file_id(ps); $ looks up file id
21 size file_mode(ps); $ looks up file mode
22
23
24 name = stack_arg(1, na);
25 mode = stack_arg(2, na);
26
27 id = file_id(name, io_open);
28 acs = file_mode(mode);
29
30 str = bldsds(name);
31 sopen = heap(s_false); $ assume open will fail
32 call eretsio(id, rc, 1); $ set 'quiet' return if error
33 $ opening file.
34 if (rc) return;
35
36 go to case(acs) in io_get to io_write;
37
38/case(io_get)/
39
40 file id title = str, access = get;
41
42 endline(id);
43
44 go to esac;
45
46/case(io_print)/
47
48 file id title = str, access = print;
49 go to esac;
50
51
52/case(io_put)/
53
54 file id title = str, access = put;
55 go to esac;
56
57
58/case(io_read)/
59
60 file id title = str, access = read;
61 go to esac;
62
63
64/case(io_string)/
65
66 call err_fatal(11);
67
68
69/case(io_write)/
70
71 file id title = str, access = write;
72 go to esac;
73
74
75
76/esac/
77
78 if filestat(id,access)=0 then $ if could not open
79 call eretsio(id, rc, 0); $ set for temination if i/o error
80 id = file_id(name,io_close); $ delete file from maps
81 return;
82 end if;
83 call eretsio(id, rc, 0); $ set for termination if i/o error.
84 sopen = heap(s_true);
85
86
87
88 end fnct sopen;
1 .=member close
2 fnct sclose(na);
3
4$ this is the setl 'close' procedure.
5
6 size na(ps); $ number of interpreter arguments
7
8 size sclose(hs); $ condition code returned
9
10 size name(hs), $ file name
11 id(ps); $ file id
12
13 size file_id(ps); $ looks up file id
14
15
16 name = stack_arg(1, na);
17 id = file_id(name, io_close);
18
19 if (filestat(id, access)) file id access = release;
20
21 sclose = spec_om;
22
23
24 end fnct sclose;
1 .=member print
2 fnct print(na);
3
4$ this is the setl print function. it simply calls -print1- with
5$ the proper file number.
6
7 size na(ps); $ number of arguments
8
9 size print(hs), $ value returned
10 print1(hs), $ lower level function
11 file_id(ps); $ looks up file id
12
13 print = print1(out_file, na);
14
15
16 end fnct print;
1 .=member printa
2 fnct printa(na);
3
4$ this is the setl printa function. it is just like 'print'
5$ except that we must look up the file number.
6
7 size na(ps); $ number of arguments
8
9 size name(hs), $ file name
10 id(ps); $ file id
11
12 size printa(hs), $ value returned
13 print1(hs), $ lower level function
14 file_id(ps); $ finds file id
15
16
17 name = stack_arg(1, na);
18
strb 42 until 1; $ exit when file id has been determined.
strb 43 until 2; $ exit when not short null string.
strb 44 if (otype_ name ^= t_string) quit until 2;
strb 45 if (sc_nchars_ name ^= 0) quit until 2;
strb 46
strb 47 $ nullstring ---> standard output file
strb 48 id = out_file;
strb 49 quit until 1;
strb 50 end until 2;
strb 51 until 2; $ exit when not long null string.
strb 52 if (otype_ name ^= t_istring) quit until 2;
strb 53 if (ss_len(value_ name) ^= 0) quit until 2;
strb 54
strb 55 $ nullstring ---> standard output file
strb 56 id = out_file;
strb 57 quit until 1;
strb 58 end until 2;
strb 59
strb 60 id = file_id(name, io_put); $ look-up little file id
strb 61 end until 1;
25
26 printa = print1(id, na-1);
27
28
29 end fnct printa;
1 .=member print1
2 fnct print1(id, na);
3
4$ this routine is called from 'print' and 'printa' once the
5$ number of the output file has been determined. we iterate
6$ over the items to be printed, calling print2 to print each one.
7
8 size id(ps), $ file id
9 na(ps); $ number of arguments
10
11 size print1(hs); $ valur retuened
12
13 size j(ps); $ loop index
14
15 size print2(hs); $ lower level function
16
17$ before we start printing anything we reserve all the space that
18$ print2 will need. this includes space for recursion and for building
19$ pairs as it iterates over maps.
20
21 reserve(reserve_io);
22 can_collect = no;
23
24 do j = 1 to na;
25 print1 = print2(id, stack_arg(j, na));
26 end do;
27
28$ start a new line if either
29
30$ 1. we are in the middle of a line
31$ 2. we are printing zero items.
32
33 if (filestat(id, column) ^= 1 ! na = 0) put id, skip;
34
35 can_collect = yes; $ reenable garbage collection
36
37 return;
38
39 end fnct print1;
1 .=member print2
2 fnct print2(id, a);
3
4$ this is the main routine for streamed output. it prints a
5$ setl value 'a' onto file 'id'.
6
7$ print2 is recursive to handle sets and tuples. it assumes that
8$ the caller has already reserved the maximum space it will need
9$ for stacked variables, etc. this is necessary so that we do not
10$ have to backtrack output files after each garbage collection.
11
asca 17 .+ascebc.
asca 18$ convert strings to ebcdic before output.
asca 19 size ebchar(cs); $ ascii-to-ebcdic conversion function
asca 20 ..ascebc
25
26
27 size id(ps), $ file id
28 a(hs); $ item to print
29
30 size print2(hs); $ value returned
31
32 size arg(hs); $ copy of a
33
34
35 size tstart(ps); $ initial recursion stack pointer
36
37 size val(hs), $ untyped value
38 p(ps), $ misc. pointer
39 c(cs), $ character code
40 i(ps), $ loop index
41 j(ps); $ loop index
42
43 size pbits(ps), $ ptbits of packed tuple
44 pvect(ps), $ ptvect of tuple
45 bpos(ps); $ bit position in tuple
46
47 size ss(ssz); $ string specifier
48
49 size omval(hs); $ omega value
50
51 size tup(ps); $ pointer to tuple
52
53 size t1(hs), $ temporaries for value return from 'nexts'.
54 t2(hs);
55
56 size rout(sds_sz), $ routine name
57 stmt(ps); $ statement number
mjsa 32
mjsa 33 size strli(hs); $ convert long integer to string
58
59$ stacked variables
60
61 .=zzyorg b $ reset counters for stack offsets
62
63
64
65 local(retpt); $ return pointer
66
67 local(temp1); $ pointer to tuple or specifier for set
68 local(temp2); $ index in tuple or element of set
69 local(temp3);
70
71
72
73/begin/ $ begin execution
74
75 tstart = t; $ save recursion stack pointer
76
77 .=zzyorg a $ reset counter for return labels
78
79 arg = a;
80
81/entry/ $ recursive entry point
82
83 r_entry; $ increment recursion stack
84
85
86 /switch/ $ branch on type
87
88 go to case(otype_ arg) in t_min to t_max; $ branch on type
89
90
91
92
93/case(t_int)/ $ short integers
94
95 put id: ivalue_ arg, i;
96
97 go to exit;
98
99
100/case(t_string)/ $ short character strings
101
102 do j = 1 to sc_nchars_ arg;
stra 310 c = scchar(arg, j);
stra 311 .+ascebc if (ascebc_flag) c = ebchar(c); $ convert to ebcdic
104
105 put id: c, r(1);
106 end do;
107
108 go to exit;
109
110
111/case(t_atom)/ $ short atom
112
113 if arg = heap(s_true) then
114 put id, '#t';
115
116 elseif arg = heap(s_false) then
117 put id, '#f';
118
119 else
120 put id: 1r#, r(1): ivalue_ arg, i;
121 end if;
122
123 go to exit;
124
125
126/case(t_proc)/ $ procedures
127
128/case(t_lab)/ $ labels
129
130 call err_fatal(12);
131
132
133/case(t_latom)/ $ long atom
134
smfa 16 put id ,'#' :la_value(value_ arg),i;
136
137 go to exit;
138
139
140/case(t_elmt)/ $ element
141
142 deref(arg); $ get value and try again
143
144 go to switch;
145
146
147/case(t_lint)/ $ long integer
148
mjsa 34 arg = strli(arg);
mjsa 35 $ fall through to string case
153
154
155/case(t_istring)/ $ long character string
156
157 ss = value_ arg; $ get string specifier for argument
158
159$ iterate over string printing characters. obviously there-s alot of
160$ room for loop unrolling here.
161
162 do j = 1 to ss_len(ss);
163 c = icchar(ss, j);
asca 21 .+ascebc if (ascebc_flag) c = ebchar(c); $ convert to ebcdic
164
165 put id: c, r(1);
166 end do;
167
168 go to exit;
169
170
171/case(t_real)/ $ real
172
173 put id: rval(value_ arg), e(13, 6);
174
175 go to exit;
176
177
178/case(t_tuple)/ $ standard tuple
179
180 temp1 = value_ arg; $ get pointer to tuple
181 temp2 = 1; $ component index
182
183 put id: ltb_char, r(1), x(1); $ open tuple
184
185 while temp2 <= nelt(temp1);
186
187 arg = tcomp(temp1, temp2);
188 temp2 = temp2+1;
189
190 r_call;
191
192 put id, x(1); $ space between components
193
194 end while;
195
196 put id: rtb_char, r(1); $ close tuple
197
198 go to exit;
199
200
201/case(t_stuple)/ $ special tuple
202
203 put id: ltb_char, r(1), x(1); $ open tuple
204
205 tup = value_ arg;
206
207 go to tc(htype(tup)) in h_ptuple to h_rtuple;
208
209
210/tc(h_ptuple)/ $ packed tuple
211
212 temp1 = value_ arg; $ get pointer to tuple
213 temp2 = 1; $ iteration index
214
215 while temp2 <= nelt(temp1);
216
217 val = pcomp(temp1, temp2);
218 unpack(ptkey(temp1), val, arg);
219
220 r_call;
221
222 put id, x(1); $ space between components
223
224 temp2 = temp2 + 1;
225
226 end while;
227
228 put id: rtb_char, r(1); $ close tuple
229
230 go to exit;
231
232
233/tc(h_ituple)/ $ integer tuple
234
235 omval = tcomp(tup, 0); $ get omega value
236
237 do j = 1 to nelt(tup);
238 val = tcomp(tup, j);
239
240 if val ^= omval then
241 put id: val, i;
242 else
243 put id, '*';
244 end if;
245
246 put id, x(1);
247 end do;
248
249 put id: rtb_char, r(1); $ close tuple
250
251 go to exit;
252
253
254/tc(h_rtuple)/ $ real tuple
255
256 omval = tcomp(tup, 0); $ get omega value
257
258 do j = 1 to nelt(tup);
259 val = tcomp(tup, j);
260
261 if val ^= omval then
262 put id: val, e(13, 6);
263 else
264 put id, '*';
265 end if;
266
267 put id, x(1);
268 end do;
269
270 put id: rtb_char, r(1); $ close tuple
271
272 go to exit;
273
274
275/case(t_set)/ $ sets and maps
276
277/case(t_map)/
278
279$ all sets and maps are printed using the general next routine.
280
281 put id: lsb_char, r(1), x(1); $ open set
282
283 temp3 = arg;
284
285 call inext(t1, t2, temp3); $ initialize set iterator
286 temp1 = t1;
287 temp2 = t2;
288
289 while 1;
290 t1 = temp1;
291 t2 = temp2;
292
293 call nexts(t1, t2, temp3); $ advance iterator
294 temp1 = t1;
295 temp2 = t2;
296
297 if (is_om_ temp1) quit;
298
299 arg = temp1;
300 r_call;
301
302 put id, x(1);
303 end while;
304
305 put id: rsb_char, r(1); $ close set
306
307 go to exit;
308
309
310
311
312
313 case_om $ om types
314
315$ isolate errors from omegas
316
317 if otype_ arg = t_error then
318 call find_stmt(rout, stmt, value_ arg);
319
320 put id, '*** error at proc: ': rout, a,
321 ' stmt: ': stmt, i,
322 ' addr: ': value_ arg, i,
323 ' ***';
324 else
325 put id, '*';
326 end if;
327
328 go to exit;
329
330
331/exit/ $ recursive exit point
332
333 r_exit;
334
335 if t ^= tstart then $ recursive return
336 go to rlab(retpt) in 1 to zzya;
337 end if;
338
339 if (filestat(id, column) ^= 1) put id, x(1);
340
341
342 print2 = spec_om;
343
344 return;
345
346
347
348$ drop local variables
349
350 macdrop2(retpt, temp1)
351 macdrop2(temp2, temp3)
352
353
354 end fnct print2;
1 .=member readr
2 fnct readr(na);
3
4$ this is the setl read procedure. it simply calls -read1- with the
5$ appropriate file number.
6
7
8 size na(ps); $ number of arguments
9
10 size readr(hs); $ value returned
11
12 size read1(hs); $ lower level routine
13
14 access nsread; $ nameset with static variables
15
16
17 read_file = in_file;
18 readr = read1(na);
19
20
21 end fnct readr;
1 .=member reada
2 fnct reada(na);
3
4$ this is the setl -reada- routine. it looks up the little file
5$ identifier and calls -read1-.
6
7
8 size na(ps); $ number of arguments
9
10 size reada(hs); $ value returned
11
12 size name(hs); $ setl file name
13
14 size read1(hs), $ lower level function
15 file_id(ps); $ looks up little file identifier
16
17 access nsread; $ nameset with static variables
18
19
20 if read_case = read_init then $ get little file identifier
21 name = stack_arg(1, na);
22
strb 62 until 1; $ exit when file id has been determined.
strb 63 until 2; $ exit when not short null string.
strb 64 if (otype_ name ^= t_string) quit until 2;
strb 65 if (sc_nchars_ name ^= 0) quit until 2;
strb 66
strb 67 $ nullstring ---> standard input file
strb 68 read_file = in_file;
strb 69 quit until 1;
strb 70 end until 2;
strb 71 until 2; $ exit when not long null string.
strb 72 if (otype_ name ^= t_istring) quit until 2;
strb 73 if (ss_len(value_ name) ^= 0) quit until 2;
strb 74
strb 75 $ nullstring ---> standard input file
strb 76 read_file = in_file;
strb 77 quit until 1;
strb 78 end until 2;
strb 79
strb 80 read_file = file_id(name, io_get); $ look-up little file
strb 81 end until 1;
29 end if;
30
31 reada = read1(na-1);
32
33
34 end fnct reada;
1 .=member read1
2 fnct read1(na);
3
4$ this is the setl -read1- routine. like -getb-, it can be inter-
5$ rupted for garbage collections. the variable -read_indx- gives the
6$ index of the current argument in the argument list.
7
8
9 size na(ps); $ number of arguments
10
11 size read1(hs); $ value returned
12
13 size datum(hs); $ datum returned by -read2-
14
15 size read2(hs); $ lower level coded read routine
16
17 access nsread;
18
19
20 if read_case = read_init then $ initial entry
21
22$ make sure no other library routine is currently using the stack,
smfc 72$ since the formatted read routines are the only routines which format
24$ it correctly. this check is done by comparing the global stack
25$ pointer -t- with the global stack pointer on entry of the library,
26$ -savet-.
27
28 if (t ^= savet) call err_fatal(14);
29
30$ we keep two local stack pointers:
31
smfc 73$ read_t1: stack top an initial entry to formatted read routines
33
34$ read_t2: reference point to update -read_t1- after a garbage
35$ collection moved the stack.
36
37 read_t1 = t;
38 read_t2 = t;
39
40$ initialize the argument index
41
42 read_indx = 1;
43 last_id = read_file;
44
45 else $ continue read after garbage collection
46 read_t1 = read_t1 + (savet - read_t2); $ adjust stack pointer
47 read_t2 = savet;
48
49 end if;
50
51 while read_indx <= na;
52 datum = read2(read_file);
53 stack_arg(read_indx, na) = datum;
54
55 read_indx = read_indx + 1;
56 end while;
57
58 read1 = spec_om;
59
60
61 end fnct read1;
1 .=member read2
2 fnct read2(id);
3
4$ this routine reads the next item from file 'id' and converts it
5$ into its internal value.
6
7$ the actual -read2- routine handles the recursive cases; primitive
8$ cases are handled off line. on each recursive level we keep a
9$ count of the number of items read. when we begin reading a
10$ composite object, we push both the count, and a code of 0 for
11$ sets and 1 for tuples. both the count and the code are setl
12$ integers.
13
14$ when we enter read2 there are two possibilities:
15
16$ 1. we are in the middle of a read which was interrupted by a garbage
17$ collection. we jump to the appropriate label and continue the
18$ read.
19
20$ 2. we are starting a new read. at this point rd_char is undefined,
21$ and we must do getc to get the first character.
22
23$ after we are finished with each character we do a getc. when we
24$ finish reading each item rd_char contains the first character of
25$ the next item.
26
27$ when we finish reading the top level object we must back up one
28$ character so that it can be read again the next time we use this
29$ file.
30
31
32 size id(ps); $ little file identifier
33
34 size read2(hs); $ specifier returned
35
36 size readnum(hs), $ lower level read functions
37 readstr(hs),
38 rdbool(hs),
39 rdname(hs),
40 setform(hs), $ set-former utility
41 anyc(ps), $ seek character in given class
42 tupform(hs);
43
44 access nsread; $ nameset with static variable
45
46
47$ jump on read_case to the proper label, and either start or
48$ continue read.
49
50 go to case(read_case) in read_init to read_error;
51
52
53/case(read_init)/ $ initialze to start read
54
55 read_cntr = zero;
56
57 getc(id);
58
59
60/entry/ $ recursive entry point
61
62
63 if (anyc(rd_char,2)) rd_char = 1r ;
64$ 2 above should be ss_separ, code maps separators to blanks.
65 read_case = lexclass(rd_char);
66 go to case(read_case) in read_num to read_error;
67
68
69/case(read_num)/ $ read integer or real
70
71 heap(s_io1) = readnum(id); $ read number
72
73 go to exit;
74
75
76/case(read_str)/ $ read quoted string
77
78 heap(s_io1) = readstr(id); $ read string
79
80 go to exit;
81
82
83/case(read_set1)/ $ set former '@'
84
85 push2(read_cntr, zero);
86 savet = t;
87 read_t2 = t;
88
89 read_cntr = zero;
90
91 getc(id);
92 go to entry;
93
94
95/case(read_set2)/ $ set former '<'
96
97 getc(id);
98
99 if rd_char ^= 1r< then backc(id); end if;
100
101 go to case(read_set1);
102
103
104
105/case(read_tup1)/ $ start reading tuple
106
107 push2(read_cntr, one);
108 savet = t;
109 read_t2 = t;
110
111 read_cntr = zero;
112
113 getc(id);
114 go to entry;
115
116
117/case(read_tup2)/ $ tuple former '(' or '(/'
118
119 getc(id);
120
121 if rd_char ^= 1r/ then
122 backc(id);
123 end if;
124
125 go to case(read_tup1);
126
127
128
129/case(read_set3)/ $ end of set '\'
130
131$ see if the opening token was '@'.
132 if (heap(t + ivalue_ read_cntr) ^= zero) go to fail;
133
134 heap(s_io1) = setform(f_uset, ivalue_ read_cntr);
135
136 pop2(read_key, read_cntr);
137 savet = t;
138 read_t2 = t;
139
140 getc(id); $ get character after '\'
141
142 go to exit;
143
144
145/case(read_set4)/ $ end of set - '>>'
146
147 getc(id);
148
149 if rd_char ^= 1r> then backc(id); end if;
150
151 go to case(read_set3);
152
153
154/case(read_tup3)/ $ end of tuple ']' or ')'
155
156$ see if opening token was '['
157 if (heap(t + ivalue_ read_cntr) ^= one) go to fail;
158
159 heap(s_io1) = tupform(f_tuple, ivalue_ read_cntr);
160
161 pop2(read_key, read_cntr);
162 savet = t;
163 read_t2 = t;
164
165 getc(id); $ get character after ']'
166
167 go to exit;
168
169
170/case(read_tup4)/ $ end of tuple '/'
171
172 getc(id);
173 if (rd_char ^= 1r)) go to case(read_error);
174
175 go to case(read_tup3);
176
177
178
179/case(read_blank)/ $ blanks between items
180
181 until anyc(rd_char, 2) = no;
182 getc(id);
183 end until;
184
185$ if the blanks are followed by a comma then skip past it.
186 if rd_char = 1r, then
187 getc(id);
188 end if;
189
190 go to entry;
191
192/case(read_bool)/ $ boolean
193
194 heap(s_io1) = rdbool(id);
195 go to exit;
196
197
198/case(read_name)/ $ name (to be converted to string)
199
200 heap(s_io1) = rdname(id);
201 go to exit;
202
203
204/case(read_om)/ $ read omega
205
206
207 heap(s_io1) = spec_om;
208
209 getc(id); $ get next character
210
211 go to exit;
212
213
214/case(read_eof)/ $ trying to read past eof
215
216$ if we are at the outermost level, return omega. otherwise we
217$ abort.
218
219 if t = read_t1 then
220 heap(s_io1) = spec_om;
221 go to exit;
222
223 else
224 call err_fatal(15);
225
226 end if;
227
228
229/case(read_error)/ $ illegal starting character
230
231$ this error occurs when the next character cannot begin a legal
232$ input item.
233
234 call err_fatal(16);
235
236
237/fail/ $ mismatching brackets
238
239 call err_fatal(17);
240
241
242
243
244/exit/ $ recursive exit point
245
246 read_case = read_term;
247
248 if rd_char = 1r, then $ advance
249 getc(id);
250 end if;
251
252/case(read_term)/
253
254 if t ^= read_t1 then $ read next set/tuple element
255 push1(heap(s_io1));
256 savet = t;
257 read_t2 = t;
258
259 add1(read_cntr);
260 go to entry; $ read next item
261 end if;
262
263 $ n.b. t = read_t1
264
265 read_case = read_init; $ so we start fresh next time
266 backc(id); $ return next character
267
268 read2 = heap(s_io1); $ get result
269 heap(s_io1) = 0;
270
271
272 end fnct read2;
1 .=member readnum
2 fnct readnum(id);
3
4$ this routine reads an integer or real and returns a specifier
5$ for it. we assume that the value is small enough to fit in 1 word.
6
7
8 size id(ps); $ little file identifier
9
10 size readnum(hs); $ specifier returned
11
12 size p(ps), $ pointer to real
smfe 3 val1(ps); $ integer for character
14
smfe 4 real val; $ real to return
16
17 size read_neg(1); $ flags negative value
18
19 size expval(ws); $ exponent value in powers of 10
20
21 size numstrng (cs); $ number read as an array of characters
22 dims numstrng (253); $ maximum of 250 character long numbers
23
24 size word(hs); $ word for building ints
25 size len(ps); $ length of array actually used
26
27 size readint(hs); $ functions called
smfe 5 .+mc size ctpc(cs); $ converts character to primary case
mjsa 36 size i(ps); $ loop index
mjsa 37 size lint_flag(1); $ flags when integer must be long
mjsa 38 size ss(ssz); $ string specifier for numeric string
mjsa 39 size number_str(hs); $ specifier for numeric string
mjsa 40 size valli(hs); $ returns integer specifier
mjsa 41 size nulllc(ssz); $ function to allocate string space
mjsa 42
mjsa 43
mjsa 44$ we begin by making sure that we have all the heap space we are likely
mjsa 45$ to read. the largest quantity which might be read is a 251 digit long
mjsa 46$ integer. since the magnitude of this value so outweighs the other
mjsa 47$ types of numbers which might be read in, it is sufficient to reserve
mjsa 48$ space only for this long integer.
mjsa 49
mjsa 50 reserve(hl_lint + li_dbas_digits(253));
mjsa 51
mjsa 52 word = 0;
mjsa 53 len = 0;
smfe 6 lint_flag = no;
mjsa 55
mjsa 56 if rd_char = 1r- then
mjsa 57 read_neg = yes;
mjsa 58 getc(id);
mjsa 60
mjsa 61 elseif rd_char = 1r+ then
mjsa 62 read_neg = no;
mjsa 63 getc(id);
mjsa 64
mjsa 65 else
mjsa 66 read_neg = no; $ no sign therefore positive
mjsa 67 end if;
mjsa 68
mjsa 69
mjsa 70 while numeric(rd_char);
mjsa 71
smfe 7 if lint_flag = no then $ only if we have not detected
mjsa 73 val1 = dig_val(rd_char); $ a long integer should we do
mjsa 74 word = word * 10 + val1; $ these
smfe 8 if (word > maxsi) lint_flag = yes;
mjsa 76 end if;
mjsa 77
smfe 9 if (word ^= 0) len = len + 1;
mjsa 79
mjsa 80 if len = 251 then
mjsa 81 call err_fatal(18);
mjsa 82 elseif len > 0 then
mjsa 83 numstrng(len) = rd_char;
mjsa 84 end if;
mjsa 85
mjsa 86 getc(id);
mjsa 87
mjsa 88 end while;
mjsa 89
mjsa 90 .-mc if (rd_char ^= 1r. & rd_char ^= 1re) then
mjsa 91 .+mc if (rd_char ^= 1r. & ctpc(rd_char) ^= 1re) then
mjsa 92
smfe 10 if lint_flag = no then
smfe 11 if (read_neg) word = - word;
mjsa 94 put_intval(word, readnum);
mjsa 95 else
mjsa 96 $ transform numstrng to a setl string
smfe 12 ss = nulllc(len + read_neg);
mjsa 98
mjsa 99 if (read_neg) icchar(ss, 1) = 1r-;
mjsa 100
mjsa 101 do i = 1 to len;
mjsa 102 icchar(ss, i+read_neg) = numstrng(i);
mjsa 103 end do;
asca 22 .+ascebc if (ascebc_flag) call ascstr(ss); $ convert to ascii
mjsa 104
mjsa 105 ss_len(ss) = len + read_neg;
mjsa 106 build_spec(number_str, t_istring, ss);
mjsa 107
mjsa 108 $ call valli to actually create the long integer
mjsa 109 readnum = valli(number_str);
mjsa 110 end if;
mjsa 111
mjsa 112 return; $ since this was an integer we return
mjsa 113
mjsa 114 end if;
81$
82$ absorb fraction and exponent into array
83$
84 if word = 0 then
85 len = 1;
86 numstrng(len) = 1r0;
87 end if;
88
89 if (rd_char = 1r.) then
90 len = len + 1;
91 if len = 251 then
92 call err_fatal(18);
93 end if;
94 numstrng(len) = rd_char;
95 getc(id);
96
97 while numeric(rd_char);
98
99 len = len + 1;
100 if len = 251 then
101 call err_misc(57);
102 end if;
103 numstrng(len) = rd_char;
104
105 getc(id);
106
107 end while;
108
109 end if;
111$
112$ we are now at an exponent or at the end of the real
113$
115 .-mc if rd_char = 1re then
116 .+mc if ctpc(rd_char) = 1re then
117 $ absorb exponent into numstrng
118 len = len+1;
119 if len = 251 then
120 call err_misc(57);
121 end if;
122 numstrng(len) = rd_char;
123
124 getc(id);
125
126 if rd_char = 1r+ .or. rd_char = 1r- then
127
128 len = len + 1;
129 if len = 251 then
130 call err_misc(57);
131 end if;
132 numstrng(len) = rd_char;
133
134 getc(id);
135
136 end if;
137
138 while numeric(rd_char);
139
140 len=len+1;
141 if len = 251 then
142 call err_misc(57);
143 end if;
144 numstrng(len)=rd_char;
145
146 getc(id);
147
148 end while;
149
150 end if;
151
152$ we have now absorbed a real into the character array numstrng
153
154$ the conversion is done by a pair of little library routines, actu
155$ coded in assembly language.
156
157 call 7nvnum$io(numstrng, len, expval); $ formats numstrng for
158
159 if numstrng(len+2) then $ bad exponent
160 call err_misc(57);
161 end if;
162
163 if numstrng(len+3) > 1 then $ point present adjust exponent
164 expval = expval - (numstrng(len+3)-1);
165 end if;
166
167 call 7ncefr$io(val, numstrng, len, expval); $ conversion
168
169 if numstrng(len+2) then $ bad value message
170 call err_misc(57);
171 end if;
172
173 if (read_neg) val = - val;
174
175 get_real(p);
176 rval(p) = val;
177
178 build_spec(readnum, t_real, p);
179
180
181 end fnct readnum;
1 .=member readstr
2 fnct readstr(id);
3
4$ this routine reads a quoted string and returns a specifier for it.
5$ the flag -read_flag- is on if we were interrupted by a garbage
6$ collection during the last read. if so, we continue where we
7$ left off.
8
9$ the code for building strings is very conservative about calling
10$ primitives such as 'explc' to build and extend strings. this could
11$ by done much more efficiently by duplicating some of the string
12$ code in line. for the moment we play it safe, and avoid building
13$ illformed heap blocks.
14
stra 312$ for now, always return a long string. it would be possible to return
stra 313$ a single character result if the result string has length 0 or 1.
15
16 size id(ps); $ little file identifier
17
18 size readstr(hs); $ specifier returned
19
20 size nulllc(ssz), $ generates null string specifier
21 convert(hs); $ conversion routine
asca 23 .+ascebc size aschar(cs); $ ebcdic-to-ascii conversion
22
23 access nsread;
24
25
26 if (read_flag) go to loop; $ continue where we left off.
27
28
29/init/ $ initialize for read
30
31 read_flag = yes;
32
33$ initialize read_len to 0 and heap(s_io2) to the null
34$ string.
35
36 read_len = 0;
37 build_spec(heap(s_io2), t_istring, nulllc(0));
38
39/loop/ $ read characters
40
41 while 1;
43 if mod(read_len, chpw) = 0 then $ current word is full
44 read_ss = value(s_io2);
45 call explc(read_ss, read_len+1);
46 value(s_io2) = read_ss;
47 end if;
48
49 getc(id);
50
51 if filestat(id, end) then
52 call err_misc(45);
53 quit;
54 end if;
55
56 if rd_char = 1r' then
57 getc(id);
58 if (rd_char ^= 1r') quit;
59 end if;
60
61 read_len = read_len + 1;
asca 24 .+ascebc.
asca 25 if (ascebc_flag) rd_char = aschar(rd_char); $ change to ascii
asca 26 ..ascebc
62 icchar(value(s_io2), read_len) = rd_char;
63
64 .+ssi ss_len(value(s_io2)) = read_len;
65 .-ssi ss_len(heap(s_io2)) = read_len;
66
67 end while;
68
69
70 readstr = heap(s_io2);
71 read_flag = no; $ indicate read done
72
73
74 end fnct readstr;
1 .=member rdbool
2 fnct rdbool(id);
3
4$ this routine reads a boolean from file 'id'.
5
6
7 size id(ps); $ little file identifier
8
9 size rdbool(hs); $ specifier returned
10
11 .+mc size ctpc(cs); $ converts character to primary case
12
13 getc(id);
14
15 .+mc rd_char = ctpc(rd_char); $ fold to primary case
16
17 if rd_char = 1rt then
18 rdbool = heap(s_true);
19 elseif rd_char = 1rf then
20 rdbool = heap(s_false);
21 else
22 call err_fatal(16);
23 rdbool = err_val(f_gen);
24 end if;
25
26 getc(id); $ get next char
27
28
29 end fnct rdbool;
1 .=member rdname
2 fnct rdname(id);
3
4$ this routine reads a name and returns a specifier for it.
5$ the name is returned in the form of a setl string.
6
7$ the flag -read_flag- is on if we were interrupted by a garbage
8$ collection during the last read. if so, we continue where we
9$ left off.
10
11$ the code for building strings is very conservative about calling
12$ primitives such as 'explc' to build and extend strings. this could
13$ by done much more efficiently by duplicating some of the string
14$ code in line. for the moment we play it safe, and avoid building
15$ illformed heap blocks.
16
17
18 size id(ps); $ little file identifier
19
20 size rdname(hs); $ specifier returned
21
22 size nulllc(ssz); $ generates null string specifier
23 size anyc(ps); $ searches for character in string set
24 size convert(hs); $ conversion routine
asca 27 .+ascebc size aschar(cs); $ ebcdic-to-ascii conversion
25
26 access nsread;
27
28
29 if ^ read_flag then
30 read_flag = yes; $ indicate start of read
31
32 $ initialize read_len and heap(s_io2)
33 build_spec(rdname, t_istring, nulllc(1));
34 heap(s_io2) = rdname;
35
36 read_ss = value_ rdname; read_len = 1;
asca 28 .+ascebc if (ascebc_flag) rd_char = aschar(rd_char); $ change to ascii
37 icchar(read_ss, 1) = rd_char; ss_len(read_ss) = 1;
38 end if;
39
40 read_ss = value(s_io2);
41
42 while 1;
43 if mod(read_len, chpw) = 0 then $ current word is full
44 call explc(read_ss, read_len+1);
45 value(s_io2) = read_ss;
46 end if;
47
48 getc(id);
49
50 if (filestat(id, end)) quit while 1;
51 if (anyc(rd_char, 4+8+16+32) = no) quit while 1;
52 $ above matches letter, digit or underline
53
asca 29 .+ascebc if (ascebc_flag) rd_char = aschar(rd_char); $ change to ascii
54 read_len = read_len + 1; ss_len(read_ss) = read_len;
55 icchar(read_ss, read_len) = rd_char;
56 end while 1;
57
58 rdname = heap(s_io2);
59 read_flag = no; $ indicate read done
60
61
62 end fnct rdname;
1 .=member putr
2 fnct putr(na);
3
4$ this is the setl 'put' function.
5
6 size na(ps); $ number of arguments
7
8 size putr(hs); $ value returned
9
strb 82 size name(hs); $ file name
strb 83 size id(ps); $ little file id
strb 84 size rc(ws); $ return code
strb 85 size arg(hs); $ item to be output
strb 86 size ss(ssz); $ string specifer
strb 87 size i(ps); $ loop index
18
strb 88 size file_id(ps); $ looks up little file id
strb 89 size nulllc(ssz); $ allocates null string
20
21
strb 90 .-env_pss.
strb 91 call err_fatal(49);
24 .+env_pss.
25
26 name = stack_arg(1, na);
27
strb 92 until 1; $ exit when file id has been determined.
strb 93 until 2; $ exit when not short null string.
strb 94 if (otype_ name ^= t_string) quit until 2;
strb 95 if (sc_nchars_ name ^= 0) quit until 2;
strb 96
strb 97 $ nullstring ---> standard output file
strb 98 id = out_file;
strb 99 quit until 1;
strb 100 end until 2;
strb 101 until 2; $ exit when not long null string.
strb 102 if (otype_ name ^= t_istring) quit until 2;
strb 103 if (ss_len(value_ name) ^= 0) quit until 2;
strb 104
strb 105 $ nullstring ---> standard output file
strb 106 id = out_file;
strb 107 quit until 1;
strb 108 end until 2;
strb 109
strb 110 id = file_id(name, io_put); $ look-up little file id
strb 111 end until 1;
34
37 if (filestat(id, column) ^= 1) put, skip; $ new line
38
39 do i = 2 to na;
40 arg = stack_arg(i, na);
41
strb 112 if otype_ arg = t_string then
strb 113 ss = nulllc(1); ss_len(ss) = sc_nchars_ arg;
strb 114 if (sc_nchars_ arg) icchar(ss, 1) = scchar(arg, 1);
strb 115 elseif otype_ arg = t_istring then
strb 116 ss = value_ arg;
strb 117 else
strb 118 call err_type(29);
strb 119 cont do;
strb 120 end if;
strb 121
strb 122 .+ascebc.
strb 123 $ if ascii mode, convert string to ebcdic before output.
strb 124 if (ascebc_flag) call ebcstr(ss);
strb 125 ..ascebc
strb 126 call envpss(id, rc, ss, heap);
strb 127 .+ascebc.
strb 128 $ if ascii mode, convert string to ebcdic before output.
strb 129 if (ascebc_flag) call ascstr(ss);
strb 130 ..ascebc
47 end do;
48
49 putr = spec_om;
50
51 ..env_pss
52
53
54 end fnct putr;
1 .=member getr
2 fnct getr(na);
3
4$ this is the setl 'get' routine.
5
6 size na(ps); $ number of arguments
7
8 size getr(hs); $ value returned
9
10 size name(hs); $ file name
11 size id(hs); $ little file identifier
12 size spec(hs); $ datum to be read
13 size len(ps); $ linesize
14 size ss(ssz); $ string specifier
15 size ptr(ps); $ pointer to character block
16 size rc(ps); $ return code from little getvsio
17 size i(ps); $ loop index
18
19 size file_id(ps); $ looks up file id
20 size nulllc(ssz); $ builds null string
21
22
strb 131 .-env_gss.
strb 132 call err_fatal(49);
25 .+env_gss.
26
27 name = stack_arg(1, na);
28
strb 133 until 1; $ exit when file id has been determined.
strb 134 until 2; $ exit when not short null string.
strb 135 if (otype_ name ^= t_string) quit until 2;
strb 136 if (sc_nchars_ name ^= 0) quit until 2;
strb 137
strb 138 $ nullstring ---> standard input file
strb 139 id = in_file;
strb 140 quit until 1;
strb 141 end until 2;
strb 142 until 2; $ exit when not long null string.
strb 143 if (otype_ name ^= t_istring) quit until 2;
strb 144 if (ss_len(value_ name) ^= 0) quit until 2;
strb 145
strb 146 $ nullstring ---> standard input file
strb 147 id = in_file;
strb 148 quit until 1;
strb 149 end until 2;
strb 150
strb 151 id = file_id(name, io_get); $ look-up little file id
strb 152 end until 1;
35
36 last_id = id; $ update 'last input file accessed'
37
38 len = filestat(id, linesize);
39 $
40 $ we begin by allocating a null string for each of the
41 $ arguments. this way we cannot run out of space after we
42 $ have started the read.
43 $
44 do i = 2 to na;
45 ss = nulllc(len); ss_len(ss) = len;
46
47 build_spec(spec, t_oistring, ss);
48 stack_arg(i, na) = spec;
49 end do;
50 $
51 $ then we read the next (na-1) lines of file 'id'
52 $
53 do i = 2 to na;
54 ss = value_ stack_arg(i, na);
55
56 call envgss(id, rc, ss, heap); if (rc ^= 0) quit do;
asca 38 .+ascebc if (ascebc_flag) call ascstr(ss); $ convert to ascii
57
58 value_ stack_arg(i, na) = ss;
59 is_om_ stack_arg(i, na) = no;
60 end do;
61
62 endline(id); $ set cursor to end of line
63
64 getr = spec_om;
65
66 ..env_gss
67
68
69 end fnct getr;
1 .=member ascebc
2 .+ascebc.
3 subr ascstr(ss); $ convert string to ascii
4
5 size ss(ssz); $ string specifier
6 size i(ps); $ loop index
7 size aschar(cs); $ ebcdic-to-ascii conversion function
8
9 do i = 1 to ss_len(ss);
10 icchar(ss,i) = aschar(icchar(ss,i));
11 end do;
12
13 end subr ascstr;
14 ..ascebc
1 .=member ebcstr
2 .+ascebc.
3 subr ebcstr(ss); $ convert string to ebcdic
4
5 size ss(ssz); $ string specifier
6 size i(ps); $ loop index
7 size ebchar(cs); $ ascii-to-ebcdic conversion function
8
9 do i = 1 to ss_len(ss);
10 icchar(ss,i) = ebchar(icchar(ss,i));
11 end do;
12
13 end subr ebcstr;
14 ..ascebc
1 .=member putb
2 fnct putb(na);
3
4$ this is the setl 'putb' function. it gets the identifier then
5$ calls putb1 to write out each argument.
6
7 size na(ps); $ number of arguments
8
9 size putb(hs); $ value returned
10
11 size name(hs), $ file name
12 id(hs), $ file id
13 j(ps); $ loop index
14
15 size putb1(hs), $ lower level function
16 file_id(ps); $ looks up file id
17
18
19 name = stack_arg(1, na);
20 id = file_id(name, io_write);
21
22$ before we start writing anything out we reserve all the space that
23$ putb1 is likely to need and disbale the garbage collector.
24
25 reserve(reserve_io);
26 can_collect = no;
27
28 do j = 2 to na;
29 putb = putb1(id, stack_arg(j, na));
30 end do;
31
32 can_collect = yes; $ renable garbage collector
33
34
35 end fnct putb;
1 .=member putb1
2 fnct putb1(id, a);
3
4$ this is the main routine for binary output. it writes an object
5$ 'a' onto file 'id'.
6
7$ the external form begins with a binary header block which
8$ has a type field and a value field. the type field is one
9$ of the binary types bt_xxx.
10
11$ the external form of a setl value is a function of its type:
12
13$ 1. short objects:
14
15$ short objects are represented according to their type.
16$ in general, a one-word data block is written.
17
18$ 2. reals:
19
20$ reals are represented by header block followed by their
21$ rval fields.
22
23$ 3. long ints, strings, and atoms:
24
25$ these are represented by:
26
27$ a. header block of appropriate type
28$ b. a data block.
29
30$ 4. tuples:
31
32$ tuples are represented by:
33
34$ header block with type bt_tuple and bh_val set to zero.
35$ there follows binary block for each element.
36$ last entry followed by binary header block with value field of one.
37
38$ 5. sets and maps
39
40$ sets and maps have a representation similar to tuples
41$ except that the type code is set or map respectively.
42
43$ objects of type element are always dereferenced before writing them
44$ out.
45
46
49 size id(ps), $ file id
50 a(hs); $ value to write out
51
52 size putb1(hs); $ value returned
53
54 size arg(hs); $ copy of a
55
56 size tstart(ps); $ initial recursion stack pointer
57
58 size val(hs), $ untyped value
59 spec(hs), $ specifier
60 p(ps), $ misc. pointer
61 len(ps), $ block length
62 i(ps), $ loop index
63 j(ps); $ loop index
64
65 size pbits(ps), $ ptbits of packed tuple
66 pvect(ps), $ ptvect of tuple
67 bpos(ps); $ bit position in tuple
68
69 size ss(ssz); $ string specifier
70
71 size putbhdrblk(hs); $ binary header block word
72
73 size tup(ps); $ pointer to tuple
74
75 size t1(hs), $ temporaries for values from 'nexts'
76 t2(hs);
77
mjsa 115 size putbli(hs); $ function called for long integers
78 size var_id(sds_sz); $ function called
79
80$ stacked variables
81
82 .=zzyorg b $ reset counters for stack offsets
83
84 local(retpt); $ return pointer
85
86 local(temp1); $ pointer to tuple or specifier for set
87 local(temp2); $ index in tuple or element of set
88 local(temp3);
89
90$ local macros
91
92 +* putbhdr(t, v) = $ put binary header block
93 putbhdrblk = 0;
94 bh_typ_ putbhdrblk = t;
95 bh_val_ putbhdrblk = v;
96 write id, putbhdrblk;
97 **
98
99 +* putbdat1(v) = $ write one word data block
100 write id, v;
101 **
102
103 +* putbdatn(p, n) = $ write n word data block from heap
104 write id, heap(p) to heap(p+(n)-1);
105 **
106
107
110 tstart = t; $ save recursion stack pointer
111
112 .=zzyorg a $ reset counter for return labels
113
114 arg = a; $ copy argument
115
116
117/entry/ $ recursive entry point
118
119 r_entry; $ increment recursion stack
120
121
122/switch/
123
124
125 go to case(otype_ arg) in t_min to t_max; $ branch on type
126
127
128/case(t_int)/ $ short integers
129
smfd 34 if ivalue_ arg < bh_val_max then
smfd 35 putbhdr(bt_sint, ivalue_ arg);
smfd 36 else
smfd 37 putbhdr(bt_int, 1);
smfd 38 putbdat1(ivalue_ arg);
smfd 39 end if;
smfd 40
132 go to exit;
133
134/case(t_string)/ $ short character strings
135
stra 314 len = sc_nchars_ arg;
stra 315
stra 316 if len = 0 then $ write null string
stra 317 putbhdr(bt_string, len);
stra 318 else $ write character, since sc_max = 1
stra 319 putbhdr(bt_char, scchar(arg, 1));
stra 320 end if;
stra 321
stra 322 go to exit;
stra 323
137
138/case(t_atom)/ $ short atom
139
140 if arg = heap(s_true) then
141 putbhdr(bt_bool, 1);
142 putbdat1(1);
143
144 elseif arg = heap(s_false) then
145 putbhdr(bt_bool, 1);
146 putbdat1(0);
147
148 else
149 putbhdr(bt_atom, 1);
150 putbdat1(value_ arg);
151 end if;
152
153 go to exit;
154
155
156/case(t_proc)/ $ procedures
157
158/case(t_lab)/ $ labels
159
160 go to error;
161
162
163/case(t_latom)/ $ long atom
164
165$ long atom block will be more than one word so that
166$ can distinguish this case on subsequent read.
167
168 p = value_ arg;
169 len = la_nwords(p);
170
171 putbhdr(bt_atom, len);
172 putbdatn(p, len);
173
174 go to exit;
175
176
177/case(t_elmt)/ $ element
178
179 deref(arg); go to switch;
180
181
182/case(t_lint)/ $ long integer
183
mjsa 116 putb1 = putbli(id, arg);
190
191 go to exit;
192
193
194/case(t_istring)/ $ long character string
195
196 ss = value_ arg;
197 p = ss_ptr(ss);
198 len = ss_len(ss);
199
200 putbhdr(bt_string, len);
201
202$ write characters left-justified with zero fill
203
204 t1 = 0; $ used to build the word to be written
205 p = hs + 1; $ character position
206 do i = 1 to len;
207 p = p - cs; $ move to next character
208 .f. p, cs, t1 = icchar(ss, i); $ insert character
209
210 if p = 1 then $ if the word is filled, write it out
211 putbdat1(t1);
212
213 p = hs + 1; $ reset the position
214 t1 = 0;
215 end if;
216 end do;
217
218$ write the last word if it contains any characters
219
220 if p ^= hs + 1 then
221 putbdat1(t1);
222 end if;
223
224 go to exit;
225
226
227/case(t_real)/ $ real
228
229$ n.b. this code assumes that 'rval' yields a word-size quantity
230
231 putbhdr(bt_real, 1);
232 putbdat1(rval(value_ arg));
233
234 go to exit;
235
236
237/case(t_tuple)/ $ tuples
238
239 temp1 = value_ arg;
240 temp2 = 1;
241
242 putbhdr(bt_tuple, 0);
243
244 while temp2 <= nelt(temp1);
245
246 arg = tcomp(temp1, temp2);
247 temp2 = temp2+1;
248
249 r_call;
250 end while;
251
252 putbhdr(bt_tuple, 1); $ mark end of tuple
253
254 go to exit;
255
256
257/case(t_stuple)/ $ special tuple
258
259 go to error;
260
261
262/case(t_set)/ $ sets and maps
263
264/case(t_map)/
265
266$ all sets and maps are printed using the general next routine
267
268 temp3 = arg;
269
270 putbhdr(bt_set, 0);
271
272 call inext(t1, t2, temp3); $ initialize set iterator
273 temp1 = t1;
274 temp2 = t2;
275
276 while 1;
277 t1 = temp1;
278 t2 = temp2;
279
280 call nexts(t1, t2, temp3); $ advance iterator
281 temp1 = t1;
282 temp2 = t2;
283
284 if (is_om_ temp1) quit;
285
286 arg = temp1;
287 r_call;
288 end while;
289
290 putbhdr(bt_set, 1); $ mark end of set
291
292 go to exit;
293
294
295case_om $ omega types
296
297 if (otype_ arg = t_error) call err_fatal(45);
298
299 putbhdr(bt_omega, 0);
300
301 go to exit;
302
303
304/error/ $ error exit
305
306 call err_fatal(20);
307
308
309/exit/ $ recursive exit point
310
311 r_exit;
312
313 if t ^= tstart then $ recursive return
314 go to rlab(retpt) in 1 to zzya;
315 end if;
316
317 putb1 = spec_om;
318
319 return;
320
321
322$ drop local variables
323
324 macdrop2(retpt, temp1)
325 macdrop2(temp2, temp3)
326
327$ drop local macros
328
329 macdrop (putbhdr)
330 macdrop2(putbdat1, putbdatn)
331
332
333 end fnct putb1;
1 .=member getb
2 fnct getb(na);
3
4$ this is the setl -getb- routine. like -read1-, it can be inter-
5$ rupted for garbage collections. the variable -getb_indx- gives the
6$ index of the current argument in the argument list.
7
8
9 size na(ps); $ number of arguments
10
11 size getb(hs); $ value returned
12
13 size name(hs); $ file name
14
15 size datum(hs); $ datum returned by -getb1-
16
17 size nulltup(hs), $ builds null tuple
18 file_id(ps), $ looks up file id
19 getb1(hs); $ lower level routine
20
21 access nsgetb;
22
23
24$ begin execution
25
26 if getb_case = getb_init then $ initial entry
27
28$ make sure no other library routine is currently using the stack,
29$ since the binary read routines are the only routines which format
30$ it correctly. this check is done by comparing the global stack
31$ pointer -t- with the global stack pointer on entry of the library,
32$ -savet-.
33
34 if (t ^= savet) call err_fatal(21);
35
36$ we keep two local stack pointers:
37
38$ getb_t1: stack top at initial entry to binary read routines
39
40$ getb_t2: reference point to update -getb_t1- after a garbage
41$ collection moved the stack.
42
43 getb_t1 = t;
44 getb_t2 = t;
45
46$ the first argument of the argument list is the setl file name.
47$ first find the little file identifier corresponding to this name.
48
49 name = stack_arg(1, na);
50 getb_file = file_id(name, io_read);
51
52 getb_indx = 2;
53
54 last_id = getb_file; $ update 'last input file accessed'
55
56 else $ continue read after garbage collection
57 getb_t1 = getb_t1 + (savet - getb_t2); $ adjust stack pointer
58 getb_t2 = savet;
59
60 end if;
61
62 while getb_indx <= na;
63 datum = getb1(getb_file);
64 stack_arg(getb_indx, na) = datum;
65
66 getb_indx = getb_indx + 1;
67 end while;
68
69 getb = spec_om;
70
71
72 end fnct getb;
1 .=member getb1
2 fnct getb1(id);
3
4$ this is the main binary read routine. it reads a setl object
5$ from file 'id' and returns its value.
6
7$ the external form of a setl object consists of a binary header
8$ block followed by a type dependent data block. this is
9$ decsribed in greater detail in the binary write routine
10$ putb1.
11
12$ getb is somewhat similar to the stream read routine except that
13$ instead of jumping on the first character of each object we jump
14$ on the type code of its specifier.
15
16$ we keep a count of the number of items read at each level of
17$ recursion. the counter is kept as a setl integer so that the
18$ stack remains valid.
19
20$ there are three possibilities on entry to the routine:
21
22$ 1. we are about to start a new read: read the outermost header
23$ and jump on its type.
24
25$ 2. we have already read in the header for a long object,
26$ and ran out of space before we could read in the data words:
27$ jump on the type of the header.
28
29$ 3. we have just finished reading an object and ran out of space
30$ as we were about to push it onto the stack.
31
32$ these cases are identifier by the macros 'getb_xxxx'; the current
33$ case is given by the variable 'getb_case'.
34
35
36 size id(ps); $ little file identifier
37
38 size getb1(hs); $ specifier returned
39
40 size j(ps), $ loop index
41 p(ps); $ pointer into getb_word
42
43 size temp(ws); $ used to read real
44
45 size setform(hs), $ set former
46 tupform(hs), $ tuple former
47 nulllc(ssz); $ null string
mjsa 117 size getbli(hs); $ function called for long integers
48
49 access nsgetb; $ static variables
50
51
52 go to c(getb_case) in getb_init to getb_term;
53
54
55/c(getb_init)/ $ initialize and start new read
56
57/entry/
58
59 read id, getb_word;
60
61 if filestat(id, end) then
62 getb1 = err_val(f_gen);
63 return;
64 end if;
65
66 getb_typ = bh_typ_ getb_word;
67 getb_val = bh_val_ getb_word;
68
69 getb_case = getb_cont;
70
71
72/c(getb_cont)/
73
74 if (getb_typ < bt_min ! bt_max < getb_typ) call err_fatal(62);
75 go to case(getb_typ) in bt_min to bt_max;
76
77
smfd 41/case(bt_sint)/ $ unsigned integer
smfd 42
smfd 43 put_intval(getb_val, getb_spec);
smfd 44 heap(s_io1) = getb_spec;
smfd 45
smfd 46 go to exit;
smfd 47
smfd 48
78/case(bt_int)/ $ integer
79
mjsa 118 reserve(hl_lint + getb_val);
mjsa 119
mjsa 120 getb_spec = getbli(id, getb_val);
mjsa 121 heap(s_io1) = getb_spec;
87
88 go to exit;
89
90
91/case(bt_real)/ $ real
92
93 get_real(getb_ptr);
94 read id, temp; rval(getb_ptr) = temp;
95
96 build_spec(getb_spec, t_real, getb_ptr);
97
98 heap(s_io1) = getb_spec;
99
100 go to exit;
stra 324
stra 325
stra 326/case(bt_char)/ $ character
stra 327
stra 328 getb_spec = spec_char; $ one-character template
stra 329 scchar(getb_spec, 1) = getb_val;
stra 330 heap(s_io1) = getb_spec;
stra 331
stra 332 go to exit;
101
102
103/case(bt_string)/ $ character string
stra 333
stra 334 if getb_val <= sc_max then $ can store as short string
stra 335 if getb_val = 0 then $ null string
stra 336 build_spec(getb_spec, t_string, 0);
stra 337 else
stra 338 read id, getb_word; $ get data word
stra 339 getb_spec = spec_char; $ one-character template
stra 340 scchar(getb_spec, 1) = .f. hs+1-cs, cs, getb_word;
stra 341 end if;
stra 342
stra 343 heap(s_io1) = getb_spec;
stra 344
stra 345 go to exit;
stra 346 end if;
104
105 getb_ss = nulllc(getb_val); $ null string of proper length
106 ss_len(getb_ss) = getb_val; $ set length
107 build_spec(getb_spec, t_istring, getb_ss);
108
109 p = 1;
110
111 do j = 1 to getb_val;
112 if p = 1 then $ the current word is exhausted
113 read id, getb_word;
114 p = hs + 1;
115 end if;
116
117 p = p - cs; $ advance to the next character
118 icchar(getb_ss, j) = .f. p, cs, getb_word;
119 end do;
120
121 heap(s_io1) = getb_spec;
122
123 go to exit;
124
125
126/case(bt_bool)/ $ boolean
127
128 read id, getb_word;
129
130 if getb_word then
131 heap(s_io1) = heap(s_true);
132 else
133 heap(s_io1) = heap(s_false);
134 end if;
135
136 go to exit;
137
138
139/case(bt_atom)/ $ atom
140
141 if getb_val = 1 then $ short atom
142 read id, getb_word;
143 build_spec(getb_spec, t_atom, getb_word);
144
145 else $ long atom
146 get_heap(getb_val, getb_ptr);
147 read id, heap(getb_ptr) to heap(getb_ptr+getb_val-1);
148 build_spec(getb_spec, t_latom, getb_ptr);
149 end if;
150
151 heap(s_io1) = getb_spec;
152
153 go to exit;
154
155
156/case(bt_tuple)/ $ standard tuple
157
158 if getb_val = 1 then $ marks end of tuple
159
160 heap(s_io1) = tupform(f_tuple, ivalue_ getb_cntr);
161
162 pop1(getb_cntr);
163 savet = t;
164 getb_t2 = t;
165
166 go to exit;
167
168 else
169 push1(getb_cntr);
170 savet = t;
171 getb_t2 = t;
172
173 getb_cntr = zero;
174 go to entry;
175 end if;
176
177
178/case(bt_set)/ $ sets
179
180 if getb_val = 1 then $ marks end of set
181
182 heap(s_io1) = setform(f_uset, ivalue_ getb_cntr);
183
184 pop1(getb_cntr);
185 savet = t;
186 getb_t2 = t;
187
188 go to exit;
189
190 else
191 push1(getb_cntr);
192 savet = t;
193 getb_t2 = t;
194
195 getb_cntr = zero;
196 go to entry;
197 end if;
198
199
200/case(bt_map)/ $ maps
201
202 if getb_val = 1 then $ marks end of set
203
204 heap(s_io1) = setform(f_umap, ivalue_ getb_cntr);
205
206 pop1(getb_cntr);
207 savet = t;
208 getb_t2 = t;
209
210 go to exit;
211
212 else
213 push1(getb_cntr);
214 savet = t;
215 getb_t2 = t;
216
217 getb_cntr = zero;
218 go to entry;
219 end if;
220
221
222/case(bt_omega)/ $ omega case
223
224 heap(s_io1) = spec_om;
225 go to exit;
226
227
228/error/ $ error exit
229
230 call err_fatal(22);
231
232
233/exit/ $ recursive exit point
234
235 getb_case = getb_term;
236
237
238/c(getb_term)/
239
240 if t = getb_t1 then $ convert result and return
241
242 getb1 = heap(s_io1);
243 heap(s_io1) = 0;
244
245 getb_case = getb_init;
246
247 else $ read the next tuple/set/map element
248 push1(heap(s_io1));
249 savet = t;
250 getb_t2 = t;
251
252 add1(getb_cntr);
253 go to entry;
254 end if;
255
256
257 end fnct getb1;
1 .=member putk
2 fnct putk(na);
3
4$ this is the setl -putk- routine.
5
6 size na(ps); $ number of arguments
7
8 size putk(hs); $ value returned
9
10 call err_fatal(24);
11
12 end fnct putk;
1 .=member getk
2 fnct getk(na);
3
4$ this is the setl -getk- routine.
5
6 size na(ps); $ number of arguments
7
8 size getk(hs); $ value returned
9
10 call err_fatal(27);
11
12 end fnct getk;
1 .=member getf
2 fnct getf(na);
3$
4$ this is the setl -getf- routine. like -read1-, it can be inter-
5$ rupted for garbage collections. the variable -intf_indx- gives the
6$ index of the current argument in getf's argument list, and the
7$ the variable -intf_argp- gives the index of the current argument
8$ in the interface parameter list.
9$
10 size na(ps); $ number of arguments
11
12 size getf(hs); $ specifier returned
13
14 size datum(hs); $ datum returned by getf1
15
16 size getf1(hs); $ lower level routine
17
18 access nsintf; $ global nameset with static variables
19
20
21 .-defenv_envfor.
22
23 call err_fatal(49);
24
25 .+defenv_envfor.
26
27 if intf_case = intf_init then $ initial entry
28
29 intf_spec = stack_arg(1, na);
30 if (otype_ intf_spec ^= t_int) call err_fatal(57);
31 intf_argp = ivalue_ intf_spec;
32
33 if (intf_argp-1) + (na-1) > nelt(value(s_intf)) then
34 call err_fatal(58);
35 end if;
36
37 intf_indx = 2;
38 intf_case = intf_cont;
39 end if;
40
41 while intf_indx <= na;
42 datum = getf1(tcomp(value(s_intf), intf_argp));
43 stack_arg(intf_indx, na) = datum;
44
45 intf_indx = intf_indx + 1;
46 intf_argp = intf_argp + 1;
47 end while;
48
49 intf_case = intf_init;
50
51 getf = spec_om;
52
53 ..defenv_envfor
54
55
56 end fnct getf;
1 .=member getf1
2
3
4 .+defenv_envfor.
5
6
7 fnct getf1(arg);
8$
9$ this function controls the copy semantics between the interface and
10$ the setl system per se.
11$
12 size arg(ws); $ specifier for argument
13
14 size getf1(hs); $ specifier returned
15
16 size p(ps); $ pointer to heap block
stra 347 size ss(ssz); $ string specifier
stra 348 size len(ps); $ length of string
17
18 size convert(hs); $ general conversion utility
19 size copy1(hs); $ general copy utility
20
21 access nsintf; $ global nameset with static variables
22
23
24 go to case(otype_ arg) in t_min to t_max;
25
26
27/case(t_int)/ $ short integer
28
29 getf1 = arg;
30 return;
31
32
33/case(t_string)/ $ short character string
34
35/case(t_atom)/ $ short atom
36
37/case(t_proc)/ $ procedure
38
39/case(t_lab)/ $ label
40
41/case(t_latom)/ $ long atom
42
43/case(t_elmt)/ $ element-of-base
44
45 go to error;
46
47
50/case(t_istring)/ $ long character string
stra 349
stra 350 ss = value_ arg; $ get string specifier
stra 351 len = ss_len(ss); $ get length of string
stra 352
stra 353 if len <= sc_max then $ result is short character string
stra 354 if len = 0 then $ result is null string
stra 355 build_spec(getf1, t_string, 0);
stra 356 else
stra 357 getf1 = spec_char; $ one-character template
stra 358 scchar(getf1, 1) = icchar(ss, 1);
stra 359 end if;
stra 360
stra 361 return; $ done
stra 362 end if;
stra 363
stra 364 $ fall through to t_lint case.
stra 365
51
stra 366/case(t_lint)/ $ long integer
stra 367
52/case(t_real)/ $ real
53
54 getf1 = copy1(arg);
55 return;
56
57
58/case(t_tuple)/ $ standard tuple
59
60 go to error;
61
62
63/case(t_stuple)/ $ packed or untyped tuple
64
65 p = value_ arg; $ get pointer to heap block
66
67 go to tc(htype(p)) in h_ptuple to h_rtuple;
68
69
70/tc(h_ptuple)/ $ packed tuple
71
72 go to error;
73
74
75/tc(h_ituple)/ $ tuple(untyped integer)
76
77/tc(h_rtuple)/ $ tuple(untyped real)
78
79 getf1 = convert(arg, f_tuple);
80 return;
81
82
83/case(t_set)/ $ set
84
85/case(t_map)/ $ map
86
87 go to error;
88
89
90case_om $ omega types
91
92 go to error;
93
94
95/error/ $ error exit
96
97 call err_fatal(59);
98
99
100 end fnct getf1;
101
102
103 ..defenv_envfor
104
105
1 .=member callf
2 fnct callf(na);
3$
4$ this is the top-level routine for linking to an external routine,
5$ assuming fortran calling conventions.
6$
7 size na(ps); $ number of arguments
8
9 size callf(hs); $ specifier returned
10
11 size ext_addr(ws); $ address of external routine
12 size ext_indx(hs); $ index of external routine
13 size arg_addr(ws); $ address of parameter list
14
15 size spec(hs); $ setl specifier
16
17 size callf2(hs); $ lower level routine called
18 size pimadr(ws); $ returns absolute memory address
19 size pigetw(ws); $ returns memory contents
20
21 access nsintf; $ global nameset with static variables
22
23
24 .-defenv_envfor.
25
26 call err_fatal(49);
27
28 .+defenv_envfor.
29
30 $ get the entry address of the external routine
31 if (intf_extlen = 0 ! intf_extadr = 0) call err_fatal(60);
32 spec = stack_arg(1, na);
33 if (otype_ spec ^= t_int) call err_fatal(61);
34 ext_indx = ivalue_ spec;
35 if (ext_indx > intf_extlen) call err_fatal(61);
36 ext_addr = pigetw(intf_extadr+(ext_indx-1)*mem_bpw);
37
38 $ get the low index for the parameter list
39 spec = stack_arg(2, na);
40 if (otype_ spec ^= t_int) call err_fatal(57);
41 intf_argp = ivalue_ spec;
42
43 $ get the length of the parameter list
44 spec = stack_arg(3, na);
45 if (otype_ spec ^= t_int) call err_fatal(58);
46 intf_na = ivalue_ spec;
47
48 if intf_argp - 1 + intf_na > nelt(value(s_intf)) then
49 call err_fatal(58);
50 end if;
51
52 $ allocate a block of untyped data on the stack. this block
53 $ consists of two parts: the first part contains immediate
54 $ data, such as the value of a short integer. the second part
55 $ forms the parameter list proper. this list consists of an
56 $ untyped integer n giving the length of the parameter list,
57 $ followed by n setl words with the addresses of the actual
58 $ parameters.
59
60 $ the constant 3 is derived as follows: length of entry in
61 $ parameter list is one setl word for the address, longest
62 $ auxuliary storage needed is two setl words for the vax vms
63 $ string descriptors.
64 $ n+1 entries are allocated, accounting for the parameter list
65 $ length and two skip words.
66 reserve((intf_na+1)*3); $ no garbage collection hereafter
67
68 get_stack(2*intf_na); $ get auxiliary storage
69 intf_t2 = t; $ keep pointer to start
70 build_spec(intf_spec, t_skip, 2*intf_na+1);
71 push1(intf_spec);
72
73 $ build the parameter list
74 intf_indx = intf_na;
75 intf_argp = intf_argp - 1 + intf_na;
76
77 while intf_indx > 0;
78 call callf1(intf_indx, tcomp(value(s_intf), intf_argp));
79
80 intf_indx = intf_indx - 1;
81 intf_argp = intf_argp - 1;
82 end while;
83
84 push1(intf_na); $ push length of parameter list
85 intf_parm = t; $ actual start of parameter list
86 build_spec(intf_spec, t_skip, intf_na+2);
87 push1(intf_spec); $ mark block
88
89 arg_addr = pimadr(heap) + (intf_parm-1)*mem_bpw;
90
91 $ call external routine
92 call picall(ext_addr, arg_addr);
93
94 $ pop the skip word and the number of arguments
95 free_stack(2);
96
97 $ pop the parameter list, copying back values
98 while intf_indx < intf_na;
99 intf_indx = intf_indx + 1;
100 intf_argp = intf_argp + 1;
101
102 tcomp(value(s_intf), intf_argp) =
103 callf2(intf_indx, tcomp(value(s_intf), intf_argp));
104 end while;
105
106 $ free the auxiliary storage allocated above
107 free_stack(2*intf_na+1);
108 assert t = savet; $ lest i forgot something
109
110 callf = spec_om; $ return omega
111
112 ..defenv_envfor
113
114
115 end fnct callf;
1 .=member callf1
2
3
4 .+defenv_envfor.
5
6
7 subr callf1(indx, arg);
8$
9$ this routine pushes the address of its argument arg onto the setl
10$ stack, thus forming the parameter list for the fortran call. the
11$ argument indx gives the index in the fortran parameter list, and is
12$ used to address, together with the global intf_t2, the scratch
13$ storage on the setl stack.
14$
15 size indx(ps); $ formal parameter index
16 size arg(hs); $ specifier for actual parameter
17
18 size p(ps); $ pointer to long object
19
20 size pimadr(ws); $ return memory address
21
22 access nsintf; $ global nameset with static variables
23
24
25 go to case(otype_ arg) in t_min to t_max;
26
27
28/case(t_int)/ $ short integer
29
30 heap(intf_t2 + 2*(indx-1)) = ivalue_ arg;
31 push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
32 return;
33
34
35/case(t_string)/ $ short character string
36
37/case(t_atom)/ $ short atom
38
39/case(t_proc)/ $ procedure
40
41/case(t_lab)/ $ label
42
43/case(t_latom)/ $ long atom
44
45/case(t_elmt)/ $ element-of-base
46
47 go to error;
48
49
50/case(t_lint)/ $ long integer
51
smfc 74 heap(intf_t2 + 2*(indx-1)) = getintli(arg);
55 push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
56 return;
57
58
59/case(t_istring)/ $ long character string
60
suna 39 .+s32v.
61 push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
62 call picrsd(heap(t), arg, heap);
suna 40 ..s32v
suna 41 .+s32u.
suna 42 get_stack(1); $ reserve space for string address.
suna 43 call picrsd(t, arg, heap); $ now store string address.
suna 44 ..s32u
suna 45 .+s37.
suna 46 push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
suna 47 call picrsd(heap(t), arg, heap);
suna 48 ..s37
suna 49 .+s66.
suna 50 push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
suna 51 call picrsd(heap(t), arg, heap);
suna 52 ..s66
suna 53 .+s68.
suna 54 get_stack(1); $ reserve space for string address.
suna 55 call picrsd(t, arg, heap); $ now store string address.
suna 56 ..s68
63 return;
64
65
66/case(t_real)/ $ real
67
68 heap(intf_t2 + 2*(indx-1)) = rval(value_ arg);
69 push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
70 return;
71
72
73/case(t_tuple)/ $ standard tuple
74
75 go to error;
76
77
78/case(t_stuple)/ $ packed or untyped tuple
79
80 p = value_ arg;
81
82 go to tc(htype(p)) in h_ptuple to h_rtuple;
83
84
85/tc(h_ptuple)/ $ packed tuple
86
87 go to error;
88
89
90/tc(h_ituple)/ $ tuple(untyped integer)
91
92 push1( pimadr(heap) + ((p-1) + (hl_ituple+1)) * mem_bpw );
93 return;
94
95
96/tc(h_rtuple)/ $ tuple(untyped real)
97
98 push1( pimadr(heap) + ((p-1) + (hl_rtuple+1)) * mem_bpw );
99 return;
100
101
102/case(t_set)/ $ set
103
104/case(t_map)/ $ map
105
106 go to error;
107
108
109case_om $ omega types
110
111 go to error;
112
113
114/error/ $ error exit
115
116 call err_fatal(59);
117
118
119 end subr callf1;
120
121
122 ..defenv_envfor
123
124
1 .=member callf2
2
3
4 .+defenv_envfor.
5
6
7 fnct callf2(indx, arg);
8$
9$ this routine pops the current argument from the setl stack. the
10$ argument arg serves as a type indicator. the argument indx is used,
11$ together with the global intf_t2, to address the scratch section on
12$ the setl stack.
13$
14 size indx(ps); $ formal parameter index
15 size arg(hs); $ specifier for actual parameter
16
17 size callf2(hs); $ specifier returned
18
19 size p(ps); $ pointer to heap block
20 size val(hs); $ untyped value
21
22 access nsintf; $ global nameset with static variables
23
24
25 go to case(otype_ arg) in t_min to t_max;
26
27
28/case(t_int)/ $ short integer
29
30 val = heap(intf_t2 + 2*(indx-1));
31 put_intval(val, intf_spec);
32 go to esac;
33
34
35/case(t_string)/ $ short character string
36
37/case(t_atom)/ $ short atom
38
39/case(t_proc)/ $ procedure
40
41/case(t_lab)/ $ label
42
43/case(t_latom)/ $ long atom
44
45/case(t_elmt)/ $ element-of-base
46
47 go to error;
48
49
50/case(t_lint)/ $ long integer
51
52 val = heap(intf_t2 + 2*(indx-1));
53 put_intval(val, intf_spec);
54 go to esac;
55
56
57/case(t_istring)/ $ long character string
58
59 intf_spec = arg;
60 go to esac;
61
62
63/case(t_real)/ $ real
64
65 val = heap(intf_t2 + 2*(indx-1));
66 put_realval(val, intf_spec);
67 go to esac;
68
69
70/case(t_tuple)/ $ standard tuple
71
72 go to error;
73
74
75/case(t_stuple)/ $ packed or untyped tuple
76
77 p = value_ arg;
78
79 go to tc(htype(p)) in h_ptuple to h_rtuple;
80
81
82/tc(h_ptuple)/ $ packed tuple
83
84 go to error;
85
86
87/tc(h_ituple)/ $ tuple(untyped integer)
88
89/tc(h_rtuple)/ $ tuple(untyped real)
90
91 intf_spec = arg;
92
93 go to esac;
94
95
96/case(t_set)/ $ set
97
98/case(t_map)/ $ map
99
100 go to error;
101
102
103case_om $ omega types
104
105 go to error;
106
107
108/esac/ $ end case
109
110 free_stack(1); $ pop stack
111
112 callf2 = intf_spec;
113
114 return;
115
116
117/error/ $ error exit
118
119 call err_fatal(59);
120
121
122 end fnct callf2;
123
124
125 ..defenv_envfor
126
127
1 .=member putf
2 fnct putf(na);
3$
4 size na(ps); $ number of arguments
5
6 size putf(hs); $ specifier returned
7
8 access nsintf; $ global nameset with static variables
9
10
11 .-defenv_envfor.
12
13 call err_fatal(49);
14
15 .+defenv_envfor.
16
17 if intf_case = intf_init then $ initial entry
18
19 $ initialise the pointer into the argument array
20 intf_argp = stack_arg(1, na);
21 if (otype_ intf_argp ^= t_int) call err_fatal(57);
22 intf_argp = ivalue_ intf_argp;
23
24 if (intf_argp-1) + (na-1) > maxindx(value(s_intf)) then
25 intf_spec = heap(s_intf);
26 call exptup(intf_spec, ((intf_argp-1)+(na-1)));
27 heap(s_intf) = intf_spec;
28 end if;
29
30 intf_indx = 2;
31 intf_case = intf_cont;
32 end if;
33
34 while intf_indx <= na;
35 call putf1(intf_argp, stack_arg(intf_indx, na));
36
37 intf_indx = intf_indx + 1;
38 intf_argp = intf_argp + 1;
39 end while;
40
41 intf_case = intf_init;
42
43 putf = spec_om; $ return omega
44
45 ..defenv_envfor
46
47
48 end fnct putf;
1 .=member putf1
2
3
4 .+defenv_envfor.
5
6
7 subr putf1(argp, arg);
8$
9$ this routine transfers its argument arg to the fortran interface
10$ communication tuple. it controls the copy-semantics and the
11$ representation restrictions for the interface.
12$
13 size argp(ws); $ actual parameter list index
14 size arg(hs); $ value to be transmitted
15
16 size a(hs); $ local copy of arg
17
stra 368 size len(ps); $ length of string
stra 369 size ss(ssz); $ string specifier
18 size p(ps); $ pointer to long object
19 size val(hs); $ packed value
20
21 size convert(hs); $ general conversion utility
22 size copy1(hs); $ general copy utility
stra 370 size nulllc(ssz); $ allocates null string
23
24 access nsintf; $ global nameset with static variables
25
26
27 a = arg; $ copy argument
28
29
30/entry/
31
32 go to case(otype_ a) in t_min to t_max;
33
34
35/case(t_int)/ $ short integer
36
37 go to esac;
38
39
40/case(t_string)/ $ short character string
stra 371
stra 372$ convert to long string. this reduces the amount of interface code
stra 373$ that has to be written for strings.
stra 374
stra 375 len = sc_nchars_ a; $ get length of string
stra 376 ss = nulllc(len); $ allocate null string block
stra 377 ss_len(ss) = len; $ set length of converted string
stra 378 if len then icchar(ss, 1) = scchar(a, 1); end if;
stra 379 build_spec(a, t_istring, ss);
stra 380
stra 381 go to esac;
stra 382
41
42/case(t_atom)/ $ short atom
43
44/case(t_proc)/ $ procedure
45
46/case(t_lab)/ $ label
47
48/case(t_latom)/ $ long atom
49
50 go to error;
51
52
53/case(t_elmt)/ $ element-of-base
54
55 deref(a); go to entry;
56
57
58/case(t_lint)/ $ long integer
59
62 maycopy(a); $ copy if shared
63
64 go to esac;
65
66
67/case(t_istring)/ $ long character string
68
69 a = copy1(a); $ always copy strings
sunb 34 .+s68.
sunb 35 p = value_ a; $ get string specifier of argument.
sunb 36 call explc(p, ss_len(p) + 1);
sunb 37 icchar(p, ss_len(p)+1) = 0; $ string terminator for c.
sunb 38 build_spec(a, t_istring, p);
sunb 39 ..s68
70
71 go to esac;
72
73
74/case(t_real)/ $ real
75
76 maycopy(a); $ copy if shared
77
78 go to esac;
79
80
81/case(t_tuple)/ $ standard tuple
82
83 intf_spec = tcomp(value_ a, 1); deref(intf_spec);
84
85 if otype_ intf_spec = t_int ! otype_ intf_spec = t_lint then
86 a = convert(a, f_ituple);
87
88 elseif otype_ intf_spec = t_real then
89 a = convert(a, f_rtuple);
90
91 else
92 go to error;
93 end if;
94
95 go to esac;
96
97
98/case(t_stuple)/ $ packed or untyped tuple
99
100 p = value_ a;
101
102 go to tc(htype(p)) in h_ptuple to h_rtuple;
103
104
105/tc(h_ptuple)/ $ packed tuple
106
107 val = pcomp(p, 1);
108 unpack(ptkey(p), val, intf_spec);
109 deref(intf_spec);
110
111 if otype_ intf_spec = t_int ! otype_ intf_spec = t_lint then
112 a = convert(a, f_ituple);
113
114 elseif otype_ intf_spec = t_real then
115 a = convert(a, f_rtuple);
116
117 else
118 go to error;
119 end if;
120
121 go to esac;
122
123
124/tc(h_ituple)/ $ tuple(untyped integer)
125
126/tc(h_rtuple)/ $ tuple(untyped real)
127
128 maycopy(a); $ copy if shared
129
130 go to esac;
131
132
133/case(t_set)/ $ set
134
135/case(t_map)/ $ map
136
137 go to error;
138
139
140case_om $ omega types
141
142 go to error;
143
144
145/esac/ $ end case
146
147 tcomp(value(s_intf), argp) = a;
148 if (nelt(value(s_intf)) < argp) nelt(value(s_intf)) = argp;
149
150 return;
151
152
153/error/ $ error exit
154
155 call err_fatal(59);
156
157
158 end subr putf1;
159
160
161 ..defenv_envfor
162
163
1 .=member rewindr
2 fnct rewindr(na);
3
4$ this is the setl rewind function
5
6 size na(ps); $ number of arguments
7
8 size rewindr(hs); $ returned value
9
10 size name(hs), $ file name
11 id(ps); $ file id
12
13 size file_id(ps); $ looks up file id
14
15 name = stack_arg(1, na);
16 id = file_id(name, io_rewind);
17
18 rewind id;
19 endline(id);
20
21 rewindr = spec_om;
22
23 return;
24
25 end fnct rewindr;
1 .=member eof
2 fnct eof(na);
3
4$ this is the setl eof function. it returns true if the last file
5$ accessed is at the end of file.
6
7 size na(ps); $ number of arguments
8
9 size eof(hs); $ specifier returned
10
11 if last_id = 0 then $ no i-o yet
12 eof = heap(s_false);
13 elseif filestat(last_id, end) then
14 eof = heap(s_true);
15 else
16 eof = heap(s_false);
17 end if;
18
19
20 end fnct eof;
1 .=member eject
2 fnct eject(na);
3
4$ this is the setl 'eject' function. it causes a page eject on
5$ a specified file.
6
7 size na(ps); $ number of arguments
8
9 size eject(hs); $ returned value
10
11 size name(hs), $ file name
12 id(ps); $ file id
13
14 size file_id(ps); $ maps file name into id
15
16 if na = 0 then $ use out_file as default
17 id = out_file;
18 else
19 name = stack_arg(1, 1);
20 id = file_id(name, io_print);
21 end if;
22
23 put id, page;
24
25 eject = spec_om;
26
27 return;
28
29 end fnct eject;
1 .=member title
2 fnct title(na);
3
4$ this is the setl 'title' function. it resets the main title
5$ on the file 'output' and causes a page eject.
6
7 size na(ps); $ number of arguments
8
9 size title(hs); $ specifier returned
10
11 size str(sds_sz); $ title as sds
12
13 size bldsds(sds_sz); $ converts string to sds
14
15 if na = 0 then $ turn off titling
16 call stltitle(no, '');
17 else $ install new title
18 str = bldsds(stack_arg(1, 1));
19 call stltitle(yes, str);
20 end if;
21
22 title = spec_om;
23
24 return;
25
26 end fnct title;
1 .=member stltitle
2 subr stltitle(titl, str);
3
4$ this routine sets up a new title on the system output file. its
5$ arguments are:
6
7$ titl: indicates enable/disable titling
8$ str: new title as an sds string
9
10 size titl(1),
11 str(sds_sz);
12
13 size t_flag(1); $ on if currently titling
14 data t_flag = no;
15
16 size lines(ps); $ lines per page
17
18
19
20 if titl then $ enable titling
21 if t_flag then $ reset title
22 call etitlr(0, str, 2, 35);
23 call contlpr(10, lines); $ get lines per page
24 call contlpr(15, lines); $ set line number within page
25
26 else $ start from scratch
27 call contlpr( 6, yes); $ set paging mode
28 call contlpr( 7, yes); $ set titling mode
29 call contlpr( 8, 76); $ set page number in col. 76
30 call contlpr( 9, 41); $ set date field in col. 41
31 call contlpr(13, 0); $ set number of current page
sunb 40 call contlpr(10, lines); $ get lines per page
sunb 41 call contlpr(15, lines); $ set line number within page
32 call etitlr(0, str, 2, 35);
33 call etitlr(0, 'page', 71, 4);
35
36 t_flag = yes;
37
38 end if;
39 else
40 call contlpr(6, 0); $ disable page numbering
41 call contlpr(7, 0); $ disable titleing
42
43 t_flag = no;
44 end if;
45
47
48 end subr stltitle;
1 .=member fileid
2 fnct file_id(name, use);
3
4$ this routine maps a setl string into a little file identifier
5$ then checks that the 'access' attribute of the file is consistent
6$ with an io code 'code'.
7
8$ we also set last_id to the number of the last input file
9$ accessed.
10
11$ we merley perform a look up in an unbased map called 'fid'.
12
13 size name(hs), $ file name
14 use(ps); $ use io_xxx
15
16 size file_id(ps); $ integer returned
17
18 size p(ps), $ pointer set by locate
19 valid(1), $ flags valid io operation
20 acs(ps), $ access mode of file
21 im(hs), $ map image
22 temp1(hs), $ temps for calling 'from'
23 temp2(hs);
asca 39 size file_title(sds_sz); $ file title
24
25 size bldsds(sds_sz); $ converts string to sds
26
27
28 call locate(p, name, value(s_fid), no);
29
30 if (^ loc_found) go to nfound;
31
32 im = ebimag(p);
33 file_id = value_ im;
34
35
36 acs = filestat(file_id, access);
asca 40 file_title = bldsds(name); $ file title
37
38 go to case(use) in io_min to io_max;
39
40/case(io_get)/
41
42 if acs = io_put then $ change access
asca 41 file file_id title = file_title, access = get;
44 endline(file_id);
45
46 valid = yes;
47
48 else
49 valid = (acs = io_get);
50 end if;
51
52 last_id = file_id;
53
54 go to esac;
55
56/case(io_print)/
57
58 if acs = io_get then $ change access
asca 42 file file_id title = file_title, access = print;
60 valid = yes;
61
62 else
63 valid = (acs = io_put ! acs = io_print);
64 end if;
65
66 go to esac;
67
68/case(io_put)/
69
70 if acs = io_get then $ change access
asca 43 file file_id title = file_title, access = put;
72 valid = yes;
73
74 else
75 valid = (acs = io_put ! acs = io_print);
76 end if;
77
78 go to esac;
79
80
81/case(io_read)/
82
83 if acs = io_write then $ change access
asca 44 file file_id title = file_title, access = read;
85 valid = yes;
86
87 else
88 valid = (acs = io_read);
89 end if;
90
91 last_id = file_id;
92
93 go to esac;
94
95
96/case(io_string)/
97
98 valid = no;
99 go to esac;
100
101
102/case(io_write)/
103
104 if acs = io_read then $ change access
asca 45 file file_id title = file_title, access = write;
106 valid = yes;
107
108 else
109 valid = (acs = io_write);
110 end if;
111
112 go to esac;
113
114
115
116/case(io_open)/
117
118 valid = no; $ since file already open
119 go to esac;
120
121
122/case(io_rewind)/
123
124 valid = yes;
125 go to esac;
126
127
128/case(io_close)/
129
130$ remove the pair [name, file_id] from fid and add file_id to the
131$ set of free file numbers.
132
133 call delete(value(s_fid), loc_prev, p, yes);
134 call insert(p, im, value(s_free));
135
136 valid = yes;
137 go to esac;
138
139/esac/
140
141 if (^ valid) call err_fatal(28);
142
143 return;
144
145
146/nfound/ $ file not found
147
148$ if we are opening a new file we must obtain a file number for
149$ it and add a pair to 'fid'.
150
151$ the variable 'fmax' contains the maximum file number so far,
152$ and 'free' contains the set of all file numbers which have been
153$ freed.
154
155 if use = io_open then
156 temp2 = heap(s_free);
157 call from(temp1, temp2);
158
159 heap(s_free) = temp2;
160
161 if is_om_ temp1 then
162 add1(heap(s_fmax));
163 temp1 = heap(s_fmax);
164
165 if (value_ temp1 > file_max) call err_fatal(29);
166 end if;
167
168 call insert(p, name, value(s_fid));
169 ebimag(p) = temp1;
170
171 file_id = value_ temp1;
172
173 else
174 call err_fatal(30);
175 end if;
176
177 end fnct file_id;
1 .=member filemode
2 fnct file_mode(name);
3
4$ this routine maps a setl string into a little flie access mode.
5$ we simply do a map look up in the map 'fmode'.
6
7 size name(hs); $ specifier for name
8
9 size file_mode(ps); $ code io_xxx returned
10
11 size p(ps); $ pointer returned by locate
12
13 call locate(p, name, value(s_fmode), no);
14
15 if (^ loc_found) call err_fatal(31);
16
17 file_mode = value_ ebimag(p);
18 return;
19
20 end fnct file_mode;
1 .=member newliner
2 subr newliner(id);
3
4$ this routine reads a new line image into the buffer for file
5$ 'id' and set its cursor to point to the first character
6$ of the line.
7
8 size id(ps); $ file id
9
10 size len(ps), $ line length
11 j(ps); $ loop index
12
13 size bf(linesize_max*cs); $ scratch buffer
14
15 len = filestat(id, linesize);
16 if (len > linesize_max) len = linesize_max;
17 get id, skip: bf, r(len);
18
19 .f. 1, ws, buffer(id) = blank_buffer;
20 .f. ws+1, linesize_max*cs, buffer(id) = bf;
21
22 cursor(id) = ws + 1 + (len-1) * cs;
23
24$ if we are at the end of file we set each character of the
25$ line to 'eof_char'.
26
27 if filestat(id, end) then
28 do j = 0 to len-1;
29 .f. 1 + ws + j*cs, cs, buffer(id) = eof_char;
30 end do;
31 end if;
32
33 rd_char = .f. cursor(id), cs, buffer(id);
34
35 end subr newliner;
1 .=member bldsds
2 fnct bldsds(spec);
3
stra 383$ this routine converts a setl string to a little sds string.
5
6
7 size spec(hs); $ setl string
8
9 size bldsds(sds_sz);
10
11 size ss(ssz), $ string specifier
12 j(ps), $ loop index
13 org(ps), $ sorg of string
14 len(ps); $ length of string
15
16
22 bldsds = 0;
23
stra 384 if otype_ spec = t_string then $ short character string
stra 385 len = sc_nchars_ spec; org = .sds. len + 1;
stra 386 slen bldsds = len; sorg bldsds = org;
stra 387 if len then .f. org-cs, cs, bldsds = scchar(spec, 1); end;
stra 388
stra 389 else $ long character string
stra 390 ss = value_ spec;
stra 391 len = ss_len(ss); org = .sds. len + 1;
stra 392 slen bldsds = len; sorg bldsds = org;
stra 393 do j = 1 to len;
stra 394 .f. org - j*cs, cs, bldsds = icchar(ss, j);
stra 395 end do;
stra 396 end if;
asca 46
asca 47 .+ascebc if (ascebc_flag) call ebcsds(bldsds); $ convert to ebcdic
30
31
32 end fnct bldsds;
1 .=member bldstr
2 fnct bldstr(str);
3
stra 397$ this routine builds a setl character string from a little sds string.
5
6 size str(sds_sz);
7
8 size bldstr(hs); $ specifier returned
9
10 size ss(ssz), $ string specifier
11 j(ps), $ loop index
12 org(ps), $ sorg of sds
13 len(ps); $ slen of sds
stra 398 size c(cs); $ current character
14
15 size nulllc(ssz); $ builds null string
stra 399 .+ascebc size aschar(cs); $ ebcid-to-ascii conversion function
16
17 org = sorg str;
18 len = slen str;
stra 400
stra 401 if len <= sc_max then $ result is short string
stra 402 if len = 0 then $ result is null string
stra 403 build_spec(bldstr, t_string, 0);
stra 404 else
stra 405 bldstr = spec_char; $ one-character template
stra 406 c = .f. org - cs, cs, str; $ get character
stra 407 .+ascebc if (ascebc_flag) c = aschar(c); $ convert to ascii
stra 408 scchar(bldstr, 1) = c;
stra 409 end if;
stra 410
stra 411 return;
stra 412 end if;
19
20 ss = nulllc(len);
21
22 ss_len(ss) = len;
23
24 do j = 1 to len;
25 icchar(ss, j) = .f. org - j*cs, cs, str;
26 end do;
asca 48 .+ascebc if (ascebc_flag) call ascstr(ss); $ convert to ascii
28 build_spec(bldstr, t_istring, ss);
29
30 return;
31
32 end fnct bldstr;
1 .=member dumpio
2 subr dumpio;
3
4$ this routine dumps the state of all files in case of an abort.
5$ for now we merely print the current line of the input file.
6
7 size len(ps), $ length of print file
8 col(ps); $ current column
9
10 size j(ps); $ loop index
11
12 size line(cs); $ current line image
13 dims line(130);
14
15 len = filestat(in_file, linesize);
16 col = filestat(in_file, column);
17
18 get in_file, column(1): line(1) to line(len), r(1);
19
20 put, skip(2), column(7), 'current line of input file is: ',
21 skip(1), column(2): line(1) to line(len), r(1),
22 skip(1), column(7+col): 1r$, r(1);
23
24 return;
25
26 end subr dumpio;
1 .=member copy1
2 fnct copy1(arg);
3
4$ this routine performs a single level copy of a setl data object and
5$ sets the share bits on the second level of the object. its argument
6$ is a specifier, and a specifier is returned.
7
8$ if "arg" is omega then we call err_om and take one of
9$ two actions depending on err_mode:
10
11$ 1. if we are doing full error detection we return the
12$ appropriate error value.
13
14$ 2. otherwise we return a copy of the appropriate standard
15$ omega. note that this must be a copy since we may use
16$ it destructively.
17
18$ variable declarations
19
20 size copy1(hs); $ specifier returned
21
22 size arg(hs); $ specifier for object to be copied
23
24 size oldp(ps), $ pointer to value to be copied
25 newp(ps), $ pointer to copy
26 len(ps), $ its length
27 oldss(ssz), $ old string specifier
28 newss(ssz), $ new string specifier
29 j(ps); $ loop index
30
31 size oldht(ps), $ pointer to old hash table
32 newht(ps), $ pointer to new hash table
33 nhedrs(ps), $ number of hash headers
34 p(ps), $ misc. pointer
35 ebsz(ps), $ ebsize of set being copied
36 total(ps), $ total space needed
37 map(1), $ indicates we are copying a map
38 old(ps), $ pointer to eb being copied
39 new(ps), $ pointer to eb being copied to
40 prev(ps), $ pointer to last eb initialized
41 head(ps); $ pointer to current hash header of new set
42
43 size nulllc(ssz); $ function called
44
45
46$ begin execution
47
48 .+st init_time(st_copy);
49
50 if is_om_ arg then
51 call err_om(13);
52
53 if err_mode = err_full then
54 build_spec(copy1, t_error, codep);
55 go to done;
56 end if;
57 end if;
58
59$ initialize the specifier for the result and jump on its type.
60$ om - value can be used destructively.
61
62 copy1 = arg; $ initialize type, etc.
63 is_shared_ copy1 = no;
64
65 oldp = value_ arg; $ get pointer to old block
66
67
68$ branch on type of argument ignoring is-om flag.
69
70 go to case(type_ arg) in t_min to t_lmax;
71
72
73
74
75/case(t_int)/ $ types which are never copied
76
77/case(t_string)/
78
79/case(t_atom)/
80
81/case(t_error)/
82
83/case(t_skip)/
84
85/case(t_proc)/
86
87/case(t_lab)/
88
89/case(t_latom)/
90
91/case(t_elmt)/
92
93 go to done; $ nothing to do
94
95
96/case(t_lint)/ $ long integers
97
98 len = li_nwords(oldp); $ length of data area
99 go to loop;
100
101/case(t_istring)/ $ long chars
102
103 oldss = value_ arg; $ get original string specifier
104 len = ss_len(oldss);
105
106 newss = nulllc(len); $ get string block
107 ss_len(newss) = len;
108
109 mvc(newss, oldss, len); $ copy string
110
111 value_ copy1 = newss; $ store new string specifier
112
113 go to done;
114
115
116/case(t_real)/ $ reals
117
118 go to done; $ no copy necessary
119
120
121/case(t_tuple)/ $ tuples
122
123 len = tuplen(oldp);
124
125 get_heap(len, newp); $ get new block
126
127 do j = 0 to hl_tuple-1; $ copy header
128 heap(newp+j) = heap(oldp+j);
129 end do;
130
131 $ copy elements, setting share bits.
132 do j = 0 to maxindx(oldp);
133 is_shared_ tcomp(oldp, j) = yes;
134 tcomp(newp, j) = tcomp(oldp, j);
135 end do;
136
137 value_ copy1 = newp; $ save new value_
138
139 go to done;
140
141
142/case(t_stuple)/ $ special tuples
143
144$ jump on header type to get size of tuple
145 go to tc(htype(oldp)) in h_ptuple to h_rtuple;
146
147
148/tc(h_ptuple)/ $ packed tuples
149
150 len = ptuplen(oldp);
151 go to loop;
152
153/tc(h_ituple)/ $ integer tuples
154
155/tc(h_rtuple)/ $ real tuples
156
157 len = tuplen(oldp);
158 go to loop;
159
160/case(t_set)/ $ sets and maps.
161
162/case(t_map)/
163
164$ jump on header type
165 go to sc(htype(oldp)) in h_uset to h_lrmap;
166
167
168/sc(h_uset)/ $ unbased sets and maps
169
170/sc(h_umap)/
171$
172$ to copy a set or map means to copy the set/map header, its hash
173$ table header, its template, its hash table, and all its element
174$ blocks. we first allocate one large block which will suffice for
175$ the whole of the new set, and then subdivide this block into the
176$ smaller blocks needed.
177$
178 oldht = hashtb(oldp); $ pointer to old hash table
179 nhedrs = pow2(lognhedrs(oldht)); $ number of hash headers
180 ebsz = ebsize(oldht + hl_ht); $ element block size
181
182 $ get space for the set header, the hash table header, the
183 $ template block, the hash table, and the element blocks.
184 $ assert hl_uset = hl_umap;
185 total = hl_uset + hl_ht + nhedrs * hl_htb + (neb(oldht)+1) * ebsz;
186 get_heap(total, newp);
187
188 $ initialize set/map header
189 do j = 0 to hl_uset-1;
190 heap(newp+j) = heap(oldp+j);
191 end do;
192
193 $ initialize hash table header
194 newht = newp + hl_uset; $ address of new hash table header
195 hashtb(newp) = newht; $ insert pointer into set header
196
197 do j = 0 to hl_ht-1;
198 heap(newht+j) = heap(oldht+j);
199 end do;
200
201$ copy the template block and hash table. we use a double loop over
202$ the two sets. the outer loop iterates over hash headers and the
203$ inner loop iterates over clash lists. the variables used in the
204$ loop are:
205
206$ old: current element of old set.
207$ new: current element of new set.
208$ prev: previous element of new set.
209$ head: used to remember current hash header of new set.
210$ map: flag set on for maps and off for sets.
211$ p: points to next unused heap word.
212
213 old = oldht + hl_ht; $ points to the old template block
214 new = newht + hl_ht; $ points to the new template block
215
216 $ initialize the new template block
217 do j = 0 to ebsz-1;
218 heap(new+j) = heap(old+j);
219 end do;
220
221 old = eblink(old); $ points to the first old hash header
222 prev = new; $ points to the new template
223 head = new + ebsz; $ points to the first new hash header
224 map = is_map(oldp); $ flags u_map case
225 p = head + nhedrs * hl_htb;
226 $ points to the next new eb
227
228 while ^ is_ebtemp(old);
229 if is_ebhedr(old) then
230 new = head; head = head + hl_htb;
231
232 htype(new) = h_htb;
233 hlink(new) = 0;
234 is_ebhedr(new) = yes;
235 is_ebtemp(new) = no;
236
237 else
238 new = p; p = p + ebsz;
239
240 do j = 0 to hl_eb-1; $ copy eb header
241 heap(new+j) = heap(old+j);
242 end do;
243
244 is_shared_ ebspec(old) = yes; $ copy specifier
245 ebspec(new) = ebspec(old);
246
247 if map then $ copy image
248 is_shared_ ebimag(old) = yes;
249 ebimag(new) = ebimag(old);
250 end if;
251 end if;
252
253 eblink(prev) = new; prev = new; $ link and advance
254 old = eblink(old); $ advance in original
255 end while;
256
257 $ reset the last link to point to the template block
258 eblink(prev) = template(newp);
259
260 value_ copy1 = newp; $ save new value_
261
262 go to done;
263
264
265/sc(h_lset)/ $ local subsets
266
267 call err_fatal(32);
268
269/sc(h_rset)/ $ remote subsets
270
271$ get length and jump to main loop
272 len = rswords(oldp) + hl_rset;
273 go to loop;
274
275/sc(h_lmap)/ $ local maps
276
277 call err_fatal(33);
278
279/sc(h_rmap)/ $ remote maps
280
281$ remote tuples are copied in line rather then jumping to the
282$ main loop since we must set share bits in the tuple.
283
284$ allocate space for the set header and the tuple.
285 len = hl_rmap + tuplen(oldp +hl_rmap);
286
287 get_heap(len, newp); $ get new block
288
289$ copy set and tuple headers
290 do j = 0 to (hl_rmap + hl_tuple) - 1;
291 heap(newp+j) = heap(oldp+j);
292 end do;
293
294$ copy tuple elements, setting share bits.
295 do j = 0 to maxindx(oldp + hl_rmap);
296 is_shared_ tcomp(oldp + hl_rmap, j) = yes;
297 tcomp(newp + hl_rmap, j) = tcomp(oldp + hl_rmap, j);
298 end do;
299
300 value_ copy1 = newp; $ save new value_
301
302 go to done;
303
304/sc(h_lpmap)/ $ local packed map
305
306/sc(h_limap)/ $ local integer map
307
308/sc(h_lrmap)/ $ local real map
309
310 call err_fatal(34);
311
312/sc(h_rpmap)/ $ remote packed map
313
314$ get length and jump to main loop
315 len = hl_rpmap + ptuplen(oldp + hl_rpmap);
316 go to loop;
317
318/sc(h_rimap)/ $ remote integer map
319
320
321/sc(h_rrmap)/ $ remote real map
322
323$ get length and jump to main loop
324 len = hl_rmap + tuplen(oldp +hl_rmap);
325 go to loop;
326
327
328/loop/ $ main copy loop
329
330$ this loop handles all cases where we simply make a word for word copy
331$ of the old data block. oldp points to the old data block, and len
332$ is its length.
333
334 get_heap(len, newp);
335
336 do j = 0 to len-1;
337 heap(newp+j) = heap(oldp+j);
338 end do;
339
340 value_ copy1 = newp; $ save new value_
341
342 go to done;
343
344
345
346/done/ $ save statistics and return
347
348 .+st save_time(st_copy);
349
350
351 end fnct copy1;
1 .=member locate
2 subr locate(pos, x, s, add);
3
4$ this routine searches the hash table of 's' for the element 'x',
5$ and returns a pointer to the element block of 'x'. if the 'add'
6$ parameter is set, we add 'x' to 's' if it is not found. other-
7$ wise we return a pointer to the template block of 's'.
8
9$ locate has various auxilliary outputs which are not needed by
10$ every caller. these are:
11$
12$ loc_found: indiates whether 'x' was found in 's'.
13$ loc_prev: pointer to the previous element block in 's'.
14$ loc_hash: the hash code calculated for 'x'.
15$
16$ 'loc_prev' is used to delete an element from a clash list, and
17$ can be left undefined in certain cases:
18$
19$ 1. 's' is a base, since only the garbage collector deletes base
20$ elements.
21$
22$ 2. 'x' is om, since we never delete om.
23$
24$ locate will expand the hash table when necessary.
25
26
27 size pos(ps); $ pointer returned
28 size x(hs); $ value specifier
29 size s(ps); $ pointer to set header
30 size add(1); $ assert on exit: x in s
31
32 size e(hs); $ set element
33 size fm1(ps); $ base form of 'x' if 'x' is 'elmt b1'
34 size fm2(ps); $ form of 's'
35 size ht(ps); $ pointer to hash table of s
36 size tmp(ps); $ pointer to template block of s
37 size log(ps); $ log of hash header number
38 size head(ps); $ pointer to hash header
39
40 size gethash(hcsz); $ computes hash code
41 size equal(1); $ top level equality routine
42 size fval(hs); $ tests based set membership
43
44
45 loc_prev = 0;
46 loc_found = yes;
47$
48$ when the library is running with full error detection we will
49$ sometimes call the locate routine to do locates in plex bases.
50$
51$ we are doing a locate in a plex base if and only if 's' has a
52$ zero hashtb field. in this case x must already be an element
53$ of the base, and we merely return a pointer to it. (this is a
54$ result of various restrictions on plex bases enforced by the
55$ compiler)
56$
57 if hashtb(s) = 0 then
58 loc_hash = 0; $ not needed
59 pos = value_ x;
60
61 return;
62 end if;
63$
64$ if 'x' has the form 'elmt b1', and 's' happens to be the base b1,
65$ then there is no need to do a hashed search since 'x' points to
66$ the proper element base block.
67$
68 $ determine whether 'x' has the form 'elmt b1'
69 if (otype_ x ^= t_elmt) go to search;
70 pos = value_ x; if (htype(pos) ^= h_ebb) go to search;
71
72 loc_hash = ebhash(pos);
73
74 $ check whether 'x' is 'elmt b1', 's' is base b1
75 fm1 = ebform(pos); fm2 = hform(s);
76 if (fm1 = fm2) return;
77
78 if ( ^ is_based(s)) go to search;
79 if (fm1 = ft_base(fm2)) return;
80
81
82/search/ $ do hashed search
83$
84$ at this point we must search the appropriate clash list of 's',
85$ looking for 'x'. we assume that 'x' can be found, and advance
86$ 'pos' over the clash list. if we find 'x', we return. if we
87$ fall through the loop, 'x' is not in the set.
88$
89$ 'loc_prev' is usually set at the bottom of the loop. we initia-
90$ lize it to point to the hash header to handle the case where 'x'
91$ is the first element block on the clash list.
92$
93 init_probe(x, s, loc_hash, head);
94
95 loc_prev = head;
96
97 probe_loop(pos, head);
98
99 e = ebspec(pos);
100
101 if (eq(x, e)) return;
102 if ^ ne(x, e) then
103 if (equal(x, e)) return;
104 end if;
105
106 loc_prev = pos; $ save pointer to previous element
107
108 end_probe;
109
110
111/not_found/
112$
113$ 'x' is not in the set: add it if desired, otherwise return a
114$ pointer to the template block so that 'f(x)' yields 'om'.
115$
116 loc_found = no; $ flag not found
117
118 if add then
119 call augment(head, x, s, loc_hash); pos = head;
120 else
121 pos = template(s);
122 end if;
123
124
125 end subr locate;
1 .=member insert
2 subr insert(pos, x, s);
3
4$ this routine inserts an element into the hash table and returns
5$ a pointer to it. like 'locate' it is a very low level primitive
6$ however unlike locate, it assumes that x is not already in the set.
7
8 size pos(ps), $ pointer returned
9 x(hs), $ specifier for element
10 s(ps); $ pointer to set header
11
12 size hashc(hcsz), $ hash code of x
13 head(ps); $ pointer to hash header
14
15 size gethash(hcsz); $ function called
16
17
18 init_probe(x, s, hashc, head); $ get pointer to hash header
19
20 call augment(head, x, s, hashc); $ add element
21 pos = head;
22
23
24 end subr insert;
1 .=member augment
2 subr augment(pos, x, s, hashc);
3
4$ this routine performs the actual list manipulation of inserting
5$ 'x' into 's'.
6
7$ augment is the lowest level routine for hash table insertion. it
8$ assumes that some higher level routine has already performed the
9$ necessary hashing.
10
11$ 'hashc' is the hash code of 'x'. it is only used when augmenting
12$ bases, and can be invalid in other cases.
13$ this might well be under review, since our implementation of
14$ iterators made it necessary to keep base sets sorted by their
15$ element hash codes. it probably would be better to always
16$ require 'hashc' to be valid, and furthermore to always store
17$ the hash code in the element block (this, too, is only done
18$ for bases).
19
20
21 size pos(ps); $ ptr to hash header, then to eb of x
22 size x(hs); $ specifier for new element
23 size s(ps); $ pointer to set header
24 size hashc(ps); $ hash of x
25
26 size ht(ps); $ pointer to hash table
27 size tmp(ps); $ pointer to template block
28 size head(ps); $ pointer to hash header
29 size ebsz(ps); $ element block size
30 size isb(1); $ indicates that we process a base
31 size fm(ps); $ form of base
32 size lim(ps); $ maximum ebindx for constant base
33 size indx(ps); $ eb index of template
34 size p1(ps); $ misc. pointer
35 size p2(ps); $ misc. pointer
36 size j(ps); $ loop index
37
38
39$
40$ make sure we are not inserting omega.
41$
42 if is_om_ x then
43 call err_om(14);
44 return;
45 end if;
46$
47$ get pointers to hash table header, template block, and hash header
48$
49 ht = hashtb(s);
50 tmp = template(s);
51 head = pos;
52 isb = (htype(tmp) = h_ebb);
53$
54$ allocate and initialize a new element block for 'x'.
55$
56 ebsz = ebsize(tmp); get_heap(ebsz, pos);
57
58 $ set the new element block to match the template block
59 do j = 0 to ebsz-1;
60 heap(pos+j) = heap(tmp+j);
61 end do;
62
63 $ set the proper flags
64 is_ebtemp(pos) = no;
65 is_ebhedr(pos) = no;
66
67 if isb then
68 $
69 $ we keep clash lists of bases sorted in ascending order
70 $ of their hash codes. this means that we have to do a
71 $ little extra work here.
72 $
73 p1 = head; p2 = eblink(p1);
74 while ^ is_ebhedr(p2);
75 if (ebhash(p2) > hashc) quit while;
76
77 p1 = p2; p2 = eblink(p2);
78 end while;
79
80 eblink(pos) = p2;
81 eblink(p1) = pos;
82
83 else $ add as first element of clash list
84 eblink(pos) = eblink(head);
85 eblink(head) = pos;
86 end if;
87$
88$ insert 'x' into the element block
89$
90 is_shared_ x = yes; ebspec(pos) = x;
91$
92$ save additional information for bases
93$
94 if isb then
95 $ increment and assign base index. make sure there is
96 $ enough space between the stack and heap to do base com-
97 $ paction.
98
99 indx = ebindx(tmp);
100 if (indx = max_ebindx) call err_fatal(35);
101
102 if (min_gap < gb_space(indx)) min_gap = gb_space(indx);
103
104 $ if this is a constant base, make sure we are not inser-
105 $ ting too many elements.
106
107 fm = ebform(pos); lim = ft_lim(fm);
108
109 if lim ^= 0 then $ constant base
110 if (indx > lim) call err_fatal(36);
111 end if;
112
113 ebindx(pos) = indx;
114 ebindx(tmp) = indx+1;
115
116 ebhash(pos) = hashc; $ store hash code
117 end if;
118$
119$ increment the number of element blocks in the set. any necessary
120$ adjustment to the 'nelt' field is handled by the caller.
121$
122 neb(ht) = neb(ht)+1;
123
124 mayexpand(s);
125
126
127 end subr augment;
1 .=member delete
2 subr delete(s, prev, e, rehash);
3
4
5$ this routine deletes an element block from a set. its arguments are:
6
7$ s: pointer to set header
8$ e: pointer to eb being deleted
9$ prev: pointer to some eb which comes before 'e' in the set
10$ rehash: indicates that we should try to contract set after deletion
11
12$ prev may point either to the eb immediately before 'e' or to
13$ an eb considerably earlier. it is only used as the starting
14$ point for loop which sets 'prev1' to point to the eb immediately
15$ before 'e'. prev may even be 0, in which case we start the loop
16$ with prev1 pointing to the template.
17
18$ we assume that 'delete' does not change the eblink of the block it
19$ is deleting.
20
21
22 size s(ps), $ pointer to set
23 prev(ps), $ pointer to some previous eb
24 e(ps), $ pointer to element to be deleted
25 rehash(1); $ on if rehashing allowed
26
27 size j(ps), $ loop index
28 ht(ps), $ pointer to hash table
29 tmp(ps), $ pointer to template block
30 nxt(ps), $ pointer to next eb
31 prev1(ps); $ pointer to immediately previous eb.
32
33
34
35 if (is_ebtemp(e)) return; $ never delete template
36
37 ht = hashtb(s); $ pointer to hash table
38 tmp = template(s); $ pointer to template block
39 nxt = eblink(e); $ pointer to next element block
40
41 prev1 = prev; $ copy parameter
42 if (prev1 = 0) prev1 = tmp; $ worst case: start with template
43
44 while eblink(prev1) ^= e; $ find immediate predecessor
45 prev1 = eblink(prev1);
46 end while;
47
48 eblink(prev1) = nxt; $ link immediate predecessor to successor
49
50 neb(ht) = neb(ht)-1; $ decrement number of block
51
52 if rehash then
53 maycontract(s);
54 end if;
55
56
57 end subr delete;
1 .=member nullset
2 fnct nullset(form, n);
3
4$ this routine builds a null set and returns a specifier for it. its
5$ arguments are:
6
7$ form: the form of the desired set
8$ n: expected size of set
9
10$ we use 'form' to get a pointer to the omega value for the set and
11$ then use the omega to build the null set.
12
13
16 size nullset(hs); $ specifier returned
17
18 size form(ps), $ form of set
19 n(ps); $ indication of initial set size
20
21 size old(ps), $ pointer to omega set
22 new(ps); $ pointer to null set
23
24 size tp(ps); $ their htype
25
26 size i(ps), $ loop indices
27 j(ps);
28
29 size logn(ps), $ log number of hash headers
30 nhedr(ps), $ number of hash headers
31 total(ps), $ total words needed for hash table
32 ht(ps), $ pointer to hash table of sample
33 ebsz(ps), $ its ebsize
34 newht(ps), $ pointer to new hash table
35 tmp(ps), $ pointer to template block of sample
36 ntmp(ps), $ pointer to template of nullset
37 last(ps), $ pointer to last hash header of null set
38 eb(ps); $ pointer to current eb.
39
40 size bit(ps), $ ls_bit for local set
41 word(ps); $ ls_word
42
43 size p(ps); $ misc. pointer
44
45 size om_val(hs), $ om image of local map
46 e(ps); $ pointer to base element
47
48 size org(ps), $ bit origin for local packed maps
49 len(ps); $ length of local packed value
50
51 size tup(hs); $ specifier for null tuple
52
53 size nulltup(hs); $ function called
54
55
59$ initialize set header
60
61 old = value(ft_samp(form));
62 tp = htype(old);
63
64$ copy set header
65
66 get_heap(hl(tp), new);
67
68 do j = 0 to hl(tp)-1;
69 heap(new+j) = heap(old+j);
70 end do;
71
72$ branch on type of set.
73
74 go to case(tp) in h_uset to h_lrmap;
75
76
77
78/case(h_uset)/ $ unbased sets and maps
79
80/case(h_umap)/
81$
82$ allocate a template block, hash table header, and hash table.
83$
84$ the hash table is built to hold n elements. in order to keep the
85$ density of the hash table correct, we allocate ceil(n/2) hash
86$ headers.
87$
88 ht = hashtb(old); $ pointer to hash table of sample value
89 ebsz = ebsize(ht+hl_ht); $ element block size of sample value
90 logn = .fb. (n/2); $ log number of new hash headers
91 nhedr = pow2(logn); $ number of new hash headers
92
93 total = hl_ht + ebsz + nhedr * hl_htb;
94 get_heap(total, newht);
95$
96$ initialize hash table header
97$
98 hashtb(new) = newht;
99
100 htype(newht) = h_ht;
101 hlink(newht) = 0;
102 lognhedrs(newht) = logn;
103 neb(newht) = 0;
104$
105$ initialize template block
106$
107 tmp = ht + hl_ht; $ pointer to template of sample
108 ntmp = newht + hl_ht; $ pointer to new template block.
109
110 do i = 0 to ebsz-1;
111 heap(ntmp+i) = heap(tmp+i);
112 end do;
113
114 eblink(ntmp) = ntmp + ebsz; $ pointer to first hash header
115$
116$ initialize hash table
117$
118 last = ntmp + ebsz + (nhedr-1)*hl_htb; $ last hash header
119
120 do eb = ntmp+ebsz to last by hl_htb;
121 htype(eb) = h_htb;
122 hlink(eb) = 0;
123 is_ebhedr(eb) = yes;
124 is_ebtemp(eb) = no;
125 eblink(eb) = eb + hl_htb;
126 end do;
127
128 eblink(last) = ntmp; $ link last htb to template
129
130 if tp = h_uset then
131 build_spec(nullset, t_set, new);
132 else
133 build_spec(nullset, t_map, new);
134 end if;
135
136 return;
137
138
139/case(h_lset)/ $ local based set
140
141$ iterate through set, clearing bits.
142
143 bit = ls_bit(new);
144 word = ls_word(new);
145
146 next_loop(e, new);
147 .f. bit, 1, heap(e+word) = 0;
148 end_next;
149
150 build_spec(nullset, t_set, new);
151
152 return;
153
154
155/case(h_rset)/ $ remote based set
156
157$ fill in rs_maxi then allocate a bit string for the remote set.
158$ since these bit strings are zero origined, rs_maxi will always
159$ be 1 less than a multiple of rs_bpw. if particular, if k is
160$ the floor of n/ps_bpw it will be k * rs_bpw + (rs_bpw-1).
161
162$ 'rswords(new)' gives the number of words in the sets
163$ bit string. this is determined from the sets rs_maxi, which
164$ must be filled in first.
165
166 rs_maxi(new) = (n/rs_bpw) * rs_bpw + (rs_bpw-1);
167
168 get_heap(rswords(new), p);
169
170 do j = 1 to rswords(new);
171 rsword(new, j) = 0;
172 end do;
173
174 build_spec(nullset, t_set, new);
175
176 return;
177
178
181/case(h_rmap)/ $ remote maps
182
183/case(h_rpmap)/
184
185/case(h_rrmap)/
186
187/case(h_rimap)/
188
189
190$ remote maps are processed in two steps:
191
192$ 1. allocate a null tuple of the appropriate type. this is given
193$ by ft_tup(form).
194
195$ 2. if this is an mmap, iterate over the components of the tuple,
196$ clearing their is_im bits and setting their is_multi bits.
197
198 tup = nulltup(ft_tup(form), n);
199
200 if is_mmap(new) then
201 p = value_ tup;
202
203 do j = 0 to maxindx(p);
204 is_multi_ tcomp(p, j) = yes;
205 is_om_ tcomp(p, j) = no;
206 end do;
207 end if;
208
209 build_spec(nullset, t_map, new);
210
211 return;
212
213
214/case(h_lmap)/ $ local based maps
215
216/case(h_limap)/
217
218/case(h_lrmap)/
219
220$ set images to template block
221
222 word = ls_word(new); $ get eb word
223
224 om_val = heap(template(new)+word); $ get om image
225
226 next_loop(e, new);
227 heap(e+word) = om_val;
228 end_next;
229
230 build_spec(nullset, t_map, new);
231
232 return;
233
234
236/case(h_lpmap)/ $ local packed map
237
238$ set images to 0.
239
240 org = ls_bit(new); $ bit origin in word
241 len = ls_bits(new); $ length of field to clear
242 word = ls_word(new); $ word offset
243
244 next_loop(e, new);
245 .f. org, len, heap(e+word) = 0;
246 end_next;
247
248 build_spec(nullset, t_map, new);
249
250 return;
251
252 end fnct nullset;
1 .=member nulltup
2 fnct nulltup(form, n);
3
4$ this routine builds a null tuple of alloc -n- from a form
5$ and returns a pointer to it.
6
7
10 size nulltup(hs); $ specifier for tuple returned
11
12 size form(ps), $ form for tuple tuple
13 n(ps); $ initial size
14
15 size old(ps), $ pointer to standard omega tuple
16 new(ps); $ pointer to new tuple
17
18 size j(ps), $ loop index
19 tp(ps), $ type of tuple
20 maxi(ps), $ maximum index for tuple.
21 alloc(ps), $ total allocation
22 scomp(hs), $ specifier for sample component
23 spec(hs); $ specifier passed to copy routine
24
25
28 old = value(ft_samp(form));
29
30
31$ branch on type
32
33 tp = htype(old);
34 go to case(tp) in h_tuple to h_rtuple;
35
36
37/case(h_tuple)/ $ standard tuples
38
39$ special case mixed tuples
40
41 if (ft_type(hform(old)) = f_mtuple) go to mtuple;
42
43
44/case(h_rtuple)/ $ real and integer tuples
45
46/case(h_ituple)/
47
48$ determine the maximum index for the tuple, then find the
49$ number of words to allocate.
50
51 maxi = n + breath_space(n);
52 if (maxi < ft_lim(form)) maxi = ft_lim(form);
53 alloc = talloc(maxi);
54
55 get_heap(alloc, new); $ allocate space
56
57 do j = 0 to hl_tuple-1; $ initialize tuple header
58 heap(new+j) = heap(old+j);
59 end do;
60
61 maxindx(new) = maxi; $ store maximum index
62
63$ get sample component from old(0) and initialize null tuple.
64 scomp = tcomp(old, 0); $ sample component
65
66 do j = 0 to maxi;
67 tcomp(new, j) = scomp;
68 end do;
69
70 if tp = h_tuple then
71 build_spec(nulltup, t_tuple, new);
72 else
73 build_spec(nulltup, t_stuple, new);
74 end if;
75
76 return;
77
78
79/case(h_ptuple)/ $ packed tuples
80
81$ find maximum index and total length of tuple
82 maxi = n + breath_space(n);
83 if (maxi < ft_lim(form)) maxi = ft_lim(form);
84 alloc = palloc(old, maxi);
85
86 get_heap(alloc, new);
87
88 do j = 0 to hl_ptuple-1; $ initialize header
89 heap(new+j) = heap(old+j);
90 end do;
91
92 maxindx(new) = maxi;
93
94$ set components to 0, a word at a time.
95 do j = hl_ptuple to alloc-1;
96 heap(new+j) = 0;
97 end do;
98
99 build_spec(nulltup, t_stuple, new);
100
101 return;
102
103
106/mtuple/ $ mixed tuples
107
108$ for mixed tuples, we return a copy of the sample, with the
109$ is_om bits of its components set. when we make the copy
110$ we do not set the share bits of the components. this is
111$ safe since no correct program will destructively use an om.
112
113 maxi = maxindx(old); $ get maximum index and length.
114 alloc = talloc(maxi);
115
116 get_heap(alloc, new); $ allocate new tuple
117
118 do j = 0 to hl_tuple-1; $ initialize header
119 heap(new+j) = heap(old+j);
120 end do;
121
122 do j = hl_tuple to alloc-1; $ copy components
123 heap(new+j) = heap(old+j);
124 is_om(new+j) = yes;
125 end do;
126
127 build_spec(nulltup, t_tuple, new);
128
129 return;
130
131
132 end fnct nulltup;
1 .=member nulllc
2 fnct nulllc(n);
3
4$ this routine allocates a long character block large enough to hold
5$ -n- characters, and returns a string specifier whose ss_len
6$ indicates a null string and whose ss_ptr points to the the block.
7
8
9 size nulllc(ssz);
10
11 size n(ps); $ number of characters to fit in block.
12
13 size p(ps); $ pointer to long character data block
14
15
16$ before allocating a long character string block, we build
17$ a string specifier with zero fields. if string specifiers are
18$ being stored indirectly, building the specifier will allocate
19$ a heap block. we build the string specifier before allocating
20$ the long character data block. this means the long character block
21$ will be the last thing allocated on the heap, and can be expanded
22$ more efficiently.
23
24 build_ss(nulllc, 0, 0, 0);
25
26 get_heap(lcalloc(n), p);
27
28 htype(p) = h_lstring; $ initialize header
29 hlink(p) = 0;
30 lc_nwords(p) = lcalloc(n);
31
32 ss_ptr(nulllc) = p; $ point to long chars block
33
34
35 end fnct nulllc;
1 .=member rset1
2 fnct rset1(el);
3
4$ this function builds the singleton set @el\. it is used
5$ primarily when we are taking f@x\ at a point where f is
6$ single valued or undefined.
7
8$ if 'el' is a pair, we return an unbased map; otherwise
9$ we return an unbased set.
10
11
12 size el(hs); $ specifier for element
13
14 size rset1(hs); $ specifier for set returned
15
16 size p(ps), $ pointer to pair
17 hd(hs), $ head of pair
18 tl(hs), $ tail of pair
19 s(ps), $ pointer to result
20 pos(ps); $ pointer returned by locate routine
21
22 size nullset(hs); $ function called
23
24
25$ seperate map and set cases
26
27 if (type_ el ^= t_tuple) go to set;
28
29 p = value_ el;
30 if (nelt(p) ^= 2) go to set;
31 if (is_om_ tcomp(p, 1)) go to set;
32
33
34/map/ $ build map
35
36 rset1 = nullset(f_umap, 1);
37 s = value_ rset1;
38
39 if ^ is_om_ el then $ insert el
40 hd = tcomp(p, 1);
41 tl = tcomp(p, 2);
42
43 call insert(pos, hd, s);
44 call sfval(s, pos, tl);
45
46 set_nelt(s, 1);
47 end if;
48
49 return;
50
51
52/set/ $ build set
53
54 rset1 = nullset(f_uset, 1);
55 s = value_ rset1;
56
57 if ^ is_om_ el then $ insert el
58 call insert(pos, el, s);
59 set_nelt(s, 1);
60 end if;
61
62 return;
63
64
65 end fnct rset1;
66 fnct rset2(e1, e2);
67
68$ this function builds the set @e1, e2\ so that it can be stored
69$ as the image of a map. e1 and e2 are known to be non-om and
70$ unequal.
71
72$ if e1 and e2 are both pairs, we build an unbased map; otherwise
73$ we build an unbased set. the routine is recursive, since e1 and
74$ e2 may be pairs with the same head, in which case their image
75$ will be the set containing their tails.
76
77
78 size e1(hs), $ specifiers for elements
79 e2(hs);
80
81 size rset2(hs); $ specifier for set returned
82
83 size a1(hs), $ arguments to recursive routine
84 a2(hs);
85
86 size tstart(ps); $ initial pointer to top of stack
87
88 size pos(ps); $ pointer returned by 'insert'.
89
90 size nullset(hs), $ functions called
91 equal(1);
92
93$ stacked variables
94
95 .=zzyorg b $ reset counter for local variables
96
97 local(st); $ specifier for set returned
98 local(s); $ pointer to it
99
100 local(p1); $ pointers to pairs
101 local(p2);
102
103 local(hd1); $ components of pairs
104 local(tl1);
105
106 local(hd2);
107 local(tl2);
108
109 local(retpt); $ return pointer
110
111
112 a1 = e1; $ make local copies of arguments
113 a2 = e2;
114
115 tstart = t; $ save pointer to top of stack
116
117 .=zzyorg a $ reset counter for return labels
118
119/entry/ $ recursive entry point
120
121 r_entry;
122
123$ seperate set and map cases
124
125 if (type_ a1 ^= t_tuple ! type_ a2 ^= t_tuple) go to set;
126
127 p1 = value_ a1; $ get pointers to tuples
128 p2 = value_ a2;
129
130 if (nelt(p1) ^= 2 ! nelt(p2) ^= 2) go to set;
131 if (is_om_ tcomp(p1, 1) ! is_om_ tcomp(p2, 1)) go to set;
132
133
134/map/ $ build map
135
136$ allocate a null map, then branch to either 'match' or 'nomatch'
137$ depending on whether the pairs have matching heads.
138
139 st = nullset(f_umap, 2);
140 s = value_ st;
141
142 hd1 = tcomp(p1, 1); $ take apart tuples
143 tl1 = tcomp(p1, 2);
144
145 hd2 = tcomp(p2, 1);
146 tl2 = tcomp(p2, 2);
147
148 if eq(hd1, hd2) then
149 go to match;
150
151 elseif ne(hd1, hd2) then
152 go to nomatch;
153
154 elseif equal(hd1, hd2) then
155 go to match;
156
157 else
158 go to nomatch;
159 end if;
160
161
162/match/ $ heads match
163
164$ we will insert hd1 into the domain of s, and set its
165$ image to the set @tl1, tl2\. we begin by forming
166$ this doubleton set. this of course requires a recursive
167$ call.
168
169 a1 = tl1;
170 a2 = tl2;
171
172 r_call;
173
174 is_multi_ rset2 = yes;
175
176 call insert(pos, hd1, s); $ insert hd1 and set its image.
177 call sfval(s, pos, rset2);
178
179 set_nelt(s, 2);
180 rset2 = st;
181
182 go to exit;
183
184
185/nomatch/ $ heads dont match
186
187$ insert both pairs in the map.
188
189 call insert(pos, hd1, s);
190 call sfval(s, pos, tl1);
191
192 call insert(pos, hd2, s);
193 call sfval(s, pos, tl2);
194
195 set_nelt(s, 2);
196 rset2 = st;
197
198 go to exit;
199
200
201/set/ $ build set
202
203 st = nullset(f_uset, 2);
204 s = value_ st;
205
206 call insert(pos, a1, s);
207 call insert(pos, a2, s);
208
209 set_nelt(s, 2);
210 rset2 = st;
211
212 go to exit;
213
214
215/exit/ $ recursive exit point
216
217 r_exit;
218
219 if t ^= tstart then $ recursive return
220 go to rlab(retpt) in 1 to zzya;
221 else
222 return;
223 end if;
224
225 macdrop8(s, p1, p2, hd1, tl1, hd2, tl2, retpt)
226 macdrop(st)
227
228 end fnct rset2;
1 .=member rset2
1 .=member setform
2 fnct setform(form, n);
3
4$ this is the general set former. n is the number of elements, and
5$ 'form' is a form value for the result.
6
7$ the elements are passed through the stack and popped when we are done.
8$ they are assumed to already have the proper type.
9
10
11 size setform(hs); $ specifier returned
12
13 size form(ps), $ form of set
14 n(ps); $ number of elements
15
16 size el(hs), $ set element
17 j(ps); $ loop index
18
19 size nullset(hs), $ functions called
20 withs(hs);
21
22
23$ we begin by allocating a null set of the proper size and type,
24$ then iterate over the elements calling 'withs'.
25
26 setform = nullset(form, n);
27
28 do j = 1 to n;
29 el = stack_arg(j, n);
30 setform = withs(setform, el, yes);
31 end do;
32
33 free_stack(n);
34
35
36 end fnct setform;
1 .=member setf1
2 fnct setf1(n);
3
4$ this routine is similar to the general purpose setformer
5$ above, but is used when we do not know at compile time
6$ whether we would like the result to be a set or a map.
7$ if all the elements of the set turn out to be pairs, we
8$ will generate a map; otherwise we will generate a set.
9
10
11 size n(ps); $ number of elements in set
12
13 size setf1(hs); $ specifier returned
14
15 size j(ps), $ loop index
16 el(hs); $ set element
17
18 size setform(hs); $ general setformer
19
20
21 do j = 1 to n;
22 el = stack_arg(j, n);
23
24 if (otype_ el ^= t_tuple) go to set;
25 if (nelt(value_ el) ^= 2) go to set;
26 if (is_om_ tcomp(value_ el, 1)) go to set;
27 end do;
28
29/map/ $ build unbased map
30
31 setf1 = setform(f_umap, n);
32 return;
33
34/set/ $ build set
35
36 setf1 = setform(f_uset, n);
37 return;
38
39 end fnct setf1;
1 .=member tupform
2 fnct tupform(form, n);
3
4$ this routine builds a tuple. the components are passed through
5$ the stack, and are assumed to have the proper type. we begin
6$ by building a null tuple, then iterate over the components,
7$ popping them and putting them into the tuple.
8
9
10 size form(ps), $ form of tuple
11 n(ps); $ number of elements
12
13 size tupform(hs); $ specifier returned
14
15 size p(ps), $ pointer to nulltup
16 j(ps), $ loop index
17 el(hs), $ specifier for tuple element
18 tp(ps), $ type of tuple
19 nel(ps), $ nelt of tuple
20 omval(hs); $ omega value
21 size key(hs); $ pack key for packed tuple
22 size indx(ps); $ pack index for packed tuple
23
24 size nulltup(hs); $ function called
25
26
27 tupform = nulltup(form, n);
28 p = value_ tupform;
29
30 go to case(htype(p)) in h_tuple to h_rtuple;
31
32
33/case(h_tuple)/ $ standard tuple
34
35 nel = 0; $ nelt of tuple
36
37 do j = 1 to n;
38 el = stack_arg(j, n);
39 if (^ is_om_ el) nel = j; $ save index if defined
40 tcomp(p, j) = el;
41 end do;
42
43 nelt(p) = nel;
44
45 free_stack(n);
46
47 return;
48
49
50/case(h_ptuple)/ $ packed tuples
51
52$ store components by offline calls to sof.
53$ sof will adjust the nelt of the tuple as it goes.
54
55 key = ptkey(p); nel = 0;
56
57 do j = 1 to n;
58 el = stack_arg(j, n);
59 if (^ is_om_ el) nel = j;
60
61 pack(key, indx, el);
62 pcomp(p, j) = indx;
63 end do;
64
65 nelt(p) = nel;
66
67 free_stack(n); $ free space used by arguments
68
69 return;
70
71
72/case(h_ituple)/ $ untyped tuples
73
74/case(h_rtuple)/
75
76$ the top 2n stack entries contain n untyped data words
77$ sandwiched between n skip words.
78
79 omval = tcomp(p, 0); $ omega value
80 nel = 0;
81
82 do j = 1 to n;
83 el = stack_arg(2*j - 1, 2*n);
84 if (el ^= omval) nel = j;
85
86 tcomp(p, j) = el;
87 end do;
88
89 nelt(p) = nel;
90
91 free_stack(2*n);
92
93 return;
94
95
96 end fnct tupform;
1 .=member expand
2 subr expand(ht);
3
4$ this routine expands the hash table for a set or base, rehashing
5$ all its elements.
6$
7$ rehashing is always done in place. we allocate a new hash table
8$ and chain the eb's of the old hash table to it. this leaves all
9$ the hash headers of the new hash table unused.
10
11
12 size ht(ps); $ pointer to hash table
13
14 size nhedr(ps); $ number of headers in new hash table
15 size log(ps); $ log of nhedr
16
17 size tmp(ps); $ pointer to template block
18 size first(ps); $ pointer to first new hash header
19 size last(ps); $ pointer to last new hash header
20 size eb(ps); $ pointer to eb being initialized
21 size i(ps); $ loop index within current eb
22
23 size hashc(hcsz); $ hash code of current eb
24 size mask(hs); $ mask used to restrict hash code
25 size key(hs); $ restricted hash code
26 size head(ps); $ pointer to new hash header
27 size now(ps); $ pointer to current element block
28 size nxt(ps); $ pointer to next element block
29 size prev(ps); $ pointer to element block before nxt
30 size isb(1); $ set if we expand a base
31 size spec(hs); $ element block specifier
32
33 size gethash(hcsz); $ function called
34
35
36 tmp = ht + hl_ht; $ pointer to template block
37 isb = (htype(tmp) = h_ebb); $ flag base expansions
38$
39$ determine the size of the new hash table
40$
41 log = lognhedrs(ht)+1;
42
43 if (log >= hcsz) return; $ maximum hash code used
44 if (log >= max_logn) return; $ maximum value for lognhedrs
45
46 mask = onebits(log);
47 nhedr = pow2(log);
48$
49$ allocate and initialize new hash table
50$
51 $ there is at least one place in the library ('withs'), where
52 $ we assume that the re-allocation of the hash table does not
53 $ cause a garbage collection. the following test asserts this
54 $ assumption.
55 $ note that we call gethash, which is a recursive routine with
56 $ 14 local variables.
57 if ((t-h-(nhedr*hl_htb)-(max_depth*14)) < min_gap) return;
58 get_heap(nhedr * hl_htb, first);
59
60 $ initialize each hash header to a copy of the template and
61 $ link it to the next header. link the last header to the
62 $ template.
63
64 last = first + (nhedr-1) * hl_htb;
65
66 do eb = first to last by hl_htb;
67 htype(eb) = h_htb;
68 hlink(eb) = 0;
69 eblink(eb) = eb + hl_htb;
70 is_ebhedr(eb) = yes;
71 is_ebtemp(eb) = no;
72 end do;
73
74 eblink(last) = tmp; $ link last header to template
75$
76$ add elements of old hash table to clash lists.
77$
78 $ we iterate over the old hash table, inserting elements into
79 $ the new hash table. since we will be adjusting the eblinks
80 $ of the elements as we go, we must use a variant of the nor-
81 $ mal next_loop.
82 $
83 $ the variables used in this loop are:
84 $
85 $ now: element currently being moved
86 $ head: hash header on which it will be inserted.
87 $ nxt: next element block to be moved.
88
89 now = eblink(tmp); $ point to first hash header of old hash table
90
91 while 1;
92 if is_ebhedr(now) then
93 if (is_ebtemp(now)) quit while 1;
94
95 now = eblink(now);
96 cont while 1;
97 end if;
98$
99$ find the proper hash header. this code is similar to the code
100$ in 'init_probe', with the exceptions that we assume that the
101$ element had its hash calculated when it was inserted. if the
102$ element is itself a set or tuple, its hash field must still be
103$ valid.
104$
105$ when we expand the hash table of a base, we can take advantage
106$ of the fact that the clash lists are sorted in ascending hash
107$ order, and that the hash code of each element is saved in the eb.
108$
109 if isb then
110 hashc = ebhash(now);
111
112 else
113 spec = ebspec(now);
114
115 if ^ isprim(type_ spec) then
116 hashc = hash(value_ spec);
117 else
118 hashc = gethash(spec);
119 end if;
120 end if;
121
122 key = hashc & mask;
123 head = first + hl_htb * (.f. hcsz-log+1, log, key);
124
125 prev = now; nxt = eblink(now);
126
127 if isb then
128 while 2;
129 if (is_ebhedr(nxt)) quit while 2;
130 if (key ^= (ebhash(nxt) & mask)) quit while 2;
131
132 prev = nxt; nxt = eblink(nxt);
133 end while 2;
134 end if;
135
136 eblink(prev) = eblink(head);
137 eblink(head) = now;
138
139 now = nxt;
140 end while 1;
141
142 eblink(tmp) = first;
143
144 lognhedrs(ht) = log;
145
146
147 end subr expand;
1 .=member contract
2 subr contract(ht);
3
4$ this routine halfs the size of a hash table. we reuse the first
5$ half of the old hash table, combining each pair of clash lists of
6$ the old hash table to one clash list in the new hash table.
7
8
9 size ht(ps); $ pointer to hash table
10
11 size tmp(ps); $ pointer to template block
12 size head(ps); $ pointer to current new hash header
13 size now(ps); $ pointer to head of new clash list
14 size prev(ps); $ pointer to tail of old clash list
15 size nxt(ps); $ pointer to next old hash header
16 size p(ps); $ misc. pointer
17
18
19 tmp = ht + hl_ht;
20 head = eblink(tmp);
21$
22$ iterate over the set, combining clash lists and re-linking the
23$ hash headers.
24$
25 nxt = head;
26
27 until is_ebtemp(nxt);
28
29 $ save potential start of new clash list
30 now = eblink(nxt);
31
32 $ find the end of the even clash list
33 prev = nxt; nxt = now;
34
35 while ^ is_ebhedr(nxt);
36 prev = nxt; nxt = eblink(nxt);
37 end while;
38
39 $ if the current clash list is null, then update 'now' to
40 $ point to the head of the odd clash list; else update
41 $ the tail pointer of the even clash list to point to the
42 $ head of the odd clash list.
43 p = eblink(nxt);
44 if now = nxt then now = p; else eblink(prev) = p; end if;
45
46 $ find the end of the odd clash list
47 nxt = p; $ skip old header
48
49 while ^ is_ebhedr(nxt);
50 prev = nxt; nxt = eblink(nxt);
51 end while;
52
53 $ compute the pointer to the next hash header
54 if nxt = tmp then p = tmp; else p = head + hl_htb; end if;
55
56 $ if the current clash list is null, then update 'now' to
57 $ point to the next hash header; else update the tail
58 $ pointer of the current clash list to point to the next
59 $ hash header.
60 if now = nxt then now = p; else eblink(prev) = p; end if;
61
62 eblink(head) = now; head = p;
63
64 end until;
65$
66$ update the log of the number of hash headers
67$
68 lognhedrs(ht) = lognhedrs(ht) - 1;
69
70
71 end subr contract;
1 .=member exptup
2 subr exptup(tup, n);
3
4$ this routine rebuilds a tuple so that it has room for n elements.
5$ tup is the specifier for the tuple. we assume that no share bits
6$ need be set.
7
8
9 size tup(hs), $ specifier for tuple
10 n(ps); $ minimum new length
11
12 size p(ps), $ pointer to tuple
13 p1(ps), $ pointer to new components
14 newp(ps), $ pointer to new tuple
15 j(ps), $ loop index
16 om_val(hs), $ om component
17 extra(ps), $ extra words needed for packed tuple
18 maxi(ps), $ currnet maximum index of tuple
19 nmaxi(ps), $ new maximum index
20 len(ps); $ its current length, including header
21
22
23$ begin by getting a pointer to the tuple, and splitting out packed
24$ tuples for special treatment.
25
26 p = value_ tup;
27
28 if (htype(p) = h_ptuple) go to packed;
29
30$ otherwise proceed with standard tuples. get current maximum index
31$ and storage allocation, then see if the tuple was the last thing
32$ allocated. if not, move it to the top of the heap.
33
34 maxi = maxindx(p);
35 len = tuplen(p);
36
37 if p + len = h then $ last thing allocated
38 newp = p;
39
40 else $ move to top of heap
41 get_heap(len, newp);
42
43 do j = 0 to len-1;
44 heap(newp+j) = heap(p+j);
45 end do;
46
47 value_ tup = newp; is_shared_ tup = no;
48 end if;
49
50$ now get space for the new components and copy the template.
51
52 nmaxi = n + breath_space(n); $ new maximum index
53 get_heap(nmaxi-maxi, p1); $ allocate extra space
54
55 om_val = tcomp(newp, 0); $ initialize new components
56
57 do j = maxi+1 to nmaxi;
58 tcomp(newp, j) = om_val;
59 end do;
60
61 maxindx(newp) = nmaxi; $ reset alloc.
62
63 return;
64
65
66/packed/ $ packed tuples
67
68$ the algorithm for packed tuples is identical to the above,
69$ except that we calculate block sizes, etc. using macros for
70$ packed tuples.
71
72 maxi = maxindx(p);
73 len = ptuplen(p);
74
75 if p + len = h then
76 newp = p;
77
78 else
79 get_heap(len, newp);
80
81 do j = 0 to len-1;
82 heap(newp+j) = heap(p+j);
83 end do;
84
85 value_ tup = newp; is_shared_ tup = no;
86 end if;
87
88$ now extend tuple in place
89
90 nmaxi = n + breath_space(n);
91 extra = palloc(p, nmaxi) - palloc(p, maxi);
92
93 get_heap(extra, p1);
94
95 do j = 0 to extra-1; $ zero out extra words.
96 heap(p1+j) = 0;
97 end do;
98
99 maxindx(newp) = nmaxi; $ store new maximum index
100
101 return;
102
103
104 end subr exptup;
1 .=member explc
2 subr explc(ss, n);
3
4$ this routine rebuilds a character string so that it has room
5$ for -n- characters.
smfc 75
smfc 76
smfc 77 size ss(ssz); $ string specifier
smfc 78 size n(ps); $ new minimum length
smfc 79
smfc 80 size p(ps); $ pointer to data block
smfc 81 size len(ps); $ length of data block (in words)
smfc 82 size total(ps); $ total allocation used (in characters)
smfc 83 size newss(ssz); $ new string specifier
smfc 84 size new(ps); $ pointer to new data block
smfc 85
smfc 86 size nulllc(ssz); $ allocates null string
26$ begin by checking whether we can extend the current string, or
27$ whether we must build a new one. the current string can be
28$ extended if
29
30$ 1. its at the end of a long character data block.
31
32$ 2. the data block was the last thing allocated.
33
34 p = ss_ptr(ss); $ point to data block and get length
35 len = lc_nwords(p);
36
37$ get total number of characters from start of block to the end of
38$ the string. see if this equals the length of the block.
39 total = ss_ofs(ss) + ss_len(ss);
40
41 if p+len = h & lcalloc(total) = len then $ reuse block
42
43 get_heap(lcalloc(n)-lc_nwords(p), new); $ get extra block
44 lc_nwords(p) = lcalloc(n);
45
46 else $ get new block and copy
smfc 87 newss = nulllc(n); ss_len(newss) = ss_len(ss);
48
49 mvc(newss, ss, ss_len(ss));
50
51 ss = newss; $ return specifier for new ss
52 end if;
53
54
55 end subr explc;
1 .=member exprmap
2 fnct exprmap(map, n);
3
4$ this routine expands the tuple for a remote map. -map- is a pointer to
5$ the map and -n- is the minimum size for the new tuple. a pointer
6$ to the new map is returned.
7
8
11 size exprmap(ps); $ pointer to map returned
12
13 size map(ps), $ pointer to original map
14 n(ps); $ new capacity of map
15
16 size spec(hs), $ specifier for tuple contained in map
17 tup(hs), $ specifier for tuple
18 len(ps), $ current length of map
19
20 l(ps), $ length of header
21 p(ps), $ pointer to tuple
22 j(ps); $ loop index
23
24
28$ remote maps are expaned in three steps
29
30$ 1. build a specifier for the embedded tuple.
31$ 2. copy the set header to the top of the heap if necessary
32$ 3. call exptup to expand the embedded tuple.
33
34 l = hl(htype(map));
35 p = map + l;
36
37 go to case(htype(p)) in h_tuple to h_rtuple;
38
39/case(h_tuple)/ $ standard tuple
40
41 build_spec(tup, t_tuple, p);
42 len = l + tuplen(p);
43 go to esac;
44
45/case(h_ptuple)/ $ packed tuple
46
47 build_spec(tup, t_stuple, p);
48 len = l + ptuplen(p);
49 go to esac;
50
51
52/case(h_ituple)/ $ untyped tuples
53
54/case(h_rtuple)/
55
56 build_spec(tup, t_stuple, p);
57 len = l + tuplen(p);
58 go to esac;
59
60
61/esac/ $ end of case
62
63$ see if the map is on top of the heap. if not, copy the set header.
64
65 if map+len = h then $ on top of heap
66 exprmap = map;
67
68 else $ move set header to top of heap
69 get_heap(l, exprmap);
70
71 do j = 0 to l-1;
72 heap(exprmap+j) = heap(map+j);
73 end do;
74 end if;
75
76 call exptup(tup, n); $ move tuple on top of it.
77
79
80 end fnct exprmap;
1 .=member exprset
2 fnct exprset(s, n);
3
4$ this routine expands a remote set. if the set is already on the
5$ top of the heap, we expand it in place.
6
7
8 size exprset(ps); $ pointer to new set returned
9
10 size s(ps), $ pointer to old set
11 n(ps); $ new capacity of set
12
13 size total(ps), $ total length of new set
14 len(ps), $ length of old set
15 extra(ps); $ extra words needed
16
17 size p(ps), $ pointer to new block
18 j(ps); $ loop index
19
20
21 total = rsalloc(n); $ length of new set
22 len = rswords(s) + hl_rset; $ current length
23
24 extra = total - len; $ extra space needed
25
26 if s + len ^= h then $ copy s to top of heap
27 get_heap(len, p);
28
29 do j = 0 to len-1;
30 heap(p+j) = heap(s+j);
31 end do;
32
33 exprset = p;
34
35 else $ expand in place
36 exprset = s;
37 end if;
38
39$ allocate extra words and inialize to 0.
40 get_heap(extra, p);
41
42 do j = 0 to extra-1;
43 heap(p+j) = 0;
44 end do;
45$
46$ finally set rs_maxi. since the bit strings in remote sets are
47$ zero origined, this will always be one less than a multiple
48$ of rs_bpw. in particular if k is the floor of n/rs_bpw it
49$ will be k * rs_bpw + (rs_bpw-1).
50$
51 rs_maxi(exprset) = (n/rs_bpw)*rs_bpw + (rs_bpw-1);
52
53
54 end fnct exprset;
55 ..part3
1 .=member gethash
2 .+part4.
3 fnct gethash(spec);
4
5$ this routine calculates the hash code corresponding to a given
6$ specifier. it is recursive to handle the hash codes of sets,
7$ maps and tuples.
8
9$ this routine is called in many inner loops and should be carefully
10$ instrumented.
11$ if the arguments form allows it, we set the objects is_hashok
12$ bit once the hash is validated.
13
14$ it is inexpensive, and in some cases, necessary, to compute the
15$ nelt of sets and tuples as we compute their hashes. as with
16$ the calculation of hashes, we store the nelt in the set or tuple
17$ header, but only turn on is_neltok if the form allows.
18
19$ the hash code of an object depends only on its value, not its
20$ representation. in particular the hash code of a map must be
21$ equivlent to the hash code of a set of pairs.
22
23
24 size gethash(hcsz); $ hash code returned
25
26 size spec(hs); $ specifier for item to be hashed
27
28 size arg(hs); $ argument to recursive part of routine
29
30 size tstart(ps); $ stack pointer at start of routine
31
32 size i(ps); $ loop index
33 size j(ps); $ loop index
34 size word(hs); $ data word of long string, etc
35 size char_hash(hcsz); $ hash of group of characters
36 size ss(ssz); $ string specifier
37 size len(ps); $ length of character string
38 size key(hs); $ descriptor for packed tuples
39 size ebb(ps); $ ls_bit of set
40 size ebw(ps); $ ls_word of set
41 size om_val(hs); $ untyped om value
42
43 size fval(hs); $ function called
mjsa 122 size hashli(hcsz); $ computes hash for long integers
44
45
46$ stacked variables
47
48 .=zzyorg b $ reset counters for stack offsets
49
50 local(retpt); $ return pointer
51
52 local(p); $ pointer to long value
53
54 local(indx); $ loop index
55 local(lim); $ loop limit
56
57 local(tuphc); $ hash code of tuple
58 local(comphash); $ component hash
59 local(n); $ nelt
60
61 local(s); $ pointer to set
62 local(sethc); $ hash code of set
63 local(e); $ pointer to current eb
64 local(x); $ domain element
65 local(im); $ map image
66 local(hash_x); $ hash of x
67 local(hash_im); $ hash of im
68
69
70 .+st init_time(st_hash);
71
72 tstart = t; $ save initial recursion stack pointer
73
74 .=zzyorg a $ reset counter for return labels
75
76 arg = spec; $ make local copy of specifier
77
78
79/entry/ $ recursive entry point
80
81 r_entry; $ increment recursion stack
82
83/switch/ $ branch on type
84
85 go to case(otype_ arg) in t_min to t_max;
86
87
88/case(t_int)/ $ short atomic types
89
90/case(t_atom)/
91
92/case(t_proc)/ $ procedures
93
94/case(t_lab)/ $ label
95
stra 413$ we use the low order bits of the value field. these are accessed
99$ through the macro 'short_hash'.
100
101 gethash = hcsd * short_hash(arg);
102
103 go to exit;
104
105
stra 414/case(t_string)/ $ short character string
stra 415
stra 416$ the hash code of a short character string is the same as the hash code
stra 417$ for a long character string of the same value.
stra 418
stra 419 len = sc_nchars_ arg;
stra 420 if len = 0 then
stra 421 gethash = 0;
stra 422 else
stra 423 gethash = hcsd * (2 * (scchar(arg, 1)) + 1);
stra 424 end if;
stra 425 go to exit;
106
107/case(t_elmt)/ $ element
108
109$ if arg is a base element we can get its hash from the base eb.
110$ otherwise arg points to an element which was hashed when it
111$ was put into the set. if the element itself is a set or tuple,
112$ its hash field must still be valid.
113
114 p = value_ arg; $ get pointer into set.
115
116 if htype(p) = h_ebb then
117 gethash = ebhash(p);
118
119 go to exit;
120
121 else
122$ dereference arg and see if it is a set or tuple. if so, its hash
123$ field is still valid.
124 deref(arg);
125
126 if ^ isprim(otype_ arg) then $ set or tuple
127 gethash = hash(value_ arg);
128 go to exit;
129 end if;
130
131 go to switch; $ recalculate hash
132 end if;
133
134
135/case(t_latom)/ $ long atom
136
137 gethash = hcsd * la_value(value_ arg);
138
139 go to exit;
140
141
142/case(t_real)/ $ real
143
144$ the hash of a real is the same as that of an integer, namely
145$ its low order bits. this means the hash of a normalized real
146$ is usually zero, a very poor idea, but it also means that the
147$ same code can be used to hash all untyped tuples. since sets of
148$ reals are almost unheard of anyway, there is no loss.
149
150 gethash = hcsd * (.f. 1, hcsz, rval(value_ arg));
151
152 go to exit;
153
154
155/case(t_lint)/ $ long integers
156
mjsa 123 gethash = hashli(arg);
162
163 go to exit;
164
165
166/case(t_istring)/
167
168 ss = value_ arg; $ get string specifier
169 len = ss_len(ss); $ and length of string
170
171 if len = 0 then
172 gethash = 0;
173 else
174 gethash = icchar(ss, 1) + icchar(ss, ss_len(ss)) + ss_len(ss);
175 gethash = hcsd * gethash;
176 end if;
177 go to exit;
178
179
180
181/case(t_tuple)/ $ standard tuples
182
183$ the hash code of a tuple t is the setl expression
184$
185$ hc_tuple + +/[ i * hash(x) : x = t(i)]
186$
187$ where hc_tuple is a constant used to distinguish between the
188$ hash codes for [1] and <<1>>.
189
190
191 p = value_ arg; $ get pointer to tuple
192
193 if is_hashok(p) then $ already have hash
194 gethash = hash(p);
195 go to exit;
196 end if;
197
198
199 indx = 1; $ initialize for loop
200 lim = nelt(p);
201
202 tuphc = hc_tuple; $ hash code of tuple
203
204 while indx <= lim;
205 arg = tcomp(p, indx);
206
207 if ^ is_om_ arg then
208 r_call; $ get hash recursively.
209 tuphc = tuphc + indx * gethash;$ adjust hash then incremen
210 end if;
211
212 indx = indx + 1;
213 end while;
214
215
216 set_hash(p, tuphc);
217
218 gethash = tuphc;
219 go to exit;
220
221/case(t_stuple)/ $ special tuple
222
223$ we use the same function for special tuples. real and integer tuples
224$ share the same loop.
225
226 p = value_ arg; $ get pointer to tuple
227
228 if is_hashok(p) then $ already have hash
229 gethash = hash(p);
230 go to exit;
231 end if;
232
233
234 go to tc(htype(p)) in h_ptuple to h_rtuple;
235
236
237/tc(h_ptuple)/ $ packed tuple
238
239 indx = 1; $ initialize loop
240 lim = nelt(p);
241
242 tuphc = hc_tuple; $ hash code for tuple
243
244 key = ptkey(p);
245
246 while indx <= lim;
247
248 word = pcomp(p, indx);
249 unpack(key, word, arg);
250
251 if ^ is_om_ arg then
252 r_call; $ get hash recursively
253 tuphc = tuphc + indx * gethash; $ adjust hash
254 end if;
255
256 indx = indx + 1;
257
258 end while;
259
260 set_hash(p, tuphc);
261 gethash = tuphc;
262
263 go to exit;
264
265
266/tc(h_ituple)/ $ untyped integer tuple
267
268/tc(h_rtuple)/ $ untyped real tuple
269
270$ iterate over the tuple, computing the hash of each component as if
271$ it were a real, short int, or long int. in all three cases, this
272$ means merely taking the low order bits.
273
274 gethash = hc_tuple;
275
276 om_val = tcomp(p, 0); $ get om value
277
278 do i = 1 to nelt(p);
279
280 word = tcomp(p, i); $ get untyped component
281 if (word = om_val) cont do i;
282
283 gethash = gethash + i * hcsd * (.f. 1, hcsz, word);
284 end do;
285
286 set_hash(p, gethash);
287
288 go to exit;
289
290
291/case(t_set)/ $ sets
292
293$ the hash code of a set is the sum
294$
295$ hc_set + +/[ hash(x) : x in s]
296$
297$ since we are iterating through the set anyway, we also update its
298$ nelt.
299
300$ see if the hash of the set is already valid. otherwise initialize
301$ sethc to the hash of a null set, and n to 0, then jump on the type of
302$ the set.
303
304 s = value_ arg; $ get pointer to set.
305
306 if is_hashok(s) then $ already have hash
307 gethash = hash(s);
308 go to exit;
309 end if;
310
311
312 sethc = hc_set; $ hash of set
313 n = 0; $ nelt of set.
314
315$ jump on type of set
316
317 go to sc(htype(s)) in h_uset to h_rset;
318
319
320/sc(h_uset)/ $ unbased set
321
322$ iterate over the set, adding the hash of each element. each
323$ element was hashed when it was put into the set. therefore, if
324$ the element is itself a set or tuple, its hash field is still
325$ valid.
326
327 next_loop(e, s);
328
329 arg = ebspec(e);
330 n = n+1; $ nelt of set
331
332 if isprim(type_ arg) then $ recompute hash
333 r_call;
334 sethc = sethc + gethash;
335
336 else $ reuse hash in header
337 sethc = sethc + hash(value_ arg);
338 end if;
339
340 end_next;
341
342 go to esac;
343
344
345/sc(h_lset)/ $ local set
346
347$ get the hash of each element from the base.
348
349 ebb = ls_bit(s); $ get ls_bit and ls_word of set
350 ebw = ls_word(s);
351
352 next_loop(e, s); $ iterate over base
353
354 if (.f. ebb, 1, heap(e+ebw) = no) cont; $ not in set
355
356 sethc = sethc + ebhash(e);
357 n = n+1;
358
359 end_next;
360
361 go to esac;
362
363
364/sc(h_rset)/ $ remote set
365
366$ this case is very similar to the above, except in the way we test
367$ membership.
368
369 next_loop(e, s);
370
371 i = ebindx(e);
372
373 if (i > rs_maxi(s)) cont_next;
374 if (rsbit(s, i) = no) cont_next;
375
376 sethc = sethc + ebhash(e);
377 n = n+1;
378 end_next;
379
380 go to esac;
381
382
383/esac/ $ end of set case
384
385 set_hash(s, sethc); $ save nelt and hash
386 set_nelt(s, n);
387
388 gethash = sethc;
389 go to exit;
390
391
392/case(t_map)/ $ maps
393
394$ the hash code of a map is computed as if it were a set of pairs.
395$ as usual, we begin by checking whether the hash is already
396$ available.
397
398$ since the hash code of a map is hard to compute and rarely
399$ needed, there is a tempation to merely convert the map to
400$ a set. however this conversion would require mutual recursion
401$ of the convert, equality and hash routines.
402
403 if is_hashok(value_ arg) then $ already have hash
404 gethash = hash(value_ arg);
405 go to exit;
406 end if;
407
408$ we compute the hash as follows:
409$
410$ 1. initialize the hash 'sethc' to hc_set and the nelt 'n' to 0.
411$
412$ 2. set 's' to point to the map and iterate for all x in s.
413$
414$ 3. if the image of x is single valued, set sethc to
415$ sethc + hc_tuple + hash(x) + 2 * hash(f(x))
416$ set n to n+1.
417$
418$ 4. otherwise, set sethc to
419$ sethc + +/[ hc_tuple + hash(x) + 2*hash(y) : y in f<>]
420$
421$ we do some factoring of this expression to avoid the iteration
422$ and come up with:
423$
424$ sethc := sethc + # f<> * (hc_tuple + hash(x))
425$ + 2 * (hash(f<>) - hc_set);
426$
427$ in addition, we set n to n + # f<>.
428
429
430 s = value_ arg;
431
432 sethc = hc_set;
433 n = 0;
434
435 next_loop(e, s);
436
437 x = ebspec(e);
438 im = fval(s, e, no);
439
440 if (is_om_ im) cont;
441
442 arg = x; $ get hash of x
443 r_call;
444
445 hash_x = gethash;
446
447 arg = im; $ get hash of f(x) or f@x\.
448 r_call;
449
450 hash_im = gethash;
451
452 if is_multi_ im then
453 p = value_ im;
454 if (nelt(p) = 0) cont;
455
456 sethc = sethc + nelt(p) * (hc_tuple + hash_x) +
457 2 * (hash_im - hc_set);
458
459 n = n + nelt(p);
460
461 else
462 sethc = sethc + hc_tuple + hash_x + 2 * hash_im;
463 n = n + 1;
464 end if;
465
466 end_next;
467
468 set_hash(s, sethc);
469 set_nelt(s, n);
470
471 gethash = sethc;
472
473 go to exit;
474
475case_om; $ om types
476
477 gethash = 0; $ all nils have a hash of 0.
478
479 go to exit;
480
481
482
483/exit/
484
485 gethash = .f. 1, hcsz, gethash;
486
487 r_exit;
488
489 if t ^= tstart then
490 go to rlab(retpt) in 1 to zzya;
491 else
492 .+st save_time(st_hash);
493 return;
494 end if;
495
496
497
498$ drop local variables
499
500 macdrop8(retpt, p, i, lim, tuphc, n, s, sethc)
501 macdrop4(e, indx, x, im);
502 macdrop2(hash_x, hash_im);
503
504 end fnct gethash;
1 .=member getnelt
2 fnct getnelt(spec);
3
4$ this routine handles the setl nelt operator. it returns ? spec
5$ as a short integer. sets and tuples are handled by calling
6$ 'oknelt'.
7
11 size getnelt(hs); $ specifier returned
12
13 size spec(hs); $ specifier for argument
14
15 size arg(hs), $ copy of argument
16 n(ps), $ result as untyped integer
17 ss(ssz); $ string specifier
18
19
23$ copy spec so that it can be dereferenced, then jump on its type
24 arg = spec;
25
26/switch/ $ jump on type
27
28 go to case(otype_ arg) in t_min to t_max;
29
30
31
33/case(t_int)/ $ short int
34
35 go to error;
36
37/case(t_string)/ $ short character strings
38
39 n = sc_nchars_ arg;
40 go to esac;
41
42/case(t_atom)/ $ error types
43
44/case(t_proc)/ $ procedures
45
46/case(t_lab)/ $ labels
47
48/case(t_latom)/ $ long atom
49
50 go to error;
51
52/case(t_elmt)/ $ element
53
54 deref(arg);
55 go to switch;
56
57
58/case(t_lint)/ $ long integers
59
60 go to error;
61
62/case(t_istring)/ $ long chars
63
64 ss = value_ arg;
65 n = ss_len(ss);
66 go to esac;
67
68
69/case(t_real)/ $ reals
70
71 go to error;
72
73/case(t_tuple)/ $ tuples and sets
74
75/case(t_stuple)/
76
77/case(t_set)/
78
79/case(t_map)/
80
81 ok_nelt(arg);
82 n = nelt(value_ arg);
83 go to esac;
84
85case_om; $ om types
86
87 call err_om(15);
88
89 getnelt = err_val(f_gen);
90
91 return;
92
93
94/esac/ $ build specifier and return
95
96 build_spec(getnelt, t_int, n);
97
98 return;
99
100
101/error/ $ type error
102
103 call err_type(32);
104
105 getnelt = err_val(f_gen);
106
107 return;
108
109
110 end fnct getnelt;
1 .=member okneltr
2 subr okneltr(spec);
3
4$ this routine updates the nelt of a set or tuple. we assume that
5$ its nelt field is invalid on entry to the routine. on exit the
6$ nelt field is valid. in addition, the objects is_neltok bit has
7$ been turned on if its form allows it.
8
9$ the routine consists of an inner recursive section which determines
10$ the objects nelt and a section which stores it in the set/map header.
11$ the nelt is always placed in the variable -n- then stored in the
12$ header.
13
14
15$ variable declarations
16
17 size spec(hs); $ specifier for set or tuple
18
19 size arg(hs); $ local copy of argument
20
21 size tstart(ps); $ recursion stack pointer at start of routine
22
23 size j(ps), $ loop index
24 im(hs), $ map image
25 om_val(hs); $ untyped om
26
27
28 size fval(hs); $ function called
29
30$ stacked variables
31
32 .=zzyorg b $ reset counters for stack offsets
33
34 local(retpt); $ return pointer
35
36 local(e); $ pointer to current eb
37 local(im); $ specifier for its image
38 local(n); $ nelt being calculated
39 local(p); $ pointer to set or tuple
40 local(bit); $ ls_bit of local object
41 local(word); $ ls_word of local object
42
43
44
45
46/begin/ $ begin execution
47
48 .+st init_time(st_nelt);
49 tstart = t; $ save initial recursion stack pointer
50
51 .=zzyorg a $ reset counter for return labels
52
53 arg = spec; $ make local copy of argument
54
55
56/entry/ $ recursive entry point
57
58 r_entry; $ increment recursion stack
59
60 p = value_ arg; $ get pointer to set or tuple
61
62 go to case(htype(p)) in h_tuple to h_lrmap;
63
64
65/case(h_tuple)/ $ standard tuple
66
67$ assume nelt is equal to maxindx, and then work towards the start of
68$ the tuple, looking for the first defined element.
69 n = maxindx(p);
70
71 while n > 0 & is_om_ tcomp(p, n);
72 n = n-1;
73 end while;
74
75 go to done;
76
77
78/case(h_ituple)/ $ untyped integer tuple
79
80/case(h_rtuple)/ $ untyped real tuple
81
82$ we use a loop similar to the above, comparing elements with the
83$ appropriate om value
84
85 om_val = tcomp(p, 0); $ get om value
86
87 n = maxindx(p);
88
89 while n > 0 & tcomp(p, n) = om_val;
90 n = n-1;
91 end while;
92
93 go to done;
94
95
96/case(h_ptuple)/ $ packed tuples
97
98 n = maxindx(p); $ use alloc for first assumption
99
100 while n > 0 & pcomp(p, n) = 0; $ this loop can be faster
101 n = n-1;
102 end while;
103
104 go to done;
105
106
107/case(h_uset)/ $ unbased set.
108
109$ the nelt of an unbased set is the neb of its hash table
110 n = neb(hashtb(p));
111 go to done;
112
113
114/case(h_rset)/ $ remote based set
115
116$ the nelt of a remote set is the nelt of its bit string.
117
118 n = 0;
119
120 do j = 1 to rswords(p);
121 n = n + .nb. rsword(p, j);
122 end do;
123
124 go to done;
125
126
127/case(h_lset)/ $ local based set
128$ the nelt of a local set is the number of membership bits on for it
129$ in its base.
130
131 bit = ls_bit(p); $ get bit and word position in base.
132 word = ls_word(p);
133
134 n = 0;
135
136 next_loop(e, p); $ iterate over base
137
138 n = n + .f. bit, 1, heap(e+word);
139
140 end_next;
141
142 go to done;
143
144
145
146/case(h_umap)/ $ maps
147
148/case(h_lmap)/
149
150/case(h_rmap)/
151
152/case(h_limap)/
153
154/case(h_lrmap)/
155
156/case(h_lpmap)/
157
158/case(h_rimap)/
159
160/case(h_rrmap)/
161
162/case(h_rpmap)/
163
164
165$ calculating the nelt of a map is a recursive procedure involving
166$ a nelt calculation on all its range sets. our procedure has
167$ four steps:
168
169$ 1. set n to 0.
170$ 2. iterate for all x _ f, and set im = fval(f, x).
171$ 3. if im has its is_multi bit set, add in the nelt of the range set
172$ 4. otherwise add 1 if im is not om.
173
174 n = 0;
175
176 next_loop(e, p); $ iterate over domain.
177
178 im = fval(p, e, no); $ get image
179
180 if is_multi_ im then $ add in nelt of range set.
181 if ^ is_neltok(value_ im) then $ update nelt of range set
182 arg = im;
183 r_call;
184 end if;
185
186 n = n+nelt(value_ im);
187
188 else $ singlevalued
189 if (^ is_om_ im) n = n+1;
190 end if;
191
192 end_next;
193
194 go to done;
195
196
197/done/ $ store nelt in header
198
199 set_nelt(p, n);
200
201
202/exit/ $ recursive exit point
203 r_exit;
204
205 if t ^= tstart then $ recursive return
206 go to rlab(retpt) in 1 to zzya;
207 else
208 .+st save_time(st_nelt);
209 return;
210 end if;
211
212
213
214$ drop local variables
215
216 macdrop4(retpt, n, p, bit)
217 macdrop2(word, im);
218 macdrop(e)
219
220 end subr okneltr;
1 .=member nullp
2 fnct nullp(set);
3
4$ this predicate tests a set to see if it is null.
5$ if the set is null, we set its nelt to 0. we also set its
6$ is_neltok flag if the form allows.
7
8$ variable declarations
9
10 size nullp(1); $ boolean value returned
11
12 size set(ps); $ pointer to set
13
14 size tstart(ps); $ pointer to recursion stack at start of routine
15
16 size s(ps); $ parameter to recursive routine
17
18 size j(ps), $ loop index
19 im(hs); $ map image
20
21
22 size fval(hs); $ function called
23
24$ stacked variables
25
26 .=zzyorg b $ reset counters for stack offsets
27
28 local(retpt); $ return pointer
29
30 local(bit); $ ls_bit of local set
31 local(word); $ ls_word of local set or map
32
33 local(e); $ pointer to current eb
34 local(map); $ pointer to map being tested
35
36
37
38$ begin execution
39
40 tstart = t; $ save initial recursion stack pointer.
41
42 .=zzyorg a $ reset counter for return labels
43
44 s = set; $ local copy of argument
45
46 if is_neltok(s) then $ nelt valid on top level
47 nullp = (nelt(s) = 0);
48 return;
49 end if;
50
51
52/entry/ $ recursive entry point
53
54 $ nb. heap_valid = no during garbage collections.
55 $ nb. this routine has five local variables, about to be pushed
56 $ onto the stack.
57 .+gt if (^ heap_valid & (t - h - 5) < min_gap) call err_fatal(50);
58
59 r_entry; $ increment recursion stack
60
61 if (neb(hashtb(s)) = 0) go to pass; $ hash table empty
62
63$ jump on type
64 go to case(htype(s)) in h_uset to h_lrmap;
65
66
67/case(h_uset)/ $ unbased set
68
69/case(h_umap)/ $ unbased map
70
71 go to fail; $ since hash table is non empty.
72
73
74/case(h_rset)/ $ remote set
75
76 $ see if any bits of bitstring are on.
77 do j = 1 to rswords(s);
78 if (rsword(s, j) ^= 0) go to fail;
79 end do;
80
81 go to pass;
82
83
84/case(h_lset)/ $ local set
85
86 bit = ls_bit(s); $ get bit and word position in base.
87 word = ls_word(s);
88
89 next_loop(e, s); $ iterate over base
90 if (.f. bit, 1, heap(e+word) ^= 0) go to fail;
91 end_next;
92
93 go to pass;
94
95
96/case(h_lmap)/ $ local map
97
98/case(h_rmap)/ $ remote map
99
100/case(h_lpmap)/ $ local packed map
101
102/case(h_rpmap)/ $ remote packed map
103
104
105$ iterate over the domain. if this is an mmap, see whether all
106$ images are null. otherwise see if they are all om.
107
108 map = s; $ save pointer to map
109
110 next_loop(e, map); $ iterate over domain.
111
112 im = fval(map, e, no); $ get image
113
114 if is_mmap(map) then
115 s = value_ im;
116
117 if is_neltok(s) then
118 if (nelt(s) ^= 0) go to fail;
119 else
120 r_call;
121 if (^ nullp) go to fail;
122 end if;
123
124 else $ single valued
125 if (^ is_om_ im) go to fail;
126
127 end if;
128 end_next;
129
130 s = map; $ restore parameter
131
132 go to pass;
133
134
135/case(h_limap)/ $ local integer map
136
137 word = ls_word(s);
138
139 next_loop(e, s);
140 if (heap(e + word) = om_int) go to fail;
141 end_next;
142
143 go to pass;
144
145
146/case(h_lrmap)/ $ local real map
147
148 word = ls_word(s);
149
150 next_loop(e, s);
151 if (heap(e + word) = om_real) go to fail;
152 end_next;
153
154 go to pass;
155
156
157/case(h_rimap)/ $ remote integer map
158
159 next_loop(e, s);
160 if (ebindx(e) > maxindx(s+hl_rmap)) go to fail;
161 if (tcomp(s+hl_rmap, ebindx(e)) = om_int) go to fail;
162 end_next;
163
164 go to pass;
165
166
167/case(h_rrmap)/ $ remote real map
168
169 next_loop(e, s);
170 if (ebindx(e) > maxindx(s+hl_rmap)) go to fail;
171 if (tcomp(s+hl_rmap, ebindx(e)) = om_int) go to fail;
172 end_next;
173
174 go to pass;
175
176
177/pass/ $ return true
178
179$ as long as we know s-s nelt is zero, we set its nelt and is_neltok
180$ fields before returning.
181 set_nelt(s, 0);
182
183 nullp = yes;
184 go to exit;
185
186
187/fail/ $ return false
188
189 nullp = no;
190
191
192/exit/ $ recursive exit point
193
194 r_exit; $ pop recursion stack
195
196 if t ^= tstart then $ recursive return
197 go to rlab(retpt) in 1 to zzya;
198 else
199 return;
200 end if;
201
202
203
204$ drop local variables
205
206 macdrop4(retpt, bit, word, e);
207 macdrop(map);
208
209
210 end fnct nullp;
1 .=member arb
2 fnct arb(arg);
3
4$ this is the general setl arb routine. it is called when the mode
5$ of the argument is not known at compile time. it calls the arbs
6$ routine for sets and maps, the only modes for which arb is defined.
7
8
9 size arg(hs); $ specifier for set or map
10 size arb(hs); $ specifier returned
11 size a(hs); $ local copy of argument
12 size arbs(hs); $ routine to compute arb(set_mode)
13
14
15 a = arg; deref(a);
16
17 if ^ isset(otype_ a) then $ error conditions
18 if is_om_ a then
19 call err_om(16);
20 else
21 call err_type(33);
22 end if;
23
24 if isprim(type_ a) then
25 arb = err_val(f_gen);
26 else
27 arb = err_val(hform(value_ a));
28 end if;
29
30 else
31 arb = arbs(a);
32 end if;
33
34
35 end fnct arb;
1 .=member arbs
2 fnct arbs(set);
3
4$ this routine performs the 'arb' function on sets and maps.
5
6
7$ variable declarations
8
9 size arbs(hs); $ specifier returned
10
11 size set(hs); $ specifier for set
12
13 size tstart(ps); $ recursion stack pointer at start of routine
14
15 size s(ps); $ pointer to set, used as argument to recursive
16 $ part of routine.
17
18
19 size e(ps), $ pointer to eb
20 p(ps); $ pointer to pair
21
22 size bit(ps), $ ls_bit of set
23 word(ps), $ ls_word of set
24 indx(ps); $ ebindx of element
25
26 size nullp(1), $ functions called
27 fval(hs);
28
29$ stacked variables
30
31 .=zzyorg b $ reset counters for stack offsets
32
33 local(retpt); $ return pointer
34
35 local(map); $ pointer to map
36
37 local(dom); $ domain specifier
38 local(im); $ image specifier
39
40 local(ended); $ flags end of hash table
41
42
43
44/begin/ $ begin execution
45
46 tstart = t; $ save initial recursion stack pointer
47
48 .=zzyorg a $ reset counter for return labels
49
50 s = value_ set; $ get pointer to set
51
52/entry/ $ recursive entry point
53
54 r_entry; $ increment recursion stack
55
56 if (^ is_map(s)) go to case_set; $ branch for sets
57
58
59/case_map/ $ map cases
60
61 map = s; $ save pointer to map we are iterating over
62
63
64$ find domain element
65
66$ we begin by finding the first domain element whose image is
67$ defined. for mmaps, we must skip domain elements whose images
68$ are null range sets.
69
70 next_loop(e, map); $ iterate over domain
71
72 im = fval(map, e, yes); $ get image
73
74 if is_mmap(map) then $ look for non-null image
75 p = value_ im; $ get pointer to range set
76
77 if is_neltok(p) then
78 if (nelt(p) ^= 0) quit;
79 else
80 if (^ nullp(p)) quit;
81 end if;
82
83 else $ look for defined image
84 if (^ is_om_ im) quit;
85 end if;
86
87 end_next;
88
89$ build specifier for domain element
90
91 if is_based(map) then $ value is element of base
92 build_spec(dom, t_elmt, e);
93
94 else $ value is actual specifier in set
95 is_shared_ ebspec(e) = yes;
96 dom = ebspec(e);
97 end if;
98$
99$ special case: null map
100$
101 if is_ebtemp(e) then
102 is_om_ dom = yes;
103 im = fval(map, e, yes);
104 ended = yes;
105 else
106 ended = no;
107 end if;
108
109$ do arb on range set if necessary
110
111 if is_multi_ im then $ get arbitrary element of range set
112 s = value_ im;
113 r_call;
114
115 im = arbs;
116 end if;
117
118$ build pair .
119
120 get_pair(p);
121
122 hform(p) = ft_elmt(hform(map)); $ get form and base array from map
123
124 tcomp(p, 1) = dom; $ set components
125 tcomp(p, 2) = im;
126
127 build_spec(arbs, t_tuple, p); $ build specifier
128 if (ended = yes) is_om_ arbs = yes; $ flag omega result
129
130 go to exit;
131
132
133
134
135/case_set/ $ set cases
136
137$ special case null sets
138
139 if is_neltok(s) & nelt(s) = 0 then $ null set
140
141 if is_based(s) then $ return base element
142 build_spec(arbs, t_oelmt, template(s));
143 else $ return value
144 arbs = ebspec(template(s));
145 end if;
146
147 go to exit;
148 end if;
149
150 $ jump on type
151
152 go to sc(htype(s)) in h_uset to h_rset;
153
154
155/sc(h_uset)/ $ unbased set
156
157$ look for the first element which is not a dummy hash header. we
158$ do this with a next_loop which quits the first time we enter
159$ the body of the loop.
160
161 next_loop(e, s);
162
163 quit;
164
165 end_next;
166
167$ value is actual specifier in set. we assume that the eb specifier for
168$ the template has its is_om bit already set, so there is no need to
169$ test whether the set is empty.
170$
171 is_shared_ ebspec(e) = yes;
172 arbs = ebspec(e);
173
174 go to exit;
175
176
177
178/sc(h_lset)/ $ local based set
179
180$ find arb element of base with membership bit on.
181
182 bit = ls_bit(s); $ get bit and word offset
183 word = ls_word(s);
184
185
186 next_loop(e, s); $ iterate over base
187
188 if (.f. bit, 1, heap(e+word)) quit; $ in set
189
190 end_next;
191
192
193 build_spec(arbs, t_elmt, e); $ value is element of base
194 if (is_ebtemp(e)) is_om_ arbs = yes; $ flag end of set
195
196 go to exit;
197
198
199
200/sc(h_rset)/ $ remote based set
201
202$ advance in base looking for arb element with membership bit on.
203
204 next_loop(e, s); $ iterate over base
205
206 indx = ebindx(e); $ get base index
207
208 if (indx > rs_maxi(s)) cont;
209
210 if (rsbit(s, indx)) quit;
211
212 end_next;
213
214
215 build_spec(arbs, t_elmt, e); $ value is element of base
216 if (is_ebtemp(e)) is_om_ arbs = yes; $ flag end of set
217
218 go to exit;
219
220
221
222/exit/ $ recursive exit
223
224 r_exit;
225
226 if t ^= tstart then $ recursive return
227 go to rlab(retpt) in 1 to zzya;
228
229 else
230 return;
231 end if;
232
233
234
235$ drop local variables
236
237 macdrop4(retpt, map, dom, im)
238 macdrop(ended)
239
240 end fnct arbs;
1 .=member arb1
2
3 fnct arb1(im);
4
5$ this routine is used to convert a map image from mmap form to map
6$ form. im is a specifier for a map image with its is_multi flag set.
7$ if im represents a null or singleton set, we perform -arb- on it.
8$ otherwise we return it unchanged.
9
10
11 size arb1(hs); $ specifier returned
12
13 size im(hs); $ specifier for image
14
15 size arbs(hs); $ function called
16
17
18 ok_nelt(im); $ update its nelt.
19
20 if nelt(value_ im) <= 1 then $ get element
21 arb1 = arbs(im);
22 else $ return im
23 arb1 = im;
24 end if;
25
26
27 end fnct arb1;
1 .=member dom
2 fnct dom(arg, fm);
3
4$ this routine calculates the domain of a set or map. there are
5$ three possible cases:
6
7$ 1. arg is a set. convert it to a map and proceed as in case(3).
8
9$ 2. arg is a based map. iterate over the base, finding all
10$ base elements which are in the domain of the map and
11$ put them into the result.
12
13$ 3. arg is an unbased map. build a nullset with the same number
14$ of hash headers as the map, then iterate over each clash list
15$ of the map, putting domain elements onto the corresponding
16$ clash list of the result.
17
18
19 size arg(hs); $ specifier for set or map
20 size fm(ps); $ form of result
21
22 size dom(hs); $ specifier returned
23
24 size map(hs), $ specifier for map
25 m(ps), $ pointer to map
26 mmap_flag(1), $ true for m-maps
27 conv_flag(1), $ true if element conversion required
28 based_flag(1), $ true if result is based subset
29 s(ps), $ pointer to set being build
30 logn(ps), $ lognhedrs of map
31 n(ps), $ estimate of nelt of result
32 count(ps), $ actual nelt of result
33 eb(ps), $ pointer to current eb of map
34 im(hs), $ image
35 p(ps), $ pointer to range set
36 spec(hs); $ specifier for domain element
37 size xfm(ps); $ element form of result
38
39 size nullset(hs), $ builds null set
40 nullp(1), $ tests for null set
41 setform(hs), $ set former
42 convert(hs),
43 convsm(hs), $ converts set to map
44 fval(hs); $ returns functional value
45
46
47 map = arg;
48 deref(map);
49
50 if (otype_ map = t_set) map = convsm(map, f_umap);
51
52 if otype_ map ^= t_map then
53 if is_om_ map then
54 call err_om(30);
55 else
56 call err_type(34);
57 end if;
58
59 dom = err_val(fm);
60 return;
61 end if;
62
63$ split up the based and unbased cases.
64
65 m = value_ map;
66
67 if ft_elmt(fm) ^= ft_dom(hform(m)) then
68 conv_flag = yes; xfm = ft_elmt(fm);
69 else
70 conv_flag = no;
71 end if;
72
73 if (htype(m) = h_umap) go to unbased;
74
75/based/ $ based case
76
77 count = 0; mmap_flag = is_mmap(m);
78
79 next_loop(eb, m);
80 im = fval(m, eb, no);
81
82 if mmap_flag then
83 p = value_ im;
84
85 if is_neltok(p) then
86 if (nelt(p) = 0) cont;
87 else
88 if (nullp(p)) cont;
89 end if;
90
91 else
92 if (is_om_ im) cont;
93 end if;
94
95 build_spec(spec, t_elmt, eb);
96 if (conv_flag) spec = convert(spec, xfm);
97 push1(spec);
98
99 count = count + 1;
100 end_next;
101
102 dom = setform(fm, count);
103
104 return;
105
106
107/unbased/ $ unbased case
108
109$ allocate a null set with the same number of headers as
110$ the map.
111
112 logn = lognhedrs(hashtb(m));
113 n = pow2(logn);
114
115 dom = nullset(fm, n);
116 s = value_ dom;
117
118 based_flag = is_based(s);
119
120$ iterate over map, inserting elements in set
121
122 count = 0; $ nelt of domain
123
124 next_loop(eb, m);
125 spec = ebspec(eb);
126 if (conv_flag) spec = convert(spec, xfm);
127
128 call locate(p, spec, s, yes);
129 if (based_flag) call sfval(s, p, yes); $ set subset bit
130
131 count = count + 1;
132 end_next;
133
134 set_nelt(s, count); $ set nelt and hash.
135 is_hashok(s) = no;
136
137 return;
138
139 end fnct dom;
1 .=member range
2 fnct range(arg, fm);
3
4$ this routine finds the range of a set or map. as with the
5$ domain function, we handle sets by converting a temporary
6$ copy of the set to a map.
7
8$ our algorithm is as follows:
9
10$ 1. iterate for all x _ domain map
11
12$ 2. get the set im to the image of x.
13
14$ 3. if im is multi valued, set the result to result + im;
15$ otherwise set result = result with im.
16
17
18 size arg(hs); $ specifier for set or map
19 size fm(ps); $ form of result
20
21 size range(hs); $ specifier returned
22
23 size map(hs), $ specifier for map
24 m(ps), $ pointer to map
25 x(ps), $ pointer to domain
26 im(hs), $ specifier for image
27 s(ps); $ pointer to result set
28 size sfm(ps); $ intermediate set form
29 size xfm(ps); $ set element form
30 size conv_flag(1); $ true if element conversion required
31
32 size fval(hs), $ functions called
33 withs(hs),
34 union(hs),
35 convert(hs),
36 convsm(hs),
37 nullset(hs);
38
39
40$ convert to map if necessary
41
42 map = arg;
43 deref(map);
44
45 if (otype_ map = t_set) map = convsm(map, f_umap);
46
47 if otype_ map ^= t_map then
48 if is_om_ map then
49 call err_om(31);
50 else
51 call err_type(35);
52 end if;
53
54 range = err_val(fm);
55 return;
56 end if;
57
58 m = value_ map;
59
60 if ft_type(fm) = f_lset & ^ is_smap(m) then
61 sfm = f_uset;
62 else
63 sfm = fm;
64 end if;
65
66 if ft_elmt(sfm) ^= ft_im(hform(m)) then
67 conv_flag = yes; xfm = ft_elmt(sfm);
68 else
69 conv_flag = no;
70 end if;
71
72$ allocate null set with same nelt as map
73 ok_nelt(map);
74 range = nullset(sfm, nelt(m));
75
76$ iterate over map, inserting range elements in set.
77
78 next_loop(x, m);
79 im = fval(m, x, yes);
80
81 if is_multi_ im then
82 if (hform(value_ im) ^= sfm) im = convert(im, sfm);
83 range = union(range, im, yes);
84
85 elseif ^ is_om_ im then
86 if (conv_flag) im = convert(im, xfm);
87 range = withs(range, im, yes);
88 end if;
89
90 end_next;
91
92 if (fm ^= sfm) range = convert(range, fm);
93
94
95 end fnct range;
1 .=member subst
2 fnct subst(arg1, arg2, arg3);
3
4$ this is the top level routine for substring extraction. it
5$ returns -arg1(arg2 ... arg3)-. most of the work is done by
6$ lower level routines.
7
8
9 size arg1(hs), $ specifier for string or tuple
10 arg2(hs), $ specifier for first component
11 arg3(hs); $ specifier for last component
12
13 size subst(hs); $ specifier returned
14
15 size a1(hs), $ copies of arguments
16 a2(hs),
17 a3(hs);
18
19 size first(ps), $ first component of substring
20 last(ps), $ last component of substring
21 j(ps); $ loop index
22
23 size substt(hs), $ functions called
24 substs(hs);
25
26
27 a1 = arg1; $ copy arguments
28 a2 = arg2;
29 a3 = arg3;
30
31 deref(a2);
32 deref(a3);
33
34$ check types of bounds
35
36 if otype_ a2 ^= t_int then
37 call err_type(37);
38 go to error;
39 end if;
40
41 if otype_ a3 ^= t_int then
42 call err_type(38);
43 go to error;
44 end if;
45
46$ check range of lower bound: 1 <= a2 <= a3+1
47
48 if eq(a2, zero) then
49 call err_misc(35);
50 go to error;
51 end if;
52
53 if ivalue_ a2 > (ivalue_ a3)+1 then
54 call err_misc(36);
55 go to error;
56 end if;
57
58/switch/
59
60 go to case(otype_ a1) in t_min to t_max;
61
62
63/case(t_int)/ $ short integer
64
65 go to error1;
66
67
68/case(t_string)/ $ short character string
69
74
75 first = ivalue_ a2;
76 last = ivalue_ a3;
77
78 if last > sc_nchars_ a1 then
79 call err_misc(37);
80 go to error;
81 end if;
82
strb 153 if last = first then $ must be s(1..1)
strb 154 subst = a1;
strb 155 else $ s(1..0) or s(2..1)
strb 156 build_spec(subst, t_string, 0);
strb 157 end if;
89
90 return;
91
92
93/case(t_atom)/ $ short atom
94
95/case(t_proc)/
96
97/case(t_lab)/
98
99/case(t_latom)/ $ long atom
100
101 go to error1;
102
103
104/case(t_elmt)/ $ compressed element
105
106 deref(a1);
107 go to switch;
108
109
110/case(t_lint)/ $ long integer
111
112 go to error1;
113
114
115/case(t_istring)/ $ long character string
116
117 subst = substs(a1, a2, a3);
118 return;
119
120
121/case(t_real)/ $ real
122
123 go to error1;
124
125
126/case(t_tuple)/ $ standard tuple
127
128/case(t_stuple)/ $ packed or untyped tuple
129
130 subst = substt(a1, a2, a3);
131 return;
132
133
134/case(t_set)/ $ set
135
136/case(t_map)/ $ map
137
138 go to error1;
139
140
141case_om; $ om type
142
143 call err_om(17);
144
145/error/ $ return proper error value
146
147 if isprim(type_ a1) then
148 subst = err_val(f_gen);
149 else
150 subst = err_val(hform(value_ a1));
151 end if;
152
153 return;
154
155/error1/ $ illegal type for -a1-
156
157 call err_type(36);
158
159 subst = err_val(f_gen);
160
161 return;
162
163
164 end fnct subst;
1 .=member substt
2 fnct substt(a1, a2, a3);
3
4$ this routine returns -a(a2...a3)- for tuples. it does not use
5$ any of its arguments destructively.
6
7$ n.b. -a1- is a specifier for a tuple
8$ -a2- and -a3- are specifiers for short integers
9$ 1 <= a2 <= a3+1
10
11
12 size a1(hs), $ specifier for tuple
13 a2(hs), $ specifier for first component
14 a3(hs); $ specifier for last component
15
16 size substt(hs); $ specifier for result
17
18 size oldp(ps), $ pointer to original tuple
19 newp(ps); $ pointer to new tuple
20
21 size first(ps), $ first component
22 last(ps), $ last component
23 len(ps), $ expected length of new tuple
24 card(ps); $ actual length of new tuple
25
26 size om_val(hs); $ omega value
27
28 size j(ps); $ loop index
29
30 size nulltup(hs); $ builds null tuple
31
32
33 oldp = value_ a1; $ get values of arguments
34 first = ivalue_ a2;
35 last = ivalue_ a3;
36
37$ if we have:
38
39$ t := [1, 2, 3, 4];
40$ s := t(3 ... 6);
41
42$ then we will return the tuple [3, 4] with a lot of nils at the
43$ end of it. this means that the length of the result is really
44$ the minimum of a3 and the length of a1(a2 ...).
45
46 if (last > nelt(oldp)) last = nelt(oldp);
47
48 len = last + 1 - first;
49
50$ if we have:
51
52$ t := [1, om, om, 4];
53$ s := t(1 ... 3);
54
55$ then we shall return the tuple [1], since we don-t save omegas at
56$ the end of the tuple. the variable -card- saves the index of the
57$ last non-omega value of the new tuple.
58
59 card = 0; $ actual length of tuple
60
61 substt = nulltup(hform(oldp), len);
62 newp = value_ substt;
63
64$ copy components
65
66 go to case(htype(newp)) in h_tuple to h_rtuple;
67
68
69/case(h_tuple)/ $ standard tuple
70
71$ copy components and set share bits
72
73 do j = 1 to len;
74 is_shared_ tcomp(oldp, (first-1) + j) = yes;
75 tcomp(newp, j) = tcomp(oldp, (first-1) + j);
76 if (^ is_om_ tcomp(newp, j)) card = j;
77 end do;
78
79 go to esac;
80
81
82/case(h_ptuple)/ $ packed tuple
83
84 om_val = pcomp(oldp, 0);
85
86 do j = 1 to len;
87 pcomp(newp, j) = pcomp(oldp, (first-1) + j);
88 if (pcomp(newp, j) ^= om_val) card = j;
89 end do;
90
91 go to esac;
92
93
94/case(h_ituple)/ $ untyped tuples
95
96/case(h_rtuple)/
97
98 om_val = tcomp(oldp, 0);
99
100 do j = 1 to len;
101 tcomp(newp, j) = tcomp(oldp, (first-1) + j);
102 if (tcomp(newp, j) ^= om_val) card = j;
103 end do;
104
105 go to esac;
106
107
108/esac/ $ build result specifier and return
109
110 set_nelt(newp, card);
111
112 build_spec(substt, type_ a1, newp);
113
114
115 end fnct substt;
1 .=member substs
2 fnct substs(a1, a2, a3);
3
4$ this routine returns -a1(a2...a3)- on indirect strings.
5
6$ n.b. -a1- is a specifier for an indirect string
7$ -a2- and -a3- are specifiers for short integers
8$ 1 <= a2 <= a3+1
9
10
11 size a1(hs), $ specifier for string
12 a2(hs), $ specifier for first component
13 a3(hs); $ specifier for last component
14
15 size substs(hs); $ specifier returned
16
17 size ss1(ssz), $ string specifier for a1
18 ss(ssz), $ specifier for result
19 first(ps), $ position of first component
20 last(ps), $ position of last component
21 len(ps); $ length
22
23
24 ss1 = value_ a1; $ get values of arguments
25 first = ivalue_ a2;
26 last = ivalue_ a3;
27
28$ check range of upper bound: a3 <= ?a1
29
30 if last > ss_len(ss1) then
31 call err_misc(38);
32 substs = err_val(f_gen);
33 return;
34 end if;
35
36 len = last + 1 - first; $ get length of substring
37
strb 158 if len <= sc_max then $ result is short string
stra 434 if len = 0 then $ result is null string
stra 435 build_spec(substs, t_string, 0);
stra 436 else $ result is single character
stra 437 substs = spec_char; $ one-character template
stra 438 scchar(substs, 1) = icchar(ss1, first);
stra 439 end if;
stra 440 else
stra 441 build_ss(ss, ss_ptr(ss1), ss_ofs(ss1) + first - 1, len);
stra 442 build_spec(substs, t_istring, ss);
stra 443 end if;
stra 444
43
44 end fnct substs;
1 .=member ssubst
2 fnct ssubst(arg1, arg2, arg3, arg4);
3
4$ this is the top level routine for substring assingments. it
5$ returns -arg1(arg2 ... arg3) := arg4-. most of the work is
6$ done by lower level routines.
7
8
9 size arg1(hs), $ specifiers for arguments
10 arg2(hs),
11 arg3(hs),
12 arg4(hs);
13
14 size ssubst(hs); $ specifier returned
15
16 size a1(hs), $ copies of arguments
17 a2(hs),
18 a3(hs),
19 a4(hs);
20
21 size j(ps), $ loop index
22 first(ps), $ first component
23 last(ps);
stra 445 size len1(ps); $ length of -a1-
stra 446 size len4(ps); $ length of -a4-
stra 447 size len(ps); $ length of result
stra 448 size ss(ssz); $ string specifier
24
25 size ssbsts(hs); $ ssubst on strings
26 size ssbstt(hs); $ ssubst on tuples
27 size convert(hs); $ conversion utility
28 size copy1(hs); $ copy utility
stra 449 size nulllc(ssz); $ allocates null string
29
30
31 a1 = arg1; $ copy arguments
32 a2 = arg2; deref(a2);
33 a3 = arg3; deref(a3);
34 a4 = arg4;
35
36$ check types of bounds
37
38 if otype_ a2 ^= t_int then
39 call err_type(55);
40 go to error;
41 end if;
42
43 if otype_ a3 ^= t_int then
44 call err_type(56);
45 go to error;
46 end if;
47
48$ check range of lower bound: 1 <= a2 <= a3+1
49
50 if eq(a2, zero) then
51 call err_misc(39);
52 go to error;
53 end if;
54
55 if ivalue_ a2 > (ivalue_ a3)+1 then
56 call err_misc(40);
57 go to error;
58 end if;
59
60/switch/
61
62 go to case(otype_ a1) in t_min to t_max;
63
64
65/case(t_int)/ $ short integer
66
67 go to error1;
68
69
70/case(t_string)/ $ short character strings
71
stra 450 if (otype_ a4 ^= t_string & otype_ a4 ^= t_istring) go to error4;
79
80 first = ivalue_ a2;
81 last = ivalue_ a3;
82
stra 451$ check range of upper bound: a3 <= #a1
stra 452
stra 453 len1 = sc_nchars_ a1; $ get length
stra 454
84
stra 455 if last > len1 then
86 call err_misc(41);
87 go to error;
88 end if;
89
stra 458 if otype_ a4 = t_string then $ short character string
stra 459 len4 = sc_nchars_ a4; $ get length
stra 460 len = len1 + len4 - (last + 1 - first);
stra 461 if len = 0 then $ result is null
stra 462 build_spec(ssubst, t_string, 0);
stra 463 elseif len <= sc_max then $ result is short
stra 464 if len4 then a1 = a4; end if;
stra 465 else $ len = 2
stra 466 ss = nulllc(len); $ allocate result string
stra 467 ss_len(ss) = len; $ set length
stra 468 icchar(ss, 1) = scchar(a4, 1);
stra 469 icchar(ss, 2) = scchar(a1, 1);
stra 470 end if;
stra 471 else $ otype_ a4 = t_istring: convert a1 to long string
stra 472 ss = nulllc(len1); $ allocate null string block
stra 473 ss_len(ss) = len1; $ set length of converted string
stra 474 if len1 then icchar(ss, 1) = scchar(a1, 1); end if;
stra 475 build_spec(a1, t_istring, ss);
stra 476 go to case(t_istring);
stra 477 end if;
stra 478
stra 479 return;
91
92
93/case(t_atom)/ $ short atom
94
95/case(t_proc)/ $ procs
96
97/case(t_lab)/ $ labels
98
99/case(t_latom)/ $ long atom
100
101 go to error1;
102
103
104/case(t_elmt)/ $ compressed element
105
106 deref(a1); go to switch;
107
108
109/case(t_lint)/ $ long integer
110
111 go to error1;
112
113
114/case(t_istring)/ $ long chars
115
stra 480 if (otype_ a4 ^= t_string & otype_ a4 ^= t_istring) go to error4;
117
118 if (ivalue_ a3 > ss_len(value_ a1)) go to error2;
stra 481
stra 482 if otype_ a4 = t_string then $ convert to long string
stra 483 len4 = sc_nchars_ a4; $ get length
stra 484 ss = nulllc(len4); $ allocate null string block
stra 485 ss_len(ss) = len1; $ set length of converted string
stra 486 if len4 then icchar(ss, 1) = scchar(a4, 1); end if;
stra 487 end if;
119
120 ssubst = ssbsts(a1, a2, a3, a4);
121
122 return;
123
124
125/case(t_real)/ $ real
126
127 go to error1;
128
129
130/case(t_tuple)/ $ standard tuple
131
132/case(t_stuple)/ $ packed or untyped tuple
133
134 if (otype_ a4 ^= t_tuple & otype_ a4 ^= t_stuple)
135 go to error4;
136
137 ssubst = ssbstt(a1, a2, a3, a4);
138
139 return;
140
141
142/case(t_set)/ $ set
143
144/case(t_map)/ $ map
145
146 go to error1;
147
148
149case_om; $ om type
150
151 call err_om(18);
152
153 go to error;
154
155
156/error1/ $ illegal type for -a1-
157
158 call err_type(54);
159 a1 = err_val(f_gen);
160
161 return;
162
163
164/error2/ $ index out of range for strings
165
166 call err_misc(41);
167 go to error;
168
169
170/error4/ $ incompatible types for -a1- and -a4-
171
172 call err_type(57);
173
174/error/ $ assign proper error value to -a1-
175
176 if isprim(type_ a1) then
177 a1 = err_val(f_gen);
178 else
179 a1 = err_val(hform(value_ a1));
180 end if;
181
182 return;
183
184
185 end fnct ssubst;
1 .=member ssubstt
2 fnct ssbstt(a1, a2, a3, a4);
3
4$ this routine performs -a1(a2 ... a3) := a4- on tuples. since
5$ this operation is relatively rare, it is performed by a series
6$ of calls to the -of- and -sof- routines.
7
8$ n.b. -a1- and -a4- are specifiers for tuples
9$ -a2- and -a3- are specifiers for short integers
10$ 1 <= a2 <= a3+1
11
12
13 size a1(hs), $ specifiers for arguments
14 a2(hs),
15 a3(hs),
16 a4(hs);
17
18 size ssbstt(hs); $ specifier returned
19
20 size indx1(hs), $ index over -a1- as setl integer
21 indx4(hs), $ index over -a4- as setl integer
22 indxs(hs), $ index over -ssbstt-
23 comp(hs); $ component being copied
24
25 size len1(ps), $ ?a1
26 len4(ps); $ ?a4
27
28 size first(ps), $ index of first component
29 last(ps), $ index of last component
30 len(ps), $ length of result
31 j(ps); $ loop index
32
33 size nulltup(hs), $ functions called
34 copy1(hs);
35
36
37 len1 = nelt(value_ a1); $ get lengths of tuples
38 len4 = nelt(value_ a4);
39
40 first = ivalue_ a2; $ get bounds of subtuple
41 last = ivalue_ a3;
42
43
44$ compute nelt of result
45
46 len = len1 + len4 - (last + 1 - first);
47
48 ssbstt = a1;
49
50 if (len > maxindx(value_ ssbstt)) call exptup(ssbstt, len);
51 if (is_shared_ ssbstt) ssbstt = copy1(ssbstt);
52$
53$ we distinguish two cases:
54$
55$ 1. ?ssubstt = ?a1: we copy -a1- if it is shared, then copy -a4-
56$ into -a1- and return its specifier.
57$
58$ 2. ?ssubstt ^= ?a1: we allocate a new block, then copy the parts
59$ of -a1- and -a4- into this block and return
60$ its specifier.
61$
62 if len = len1 then
63 indx1 = a2;
64 indx4 = one;
65
66 do j = 1 to len4;
67 call of(comp, a4, indx4);
68 call sof(ssbstt, indx1, comp);
69
70 add1(indx1);
71 add1(indx4);
72 end do;
73
74 else $ # ssbstt /= # a1
75 $ we would have to duplicate code if we expand, taking
76 $ into account whether we expand or contract the tuple.
77 if value_ ssbstt = value_ a1 then
78 ssbstt = nulltup(hform(value_ ssbstt), len);
79 end if;
80
81$ ssubstt( 1 ... (a2-1) ) := a1( 1 ... (a2-1) )
82
83 indx1 = one;
84 indxs = one;
85
86 do j = 1 to first - 1;
87 call of(comp, a1, indx1);
88 call sof(ssbstt, indxs, comp);
89
90 add1(indx1);
91 add1(indxs);
92 end do;
93
94
95$ ssubstt( a2 ... a2+?a4-1 ) := a4( 1 ... ?a4 )
96
97 indx4 = one;
98
99 do j = 1 to len4;
100 call of(comp, a4, indx4);
101 call sof(ssbstt, indxs, comp);
102
103 add1(indx4);
104 add1(indxs);
105 end do;
106
107
108$ ssubstt( a2+?a4 ... ?ssubstt ) := a1( a3+1 ... ?a1 )
109
110 indx1 = a3;
111
112 do j = 1 to len1 - last;
113 add1(indx1);
114
115 call of(comp, a1, indx1);
116 call sof(ssbstt, indxs, comp);
117
118 add1(indxs);
119 end do;
120
121 $ if we did not allocate a null tuple, we must set the re-
122 $ maining components to the proper omega. this must be done,
123 $ since otherwise the okneltr routine will fail to compute the
124 $ cardinality correctly.
125 do j = len + 1 to len1;
126 call sof(ssbstt, indxs, spec_om);
127
128 add1(indxs);
129 end do;
130
131 nelt(value_ ssbstt) = len;
132
133 end if;
134
135
136 end fnct ssbstt;
1 .=member ssubsts
2 fnct ssbsts(a1, a2, a3, a4);
3
4$ this routine performs -a1(a2...a3) := a4- on indirect strings.
5
6$ n.b. -a1- and -a4- are specifiers for indirect strings
7$ -a2- and -a3- are specifiers for short integers
8$ 1 <= a2 <= a3+1 <= #a1+1
9
10
11 size a1(hs), $ specifiers for arguments
12 a2(hs),
13 a3(hs),
14 a4(hs);
15
16 size ssbsts(hs); $ specifier returned
17
18 size ss1(ssz), $ string specifier for -a1-
19 ss4(ssz), $ string specifier for -a4-
20 newss(ssz); $ string specifier of result
21
22 size first(ps), $ first character of substring
23 last(ps), $ last character of substring
24 len1(ps), $ length of -a1-
25 len4(ps), $ length of -a4-
26 len(ps), $ length of result
27 temp(ps), $ temporary end of result string
28 j(ps); $ loop index
29
30 size mvc_ss1(ssz); $ string specifiers for system variables
31 size mvc_ss2(ssz);
32
33 size nulllc(ssz); $ function called
34
35
36 $ unpack the arguments
37 ss1 = value_ a1; len1 = ss_len(ss1);
38 ss4 = value_ a4; len4 = ss_len(ss4);
39 first = ivalue_ a2; last = ivalue_ a3;
40
41 $ assert that the global string specifiers have been allocated
42 assert runtime_flag;
43 mvc_ss1 = value(s_ss1); mvc_ss2 = value(s_ss2);
44$
45$ compute the length of the result string, then allocate the result
46$ string block
47$
48 len = len1 + len4 - (last + 1 - first);
stra 488
stra 489 if len = 0 then $ result is null string
stra 490 build_spec(ssbsts, t_string, 0);
stra 491 elseif len <= sc_max then $ result is short
stra 492 ssbsts = spec_char; $ one-character template
stra 493 if len4 then
stra 494 scchar(ssbsts, 1) = icchar(ss4, 1);
stra 495 else
stra 496 scchar(ssbsts, 1) = icchar(ss1, 1);
stra 497 end if;
stra 498 return;
stra 499 end if;
49
50 newss = nulllc(len);
51 ss_len(newss) = len;
52 build_spec(ssbsts, t_istring, newss);
53
54 ss_ptr(mvc_ss1) = ss_ptr(newss);
55 ss_ofs(mvc_ss1) = ss_ofs(newss);
56 ss_len(mvc_ss1) = len;
57
58$ ssubsts( 1 ... (a2-1) ) := a1( 1 ... (a2-1) )
59
60 temp = first - 1; $ temp := (a2-1)
61
62 ss_ptr(mvc_ss2) = ss_ptr(ss1);
63 ss_ofs(mvc_ss2) = ss_ofs(ss1);
64 ss_len(mvc_ss2) = len1;
65
66 mvc(mvc_ss1, mvc_ss2, temp);
67
68$ ssubsts( (a2-1)+1 ... (a2-1)+?a4 ) := a4( 1 ... ?a4 )
69
70 ss_ofs(mvc_ss1) = ss_ofs(mvc_ss1) + temp;
71 ss_len(mvc_ss1) = ss_len(mvc_ss1) - temp;
72
73 mvc(mvc_ss1, ss4, len4);
74
75$ ssubsts( (a2-1+?a4)+1 ... ?ssubsts ) := a1( a3+1 ... ?a1 )
76
77 ss_ofs(mvc_ss1) = ss_ofs(mvc_ss1) + len4;
78 ss_len(mvc_ss1) = ss_len(mvc_ss1) - len4;
79
80 ss_ofs(mvc_ss2) = ss_ofs(mvc_ss2) + last;
81 ss_len(mvc_ss2) = ss_len(mvc_ss2) - last;
82
83 mvc(mvc_ss1, mvc_ss2, ss_len(mvc_ss2));
84
85
86 end fnct ssbsts;
1 .=member endop
2 fnct endop(s1, low);
3
4$ this routine performs -s(low...)-. it treats this construct
5$ as a shorthand for -s(low... ?s)-.
6
7
8 size s1(hs); $ specifier for string or tuple
9 size low(hs); $ specifier for lower bound
10
11 size endop(hs); $ specifier returned
12
13 size s(hs); $ local copy of s1
14 size tp(ps), $ type of s
15 high(hs); $ ?s as short integer
16
17 size subst(hs); $ substring function
18
19
20 s = s1; deref(s);
21 tp = type_ s; $ find type of -s-
22
23 high = 0; $ set otype_ high = t_int
24
25 if tp = t_string then $ find ?s
26 ivalue_ high = sc_nchars_ s;
27
28 elseif tp = t_istring then
29 ivalue_ high = ss_len(value_ s);
30
31 elseif istuple(tp) then
32 ivalue_ high = nelt(value_ s);
33
34 else
35 call err_type(40);
36 endop = err_val(f_gen);
37 return;
38
39 end if;
40
41 endop = subst(s, low, high);
42
43
44 end fnct endop;
1 .=member send
2 fnct send(s1, low, y);
3
4$ this routine performs -s(low...) := y-. it treats this
5$ construct as a shorthand for -s(low ... ?s) := y-.
6$ it does it by calling -ssubst-.
7
8
9 size s1(hs); $ specifier for string or tuple
10 size low(hs); $ specifier for lower bound
11 size y(hs); $ specifier for right-hand side
12
13 size send(hs); $ specifier returned
14
15 size s(hs); $ local copy of s1
16 size tp(ps), $ type of s
17 high(hs); $ length of substring as short int
18
19 size ssubst(hs); $ function called
20
21
22 s = s1; deref(s);
23 tp = type_ s; $ find type of -s-
24
25 high = 0; $ set otype_ high = t_int
26
27 if tp = t_string then $ find ?s
28 ivalue_ high = sc_nchars_ s;
29
30 elseif tp = t_istring then
31 ivalue_ high = ss_len(value_ s);
32
33 elseif istuple(tp) then
34 ivalue_ high = nelt(value_ s);
35
36 else
37 call err_type(41);
38 send = err_val(f_gen);
39 return;
40
41 end if;
42
43 send = ssubst(s, low, high, y);
44
45
46 end fnct send;
1 .=member lt
2 fnct lt(arg1, arg2);
3
4$ this is the setl less than function. it returns 0 or 1
5$ as its value.
6
7$ less than may be applied to integers, reals, and strings.
8$ we compare two characters by comparing their internal
9$ character codes; one string is less than another if it
10$ would appear first in the phone book.
11
12
13 size arg1(hs); $ specifier for left operand
14 size arg2(hs); $ specifier for right operand
15
16 size lt(1); $ boolean value returned
17
18 size a1(hs); $ local copy of left operand
19 size a2(hs); $ local copy of right operand
20
21 size ss1(ssz); $ string specifier for left operand
stra 500 size len1(ps); $ length of left operand
22 size ss2(ssz); $ string specifier for right operand
stra 501 size len2(ps); $ length of right operand
23 size len(ps); $ length of string
24 size cc(ps); $ condition code
25 size j(ps); $ loop index
26 size c1(chsiz); $ characters
27 size c2(chsiz);
28
29 real real1, real2; $ real temporaries
mjsa 124
mjsa 125 size ltli(1); $ computes lt for long integers
30
31
32 a1 = arg1; deref(a1);
33 a2 = arg2; deref(a2);
34
35 go to case(otype_ a1) in t_min to t_max;
36
37
mjsa 126/case(t_int)/ $ short integer
mjsa 127
mjsa 128$ call the arbitrary precision arithmetic package if a2 is long
mjsa 129
mjsa 130 if otype_ a2 = t_int then
mjsa 131 lt = (ivalue_ a1 < ivalue_ a2);
mjsa 132
mjsa 133 elseif otype_ a2 = t_lint then
mjsa 134 lt = ltli(a1, a2);
mjsa 135
mjsa 136 else
mjsa 137 go to error;
mjsa 138 end if;
mjsa 139
mjsa 140 return;
53
54
55/case(t_string)/ $ short chars
56
stra 502 len1 = sc_nchars_ a1; $ get length of left operand
stra 503
stra 504 if otype_ a2 = t_istring then
stra 505 ss2 = value_ a2; len2 = ss_len(ss2);
stra 506 len = len1; if (len2 < len) len = len2;
stra 507 if len then $ non-trivial, must compare characters
stra 508 c1 = scchar(a1, 1); c2 = icchar(ss2, 1);
stra 509 if c1 ^= c2 then lt = (c1 < c2); return; end if;
stra 510 end if;
stra 511 lt = (len1 < len2);
stra 512
stra 513 elseif otype_ a2 = t_string then
stra 514 len2 = sc_nchars_ a2;
stra 515 len = len1; if (len2 < len) len = len2;
stra 516 if len then $ non-trivial, must compare characters
stra 517 c1 = scchar(a1, 1); c2 = scchar(a2, 1);
stra 518 if c1 ^= c2 then lt = (c1 < c2); return; end if;
stra 519 end if;
stra 520 lt = (len1 < len2);
stra 521
stra 522 else
stra 523 go to error;
stra 524 end if;
stra 525
79 return;
80
81
82/case(t_atom)/ $ short atom
83
84/case(t_proc)/
85
86/case(t_lab)/
87
88/case(t_latom)/ $ 'long' atom
89
90/case(t_elmt)/ $ compressed element
91
92 go to error;
93
94
mjsa 141/case(t_lint)/ $ long integer
mjsa 142
mjsa 143$ call the arbitrary precision arithmetic package since a1 is long
mjsa 144
mjsa 145 if otype_ a2 = t_int ! otype_ a2 = t_lint then
mjsa 146 lt = ltli(a1, a2);
mjsa 147 else
mjsa 148 go to error;
mjsa 149 end if;
mjsa 150
mjsa 151 return;
110
111
112/case(t_istring)/ $ long chars
113
stra 526 ss1 = value_ a1; len1 = ss_len(ss1);
stra 527
stra 528 if otype_ a2 = t_string then
stra 529 len2 = sc_nchars_ a2;
stra 530 len = len1; if (len2 < len) len = len2;
stra 531 if len then $ non-trivial, must compare characters
stra 532 c1 = icchar(ss1, 1); c2 = scchar(a2, 1);
stra 533 if c1 ^= c2 then lt = (c1 < c2); return; end if;
stra 534 end if;
stra 535 lt = (len1 < len2);
stra 536
stra 537 elseif otype_ a2 = t_istring then
stra 538 ss2 = value_ a2; len2 = ss_len(ss2);
stra 539 len = len1; if (len2 < len) len = len2;
stra 540 clc(cc, ss1, ss2, len);
stra 541 if cc = 0 then
stra 542 lt = (len1 < len2);
stra 543 else
stra 544 lt = (cc = 1);
stra 545 end if;
stra 546
stra 547 else
stra 548 go to error;
stra 549 end if;
129
130 return;
131
132
133/case(t_real)/ $ real
134
135 if (otype_ a2 ^= t_real) go to error;
136
137 real1 = rval(value_ a1);
138 real2 = rval(value_ a2);
139 lt = (real1 < real2);
140
141 return;
142
143
144/case(t_tuple)/ $ standard tuple
145
146/case(t_stuple)/ $ packed or untyped tuple
147
148/case(t_set)/ $ set
149
150/case(t_map)/ $ map
151
152 go to error;
153
154
155case_om; $ om type
156
157 call err_om(19);
158
159 lt = no;
160
161 return;
162
163/error/ $ illegal argument type
164
165 call err_type(42);
166 lt = no;
167
168 return;
169
170
190 end fnct lt;
1 .=member even
2 fnct even(arg);
3
4$ this is the setl 'even' predicate
5
6 size arg(hs); $ specifier for integer
7
8 size even(1); $ flag returned
9
10 size val(hs); $ value of integer
mjsa 152
mjsa 153 size evenli(1);
11
12
mjsa 154 if otype_ arg = t_int then
mjsa 155 .+s10 even = ( ^ .f. 1, 1, arg);
mjsa 156 .+s20 even = ( ^ .f. 1, 1, arg);
mjsa 157 .+r32 even = ( ^ .f. 3, 1, arg);
mjsa 158 .+s66 even = ( ^ .f. 1, 1, arg);
mjsa 159 else
mjsa 160 even = evenli(arg);
mjsa 161 end if;
17
18
19 end fnct even;
1 .=member min
2 fnct smin(a, b);
3
4$ this routine returns the minimum of two values a and b.
5$ min is defined on integers, reals, and strings. the
6$ minimum of two strings is the one which would appear
7$ first in the telephone book according to some machine
8$ dependant collating sequence.
9
10
11 size a(hs), $ items being compared
12 b(hs);
13
14 size smin(hs); $ specifier returned
15
16 size lt(1); $ setl less than function
17
18
19 if lt(a, b) then
20 smin = a;
21 else
22 smin = b;
23 end if;
24
25
26 end fnct smin;
1 .=member max
2 fnct smax(a, b);
3
4$ this routine returns the maximum of two values a and b.
5$ max is defined on integers, reals, and strings. the
6$ maximum of two strings is the one which would appear
7$ last in the telephone book according to some machine
8$ dependant collating sequence.
9
10
11 size a(hs), $ items being compared
12 b(hs);
13
14 size smax(hs); $ specifier returned
15
16 size lt(1); $ setl less than function
17
18
19 if lt(a, b) then
20 smax = b;
21 else
22 smax = a;
23 end if;
24
25
26 end fnct smax;
1 .=member addli
mjsa 162$ arbitrary precision arithmetic package
mjsa 163$ --------- --------- ---------- -------
mjsa 164
mjsa 165$ the setl arbitrary precision arithmetic package consists of a number
mjsa 166$ of functions whose arguments may be long or short integer specifiers,
mjsa 167$ and which return the specifier for a long or short integer. the
mjsa 168$ following routines are provided:
mjsa 169$
mjsa 170$ the main set of arithmetic routines are:
mjsa 171$
mjsa 172$ fnct addli(arg1, arg2) addition of integers
mjsa 173$ fnct diffli(arg1, arg2) subtraction of integers
mjsa 174$ fnct multli(arg1, arg2) multiplication
mjsa 175$ fnct divli(arg1, arg2) division
mjsa 176$ fnct modli(arg1, arg2) mod
mjsa 177$
mjsa 178$ fnct uminli(arg1) unary minus
mjsa 179$
mjsa 180$ the following predicates on setl integers return a little value of yes
mjsa 181$ or no (1 or 0).
mjsa 182$
mjsa 183$ fnct equalli(arg1, arg2) =
mjsa 184$ fnct ltli(arg1, arg2) <
mjsa 185$ fnct evenli(arg1, arg2) check for even integer
mjsa 186$
mjsa 187$ the following routines perform transformations between setl integer
mjsa 188$ and real values:
mjsa 189$
mjsa 190$ fnct floatli(arg1) floating point from integer
mjsa 191$ fnct fixli(arg1) returns long int from real notation
mjsa 192$
mjsa 193$ the following functions aid in performing input/output on integers.
mjsa 194$
mjsa 195$ fnct strli(arg1) transform integer to string
mjsa 196$ fnct putbli(arg1) output for long integers
mjsa 197$ fnct getbli(arg1) input for long integers
mjsa 198$
mjsa 199$ the following functions perform miscellaneous tasks.
mjsa 200$
mjsa 201$ fnct putintli(arg1) transform little integer to setl int
mjsa 202$ fnct getintli(arg1) transform setl integer to little int
mjsa 203$ fnct hashli(arg1) integrates long int into sets
mjsa 204$ fnct valli(arg1) transform string to integer
mjsa 205$
mjsa 206$ in addition, the following routines are provided but should never
mjsa 207$ be called from outside this package:
mjsa 208$
mjsa 209$ fnct intad1(arg1, arg2) add long int to short int
mjsa 210$ fnct intad2(arg1, arg2) add long int to long int
mjsa 211$ fnct intsb1(arg1, arg2) sub abs(long int) from short int
mjsa 212$ fnct intsb2(arg1, arg2) sub abs(long int) from abs(long int)
mjsa 213$ fnct intdiv(arg1, arg2) divide a long int by long int
mjsa 214$ fnct trlint(arg1) transform short int to long int
mjsa 215
mjsa 216
mjsa 217$ long integer arithmetic functions
mjsa 218$ ---- ------- ---------- ---------
mjsa 219
mjsa 220
mjsa 221 fnct addli(arg1, arg2);
mjsa 222
mjsa 223$ this routine takes as its arguments the specifiers to two integers
mjsa 224$ and returns the specifier to the sum of these two integers. it
mjsa 225$ normally calls the auxiliary additions and subtraction routines
mjsa 226$ to perform the calculations, although it does try to catch certain
mjsa 227$ special cases (namely short negative and short positive integers)
mjsa 228$ in-line.
mjsa 229
mjsa 230 size addli(hs); $ integer specifier returned
mjsa 231
mjsa 232 size arg1(hs); $ arguments are integer specifiers
mjsa 233 size arg2(hs);
mjsa 234
mjsa 235 size p1(ps); $ pointer to data block for arg1
mjsa 236 size p2(ps); $ pointer to data block for arg2
mjsa 237 size ptr(ps); $ pointer to data block for addli
mjsa 238 size s1(1); $ sign of arg1
mjsa 239 size s2(1); $ sign of arg2
mjsa 240 size temp(ws); $ stores value of small sums
mjsa 241
mjsa 242 size intad1(hs); $ functions used
mjsa 243 size intad2(hs);
mjsa 244 size intsb1(hs);
mjsa 245 size intsb2(hs);
mjsa 246 size ltli(1);
mjsa 247
mjsa 248
mjsa 249 if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 250
mjsa 251 temp = ivalue_ arg1 + ivalue_ arg2;
mjsa 252 if temp <= maxsi then $ result fits in specifier
mjsa 253 build_spec(addli, t_int, temp);
mjsa 254 else $ result requires data block
mjsa 255 build_lint1(addli, temp, positive);
mjsa 256 end if;
mjsa 257
mjsa 258 elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 259
mjsa 260 p2 = value_ arg2;
mjsa 261 if li_snint(p2) then
mjsa 262 temp = ivalue_ arg1 - li_ddigit(p2, 1);
mjsa 263 if temp >= 0 then
mjsa 264 build_spec(addli, t_int, temp);
mjsa 265 else
mjsa 266 build_lint1(addli, iabs(temp), negative);
mjsa 267 end if;
mjsa 268 elseif li_pos(p2) then
mjsa 269 addli = intad1(arg2, arg1, positive);
mjsa 270 else
mjsa 271 addli = intsb1(arg2, arg1, negative);
mjsa 272 end if;
mjsa 273
mjsa 274 elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 275
mjsa 276 p1 = value_ arg1;
mjsa 277 if li_snint(p1) then
mjsa 278 temp = ivalue_ arg2 - li_ddigit(p1, 1);
mjsa 279 if temp >= 0 then
mjsa 280 build_spec(addli, t_int, temp);
mjsa 281 else
mjsa 282 build_lint1(addli, iabs(temp), negative);
mjsa 283 end if;
mjsa 284 elseif li_pos(p1) then
mjsa 285 addli = intad1(arg1, arg2, positive);
mjsa 286 else
mjsa 287 addli = intsb1(arg1, arg2, negative);
mjsa 288 end if;
mjsa 289
mjsa 290 elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 291
mjsa 292$ two long integers: if the signs of the two integers are the same we
mjsa 293$ can simply call the long integer addition routine, setting the the
mjsa 294$ sign of the answer to be the same as that of either one of its
mjsa 295$ arguments. if one of the integers is positive and the other is
mjsa 296$ negative, then we save the signs of the two arguments and temporarly
mjsa 297$ set both arguments to their absolute value. we do this so that we can
mjsa 298$ compare the magnitudes of the two numbers using the function -ltli-
mjsa 299$ without having to recopy either of the two integers. before leaving
mjsa 300$ the routine we restore both of the arguments to their original sign.
mjsa 301
mjsa 302 p1 = value_ arg1;
mjsa 303 p2 = value_ arg2;
mjsa 304
mjsa 305 if li_sign(p1) = li_sign(p2) then
mjsa 306
mjsa 307 addli = intad2(arg1, arg2, li_sign(p1));
mjsa 308
mjsa 309 else $ the signs differ
mjsa 310
mjsa 311 s1 = li_sign(p1);
mjsa 312 s2 = li_sign(p2);
mjsa 313 li_sign(p1) = positive;
mjsa 314 li_sign(p2) = positive;
mjsa 315
mjsa 316 if ltli(arg1, arg2) then
mjsa 317 addli = intsb2(arg2, arg1, s2);
mjsa 318 else
mjsa 319 addli = intsb2(arg1, arg2, s1);
mjsa 320 end if;
mjsa 321
mjsa 322 li_sign(p1) = s1;
mjsa 323 li_sign(p2) = s2;
mjsa 324
mjsa 325 end if;
mjsa 326
mjsa 327 else $ one of the arguments is om
mjsa 328 call err_om(13);
mjsa 329 addli = err_val(f_int);
mjsa 330 end if;
mjsa 331
mjsa 332
mjsa 333 end fnct addli;
1 .=member diffli
mjsa 334 fnct diffli(arg1, arg2);
mjsa 335
mjsa 336$ this routine takes as its arguments the specifiers to two integers
mjsa 337$ and returns the specifier to the difference of these two integers.
mjsa 338$ it normally calls the auxiliary additions and subtraction
mjsa 339$ routines to perform the calculations, although it does try to catch
mjsa 340$ certain special cases (namely short negative and short positive
mjsa 341$ integers) in-line.
mjsa 342
mjsa 343 size diffli(hs); $ integer specifier returned
mjsa 344
mjsa 345 size arg1(hs); $ arguments are integer specifiers
mjsa 346 size arg2(hs);
mjsa 347
mjsa 348 size p1(ps); $ pointers to data blocks
mjsa 349 size p2(ps);
mjsa 350 size ptr(ps);
mjsa 351 size s1(1); $ sign of argument 1
mjsa 352 size s2(1); $ sign of argument 2
mjsa 353 size temp(ws); $ temporary values of differences
mjsa 354
mjsa 355 size intad1(hs); $ add long to short int
mjsa 356 size intad2(hs); $ add long to long int
mjsa 357 size intsb1(hs); $ subtract short from long int
mjsa 358 size intsb2(hs); $ subtract long int from long int
mjsa 359 size ltli(hs); $ less than for long integers
mjsa 360
mjsa 361$ although we break down the subtraction of two numbers into the
mjsa 362$ standard four cases, we also check within the first case for a
mjsa 363$ subtraction which will result in a short integer (or a negative
mjsa 364$ integer whose magnitude is less than maxsi.
mjsa 365
mjsa 366 if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 367
mjsa 368 temp = ivalue_ arg1 - ivalue_ arg2;
mjsa 369 if temp >= 0 then
mjsa 370 build_spec(diffli, t_int, temp);
mjsa 371 else
mjsa 372 build_lint1(diffli, iabs(temp), negative);
mjsa 373 end if;
mjsa 374
mjsa 375 elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 376
mjsa 377 p2 = value_ arg2;
mjsa 378 if li_snint(p2) then
mjsa 379 temp = ivalue_ arg1 + li_ddigit(p2, 1);
mjsa 380 if temp <= maxsi then
mjsa 381 build_spec(diffli, t_int, temp);
mjsa 382 else
mjsa 383 build_lint1(diffli, iabs(temp), positive);
mjsa 384 end if;
mjsa 385 elseif li_pos(p2) then
mjsa 386 diffli = intsb1(arg2, arg1, negative);
mjsa 387 else
mjsa 388 diffli = intad1(arg2, arg1, positive);
mjsa 389 end if;
mjsa 390
mjsa 391 elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 392
mjsa 393 if li_pos(value_ arg1) then
mjsa 394 diffli = intsb1(arg1, arg2, positive);
mjsa 395 else
mjsa 396 diffli = intad1(arg1, arg2, negative);
mjsa 397 end if;
mjsa 398
mjsa 399 elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 400
mjsa 401 p1 = value_ arg1;
mjsa 402 p2 = value_ arg2;
mjsa 403
mjsa 404 if li_sign(p1) ^= li_sign(p2) then
mjsa 405
mjsa 406 diffli = intad2(arg1, arg2, li_sign(p1));
mjsa 407
mjsa 408 else $ the signs are the same
mjsa 409
mjsa 410 s1 = li_sign(p1);
mjsa 411 s2 = li_sign(p2);
mjsa 412 li_sign(p1) = positive;
mjsa 413 li_sign(p2) = positive;
mjsa 414
mjsa 415 if ltli(arg1, arg2) then
mjsa 416 diffli = intsb2(arg2, arg1, (s1=no));
mjsa 417 else
mjsa 418 diffli = intsb2(arg1, arg2, s1);
mjsa 419 end if;
mjsa 420
mjsa 421 li_sign(p1) = s1;
mjsa 422 li_sign(p2) = s2;
mjsa 423
mjsa 424 end if;
mjsa 425
mjsa 426 else $ one of the arguments is om
mjsa 427 call err_om(13);
mjsa 428 diffli = err_val(f_int);
mjsa 429 end if;
mjsa 430
mjsa 431
mjsa 432 end fnct diffli;
1 .=member divli
mjsa 433 fnct divli(arg1, arg2);
mjsa 434
mjsa 435$ this function returns the value of the first argument divided by
mjsa 436$ the second argument. it first checks to see if the dividend and
mjsa 437$ the divisor both have absolute values less than maxsi. if so
mjsa 438$ the division is performed in-line, otherwise a call to intdiv
mjsa 439$ is made.
mjsa 440
mjsa 441 size divli(hs); $ integer specifier returned
mjsa 442
mjsa 443 size arg1(hs); $ arguments are integer specifiers
mjsa 444 size arg2(hs);
mjsa 445
mjsa 446 size p1(ps); $ pointers to long int data blocks
mjsa 447 size p2(ps);
mjsa 448 size ptr(ps);
mjsa 449 size temp(ws); $ used for temporary results
mjsa 450
mjsa 451 size trlint(hs); $ transfrom short to long int
mjsa 452 size intdiv(hs); $ long integer division routine
mjsa 453 size equalli(hs); $ equality for long integers
mjsa 454
mjsa 455$ the simple case consists of two short integers. since both arguments
mjsa 456$ must be positive, and since the magnitude of the result must be
mjsa 457$ smaller than maxsi, we can can be sure that the result will be a short
mjsa 458$ integer.
mjsa 459
mjsa 460 if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 461
mjsa 462 if (ivalue_ arg2 = 0) go to error1;
mjsa 463
mjsa 464 build_spec(divli, t_int, ivalue_ arg1 / ivalue_ arg2);
mjsa 465
mjsa 466$ the two mixed cases (t_int and t_lint) are not symetrical since if the
mjsa 467$ first argument is a short integer, we know that the result of the
mjsa 468$ division must be smaller than or equal to that short integer. we take
mjsa 469$ advantage of this knowledge below.
mjsa 470
mjsa 471 elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 472
mjsa 473 p2 = value_ arg2;
mjsa 474 if li_nddig(p2) = 1 then
mjsa 475 temp = ivalue_ arg1 / li_ddigit(p2, 1);
mjsa 476 if temp = 0 then
mjsa 477 divli = zero;
mjsa 478 elseif li_pos(p2) then
mjsa 479 build_spec(divli, t_int, temp);
mjsa 480 else $ temp ^= 0 & li_neg(p2)
mjsa 481 build_lint1(divli, temp, negative);
mjsa 482 end if;
mjsa 483 else
mjsa 484 divli = intdiv(trlint(arg1), arg2, 1);
mjsa 485 end if;
mjsa 486
mjsa 487$ here we have the case of a long and a short integer argument. we
mjsa 488$ must do a bit more checking here to see if the result of the division
mjsa 489$ can fit into a short integer format. we must also check for
mjsa 490$ division by zero since the divisor is a short integer.
mjsa 491
mjsa 492 elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 493
mjsa 494 if (ivalue_ arg2 = 0) go to error1;
mjsa 495
mjsa 496 p1 = value_ arg1;
mjsa 497 if li_nddig(p1) = 1 then
mjsa 498 temp = li_ddigit(p1, 1) / ivalue_ arg2;
suna 57 if temp = 0 then
suna 58 divli = zero;
suna 59 elseif temp <= maxsi & li_pos(p1) then
mjsa 500 build_spec(divli, t_int, temp);
mjsa 501 else
mjsa 502 build_lint1(divli, temp, li_sign(p1));
mjsa 503 end if;
mjsa 504 else
mjsa 505 divli = intdiv(arg1, trlint(arg2), 1);
mjsa 506 end if;
mjsa 507
mjsa 508$ the division can be performed in-line if both of the operands are
mjsa 509$ integers whose magnitude fits into one machine word. if they do not,
mjsa 510$ we call the lower level division routine.
mjsa 511
mjsa 512 elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 513
mjsa 514 p1 = value_ arg1; p2 = value_ arg2;
mjsa 515
mjsa 516 if li_nddig(p1) = 1 & li_nddig(p2) = 1 then
mjsa 517 temp = li_ddigit(p1, 1) / li_ddigit(p2, 1);
mjsa 518 if (li_sign(p1) ^= li_sign(p2)) temp = -temp;
mjsa 519 put_intval(temp, divli);
mjsa 520 else
mjsa 521 divli = intdiv(arg1, arg2, 1);
mjsa 522 end if;
mjsa 523
mjsa 524 else $ one of the arguments is om
mjsa 525 call err_om(13);
mjsa 526 divli = err_val(f_int);
mjsa 527 end if;
mjsa 528
mjsa 529 return;
mjsa 530
mjsa 531
mjsa 532/error1/ $ zero-divide check
mjsa 533
mjsa 534 call err_misc(01);
mjsa 535 divli = err_val(f_int);
mjsa 536 return;
mjsa 537
mjsa 538
mjsa 539 end fnct divli;
1 .=member modli
mjsa 540 fnct modli(arg1, arg2);
mjsa 541
mjsa 542$ this function returns the mod (the remainder) of arg1 divided by arg2.
mjsa 543$ if the dividend and the divisor are are both smaller than maxsi, the
mjsa 544$ calculation is performed in-line, otherwise a call to intdiv is made.
mjsa 545$ n.b. the definition of mod differs in little and setl. as a result,
mjsa 546$ we use the little -mod- function to help us in calculating the setl
mjsa 547$ mod, but must make adjustments to reflect the difference in their
mjsa 548$ definitions.
mjsa 549
mjsa 550 size modli(hs); $ integer specifier returned
mjsa 551
mjsa 552 size arg1(hs); $ arguments are integer specifiers
mjsa 553 size arg2(hs);
mjsa 554
mjsa 555 size intdiv(hs); $ long integer division routine
mjsa 556 size temp(ws); $ temporary results
mjsa 557 size trlint(hs); $ transform short to long int
mjsa 558
mjsa 559$ if both of the integers are short, then we can do the division inline.
mjsa 560$ otherwise, we transform the short integers to a long integer format
mjsa 561$ and then call function intdiv with an -op- parameter of 2.
mjsa 562
mjsa 563 if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 564
mjsa 565 if (ivalue_ arg2 = 0) go to error1;
mjsa 566
mjsa 567 temp = mod(ivalue_ arg1, ivalue_ arg2);
mjsa 568 build_spec(modli, t_int, temp);
mjsa 569
mjsa 570 elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 571
mjsa 572 modli = intdiv(trlint(arg1), arg2, 2);
mjsa 573
mjsa 574 elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 575
mjsa 576 if (ivalue_ arg2 = 0) go to error1;
mjsa 577
mjsa 578 modli = intdiv(arg1, trlint(arg2), 2);
mjsa 579
mjsa 580 elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 581
mjsa 582 modli = intdiv(arg1, arg2, 2);
mjsa 583
mjsa 584 else $ one of the arguments is om
mjsa 585 call err_om(13);
mjsa 586 modli = err_val(f_int);
mjsa 587 end if;
mjsa 588
mjsa 589 return;
mjsa 590
mjsa 591
mjsa 592/error1/ $ zero-divide check
mjsa 593
mjsa 594 call err_misc(01);
mjsa 595 modli = err_val(f_int);
mjsa 596 return;
mjsa 597
mjsa 598
mjsa 599 end fnct modli;
1 .=member multli
mjsa 600 fnct multli(arg1, arg2);
mjsa 601
mjsa 602$ function multiplies two integers, either short or long, and returns
mjsa 603$ the specifier to a long or short integer result.
mjsa 604
mjsa 605 size multli(hs); $ integer specifier returned
mjsa 606
mjsa 607 size arg1(hs); $ arguments are integer specifiers
mjsa 608 size arg2(hs);
mjsa 609
mjsa 610 size p1(ps); $ pointer to data block for arg1
mjsa 611 size p2(ps); $ pointer to data block for arg2
mjsa 612 size ptr(ps); $ pointer to data block of result multli
mjsa 613 size nd1(ws); $ number of digits in arg1
mjsa 614 size nd2(ws); $ number of digits in arg2
mjsa 615 size temp(ws); $ used to store temporary values of mult
mjsa 616 size carry(ws); $ carry
mjsa 617 size i(ps); $ loop index
mjsa 618 size j(ps); $ loop index
mjsa 619
mjsa 620 size trlint(hs); $ functions used
mjsa 621
mjsa 622$ since there is no easy way to check whether the result will be less
mjsa 623$ than maxsi in the case of two short integers, we change any arguments
mjsa 624$ which happen to be short integers into their long integer form,
mjsa 625$ perform the multiplication, and then make sure that the result is
mjsa 626$ represented correctly as a long or short integer.
mjsa 627
mjsa 628 if is_om_ arg1 ! is_om_ arg2 then
mjsa 629 call err_om(13);
mjsa 630 multli = err_val(f_int);
mjsa 631 return;
mjsa 632 end if;
mjsa 633
mjsa 634 if type_ arg1 = t_int then
mjsa 635 if ivalue_ arg1 = 0 then
mjsa 636 multli = zero;
mjsa 637 return;
mjsa 638 else
mjsa 639 p1 = value_ trlint(arg1);
mjsa 640 end if;
mjsa 641 else
mjsa 642 p1 = value_ arg1;
mjsa 643 end if;
mjsa 644
mjsa 645 if type_ arg2 = t_int then
mjsa 646 if ivalue_ arg2 = 0 then
mjsa 647 multli = zero;
mjsa 648 return;
mjsa 649 else
mjsa 650 p2 = value_ trlint(arg2);
mjsa 651 end if;
mjsa 652 else
mjsa 653 p2 = value_ arg2;
mjsa 654 end if;
mjsa 655
mjsa 656 nd1 = li_ndig(p1);
mjsa 657 nd2 = li_ndig(p2);
mjsa 658
mjsa 659 $ allocate a long integer for the result; initialize it to zero.
mjsa 660 get_lint((nd1 + nd2 + 1)/ 2, ptr);
mjsa 661 do j = hl_lint to li_nwords(ptr);
mjsa 662 heap(ptr+j) = 0;
mjsa 663 end do;
mjsa 664 build_spec(multli, t_lint, ptr);
mjsa 665
mjsa 666$ perform the multiplication, adding the partial sums as we go along.
mjsa 667
mjsa 668 do j = 1 to nd2;
mjsa 669 carry = 0;
mjsa 670 do i = 1 to nd1;
mjsa 671 temp = (li_digit(p1, i) * li_digit(p2, j))
mjsa 672 + li_digit(ptr, j+(i-1))
mjsa 673 + carry;
mjsa 674 li_digit(ptr, j+(i-1)) = temp;
mjsa 675 carry = temp / li_bas;
mjsa 676 end do;
mjsa 677 li_digit(ptr, j+nd1) = carry;
mjsa 678 end do;
mjsa 679
mjsa 680$ if the leading digit of the result is zero, then the number of digits
mjsa 681$ in the result is one less than the sum of the number of digits of the
mjsa 682$ operands. we exclusive-or the sign of the operands to get the sign
mjsa 683$ of the result. we do not need to check for an odd number of digits
mjsa 684$ to zero out the extra digit since the algorithm required that we zero
mjsa 685$ the result initially.
mjsa 686
mjsa 687 li_sign(ptr) = (li_sign(p1) ^= li_sign(p2));
mjsa 688 li_ndig(ptr) = nd1 + nd2 - (li_digit(ptr, nd1 + nd2) = 0);
mjsa 689
mjsa 690$ although the case of multiplication by two short integers will be
mjsa 691$ caught by the interpreter, it is still possible that two small
mjsa 692$ integers were multiplied to yield a short integer.
mjsa 693
mjsa 694 if li_spint(ptr) then
mjsa 695 build_spec(multli, t_int, li_ddigit(ptr, 1));
mjsa 696 end if;
mjsa 697
mjsa 698
mjsa 699 end fnct multli;
1 .=member uminli
2 fnct uminli(arg1);
3
4$ this function accepts as its arguments any integer, short or long,
5$ and returns the specifier it unary minus.
6
7 size uminli(hs); $ integer specifier returned
8
9 size arg1(hs); $ argument: integer specifier
10
11 size copy1(hs); $ general copy function
12
13
14$ if the argument is a short integer then we can be sure that the unary
15$ minus will fit into a one word long negative integer. if the argument
16$ is a long integer, we must check to see if it is a negative integer
17$ whose negation may be represented as a short integer.
18
19 if otype_ arg1 = t_int then
20
21 if ivalue_ arg1 = 0 then
22 uminli = zero;
23 else
24 build_lint1(uminli, ivalue_ arg1, negative);
25 end if;
26
27 elseif otype_ arg1 = t_lint then
28
29 if li_snint(value_ arg1) then
30 build_spec(uminli, t_int, li_ddigit(value_ arg1, 1));
31 else
32 uminli = copy1(arg1);
33 li_sign(value_ uminli) = ^ li_sign(value_ uminli);
34 end if;
35
36 else
37 call err_type(13);
38 uminli = err_val(f_int);
39 end if;
40
41
42 end fnct uminli;
1 .=member equalli
2 fnct equalli(arg1, arg2);
3
4$ this function returns a little boolean value of either yes or no
5$ depending upon whether the two integer arguments are equal.
6
7 size equalli(1); $ little boolean returned
8
9 size arg1(hs); $ arguments are integer specifiers
10 size arg2(hs);
11
12 size p1(ps); $ pointers to lint data blocks
13 size p2(ps);
14 size j(ps); $ loop index
15
16
17 if (is_om_ arg1 ^= is_om_ arg2) go to fail;
18 if (is_om_ arg1) go to pass;
19
20 if (eq(arg1, arg2)) go to pass;
21 if (ne(arg1, arg2)) go to fail;
22
23$ if one integer is short and the other is long, then the two must be
24$ distinct, since each integer has a unique representation.
25
26 if (otype_ arg1 ^= otype_ arg2) go to fail;
27
28$ in comparing two long integers for equality we first check the sign of
29$ the two integers, then the number of digits in each, and finally
30$ compare each of the corresponding digits.
31
32 p1 = value_ arg1; p2 = value_ arg2;
33
34 if (li_sign(p1) ^= li_sign(p2)) go to fail;
35 if (li_ndig(p1) ^= li_ndig(p2)) go to fail;
36
37 do j = 1 to li_ndig(p1);
38 if (li_digit(p1, j) ^= li_digit(p2, j)) go to fail;
39 end do;
40
41/pass/
42 equalli = yes;
43 return;
44
45/fail/
46 equalli = no;
47 return;
48
49
50 end fnct equalli;
1 .=member ltli
2 fnct ltli(arg1, arg2);
3
4$ the function ltli returns true or false if the first argument is
5$ less than the second.
6
7 size ltli(1); $ little boolean value returned
8
9 size arg1(hs); $ arguments are specifiers
10 size arg2(hs);
11
12 size p1(hs); $ pointers to argument blocks
13 size p2(hs);
14 size sign(1); $ sign of arg1
15 size i(ps); $ loop index
16
17
18 if otype_ arg1 = t_int & otype_ arg2 = t_int then
19 ltli = (ivalue_ arg1 < ivalue_ arg2);
20
21 elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
22 ltli = (li_sign(value_ arg2) = positive);
23
24 elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
25 ltli = (li_sign(value_ arg1) = negative);
26
27 elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
28
29 p1 = value_ arg1;
30 p2 = value_ arg2;
31
32 if li_neg(p1) & li_pos(p2) then
33 ltli = yes;
34
35 elseif li_pos(p1) & li_neg(p2) then
36 ltli = no;
37
38 else $ both long integers have same sign
39 sign = li_sign(p1);
40 if li_ndig(p1) < li_ndig(p2) then
41 ltli = (sign = positive);
42 elseif li_ndig(p1) > li_ndig(p2) then
43 ltli = (sign = negative);
44 else $ same sign and # digits
45 do i = li_ndig(p1) to 1 by -1;
46 if li_digit(p1, i) ^= li_digit(p2, i) then
47 ltli = ( (li_digit(p1, i) < li_digit(p2, i))
48 = (sign = positive) );
49 return;
50 end if;
51 end do;
52 ltli = no; $ numbers were equal
53 end if;
54 end if;
55
56 else
57 call err_om(19);
58 end if;
59
60
61 end fnct ltli;
1 .=member evenli
2 fnct evenli(arg1);
3
4$ this function returns a little boolean value of true if the integer
5$ argument is even. this is accomplished by checking the last bit
6$ of the integer.
7
8 size evenli(1); $ specifier returned
9
10 size arg1(hs); $ specifier for argument
11
12
13 if otype_ arg1 = t_int then
14 evenli = ((.f. 1, 1, ivalue_ arg1) = 0);
15
16 elseif otype_ arg1 = t_lint then
17 evenli = ((.f. 1, 1, li_digit(value_ arg1, 1)) = 0);
18
19 else
20 call err_type(13);
21 end if;
22
23
24 end fnct evenli;
1 .=member floatli
2 fnct floatli(arg1);
3
4$ this function returns a setl floating point representation for
5$ a long integer argument. since long integers have no limitations
6$ on their size while reals do have some limits, it is possible
7$ for an overflow to occur.
smfc 88$
smfc 89$ assert ws > real_mant_sz;
8
9 size floatli(hs); $ real specifier returned
10
11 size arg1(hs); $ integer specifier
12
smfc 91 size j(ps); $ loop index
smfc 92 size j1(ps); $ index of long integer digit
smfc 93 size k1(ps); $ number of bits in leading digit
smfc 94 size k2(ps); $ index in value being assembled
smfc 95 size n(ps); $ number of bits in long integer
smfc 96 size p1(ps); $ pointer to long integer data block
smfc 97 size ptr(ps); $ pointer to real data block
smfc 98
smfc 99 real r1; $ real temporary
smfc 100
smfc 101 size val(ws); $ signed integer temporary
smfc 102
smfc 103
smfc 104 if otype_ arg1 = t_lint then
smfc 105
smfc 106 p1 = value_ arg1; $ pointer to long integer data block
smfc 107 j1 = li_ndig(p1); $ number of digits in long integer
smfc 108 k1 = .fb. li_digit(p1, j1); $ number of bits in leading digit
smfc 109 n = (j1-1)*ds + k1; $ number of bits in long integer
smfc 110
smfc 111 if n > real_mant_sz then
smfc 112 k2 = real_mant_sz - k1 + 1;
smfc 113 else
smfc 114 k2 = n - k1 + 1;
smfc 115 end if;
smfc 116
smfc 117 val = 0;
smfc 118
smfc 119 $ extract the leading min(real_mant_sz, n) bits from the long
smfc 120 $ integer. this is done in three step, from left (high-order)
smfc 121 $ to right (low-order).
smfc 122
smfc 123 $ first extract all significant bits from the leading digit
smfc 124 .f. k2, k1, val = li_digit(p1, j1);
smfc 125
smfc 126 $ extract as many whole digits as required to fill the value
smfc 127 while k2 > ds;
smfc 128 k2 = k2 - ds; j1 = j1 - 1;
smfc 129 .f. k2, ds, val = li_digit(p1, j1);
smfc 130 end while;
smfc 131
smfc 132 $ extract the high-order bits of the next digit to fill the
smfc 133 $ remaining low-order bits of the value
smfc 134 if k2 > 1 then
smfc 135 .f. 1, k2-1, val =
smfc 136 .f. (ds+1)-(k2-1), k2-1, li_digit(p1, j1-1);
smfc 137 end if;
smfc 138
smfc 139 if (li_neg(p1)) val = -val;
smfc 140
smfc 141 r1 = float(val);
smfc 142
smfc 143 $ do any required scaling
smfc 144 do j = real_mant_sz+1 to n by real_exp_base_sz;
smfc 145 r1 = r1 * real_exp_base;
smfc 146 end do;
smfc 147
smfc 148 elseif otype_ arg1 = t_int then
smfc 149 r1 = float(ivalue_ arg1);
smfc 150
smfc 151 else
smfc 152 if is_om_ arg1 then
smfc 153 call err_om(27);
smfc 154 else
smfc 155 call err_type(61);
smfc 156 end if;
smfc 157 floatli = err_val(f_real);
smfc 158 return;
smfd 49 end if;
smfc 160
smfd 50 get_real(ptr); rval(ptr) = r1;
smfd 51 build_spec(floatli, t_real, ptr);
smfc 163
74
75 end fnct floatli;
1 .=member fixli
2 fnct fixli(arg1);
3
4$ functon fixli accepts as its argument the specifier for a setl real
5$ number, and returns the long integer representation for that real
6$ value, truncating any digits which are to the right of the decimal
7$ point.
smfc 164$
smfc 165$ assert otype_ arg1 = t_real;
smfc 166$ assert ws > real_mant_sz & real_mant_sz > .fb. maxsi;
smfc 167
8
9 size fixli(hs); $ integer specifier returned
10
11 size arg1(hs); $ real specifier
12
smfc 169 size j(ps); $ loop index
smfc 170 size j1(ps); $ index of long integer digit
smfc 171 size k1(ps); $ number of bits in leading digit
smfc 172 size k2(ps); $ index in value being assembled
smfc 173 size n(ps); $ number of bits in long integer
smfc 174 size ptr(ps); $ pointer to result long integer
smfc 175
smfc 176 real r1, r2; $ real temporaries
smfc 177
smfc 178 size temp(ws); $ field extract temporary
smfc 179 size val(ws); $ signed integer temporary
smfc 180
smfc 181
smfc 182 r1 = rval(value_ arg1);
smfc 183 r2 = float(.f. 1, real_mant_sz, all_ones);
smfc 184
smfc 185 n = 0;
smfc 186
smfc 187 while abs(r1) > r2;
smfc 188 r1 = r1 / real_exp_base; n = n + real_exp_base_sz;
smfc 189 end while;
smfc 190
smfc 191 val = ifix(r1);
smfc 192
smfc 193 if 0 <= val & val <= maxsi & n = 0 then
smfc 194 build_spec(fixli, t_int, val);
smfc 195
smfc 196 else
smfc 197
smfc 198 n = n + .fb. iabs(val); $ total size of result
smfc 199 j1 = (n+ds)/ds; $ number of digits in result
smfc 200
smfc 201 $ allocate a j1-digit long integer and initialise it to zero
smfc 202 get_lint((j1+1)/2, ptr);
smfc 203 do j = hl_lint to li_nwords(ptr)-1; heap(ptr+j) = 0; end do;
smfc 204 li_sign(ptr) = (val < 0); li_ndig(ptr) = j1;
smfc 205 build_spec(fixli, t_lint, ptr);
smfc 206
smfc 207 val = iabs(val);
smfc 208
smfc 209 k1 = mod(n, ds); $ number of bits in leading digit
smfc 210 k2 = (.fb. val) - k1 + 1; $ starting bit position in val
smfc 211
smfc 212 li_digit(ptr, j1) = .f. k2, k1, val;
smfc 213
smfc 214 while k2 > ds;
smfc 215 k2 = k2 - ds; j1 = j1 - 1;
smfc 216 li_digit(ptr, j1) = .f. k2, ds, val;
smfc 217 end while;
smfc 218
smfc 219 if k2 > 1 then
smfc 220 temp = 0;
smfc 221 .f. (ds+1)-(k2-1), k2-1, temp = .f. 1, k2-1, val;
smfc 222 li_digit(ptr, j1-1) = temp;
smfc 223 end if;
smfd 52 end if;
113
114
115 end fnct fixli;
1 .=member hashli
2 fnct hashli(arg1);
3
4$ this function returns the hash code for a long integer. to calculate
5$ the hash code we simply exclusive-oring each of the double digits of
6$ the long integer and then fold the resulting word in two. note: this
7$ function may only be called with a long integer argument.
8
9 size hashli(hcsz); $ hash code returned
10
11 size arg1(hs); $ integer specifier
12
13 size temp(dds); $ used in calc of hash code
14 size p1(ps); $ pointer to data block of arg1
15 size i(ps); $ loop index
16
17$ the hash code of a long integer is calculated by exclusive-oring each
18$ of the double digits of the long integer, folding the result in two,
19$ and then multiplying by the hash code seed.
20
21 p1 = value_ arg1;
22 temp = 0;
23
24 do i = 1 to li_nddig(p1);
25 temp = temp .ex. li_ddigit(p1, i);
26 end do;
27
28 temp = (.f. 1, ds, temp) .ex. (.f. ds+1, ds, temp);
29 hashli = hcsd * (.f. 1, hcsz, temp);
30
31
32 end fnct hashli;
1 .=member valli
2 fnct valli(arg1);
3
4$ the function valli takes as its argument a specifier for a string
5$ which contains a sequence of numeric characters, and returns a
6$ specifier to its integer representation.
7
8 size valli(hs); $ integer specifier returned
9
10 size arg1(hs); $ argument is string specifier
11
12 size ss(ssz); $ string specifier to number string
13 size ptr(hs); $ pointer to data block of result
14 size ndigs(ws); $ number of li_dbas digits in value
15 size sign(1); $ sign of number
16 size carry(ws); $ carry for addition and multiplication
17 size first_char(ws); $ pointer to first digit in num string
18 size last_char(ws); $ pointer to last digit in num string
19 size next_char(ws); $ pointer to char being added to result
20 size temp(ws); $ temporary variable
21 size i(ps); $ loop index
22 size j(ps); $ loop index
asca 49 size c(cs); $ current character
23
24 size trlint(hs); $ function to transform short to long int
asca 50 .+ascebc size ebchar(cs); $ ascii-to-ebcdic conversion function
26
27$ first we look at the number of characters in the string, then check to
28$ see if the leading character is a "+" or a "-", and then reset the
29$ number of characters and finally set the sign.
30
31 if is_om_ arg1 then
32 call err_om(13);
33 valli = err_val(f_int);
34 return;
35 end if;
stra 550
stra 551 if otype_ arg1 = t_string then $ short character string
stra 552 if sc_nchars_ arg1 = 0 then $ null string - this is an error
stra 553 valli = zero; $ not diagnosed
stra 554 else
stra 555 c = scchar(arg1, 1);
stra 556 .+ascebc if (ascebc_flag) c = ebchar(c); $ convert to ebcdic
stra 557 c = c - 1r0;
stra 558 build_spec(valli, t_int, c);
stra 559 end if;
stra 560 return;
stra 561 end if;
36
37 ss = value_ arg1;
38 sign = (icchar(ss, 1) = 1r-);
39 first_char = 1 + sign;
40 last_char = ss_len(ss);
41 ndigs = li_dbas_digits(last_char) + 1;
42
43 $ initialise the result to zero
44 get_lint(ndigs, ptr);
45 do j = hl_lint to li_nwords(ptr);
46 heap(ptr+j) = 0;
47 end do;
48 li_sign(ptr) = sign;
49 li_ndig(ptr) = 1;
50 build_spec(valli, t_lint, ptr);
51
52$ the strategy used to create an integer from a string is to use
53$ horner's rule. multiply the number by ten and then add the next digit
54$ in line by the base of the number you are working in. the first loop
55$ performs the multiplication, while the second loop adds the next
56$ digit. in the second loop we only loop as long as there is a carry.
57
58 do i = first_char to last_char;
59
60 carry = 0;
61 do j = 1 to li_ndig(ptr);
62 temp = li_digit(ptr, j) * 10 + carry;
63 carry = temp / li_bas;
64 li_digit(ptr, j) = temp;
65 end do;
66
67 if (carry) then
68 li_ndig(ptr) = li_ndig(ptr) + 1;
69 li_digit(ptr, li_ndig(ptr)) = carry;
70 end if;
71
asca 51 c = icchar(ss, i);
asca 52 .+ascebc if (ascebc_flag) c = ebchar(c); $ convert to ebcdic
asca 53 carry = c - 1r0;
smff 10 do j = 1 to li_ndig(ptr);
smff 11 if (carry = 0) quit do j;
75 temp = li_digit(ptr, j) + carry;
76 carry = (temp >= li_bas);
77 li_digit(ptr, j) = temp;
smff 12 end do j;
80
81 if (carry) then
82 li_ndig(ptr) = li_ndig(ptr) + 1;
83 li_digit(ptr, li_ndig(ptr)) = carry;
84 end if;
85
86 end do;
87
88$ it is possible that the value of the string is a short integer,
89$ so we must check for this case.
90
91 if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
92 build_spec(valli, t_int, li_ddigit(ptr, 1));
93 end if;
94
95 end fnct valli;
1 .=member strli
2 fnct strli(arg1);
3
4$ the function strli accepts as its argument a specifier for an
5$ integer and returns the specifier to the string version of
6$ that integer.
7
8 size strli(hs); $ string specifier returned
9
10 size arg1(hs); $ long integer specifier
11
12 size ss(ssz); $ pointer to string descriptor
13 size a1(hs); $ local copy of long int argument
14 size p1(ps); $ pointer to a1 data block
15 size max_nchar(ps); $ max no. of char in resulting str
16 size sign_arg1(1); $ need to save the sign of arg1
17 size rem(ws); $ remainder from divisions
18 size temp(ws); $ temporary result
19 size next_char_pos(ps); $ counter into setl string
20 size i(ps); $ loop index
21
22 size nulllc(ssz); $ returns null string specifier
23 size trlint(hs); $ converts short to long integer
24 size copy1(hs); $ copy utility
25
26$ setup a positive long integer value: if the number we are transforming
27$ is a regular integer, we make a copy of it in long integer format. if
28$ it is a long integer, we make a copy. in both cases we check and save
29$ the sign of the number, and then change this copy to its absolute
30$ value.
31
32 if type_ arg1 = t_int then
33 a1 = trlint(arg1);
34 else
35 a1 = copy1(arg1);
36 end if;
37
38 p1 = value_ a1;
39
40 sign_arg1 = li_sign(p1);
41 li_sign(p1) = positive;
42
43$ we use the macro -li_decbas_digits- to estimate the number of
44$ characters which will appear in the base ten representation of the
45$ integer, and then call -nulllc- to allocate space for the string.
46$ we set the -len- field to this number of characters so that we can
47$ build the string from the back (least significant digits).
48
49 max_nchar = li_decbas_digits(li_ndig(p1)) + sign_arg1;
50 ss = nulllc(max_nchar);
51 ss_len(ss) = max_nchar;
52 next_char_pos = max_nchar;
53
54$ since we do not know exactly how many digits will be present in the
55$ decimal representation of the li_bas number, we enter a while loop
56$ which keeps the division going until a1 goes to zero. instead of
57$ keeping the result of each successive division in a seperate long
58$ integer variable, we simply replace a1 during the division. it should
59$ also be noted that since we are not calling the regular division
60$ routine in this situation, the value of a1 will reach a point in the
61$ course of its successive divisions at which it could be represented as
62$ a short integer. we will not do this however, and instead make a
63$ special check for zero.
64
65 until li_ndig(p1) = 1 & li_digit(p1, 1) = 0;
66
67 rem = 0;
68 do i = li_ndig(p1) to 1 by -1;
69 temp = rem * li_bas + li_digit(p1, i);
70 li_digit(p1, i) = temp / 10;
71 rem = mod(temp, 10);
72 end do;
73
74 $ normalize a1
75 while li_ndig(p1) > 1;
76 if (li_digit(p1, li_ndig(p1)) ^= 0) quit while;
77 li_ndig(p1) = li_ndig(p1) - 1;
78 end while;
79
80 $ place the character in the string
81 icchar(ss, next_char_pos) = 1r0 + rem;
82 next_char_pos = next_char_pos - 1;
83
84 end until;
85
86$ we now must add the character "-" to the string if the number was
87$ negative, and set the both the offset and length fields so that
88$ so that they correctly reflect the position of the string within
89$ the long string data block.
90
91 if sign_arg1 = negative then
92 icchar(ss, next_char_pos) = 1r-;
93 next_char_pos = next_char_pos - 1;
94 end if;
95
96 ss_len(ss) = max_nchar - next_char_pos;
97 ss_ofs(ss) = next_char_pos;
asca 54 .+ascebc if (ascebc_flag) call ascstr(ss); $ convert to ascii
99 build_spec(strli, t_istring, ss);
100
101
102 end fnct strli;
1 .=member putbli
2 fnct putbli(id, arg1);
3
4$ this function performs the setl input/output operation -putb-
5$ for long integers.
6
7 size putbli(hs); $ om is returned
8
9 size id(ps); $ little file id
10 size arg1(hs); $ long integer specifier to be written
11
12 size p1(ps); $ pointer to data block for arg1
13 size putbhdrblk(hs); $ header block for binary output
14 size len(ws);
15
16$ define these local macros so that they are precisely the same
17$ as those defined in the binary input/output package.
18
19 +* putbhdr(t, v) =
20 putbhdrblk = 0;
21 bh_typ_ putbhdrblk = t;
22 bh_val_ putbhdrblk = v;
23 write id, putbhdrblk;
24 **
25
26 +* putbdatn(p, n) =
27 write id, heap(p) to heap(p+(n)-1);
28 **
29
30
31$ we first calculate the number of words which need to be writen to the
32$ file, and then create the header and data blocks using the above
33$ macros. notice that we do not copy all of the words which compose
34$ this particular form of the integer, since it is possible that more
35$ blocks were allocated for the integer than were necessary. we instead
36$ look at the number of double digits (li_dbas digits) in the number,
37$ an only write this necessary number to file -id-. this is important
38$ since the li_ndig field is not stored in the binary representation, so
39$ we must be sure that all of the stored words represent valid data.
40
41 p1 = value_ arg1;
42 len = li_nddig(p1);
43
44 putbhdr(bt_int, len);
45 putbdatn(p1 + hl_lint, len);
46
47 putbli = spec_om;
48
49$ drop the local macros.
50
51 macdrop2(putbhdr, putbdatn);
52
53 end fnct putbli;
1 .=member getbli
2 fnct getbli(id, val);
3
4$ this function performs the setl input/output operation -getb-
5$ for long integers. it returns the specifier to the integer
6$ which it has just read in.
7
8 size getbli(hs); $ specifier returned
9
10 size id(ps); $ little file id
11 size val(hs); $ number words read in
12
13 size ptr(ps); $ pointer to resulting data block
14 size getbword(hs); $ most recently read data word from id
15
16$ by looking at the val field we can tell if there is a possibility that
17$ the integer which we are reading is actually a short integer value.
18$ it may however be a long integer value (a positive number which fits
19$ into a setl word)
20
21 if val = 1 then
22
23 read id ,getbword;
24
smfc 225 if 0 <= getbword & getbword <= maxsi then
26 build_spec(getbli, t_int, getbword);
27 else
28 get_lint1(ptr); build_spec(getbli, t_lint, ptr);
29 heap(ptr + hl_lint) = getbword;
30 li_ndig(ptr) = 1 + (li_ddigit(ptr, 1) >= li_bas);
31 end if;
32
33$ if the value of val is greater than one, then we can be sure that we
34$ have a long integer.
35
36 else
37 get_lint(val, ptr); build_spec(getbli, t_lint, ptr);
38
39 read id ,heap(ptr+hl_lint) to heap(ptr+hl_lint+val-1);
40
41 li_ndig(ptr) =
42 (2 * (val-1)) + 1 + (li_ddigit(ptr, val) >= li_bas);
43 end if;
44
45
46 end fnct getbli;
1 .=member putintli
2 fnct putintli(val);
3
4$ this function receives as an argument a little signed integer and
5$ returns a specifier to the setl representation of that integer.
6
7 size putintli(hs); $ integer specifier returned
8
9 size val(ws); $ little signed integer
10
11 size ptr(hs);
12
13
14$ in order to represent the argument as a setl integer, we must be able
15$ to take its absolute value. in the case of a one's complement machine
16$ this never presents a problem since each negative number may be
17$ represented as positive number (the largest negative number requires
18$ the same number of bits as the largest positive number). in the case
19$ of a two's complement machine, however, the absolute value of the
20$ largest negative number will not fit into a machine word. since the
21$ largest negative number is used for the special value -om_int- on
22$ two's complement machines, this does not cause a problem. normally,
23$ this routine is called from within the -put_intval- macro, and hence
24$ -val- will never be -om_int- or in the range [ 0..maxsi ]. there is
25$ one exception: when we initialise the sample values, we call this
26$ routine directly with val = om_int. all that matters in that context
27$ is that we return an omega-long-integer specifier.
28
29 if val = om_int then
30 get_lint1(ptr); build_spec(putintli, t_olint, ptr);
31 li_ddigit(ptr, 1) = 0;
32 li_sign(ptr) = positive;
33 li_ndig(ptr) = 0;
34
35 elseif 0 <= val & val <= maxsi then
36 call err_misc(47);
37
38 elseif iabs(val) < li_dbas then
39 build_lint1(putintli, iabs(val), (val < 0));
40
41 else
42 get_lint(2, ptr); build_spec(putintli, t_lint, ptr);
43
44 li_ddigit(ptr, 1) = .f. 1, dds, iabs(val);
45 li_ddigit(ptr, 2) = .f. dds+1, ws-dds-1, iabs(val);
46 li_sign(ptr) = (val < 0);
47 li_ndig(ptr) = 3;
48 end if;
49
50
51 end fnct putintli;
1 .=member getintli
2 fnct getintli(spec);
3
4$ this function gets as an argument a setl integer and returns
5$ a little signed integer when possible.
6
7 size getintli(ws); $ little signed integer returned
8
9 size spec(hs); $ setl integer specifier
10
11 size p1(ps);
12
13
14$ if we have a short integer argument then the value resides in the
15$ value field of the specifier. if we have a long integer, then we
16$ must check that we are able to put the value into a machine word.
17
18 if otype_ spec = t_int then
19 getintli = ivalue_ spec;
20
21$ long integers can be divided into three categories: 1) those with
22$ less than two li_bas digits may always be transformed, 2) those
23$ with three digits may sometimes be transformed and the tranformation
24$ will depend upon whether the machine is two's or one's complement
25$ if the number is negative, 3) those with greater than three digits may
26$ never be transformed since their magnitude is too great to fit into
27$ a machine word.
28
29 elseif otype_ spec = t_lint then
30
31 p1 = value_ spec;
32
33 if li_ndig(p1) <= 2 then $ must be in range
34
35 getintli = li_ddigit(p1, 1);
36 if (li_neg(p1)) getintli = -getintli;
37
38$ because li_dbas has only one less bit than the number of bits used to
39$ represent the magnitude of a machine integer, the only possible value
40$ for the third digit is one. otherwise the number will be out of
41$ range.
42
43 elseif li_nddig(p1) = 2 then
44
45 if .fb. li_ddigit(p1, 2) < ws-dds then
46 getintli = li_ddigit(p1, 1);
47 .f. dds+1, ws-dds-1, getintli = li_ddigit(p1, 2);
48 if (li_neg(p1)) getintli = -getintli;
49 else
50 call err_misc(21); $ number out of range
51 end if;
52 else
53 call err_misc(21);
54 end if;
55 else
56 call err_om(13); $ omega value
57 end if;
58
59 end fnct getintli;
1 .=member intad1
2$ internal arithmetic routines used by lint interface routines.
3$ -------- ---------- -------- ---- -- ---- --------- ---------
4
5
6 fnct intad1(arg1, arg2, sign);
7
8$ this function adds the absolute values of two integers, the first
9$ of which is a long integer, and the second of which is a short
10$ integer. although -arg1- may actually be negative, we take look
11$ only at the magnitude of the number and add this to -arg2-.
12
13 size intad1(hs); $ result is a specifier
14
15 size arg1(hs); $ long integer specifier
16 size arg2(hs); $ short integer specifier
17 size sign(1); $ result should have this sign
18
19 size ptr(hs); $ pointer to long int data block
20 size p1(ps); $ pointer to long int data block
21 size temp(ws); $ used to store partial sums
22 size carry(1); $ carry
23 size j(ps); $ loop index
24
25$ allocate space for result: the result can have at most 1 more digit
26$ than the long integer argument. we know that the result must be a
27$ long integer value, so we build the specifier now.
28
29 p1 = value_ arg1;
30
31 get_lint(li_nddig(p1) + 1, ptr);
32 build_spec(intad1, t_lint, ptr);
33
34$ set the pointer to the data block of the long integer argument, and
35$ then begin the addition, adding the first digit, and then adding the
36$ carry as long as necessary.
37
38 temp = li_ddigit(p1, 1) + ivalue_ arg2;
39 carry = (temp >= li_dbas);
40 li_ddigit(ptr, 1) = temp;
41
42 do j = 2 to li_nddig(p1);
43 temp = li_ddigit(p1, j) + carry;
44 carry = (temp >= li_dbas);
45 li_ddigit(ptr, j) = temp;
46 end do;
47
48$ set number of digits, the sign, and zero an odd leading integer:
49
50 if li_oddndig(p1) then
51 $ assert carry = 0;
52 li_ndig(ptr) = li_ndig(p1) + (temp >= li_bas);
53 elseif (carry) then
54 li_digit(ptr, li_ndig(p1) + 1) = 1;
55 li_ndig(ptr) = li_ndig(p1) + 1;
56 else
57 li_ndig(ptr) = li_ndig(p1);
58 end if;
59 li_sign(ptr) = sign;
60 if (li_oddndig(ptr)) li_digit(ptr, li_ndig(ptr)+1) = 0;
61
62$ in the course of the addition it is possible that value became small
63$ enough to be represented as a short integer. check for this case.
64
65 if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
66 build_spec(intad1, t_int, li_ddigit(ptr, 1));
67 end if;
68
69 end fnct intad1;
1 .=member intad2
2 fnct intad2(arg1, arg2, sign);
3
4$ this function adds two long integers and returns a specifer to the
5$ result with a sign equal to that of the parameter -sign-.
6
7 size intad2(hs); $ integer specifier returned
8
9 size arg1(hs); $ input specifiers
10 size arg2(hs);
11 size sign(1); $ returned integer must have this sign
12
13 size p1(ps); $ pointers to long integer data blocks
14 size p2(ps);
15 size ptr(ps);
16 size temp(ws); $ holds the temporary result of additions
17 size g(ps); $ pointer to lint with greater # of digits
18 size l(ps); $ pointer to lint with lesser # of digits
19 size gdigs(ws); $ greater number of digits
20 size ldigs(ws); $ lesser number of digits
21 size i(ps); $ loop index
22 size carry(1); $ carry
23
24$ after setting pointers to the data blocks of the two long
25$ integers, we check to see which has the greater number of
26$ double digits, and then set the values of g, l, gdigs, ldigs
27$ accordingly. we also allocate heap space for the result.
28
29 p1 = value_ arg1;
30 p2 = value_ arg2;
31
32 if li_ndig(p1) >= li_ndig(p2) then
33 g = p1;
34 l = p2;
35 else
36 g = p2;
37 l = p1;
38 end if;
39
40 gdigs = li_nddig(g);
41 ldigs = li_nddig(l);
42
43 get_lint(gdigs + 1, ptr);
44 build_spec(intad2, t_lint, ptr)
45
46$ first part of the addition: we add the digits of the two long
47$ integers up to the most significant digit of the smaller
48$ of the two integers.
49
50 carry = 0;
51 do i = 1 to ldigs;
52 temp = li_ddigit(g, i) + li_ddigit(l, i) + carry;
53 carry = (temp >= li_dbas);
54 li_ddigit(ptr, i) = temp;
55 end do;
56
57 do i = ldigs + 1 to gdigs;
58 temp = li_ddigit(g, i) + carry;
59 carry = (temp >= li_dbas);
60 li_ddigit(ptr, i) = temp;
61 end do;
62
63$ set the number of digits, the sign, and zero any odd leading digits:
64$ if the carry is now 1, we must add one more digit.
65$ also, set the sign of the answer to the sign of p1, since
66$ both long integers were assumed to have the same sign.
67
68 if (carry) then
69 li_ddigit(ptr, gdigs + 1) = carry;
70 li_ndig(ptr) = 2 * gdigs + 1;
71 else
72 li_ndig(ptr) = 2 * (gdigs - 1) + 1 + (temp >= li_bas);
73 end if;
74
75 li_sign(ptr) = sign;
77
78$ if we were adding two short negative integers, it is possible that the
79$ result is a short integer.
80
81 if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
82 build_spec(intad2, t_int, li_ddigit(ptr, 1));
83 end if;
84
85
86 end fnct intad2;
1 .=member intsb1
2 fnct intsb1(arg1, arg2, sign);
3
4$ this function subtracts the short integer arg2 from the absolute value
5$ of a long integer. we do not actually compute the absolute value of
6$ the long integer but instead take advantage of the signed-magnitude
7$ representation of long integers. the parameter -sign- gives the sign
8$ of the result.
9
10 size intsb1(hs); $ result is a specifier
11
12 size arg1(hs); $ long integer specifier
13 size arg2(hs); $ short integer specifier
14 size sign(1); $ sign of the result
15
16 size ptr(ps); $ pointer to data block of result
17 size p1(ps); $ pointer to long int data block
18 size temp(ws); $ temporary result for difference
19 size borrow(1); $ borrow
20 size j(ps); $ loop index
21
22$ allocate space for the result: the largest possible number of digits
23$ in the result could be the same as the number of digits in -arg1-.
24
25 p1 = value_ arg1;
26
27 get_lint(li_nddig(p1), ptr);
28 build_spec(intsb1, t_lint, ptr);
29
30$ subtract the short integer from the least significant digit of the
31$ long integer. then complete the subtraction taking into account that
32$ the carry may affect even the most significant digit.
33
smfc 226 do j = hl_lint to li_nwords(ptr)-1;
35 heap(ptr+j) = 0;
36 end do;
37
38 temp = li_ddigit(p1, 1) - ivalue_ arg2;
39 borrow = (temp < 0);
40 if (borrow) temp = temp + li_dbas;
41 li_ddigit(ptr, 1) = temp;
42
43 do j = 2 to li_nddig(p1);
44 temp = li_ddigit(p1, j) - borrow;
45 borrow = (temp < 0);
46 if (borrow) temp = temp + li_dbas;
47 li_ddigit(ptr, j) = temp;
48 end do;
49
50 li_ndig(ptr) = li_ndig(p1);
51 while li_ndig(ptr) > 1;
52 if (li_digit(ptr, li_ndig(ptr)) > 0) quit while;
53 li_ndig(ptr) = li_ndig(ptr) - 1;
54 end while;
55
56 li_sign(ptr) = sign;
57
58$ note that if there is an odd, leading digit, it must be zero. next
59$ check whether the result can be represented as a short integer.
60
61 if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
62 build_spec(intsb1, t_int, li_ddigit(ptr, 1));
63 end if;
64
65 end fnct intsb1;
1 .=member intsb2
2 fnct intsb2(arg1, arg2, sign);
3
4$ this function subtracts one long integer from another and returns the
5$ specifier for the result, which can be either a short or a long
6$ integer.
7
8 size intsb2(hs); $ integer specifier returned
9
10 size arg1(hs); $ arguments are specifiers
11 size arg2(hs);
12 size sign(1); $ returned value must have this sign
13
14 size p1(ps); $ pointers to data blocks
15 size p2(ps);
16 size ptr(ps);
17 size gdigs(ws); $ number of li_dbas digits in larger int
18 size ldigs(ws); $ number of li_dbas digits in smaller int
19 size borrow(ws); $ borrow from partial subtractions
20 size temp(ws); $ temporary values
21 size i(ps); $ loop index
22 size j(ps); $ loop index
23
24$ set the pointers to the data block of the long integers, and then
25$ allocate space in the heap for the result.
26
27 p1 = value_ arg1;
28 p2 = value_ arg2;
29
30 gdigs = li_nddig(p1);
31 ldigs = li_nddig(p2);
32
33 get_lint(gdigs, ptr);
34 build_spec(intsb2, t_lint, ptr);
35
36$ start by subtracting the as many digits as are present in the smaller
37$ number. then finish the subtraction by carrying along the borrow.
38
smfc 227 do j = hl_lint to li_nwords(ptr)-1;
40 heap(ptr+j) = 0;
41 end do;
42
43 borrow = 0;
44 do i = 1 to ldigs;
45 temp = li_ddigit(p1, i) - li_ddigit(p2, i) - borrow;
46 borrow = (temp < 0);
47 if (borrow) temp = temp + li_dbas;
48 li_ddigit(ptr, i) = temp;
49 end do;
50
51 do i = ldigs + 1 to gdigs;
52 temp = li_ddigit(p1, i) - borrow;
53 borrow = (temp < 0);
54 if (borrow) temp = temp + li_dbas;
55 li_ddigit(ptr, i) = temp;
56 end do;
57
58$ if a final carry took place then it is possible that the leading
59$ digit became a zero. in this case we must normalize the long integer.
60
61 li_ndig(ptr) = li_ndig(p1);
62 while li_ndig(ptr) > 1;
63 if (li_digit(ptr, li_ndig(ptr)) > 0) quit while;
64 li_ndig(ptr) = li_ndig(ptr) - 1;
65 end while;
66
67 li_sign(ptr) = sign;
69
70$ check to see that the value generated by the subtraction can be
71$ represented as a short integer.
72
73 if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
74 build_spec(intsb2, t_int, li_ddigit(ptr, 1));
75 end if;
76
77 end fnct intsb2;
1 .=member intdiv
2 fnct intdiv(arg1, arg2, op);
3
4$ this function divides two integers in long integer format. if one of
5$ the two arguments can be represented as a short integer, it must be
6$ transformed into a long integer format in order to use this routine.
7$ the parameter op determines whether the value returned by this
8$ function is the quotient (op=1) or the mod (op=2).
9
10 size intdiv(hs); $ integer specifier returned
11
12 size arg1(hs); $ long integer specifiers
13 size arg2(hs);
14 size op(ws);
15
16 size a1(hs); $ local copy of arg1
17 size a2(hs); $ local copy of arg2
18 size p1(ps); $ pointer to data block of arg1
19 size p2(ps); $ pointer to data block of arg2
20 size ptr(ps); $ pointer to data block of intdiv
21 size sign(1); $ sign of the result
22 size scale(ws); $ scaling factor for case 4
23 size temp(ws); $ temporary result
24 size rr(ws); $ remainder of division steps
25 size divisor(ws); $ divisor in case three
26 size c(ws); $ carry
27 size qe(ws); $ quotient estimate
28 size du(ws); $ temporary variable
29 size temp2(ws); $ temporary variable
30 size m(ps); $ number of digits in dividend minus n
31 size n(ps); $ number of digits in divisor
32 size i(ps); $ loop index
33 size j(ps); $ loop index
34 size k(ps); $ loop index
35
36 size copy1(hs); $ copy function
37 size addli(hs); $ arithmetic functions used
38 size diffli(hs);
39 size equalli(hs);
40
41$ on entering this function we assume only that both the divisor and the
42$ dividend are in long integer format. we divide the function into four
43$ cases: 1) division by zero; 2) fewer digits in the dividend than the
44$ divisor; 3) a divisor with only one digit; 4) a divison with a
45$ multi-digit divisor.
46
47$ case one: division by zero. if the divisor is equal to zero then we
48$ must call an error.
49
50 if eq(arg2, zero) then
51
52 call err_type(0);
53 return;
54
55$ case two: fewer digits in dividend than divisor. in the case where
56$ there are fewer digits in the divisor than the dividend we can be
57$ certain that the result is zero. if the dividend is negative we must
58$ add the divisor to it to get the mod
59
60 elseif li_ndig(value_ arg1) < li_ndig(value_ arg2) then
61
62 if op = 1 then
63 intdiv = zero;
64 else
65 if li_pos(value_ arg1) then
66 intdiv = copy1(arg1);
67 elseif li_pos(value_ arg2) then
68 intdiv = addli(arg1, arg2);
69 else $ arg2 is negative: subtract instead
70 intdiv = diffli(arg1, arg2);
71 end if;
72 end if;
73
74 return;
75
76$ case three: one digit divisor. we now further subdivide the case of a
77$ division into the cases of a one digit divisor, and a multi digit
78$ divisor. we do this not only because it is more efficient, but also
79$ because the quotient estimation algorithm used in the latter case
80$ assumes at least two digits in the divisor. it is also worth noting
81$ that -p1- begins by pointing to a copy of the dividend but after the
82$ division points to the quotient. it is possible that in the course of
83$ doing the division we will reduce the magnitude of the first argument
84$ to the extent that the result can be represented as a short integer.
85
86 elseif li_ndig(value_ arg2) = 1 then
87
88 a1 = copy1(arg1);
89 ptr = value_ a1;
90
91 rr = 0;
92 divisor = li_digit(value_ arg2, 1);
93 do j = li_ndig(ptr) to 1 by -1;
94 temp = rr * li_bas + li_digit(ptr, j);
95 li_digit(ptr, j) = temp / divisor;
96 rr = mod(temp, divisor);
97 end do;
98
99 if op = 1 then
100
101 if li_digit(ptr, li_ndig(ptr)) = 0 then
102 li_ndig(ptr) = li_ndig(ptr) - 1;
103 end if;
104 build_spec(intdiv, t_lint, ptr);
105 li_sign(ptr) = (li_sign(ptr) ^= li_sign(value_ arg2));
108
109 if li_ndig(ptr) <= 1 & li_digit(ptr, 1) = 0 then
110 intdiv = zero;
111 elseif li_spint(ptr) then
112 build_spec(intdiv, t_int, li_ddigit(ptr, 1));
113 end if;
114
115 else $ op = 2: compute remainder
117 if (li_neg(value_ arg1) & rr ^= 0) rr = divisor - rr;
118
119 if rr <= maxsi then
120 build_spec(intdiv, t_int, rr);
121 else
122 build_lint1(intdiv, rr, positive);
123 end if;
124 end if;
125
126 return;
127
128$ case four: divisor has at least two digits. we have the case of a
129$ long integer with several digits being divided by a long integer with
130$ at least two digits. we begin by making copys of the two integers
131$ being divided. the dividend must be padded with one extra zero, so we
132$ must copy it without the help of the function -copy1-. we then set the
133$ pointers p1 and p2 to point to the copies of the two arguments. we
134$ must also create a special long integer block for the result, whose
135$ value has been initialized to zero and whose number of digits field
136$ states that it contains m + 1 digits.
137
138 elseif li_ndig(value_ arg2) > 1 then
139
140 $ make copies of both arguments:
141 m = li_ndig(value_ arg1) - li_ndig(value_ arg2);
142 n = li_ndig(value_ arg2);
143 sign = (li_sign(value_ arg1) ^= li_sign(value_ arg2));
144
145 $ copy arg1 padding it with an extra zero at the left
146 get_lint(li_nddig(value_ arg1) + 1, p1);
147 do i = 1 to li_ndig(value_ arg1);
148 li_digit(p1, i) = li_digit(value_ arg1, i);
149 end do;
150 li_digit(p1, li_ndig(value_ arg1) + 1) = 0;
151 li_sign(p1) = li_sign(value_ arg1);
152 li_ndig(p1) = li_ndig(value_ arg1) + 1;
153
154 $ copy arg2
155 a2 = copy1(arg2);
156 p2 = value_ a2;
157
158 $ allocate space for the quotient
159 get_lint(((m + 1) + 1) / 2, ptr);
smfc 228 do j = hl_lint to li_nwords(ptr)-1;
161 heap(ptr+j) = 0;
162 end do;
163 li_sign(ptr) = sign;
164 li_ndig(ptr) = m + 1;
165
166$ multiply both arguments by scaling factor since the division algorithm
167$ requires the divisor be >= li_bas.
168
169 scale = li_bas / (li_pdigit(p2, 1) + 1);
170 if scale ^= 1 then
171 c = 0;
172 do i = 1 to li_ndig(p1);
173 temp = li_digit(p1, i) * scale + c;
174 li_digit(p1, i) = temp;
175 c = temp / li_bas;
176 end do;
177 c = 0;
178 do i = 1 to li_ndig(p2);
179 temp = li_digit(p2, i) * scale + c;
180 li_digit(p2, i) = temp;
181 c = temp / li_bas;
182 end do;
183 end if;
184
185$ now we come to the main loop of the algorithm. this loop has five
186$ parts: 1) estimate the quotient; 2) refine the estimate 3) subtract
187$ qe times the divisor from the dividend; 4) add back the divisor if the
188$ estimate was too high, and 5) set the the digit to the estimate.
189
190 do j = 1 to (m + 1);
191
192 $ part one: estimate qe.
193 if li_pdigit(p1, j) ^= li_pdigit(p2, 1) then
194 qe = (li_pdigit(p1, j) * li_bas + li_pdigit(p1, j+1))
195 / li_pdigit(p2, 1);
196 else
197 qe = li_bas - 1;
198 end if;
199
200 $ part two: refine estimate of qe.
201 while qe * li_pdigit(p2, 2) >
202 ( (li_pdigit(p1, j) * li_bas + li_pdigit(p1, j+1))
203 - qe * li_pdigit(p2, 1) ) * li_bas
204 + li_pdigit(p1, j+2);
205 qe = qe - 1;
206 end while;
207
208 $ part three: subtract qe times the divisor from the
209 $ dividend.
210 c = 0;
211 do k = n to 1 by -1;
212 du = li_pdigit(p1,j+k) - (qe * li_pdigit(p2,k)) + c;
213 temp = du - ((du / li_bas) * li_bas);
214 c = du / li_bas;
215 if temp < 0 then
216 li_pdigit(p1, j+k) = temp + li_bas;
217 c = c - 1;
218 else
219 li_pdigit(p1, j+k) = temp;
220 end if;
221 end do;
222
223 $ part four: if temp is negative, then qe was high and we
224 $ must add back the divisor and adjust qe.
225 temp = li_pdigit(p1, j) + c;
226 if temp < 0 then
227 qe = qe - 1;
228 c = 0;
229 do k = n to 1 by -1;
230 temp2 = li_pdigit(p1,j+k) + li_pdigit(p2,k) + c;
231 c = (temp2 >= li_bas);
232 li_pdigit(p1, j+k) = temp2;
233 end do;
234 li_pdigit(p1, j) = temp + c;
235 else
236 li_pdigit(p1, j) = temp;
237 end if;
238
239 $ part five: set the j-th digit of result to qe.
240 li_pdigit(ptr, j) = qe;
241
242 end do j;
243
244$ although we have finished the division, we must check to see whether
245$ this routine was called for the purpose of doing a division, or to
246$ find the mod of two numbers. if it was called to find the division
247$ nothing much needs to be done. if it was called in order to calculate
248$ the mod, we must reset the pointer -ptr- to point to -p1- and then
249$ divide the remainder by the scaling factor.
250
251 if op = 2 then $ compute remainder
252
253 ptr = p1; $ change the result to the remainder
254 sign = li_sign(p1);
255
256 if scale ^= 1 then
257 rr = 0;
258 do j = 1 to li_ndig(ptr);
259 temp = rr * li_bas + li_pdigit(ptr, j);
260 li_pdigit(ptr, j) = temp / scale;
261 rr = mod(temp, scale);
262 end do;
263 end if;
264 end if;
265
266 $ normalize the result
267 while li_ndig(ptr) > 1;
268 if (li_digit(ptr, li_ndig(ptr)) > 0) quit while;
269 li_ndig(ptr) = li_ndig(ptr) - 1;
270 end while;
271
272 li_sign(ptr) = sign;
274
275 build_spec(intdiv, t_lint, ptr);
276
277 $ check if result can be represented as a short int
278 if li_spint(ptr) ! (li_ndig(ptr)=1 & li_digit(ptr,1)=0) then
279 build_spec(intdiv, t_int, li_ddigit(ptr, 1));
280
281 elseif li_neg(ptr) & op = 2 then $ increment neg remainder
282 if li_pos(value_ arg2) then
283 intdiv = addli(intdiv, arg2);
284 else $ arg2 is negative: subtract instead
285 intdiv = diffli(intdiv, arg2);
286 end if;
287 end if;
288
289$ otherwise, one of the arguments was undefined, so we print an
290$ error message.
291
292 else
293 call err_type(13);
294 intdiv = err_val(f_int);
295 end if;
296
297 end fnct intdiv;
1 .=member trlint
2 fnct trlint(arg1);
3
4$ the function trlint transforms a setl short integer into it's setl
5$ long integer format. this form of integer exists only within the
6$ package for the sake of certain routines (e.g., multiplication)
7$ which are simplified by the use of such a representation.
8
9 size trlint(hs);
10
11 size arg1(hs);
12
13$ we simply build a long integer whose value happens to fall below
14$ maxsi.
15
16 build_lint1(trlint, ivalue_ arg1, positive);
17
18 end fnct trlint;
1 .=member umin
2 fnct umin(arg);
3
4$ unary minus operator
5
6
7 size arg(hs); $ specifier for long or short integer
8
9 size umin(hs); $ value returned
10
11 size val(hs), $ integer value of -arg-
12 temp(hs); $ temporary value
13
14 real v; $ real value of -arg-
mjsa 700
mjsa 701 size uminli(hs); $ returns complement of integers
15
16
17 if otype_ arg = t_real then
18 v = rval(value_ arg);
19 v = - v;
20 temp = v;
21 put_realval(temp, umin);
22
23 else
mjsa 702 umin = uminli(arg);
27 end if;
28
29
30 end fnct umin;
1 .=member sabs
2 fnct sabs(arg);
3
4$ this is the setl -abs x- routine. for a numeric x, it returns the
5$ absolute value of the argument; for a character string of length
6$ one, it returns an integer whose value is the internal representation
7$ of the string character.
8
9
10 size arg(hs); $ specifier for argument
11
12 size sabs(hs); $ specifier returned
13
14 size a(hs); $ local copy of argument
15 size p(ps); $ pointer to long int
16 size v(hs); $ integer value
17 size ss(ssz); $ string specifier
18
19 real r; $ real temporary
mjsa 703
mjsa 704 size ltli(1);
mjsa 705 size uminli(hs);
20
21
22 a = arg;
23
24/switch/
25
26 go to case(otype_ a) in t_min to t_max;
27
28
29/case(t_int)/ $ short integer
30
31 sabs = a; $ short integers are always positive
32 return;
33
34
35/case(t_string)/ $ short character string
stra 562
stra 563 if (sc_nchars_ a ^= 1) go to error2;
stra 564
stra 565 v = scchar(a, 1);
stra 566 build_spec(sabs, t_int, v);
stra 567
stra 568 return;
stra 569
36
37/case(t_atom)/ $ short atom
38
39/case(t_proc)/ $ procedure
40
41/case(t_lab)/ $ label
42
43/case(t_latom)/ $ long atom
44
45 go to error;
46
47
48/case(t_elmt)/ $ element
49
50 deref(a);
51 go to switch;
52
53
54/case(t_lint)/ $ long integer
55
mjsa 706 if ltli(a, zero) then $ a < 0: return - a
mjsa 707 sabs = uminli(a);
mjsa 708 else
mjsa 709 sabs = a;
mjsa 710 end if;
71
72 return;
73
74
75/case(t_istring)/ $ long character string
76
77 ss = value_ a;
78
79 if ss_len(ss) ^= 1 then $ invalid string length
80 go to error2;
81 else
82 v = icchar(ss, 1);
83 end if;
84
85 build_spec(sabs, t_int, v);
86 return;
87
88
89/case(t_real)/ $ real
90
91 r = rval(value_ a);
92
93 if r >= 0.0 then
94 sabs = a;
95 else
96 get_real(p);
97 rval(p) = -r;
98 build_spec(sabs, t_real, p);
99 end if;
100
101 return;
102
103
104/case(t_tuple)/ $ standard tuple
105
106/case(t_stuple)/ $ packed or untyped tuple
107
108/case(t_set)/ $ set
109
110/case(t_map)/ $ map
111
112 go to error;
113
114
115case_om; $ om type
116
117 call err_om(21);
118 sabs = err_val(f_gen);
119 return;
120
121
122/error/ $ type error
123
124 call err_type(44);
125 sabs = err_val(f_gen);
126 return;
127
128
129/error2/
130
131 call err_misc(49);
132 sabs = err_val(f_gen);
133 return;
134
135
136 end fnct sabs;
1 .=member schar
2 fnct schar(arg);
3
4$ this is the setl -char n- routine. it converts an integer in the
5$ range 0 ... 2**chsiz-1 into a character string of length one.
6
7
8 size arg(hs); $ specifier for integer
9
10 size schar(hs); $ specifier returned
11
12 size a(hs); $ local copy of arg
13 size v(ws); $ integer value of arg
16
17
18 a = arg; deref(a);
19
20 if otype_ a ^= t_int then $ invalid arguement
21 if is_om_ a then
22 call err_om(35);
23 else
24 call err_type(65);
25 end if;
26
27 schar = err_val(f_string);
28
29 else
30 v = ivalue_ a;
31
32 if v >= pow2(chsiz) then
33 call err_misc(50);
34 schar = err_val(f_string);
35
36 else
stra 570 schar = spec_char; $ one-character template
stra 571 scchar(schar, 1) = v;
40 end if;
41 end if;
42
43
44 end fnct schar;
1 .=member ceil
2 fnct ceil(arg);
3
4$ this is the setl 'ceil' function. it computes the smallest
5$ integer greater than or equal to a given real.
6
7
8 size arg(hs); $ specifier for real
9
10 size ceil(hs); $ specifier returned
11
12 size a(hs); $ local copy of arg
mjsa 711 real r1, r2; $ real temporaries
mjsa 712
mjsa 713 size addli(hs); $ adds two integers
mjsa 714 size fixli(hs); $ converts a real to an integer
mjsa 715 size floatli(hs); $ converts an integer to a real
15
16
17 a = arg; deref(a);
18
19 if otype_ a ^= t_real then $ invalid argument
20 if is_om_ a then
21 call err_om(24);
22 else
23 call err_type(58);
24 end if;
25
mjsa 716 ceil = err_val(f_int);
27
28 else
mjsa 717 ceil = fixli(a);
mjsa 718
smfc 229 r1 = rval(value_ a);
smfc 230
smfc 231 if abs(r1) <= float(.f. 1, real_mant_sz, all_ones) then
smfc 232 r2 = rval(value_ floatli(ceil));
smfc 233 if (r1 > r2) ceil = addli(ceil, one);
mjsa 723 end if;
32 end if;
33
34
35 end fnct ceil;
1 .=member floor
2 fnct floor(arg);
3
4$ this is the setl 'floor' function. it computes the largest
5$ integer less than or equal to a given real.
6
7
8 size arg(hs); $ specifier for real
9
10 size floor(hs); $ specifier returned
11
12 size a(hs); $ local copy of arg
mjsa 724 real r1, r2; $ real temporaries
mjsa 725
mjsa 726 size diffli(hs); $ subtracts two integers
mjsa 727 size fixli(hs); $ converts a real to an integer
mjsa 728 size floatli(hs); $ converts an integer to a real
15
16
17 a = arg; deref(a);
18
19 if otype_ a ^= t_real then $ invalid argument
20 if is_om_ a then
21 call err_om(25);
22 else
23 call err_type(59);
24 end if;
25
mjsa 729 floor = err_val(f_int);
27
28 else
mjsa 730 floor = fixli(a);
mjsa 731
smfc 234 r1 = rval(value_ a);
smfc 235
smfc 236 if abs(r1) <= float(.f. 1, real_mant_sz, all_ones) then
smfc 237 r2 = rval(value_ floatli(floor));
smfc 238 if (r1 < r2) floor = diffli(floor, one);
mjsa 736 end if;
32 end if;
33
34
35 end fnct floor;
1 .=member sfix
2 fnct sfix(arg);
3
4$ this is the setl 'fix' function. it computes the largest
5$ integer whose absolute value is less than or equal to the
6$ absolute value of a given real. the result has the same
7$ sign as the argument.
8
9
10 size arg(hs); $ specifier for real
11
12 size sfix(hs); $ specifier returned
13
14 size a(hs); $ local copy of arg
15 size v(ws); $ (integer) value of arg
16 real r; $ real temporary
mjsa 737
mjsa 738 size fixli(hs); $ function called
17
18
19 a = arg; deref(a);
20
21 if otype_ a ^= t_real then $ invalid argument
22 if is_om_ a then
23 call err_om(26);
24 else
25 call err_type(60);
26 end if;
27
28 sfix = err_val(f_gen);
29
30 else
mjsa 739 sfix = fixli(a);
34 end if;
35
36
37 end fnct sfix;
1 .=member sfloat
2 fnct sfloat(arg);
3
4$ this is the setl 'float' function. it converts an integer
5$ to a real.
6
7
8 size arg(hs); $ specifier for integer
9
10 size sfloat(hs); $ specifier returned
11
12 size a(hs); $ local copy of arg
13 size v(ws); $ (integer) value of arg
14 size p(ps); $ pointer to real
15 real r; $ real temporary
mjsa 740
mjsa 741 size floatli(hs); $ function called
16
17
18 a = arg; deref(a);
19
mjsa 742 if otype_ a = t_int then
mjsa 743 v = ivalue_ a; r = float(v);
mjsa 744 get_real(p); rval(p) = r;
mjsa 745 build_spec(sfloat, t_real, p);
mjsa 746
mjsa 747 elseif otype_ a = t_lint then
mjsa 748 sfloat = floatli(a);
mjsa 749
mjsa 750 else
mjsa 751 if is_om_ a then
mjsa 752 call err_om(27);
mjsa 753 else
mjsa 754 call err_type(61);
mjsa 755 end if;
mjsa 756
mjsa 757 sfloat = err_val(f_real);
mjsa 758 end if;
36
37
38 end fnct sfloat;
1 .=member relf
2 fnct relf(fc, arg);
3
4$ this routine evaluates the real unary elementary functions.
5
6
7 size fc(ps); $ function code
8 size arg(hs); $ spcifier for argument
9
10 size relf(hs); $ specifier returned
11
12 size a(hs); $ local copy of arg
13 real r; $ result value
14 real v; $ argument value
15 size p(hs); $ pointer to result
16
17
18$ erty gives error code if wrong type.
19
20 size erty(ps); dims erty(relf_max);
21 data erty(relf_acos) = 68;
22 data erty(relf_asin) = 69;
23 data erty(relf_atan) = 70;
24 data erty(relf_cos) = 71;
25 data erty(relf_exp) = 72;
26 data erty(relf_log) = 73;
27 data erty(relf_sin) = 74;
28 data erty(relf_sqrt) = 75;
29 data erty(relf_tan) = 76;
30 data erty(relf_tanh) = 77;
31
32$ erom gives error code if argument undefined.
33
34 size erom(ps); dims erom(relf_max);
35 data erom(relf_acos) = 38;
36 data erom(relf_asin) = 39;
37 data erom(relf_atan) = 40;
38 data erom(relf_cos) = 41;
39 data erom(relf_exp) = 42;
40 data erom(relf_log) = 43;
41 data erom(relf_sin) = 44;
42 data erom(relf_sqrt) = 45;
43 data erom(relf_tan) = 46;
44 data erom(relf_tanh) = 47;
45
46$ erdom gives error code if argument not in domain.
47$ code is zero if domain error not possible, else if
48$ err_misc error number.
49
50 size erdom(ps); dims erdom(relf_max);
51 data erdom(relf_acos) = 52;
52 data erdom(relf_asin) = 53;
53 data erdom(relf_atan) = 0;
54 data erdom(relf_cos) = 0;
55 data erdom(relf_exp) = 0;
56 data erdom(relf_log) = 54;
57 data erdom(relf_sin) = 0;
58 data erdom(relf_sqrt) = 55;
59 data erdom(relf_tan) = 0;
60 data erdom(relf_tanh) = 47;
61
62
63 a = arg; deref(a);
64
65 if otype_ a ^= t_real then
66 if is_om_ a then
67 call err_om(erom(fc));
68 else
69 call err_type(erty(fc));
70 end if;
71
72 relf = err_val(f_real);
73 return;
74 end if;
75
76 v = rval(value_ a);
77
78 go to case(fc) in relf_min to relf_max;
79
80
81/case(relf_acos)/ $ acos
82
smff 13 if ( ^ (-1.0 <= v & v <= 1.0)) go to domerr;
84
85$ use the identity acos x = pi/2 - atan2(x, sqrt(1-x*x))
86 r = atan2(1.0, 0.0) - atan2(v, sqrt(1.0 - v*v));
87 go to done;
88
89
90/case(relf_asin)/ $ asin
91
smff 14 if ( ^ (-1.0 <= v & v <= 1.0)) go to domerr;
93
94$ use the identity asin(x) = atan2(x, sqrt(1.0-x*x)).
95 r = atan2(v, sqrt(1.0 - v*v));
96 go to done;
97
98
99/case(relf_atan)/ $ atan
100
101 r = atan(v);
102 go to done;
103
104
105/case(relf_cos)/ $ cos
106
107 r = cos(v);
108 go to done;
109
110
111/case(relf_exp)/ $ exp
112
113 r = exp(v);
114 go to done;
115
116
117/case(relf_log)/ $ log
118
119 if (v<=0.0) go to domerr;
120 r = alog(v);
121 go to done;
122
123
124/case(relf_sin)/ $ sin
125
126 r = sin(v);
127 go to done;
128
129
130/case(relf_sqrt)/ $ sqrt
131
132 if (v<0.0) go to domerr;
133 r = sqrt(v);
134 go to done;
135
136
137/case(relf_tan)/ $ tan
138
139$ evaluate tan(x) = sin(x) / cos(x) with error if cos(x) is zero.
140
141 r = cos(v);
142 if (r=0.0) go to domerr;
143 r = sin(v) / r;
144 go to done;
145
146
147/case(relf_tanh)/ $ tanh
148
149 r = tanh(v);
150 go to done;
151
152
153/done/
154
155 get_real(p);
156 rval(p) = r;
157 build_spec(relf, t_real, p);
158
159 return;
160
161
162/domerr/ $ here if argument not in domain
163
164 call err_misc(erdom(fc));
165 relf = err_val(f_real);
166
167 return;
168
169
170 end fnct relf;
1 .=member atan2f
2 fnct atan2f(arg1, arg2);
3
4$ this function computes atan2 of its two arguments.
5
6
7 size arg1(hs); $ specifiers for arguments
8 size arg2(hs);
9
10 size atan2f(hs); $ specifier returned
11
12 size a1(hs); $ local copies of arguments
13 size a2(hs);
14 size temp(ws); $ word-sized temporary
15
16 real real1, real2, r; $ real values of operands and result
17
18
19 a1 = arg1; deref(a1);
20
21 if otype_ a1 ^= t_real then
22 if is_om_ a1 then
23 call err_om(36);
24 else
25 call err_type(66);
26 end if;
27
28 atan2f = err_val(f_real);
29 return;
30 end if;
31
32 a2 = arg2; deref(a2);
33
34 if otype_ a2 ^= t_real then
35 if is_om_ a2 then
36 call err_om(37);
37 else
38 call err_type(67);
39 end if;
40
41 atan2f = err_val(f_real);
42 return;
43 end if;
44
45 real1 = rval(value_ a1);
46 real2 = rval(value_ a2);
47
48 r = atan2(real1, real2); temp = r;
49
50 put_realval(temp, atan2f);
51
52
53 end fnct atan2f;
1 .=member rand
2 fnct srand(arg);
3
4$ this is the setl random function.
5
6
7 size arg(hs); $ specifier for argument
8
9 size srand(hs); $ specifier returned
10
11 size a(hs); $ local copy of arg
12
13 size v(hs); $ integer value
mjsa 759 size temp(hs); $ temporary variable
14 size n(ps); $ cardinality of set or map
15 size indx(hs); $ tuple index
16 size elmt(hs); $ element in set iteration
17 size iter(hs); $ iterator form of elmt
18 size p(hs); $ pointer to long int
19 size i(ps); $ loop index
20
21 size arbs(hs); $ pick element
mjsa 760 size ltli(1); $ arithmetic functions called
mjsa 761 size addli(hs);
mjsa 762 size diffli(hs);
mjsa 763 size fixli(hs);
mjsa 764 size floatli(hs);
22
23 real rr; $ real temporary
24 real r; $ real
25
26
27 a = arg;
28
29 call randr(rr); $ get next random real
30
31/switch/
32
33 go to case(otype_ a) in t_min to t_max;
34
35
36/case(t_int)/ $ short int
37
38 v = ifix(rr * float(1 + value_ a));
39 build_spec(srand, t_int, v);
40 return;
41
42
43/case(t_string)/ $ short chars
44
45/case(t_atom)/ $ short atom
46
47/case(t_proc)/
48
49/case(t_lab)/
50
51/case(t_latom)/ $ 'long' atom
52
53 go to error;
54
55
56/case(t_elmt)/ $ compressed element
57
58 deref(a); go to switch;
59
60
61/case(t_lint)/ $ long integer
62
mjsa 765 if ltli(zero, a) then
mjsa 766 temp = diffli(a, one);
mjsa 767 else
mjsa 768 temp = addli(a, one);
mjsa 769 end if;
mjsa 770
mjsa 771 r = rval(value_ floatli(temp));
mjsa 772
mjsa 773 get_real(p);
mjsa 774 rval(p) = r * rr;
mjsa 775 build_spec(temp, t_real, p);
mjsa 776
mjsa 777 srand = fixli(temp);
72
73 return;
74
75
76/case(t_istring)/ $ long chars
77
78 go to error;
79
80
81/case(t_real)/ $ real
82
83 r = rval(value_ a);
84
85 get_real(p);
86 rval(p) = r * rr;
87 build_spec(srand, t_real, p);
88
89 return;
90
91
92/case(t_tuple)/ $ standard tuple
93
94/case(t_stuple)/ $ packed or untyped tuple
95
96$ for tuple, find number of elements. if zero, return omega.
97$ otherwise, pick random integer and use of to extract component.
98
99 v = nelt(value_ a);
100
101 v = ifix(rr * float(v)) + 1;
102 build_spec(indx, t_int, v);
103 call of(srand, a, indx);
104 return;
105
106
107/case(t_set)/ $ set
108
109/case(t_map)/ $ map
110
111$ for a set of map, find number of elements n, pick
112$ random integer in range 1..n, and then iterate through argument
113$ until reach corresponding element.
114
115 ok_nelt(a); $ set element count
116 n = nelt(value_ a); $ get element count;
117 if n = 0 then $ return omega if null.
118 srand = arbs(a);
119 else
120 $ here to iterate through set.
121 n = ifix(rr * float(n)) + 1; $ get index desired element
122 call inext(elmt, iter, a);
123 do i = 1 to n; call nexts(elmt, iter, a); end do;
124 srand = elmt;
125 end if;
126 return;
127
128
129case_om; $ om type
130
131 call err_om(48);
132 srand = err_val(f_gen);
133
134 return;
135
136/error/ $ type error
137
138 call err_type(78);
139 srand = err_val(f_gen);
140
141
142 end fnct srand;
1 .=member randr
2 subr randr(r);
3
4$ this procedure computes next pseudo-random real in interval
5$ 0.0 to 1.0, including 0.0 but not including 1.0.
6$ the generator used is suggested by j. f. gimpel in algorithms in
7$ snobol4, john wiley and sons, new york, 1976, p. 343.
8
9 real r; $ result
10 size ranvar(ws); data ranvar = 1; $ variable, initial value
11
12 ranvar = mod(ranvar * 4676, 414971);
13 r = float(ranvar) / 414971.0;
14
15
16 end subr randr;
1 .=member shost
2 fnct shost(na);
3
4$ this is the host function that provides an escape to the
5$ host environment. functions provided by host are not part
6$ of the setl system and may differ from implementation to
7$ implementation.
8
9$ the default implementation of host is, appropriately, to
10$ return omega. any change to this is to be negotiated between
11$ implementor and user.
12
13 size na(ps); $ number of arguments
14
15 size shost(hs); $ specifier returned
16
17
18 shost = err_val(f_gen);
19
20
21 end fnct shost;
1 .=member isamap
2 fnct isamap(arg);
3
4$ this routine determines if argument set can be converted to map.
5
6
7 size arg(hs); $ specifier for argument
8
9 size isamap(1); $ flag returned
10
11 size a(hs); $ local copy of argument
12 size elmt(hs); $ element for iteration
13 size iter(hs); $ iterator
14
15
16 a = arg; deref(a);
17
18 if (otype_ a = t_map) go to pass;
19 if (otype_ a ^= t_set) go to fail;
20
21 call inext(elmt, iter, arg);
22
23 while 1;
24 call nexts(elmt, iter, arg);
25 if (is_om_ iter) quit;
26
27 if (^ istuple(otype_ elmt)) go to fail;
28 if (nelt(value_ elmt) ^= 2) go to fail;
29 if (is_om_ tcomp(value_ elmt, 1)) go to fail;
30 end while;
31
32/pass/
33 isamap = yes; return;
34
35/fail/
36 isamap = no; return;
37
38
39 end fnct isamap;
1 .=member istype
2 fnct istype(typ, arg);
3 $ return -little- true if arg of type typ given by ist_ code.
4 size typ(ps); $ ist_ type value
5 size arg(hs); $ specifier
6 size istype(1); $ result
7 size a(hs); $ specifier
8 size isamap(hs); $ function to test for map
9
10 a = arg; deref(a);
11 go to case(typ) in 1 to ist_max;
12
13/case(ist_int)/ $ is_integer
14
15 if (otype_ a = t_int) go to pass;
16 if (otype_ a = t_lint) go to pass;
17
18 go to fail;
19
20
21/case(ist_rea)/ $ is_real
22
23 if (otype_ a = t_real) go to pass;
24 go to fail;
25
26
27/case(ist_str)/ $ is_string
28
29 if (otype_ a = t_string) go to pass;
30 if (otype_ a = t_istring) go to pass;
31 go to fail;
32
33
34/case(ist_boo)/ $ is_boolean
35
36 if (eq(a, heap(s_true))) go to pass;
37 if (eq(a, heap(s_false))) go to pass;
38 go to fail;
39
40
41/case(ist_ato)/ $ is_atom
42
43 if (otype_ a = t_atom) go to pass;
44 if (otype_ a = t_latom) go to pass;
45 go to fail;
46
47
48/case(ist_pri)/ $ is_primitive
49
50 if (isprim(otype_ a)) go to pass;
51 go to fail;
52
53
54/case(ist_tup)/ $ is_tuple
55
56
57 if (istuple((otype_ a))) go to pass;
58 go to fail;
59
60
61/case(ist_set)/ $ is_set
62
63 if (isset((otype_ a))) go to pass;
64 go to fail;
65
66/case(ist_map)/ $ is_map
67
68 if (otype_ a = t_map) go to pass;
69 if (otype_ a ^= t_set & otype_ a ^= t_elmt) go to fail;
70
71 if (isamap(a)) go to pass;
72 go to fail;
73
74
75 /pass/ istype = 1; $ success
76 return;
77
78 /fail/ istype = 0; $ failure
79
80 end fnct istype;
81
82
1 .=member getippr
2 fnct sgtipp(na);
3
4$ this is the setl -getipp(str)- routine. it simulates the
5$ little -getipp- routine to read control card parameters.
6
7$ the argument -str- is a string of the form 'xxx=yyy/zzz'.
8$ where:
9
10$ xxx: the name of the parameter
11$ yyy: default if parameter not given
12$ zzz: default if only parameter name given
13
14$ -getippr- returns a specifier for an integer giving the
15$ value of the parameter.
16
18
19 size na(ps); $ number of arguments
20
21 size sgtipp(hs); $ specifier returned
22
23 size str(hs), $ specifier for -str-
24 parm(ps); $ value of control card parameter
25
26 size bldsds(sds_sz), $ functions called
27 err_val(hs);
28
29
32 str = stack_arg(1, 1);
33
34 if otype_ str ^= t_istring then
35 call err_type(50);
36 sgtipp = err_val(f_sint);
37 return;
38 end if;
39
40 call getipp(parm, bldsds(str));
41 put_intval(parm, sgtipp);
42
43
44 end fnct sgtipp;
1 .=member getsppr
2 fnct sgtspp(na);
3
4$ this is the setl -getspp(str)- routine. it simulates the
5$ little -getspp- routine to read control card parameters.
6
7$ the argument -str- is a string of the form 'xxx=yyy/zzz'.
8$ (see getippr)
9
10$ -getsppr- returns a specifier for a string giving the value
11$ of the parameter.
12
14
15 size na(ps); $ number of arguments
16
17 size sgtspp(hs); $ specifier returned
18
19 size str(hs), $ specifier for -str-
20 parm(sds_sz); $ parameter as little string
21
22 size bldsds(sds_sz), $ functions called
23 bldstr(hs),
24 err_val(hs);
25
26
29 str = stack_arg(1, 1);
30
31 if otype_ str ^= t_istring then
32 call err_type(51);
33 sgtspp = err_val(f_string);
34 return;
35 end;
36
37 call getspp(parm, bldsds(str));
38
39 sgtspp = bldstr(parm);
40
41
42 end fnct sgtspp;
1 .=member getem
2 fnct getem(na);
3
4$ this is the setl -getem(a, b)- routine. it assigns the values
5$ of the runtime library variables -err_mode- and -err_limit- to
6$ the variables -a- and -b-, resp.
7
8$ n.b. since this is a subroutine call, -a- and -b- are passed
9$ to -getem- through the stack.
10
11
12 size na(ps); $ number of arguments
13
14 size getem(hs); $ specifier returned
15
16
17 put_intval(err_mode, stack_arg(1, 2));
18 put_intval(err_limit, stack_arg(2, 2));
19
20
21 getem = spec_om;
22
23
24 end fnct getem;
1 .=member setem
2 fnct setem(na);
3
4$ this is the setl -setem(a, b)- routine. it assigns the values
5$ of the variables -a- and -b- to the runtime library
6$ variables -err_mode- and -err_limit-, resp.
7
8
9 size na(ps); $ number of arguments
10
11 size setem(hs); $ specifier returned
12
13 size em(hs), $ specifier for new error mode
14 el(hs); $ specifier for new error limit
15
16
17 em = ivalue_ stack_arg(1, 2);
18 el = ivalue_ stack_arg(2, 2);
19
20 if (el < err_count) call err_fatal(13);
21
22 if em = err_mode then $ just change error limit
23 err_limit = el;
24
25$ there are four possible error modes, namely err_off (= 1),
26$ err_part (= 2), err_opt (= 3), and err_full (= 4). since
27$ the code generator takes different actions depending on
28$ the specified error mode, there are restrictions as to what
29$ changes of err_mode are permissible at run-time.
30
31$ there is only one restriction: one can not change from
32$ err_mode = err_full to any other error mode, or from
33$ err_off, err_part, or err_opt to err_full.
34
35$ the following test enforces this restriction.
36
37 elseif 0 < em & em <= err_opt & err_mode <= err_opt then
38 err_mode = em;
39 err_limit = el;
40
41 else $ cannot change error mode
42 call err_fatal(23);
43 end if;
44
45
46 setem = spec_om;
47
48
49 end fnct setem;
1 .=member break
2 fnct break(na);
3
stra 572 size na(ps); $ number of arguments
stra 573 size break(hs); $ specifier for matched string returned
6
stra 574 size p(ps); $ pointer to pattern set
stra 575 size j(ps); $ loop index
stra 576 size c(cs); $ current character
stra 577 size success(1); $ success flag
11
12
13 init_match;
14
15 success = no;
16
17 string_loop(c, j);
stra 578 if memb_patt(c, p) then
19 success = yes;
stra 579 quit_string;
21 end if;
22 end_string;
23
24 match_result(break, j-1, success);
25
27
28 end fnct break;
1 .=member span
2 fnct span(na);
3
4$ this is similar to 'break', but the matched string includes all
5$ the characters in subject up to the first character which is not
6$ in 'param'.
7
stra 580 size na(ps); $ number of arguments
stra 581 size span(hs); $ specifier for matched string returned
11
stra 582 size p(ps); $ pointer to pattern set
stra 583 size j(ps); $ loop index
stra 584 size c(cs); $ current character
stra 585 size success(1); $ success flag
16
17
18 init_match;
19
20 success = no;
21
22 string_loop(c, j);
stra 586 if (^ memb_patt(c, p)) quit_string;
24 success = yes;
25 end_string;
26
27 match_result(span, j-1, success);
28
30
31 end fnct span;
1 .=member match
2 fnct match(na);
3
4$ this is the setl 'match(a1, a2)' routine.
5$
6$ it is a short hand for:
7$
8$ return
9$ if a1(1..#a2) = a2 then
10$ a2 $ side effect: a1 := a1(#a2+1..);
11$ else
12$ om $ no side effects
13$ end;
14
15
16 size na(ps); $ number of arguments
17
18 size match(hs); $ specifier returned
19
20 size a1(hs); $ specifier for first argument
21 size ss1(ssz); $ string specifier for a1
22 size l1(ps); $ length of a1
23
24 size a2(hs); $ specifier for second argument
25 size ss2(ssz); $ string specifier for a2
26 size l2(ps); $ length of a2
27
stra 587 size cc(1); $ condition code, result of string compare
stra 588 size success(1); $ success flag
32
33
34 a1 = stack_arg(1, 2); $ get arguments
35 a2 = stack_arg(2, 2);
36
stra 589 if otype_ a1 = t_string then $ subject is short string
stra 590 l1 = sc_nchars_ a1; $ get length of subject
stra 591 if otype_ a2 = t_string then $ param is short string
stra 592 l2 = sc_nchars_ a2; $ get length of param
stra 593 if l2 = 0 then $ param is null
stra 594 build_spec(match, t_string, 0);
stra 595 return;
stra 596 end if;
stra 597 if l2 > l1 then
stra 598 success = no;
stra 599 else
stra 600 success = (scchar(a1, 1) = scchar(a2, 1));
stra 601 end if;
stra 602 else $ param is long string
stra 603 ss2 = value_ a2; $ get pointer to string block
stra 604 l2 = ss_len(ss2); $ get lenght of param
stra 605 if l2 = 0 then $ param is null
stra 606 build_spec(match, t_string, 0);
stra 607 return;
stra 608 end if;
stra 609 if l2 > l1 then
stra 610 success = no;
stra 611 else
stra 612 success = (scchar(a1, 1) = icchar(ss2, 1));
stra 613 end if;
stra 614 end if;
stra 615 else $ subject is long string
stra 616 ss1 = value_ a1; $ get pointer to string block
stra 617 l1 = ss_len(ss1); $ get lenght of subject
stra 618 if otype_ a2 = t_string then $ param is short string
stra 619 l2 = sc_nchars_ a2; $ get length of param
stra 620 if l2 = 0 then $ param is null
stra 621 build_spec(match, t_string, 0);
stra 622 return;
stra 623 end if;
stra 624 if l2 > l1 then
stra 625 success = no;
stra 626 else
stra 627 success = (icchar(ss1, 1) = scchar(a2, 1));
stra 628 end if;
stra 629 else $ param is long string
stra 630 ss2 = value_ a2; $ get pointer to string block
stra 631 l2 = ss_len(ss2); $ get lenght of param
stra 632 if l2 = 0 then $ param is null
stra 633 build_spec(match, t_string, 0);
stra 634 return;
stra 635 end if;
stra 636 if l2 > l1 then
stra 637 success = no;
stra 638 else
stra 639 clc(cc, ss1, ss2, l2);
stra 640 success = (cc = 0);
stra 641 end if;
stra 642 end if;
stra 643 end if;
stra 644
stra 645 match_result(match, l2, success);
70
71
72 end fnct match;
1 .=member lpad
2 fnct lpad(na);
3
4$ this is the setl -lpad(str, n)- routine.
5
6$ it is a short hand for:
7
asca 55$ if #str > n then
9$ return str;
10$ else
asca 56$ return ' ' * (n - #str) + str;
12$ end if;
14
15 size na(ps); $ number of arguments
17 size lpad(hs); $ specifier returned
18
stra 646 size str(ssz); $ specifier for subject
stra 647 size ss1(ssz); $ string specifier for subject
stra 648 size len(ps); $ length of subject
stra 649 size n(ps); $ length of result
stra 650 size ss(ssz); $ string specifier for result
stra 651 size blank(cs); $ blank character
stra 652 size j(ps); $ loop index
26
stra 653 size nulllc(ssz); $ allocates null string
asca 58 .+ascebc size aschar(cs); $ ebcdic-to-ascii conversion
29
30
asca 59 blank = 1r ;
asca 60 .+ascebc if (ascebc_flag) blank = aschar(blank); $ convert to ascii
asca 61
stra 654 str = subject; n = ivalue_ param;
stra 655
stra 656 if otype_ str = t_string then $ subject is short
stra 657 len = sc_nchars_ str; $ get length of subject
stra 658 if len > n then
stra 659 lpad = str; $ return subject string
stra 660 else
stra 661 ss = nulllc(n); $ allocate result string block
stra 662 ss_len(ss) = n; $ set length of result
stra 663 do j = 1 to n-len; icchar(ss, j) = blank; end do;
stra 664 if len then icchar(ss, n) = scchar(str, 1); end if;
stra 665 build_spec(lpad, t_istring, ss);
stra 666 end if;
stra 667 else $ subject is long string
stra 668 ss1 = value_ str; $ get pointer to string block
stra 669 len = ss_len(ss1); $ get length of subject
stra 670 if len > n then
stra 671 lpad = str; $ return subject string
stra 672 else
stra 673 ss = nulllc(n); $ allocate result string block
stra 674 ss_len(ss) = n; $ set length of result
stra 675 do j = 1 to n-len; icchar(ss, j) = blank; end do;
stra 676 ss_ofs(ss) = ss_ofs(ss) + (n-len);
stra 677 mvc(ss, ss1, len);
stra 678 ss_ofs(ss) = ss_ofs(ss) - (n-len);
stra 679 build_spec(lpad, t_istring, ss);
stra 680 end if;
stra 681 end if;
54
55
56 end fnct lpad;
1 .=member len
2 fnct len(na);
3
4$ this is the setl 'len(str, n)' routine.
5$
6$ it is a short hand for:
7$
8$ return
9$ if #str < n then
10$ om $ no side effects
11$ else
12$ str(1..n) $ side effect: str := str(n+1..);
13$ end;
14
15
16 size na(ps); $ number of arguments
stra 682 size len(hs); $ specifier returned
17
18 size str(hs); $ specifier for string
19 size n(ps); $ length of result
20
23 size ss1(ssz); $ string specifier for first argument
24 size len1(ps); $ length of first argument
25 size ofs1(ps); $ string offset of first argument
26 size ss(ssz); $ string specifier for result
27
28
stra 683 str = subject; n = ivalue_ param;
stra 684
stra 685 if n = 0 then $ result is null, input unchanged
stra 686 build_spec(len, t_string, 0);
stra 687 return;
stra 688 end if;
stra 689
stra 690 if otype_ str = t_istring then $ subject is long string
stra 691 ss1 = value_ str; $ get pointer to string block
stra 692 len1 = ss_len(ss1); $ get length of subject
stra 693 ofs1 = ss_ofs(ss1); $ initial offset of subject
stra 694
stra 695 if len1 < n then $ subject too short: fail
stra 696 len = heap(ft_samp(f_sstring));
stra 697 else
stra 698 build_ss(ss, ss_ptr(ss1), ofs1, n);
stra 699 build_spec(len, t_istring, ss);
stra 700
stra 701 build_ss(ss, ss_ptr(ss1), ofs1 + n, len1 - n);
stra 702 build_spec(str, t_istring, ss);
stra 703
stra 704 subject = str;
stra 705 end if;
stra 706
stra 707 else $ subject is short string
stra 708 len1 = sc_nchars_ str; $ get length of subject
stra 709 if len1 < n then $ subject too short: fail
stra 710 len = heap(ft_samp(f_sstring));
stra 711 else
stra 712 len = str; value_ str = 0;
stra 713 subject = str;
stra 714 end if;
stra 715 end if;
48
49
50 end fnct len;
1 .=member any
2 fnct sany(na);
3
4$ this is another pattern matching primitive. it succeeds if the
5$ first character of the subject is in the parameter set.
6
stra 716 size na(ps); $ number of arguments
stra 717 size sany(hs); $ specifier returned
9
stra 718 size p(ps); $ pointer to param set
stra 719 size str(hs); $ specifier for subject
stra 720 size ss(ssz); $ string specifier for subject
stra 721 size c(cs); $ first character
stra 722 size success(1); $ success flag
14
stra 723
stra 724 str = subject; $ get specifier for subject string
stra 725
stra 726 until 1;
stra 727 if otype_ str = t_string then $ subject is short string
stra 728 if sc_nchars_ str = 0 then $ subject is null
stra 729 success = no; $ set to failure
stra 730 quit until; $ no character to be checked
stra 731 else
stra 732 c = scchar(str, 1); $ get first character
stra 733 end if;
stra 734 else $ subject is long string
stra 735 ss = value_ str; $ get pointer to character block
stra 736 if ss_len(ss) = 0 then $ subject is null
stra 737 success = no; $ set to failure
stra 738 quit until; $ no character to be checked
stra 739 else
stra 740 c = icchar(ss, 1); $ get first character
stra 741 end if;
stra 742 end if;
stra 743
stra 744 init_match;
stra 745 success = memb_patt(c, p);
stra 746 end until;
25
26 match_result(sany, 1, success);
27
29
30 end fnct sany;
1 .=member notany
2 fnct notany(na);
stra 747
3$ this is another pattern matching primitive. it succeeds if the
4$ first character of the subject is not in the parameter set.
5
stra 748 size na(ps); $ number of arguments
stra 749 size notany(hs); $ specifier returned
8
stra 750 size p(ps); $ pointer to param set
stra 751 size str(hs); $ specifier for subject
stra 752 size ss(ssz); $ string specifier for subject
stra 753 size c(cs); $ first character
stra 754 size success(1); $ success flag
13
stra 755
stra 756 str = subject; $ get specifier for subject string
stra 757
stra 758 until 1;
stra 759 if otype_ str = t_string then $ subject is short string
stra 760 if sc_nchars_ str = 0 then $ subject is null
stra 761 success = no; $ set to failure
stra 762 quit until; $ no character to be checked
stra 763 else
stra 764 c = scchar(str, 1); $ get first character
stra 765 end if;
stra 766 else $ subject is long string
stra 767 ss = value_ str; $ get pointer to character block
stra 768 if ss_len(ss) = 0 then $ subject is null
stra 769 success = no; $ set to failure
stra 770 quit until; $ no character to be checked
stra 771 else
stra 772 c = icchar(ss, 1); $ get first character
stra 773 end if;
stra 774 end if;
stra 775
stra 776 init_match;
stra 777 success = (memb_patt(c, p) = no);
stra 778 end until;
24
25 match_result(notany, 1, success);
26
28
29 end fnct notany;
1 .=member rbreak
2 fnct rbreak(na);
3
stra 779 size na(ps); $ number of arguments
stra 780 size rbreak(hs); $ specifier for matched string returned
6
stra 781 size p(ps); $ pointer to pattern set
stra 782 size j(ps); $ loop index
stra 783 size c(cs); $ current character
stra 784 size success(1); $ success flag
11
12
13 init_match;
14
15 success = no;
16
17 rstring_loop(c, j);
18 if memb_patt(c, p) then;
19 success = yes;
stra 785 quit_string;
21 end if;
22 end_string;
23
24 rmatch_result(rbreak, ss_len(value_ subject) - j, success);
25
27
28 end fnct rbreak;
1 .=member rspan
2 fnct rspan(na);
3
4$ this is similar to 'rbreak', but the matched string includes all
5$ the characters in subject up to the first character which is not
6$ in 'param'.
7
stra 786 size na(ps); $ number of arguments
stra 787 size rspan(hs); $ specifier for matched string returned
11
stra 788 size p(ps); $ pointer to pattern set
stra 789 size j(ps); $ loop index
stra 790 size c(cs); $ current character
stra 791 size success(1); $ success flag
16
17
18 init_match;
19
20 success = no;
21
22 rstring_loop(c, j);
stra 792 if (^ memb_patt(c, p)) quit_string;
24 success = yes;
25 end_string;
26
27 rmatch_result(rspan, ss_len(value_ subject) - j, success);
28
30
31 end fnct rspan;
1 .=member rmatch
2 fnct rmatch(na);
3
4$ this is the setl 'rmatch(a1, a2)' routine.
5$
6$ it is a short hand for:
7$
8$ return
9$ if a1(#a1-#a2+1..) = a2 then
10$ a2 $ side effect: a1 := a1(1..#a1-#a2);
11$ else
12$ om $ no side effects
13$ end;
14
15
16 size na(ps); $ number of arguments
17
18 size rmatch(hs); $ specifier returned
19
20 size a1(hs); $ specifier for first argument
21 size ss1(ssz); $ string specifier for a1
22 size l1(ps); $ length of a1
23
24 size a2(hs); $ specifier for second argument
25 size ss2(ssz); $ string specifier for a2
26 size l2(ps); $ length of a2
27
stra 793 size ss(ssz); $ string specifier for -a1(#a1-#a2+1..)-
stra 794 size cc(1); $ condition code, result of string compare
stra 795 size success(1); $ success flag
32
33
34 a1 = stack_arg(1, 2); $ get arguments
35 a2 = stack_arg(2, 2);
36
stra 796 if otype_ a1 = t_string then $ subject is short string
stra 797 l1 = sc_nchars_ a1; $ get length of subject
stra 798 if otype_ a2 = t_string then $ param is short string
stra 799 l2 = sc_nchars_ a2; $ get length of param
stra 800 if l2 = 0 then $ param is null
stra 801 build_spec(rmatch, t_string, 0);
stra 802 return;
stra 803 end if;
stra 804 if l2 > l1 then
stra 805 success = no;
stra 806 else
stra 807 success = (scchar(a1, 1) = scchar(a2, 1));
stra 808 end if;
stra 809 else $ param is long string
stra 810 ss2 = value_ a2; $ get pointer to string block
stra 811 l2 = ss_len(ss2); $ get lenght of param
stra 812 if l2 = 0 then $ param is null
stra 813 build_spec(rmatch, t_string, 0);
stra 814 return;
stra 815 end if;
stra 816 if l2 > l1 then
stra 817 success = no;
stra 818 else
stra 819 success = (scchar(a1, 1) = icchar(ss2, 1));
stra 820 end if;
stra 821 end if;
stra 822 else $ subject is long string
stra 823 ss1 = value_ a1; $ get pointer to string block
stra 824 l1 = ss_len(ss1); $ get lenght of subject
stra 825 if otype_ a2 = t_string then $ param is short string
stra 826 l2 = sc_nchars_ a2; $ get length of param
stra 827 if l2 = 0 then $ param is null
stra 828 build_spec(rmatch, t_string, 0);
stra 829 return;
stra 830 end if;
stra 831 if l2 > l1 then
stra 832 success = no;
stra 833 else
stra 834 success = (icchar(ss1, l1) = scchar(a2, 1));
stra 835 end if;
stra 836 else $ param is long string
stra 837 ss2 = value_ a2; $ get pointer to string block
stra 838 l2 = ss_len(ss2); $ get lenght of param
stra 839 if l2 = 0 then $ param is null
stra 840 build_spec(rmatch, t_string, 0);
stra 841 return;
stra 842 end if;
stra 843 if l2 > l1 then
stra 844 success = no;
stra 845 else
stra 846 build_ss(ss, ss_ptr(ss1), ss_ofs(ss1)+l1-l2, l2)
stra 847 clc(cc, ss, ss2, l2);
stra 848 success = (cc = 0);
stra 849 end if;
stra 850 end if;
stra 851 end if;
stra 852
stra 853 rmatch_result(rmatch, l2, success);
70
71
72 end fnct rmatch;
1 .=member rpad
2 fnct rpad(na);
3
4$ this is the setl -rpad(str, n)- routine.
5
6$ it is a short hand for:
7
asca 63$ if #str > n then
9$ return str;
10$ else
asca 64$ return str + ' ' * (n - #str);
12$ end if;
14
15 size na(ps); $ number of arguments
17 size rpad(hs); $ specifier returned
18
stra 854 size str(ssz); $ specifier for subject
stra 855 size ss1(ssz); $ string specifier for subject
stra 856 size len(ps); $ length of subject
stra 857 size n(ps); $ length of result
stra 858 size ss(ssz); $ string specifier for result
stra 859 size blank(cs); $ blank character
stra 860 size j(ps); $ loop index
26
stra 861 size nulllc(ssz); $ allocates null string
asca 66 .+ascebc size aschar(cs); $ ebcdic-to-ascii conversion
29
30
asca 67 blank = 1r ;
asca 68 .+ascebc if (ascebc_flag) blank = aschar(blank); $ convert to ascii
asca 69
stra 862 str = subject; n = ivalue_ param;
stra 863
stra 864 if otype_ str = t_string then $ subject is short
stra 865 len = sc_nchars_ str; $ get length of subject
stra 866 if len > n then
stra 867 rpad = str; $ return subject string
stra 868 else
stra 869 ss = nulllc(n); $ allocate result string block
stra 870 ss_len(ss) = n; $ set length of result
stra 871 if len then icchar(ss, 1) = scchar(str, 1); end if;
stra 872 do j = len+1 to n; icchar(ss, j) = blank; end do;
stra 873 build_spec(rpad, t_istring, ss);
stra 874 end if;
stra 875 else $ subject is long string
stra 876 ss1 = value_ str; $ get pointer to string block
stra 877 len = ss_len(ss1); $ get length of subject
stra 878 if len > n then
stra 879 rpad = str; $ return subject string
stra 880 else
stra 881 ss = nulllc(n); $ allocate result string block
stra 882 ss_len(ss) = n; $ set length of result
stra 883 mvc(ss, ss1, len);
stra 884 do j = len+1 to n; icchar(ss, j) = blank; end do;
stra 885 build_spec(rpad, t_istring, ss);
stra 886 end if;
stra 887 end if;
54
55
56 end fnct rpad;
1 .=member rlen
2 fnct rlen(na);
3
4$ this is the setl 'rlen(str, n)' routine.
5$
6$ it is a short hand for:
7$
8$ return
9$ if #str < n then
10$ om $ no side effects
11$ else
12$ str(#str-n+1..) $ side effect: str := str(1..#str-n);
13$ end;
14
15
16 size na(ps); $ number of arguments
stra 888 size rlen(hs); $ specifier returned
17
18 size str(ssz); $ string specifier for first argument
19 size n(ps); $ length of result
20
23 size ss1(ssz); $ string specifier for first argument
24 size len1(ps); $ length of first argument
25 size ofs1(ps); $ string offset of first argument
26 size ss(ssz); $ string specifier for result
27
stra 889
stra 890 str = subject; n = ivalue_ param;
stra 891
stra 892 if n = 0 then $ result is null, input unchanged
stra 893 build_spec(rlen, t_string, 0);
stra 894 return;
stra 895 end if;
stra 896
stra 897 if otype_ str = t_istring then $ subject is long string
stra 898 ss1 = value_ str; $ get pointer to string block
stra 899 len1 = ss_len(ss1); $ get length of subject
stra 900 ofs1 = ss_ofs(ss1); $ initial offset of subject
stra 901
stra 902 if len1 < n then $ subject too short: fail
stra 903 rlen = heap(ft_samp(f_sstring));
stra 904 else
stra 905 build_ss(ss, ss_ptr(ss1), ofs1+len1-n, n);
stra 906 build_spec(rlen, t_istring, ss);
stra 907
stra 908 build_ss(ss, ss_ptr(ss1), ofs1, len1 - n);
stra 909 build_spec(str, t_istring, ss);
stra 910
stra 911 subject = str;
stra 912 end if;
stra 913
stra 914 else $ subject is short string
stra 915 len1 = sc_nchars_ str; $ get length of subject
stra 916 if len1 < n then $ subject too short: fail
stra 917 rlen = heap(ft_samp(f_sstring));
stra 918 else
stra 919 rlen = str; value_ str = 0;
stra 920 subject = str;
stra 921 end if;
stra 922 end if;
47
48
49 end fnct rlen;
1 .=member rany
2 fnct rany(na);
3
4$ this is another pattern matching primitive. it succeeds if the
5$ first character of the subject is in the parameter set.
6
stra 923 size na(ps); $ number of arguments
stra 924 size rany(hs); $ specifier returned
9
stra 925 size p(ps); $ pointer to param set
stra 926 size str(hs); $ specifier for subject
stra 927 size ss(ssz); $ string specifier for subject
stra 928 size len(ps); $ length of subject string
stra 929 size c(cs); $ first character
stra 930 size success(1); $ success flag
14
stra 931
stra 932 str = subject; $ get specifier for subject string
stra 933
stra 934 until 1;
stra 935 if otype_ str = t_string then $ subject is short string
stra 936 if sc_nchars_ str = 0 then $ subject is null
stra 937 success = no; $ set to failure
stra 938 quit until; $ no character to be checked
stra 939 else
stra 940 c = scchar(str, 1); $ get last character
stra 941 end if;
stra 942 else $ subject is long string
stra 943 ss = value_ str; $ get pointer to character block
stra 944 len = ss_len(ss); $ get length of subject string
stra 945 if len = 0 then $ subject is null
stra 946 success = no; $ set to failure
stra 947 quit until; $ no character to be checked
stra 948 else
stra 949 c = icchar(ss, len); $ get last character
stra 950 end if;
stra 951 end if;
stra 952
stra 953 init_match;
stra 954 success = memb_patt(c, p);
stra 955 end until;
25
26 rmatch_result(rany, 1, success);
27
29
30 end fnct rany;
1 .=member rnotany
2 fnct rnotany(na);
3
4$ this is another pattern matching primitive. it succeeds if the
5$ first character of the subject is not in the parameter set.
6
stra 956 size na(ps); $ number of arguments
stra 957 size rnotany(hs); $ specifier returned
9
stra 958 size p(ps); $ pointer to param set
stra 959 size str(hs); $ specifier for subject
stra 960 size ss(ssz); $ string specifier for subject
stra 961 size len(ps); $ length of subject string
stra 962 size c(cs); $ first character
stra 963 size success(1); $ success flag
14
stra 964
stra 965 str = subject; $ get specifier for subject string
stra 966
stra 967 until 1;
stra 968 if otype_ str = t_string then $ subject is short string
stra 969 if sc_nchars_ str = 0 then $ subject is null
stra 970 success = no; $ set to failure
stra 971 quit until; $ no character to be checked
stra 972 else
stra 973 c = scchar(str, 1); $ get last character
stra 974 end if;
stra 975 else $ subject is long string
stra 976 ss = value_ str; $ get pointer to character block
stra 977 len = ss_len(ss); $ get length of subject string
stra 978 if len = 0 then $ subject is null
stra 979 success = no; $ set to failure
stra 980 quit until; $ no character to be checked
stra 981 else
stra 982 c = icchar(ss, len); $ get last character
stra 983 end if;
stra 984 end if;
stra 985
stra 986 init_match;
stra 987 success = (memb_patt(c, p) = no);
stra 988 end until;
25
26 rmatch_result(rnotany, 1, success);
27
29
30 end fnct rnotany;
1 .=member str
2 fnct str(arg);
3
4$ this routine converts any setl object to a string giving its external
5$ representation.
6
asca 71 .+ascebc.
asca 72$ in ascii mode, the result string needs to be in ascii. this is done
asca 73$ by assuming that -str- generates the correct ebcdic characters and
asca 74$ converting to ascii on the output that is done via local routine
asca 75$ write_char. however, we assume that strings in input are ascii
asca 76$ already, so we convert the output character of each string from ascii
asca 77$ to ebcdic so that when we merge with write_char, the proper output
asca 78$ conversion will be done.
asca 79 ..ascebc
7
8 size arg(hs); $ specifier for value to be converted
9
10 size str(hs); $ specifier for result string
11
12 size a(hs); $ local copy of arg
13 size len(ps); $ current length of str
14 size ss1(ssz); $ string specifier
15 size ss2(ssz); $ string specifier, used for copy
16 size p(ps); $ pointer to long string data block
17 size source_ss(ssz); $ string specifier
18 size source_word(ps); $ pointer to current word
19 size source_offs(ps); $ offset in current word
20 size rout(sds_sz); $ routine name
21 size stmt(ps); $ statement number
22 size int1(ws); $ signed integer
23 size int2(ws); $ signed integer
24 size int3(ws); $ signed integer
25 size exp1(ws); $ exponent of real number
26 real real1; $ real numbers
27 size string1(sds_sz); $ little string
28 size val(hs); $ packed or untyped value
29 size om_val(hs); $ untyped omega value
30 size t1(hs); $ temporary for set/tuple element
31 size t2(hs); $ temporary for set/tuple iterator
32 size j(ps); $ loop index
33 size k(ps); $ loop index
34 size ptr1(ps); $ pointer to current word
35 size ofs1(ps); $ offset in current word
36 size new(ps); $ junk pointer to get extra heap word
37 size c(chsiz); $ character code to be written
38 size tstart(ps); $ initial recursion stack pointer
39 size ret_int(ps); $ return address for write_int subroutine
40 size ret_real(ps); $ return address for write_real subroutine
41 size ret_sds(ps); $ return address for write_sds subroutine
42
43
44$ stacked variables
45
46 .=zzyorg b $ reset counter for stack offsets
47 local(retpt) $ return pointer
48
49 local(temp1) $ set/tuple element
50 local(temp2) $ set/tuple iterator
51 local(temp3) $ set/tuple specifier
52
53
54 size nulllc(ssz); $ returns string specifier for null string
smfc 239 size strli(hs); $ converts long integer to string
smfc 240 size addstr(hs); $ adds two strings
asca 80 .+ascebc.
asca 81 size ebchar(cs); $ ascii-to-ebcdic conversion function
asca 82 size aschar(cs); $ ebcdic-to-ascii conversion function
asca 83 ..ascebc
55
56
57 a = arg; $ local copy of argument
58
59 $ initialize result string
60 ss1 = nulllc(1); p = ss_ptr(ss1);
61 assert ss_ofs(ss1) = 0;
62 ptr1 = p + hl_lchars; ofs1 = chorg; len = 0;
63
64
65 .=zzyorg a $ reset counter for return labels
66 tstart = t; $ save recursion stack pointer
67
68/entry/ $ recursive entry point
69 r_entry $ increment recursion stack
70
71
72/switch/
73
74 if is_om_ a then
75 if (type_ a = t_error) go to case(t_error);
76
77 c = 1r*; l_call(write_char);
78
79 else
80 go to case(otype_ a) in t_min to t_lmax;
81
82
83/case(t_int)/ $ short integer
84
85 int1 = ivalue_ a; l_call(write_int);
86
87 go to exit;
88
89
90/case(t_string)/ $ short character string
91
92 c = 1r'; l_call(write_char);
93
94 do j = 1 to sc_nchars_ a;
stra 989 c = scchar(a, j);
asca 84 .+ascebc.
asca 85 $ recall that -write-char- expects ebcdic character.
asca 86 if (ascebc_flag) c = ebchar(c); $ convert to ebcdic
asca 87 ..ascebc
stra 990 l_call(write_char);
96 if c = 1r' then l_call(write_char); end if;
97 end do;
98
99 c = 1r'; l_call(write_char);
100
101 go to exit;
102
103
104/case(t_atom)/ $ short atom or boolean
105
106 c = 1r#; l_call(write_char);
107
108 if a = heap(s_true) then
109 c = 1rt; l_call(write_char);
110 elseif a = heap(s_false) then
111 c = 1rf; l_call(write_char);
112 else
113 int1 = ivalue_ a; l_call(write_int);
114 end if;
115
116 go to exit;
117
118
119/case(t_error)/ $ error value
120
121 call find_stmt(rout, stmt, value_ a);
122 string1 = '*** error at proc: '; l_call(write_sds);
123 string1 = rout; l_call(write_sds);
124 string1 = ' stmt: '; l_call(write_sds);
125 int1 = stmt; l_call(write_int);
126 string1 = ' addr: '; l_call(write_sds);
127 int1 = value_ a; l_call(write_int);
128 string1 = ' ***'; l_call(write_sds);
129
130 go to exit;
131
132
133/case(t_proc)/ $ procedure
134
135/case(t_lab)/ $ label
136
137 call err_misc(47);
138 str = err_val(f_gen);
139 return;
140
141
142/case(t_latom)/ $ long atom
143
144 c = 1r#; l_call(write_char);
145 int1 = la_value(value_ a); l_call(write_int);
146
147 go to exit;
148
149
150/case(t_elmt)/ $ element of base
151
152 deref(a); go to switch;
153
154
155/case(t_lint)/ $ long integer
156
smfc 241 ss_len(ss1) = len;
smfc 242 build_spec(str, t_istring, ss1);
smfc 243
smfc 244 ss1 = value_ addstr(str, strli(a));
smfc 245
smfc 246 p = ss_ptr(ss1); len = ss_len(ss1);
smfc 247 ptr1 = p + icoffs(ss1, len); ofs1 = icorg(ss1, len);
smfc 248 if ss_ofs(ss1) ^= 0
smfc 249 ! p + lc_nwords(p) ^= h
smfc 250 ! lcalloc(len) ^= lc_nwords(p)
smfc 251 ! ofs1 = chlst
smfc 252 then
smfc 253 ss2 = nulllc(len); $ allocate new string block
smfc 254 mvc(ss2, ss1, len) $ copy the string
smfc 255 ss1 = ss2;
smfc 256 p = ss_ptr(ss1); ptr1 = p + icoffs(ss1, len);
smfc 257 ofs1 = icorg(ss1, len);
smfc 258 end if;
smfc 259 assert ss_ofs(ss1) = 0;
smfc 260 assert p + lc_nwords(p) = h;
smfc 261 assert lcalloc(len) = lc_nwords(p);
smfc 262 if ofs1 = chlst then
smfc 263 get_heap(1, new); $ get extra word
smfc 264 lc_nwords(p) = lc_nwords(p) + 1;
smfc 265 ofs1 = chorg; ptr1 = ptr1 + 1;
smfc 266 else
smfc 267 ofs1 = ofs1 + chinc;
smfc 268 end if;
159
160 go to exit;
161
162
163/case(t_istring)/ $ long character string
164
165 c = 1r'; l_call(write_char);
166
167 s