3 <ENTRY MOVE:ARG ADDR:TYPE ADDR:VALUE MOVE:VALUE STEMP:ADDR MOVE:TYP EMIT
4 D:B:TAG SEGMENT:LIST TUPLE:FINAL STORE:BIND LOCAL-TAGS TEST:ARGPNTR
5 REFERENCE BRANCH:TAG PSLOT COPY:ARGPNTR BIND:END TIME:STACK
6 ACT:FINAL PUSH:BIND TIME:CHECK START:TAG ISTAG? FAST:GVAL
7 REFERENCE:ARGPNTR REFERENCE:ARG POP:LOCS SEGMENT:STACK PUSH:PAIR
8 MAKE:ENV LABEL:TAG FAST:SETG BUMP:CNTR MAKE:ACT REFERENCE:STACK
9 SPEC:REFERENCE:STACK ADDRESS:PAIR PCOUNTER STACK:ARGUMENT
10 SALLOC:SLOTS FAST:VAL GEN:FALSE SUBR:CALL STORE:PAIR FIX-ACLINK
11 BUMP:ARGPNTR COUNTP SEGMENT:FINAL TEST:ARG FUNCTION:VALUE
12 REFERENCE:UNBOUND ACT:INITIAL UNBIND:LOCS FIX:ADDR FAST:SET PUSH:ATB
13 UNIQUE:TAG ALLOC:SLOTS ADDR:TYPE1 PROG:END ADDR:VALUE1 FUNCTION:INITIAL
14 REFERENCE:ADR ALLOCATE:SLOTS GETUVT UNBIND:FUNNY LABEL:OFF IMCHK
15 CODE:PTR CODE:TOP BUILD:FRAME FRAMLN CHECK-LOCAL-TAGS GROUP:INITIAL
16 INT:LOSER:INITIAL INT:INITIAL SUB:INT:INITIAL FCN:INT:INITIAL
17 SUB:INITIAL FS:INT:INITIAL RDCL INT:FINAL FS:INT:FINAL FCNSUB:FINAL
20 <USE "CACS" "COMPDEC" "NPRINT" "CODGEN" "PEEPH" "CODING" "CHKDCL" "CUP">
28 <BLOCK (!.OBLIST <GET PACKAGE OBLIST>)>
32 "***** BEGINNING OF THE IMPLEMENTATION SECTION *****"
35 #DECL ((CODE:PTR) LIST)
36 <PUTREST .CODE:PTR (.INSTR)>
37 <SET CODE:PTR <REST .CODE:PTR>>>
39 <SETG BIND-BEGIN [<FORM (<CHTYPE <TYPE-C ATOM> FIX>) -1>]>
41 "Special datum meaning nothing returned."
43 <SETG NO-DATUM <CHTYPE (FLUSHED FLUSHED) DATUM>>
45 <NEWTYPE ADDRESS:C LIST>
47 <DEFINE ADDRESS:C ("TUPLE" T) <CHTYPE (!.T) ADDRESS:C>>
49 <NEWTYPE ADDRESS:PAIR LIST>
51 <DEFINE ADDRESS:PAIR ("TUPLE" T) <CHTYPE (!.T) ADDRESS:PAIR>>
53 <NEWTYPE TYPED:ADDRESS LIST>
55 <DEFINE TYPED:ADDRESS (TYP ADR)
56 <CHTYPE (.TYP !<REFERENCE .ADR>) TYPED:ADDRESS>>
62 <OR <GASSIGNED? TDEFER!-OP> <SETG TDEFER!-OP <SQUOTA |TDEFER >>>
64 <OR <GASSIGNED? TTP!-OP> <SETG TTP!-OP <SQUOTA |TTP >>>
66 <OR <GASSIGNED? TTB!-OP> <SETG TTB!-OP <SQUOTA |TTB >>>
72 <DEFINE MAKE:TAG ("OPTIONAL" (STR "TAG") ATM)
73 #DECL ((STR) STRING (ATM) ATOM (TAG:COUNT) FIX)
74 <SET STR <STRING .STR <UNPARSE .TAG:COUNT>>>
75 <SET TAG:COUNT <+ .TAG:COUNT 1>>
77 <OR <LOOKUP .STR ,TMP:OBL> <INSERT .STR ,TMP:OBL>>>>
80 <DEFINE BRANCH:TAG (TAG) <EMIT <INSTRUCTION `JRST .TAG>>>
82 <DEFINE LABEL:TAG (TAG) <EMIT .TAG>>
85 #DECL ((LOCAL-TAGS) LIST)
88 #DECL ((LL) <LIST ATOM>)
89 <COND (<==? <1 .LL> .ATM> <MAPLEAVE T>)>>
92 <DEFINE UNIQUE:TAG (ATM DEF?)
93 #DECL ((ATM) ATOM (DEF?) <OR ATOM FALSE> (LOCAL-TAGS) LIST)
96 #DECL ((L) <LIST ATOM ATOM <OR FALSE ATOM>>)
97 <COND (<==? <1 .L> .ATM>
98 <COND (<AND .DEF? <3 .L>>
100 "MULTIPLY DEFINED TAG "
102 <AND .DEF? <PUT .L 3 T>>
107 ((.ATM <SET ATM <MAKE:TAG <PNAME .ATM>>> .DEF?)
111 <DEFINE CHECK-LOCAL-TAGS (L "AUX" (LOSERS ()))
112 #DECL ((L LOSERS) LIST)
115 #DECL ((LL) <LIST ATOM ATOM <OR ATOM FALSE>>)
116 <COND (<NOT <3 .LL>> <SET LOSERS (<1 .LL> !.LOSERS)>)>>
118 <COND (<NOT <EMPTY? .LOSERS>>
119 <MESSAGE ERROR " UNDEFINED LABEL (S) " .LOSERS>)>>
121 <DEFINE LABEL:OFF (TAG)
122 <COND (.GLUE <LABEL:TAG .TAG>)
127 '<ANDB 262143 <CHTYPE .HERE!-OP FIX>>>>>)>>
129 <DEFINE TRUE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC T <>>>
131 <DEFINE FALSE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC <> <>>>
133 <DEFINE D:B:TAG (TAG SRC DIR TYP "AUX" DT)
134 #DECL ((SRC) DATUM (DIR) <OR FALSE ATOM>)
136 <SET DT <ISTYPE? <TYPE-AND .TYP '<NOT FALSE>>>>
137 <OR <MEMQ .DT '![CHANNEL RSUBR ATOM!]>
138 <AND <MEMQ <TYPEPRIM .DT> '![UVECTOR VECTOR!]>
140 <COND (<TYPE? <SET DT <DATVAL .SRC>> AC>
141 <EMIT <INSTRUCTION <COND (.DIR `JUMPL ) (ELSE `JUMPGE )>
145 <EMIT <INSTRUCTION <COND (.DIR `SKIPGE ) (ELSE `SKIPL )>
149 <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .SRC>>>
150 <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
152 '<TYPE-CODE!-OP FALSE>>>
155 <DEFINE GEN:FALSE () <EMIT <INSTRUCTION `PUSHJ `P* |RTFALS >>>
157 <DEFINE SUBR:CALL (ADR ARG-NUMBER)
158 <EMIT <INSTRUCTION MCALL!-OP .ARG-NUMBER .ADR>>>
160 <DEFINE FUNCTION:VALUE ("OPTIONAL" (ALLOC <>) "AUX" (DAT <DATUM ,AC-A ,AC-B>))
162 <SGETREG <DATTYP .DAT> .DAT>
163 <SGETREG <DATVAL .DAT> .DAT>)>
166 <SETG TMP:OBL <MOBLIST <OR <LOOKUP "TMP" <ROOT>> <INSERT "TMP" <ROOT>>>>>
168 <DEFINE ADDR:TYPE (DAT "AUX" (TYP <DATTYP .DAT>))
169 #DECL ((DAT) <DATUM ANY ANY>)
172 <DEFINE ADDR:TYPE1 (ADR "AUX" TT)
173 <COND (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
174 (<TYPE? .ADR ATOM> (<TYPE:SYM .ADR>))
175 (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 0>)
176 (<TYPE? .ADR ADDRESS:C> .ADR)
177 (<TYPE? .ADR ADDRESS:PAIR> (<1 .ADR>))
179 <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
183 <TOACV <2 .ADR>> ;"FORCE INDEX INTO REG "
184 <COND (<AND <MEMQ <SET TT <3 .ADR>> <ALLTYPES>>
185 <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
186 (<GETUVT <DATVAL <2 .ADR>>>))
189 !<COND (<==? <LENGTH .ADR> 4> <4 .ADR>)
191 (<ADDRSYM <DATVAL <2 .ADR>>>)))>)>)>>
193 <DEFINE GETUVT (AC "OPTIONAL" (TOAC ,ACO) (NS <>) "AUX" TAC (P <ACPROT .AC>))
194 #DECL ((AC TAC TOAC) AC)
196 <EMIT <INSTRUCTION `HLRE
197 <ACSYM <SET TAC <GETREG <>>>>
199 <EMIT <INSTRUCTION `SUBM <ACSYM .AC> <ADDRSYM .TAC>>>
201 <EMIT <INSTRUCTION GETYP!-OP <ACSYM .TOAC> (<ADDRSYM .TAC>)>>
202 <OR .NS <EMIT <INSTRUCTION `HRLZS <ADDRSYM .TOAC>>>>
205 <DEFINE TYPE:SYM (NAME) <FORM TYPE-WORD!-OP .NAME>>
207 <DEFINE ADDR:VALUE (DAT "AUX" (VAL <DATVAL .DAT>))
208 #DECL ((DAT) <DATUM ANY ANY>)
211 <DEFINE ADDR:VALUE1 (ADR)
212 <COND (<TYPE? .ADR ADDRESS:C> (!.ADR 1))
213 (<TYPE? .ADR ADDRESS:PAIR> <REST .ADR>)
214 (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
215 (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 1>)
217 <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
219 (<+ <1 .ADR> 1> `(TB) ))
222 (!<COND (<==? <LENGTH .ADR> 4> <4 .ADR>) (ELSE (0))>
224 (<ADDRSYM <DATVAL <2 .ADR>>>)))>)
225 (ELSE <MESSAGE INCONSISTENCY "BAD ADDRESS "> ())>>
228 <DEFINE TEMP:ADDR (TM OFF "AUX" DAT)
229 #DECL ((DAT) <OR FALSE DATUM> (TM) TEMP (OFF) FIX (FCN) NODE)
230 <COND (<SET DAT <TMPAC .TM>>
231 <COND (<0? .OFF> <ADDR:TYPE1 <DATTYP .DAT>>)
232 (<1? .OFF> <ADDR:VALUE1 <DATVAL .DAT>>)
233 (<MESSAGE "INCONSISTENCY" "TEMPORARY OFFSET BAD">)>)
234 (<COND (<=? .AC-HACK '(STACK)>
235 (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
236 (<TMPNO .TM> !.TMPS)>
241 <COND (<=? .AC-HACK '(FUNNY-STACK)>
242 <* <TOTARGS .FCN> -2>)
243 (ELSE 0)> !.TMPS) .AC-HACK>)>)>>
245 <DEFINE STEMP:ADDR (TM "OPTIONAL" (OFF 0))
246 #DECL ((TM) TEMP (OFF) FIX (FCN) NODE)
247 <COND (<=? .AC-HACK '(STACK)>
248 (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
249 (<TMPNO .TM> !.TMPS)>
254 <COND (<=? .AC-HACK '(FUNNY-STACK)>
255 <* <TOTARGS .FCN> -2>)
256 (ELSE 0)> !.TMPS) .AC-HACK>)>>
258 "FIX:ADDR TAKES TWO ARGUMENTS. THESE ARE A NEGATIVE AND POSITIVE OFFSETS ON THE STACK
259 AND BUILDS A COMPOSITE OFFSET ELIMINATING DUPLICATION"
261 <DEFINE FIX:ADDR (NEGS OPOS
262 "AUX" (POS <LIST !.OPOS>) (NUM 0) (NPOS ()) (NNEGS ()) LN)
263 #DECL ((NEGS POS) LIST (NUM) FIX (NNEGS) LIST)
265 <FUNCTION (NEG1 "AUX" NEGX)
266 <COND (<TYPE? .NEG1 FIX> <SET NUM <- .NUM .NEG1>>)
267 (<AND <TYPE? .NEG1 FORM ATOM>
268 <SET NEGX <MEMBER .NEG1 .POS>>>
269 <SET LN <- <LENGTH .POS> <LENGTH .NEGX> -1>>
270 <SET POS <DEL .POS .LN>>)
271 (ELSE <SET NNEGS (.NEG1 !.NNEGS)>)>>
275 <COND (<TYPE? .NPOS1 FIX> <SET NUM <+ .NUM .NPOS1>>)
276 (<SET NPOS (.NPOS1 !.NPOS)>)>>
278 <COND (<NOT <EMPTY? .NNEGS>> (<FORM - .NUM !.NNEGS> !.NPOS))
279 (ELSE (.NUM !.NPOS))>>
282 #DECL ((IT) <LIST ANY> (NUM) FIX)
283 <COND (<==? .NUM 1> <REST .IT>)
284 (ELSE <PUTREST <REST .IT <- .NUM 2>> <REST .IT .NUM>> .IT)>>
286 <DEFINE REFERENCE:ADR (OBJECT "EXTRA" TTYPE)
287 <COND (<AND <==? <PRIMTYPE .OBJECT> WORD>
288 <SET TTYPE <FORM TYPE-WORD!-OP <TYPE .OBJECT>>>>
289 <ADDRESS:PAIR .TTYPE [.OBJECT]>)
290 (<AND <==? <PRIMTYPE .OBJECT> LIST> <EMPTY? .OBJECT>>
291 <ADDRESS:PAIR <FORM TYPE-WORD!-OP <TYPE .OBJECT>> '[0]>)
293 <ADDRESS:C <FORM MQUOTE!-OP <FORM QUOTE .OBJECT>> -1>)>>
295 <DEFINE REFERENCE (OBJ "AUX" ADR)
296 #DECL ((VALUE) <DATUM ANY ANY>)
297 <SET ADR <REFERENCE:ADR .OBJ>>
300 <DEFINE STACK:ARGUMENT (DAT "AUX" TEM)
301 #DECL ((DAT) <DATUM ANY ANY>)
302 <COND (<N==? .DAT ,NO-DATUM>
303 <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:TYPE .DAT>>>
304 <SET TEM <ADDR:VALUE .DAT>>
305 <EMIT <INSTRUCTION `PUSH
308 !<COND (<MEMQ '`(TP) .TEM> '(-1))>>>)>
311 <DEFINE STACK:ADR (ADR)
312 <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:TYPE1 .ADR>>>
313 <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:VALUE1 .ADR>>>
316 <DEFINE MOVE:ARG (FROM1 TO1
318 "AUX" TMP TT TO TAC T1 TMP1 T2 FROM (NOTYET <>) (NOTYET2 <>)
320 #DECL ((TMP FROM TO) <<PRIMTYPE LIST> ANY ANY> (TAC) AC (VAL) FIX)
323 (<TYPE? .TO1 ATOM> <AND <==? .TO1 FLUSHED> <RET-TMP-AC .FROM1>> FLUSHED)
324 (<==? .FROM1 ,NO-DATUM> <RETURN ,NO-DATUM>)
325 (<AND <SET FROM .FROM1> <SET TMP1 <ACS? <SET TO .TO1>>> <SET TMP .TMP1>>
326 <COND (<==? <SET TT <DATTYP .TMP>> ANY-AC>
327 <COND (<TYPE? <DATTYP .FROM> AC> <SET TT <DATTYP .FROM>>)
328 (ELSE <SET TT <GETREG <>>>)>
330 #DECL ((L) <LIST [REST AC]>)
331 <COND (<MEMQ .TT .TO>
334 <SET TT <GETREG <>>>)
336 <PUT .TMP ,DATTYP .TT>
340 <PUT .TT ,ACPROT <>>>
343 <AND <==? <SET T1 <DATVAL .TMP>> ANY-AC>
344 <COND (<TYPE? <DATVAL .FROM> AC>
345 <PUT .TMP ,DATVAL <SET T1 <DATVAL .FROM>>>)
347 <COND (<TYPE? .TT AC>
349 <SET T2 <ACPROT .TAC>>
350 <PUT .TAC ,ACPROT T>)>
351 <PUT .TMP ,DATVAL <SET T1 <GETREG <>>>>
352 <COND (<TYPE? .TT AC>
354 <PUT .TAC ,ACPROT .T2>)>)>>
355 <COND (<AND <TYPE? <DATTYP .FROM> AC>
356 <TYPE? <DATVAL .FROM> AC>
357 <==? .T1 <DATTYP .FROM>>
358 <OR <TYPE? .TT ATOM> <==? .TT <DATVAL .FROM>>>>
359 <EMIT <INSTRUCTION `EXCH <ACSYM .T1> <ADDRSYM <DATVAL .FROM>>>>
360 <SET LSEXCH <EXCH-ACL .T1 <SET T2 <DATVAL .FROM>> <ACLINK .T1>>>
361 <SET LSEXCH <EXCH-ACL .T2 .T1 <ACLINK .T2> .LSEXCH>>
363 <FUNCTION (S "AUX" (SNA <SINACS .S>))
364 <COND (<NOT <MEMQ .SNA .LSEXCH>>
365 <SET LSEXCH (.SNA !.LSEXCH)>
366 <EXCH-AC .T1 .T2 <SINACS .S>>)>>
367 <ACRESIDUE <DATVAL .FROM>>>)>
368 <AND <TYPE? .TT ATOM>
369 <TYPE? <DATTYP .FROM> AC>
370 <PUT .TMP ,DATTYP <SET TT <DATTYP .FROM>>>>
373 <COND (<==? .TAC <DATTYP .FROM>> <FIX-ACLINK .TAC .TO .FROM>)
374 (<NOT <AND <NOT .KEEP> <ACLINK .TAC> <ACMEMQ .TAC .FROM>>>
376 (ELSE <SET NOTYET T>)>>
379 <COND (<==? <DATVAL .FROM> .TAC> <FIX-ACLINK .TAC .TO .FROM>)
380 (<NOT <AND <NOT .KEEP>
383 <ACMEMQ .TAC .FROM>>>
385 (ELSE <SET NOTYET2 T>)>>
386 <COND (<OR .NOTYET .NOTYET2>
390 <MOVE:VALUE <DATVAL .FROM> .T1>
391 <MOVE:TYP <DATTYP .FROM> .TT>)
394 <MOVE:TYP <DATTYP .FROM> .TT>
395 <MOVE:VALUE <DATVAL .FROM> .T1>)>
396 <PUT .FROM ,DATTYP FIX>
397 <PUT .FROM ,DATVAL DONT-CARE>)
399 <MOVE:TYP <DATTYP .FROM> .TT>
400 <MOVE:VALUE <DATVAL .FROM> .T1>)>
402 #DECL ((L) <PRIMTYPE LIST>)
403 <AND <EMPTY? .L> <RETURN .TO>>
406 <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
407 <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>>>
408 <SET L <REST .L 2>>>)
409 (<SET TMP1 <ACS? .FROM>>
412 #DECL ((L) <PRIMTYPE LIST>)
413 <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
414 <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>
415 <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
417 <COND (<NOT <OR <TYPE? <DATTYP .TO> ATOM>
418 <AND <==? <LENGTH .TO> 2>
419 <=? <DATTYP .TO> <DATTYP .FROM>>>>>
420 <MOVE:TYP <DATTYP .FROM> ,ACO>
422 #DECL ((L) <PRIMTYPE LIST>)
423 <MOVE:TYP ,ACO <DATTYP .L>>
424 <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>
426 (<NOT <OR <TYPE? <DATVAL .TO> ATOM>
427 <AND <==? <LENGTH .TO> 2> <=? <DATVAL .TO> <DATVAL .FROM>>>>>
428 <COND (<AND <TYPE? <DATVAL .FROM> ADDRESS:PAIR>
429 <OR <==? <SET VAL <CHTYPE <1 <2 <DATVAL .FROM>>> FIX>> -1>
432 #DECL ((L) <PRIMTYPE LIST>)
433 <EMIT <INSTRUCTION <COND (<0? .VAL> `SETZM )
436 <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
438 <MOVE:VALUE <DATVAL .FROM> ,ACO>
440 #DECL ((L) <PRIMTYPE LIST>)
441 <MOVE:VALUE ,ACO <DATVAL .L>>
442 <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>)>)>
443 <COND (<TYPE? .TO1 DATUM>
445 <FUNCTION (X) <COND (<TYPE? .X AC> <PUT .X ,ACPROT <>>)>>
447 <COND (<AND <NOT .KEEP> <NOT <TYPE? .TO1 ATOM>>>
449 #DECL ((L) <PRIMTYPE LIST>)
450 <OR <MEMQ <1 .L> .TO> <RET-TMP-AC <1 .L> .FROM>>
451 <AND <EMPTY? <SET L <REST .L>>> <RETURN .TO>>>)
452 (<TYPE? .TO1 ATOM> .FROM1)
455 <DEFINE MOVE:TYP (ADDRF ADDRT "AUX" TT TAC)
457 <COND (<=? .ADDRF .ADDRT>)
461 <COND (<AND <TYPE? .ADDRF OFFPTR>
462 <MEMQ <SET TT <3 .ADDRF>> <ALLTYPES>>
463 <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
465 <GETUVT <DATVAL <2 .ADDRF>> .TAC>)
467 <EMIT <INSTRUCTION `MOVE
469 !<ADDR:TYPE1 .ADDRF>>>)>
470 <PUT .TAC ,ACPROT <>>)
474 <OR <TYPE? .ADDRT ATOM>
475 <EMIT <INSTRUCTION `MOVEM
477 !<ADDR:TYPE1 .ADDRT>>>>
478 <PUT .TAC ,ACPROT <>>)
479 (<NOT <TYPE? .ADDRT ATOM>>
480 <MOVE:TYP .ADDRF ,ACO>
481 <MOVE:TYP ,ACO .ADDRT>)>>
483 <DEFINE MOVE:VALUE (ADDRF ADDRT "AUX" TAC)
485 <COND (<=? .ADDRT .ADDRF>)
489 <IMCHK '(`MOVE `MOVEI `MOVNI `MOVSI )
492 <PUT .TAC ,ACPROT <>>)
496 <OR <TYPE? .ADDRT ATOM>
497 <EMIT <INSTRUCTION `MOVEM
499 !<ADDR:VALUE1 .ADDRT>>>>
500 <PUT .TAC ,ACPROT <>>)
501 (<NOT <TYPE? .ADDRT ATOM>>
502 <MOVE:VALUE .ADDRF ,ACO>
503 <MOVE:VALUE ,ACO .ADDRT>)>>
505 <DEFINE ACMEMQ (TAC DAT "AUX" (T1 <DATTYP .DAT>) (TT <DATVAL .DAT>))
506 #DECL ((TAC) AC (DAT) DATUM)
509 <AND <OR <ISTYPE? .T1> <==? .T1 .TT>>
512 <==? <DATVAL <2 .TT>> .TAC>>>>
514 <DEFINE EXCH-ACL (AC1 AC2 L "OPTIONAL" (LST ()))
515 #DECL ((AC1 AC2) AC (L) <LIST [REST DATUM]>)
519 <COND (<NOT <MEMQ .D .LST>>
520 <EXCH-AC .AC1 .AC2 .D>
521 <SET LST (.D !.LST)>)>>
525 <DEFINE EXCH-AC (AC1 AC2 D "AUX" TMP)
526 #DECL ((AC1 AC2) AC (D) DATUM)
527 <COND (<AND <==? .AC1 <DATTYP .D>> <==? .AC2 <DATVAL .D>>>
528 <PUT .D ,DATVAL .AC1>
529 <PUT .D ,DATTYP .AC2>)
530 (<SET TMP <MEMQ .AC1 .D>>
532 <PUT .AC2 ,ACLINK (.D !<ACLINK .AC2>)>
537 <COND (<N==? .DAT .D> <MAPRET .DAT>)
540 (<SET TMP <MEMQ .AC2 .D>>
542 <PUT .AC1 ,ACLINK (.D !<ACLINK .AC1>)>
547 <COND (<==? .DAT .D> <MAPRET>)
548 (ELSE <MAPRET .DAT>)>>
551 <DEFINE FIX-ACLINK (AC TO FROM "AUX" (L <MEMQ .FROM <ACLINK .AC>>))
552 #DECL ((AC) AC (L) <PRIMTYPE LIST>)
553 <COND (.L <PUT .L 1 .TO>)
554 (ELSE <PUT .AC ,ACLINK (.TO !<ACLINK .AC>)>)>>
557 #DECL ((DAT) <PRIMTYPE LIST>)
559 <AND <EMPTY? .DAT> <RETURN <>>>
560 <COND (<OR <TYPE? <DATVAL .DAT> AC> <==? <DATVAL .DAT> ANY-AC>>
562 (<AND <TYPE? <DATVAL .DAT> ATOM>
563 <OR <TYPE? <DATTYP .DAT> AC>
564 <==? <DATTYP .DAT> ANY-AC>>>
566 <SET DAT <REST .DAT 2>>>>
568 <DEFINE IMCHK (INS AC ISRC "OPTIONAL" (COM <>)
569 "AUX" SRC VAL (LN <LENGTH .INS>))
570 #DECL ((AC) <PRIMTYPE WORD> (VAL LN) FIX (INS) <LIST ANY ANY>
571 (SRC) <<PRIMTYPE LIST> ANY <VECTOR <PRIMTYPE WORD>>>)
572 <COND (<AND <TYPE? .ISRC ADDRESS:PAIR>
573 <NOT <EMPTY? <REST .ISRC>>>
574 <TYPE? <2 .ISRC> VECTOR>
576 <SET VAL <CHTYPE <1 <2 .SRC>> FIX>>
577 <COND (<AND <G=? .VAL 0>
579 <TYPE? <2 .INS> OPCODE!-OP>>
580 <EMIT <INSTRUCTION <2 .INS> .AC .VAL>>)
582 <N==? <CHTYPE .VAL WORD> #WORD *400000000000*>
583 <L? <ABS .VAL> 262144>
584 <TYPE? <3 .INS> OPCODE!-OP>>
585 ;"Was negative immediate ins supplied?"
586 <EMIT <INSTRUCTION <3 .INS> .AC <- <ABS .VAL> <COND (.COM 1)
589 <0? <CHTYPE <GETBITS .VAL <BITS 18>> FIX>>>
590 <EMIT <INSTRUCTION <4 .INS>
592 <CHTYPE <GETBITS .VAL <BITS 18 18>> FIX>>>)
594 <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .SRC>>>)>)
596 <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .ISRC>>>)>>
598 <DEFINE GROUP:INITIAL (NAME)
599 <EMIT <INSTRUCTION TITLE .NAME>>
600 <EMIT <INSTRUCTION DECLARE!-OP '("VALUE" ATOM)>>
601 <EMIT <INSTRUCTION `MOVE `A* <FORM MQUOTE!-OP .NAME> -1>>
602 <EMIT <INSTRUCTION `MOVE `B* <FORM MQUOTE!-OP .NAME>>>
603 <EMIT <INSTRUCTION `JRST |FINIS >>>
605 <DEFINE FUNCTION:INITIAL (NAME)
606 <AND .NAME <EMIT <INSTRUCTION TITLE .NAME <>>>>
607 <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>> ;"Initial declarations.">
609 <DEFINE SUB:INITIAL (NAME "AUX" DC)
610 #DECL ((DC) <FORM ATOM>)
611 <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
612 <SET RDCL <REST .DC>>>
614 <DEFINE INT:INITIAL (NAME) <SET RDCL <CHTYPE (0 0) IRSUBR>>>
616 <DEFINE SUB:INT:INITIAL (NAME "AUX" DC)
617 #DECL ((DC) <FORM ATOM>)
618 <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
619 <SET RDCL <REST .DC>>>
621 <DEFINE FCN:INT:INITIAL (NAME)
622 <EMIT <INSTRUCTION TITLE .NAME <>>>
623 <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>>>
625 <DEFINE INT:LOSER:INITIAL (NAME FCN
626 "AUX" (ACSTR <1 <ACS .FCN>>) (TR <TOTARGS .FCN>)
627 (RQ <REQARGS .FCN>) (INAME <NODE-NAME .FCN>) TG
629 #DECL ((FCN) NODE (TR RQ) FIX (INAME) UVECTOR)
630 <COND (<=? .ACSTR '(STACK)>
631 <COND (<EMPTY? <REST .INAME>>
632 <LABEL:TAG <1 .INAME>>
633 <EMIT '<`SUBM `M* `(P) >>
634 <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)
638 <FUNCTION (NN "AUX" (LAST <EMPTY? <REST .NN>>))
640 <EMIT <INSTRUCTION `MOVEI `A* .TR>>
641 <COND (.LAST <LABEL:TAG .TG>)
642 (ELSE <BRANCH:TAG .TG>)>
645 <EMIT '<`SUBM `M* `(P) >>
646 <EMIT <INSTRUCTION ACALL!-OP `A* .NAME>>)>)
648 <LABEL:TAG <1 .INAME>>
649 <EMIT '<`SUBM `M* `(P) >>
653 <RET-TMP-AC <STACK:ARGUMENT <DATUM <1 .L> <2 .L>>>>>
655 <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)>
656 <EMIT '<`JRST |MPOPJ >>
657 <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
658 <SET RDCL <REST .DC>>>
660 <DEFINE FCNSUB:FINAL (NOD) <EMIT <INSTRUCTION `JRST |FINIS >>>
662 <DEFINE FS:INT:FINAL (ACS)
663 <COND (<=? .ACS '(STACK)> <EMIT '<`JRST |MPOPJ >>)
664 (ELSE <EMIT '<`JRST |FMPOPJ >>)>>
666 <DEFINE INT:FINAL (NOD)
667 #DECL ((RDCL) <LIST ANY> (NOD) NODE)
668 <EMIT <INSTRUCTION `JRST |MPOPJ >>
673 <DEFINE ASSEM? (SRC-FLG "OPTIONAL" (BIN-FLG .BIN-FLG) "AUX" X (T <TIME>))
674 #DECL ((CODE:TOP) <LIST ANY>)
675 <COND (<AND <ASSIGNED? CSOURCE> .CSOURCE>
676 <PRT <REST .CODE:TOP>>)>
677 <PUTREST .CODE:TOP <SET X <CDUP <REST .CODE:TOP>>>>
679 <COND (.PEEP <PEEP .X !.X> <TERPRI>)>
681 <ASSEMBLE1!-CODING!-PACKAGE .X <1 .OBLIST> <> .SRC-FLG>)
685 <DEFINE BLOCK:INITIAL () T>
687 <DEFINE BLOCK:FINAL () T>
689 <DEFINE PROG:END () <EMIT <INSTRUCTION `JRST |FINIS >>>
691 <DEFINE UNBIND:FUNNY (N "TUPLE" Y)
693 <EMIT <INSTRUCTION `MOVEI
697 <COND (.AC-HACK 1) (ELSE 0)>
698 <COND (.AC-HACK '`(FRM) ) (ELSE '`(TB) )>>>
699 <EMIT <INSTRUCTION `PUSHJ `P* |SSPEC1 >>>>
701 <DEFINE UNBIND:LOCS (FROM TO "OPTIONAL" (FLG <>))
703 <AND <POP:LOCS .FROM .TO>
705 <EMIT <INSTRUCTION `PUSHJ `P* |SSPECS >>>)
707 <EMIT '<`MOVE `TP* `FRM>>
708 <EMIT '<`PUSHJ `P* |SSPECS>>)>>
710 <DEFINE POP:LOCS (FROM TO "AUX" (OTHERS ()) (AMNT 0) (PST 0) REG (PSTN 0) TEM)
711 #DECL ((FROM TO) LIST (AMNT PST PSTN) FIX (REG) AC)
712 <REPEAT ((FROM .FROM)) ;"First count known locals and # of slots."
714 <AND <==? .TO .FROM> <RETURN>>
715 <COND (<TYPE? <SET TEM <1 .FROM>> FIX> <SET AMNT <+ .AMNT .TEM>>)
716 (<==? .TEM PSLOT> <SET PSTN <+ .PSTN 1>>)
717 (<==? .TEM PSTACK> <SET PST <+ .PST 1>>)
718 (ELSE <SET OTHERS (.TEM !.OTHERS)>)>
719 <SET FROM <REST .FROM>>>
722 <OR <AND <0? .AMNT> <EMPTY? .OTHERS>>
723 <EMIT <INSTRUCTION DEALLOCATE (.AMNT !.OTHERS)>>>
725 <EMIT <INSTRUCTION `SUB `P* [<FORM .PSTN (.PSTN)>]>>>)
727 <SET REG <GETREG <>>>
729 (<AND <1? .PST> <0? .PSTN>>
730 <EMIT <INSTRUCTION `POP `P* <ADDRSYM .REG>>>)
732 <REPEAT ((OFFS 0) (FST T))
734 <COND (<==? <SET TEM <1 .FROM>> PSLOT> <SET OFFS <+ .OFFS 1>>)
737 <EMIT <INSTRUCTION `MOVEI
744 <EMIT <INSTRUCTION `ADDI
749 <AND <==? .TO <SET FROM <REST .FROM>>> <RETURN>>>
750 <EMIT <INSTRUCTION `SUB
752 [<FORM <SET PST <+ .PSTN .PST>> (.PST)>]>>)>
753 <EMIT <INSTRUCTION `ADDI
758 <EMIT <INSTRUCTION `HRLI <ACSYM .REG> (<ADDRSYM .REG>)>>
759 <EMIT <INSTRUCTION `SUB `TP* <ADDRSYM .REG>>>)>
760 <NOT <AND <0? .AMNT> <0? .PST>>>>
762 ;"This is machine dependant code associated with setting up argument TUPLEs."
764 <DEFINE COPY:ARGPNTR ()
765 <EMIT <INSTRUCTION `MOVE `C* `AB >>
766 <EMIT <INSTRUCTION `MOVEI `D* 0>> ;"D will count args pushed.">
768 <DEFINE BUMP:ARGPNTR ("OPTIONAL" (N 1))
771 <EMIT <INSTRUCTION `ADD `C* [<FORM .N (.N)>]>>
772 ;"Bump an AOBJN pointer">
774 <DEFINE BUMP:CNTR ("OPTIONAL" (N 1))
777 <EMIT <INSTRUCTION `ADDI `D* .N>>>
779 <DEFINE TEST:ARGPNTR (TAG) <EMIT <INSTRUCTION `JUMPGE `C* .TAG>>>
781 <DEFINE REFERENCE:ARGPNTR ()
782 #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
783 <DATUM #ADDRESS:C (`(C) ) #ADDRESS:C (`(C) )>>
785 <DEFINE TUPLE:FINAL ("AUX" (VAL <FUNCTION:VALUE T>))
786 #DECL ((VALUE) <DATUM AC AC>)
787 <EMIT <INSTRUCTION `PUSHJ `P* |MAKTUP >>
790 <DEFINE REFERENCE:STACK:ADR (N "OPTIONAL" (AC-HACK .AC-HACK))
791 <COND (.AC-HACK <ADDRESS:C 1 `(FRM) !.N>)
792 (ELES <ADDRESS:C `(TB) !.N>)>>
794 <DEFINE REFERENCE:STACK (N "AUX" (TT <REFERENCE:STACK:ADR .N>))
795 #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
798 ;"Machine dependant stuff for activations and environemnts"
800 <DEFINE SPEC:REFERENCE:STACK (AC-HACK ADDRESS
802 <REFERENCE:STACK:ADR .ADDRESS .AC-HACK>))
805 <DEFINE MAKE:ENV ("AUX" (VAL <FUNCTION:VALUE T>))
806 <EMIT <INSTRUCTION `PUSHJ `P* |MAKENV >>
809 <DEFINE ACT:INITIAL ()
810 <SET START:TAG <MAKE:TAG>>
812 <EMIT <INSTRUCTION `MOVEI `O* .START:TAG>>
813 <EMIT '<`SUB `O* `M >>
814 <EMIT '<`HRLI `O* TTP!-OP>>
815 <EMIT '<`PUSH `TP* `O* >>)
817 <EMIT <INSTRUCTION `PUSH `TP* [<FORM (TTP!-OP) .START:TAG>]>>)>
818 <EMIT <INSTRUCTION `PUSH `TP* [0]>>>
821 <EMIT <INSTRUCTION `MOVEM `TP* `(TB) 1>>
822 <LABEL:OFF .START:TAG>>
824 <DEFINE MAKE:ACT ("AUX" (VAL <FUNCTION:VALUE T>))
825 <EMIT <INSTRUCTION `PUSHJ `P* |MAKACT >>
828 <DEFINE BUILD:FRAME (PC)
829 <EMIT <INSTRUCTION `MOVEI `A* .PC>>
830 <AND .GLUE <EMIT '<`SUB `A* `M >>>
831 <EMIT <INSTRUCTION `PUSHJ `P* |BFRAME >>>
833 ;"Machine dependent segment hacking code."
835 <DEFINE SEGMENT:LIST (N FLG)
836 <OR .FLG <EMIT <INSTRUCTION `PUSH `P* [.N]>>>
837 <EMIT <INSTRUCTION `MOVEI `O* |SEGLST >>
838 <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>
839 <EMIT <INSTRUCTION `SUB `P* [<FORM 1 (1)>]>>>
841 <DEFINE SEGMENT:STACK (TAG FLG)
842 <OR .FLG <EMIT <INSTRUCTION `PUSH `P* [.TAG]>>>
843 <EMIT <INSTRUCTION `MOVEI `O* |SEGMNT >>
844 <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>>
846 <DEFINE SEGMENT:FINAL (SUBR)
847 <EMIT <INSTRUCTION `POP `P* `A >>
848 <EMIT <INSTRUCTION ACALL!-OP `A* .SUBR>>>
850 <DEFINE PCOUNTER (N) <EMIT <INSTRUCTION `PUSH `P* [.N]>>>
852 <DEFINE COUNTP () <EMIT <INSTRUCTION `AOS `(P) >>>
854 <DEFINE PUSH:BIND (ATM VAL DC)
855 <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>
856 <STACK:ARGUMENT .VAL>
857 <STACK:ADR <REFERENCE:ADR .DC>>>
859 <DEFINE PUSH:PAIR (VAL) <STACK:ARGUMENT .VAL>>
861 <DEFINE PUSH:ATB (ATM)
862 <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>>
864 <DEFINE STORE:BIND (SYM VAL)
865 <RET-TMP-AC <MOVE:ARG .VAL <FUNCTION:VALUE>>>
870 !<REFERENCE:STACK:ADR (<- <ADDR-SYM .SYM> 2> !.NTSLOTS)>>>
871 <EMIT <INSTRUCTION `MOVE
873 !<REFERENCE:ADR <NAME-SYM .SYM>>
875 <EMIT <INSTRUCTION `MOVE
877 !<REFERENCE:ADR <DECL-SYM .SYM>>
879 <EMIT <INSTRUCTION `PUSHJ `P* |IBIND >>>
881 <DEFINE STORE:PAIR (SYM VAL)
883 <REFERENCE:STACK (<ADDR-SYM .SYM> !.NTSLOTS)>>>
885 <DEFINE BIND:END () <EMIT <INSTRUCTION `PUSHJ `P* |SPECBN >>>
887 <DEFINE REFERENCE:UNBOUND ()
888 #DECL ((VALUE) <DATUM ATOM ADDRESS:PAIR>)
890 <ADDRESS:PAIR '<TYPE-WORD!-OP UNBOUND> '[-1]>>>
892 <DEFINE REFERENCE:ARG (NUMBER "AUX" TEM)
893 #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C> (NUMBER) FIX)
894 <SET TEM <ADDRESS:C `(AB) <* 2 <- .NUMBER 1>>>>
897 <DEFINE TEST:ARG (NUMBER TAG)
898 <EMIT <INSTRUCTION `CAMLE `AB* [<FORM (<+ 1 <* -2 .NUMBER>>)>]>>
899 <EMIT <INSTRUCTION `JRST .TAG>>>
901 <DEFINE SALLOC:SLOTS ("TUPLE" TSLOTS)
902 <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
904 <DEFINE ALLOC:SLOTS ("TUPLE" TSLOTS "AUX" (TOTARGS <+ <* <TOTARGS .FCN> 2> 2>))
905 <COND (<=? .AC-HACK '(FUNNY-STACK)>
906 <EMIT <INSTRUCTION `PUSH `TP* [<FORM (TTP!-MUDDLE) .TOTARGS>]>>
907 <EMIT <INSTRUCTION `PUSH `TP* `FRM >>
908 <EMIT <INSTRUCTION `MOVE `FRM* `TP >>)>
909 <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
911 <DEFINE FAST:VAL () <EMIT <INSTRUCTION `PUSHJ `P* |CILVAL >>>
913 <DEFINE FAST:SET () <EMIT <INSTRUCTION `PUSHJ `P* |CISET >>>
915 <DEFINE FAST:GVAL () <EMIT <INSTRUCTION `PUSHJ `P* |CIGVAL >>>
917 <DEFINE FAST:SETG () <EMIT <INSTRUCTION `PUSHJ `P* |CSETG >>>
919 ;"Special code for READ EOF hacks."
921 <DEFINE TIME:STACK ()
922 <EMIT <INSTRUCTION `HLRZ `O* `TB >>
923 <EMIT <INSTRUCTION `PUSH `P* `O* >>
924 <EMIT <INSTRUCTION `PUSH `TP* '<TYPE-WORD!-OP TIME>>>
925 <EMIT <INSTRUCTION `PUSH `TP* `O* >>>
927 <DEFINE TIME:CHECK ("AUX" BR)
928 <EMIT <INSTRUCTION GETYP!-OP `O* `A >>
929 <EMIT <INSTRUCTION `POP `P* `C >>
930 <EMIT <INSTRUCTION `CAIN `O* '<TYPE-CODE!-OP TIME>>>
931 <EMIT <INSTRUCTION `CAIE `B* '`(C) >>
932 <EMIT <INSTRUCTION `JRST <SET BR <MAKE:TAG>>>>