--- /dev/null
+<PACKAGE "COMCOD">
+
+<ENTRY MOVE:ARG ADDR:TYPE ADDR:VALUE MOVE:VALUE STEMP:ADDR MOVE:TYP EMIT
+ D:B:TAG SEGMENT:LIST TUPLE:FINAL STORE:BIND LOCAL-TAGS TEST:ARGPNTR
+ REFERENCE BRANCH:TAG PSLOT COPY:ARGPNTR BIND:END TIME:STACK
+ ACT:FINAL PUSH:BIND TIME:CHECK START:TAG ISTAG? FAST:GVAL
+ REFERENCE:ARGPNTR REFERENCE:ARG POP:LOCS SEGMENT:STACK PUSH:PAIR
+ MAKE:ENV LABEL:TAG FAST:SETG BUMP:CNTR MAKE:ACT REFERENCE:STACK
+ SPEC:REFERENCE:STACK ADDRESS:PAIR PCOUNTER STACK:ARGUMENT
+ SALLOC:SLOTS FAST:VAL GEN:FALSE SUBR:CALL STORE:PAIR FIX-ACLINK
+ BUMP:ARGPNTR COUNTP SEGMENT:FINAL TEST:ARG FUNCTION:VALUE
+ REFERENCE:UNBOUND ACT:INITIAL UNBIND:LOCS FIX:ADDR FAST:SET PUSH:ATB
+ UNIQUE:TAG ALLOC:SLOTS ADDR:TYPE1 PROG:END ADDR:VALUE1 FUNCTION:INITIAL
+ REFERENCE:ADR ALLOCATE:SLOTS GETUVT UNBIND:FUNNY LABEL:OFF IMCHK
+ CODE:PTR CODE:TOP BUILD:FRAME FRAMLN CHECK-LOCAL-TAGS GROUP:INITIAL
+ INT:LOSER:INITIAL INT:INITIAL SUB:INT:INITIAL FCN:INT:INITIAL
+ SUB:INITIAL FS:INT:INITIAL RDCL INT:FINAL FS:INT:FINAL FCNSUB:FINAL
+ ASSEM? TAG:COUNT>
+
+<USE "CACS" "COMPDEC" "NPRINT" "CODGEN" "PEEPH" "CODING" "CHKDCL" "CUP">
+
+<BLOCK (<ROOT>)>
+
+CSOURCE
+
+<ENDBLOCK>
+
+<BLOCK (!.OBLIST <GET PACKAGE OBLIST>)>
+
+
+
+"***** BEGINNING OF THE IMPLEMENTATION SECTION *****"
+
+<DEFINE EMIT (INSTR)
+ #DECL ((CODE:PTR) LIST)
+ <PUTREST .CODE:PTR (.INSTR)>
+ <SET CODE:PTR <REST .CODE:PTR>>>
+
+<SETG BIND-BEGIN [<FORM (<CHTYPE <TYPE-C ATOM> FIX>) -1>]>
+
+"Special datum meaning nothing returned."
+
+<SETG NO-DATUM <CHTYPE (FLUSHED FLUSHED) DATUM>>
+
+<NEWTYPE ADDRESS:C LIST>
+
+<DEFINE ADDRESS:C ("TUPLE" T) <CHTYPE (!.T) ADDRESS:C>>
+
+<NEWTYPE ADDRESS:PAIR LIST>
+
+<DEFINE ADDRESS:PAIR ("TUPLE" T) <CHTYPE (!.T) ADDRESS:PAIR>>
+
+<NEWTYPE TYPED:ADDRESS LIST>
+
+<DEFINE TYPED:ADDRESS (TYP ADR)
+ <CHTYPE (.TYP !<REFERENCE .ADR>) TYPED:ADDRESS>>
+
+<NEWTYPE IRSUBR LIST>
+
+;"FUNNY FUDGES "
+
+<OR <GASSIGNED? TDEFER!-OP> <SETG TDEFER!-OP <SQUOTA |TDEFER >>>
+
+<OR <GASSIGNED? TTP!-OP> <SETG TTP!-OP <SQUOTA |TTP >>>
+
+<OR <GASSIGNED? TTB!-OP> <SETG TTB!-OP <SQUOTA |TTB >>>
+
+<SETG FRAMACT 9>
+
+<SETG FRAMLN 7>
+
+<DEFINE MAKE:TAG ("OPTIONAL" (STR "TAG") ATM)
+ #DECL ((STR) STRING (ATM) ATOM (TAG:COUNT) FIX)
+ <SET STR <STRING .STR <UNPARSE .TAG:COUNT>>>
+ <SET TAG:COUNT <+ .TAG:COUNT 1>>
+ <GUNASSIGN <SET ATM
+ <OR <LOOKUP .STR ,TMP:OBL> <INSERT .STR ,TMP:OBL>>>>
+ .ATM>
+
+<DEFINE BRANCH:TAG (TAG) <EMIT <INSTRUCTION `JRST .TAG>>>
+
+<DEFINE LABEL:TAG (TAG) <EMIT .TAG>>
+
+<DEFINE ISTAG? (ATM)
+ #DECL ((LOCAL-TAGS) LIST)
+ <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST ATOM>)
+ <COND (<==? <1 .LL> .ATM> <MAPLEAVE T>)>>
+ .LOCAL-TAGS>>
+
+<DEFINE UNIQUE:TAG (ATM DEF?)
+ #DECL ((ATM) ATOM (DEF?) <OR ATOM FALSE> (LOCAL-TAGS) LIST)
+ <COND (<MAPF <>
+ <FUNCTION (L)
+ #DECL ((L) <LIST ATOM ATOM <OR FALSE ATOM>>)
+ <COND (<==? <1 .L> .ATM>
+ <COND (<AND .DEF? <3 .L>>
+ <MESSAGE ERROR
+ "MULTIPLY DEFINED TAG "
+ .ATM>)>
+ <AND .DEF? <PUT .L 3 T>>
+ <MAPLEAVE <2 .L>>)>>
+ .LOCAL-TAGS>)
+ (ELSE
+ <SET LOCAL-TAGS
+ ((.ATM <SET ATM <MAKE:TAG <PNAME .ATM>>> .DEF?)
+ !.LOCAL-TAGS)>
+ .ATM)>>
+
+<DEFINE CHECK-LOCAL-TAGS (L "AUX" (LOSERS ()))
+ #DECL ((L LOSERS) LIST)
+ <MAPF <>
+ <FUNCTION (LL)
+ #DECL ((LL) <LIST ATOM ATOM <OR ATOM FALSE>>)
+ <COND (<NOT <3 .LL>> <SET LOSERS (<1 .LL> !.LOSERS)>)>>
+ .L>
+ <COND (<NOT <EMPTY? .LOSERS>>
+ <MESSAGE ERROR " UNDEFINED LABEL (S) " .LOSERS>)>>
+
+<DEFINE LABEL:OFF (TAG)
+ <COND (.GLUE <LABEL:TAG .TAG>)
+ (<EMIT <INSTRUCTION
+ PSEUDO!-OP
+ <FORM SETG
+ .TAG
+ '<ANDB 262143 <CHTYPE .HERE!-OP FIX>>>>>)>>
+
+<DEFINE TRUE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC T <>>>
+
+<DEFINE FALSE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC <> <>>>
+
+<DEFINE D:B:TAG (TAG SRC DIR TYP "AUX" DT)
+ #DECL ((SRC) DATUM (DIR) <OR FALSE ATOM>)
+ <COND (<AND .TYP
+ <SET DT <ISTYPE? <TYPE-AND .TYP '<NOT FALSE>>>>
+ <OR <MEMQ .DT '![CHANNEL RSUBR ATOM!]>
+ <AND <MEMQ <TYPEPRIM .DT> '![UVECTOR VECTOR!]>
+ <G? <MINL .DT> 0>>>>
+ <COND (<TYPE? <SET DT <DATVAL .SRC>> AC>
+ <EMIT <INSTRUCTION <COND (.DIR `JUMPL ) (ELSE `JUMPGE )>
+ <ACSYM .DT>
+ .TAG>>)
+ (ELSE
+ <EMIT <INSTRUCTION <COND (.DIR `SKIPGE ) (ELSE `SKIPL )>
+ !<ADDR:VALUE .SRC>>>
+ <BRANCH:TAG .TAG>)>)
+ (ELSE
+ <EMIT <INSTRUCTION GETYP!-OP `O* !<ADDR:TYPE .SRC>>>
+ <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
+ `O*
+ '<TYPE-CODE!-OP FALSE>>>
+ <BRANCH:TAG .TAG>)>>
+
+<DEFINE GEN:FALSE () <EMIT <INSTRUCTION `PUSHJ `P* |RTFALS >>>
+
+<DEFINE SUBR:CALL (ADR ARG-NUMBER)
+ <EMIT <INSTRUCTION MCALL!-OP .ARG-NUMBER .ADR>>>
+
+<DEFINE FUNCTION:VALUE ("OPTIONAL" (ALLOC <>) "AUX" (DAT <DATUM ,AC-A ,AC-B>))
+ <COND (.ALLOC
+ <SGETREG <DATTYP .DAT> .DAT>
+ <SGETREG <DATVAL .DAT> .DAT>)>
+ .DAT>
+
+<SETG TMP:OBL <MOBLIST <OR <LOOKUP "TMP" <ROOT>> <INSERT "TMP" <ROOT>>>>>
+
+<DEFINE ADDR:TYPE (DAT "AUX" (TYP <DATTYP .DAT>))
+ #DECL ((DAT) <DATUM ANY ANY>)
+ <ADDR:TYPE1 .TYP>>
+
+<DEFINE ADDR:TYPE1 (ADR "AUX" TT)
+ <COND (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
+ (<TYPE? .ADR ATOM> (<TYPE:SYM .ADR>))
+ (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 0>)
+ (<TYPE? .ADR ADDRESS:C> .ADR)
+ (<TYPE? .ADR ADDRESS:PAIR> (<1 .ADR>))
+ (<TYPE? .ADR OFFPTR>
+ <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
+ `TB )>
+ (<1 .ADR> `(TB) ))
+ (ELSE
+ <TOACV <2 .ADR>> ;"FORCE INDEX INTO REG "
+ <COND (<AND <MEMQ <SET TT <3 .ADR>> <ALLTYPES>>
+ <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
+ (<GETUVT <DATVAL <2 .ADR>>>))
+ (ELSE
+ (<1 .ADR>
+ !<COND (<==? <LENGTH .ADR> 4> <4 .ADR>)
+ (ELSE (0))>
+ (<ADDRSYM <DATVAL <2 .ADR>>>)))>)>)>>
+
+<DEFINE GETUVT (AC "OPTIONAL" (TOAC ,ACO) (NS <>) "AUX" TAC (P <ACPROT .AC>))
+ #DECL ((AC TAC TOAC) AC)
+ <PUT .AC ,ACPROT T>
+ <EMIT <INSTRUCTION `HLRE
+ <ACSYM <SET TAC <GETREG <>>>>
+ <ADDRSYM .AC>>>
+ <EMIT <INSTRUCTION `SUBM <ACSYM .AC> <ADDRSYM .TAC>>>
+ <PUT .AC ,ACPROT .P>
+ <EMIT <INSTRUCTION GETYP!-OP <ACSYM .TOAC> (<ADDRSYM .TAC>)>>
+ <OR .NS <EMIT <INSTRUCTION `HRLZS <ADDRSYM .TOAC>>>>
+ <ADDRSYM .TOAC>>
+
+<DEFINE TYPE:SYM (NAME) <FORM TYPE-WORD!-OP .NAME>>
+
+<DEFINE ADDR:VALUE (DAT "AUX" (VAL <DATVAL .DAT>))
+ #DECL ((DAT) <DATUM ANY ANY>)
+ <ADDR:VALUE1 .VAL>>
+
+<DEFINE ADDR:VALUE1 (ADR)
+ <COND (<TYPE? .ADR ADDRESS:C> (!.ADR 1))
+ (<TYPE? .ADR ADDRESS:PAIR> <REST .ADR>)
+ (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
+ (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 1>)
+ (<TYPE? .ADR OFFPTR>
+ <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
+ `TB )>
+ (<+ <1 .ADR> 1> `(TB) ))
+ (ELSE
+ <TOACV <2 .ADR>>
+ (!<COND (<==? <LENGTH .ADR> 4> <4 .ADR>) (ELSE (0))>
+ <+ 1 <1 .ADR>>
+ (<ADDRSYM <DATVAL <2 .ADR>>>)))>)
+ (ELSE <MESSAGE INCONSISTENCY "BAD ADDRESS "> ())>>
+
+
+<DEFINE TEMP:ADDR (TM OFF "AUX" DAT)
+ #DECL ((DAT) <OR FALSE DATUM> (TM) TEMP (OFF) FIX (FCN) NODE)
+ <COND (<SET DAT <TMPAC .TM>>
+ <COND (<0? .OFF> <ADDR:TYPE1 <DATTYP .DAT>>)
+ (<1? .OFF> <ADDR:VALUE1 <DATVAL .DAT>>)
+ (<MESSAGE "INCONSISTENCY" "TEMPORARY OFFSET BAD">)>)
+ (<COND (<=? .AC-HACK '(STACK)>
+ (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
+ (<TMPNO .TM> !.TMPS)>
+ '`(TP) ))
+ (ELSE
+ <REFERENCE:STACK:ADR
+ (.OFF <TMPNO .TM>
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)> !.TMPS) .AC-HACK>)>)>>
+
+<DEFINE STEMP:ADDR (TM "OPTIONAL" (OFF 0))
+ #DECL ((TM) TEMP (OFF) FIX (FCN) NODE)
+ <COND (<=? .AC-HACK '(STACK)>
+ (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
+ (<TMPNO .TM> !.TMPS)>
+ '`(TP) ))
+ (ELSE
+ <REFERENCE:STACK:ADR
+ (.OFF <TMPNO .TM>
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <* <TOTARGS .FCN> -2>)
+ (ELSE 0)> !.TMPS) .AC-HACK>)>>
+
+"FIX:ADDR TAKES TWO ARGUMENTS. THESE ARE A NEGATIVE AND POSITIVE OFFSETS ON THE STACK
+ AND BUILDS A COMPOSITE OFFSET ELIMINATING DUPLICATION"
+
+<DEFINE FIX:ADDR (NEGS OPOS
+ "AUX" (POS <LIST !.OPOS>) (NUM 0) (NPOS ()) (NNEGS ()) LN)
+ #DECL ((NEGS POS) LIST (NUM) FIX (NNEGS) LIST)
+ <MAPF <>
+ <FUNCTION (NEG1 "AUX" NEGX)
+ <COND (<TYPE? .NEG1 FIX> <SET NUM <- .NUM .NEG1>>)
+ (<AND <TYPE? .NEG1 FORM ATOM>
+ <SET NEGX <MEMBER .NEG1 .POS>>>
+ <SET LN <- <LENGTH .POS> <LENGTH .NEGX> -1>>
+ <SET POS <DEL .POS .LN>>)
+ (ELSE <SET NNEGS (.NEG1 !.NNEGS)>)>>
+ .NEGS>
+ <MAPF <>
+ <FUNCTION (NPOS1)
+ <COND (<TYPE? .NPOS1 FIX> <SET NUM <+ .NUM .NPOS1>>)
+ (<SET NPOS (.NPOS1 !.NPOS)>)>>
+ .POS>
+ <COND (<NOT <EMPTY? .NNEGS>> (<FORM - .NUM !.NNEGS> !.NPOS))
+ (ELSE (.NUM !.NPOS))>>
+
+<DEFINE DEL (IT NUM)
+ #DECL ((IT) <LIST ANY> (NUM) FIX)
+ <COND (<==? .NUM 1> <REST .IT>)
+ (ELSE <PUTREST <REST .IT <- .NUM 2>> <REST .IT .NUM>> .IT)>>
+
+<DEFINE REFERENCE:ADR (OBJECT "EXTRA" TTYPE)
+ <COND (<AND <==? <PRIMTYPE .OBJECT> WORD>
+ <SET TTYPE <FORM TYPE-WORD!-OP <TYPE .OBJECT>>>>
+ <ADDRESS:PAIR .TTYPE [.OBJECT]>)
+ (<AND <==? <PRIMTYPE .OBJECT> LIST> <EMPTY? .OBJECT>>
+ <ADDRESS:PAIR <FORM TYPE-WORD!-OP <TYPE .OBJECT>> '[0]>)
+ (ELSE
+ <ADDRESS:C <FORM MQUOTE!-OP <FORM QUOTE .OBJECT>> -1>)>>
+
+<DEFINE REFERENCE (OBJ "AUX" ADR)
+ #DECL ((VALUE) <DATUM ANY ANY>)
+ <SET ADR <REFERENCE:ADR .OBJ>>
+ <DATUM .ADR .ADR>>
+
+<DEFINE STACK:ARGUMENT (DAT "AUX" TEM)
+ #DECL ((DAT) <DATUM ANY ANY>)
+ <COND (<N==? .DAT ,NO-DATUM>
+ <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:TYPE .DAT>>>
+ <SET TEM <ADDR:VALUE .DAT>>
+ <EMIT <INSTRUCTION `PUSH
+ `TP*
+ !.TEM
+ !<COND (<MEMQ '`(TP) .TEM> '(-1))>>>)>
+ .DAT>
+
+<DEFINE STACK:ADR (ADR)
+ <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:TYPE1 .ADR>>>
+ <EMIT <INSTRUCTION `PUSH `TP* !<ADDR:VALUE1 .ADR>>>
+ .ADR>
+
+<DEFINE MOVE:ARG (FROM1 TO1
+ "OPTIONAL" (KEEP <>)
+ "AUX" TMP TT TO TAC T1 TMP1 T2 FROM (NOTYET <>) (NOTYET2 <>)
+ VAL LSEXCH)
+ #DECL ((TMP FROM TO) <<PRIMTYPE LIST> ANY ANY> (TAC) AC (VAL) FIX)
+ <PROG ()
+ <COND
+ (<TYPE? .TO1 ATOM> <AND <==? .TO1 FLUSHED> <RET-TMP-AC .FROM1>> FLUSHED)
+ (<==? .FROM1 ,NO-DATUM> <RETURN ,NO-DATUM>)
+ (<AND <SET FROM .FROM1> <SET TMP1 <ACS? <SET TO .TO1>>> <SET TMP .TMP1>>
+ <COND (<==? <SET TT <DATTYP .TMP>> ANY-AC>
+ <COND (<TYPE? <DATTYP .FROM> AC> <SET TT <DATTYP .FROM>>)
+ (ELSE <SET TT <GETREG <>>>)>
+ <REPEAT ((L ()))
+ #DECL ((L) <LIST [REST AC]>)
+ <COND (<MEMQ .TT .TO>
+ <SET L (.TT !.L)>
+ <PUT .TT ,ACPROT T>
+ <SET TT <GETREG <>>>)
+ (ELSE
+ <PUT .TMP ,DATTYP .TT>
+ <MAPF <>
+ <FUNCTION (TT)
+ #DECL ((TT) AC)
+ <PUT .TT ,ACPROT <>>>
+ .L>
+ <RETURN>)>>)>
+ <AND <==? <SET T1 <DATVAL .TMP>> ANY-AC>
+ <COND (<TYPE? <DATVAL .FROM> AC>
+ <PUT .TMP ,DATVAL <SET T1 <DATVAL .FROM>>>)
+ (ELSE
+ <COND (<TYPE? .TT AC>
+ <SET TAC .TT>
+ <SET T2 <ACPROT .TAC>>
+ <PUT .TAC ,ACPROT T>)>
+ <PUT .TMP ,DATVAL <SET T1 <GETREG <>>>>
+ <COND (<TYPE? .TT AC>
+ <SET TAC .TT>
+ <PUT .TAC ,ACPROT .T2>)>)>>
+ <COND (<AND <TYPE? <DATTYP .FROM> AC>
+ <TYPE? <DATVAL .FROM> AC>
+ <==? .T1 <DATTYP .FROM>>
+ <OR <TYPE? .TT ATOM> <==? .TT <DATVAL .FROM>>>>
+ <EMIT <INSTRUCTION `EXCH <ACSYM .T1> <ADDRSYM <DATVAL .FROM>>>>
+ <SET LSEXCH <EXCH-ACL .T1 <SET T2 <DATVAL .FROM>> <ACLINK .T1>>>
+ <SET LSEXCH <EXCH-ACL .T2 .T1 <ACLINK .T2> .LSEXCH>>
+ <MAPF <>
+ <FUNCTION (S "AUX" (SNA <SINACS .S>))
+ <COND (<NOT <MEMQ .SNA .LSEXCH>>
+ <SET LSEXCH (.SNA !.LSEXCH)>
+ <EXCH-AC .T1 .T2 <SINACS .S>>)>>
+ <ACRESIDUE <DATVAL .FROM>>>)>
+ <AND <TYPE? .TT ATOM>
+ <TYPE? <DATTYP .FROM> AC>
+ <PUT .TMP ,DATTYP <SET TT <DATTYP .FROM>>>>
+ <AND <TYPE? .TT AC>
+ <SET TAC .TT>
+ <COND (<==? .TAC <DATTYP .FROM>> <FIX-ACLINK .TAC .TO .FROM>)
+ (<NOT <AND <NOT .KEEP> <ACLINK .TAC> <ACMEMQ .TAC .FROM>>>
+ <SGETREG .TAC .TO>)
+ (ELSE <SET NOTYET T>)>>
+ <AND <TYPE? .T1 AC>
+ <SET TAC .T1>
+ <COND (<==? <DATVAL .FROM> .TAC> <FIX-ACLINK .TAC .TO .FROM>)
+ (<NOT <AND <NOT .KEEP>
+ <NOT .NOTYET>
+ <ACLINK .TAC>
+ <ACMEMQ .TAC .FROM>>>
+ <SGETREG .TAC .TO>)
+ (ELSE <SET NOTYET2 T>)>>
+ <COND (<OR .NOTYET .NOTYET2>
+ <RET-TMP-AC .FROM>
+ <COND (.NOTYET
+ <SGETREG .TT .TO>
+ <MOVE:VALUE <DATVAL .FROM> .T1>
+ <MOVE:TYP <DATTYP .FROM> .TT>)
+ (ELSE
+ <SGETREG .T1 .TO>
+ <MOVE:TYP <DATTYP .FROM> .TT>
+ <MOVE:VALUE <DATVAL .FROM> .T1>)>
+ <PUT .FROM ,DATTYP FIX>
+ <PUT .FROM ,DATVAL DONT-CARE>)
+ (ELSE
+ <MOVE:TYP <DATTYP .FROM> .TT>
+ <MOVE:VALUE <DATVAL .FROM> .T1>)>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <AND <EMPTY? .L> <RETURN .TO>>
+ <OR <==? .TMP .L>
+ <PROG ()
+ <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
+ <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>>>
+ <SET L <REST .L 2>>>)
+ (<SET TMP1 <ACS? .FROM>>
+ <SET TMP .TMP1>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
+ <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
+ (ELSE
+ <COND (<NOT <OR <TYPE? <DATTYP .TO> ATOM>
+ <AND <==? <LENGTH .TO> 2>
+ <=? <DATTYP .TO> <DATTYP .FROM>>>>>
+ <MOVE:TYP <DATTYP .FROM> ,ACO>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <MOVE:TYP ,ACO <DATTYP .L>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>
+ <COND
+ (<NOT <OR <TYPE? <DATVAL .TO> ATOM>
+ <AND <==? <LENGTH .TO> 2> <=? <DATVAL .TO> <DATVAL .FROM>>>>>
+ <COND (<AND <TYPE? <DATVAL .FROM> ADDRESS:PAIR>
+ <OR <==? <SET VAL <CHTYPE <1 <2 <DATVAL .FROM>>> FIX>> -1>
+ <0? .VAL>>>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <EMIT <INSTRUCTION <COND (<0? .VAL> `SETZM )
+ (ELSE `SETOM )>
+ !<ADDR:VALUE .L>>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
+ (ELSE
+ <MOVE:VALUE <DATVAL .FROM> ,ACO>
+ <REPEAT ((L .TO))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <MOVE:VALUE ,ACO <DATVAL .L>>
+ <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>)>)>
+ <COND (<TYPE? .TO1 DATUM>
+ <MAPF <>
+ <FUNCTION (X) <COND (<TYPE? .X AC> <PUT .X ,ACPROT <>>)>>
+ .TO>)>
+ <COND (<AND <NOT .KEEP> <NOT <TYPE? .TO1 ATOM>>>
+ <REPEAT ((L .FROM))
+ #DECL ((L) <PRIMTYPE LIST>)
+ <OR <MEMQ <1 .L> .TO> <RET-TMP-AC <1 .L> .FROM>>
+ <AND <EMPTY? <SET L <REST .L>>> <RETURN .TO>>>)
+ (<TYPE? .TO1 ATOM> .FROM1)
+ (ELSE .TO1)>>>
+
+<DEFINE MOVE:TYP (ADDRF ADDRT "AUX" TT TAC)
+ #DECL ((TAC) AC)
+ <COND (<=? .ADDRF .ADDRT>)
+ (<TYPE? .ADDRT AC>
+ <SET TAC .ADDRT>
+ <PUT .TAC ,ACPROT T>
+ <COND (<AND <TYPE? .ADDRF OFFPTR>
+ <MEMQ <SET TT <3 .ADDRF>> <ALLTYPES>>
+ <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
+ <TOACV <2 .ADDRF>>
+ <GETUVT <DATVAL <2 .ADDRF>> .TAC>)
+ (ELSE
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .TAC>
+ !<ADDR:TYPE1 .ADDRF>>>)>
+ <PUT .TAC ,ACPROT <>>)
+ (<TYPE? .ADDRF AC>
+ <SET TAC .ADDRF>
+ <PUT .TAC ,ACPROT T>
+ <OR <TYPE? .ADDRT ATOM>
+ <EMIT <INSTRUCTION `MOVEM
+ <ACSYM .TAC>
+ !<ADDR:TYPE1 .ADDRT>>>>
+ <PUT .TAC ,ACPROT <>>)
+ (<NOT <TYPE? .ADDRT ATOM>>
+ <MOVE:TYP .ADDRF ,ACO>
+ <MOVE:TYP ,ACO .ADDRT>)>>
+
+<DEFINE MOVE:VALUE (ADDRF ADDRT "AUX" TAC)
+ #DECL ((TAC) AC)
+ <COND (<=? .ADDRT .ADDRF>)
+ (<TYPE? .ADDRT AC>
+ <SET TAC .ADDRT>
+ <PUT .TAC ,ACPROT T>
+ <IMCHK '(`MOVE `MOVEI `MOVNI `MOVSI )
+ <ACSYM .TAC>
+ .ADDRF>
+ <PUT .TAC ,ACPROT <>>)
+ (<TYPE? .ADDRF AC>
+ <SET TAC .ADDRF>
+ <PUT .TAC ,ACPROT T>
+ <OR <TYPE? .ADDRT ATOM>
+ <EMIT <INSTRUCTION `MOVEM
+ <ACSYM .TAC>
+ !<ADDR:VALUE1 .ADDRT>>>>
+ <PUT .TAC ,ACPROT <>>)
+ (<NOT <TYPE? .ADDRT ATOM>>
+ <MOVE:VALUE .ADDRF ,ACO>
+ <MOVE:VALUE ,ACO .ADDRT>)>>
+
+<DEFINE ACMEMQ (TAC DAT "AUX" (T1 <DATTYP .DAT>) (TT <DATVAL .DAT>))
+ #DECL ((TAC) AC (DAT) DATUM)
+ <OR <==? .T1 .TAC>
+ <==? .TT .TAC>
+ <AND <OR <ISTYPE? .T1> <==? .T1 .TT>>
+ <TYPE? .TT OFFPTR>
+ <TOACV <2 .TT>>
+ <==? <DATVAL <2 .TT>> .TAC>>>>
+
+<DEFINE EXCH-ACL (AC1 AC2 L "OPTIONAL" (LST ()))
+ #DECL ((AC1 AC2) AC (L) <LIST [REST DATUM]>)
+ <MAPF <>
+ <FUNCTION (D)
+ #DECL ((D) DATUM)
+ <COND (<NOT <MEMQ .D .LST>>
+ <EXCH-AC .AC1 .AC2 .D>
+ <SET LST (.D !.LST)>)>>
+ .L>
+ .LST>
+
+<DEFINE EXCH-AC (AC1 AC2 D "AUX" TMP)
+ #DECL ((AC1 AC2) AC (D) DATUM)
+ <COND (<AND <==? .AC1 <DATTYP .D>> <==? .AC2 <DATVAL .D>>>
+ <PUT .D ,DATVAL .AC1>
+ <PUT .D ,DATTYP .AC2>)
+ (<SET TMP <MEMQ .AC1 .D>>
+ <PUT .TMP 1 .AC2>
+ <PUT .AC2 ,ACLINK (.D !<ACLINK .AC2>)>
+ <PUT .AC1
+ ,ACLINK
+ <MAPF ,LIST
+ <FUNCTION (DAT)
+ <COND (<N==? .DAT .D> <MAPRET .DAT>)
+ (<MAPRET>)>>
+ <ACLINK .AC1>>>)
+ (<SET TMP <MEMQ .AC2 .D>>
+ <PUT .TMP 1 .AC1>
+ <PUT .AC1 ,ACLINK (.D !<ACLINK .AC1>)>
+ <PUT .AC2
+ ,ACLINK
+ <MAPF ,LIST
+ <FUNCTION (DAT)
+ <COND (<==? .DAT .D> <MAPRET>)
+ (ELSE <MAPRET .DAT>)>>
+ <ACLINK .AC2>>>)>>
+
+<DEFINE FIX-ACLINK (AC TO FROM "AUX" (L <MEMQ .FROM <ACLINK .AC>>))
+ #DECL ((AC) AC (L) <PRIMTYPE LIST>)
+ <COND (.L <PUT .L 1 .TO>)
+ (ELSE <PUT .AC ,ACLINK (.TO !<ACLINK .AC>)>)>>
+
+<DEFINE ACS? (DAT)
+ #DECL ((DAT) <PRIMTYPE LIST>)
+ <REPEAT ()
+ <AND <EMPTY? .DAT> <RETURN <>>>
+ <COND (<OR <TYPE? <DATVAL .DAT> AC> <==? <DATVAL .DAT> ANY-AC>>
+ <RETURN .DAT>)
+ (<AND <TYPE? <DATVAL .DAT> ATOM>
+ <OR <TYPE? <DATTYP .DAT> AC>
+ <==? <DATTYP .DAT> ANY-AC>>>
+ <RETURN .DAT>)>
+ <SET DAT <REST .DAT 2>>>>
+
+<DEFINE IMCHK (INS AC ISRC "OPTIONAL" (COM <>)
+ "AUX" SRC VAL (LN <LENGTH .INS>))
+ #DECL ((AC) <PRIMTYPE WORD> (VAL LN) FIX (INS) <LIST ANY ANY>
+ (SRC) <<PRIMTYPE LIST> ANY <VECTOR <PRIMTYPE WORD>>>)
+ <COND (<AND <TYPE? .ISRC ADDRESS:PAIR>
+ <NOT <EMPTY? <REST .ISRC>>>
+ <TYPE? <2 .ISRC> VECTOR>
+ <SET SRC .ISRC>>
+ <SET VAL <CHTYPE <1 <2 .SRC>> FIX>>
+ <COND (<AND <G=? .VAL 0>
+ <L? .VAL 262144>
+ <TYPE? <2 .INS> OPCODE!-OP>>
+ <EMIT <INSTRUCTION <2 .INS> .AC .VAL>>)
+ (<AND <G=? .LN 3>
+ <N==? <CHTYPE .VAL WORD> #WORD *400000000000*>
+ <L? <ABS .VAL> 262144>
+ <TYPE? <3 .INS> OPCODE!-OP>>
+ ;"Was negative immediate ins supplied?"
+ <EMIT <INSTRUCTION <3 .INS> .AC <- <ABS .VAL> <COND (.COM 1)
+ (0)>>>>)
+ (<AND <==? .LN 4>
+ <0? <CHTYPE <GETBITS .VAL <BITS 18>> FIX>>>
+ <EMIT <INSTRUCTION <4 .INS>
+ .AC
+ <CHTYPE <GETBITS .VAL <BITS 18 18>> FIX>>>)
+ (ELSE
+ <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .SRC>>>)>)
+ (ELSE
+ <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .ISRC>>>)>>
+
+<DEFINE GROUP:INITIAL (NAME)
+ <EMIT <INSTRUCTION TITLE .NAME>>
+ <EMIT <INSTRUCTION DECLARE!-OP '("VALUE" ATOM)>>
+ <EMIT <INSTRUCTION `MOVE `A* <FORM MQUOTE!-OP .NAME> -1>>
+ <EMIT <INSTRUCTION `MOVE `B* <FORM MQUOTE!-OP .NAME>>>
+ <EMIT <INSTRUCTION `JRST |FINIS >>>
+
+<DEFINE FUNCTION:INITIAL (NAME)
+ <AND .NAME <EMIT <INSTRUCTION TITLE .NAME <>>>>
+ <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>> ;"Initial declarations.">
+
+<DEFINE SUB:INITIAL (NAME "AUX" DC)
+ #DECL ((DC) <FORM ATOM>)
+ <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
+ <SET RDCL <REST .DC>>>
+
+<DEFINE INT:INITIAL (NAME) <SET RDCL <CHTYPE (0 0) IRSUBR>>>
+
+<DEFINE SUB:INT:INITIAL (NAME "AUX" DC)
+ #DECL ((DC) <FORM ATOM>)
+ <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
+ <SET RDCL <REST .DC>>>
+
+<DEFINE FCN:INT:INITIAL (NAME)
+ <EMIT <INSTRUCTION TITLE .NAME <>>>
+ <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>>>
+
+<DEFINE INT:LOSER:INITIAL (NAME FCN
+ "AUX" (ACSTR <1 <ACS .FCN>>) (TR <TOTARGS .FCN>)
+ (RQ <REQARGS .FCN>) (INAME <NODE-NAME .FCN>) TG
+ DC)
+ #DECL ((FCN) NODE (TR RQ) FIX (INAME) UVECTOR)
+ <COND (<=? .ACSTR '(STACK)>
+ <COND (<EMPTY? <REST .INAME>>
+ <LABEL:TAG <1 .INAME>>
+ <EMIT '<`SUBM `M* `(P) >>
+ <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)
+ (ELSE
+ <SET TG <MAKE:TAG>>
+ <MAPR <>
+ <FUNCTION (NN "AUX" (LAST <EMPTY? <REST .NN>>))
+ <LABEL:TAG <1 .NN>>
+ <EMIT <INSTRUCTION `MOVEI `A* .TR>>
+ <COND (.LAST <LABEL:TAG .TG>)
+ (ELSE <BRANCH:TAG .TG>)>
+ <SET TR <- .TR 1>>>
+ .INAME>
+ <EMIT '<`SUBM `M* `(P) >>
+ <EMIT <INSTRUCTION ACALL!-OP `A* .NAME>>)>)
+ (ELSE
+ <LABEL:TAG <1 .INAME>>
+ <EMIT '<`SUBM `M* `(P) >>
+ <MAPF <>
+ <FUNCTION (L)
+ #DECL ((L) LIST)
+ <RET-TMP-AC <STACK:ARGUMENT <DATUM <1 .L> <2 .L>>>>>
+ .ACSTR>
+ <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)>
+ <EMIT '<`JRST |MPOPJ >>
+ <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
+ <SET RDCL <REST .DC>>>
+
+<DEFINE FCNSUB:FINAL (NOD) <EMIT <INSTRUCTION `JRST |FINIS >>>
+
+<DEFINE FS:INT:FINAL (ACS)
+ <COND (<=? .ACS '(STACK)> <EMIT '<`JRST |MPOPJ >>)
+ (ELSE <EMIT '<`JRST |FMPOPJ >>)>>
+
+<DEFINE INT:FINAL (NOD)
+ #DECL ((RDCL) <LIST ANY> (NOD) NODE)
+ <EMIT <INSTRUCTION `JRST |MPOPJ >>
+ <PUT .RDCL 1 .NOD>
+ .RDCL>
+
+
+<DEFINE ASSEM? (SRC-FLG "OPTIONAL" (BIN-FLG .BIN-FLG) "AUX" X (T <TIME>))
+ #DECL ((CODE:TOP) <LIST ANY>)
+ <COND (<AND <ASSIGNED? CSOURCE> .CSOURCE>
+ <PRT <REST .CODE:TOP>>)>
+ <PUTREST .CODE:TOP <SET X <CDUP <REST .CODE:TOP>>>>
+ <EXP-MAC .CODE:TOP>
+ <COND (.PEEP <PEEP .X !.X> <TERPRI>)>
+ <COND (.BIN-FLG
+ <ASSEMBLE1!-CODING!-PACKAGE .X <1 .OBLIST> <> .SRC-FLG>)
+ (ELSE .X)>>
+
+
+<DEFINE BLOCK:INITIAL () T>
+
+<DEFINE BLOCK:FINAL () T>
+
+<DEFINE PROG:END () <EMIT <INSTRUCTION `JRST |FINIS >>>
+
+<DEFINE UNBIND:FUNNY (N "TUPLE" Y)
+ <AND .SPECD
+ <EMIT <INSTRUCTION `MOVEI
+ `E*
+ .N
+ !.Y
+ <COND (.AC-HACK 1) (ELSE 0)>
+ <COND (.AC-HACK '`(FRM) ) (ELSE '`(TB) )>>>
+ <EMIT <INSTRUCTION `PUSHJ `P* |SSPEC1 >>>>
+
+<DEFINE UNBIND:LOCS (FROM TO "OPTIONAL" (FLG <>))
+ <COND (<NOT .FLG>
+ <AND <POP:LOCS .FROM .TO>
+ .SPECD
+ <EMIT <INSTRUCTION `PUSHJ `P* |SSPECS >>>)
+ (.SPECD
+ <EMIT '<`MOVE `TP* `FRM>>
+ <EMIT '<`PUSHJ `P* |SSPECS>>)>>
+
+<DEFINE POP:LOCS (FROM TO "AUX" (OTHERS ()) (AMNT 0) (PST 0) REG (PSTN 0) TEM)
+ #DECL ((FROM TO) LIST (AMNT PST PSTN) FIX (REG) AC)
+ <REPEAT ((FROM .FROM)) ;"First count known locals and # of slots."
+ #DECL ((FROM) LIST)
+ <AND <==? .TO .FROM> <RETURN>>
+ <COND (<TYPE? <SET TEM <1 .FROM>> FIX> <SET AMNT <+ .AMNT .TEM>>)
+ (<==? .TEM PSLOT> <SET PSTN <+ .PSTN 1>>)
+ (<==? .TEM PSTACK> <SET PST <+ .PST 1>>)
+ (ELSE <SET OTHERS (.TEM !.OTHERS)>)>
+ <SET FROM <REST .FROM>>>
+ <COND
+ (<0? .PST>
+ <OR <AND <0? .AMNT> <EMPTY? .OTHERS>>
+ <EMIT <INSTRUCTION DEALLOCATE (.AMNT !.OTHERS)>>>
+ <OR <0? .PSTN>
+ <EMIT <INSTRUCTION `SUB `P* [<FORM .PSTN (.PSTN)>]>>>)
+ (ELSE
+ <SET REG <GETREG <>>>
+ <COND
+ (<AND <1? .PST> <0? .PSTN>>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .REG>>>)
+ (ELSE
+ <REPEAT ((OFFS 0) (FST T))
+ #DECL ((OFFS) FIX)
+ <COND (<==? <SET TEM <1 .FROM>> PSLOT> <SET OFFS <+ .OFFS 1>>)
+ (<==? .TEM PSTACK>
+ <COND (.FST
+ <EMIT <INSTRUCTION `MOVEI
+ <ACSYM .REG>
+ `@
+ <- .OFFS>
+ '`(P) >>
+ <SET FST <>>)
+ (ELSE
+ <EMIT <INSTRUCTION `ADDI
+ <ACSYM .REG>
+ `@
+ <- .OFFS>
+ '`(P) >>)>)>
+ <AND <==? .TO <SET FROM <REST .FROM>>> <RETURN>>>
+ <EMIT <INSTRUCTION `SUB
+ `P*
+ [<FORM <SET PST <+ .PSTN .PST>> (.PST)>]>>)>
+ <EMIT <INSTRUCTION `ADDI
+ <ACSYM .REG>
+ !.OTHERS
+ .AMNT
+ (<ADDRSYM .REG>)>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .REG> (<ADDRSYM .REG>)>>
+ <EMIT <INSTRUCTION `SUB `TP* <ADDRSYM .REG>>>)>
+ <NOT <AND <0? .AMNT> <0? .PST>>>>
+
+;"This is machine dependant code associated with setting up argument TUPLEs."
+
+<DEFINE COPY:ARGPNTR ()
+ <EMIT <INSTRUCTION `MOVE `C* `AB >>
+ <EMIT <INSTRUCTION `MOVEI `D* 0>> ;"D will count args pushed.">
+
+<DEFINE BUMP:ARGPNTR ("OPTIONAL" (N 1))
+ #DECL ((N) FIX)
+ <SET N <* .N 2>>
+ <EMIT <INSTRUCTION `ADD `C* [<FORM .N (.N)>]>>
+ ;"Bump an AOBJN pointer">
+
+<DEFINE BUMP:CNTR ("OPTIONAL" (N 1))
+ #DECL ((N) FIX)
+ <SET N <* .N 2>>
+ <EMIT <INSTRUCTION `ADDI `D* .N>>>
+
+<DEFINE TEST:ARGPNTR (TAG) <EMIT <INSTRUCTION `JUMPGE `C* .TAG>>>
+
+<DEFINE REFERENCE:ARGPNTR ()
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
+ <DATUM #ADDRESS:C (`(C) ) #ADDRESS:C (`(C) )>>
+
+<DEFINE TUPLE:FINAL ("AUX" (VAL <FUNCTION:VALUE T>))
+ #DECL ((VALUE) <DATUM AC AC>)
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKTUP >>
+ .VAL>
+
+<DEFINE REFERENCE:STACK:ADR (N "OPTIONAL" (AC-HACK .AC-HACK))
+ <COND (.AC-HACK <ADDRESS:C 1 `(FRM) !.N>)
+ (ELES <ADDRESS:C `(TB) !.N>)>>
+
+<DEFINE REFERENCE:STACK (N "AUX" (TT <REFERENCE:STACK:ADR .N>))
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
+ <DATUM .TT .TT>>
+
+;"Machine dependant stuff for activations and environemnts"
+
+<DEFINE SPEC:REFERENCE:STACK (AC-HACK ADDRESS
+ "AUX" (TT
+ <REFERENCE:STACK:ADR .ADDRESS .AC-HACK>))
+ <DATUM .TT .TT>>
+
+<DEFINE MAKE:ENV ("AUX" (VAL <FUNCTION:VALUE T>))
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKENV >>
+ .VAL>
+
+<DEFINE ACT:INITIAL ()
+ <SET START:TAG <MAKE:TAG>>
+ <COND (.GLUE
+ <EMIT <INSTRUCTION `MOVEI `O* .START:TAG>>
+ <EMIT '<`SUB `O* `M >>
+ <EMIT '<`HRLI `O* TTP!-OP>>
+ <EMIT '<`PUSH `TP* `O* >>)
+ (ELSE
+ <EMIT <INSTRUCTION `PUSH `TP* [<FORM (TTP!-OP) .START:TAG>]>>)>
+ <EMIT <INSTRUCTION `PUSH `TP* [0]>>>
+
+<DEFINE ACT:FINAL ()
+ <EMIT <INSTRUCTION `MOVEM `TP* `(TB) 1>>
+ <LABEL:OFF .START:TAG>>
+
+<DEFINE MAKE:ACT ("AUX" (VAL <FUNCTION:VALUE T>))
+ <EMIT <INSTRUCTION `PUSHJ `P* |MAKACT >>
+ .VAL>
+
+<DEFINE BUILD:FRAME (PC)
+ <EMIT <INSTRUCTION `MOVEI `A* .PC>>
+ <AND .GLUE <EMIT '<`SUB `A* `M >>>
+ <EMIT <INSTRUCTION `PUSHJ `P* |BFRAME >>>
+
+;"Machine dependent segment hacking code."
+
+<DEFINE SEGMENT:LIST (N FLG)
+ <OR .FLG <EMIT <INSTRUCTION `PUSH `P* [.N]>>>
+ <EMIT <INSTRUCTION `MOVEI `O* |SEGLST >>
+ <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>
+ <EMIT <INSTRUCTION `SUB `P* [<FORM 1 (1)>]>>>
+
+<DEFINE SEGMENT:STACK (TAG FLG)
+ <OR .FLG <EMIT <INSTRUCTION `PUSH `P* [.TAG]>>>
+ <EMIT <INSTRUCTION `MOVEI `O* |SEGMNT >>
+ <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>>
+
+<DEFINE SEGMENT:FINAL (SUBR)
+ <EMIT <INSTRUCTION `POP `P* `A >>
+ <EMIT <INSTRUCTION ACALL!-OP `A* .SUBR>>>
+
+<DEFINE PCOUNTER (N) <EMIT <INSTRUCTION `PUSH `P* [.N]>>>
+
+<DEFINE COUNTP () <EMIT <INSTRUCTION `AOS `(P) >>>
+
+<DEFINE PUSH:BIND (ATM VAL DC)
+ <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>
+ <STACK:ARGUMENT .VAL>
+ <STACK:ADR <REFERENCE:ADR .DC>>>
+
+<DEFINE PUSH:PAIR (VAL) <STACK:ARGUMENT .VAL>>
+
+<DEFINE PUSH:ATB (ATM)
+ <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>>
+
+<DEFINE STORE:BIND (SYM VAL)
+ <RET-TMP-AC <MOVE:ARG .VAL <FUNCTION:VALUE>>>
+ <REGSTO T>
+ <EMIT <INSTRUCTION
+ `MOVEI
+ `E*
+ !<REFERENCE:STACK:ADR (<- <ADDR-SYM .SYM> 2> !.NTSLOTS)>>>
+ <EMIT <INSTRUCTION `MOVE
+ `C*
+ !<REFERENCE:ADR <NAME-SYM .SYM>>
+ 1>>
+ <EMIT <INSTRUCTION `MOVE
+ `D*
+ !<REFERENCE:ADR <DECL-SYM .SYM>>
+ 1>>
+ <EMIT <INSTRUCTION `PUSHJ `P* |IBIND >>>
+
+<DEFINE STORE:PAIR (SYM VAL)
+ <MOVE:ARG .VAL
+ <REFERENCE:STACK (<ADDR-SYM .SYM> !.NTSLOTS)>>>
+
+<DEFINE BIND:END () <EMIT <INSTRUCTION `PUSHJ `P* |SPECBN >>>
+
+<DEFINE REFERENCE:UNBOUND ()
+ #DECL ((VALUE) <DATUM ATOM ADDRESS:PAIR>)
+ <DATUM UNBOUND
+ <ADDRESS:PAIR '<TYPE-WORD!-OP UNBOUND> '[-1]>>>
+
+<DEFINE REFERENCE:ARG (NUMBER "AUX" TEM)
+ #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C> (NUMBER) FIX)
+ <SET TEM <ADDRESS:C `(AB) <* 2 <- .NUMBER 1>>>>
+ <DATUM .TEM .TEM>>
+
+<DEFINE TEST:ARG (NUMBER TAG)
+ <EMIT <INSTRUCTION `CAMLE `AB* [<FORM (<+ 1 <* -2 .NUMBER>>)>]>>
+ <EMIT <INSTRUCTION `JRST .TAG>>>
+
+<DEFINE SALLOC:SLOTS ("TUPLE" TSLOTS)
+ <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
+
+<DEFINE ALLOC:SLOTS ("TUPLE" TSLOTS "AUX" (TOTARGS <+ <* <TOTARGS .FCN> 2> 2>))
+ <COND (<=? .AC-HACK '(FUNNY-STACK)>
+ <EMIT <INSTRUCTION `PUSH `TP* [<FORM (TTP!-MUDDLE) .TOTARGS>]>>
+ <EMIT <INSTRUCTION `PUSH `TP* `FRM >>
+ <EMIT <INSTRUCTION `MOVE `FRM* `TP >>)>
+ <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
+
+<DEFINE FAST:VAL () <EMIT <INSTRUCTION `PUSHJ `P* |CILVAL >>>
+
+<DEFINE FAST:SET () <EMIT <INSTRUCTION `PUSHJ `P* |CISET >>>
+
+<DEFINE FAST:GVAL () <EMIT <INSTRUCTION `PUSHJ `P* |CIGVAL >>>
+
+<DEFINE FAST:SETG () <EMIT <INSTRUCTION `PUSHJ `P* |CSETG >>>
+
+;"Special code for READ EOF hacks."
+
+<DEFINE TIME:STACK ()
+ <EMIT <INSTRUCTION `HLRZ `O* `TB >>
+ <EMIT <INSTRUCTION `PUSH `P* `O* >>
+ <EMIT <INSTRUCTION `PUSH `TP* '<TYPE-WORD!-OP TIME>>>
+ <EMIT <INSTRUCTION `PUSH `TP* `O* >>>
+
+<DEFINE TIME:CHECK ("AUX" BR)
+ <EMIT <INSTRUCTION GETYP!-OP `O* `A >>
+ <EMIT <INSTRUCTION `POP `P* `C >>
+ <EMIT <INSTRUCTION `CAIN `O* '<TYPE-CODE!-OP TIME>>>
+ <EMIT <INSTRUCTION `CAIE `B* '`(C) >>
+ <EMIT <INSTRUCTION `JRST <SET BR <MAKE:TAG>>>>
+ .BR>
+
+<ENDBLOCK>
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff