13 <USE "COMPDEC" "CODGEN" "CHKDCL" "CARGEN" "NEWREP" "STRGEN" "MIMGEN" "ADVMESS">
15 " Definitions of offsets into MAPINFO vector used by MAP hackers inferiors."
45 '<VECTOR <LIST [REST NODE]>
52 <LIST [REST <OR ATOM FALSE>]>>>
56 <DEFINE MAPFR-GEN (NOD WHERE "OPT" (NF <>) (BR <>) (DIR <>)
57 "AUX" (K <KIDS .NOD>) (COD <NODE-TYPE <2 .K>>))
58 #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
60 (<==? .COD ,MFCN-CODE> <HMAPFR .NOD .WHERE .K .NF .BR .DIR>)
62 <PROG ((FAP <1 .K>) MPINFO (INRAP <2 .K>) W (STACKED 0) F? FF?
63 (MAYBE-FALSE <>) (NARG <LENGTH <SET K <REST .K 2>>>)
64 (R? <==? <NODE-SUBR .NOD> ,MAPR>) (MAPEND <MAKE-TAG "MAP">)
65 (MAPLP <MAKE-TAG "MAP">) (SUBRC <AP? .FAP>) (FOONARG .NARG)
67 <FUNCTION () <COND (<L? <SET FOONARG <- .FOONARG 1>>
69 (ELSE <GEN-TEMP <>>)>>>)
71 (EXTMP <GEN-TEMP <>>) (APTMP <>) (FLS <==? .WHERE FLUSHED>) TMP
72 (SEG? <MAPF ,LIST <FUNCTION (X) #FALSE ()> .STMPS>) (SEGCNT <>))
73 #DECL ((FAP INRAP) NODE (NARG POFF) FIX (MAPLP MAPEND) ATOM
74 (MPINFO) <SPECIAL MPINFO> (STACKED) <SPECIAL FIX>
75 (SEG?) <LIST [REST <OR ATOM FALSE>]> (SEGCNT) <OR FALSE TEMP>)
77 <COND (<==? .WHERE FLUSHED> FLUSHED)
78 (<==? .WHERE DONT-CARE> .FTMP)
80 <SET F? <DO-FIRST-SETUP .FAP .WHERE .FTMP .EXTMP .FLS>>
81 <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
82 <PUSH-STRUCS .K .STMPS .SEG?>
83 <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC .FTMP .EXTMP>>)>
84 <COND (<N==? .COD ,MPSBR-CODE> <SET APTMP <GEN .INRAP>>)>
88 '[VECTOR UVECTOR TUPLE STRING BYTES]>>>>
89 <START-FRAME <COND (.SUBRC) (ELSE APPLY)>>
90 <COND (<NOT .SUBRC> <PUSH .EXTMP>)>)>
94 <EMPTY-MAPF-CHECK .K .STMPS .MAPEND .SEG?>
95 <SET MPINFO [.K .R? .MAPEND .STMPS .F? .FTMP .EXTMP .SEG?]>
96 <COND (<AND <==? .COD ,MPSBR-CODE> <NOT <OR? !.SEG?>>>
98 <GEN <1 <KIDS .INRAP>> ,POP-STACK>
99 <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>)
101 <DO-FUNNY-HACK <GEN <1 <KIDS .INRAP>> DONT-CARE>
107 (<NOT .FLS> <GEN <1 <KIDS .INRAP>> .FTMP>)
108 (ELSE <GEN <1 <KIDS .INRAP>> FLUSHED>)>)
111 <SET SEGCNT <GEN-TEMP>>
115 <FUNCTION (SG) <COND (.SG 0) (ELSE 1)>>
117 <COND (.APTMP 1) (ELSE 0)>>>)>
118 <START-FRAME <COND (.APTMP APPLY)
119 (ELSE <NODE-NAME <1 <KIDS .INRAP>>>)>>
120 <COND (.APTMP <PUSH .APTMP>)>
123 <MPARGS-GEN .NOD ,POP-STACK .SEGCNT>
124 <AND <0? <SET I <- .I 1>>> <RETURN>>>
125 <MSUBR-CALL <COND (.APTMP APPLY)
126 (ELSE <NODE-NAME <1 <KIDS .INRAP>>>)>
127 <COND (.SEGCNT) (ELSE <+ .NARG 1>)>
128 <COND (<OR .F? .FF?> <SET TMP <GEN-TEMP>>)
130 <COND (.F? <DO-STACK-ARGS .MAYBE-FALSE .TMP .EXTMP .FTMP>)
132 <DO-FUNNY-HACK .TMP .NOD .FAP .INRAP .FTMP .EXTMP>)>)>
133 <REST-STRUCS .STMPS .K .SEG?>
136 <MAPF <> ,FREE-TEMP .STMPS>
137 <COND (<ASSIGNED? APTMP> <FREE-TEMP .APTMP>)>
139 <SET WHERE <DO-LAST .SUBRC .MAYBE-FALSE .WHERE .EXTMP .FTMP>>
142 (.FF? <FREE-TEMP .EXTMP> <SET WHERE <MOVE-ARG .FTMP .WHERE>>)
144 <SET WHERE <MOVE-ARG .FTMP .WHERE>>
146 (ELSE <FREE-TEMP .FTMP> <FREE-TEMP .EXTMP>)>
147 <FLUSH-TUPLES .STMPS .SEG?>
152 <DEFINE PUSH-STRUCS (K STMPS SEG?
153 "AUX" COUNTMP (SEGLABEL <MAKE-TAG>) (SEGCALLED <>))
154 #DECL ((K) <LIST [REST NODE]> (STMPS) <LIST [REST TEMP]>
155 (SEG?) <LIST [REST <OR ATOM FALSE>]>
156 (SEGCALLED COUNTMP SEGLABEL) <SPECIAL ANY>)
158 <FUNCTION (NP TMPP SEG "AUX" (N <1 .NP>) (TMP <1 .TMPP>) TT CT TTT TY STY)
159 #DECL ((N) NODE (SEG) LIST)
161 (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
162 <==? <NODE-TYPE .N> ,SEG-CODE>>
163 <SET N <1 <KIDS .N>>>
164 <IEMIT `SET <SET CT <SET COUNTMP <GEN-TEMP>>> 0>
165 <SET TT <GEN .N DONT-CARE>>
166 <COND (<NOT <OR <==? .TT ,NO-DATUM>
167 <AND <TYPE? .TT TEMP> <L=? <TEMP-REFS .TT> 1>>>>
168 <IEMIT `SET <SET TTT <GEN-TEMP>> .TT>
172 <COND (<N==? .TT ,NO-DATUM>
175 <STRUCTYP <RESULT-TYPE .N>>
176 <ISTYPE? <RESULT-TYPE .N>>
178 (.SEGCALLED <LABEL-TAG .SEGLABEL>)>
179 <SET SEGLABEL <MAKE-TAG>>
182 <IEMIT `TUPLE .CT = .TMP '(`TYPE TUPLE)>
185 <SET TT <GEN .N DONT-CARE>>
186 <SET STY <STRUCTYP <SET TY <RESULT-TYPE .N>>>>
187 <SET TY <ISTYPE? .TY>>
188 <COND (<AND <TYPE? .TT TEMP> <L=? <TEMP-REFS .TT> 1>>
189 <PUT .TMPP 1 <SET TMP .TT>>
190 <COND (<AND .STY <N==? .TY .STY>>
193 <FORM `TYPE-CODE .STY>
196 (<AND .STY <N==? .STY .TY>>
198 <IEMIT `CHTYPE .TT <FORM `TYPE-CODE .STY> = .TMP>)
199 (.STY <MOVE-ARG .TT .TMP (`TYPE .TY)>)
200 (ELSE <MOVE-ARG .TT .TMP>)>)>>
206 <DEFINE REST-STRUCS (STMPS K SEG?)
207 #DECL ((K) <LIST [REST NODE]> (STMPS) <LIST [REST TEMP]>
208 (SEG?) <LIST [REST <OR ATOM FALSE>]>)
210 <FUNCTION (TMP NOD SEG
211 "AUX" (ST <STRUCTYP <RESULT-TYPE .NOD>>) ETYP STMP LBL1 LBL2
213 #DECL ((NOD) NODE (TMP) TEMP)
216 <IEMIT `SET <SET STMP <GEN-TEMP>> .TMP>
217 <SET ETYP <STRUCTYP <GET-ELE-TYPE <RESULT-TYPE <1 <KIDS .NOD>>> ALL>>>
218 <COND (.ETYP <IEMIT `LOOP (<TEMP-NAME .STMP> LENGTH VALUE)>)
219 (ELSE <IEMIT `LOOP>)>
220 <LABEL-TAG <SET LBL1 <MAKE-TAG>>>
222 <EMPTY-CHECK TUPLE .STMP TUPLE T <SET LBL2 <MAKE-TAG>>>
223 <NTH-DO TUPLE .STMP <SET ETMP <GEN-TEMP>> 1>
224 <COND (.ETYP <REST-DO .ETYP .ETMP .ETMP 1>)
225 (ELSE <IEMIT `REST1 .ETMP = .ETMP>)>
226 <PUT-VECTOR .STMP 1 .ETMP>
227 <REST-DO TUPLE .STMP .STMP 1>
232 (.ST <REST-DO .ST .TMP .TMP 1>)
233 (ELSE <IEMIT `REST1 .TMP = .TMP>)>>
238 <DEFINE DO-FINAL-SETUP (FAP SUBRC FTMP EXTMP
239 "AUX" (MBYF <AND <NOT .SUBRC>
240 <OR <NOT .REASONABLE>
241 <N==? <NODE-TYPE .FAP>
243 <TYPE-OK? <RESULT-TYPE .FAP>
250 <GEN-TYPE? .EXTMP FALSE <SET TG1 <MAKE-TAG>> T>)>
251 <SET-TEMP .FTMP <COND (.SUBRC 0) (ELSE 1)> '(`TYPE FIX)>
253 <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
255 <SET-TEMP .FTMP <> '(`TYPE FALSE)>
259 <DEFINE DO-STACK-ARGS (MAYBE-FALSE ARG SW COUNT "AUX" TG1 TG2)
261 <GEN-TYPE? .SW FALSE <SET TG1 <MAKE-TAG>> T>
263 <IEMIT `ADD .COUNT 1 = .COUNT '(`TYPE FIX)>
264 <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
266 <MOVE-ARG .ARG .COUNT>
268 (ELSE <PUSH .ARG> <IEMIT `ADD .COUNT 1 = .COUNT '(`TYPE FIX)>)>>
270 <DEFINE DO-STACK-TUPLE (MAYBE-FALSE NEW-COUNT SW COUNT "AUX" TG1 TG2)
272 <LENGTH-VECTOR .NEW-COUNT .NEW-COUNT>
273 <GEN-TYPE? .SW FALSE <SET TG1 <MAKE-TAG>> T>
274 <IEMIT `ADD .COUNT .NEW-COUNT = .COUNT '(`TYPE FIX)>
275 <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
278 <IEMIT `SUB 1 .NEW-COUNT = .NEW-COUNT '(`TYPE FIX)>
279 <IEMIT `MUL .NEW-COUNT 2 = .NEW-COUNT '(`TYPE FIX)>
280 <IEMIT `ADJ .NEW-COUNT>
283 <LENGTH-VECTOR .NEW-COUNT .NEW-COUNT>
284 <IEMIT `ADD .COUNT .NEW-COUNT = .COUNT '(`TYPE FIX)>)>>
288 <SETG MINS '[[`LESS? `GRTR? `MUL `ADD] [`LESS? `GRTR? `MULF `ADDF]]>
290 <GDECL (MINS) !<VECTOR [2 !<VECTOR [4 ATOM]>]>>
292 <DEFINE DO-FUNNY-HACK (DAT N FAP NN FTMP EXTMP
293 "AUX" (COD <NODE-SUBR .FAP>)
294 (LMOD <ISTYPE? <RESULT-TYPE .NN>>)
295 (MOD <ISTYPE? <RESULT-TYPE .N>>) T1 T2 TMP INS)
296 #DECL ((COD) FIX (N FAP NN) NODE)
300 <IEMIT `CONS .DAT () = .TMP '(`TYPE LIST)>
301 <EMPTY-LIST .FTMP <SET T1 <MAKE-TAG>> <>>
302 <SET-TEMP .FTMP .TMP '(`TYPE LIST)>
303 <BRANCH-TAG <SET T2 <MAKE-TAG>>>
305 <IEMIT `PUTREST .EXTMP .TMP>
308 <SET-TEMP .EXTMP .TMP '(`TYPE LIST)>)
310 <SET MOD <OR <AND <==? .MOD FIX> 1> 2>>
311 <COND (<AND <==? .MOD 2> <==? .LMOD FIX>>
312 <SET TMP <GEN-FLOAT .DAT <GEN-TEMP>>>
315 <SET INS <NTH <NTH ,MINS .MOD> .COD>>
317 <IEMIT .INS .DAT .FTMP - <SET T1 <MAKE-TAG>>
318 (`TYPE <COND (<==? .MOD 1> FIX)
320 <MOVE-ARG .DAT .FTMP>
324 <IEMIT .INS .FTMP .DAT = .FTMP>)>)>
327 <DEFINE DO-LAST (SUBRC MAYBE-FALSE WHERE EXTMP COUNT "AUX" TG TG2)
329 <GEN-TYPE? .EXTMP FALSE <SET TG <MAKE-TAG>> T>
330 <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP>>)
331 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE>)>
332 <COND (.SUBRC <XMSUBR-CALL .SUBRC .COUNT .WHERE>)
333 (ELSE <MSUBR-CALL APPLY .COUNT .WHERE>)>
334 <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
336 <MOVE-ARG .COUNT .WHERE>
339 <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP>>)
340 (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE>)>
341 <COND (.SUBRC <XMSUBR-CALL .SUBRC .COUNT .WHERE>)
342 (ELSE <MSUBR-CALL APPLY .COUNT .WHERE>)>)>
345 <DEFINE XMSUBR-CALL (SUBRC NARGS WHERE)
346 <COND (<MEMQ .SUBRC '[VECTOR UVECTOR STRING BYTES]>
347 <IEMIT `UBLOCK <FORM `TYPE-CODE .SUBRC> .NARGS = .WHERE
350 <IEMIT `LIST .NARGS = .WHERE '(`TYPE LIST)>)
352 <IEMIT `TUPLE .NARGS = .WHERE>
353 <COND (<ASSIGNED? LIST-TUPLE>
354 <SET LIST-TUPLE (.WHERE !.LIST-TUPLE)>)>)
355 (ELSE <MSUBR-CALL .SUBRC .NARGS .WHERE>)>>
357 <SETG SLOT-FIRST [<CHTYPE <MIN> FIX> <CHTYPE <MAX> FIX> 1 0]>
359 <COND (<GASSIGNED? MINFL> <SETG FSLOT-FIRST [,MINFL ,MAXFL 1.0 0.0]>)>
361 <GDECL (SLOT-FIRST) <VECTOR [REST FIX]> (FSLOT-FIRST) <VECTOR [REST FLOAT]>>
365 <DEFINE DO-FIRST-SETUP (FAP W FTMP EXTMP FLS
367 (TYP <ISTYPE? <RESULT-TYPE <PARENT .FAP>>>))
368 #DECL ((FAP) NODE (COD) FIX)
370 (<==? <NODE-TYPE .FAP> ,MFIRST-CODE>
371 <SET COD <NODE-SUBR .FAP>>
373 <MOVE-ARG <REFERENCE <COND (.TYP <CHTYPE () .TYP>) (ELSE ())>>
375 <MOVE-ARG <REFERENCE ()> .EXTMP>
378 <MOVE-ARG <REFERENCE <COND (<==? .TYP FLOAT>
379 <NTH ,FSLOT-FIRST .COD>)
380 (ELSE <NTH ,SLOT-FIRST .COD>)>>
384 (<NOT .FLS> <DEALLOCATE-TEMP <MOVE-ARG <REFERENCE <>> .FTMP>> <>)>>
388 <DEFINE MPARGS-GEN (N W "OPT" (CNT <>) "AUX" (MP .MPINFO))
389 #DECL ((MP) MPINFO (ETAG) ATOM)
391 <STACKM <1 <MAP-STRS .MP>>
398 <PUT .MP ,MAP-STRS <REST <MAP-STRS .MP>>>
399 <PUT .MP ,MAP-TEMPS <REST <MAP-TEMPS .MP>>>
400 <PUT .MP ,MAP-SEG? <REST <MAP-SEG? .MP>>>
405 <DEFINE STACKM (N SRC R? LBL W SEG CNT
406 "AUX" (STY <STRUCTYP <RESULT-TYPE .N>>) STMP ETMP LBL1 LBL2
408 <GET-ELE-TYPE <RESULT-TYPE .N>
410 <AND .R? <NOT .SEG>>>))
412 <COND (<==? .W DONT-CARE>
413 <SET W <GEN-TEMP <COND (<ISTYPE? .ETY>)(T)>>>)
414 (<TYPE? .W TEMP> <USE-TEMP .W <ISTYPE? .ETY>>)>
415 <COND (.SEG ;"Note this implies W is STACK"
416 <IEMIT `SET <SET STMP <GEN-TEMP>> .SRC>
417 <IEMIT `LOOP (<TEMP-NAME .STMP> LENGTH VALUE)>
418 <LABEL-TAG <SET LBL1 <MAKE-TAG>>>
420 <EMPTY-CHECK TUPLE .STMP TUPLE T <SET LBL2 <MAKE-TAG>>>
421 <NTH-DO TUPLE .STMP <SET ETMP <GEN-TEMP>> 1>
422 <SET ETY <GET-ELE-TYPE <RESULT-TYPE <1 <KIDS .N>>> ALL>>
423 <COND (.R? <PUSH .ETMP>)
424 (<SET ETY <STRUCTYP .ETY>>
425 <NTH-DO .ETY .ETMP ,POP-STACK 1>)
426 (ELSE <IEMIT `NTH1 .ETMP = ,POP-STACK>)>
427 <IEMIT `ADD .CNT 1 = .CNT '(`TYPE FIX)>
428 <REST-DO TUPLE .STMP .STMP 1>
434 <SET ETY <ISTYPE? .ETY>>
435 <COND (.R? <IEMIT `SET .W .SRC>)
436 (.STY <NTH-DO .STY .SRC .W 1> .W)
437 (ELSE <IEMIT `NTH1 .SRC = .W>)>)>
440 <DEFINE EMPTY-MAPF-CHECK (K STMPS LBL SEG? "AUX" STMP ETMP LBL1 LBL2 ETYP)
441 #DECL ((K) <LIST [REST NODE]> (STMPS) <LIST [REST TEMP]>
442 (SEG?) <LIST [REST <OR ATOM FALSE>]>)
444 <FUNCTION (N TMP SEG "AUX" (STYP <STRUCTYP <RESULT-TYPE .N>>))
448 <IEMIT `SET <SET STMP <GEN-TEMP>> .TMP>
449 <IEMIT `LOOP (<TEMP-NAME .STMP> VALUE LENGTH)>
450 <LABEL-TAG <SET LBL1 <MAKE-TAG>>>
452 <EMPTY-CHECK TUPLE .STMP TUPLE T <SET LBL2 <MAKE-TAG>>>
453 <SET ETYP <STRUCTYP <GET-ELE-TYPE <RESULT-TYPE <1 <KIDS .N>>> ALL>>>
454 <NTH-DO TUPLE .STMP <SET ETMP <GEN-TEMP>> 1>
455 <COND (.ETYP <EMPTY-CHECK .ETYP .ETMP .ETYP T .LBL>)
457 <IEMIT `EMPTY? .ETMP + .LBL>)>
458 <REST-DO TUPLE .STMP .STMP 1>
463 (.STYP <EMPTY-CHECK .STYP .TMP .STYP T .LBL>)
465 <IEMIT `EMPTY? .TMP + .LBL>)>>
471 #DECL ((STK-CHARS8 STK-CHARS7 STK) FIX)
472 <COND (<N==? .STK-CHARS8 0>
473 <SET STK-CHARS8 <+ .STK-CHARS8 .STK>>
474 <SET STK-CHARS7 <+ .STK-CHARS7 .STK>>
476 <COND (<ASSIGNED? STKTMP>
478 <IEMIT `SUB .STKTMP .STK = .STKTMP (`TYPE FIX)>)
479 (<N==? .STK-CHARS7 0>
480 <IEMIT `IFSYS "TOPS20">
481 <IEMIT `SUB .STKTMP .STK-CHARS7 = .STKTMP>
482 <IEMIT `ENDIF "TOPS20">
483 <IEMIT `IFSYS "UNIX">
484 <IEMIT `SUB .STKTMP .STK-CHARS8 = .STKTMP>
485 <IEMIT `ENDIF "UNIX">)>
489 <IEMIT `ADJ <- .STK>>)
490 (<N==? .STK-CHARS8 0>
491 <IEMIT `IFSYS "TOPS20">
492 <IEMIT `ADJ <- .STK-CHARS7>>
493 <IEMIT `ENDIF "TOPS20">
494 <IEMIT `IFSYS "UNIX">
495 <IEMIT `ADJ <- .STK-CHARS8>>
496 <IEMIT `ENDIF "UNIX">)>>
498 <DEFINE FLUSH-TUPLES (STMPS SEG?)
499 #DECL ((SEG? STMPS) LIST)
502 #DECL ((TMP) TEMP (SEGF) <OR ATOM FALSE>)
504 <LENGTH-VECTOR .TMP .TMP>
505 <IEMIT `SUB 0 .TMP = .TMP '(`TYPE FIX)>
506 <IEMIT `MUL .TMP 2 = .TMP '(`TYPE FIX)>
514 <DEFINE HMAPFR (MNOD MWHERE K NF BR DIR
515 "AUX" (SPECD <>) (FAP <1 .K>) (INRAP <2 .K>) F?
516 (NARG <LENGTH <SET K <REST .K 2>>>)
517 (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (FF? <>)
518 (MAPEND <MAKE-TAG "MAP">) (MAPLP <MAKE-TAG "MAP">)
519 (REST-TAG <MAKE-TAG "MAP">) (SUBRC <AP? .FAP>)
520 (BASEF .BASEF) (MAYBE-FALSE <>) (EXIT <MAKE-TAG "MAPEX">)
521 (APPLTAG <MAKE-TAG "MAPAP">) (FLS <==? .MWHERE FLUSHED>)
522 (RTAG <MAKE-TAG "MAP">) TEM (FOONARG .NARG)
526 <COND (<L? <SET FOONARG <- .FOONARG 1>> 0>
528 (ELSE <GEN-TEMP <>>)>>>) FTMP FEXIT
529 (EXTMP <GEN-TEMP <>>) (BNDTMP <GEN-TEMP <>>)
530 (SEG? <MAPF ,LIST <FUNCTION (X) %<>> .STMPS>) SEGCNT
531 MYFRAME (INRTYP <ISTYPE? <RESULT-TYPE .INRAP>>)
532 (FWHERE <>) LEAVE? (OFT .FREE-TEMPS) (ANY-EMPTY <>)
533 STKTMP (STK 0) (STK-CHARS7 0) (STK-CHARS8 0))
534 #DECL ((STK-CHARS7 STK-CHARS8 STK) <SPECIAL FIX> (STKTMP) <SPECIAL ANY>
535 (SPECD) <SPECIAL <OR FALSE ATOM>> (NARG) <SPECIAL FIX> (FAP) NODE
536 (BASEF MNOD INRAP) <SPECIAL NODE> (K) <LIST [REST NODE]>
537 (MAPEND EXIT MAPLP RTAG APPLTAG REST-TAG) <SPECIAL ATOM>
538 (FTMP EXTMP MWHERE MAYBE-FALSE FLS) <SPECIAL ANY> (FSYM) SYMTAB
539 (F?) <SPECIAL ANY> (BNDTMP LEAVE?) <SPECIAL TEMP>
540 (DIR BR) <SPECIAL ANY> (SEG?) <LIST [REST <OR ATOM FALSE>]>
541 (TMPS) <PRIMTYPE LIST>)
545 <COND (<L? <MINL <RESULT-TYPE .X>> 1>
549 <COND (.NF <SET DIR <NOT .DIR>>)>
550 <PROG ((TMPS .TMPS) (TMPS-NEXT .TMPS-NEXT) (FREE-TEMPS .FREE-TEMPS)
551 (ALL-TEMPS-LIST .ALL-TEMPS-LIST))
552 #DECL ((TMPS-NEXT FREE-TEMPS ALL-TEMPS-LIST) <SPECIAL LIST>
553 (TMPS) <SPECIAL FORM>)
554 <COND (<==? .MWHERE DONT-CARE> <SET FTMP <SET MWHERE <GEN-TEMP <>>>>)
555 (ELSE <SET FTMP <GEN-TEMP <>>>)>
556 <SET F? <DO-FIRST-SETUP .FAP .MWHERE .FTMP .EXTMP .FLS>>
557 <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
558 <PUSH-STRUCS .K .STMPS .SEG?>
559 <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC .FTMP .EXTMP>>)>
562 <NOT <MEMQ .SUBRC '[VECTOR
567 <START-FRAME <COND (.SUBRC) (ELSE APPLY)>>
568 <COND (<NOT .SUBRC> <PUSH .EXTMP>)>)>
569 <COND (<AND .ANY-EMPTY .BR <N==? .INRTYP FALSE> <NOT .DIR>>
570 <EMPTY-MAPF-CHECK .K .STMPS .BR .SEG?>)>
577 <COND (.DIR <N==? .INRTYP FALSE>)
578 (ELSE <==? .INRTYP FALSE>)>>
582 <COND (<AND <OR <SPCS-X .INRAP> <OR? !.SEG?>>
586 <SET LEAVE? <GEN-TEMP>>
587 <IEMIT `SET .LEAVE? 0>
588 <IEMIT `ICALL <SET FEXIT <MAKE-TAG>> = <SET FWHERE <GEN-TEMP>>>
590 ((.TMPS .TMPS-NEXT .FREE-TEMPS <>) !.ALL-TEMPS-LIST)>
594 <SET MYFRAME <GEN-TEMP>>
595 <PREV-FRAME .MYFRAME>
596 <PUT <1 .ALL-TEMPS-LIST> 4 .MYFRAME>)>
597 <REPEAT ((BST <BINDING-STRUCTURE .INRAP>) (K .K) TMP SYM (STMPS .STMPS)
598 VAL (SEG? .SEG?) T-NAME TY PT)
599 #DECL ((BS) <LIST [REST SYMTAB]> (K) <LIST [REST NODE]>
600 (STMPS) <LIST [REST TEMP]> (TNAME) <SPECIAL ANY>
601 (SEG?) <LIST [REST <OR ATOM FALSE>]>)
607 <COND (<AND <NOT .SPECD> <SPEC-SYM .SYM>>
608 <SAVE-BINDING .BNDTMP>
610 <COND (<NOT <SPEC-SYM .SYM>>
616 <PUT .SYM ,TEMP-NAME-SYM .TMP>
617 <SET T-NAME <TEMP-NAME .TMP>>)>
618 <COND (<AND <MBIND-GENERATE .SYM> <NOT <SPEC-SYM .SYM>>>
619 <PUTREST .TMPS-NEXT <SET TMPS-NEXT (.T-NAME)>>
621 <PUT .TMP ,TEMP-REFS 1>)>>
625 <COND (<AND <SPEC-SYM <SET SYM <1 .BST>>> <NOT .SPECD>>
626 <SAVE-BINDING .BNDTMP>
629 (<NOT <SPEC-SYM .SYM>>
630 <SET TMP <GEN-TEMP <> <NAME-SYM .SYM> T T>>
631 <PUT .SYM ,TEMP-NAME-SYM .TMP>
635 (<COND (<AND <NOT <ASS? .SYM>>
636 <SET TY <ISTYPE? <COMPOSIT-TYPE .SYM>>>
637 <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
640 <CHTYPE [<TEMP-NAME .TMP> .TY] ADECL>)
641 (ELSE <TEMP-NAME .TMP>)>)>>
642 <PUT .TMP ,TEMP-REFS 1>)>
643 <COND (<AND <1 .SEG?> <==? <CODE-SYM .SYM> ,ARGL-TUPLE>>
644 <IEMIT `SET <SET SEGCNT <GEN-TEMP>> 0>
645 <STACKM <1 .K> <1 .STMPS> .R? .MAPEND ,POP-STACK T .SEGCNT>
649 <COND (<SPEC-SYM .SYM> <SET VAL <GEN-TEMP>>)
652 <COMPILE-LOSSAGE "Not quite implemented SEGMENTS in MAPFS">)
659 <COND (<SPEC-SYM .SYM> DONT-CARE) (ELSE .TMP)>
662 <COND (<SPEC-SYM .SYM>
663 <SPECIAL-BINDING .SYM T .VAL>
664 <SET STK <+ .STK ,BINDING-LENGTH>>)>
665 <SET STMPS <REST .STMPS>>
666 <SET BST <REST .BST>>
668 <SET SEG? <REST .SEG?>>)>>
670 <SET TEM <SEQ-GEN <KIDS .INRAP> DONT-CARE>>
671 <COND (<N==? .TEM ,NO-DATUM>
675 <IEMIT `RTUPLE 1 <FREE-TEMP <CURRENT-FRAME> <>>>)
677 <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
678 <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
679 <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
680 <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
682 <FREE-TEMP .SEGCNT>)>
684 <DO-STACK-ARGS .MAYBE-FALSE .TEM .EXTMP .FTMP>
685 <FREE-TEMP .TEM>)>)>)
687 <SET TEM <SEQ-GEN <KIDS .INRAP> DONT-CARE>>
688 <COND (<N==? .TEM ,NO-DATUM>
689 <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
690 <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
691 <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
692 <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
694 <FREE-TEMP .SEGCNT>)>
696 <DO-FUNNY-HACK .TEM .MNOD .FAP .INRAP .FTMP .EXTMP>)>)
698 <SEQ-GEN <KIDS .INRAP> FLUSHED>
699 <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
700 <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
701 <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
702 <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
704 <FREE-TEMP .SEGCNT>)>
707 <SEQ-GEN <KIDS .INRAP> .FTMP>
708 <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
709 <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
710 <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
711 <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
713 <FREE-TEMP .SEGCNT>)>
715 <COND (<NOT <ASSIGNED? LEAVE?>> <SET OFT .FREE-TEMPS>)>>
716 <SET FREE-TEMPS .OFT>
717 <SET TMPS-NEXT <REST .TMPS <- <LENGTH .TMPS> 1>>>
718 <COND (<AND .FWHERE .F?>
720 <IEMIT `VEQUAL? .LEAVE? 2 + .EXIT>
721 <DO-STACK-TUPLE .MAYBE-FALSE .FWHERE .EXTMP .FTMP>
722 <IEMIT `VEQUAL? .LEAVE? 1 + .APPLTAG>
723 <FREE-TEMP .LEAVE?>)>
724 <COND (<AND <NOT .F?> <ASSIGNED? SEGCNT> .SEGCNT>
725 <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
726 <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
728 <FREE-TEMP .SEGCNT>)>
729 <LABEL-TAG .REST-TAG>
730 <REST-STRUCS .STMPS .K .SEG?>
734 <SET MWHERE <DO-LAST .SUBRC .MAYBE-FALSE .MWHERE .EXTMP .FTMP>>
737 (.FF? <FREE-TEMP .EXTMP> <SET MWHERE <MOVE-ARG .FTMP .MWHERE>>)
738 (<N==? .MWHERE FLUSHED>
740 <COND (<N==? .FTMP .MWHERE> <MOVE-ARG .FTMP .MWHERE>)>)
741 (ELSE <FREE-TEMP .EXTMP> <FREE-TEMP .FTMP>)>
743 <FLUSH-TUPLES .STMPS .SEG?>
746 <DEFINE SAVE-BINDING (BNDTMP) <USE-TEMP .BNDTMP> <GET-BINDING .BNDTMP>>
748 <DEFINE NO-INTERFERE (N B)
749 #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
750 <COND (<AND <==? <NODE-TYPE .N> ,LVAL-CODE> <MEMQ <NODE-NAME .N> .B>>
752 (<MEMQ <NODE-TYPE .N> ,SNODES> T)
753 (<AND <==? <NODE-TYPE .N> ,COND-CODE>
754 <NOT <NO-INTERFERE <PREDIC .N> .B>>>
760 <COND (<NO-INTERFERE .N .B> T)
761 (ELSE <MAPLEAVE <>>)>>
766 <DEFINE NOTIMP (ARG) <COMPILE-ERROR "NOT IMPLEMENTED MAPF/R TUPLES">>
768 <DEFINE MENTROPY (SYM) T>
770 <DEFINE MBIND-GENERATE (SYM "AUX" (COD <CODE-SYM .SYM>))
771 #DECL ((SYM) SYMTAB (COD) FIX)
774 (,ARGL-ACT <ACT-B .SYM>)
775 (,ARGL-IAUX <AUX1-B .SYM T>)
776 (,ARGL-AUX <AUX2-B .SYM T>)
777 (,ARGL-TUPLE <NOTIMP .SYM>)
778 (,ARGL-ARGS <MENTROPY .SYM>)
779 (,ARGL-QIOPT <AUX1-B .SYM T>)
780 (,ARGL-IOPT <AUX1-B .SYM T>)
781 (,ARGL-QOPT <AUX2-B .SYM T>)
782 (,ARGL-OPT <AUX2-B .SYM T>)
783 (,ARGL-CALL <MENTROPY .SYM>)
784 (,ARGL-BIND <BIND-B .SYM>)
785 (,ARGL-QUOTE <MENTROPY .SYM>)
786 (,ARGL-ARG <MENTROPY .SYM>)>>
788 <DEFINE MAPLEAVE-GEN (N W
789 "AUX" (FAP <1 <KIDS .MNOD>>) (TMP <GEN-TEMP <>>)
790 (BR .BR) (DIR .DIR) RT (FRAME? <ASSIGNED? LEAVE?>)
792 #DECL ((MNOD FAP N) NODE (TMP) TEMP)
793 <SET FOK <TYPE-AND <SET RT <RESULT-TYPE <SET N <1 <KIDS .N>>>>> FALSE>>
794 <SET TRUE-OK <N==? <ISTYPE? .RT> FALSE>>
795 <COND (<==? .MWHERE FLUSHED>
797 <COND (<AND .FOK .TRUE-OK>
798 <PRED-BRANCH-GEN .BR .N .DIR>)
801 <COND (<COND (.FOK <NOT .DIR>) (ELSE .DIR)>
802 <BRANCH-TAG .BR>)>)>)
806 <COND (<AND .F? <==? .MWHERE .FTMP> <NOT .FRAME?>>
807 <SET-TEMP .TMP .FTMP>)
808 (ELSE <SET TMP .FTMP>)>
809 <SET MWHERE <GEN .N .MWHERE>>
810 <DEALLOCATE-TEMP .MWHERE>)>
811 <COND (.FRAME? <SET-TEMP .LEAVE? 2>)
814 <MAP-UNBIND .TMP .F? .BNDTMP .SPECD>
815 <COND (<N==? .TMP .FTMP> <FREE-TEMP .TMP>)>
819 <DEFINE MAP-UNBIND (EXTMP F? BNDTMP SPECD)
821 <IEMIT `SUB 0 .EXTMP = .EXTMP '(`TYPE FIX)>
822 <IEMIT `MUL .EXTMP 2 = .EXTMP '(`TYPE FIX)>
823 <IEMIT `ADJ .EXTMP>)>
824 <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
829 <DEFINE MAPRET-STOP-GEN (N W
830 "AUX" (SG <SEGS .N>) (K <KIDS .N>) (LN <LENGTH .K>)
831 (FAP <1 <KIDS .MNOD>>) DAT FTG
832 (FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>)
833 (LEAVE <==? <NODE-SUBR .N> ,MAPSTOP>)
834 (EXTMP .EXTMP) (FTMP .FTMP) (F? .F?)
835 (MAYBE-FALSE .MAYBE-FALSE) SEGTMP
836 (FRAME? <ASSIGNED? LEAVE?>)
837 (SEGLABEL <MAKE-TAG>) (COUNTMP .FTMP)
839 #DECL ((N MNOD) NODE (K) <LIST [REST NODE]> (LN) FIX
840 (SEGCALLED SEGLABEL COUNTMP) <SPECIAL ANY>)
842 (<AND <NOT .SG> <L? .LN 2>>
843 <COND (<NOT <0? .LN>>
844 <SET DAT <GEN <1 .K>>>
847 <DO-FUNNY-HACK .DAT <1 .K> .FAP .INRAP .FTMP .EXTMP>)
851 <IEMIT `RTUPLE 1 <FREE-TEMP <CURRENT-FRAME> <>>>)
855 <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>)>
858 (.FF? <DO-FUNNY-MAPRET .N .K .FAP> <REM-TUPS>)
860 <COND (.FRAME? <SET FTMP <GEN-TEMP>> <IEMIT `SET .FTMP 0>)>
862 <FUNCTION (NOD "AUX" TG STYP N TT RES)
865 (<==? <NODE-TYPE .NOD> ,SEGMENT-CODE>
866 <COND (<NOT <ASSIGNED? SEGTMP>> <SET SEGTMP <GEN-TEMP <>>>)>
867 <SET RES <GEN <SET N <1 <KIDS .NOD>>> .SEGTMP>>
868 <COND (.MAYBE-FALSE <GEN-TYPE? .EXTMP FALSE <SET TG <MAKE-TAG>> T>)>
869 <COND (<N==? .RES ,NO-DATUM>
873 <SET STYP <STRUCTYP <RESULT-TYPE .N>>>
874 <ISTYPE? <RESULT-TYPE .N>>
876 (.SEGCALLED <LABEL-TAG .SEGLABEL>)>
877 <SET SEGLABEL <MAKE-TAG>>
879 <BRANCH-TAG <SET FTG <MAKE-TAG>>>
881 <COND (.STYP <EMPTY-CHECK .STYP .SEGTMP .STYP T .FTG>)
882 (ELSE <IEMIT `EMPTY? .SEGTMP + .FTG>)>
883 <STACKM .N .SEGTMP <> <> .FTMP <> <>>
888 <GEN-TYPE? .EXTMP FALSE <SET TG <MAKE-TAG>> T>
890 <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>
891 <BRANCH-TAG <SET FTG <MAKE-TAG>>>
897 <GEN .NOD ,POP-STACK>
898 <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>)>)>>
901 <COND (.LEAVE <SET-TEMP .LEAVE? 1>)>
902 <IEMIT `RTUPLE .FTMP <FREE-TEMP <CURRENT-FRAME> <>>>)>)>
904 <BRANCH-TAG <COND (.LEAVE .APPLTAG) (ELSE .REST-TAG)>>)>
909 <DEFINE DO-FUNNY-MAPRET (N K FAP "AUX" SEGTMP SEGLABEL COUNTMP TGX (SEGCALLED <>))
910 #DECL ((N FAP) NODE (K) <LIST [REST NODE]>
911 (SEGLABEL COUNTMP SEGCALLED) <SPECIAL ANY>)
913 <FUNCTION (NN "AUX" TG1 TG2 DAT STYP TMPX TEM)
914 #DECL ((NN) NODE (TG1 TG2) ATOM)
915 <COND (<OR <==? <NODE-TYPE .NN> ,SEG-CODE>
916 <==? <NODE-TYPE .NN> ,SEGMENT-CODE>>
917 <SET COUNTMP <GEN-TEMP>>
918 <SET SEGLABEL <MAKE-TAG>>
919 <SET TEM <GEN <SET NN <1 <KIDS .NN>>>>>
920 <COND (<AND <TYPE? .TEM TEMP> <L=? <TEMP-REFS .TEM> 1>>
922 (<N==? .TEM ,NO-DATUM>
923 <COND (<NOT <ASSIGNED? SEGTMP>>
924 <SET SEGTMP <GEN-TEMP <>>>)>
925 <SET-TEMP .SEGTMP .TEM>
928 <COND (<N==? .TEM ,NO-DATUM>
929 <SET STYP <STRUCTYP <RESULT-TYPE .NN>>>
930 <COND (<==? .STYP LIST>
931 <IEMIT `LOOP (<TEMP-NAME .SEGTMP> VALUE)>)
933 <IEMIT `LOOP (<TEMP-NAME .SEGTMP>
935 <LABEL-TAG <SET TG1 <MAKE-TAG>>>
937 <SET TMPX <GEN-TEMP>>
939 <EMPTY-CHECK .STYP .SEGTMP .STYP T .TG2>
940 <NTH-DO .STYP .SEGTMP .TMPX 1>)
942 <IEMIT `EMPTY? .SEGTMP + .TG2>
943 <IEMIT `NTH1 .SEGTMP = .TMPX>)>
944 <DO-FUNNY-HACK .TMPX .MNOD .FAP .NN .FTMP .EXTMP>
945 <COND (.STYP <REST-DO .STYP .SEGTMP .SEGTMP 1>)
946 (ELSE <IEMIT `REST1 .SEGTMP = .SEGTMP>)>
949 <SET TMPX <GEN-TEMP>>
950 <LABEL-TAG .SEGLABEL>
952 <LABEL-TAG <SET TGX <MAKE-TAG>>>
953 <IEMIT `VEQUAL? .COUNTMP 0 + .TG2>
955 <DO-FUNNY-HACK .TMPX .MNOD .FAP .NN .FTMP .EXTMP>
956 <IEMIT `SUB .COUNTMP 1 = .COUNTMP>
961 (<N==? .TEM ,NO-DATUM>
964 <SET DAT <GEN .NN DONT-CARE>>
965 <DO-FUNNY-HACK .DAT .MNOD .FAP .NN .FTMP .EXTMP>)>>
968 <DEFINE AP? (N "AUX" AT)
970 <AND <==? <NODE-TYPE .N> ,GVAL-CODE>
971 <==? <NODE-TYPE <SET N <1 <KIDS .N>>>> ,QUOTE-CODE>
972 <SET AT <NODE-NAME .N>>
974 <AND <GASSIGNED? .AT> <TYPE? ,.AT MSUBR>>
975 <AND <GASSIGNED? .AT>
976 <TYPE? ,.AT FUNCTION>
978 <AND <TYPE? .FCNS LIST> <MEMQ .AT .FCNS>>>>>