--- /dev/null
+<SETG HAS-RESULT <>>
+
+<DEFINE MIMOC (CODLIST "OPTIONAL" (NEW-MSUBR T) "AUX" STATUS ARGS
+ (CODPTR .CODLIST))
+ #DECL ((CODLIST) <LIST [REST <OR FORM ATOM>]> (RESET-ALL) BOOLEAN
+ (CODPTR) <SPECIAL LIST>)
+ <INIT-ALL-STUFF .NEW-MSUBR>
+ <SETG FLUSH-NEXT 0>
+ <REPEAT (NUM APL CODITEM PPTR OSTATUS (LABEL? <>)
+ (FROB? <>) (FIRST? T) (PROTECT? <>) TF)
+ <SET CODITEM <1 .CODPTR>>
+ <SET PPTR .CODPTR>
+ <SET CODPTR <REST .CODPTR>>
+ <AND <GASSIGNED? MAX-SPACE> ,MAX-SPACE <PUTREST .PPTR ()>>
+ <COND (<G? ,FLUSH-NEXT 0>
+ <SETG FLUSH-NEXT <- ,FLUSH-NEXT 1>>
+ <COND (<EMPTY? .CODPTR> <RETURN>) (<AGAIN>)>)>
+ <UNPROTECT-ACS>
+ <CLEAR-DEATH>
+ <COND (<GETPROP .CODITEM DONE>)
+ (<TYPE? .CODITEM FORM>
+ <COND (<OR <NOT <GASSIGNED? <1 .CODITEM>>>
+ <NOT <TYPE? <SET NUM ,<1 .CODITEM>> FIX>>>
+ <ERROR "UNKNOWN" .CODITEM>)>
+ <COND (<L? .NUM 0>
+ <SET PROTECT? T>
+ <SET NUM <- .NUM>>)
+ (T
+ <SET PROTECT? <>>)>
+ <SET APL <NTH ,OP-APPLY-VECTOR .NUM>>
+ <COND (<AND
+ <SET TF <OR <MEMQ + .CODITEM>
+ <MEMQ - .CODITEM>>>
+ <PROG ((OUTST ,OUTST-LABEL-TABLE)
+ (LAB <2 .TF>))
+ #DECL ((OUTST) VECTOR)
+ <MAPF <>
+ <FUNCTION (LREF) #DECL ((LREF) LABEL-REF)
+ <COND (<==? <LABEL-REF-NAME .LREF> .LAB>
+ <COND (<LABEL-REF-LOOP-LABEL .LREF>
+ <MAPLEAVE T>)
+ (<MAPLEAVE <>>)>)>>
+ .OUTST>>>)
+ (<SET-DEATH .CODPTR>)>
+ <COND (<==? .NUM ,BAD-OPERATION>
+ <ERROR "BAD OPERATION" MIMOC .CODITEM>)>
+ <COND (<AND <==? .NUM ,DEAD!-MIMOP> <NOT .LABEL?>>
+ <SET OSTATUS .STATUS>)
+ (<SET OSTATUS <>>)>
+ <COND (.FIRST?
+ <SET FIRST? <>>
+ <SET FROB? <>>)
+ (<NOT .FROB?>
+ <COND (<N==? <SET FROB? <FIRST-PROCESS .CODPTR>>
+ TEMP!-MIMOP>
+ <ILDB-LOOKAHEAD .CODPTR>)>)>
+ <COND (<MEMQ .NUM ,PASS-OPS>
+ <SET STATUS <APPLY .APL !<REST .CODITEM>>>)
+ (ELSE
+ <SET ARGS <PROCESS-ARGS <REST .CODITEM> .NUM
+ .PROTECT?>>
+ <SET STATUS <APPLY .APL !.ARGS>>)>
+ <COND (<OR <NOT .FROB?>
+ <==? <1 .CODITEM> MAKTUP!-MIMOP>
+ <==? <1 .CODITEM> OPT-DISPATCH!-MIMOP>>
+ <COND (<N==? <SET FROB? <FIRST-PROCESS .CODPTR>>
+ TEMP!-MIMOP>
+ <ILDB-LOOKAHEAD .CODPTR>)>)>
+ <COND (.OSTATUS <SET STATUS .OSTATUS> <SET OSTATUS <>>)
+ (<NOT .STATUS>
+ <SET STATUS NORMAL>)>
+ <SET LABEL? <>>)
+ (<TYPE? .CODITEM ATOM>
+ <SET LABEL? T>
+ <GEN-LABEL .CODITEM .STATUS>)
+ (<ERROR "BAD CODE ITEM" MIMOC>)>
+ <COND (<EMPTY? .CODPTR> <RETURN>)>>
+ <PUSH-TEMPS>
+ T>
+
+<DEFINE SET--DEATH (CODPTR "OPT" (REALLY-DEAD <>) "AUX" (N ,FLUSH-NEXT))
+ #DECL ((CODPTR) LIST (N) FIX)
+ <MAPF <>
+ <FCN
+ (CODITEM "AUX" VAR)
+ <COND
+ (<TYPE? .CODITEM FORM>
+ <COND (<AND <L? <SET N <- .N 1>> 0> <NOT <GETPROP .CODITEM DONE>>>
+ <COND (<==? <1 .CODITEM> DEAD!-MIMOP>
+ <MAPF <>
+ <FCN (ATM)
+ <COND (<TYPE? .ATM VARTBL>
+ <VARTBL-DEAD? .ATM T>
+ <COND (.REALLY-DEAD <DEAD-VAR .ATM>)>)>>
+ <REST .CODITEM>>)
+ (<MAPLEAVE>)>)>)
+ (<MAPLEAVE>)>>
+ .CODPTR>>
+
+<SETG ARGVEC <IVECTOR ,MAX-NUMBER-ARGS>>
+
+<DEFINE FIRST-PROCESS FP (L "AUX" VAL)
+ #DECL ((L) <LIST [REST <OR FORM ATOM>]>)
+ <SET VAL
+ <MAPF <>
+ <FUNCTION (X)
+ <COND
+ (<AND <TYPE? .X FORM>
+ <GASSIGNED? <1 .X>>>
+ <COND
+ (<NOT <MEMQ ,<1 .X> ,PASS-OPS>>
+ <REPEAT ((PTR <REST .X>) ITEM ARG TTYP)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND (<==? <SET ITEM <1 .PTR>> =>
+ <1 .PTR <CHTYPE .ITEM RES-IND>>
+ <SET PTR <REST .PTR>>
+ <SET ITEM <1 .PTR>>
+ <COND (<==? .ITEM STACK>)
+ (<SET ITEM <FIND-VAR .ITEM>> <1 .PTR .ITEM>)
+ (<ERROR "NOT A VARIABLE"
+ <1 .PTR>
+ PROCESS-ARGS>)>)
+ (<TYPE? .ITEM ATOM>
+ <COND (<SET ARG <FIND-VAR .ITEM>>
+ <VARTBL-DEAD? .ARG <>>
+ <1 .PTR .ARG>)>)
+ (<AND <TYPE? .ITEM FORM>
+ <==? <LENGTH .ITEM> 2>
+ <==? <1 .ITEM> TYPE>
+ <==? <1 .X> CHTYPE!-MIMOP>>
+ <COND (<SET ARG <FIND-VAR <2 .ITEM>>>
+ <1 .PTR <FORM TYPE .ARG>>
+ <VARTBL-DEAD? .ARG <>>)>)
+ (<AND <TYPE? .ITEM FORM>
+ <==? <LENGTH .ITEM> 2>
+ <OR <==? <SET TTYP <1 .ITEM>> QUOTE>
+ <==? .TTYP TYPE-CODE>>
+ <TYPE? <2 .ITEM> ATOM>>
+ <SET ITEM <2 .ITEM>>
+ <AND <==? .TTYP TYPE-CODE>
+ <SET TTYP <CHECK-MIMOP-TYPE .ITEM>>
+ <SET ITEM .TTYP>>
+ <1 .PTR .ITEM>)>
+ <SET PTR <REST .PTR>>>)
+ (<==? <1 .X> TEMP!-MIMOP>
+ <PROG ((FIRST-PROCESS? T))
+ #DECL ((FIRST-PROCESS?) <SPECIAL ATOM>)
+ <TEMP-PROCESS !<REST .X>>>
+ <MAPR <>
+ <FUNCTION (L "AUX" (X <1 .L>))
+ #DECL ((L) LIST)
+ <COND (<TYPE? .X LIST>
+ <COND (<TYPE? <1 .X> ADECL>
+ <1 .X <FIND-VAR <1 <1 .X>>>>)
+ (T
+ <1 .X <FIND-VAR <1 .X>>>)>)
+ (<TYPE? .X ADECL> <1 .L <FIND-VAR <1 .X>>>)
+ (T <1 .L <FIND-VAR .X>>)>>
+ <REST .X>>)
+ (<OR <==? <1 .X> MAKTUP!-MIMOP>
+ <==? <1 .X> OPT-DISPATCH!-MIMOP>>
+ <MAPLEAVE TEMP!-MIMOP>)>)>>
+ .L>>
+ .VAL>
+
+<DEFINE PROCESS-ARGS (LST NUM PROTECT? "AUX" (CNT 1) (ARGS ,ARGVEC) ARG TTYP DISP)
+ #DECL ((LST) LIST (NUM) FIX)
+ <SETG HAS-RESULT <>>
+ <REPEAT ((PTR .LST) ITEM)
+ <COND (<EMPTY? .PTR> <RETURN>)>
+ <COND (<TYPE? <SET ITEM <1 .PTR>> RES-IND>
+ <SET PTR <REST .PTR>>
+ <SET ITEM <1 .PTR>>
+ <COND (<==? .NUM ,CHANNEL-OP!-MIMOP>
+ <SETG HAS-RESULT .ITEM>
+ <SET PTR <REST .PTR>>
+ <AGAIN>)
+ (<==? .ITEM STACK>)
+ (<MEMQ .NUM ,DEAD-MIM-CODES>
+ <VARTBL-DEAD? .ITEM T>)>)
+ (<TYPE? .ITEM VARTBL>
+ <COND (.PROTECT? <PROTECT-VAL .ITEM>)>
+ <VARTBL-DEAD? .ITEM <>>)
+ (<AND <TYPE? .ITEM FORM>
+ <==? <LENGTH .ITEM> 2>
+ <==? <1 .ITEM> TYPE>
+ <==? .NUM ,CHTYPE!-MIMOP>>
+ <COND (.PROTECT? <PROTECT-VAL <2 .ITEM>>)>
+ <VARTBL-DEAD? <2 .ITEM> <>>)>
+ <COND (<G? .CNT <LENGTH .ARGS>>
+ <SETG ARGVEC <IVECTOR <+ <LENGTH .ARGS> 50>>>
+ <SET ARGS <SUBSTRUC .ARGS 0 <LENGTH .ARGS> ,ARGVEC>>)>
+ <PUT .ARGS .CNT .ITEM>
+ <SET CNT <+ .CNT 1>>
+ <SET PTR <REST .PTR>>>
+ <SET DISP <- <LENGTH .ARGS> <- .CNT 1>>>
+ <SUBSTRUC .ARGS 0 <- .CNT 1> <REST .ARGS .DISP>>>
+
+<GDECL (DEAD-MIM-CODES) <UVECTOR [REST FIX]>>
+
+<DEFINE INIT-ALL-STUFF (RESET-ALL)
+ #DECL ((RESET-ALL) BOOLEAN)
+ <SETG MAKTUP-FLAG <>>
+ <SETG ICALL-LEVEL 0>
+ <RESET-AC-STACK-MODEL>
+ <RESET-CODE>
+ <COND (.RESET-ALL
+ <RESET-FCODE>
+ <RESET-CONSTANTS>
+ <INIT-MVEC-STUFF>
+ <INIT-UNRESOLVED-CALLS>
+ <INIT-CALL-ENTRYS>)>
+ <INIT-LABEL-TABLE .RESET-ALL>
+ <RESET-CALL-TABLE>
+ <INIT-VAR-LIST>
+ <INIT-INTERNAL-ENTRYS>
+ <SETG TEMP-PATCH -1>
+ <RESET-FRAME-LABEL-TABLE>
+ <INIT-PATCH-TABLE>
+ <RESET-PUSH-LABEL-TABLE>
+ <RESET-MOVE-LABEL-TABLE>>
+
+<DEFINE FCN-PROCESS (NAME DCLS
+ "TUPLE" VARS
+ "AUX" (VARLST ()) (NVARLST ())
+ (LAB <MAKE-LABEL "FNAME">))
+ #DECL ((DCLS) LIST (VARS) <TUPLE [REST ATOM]>)
+ <SETG FUNCTION-DECL .DCLS>
+ <COND (<=? <1 .DCLS> "VALUE">
+ <SET DCLS <REST .DCLS 2>>)>
+ <SETG FUNCTION-NAME .NAME>
+ <SETG ICALL-LABELS ()>
+ <REPEAT (VAR VDCL TBL)
+ <COND (<EMPTY? .VARS> <RETURN>)>
+ <SET VAR <1 .VARS>>
+ <COND (<TYPE? <SET VDCL <1 .DCLS>> STRING>
+ <SET DCLS <REST .DCLS>>
+ <SET VDCL <1 .DCLS>>)>
+ <SET TBL <CREATE-VAR .VAR <>>>
+ <COND (<EMPTY? .VARLST>
+ <SET VARLST (.TBL)>
+ <SET NVARLST .VARLST>)
+ (ELSE
+ <PUTREST .NVARLST (.TBL)>
+ <SET NVARLST <REST .NVARLST>>)>
+ <INDICATE-VAR-DECL .TBL <ISTYPE? .VDCL>>
+ <SET VARS <REST .VARS>>
+ <SET DCLS <REST .DCLS>>>
+ <SETG ARGLIST-VARS .VARLST>
+ <EMIT-LABEL .LAB <>>
+ <ADD-INTERNAL-ENTRY -1 .LAB>
+ NORMAL>
+
+<DEFINE TEMP-PROCESS ("TUPLE" TEMPS
+ "AUX" ADL SLABEL
+ (NOT-YET?
+ <AND <ASSIGNED? FIRST-PROCESS?>
+ .FIRST-PROCESS?>))
+ #DECL ((TEMPS) <TUPLE [REST <OR VARTBL ATOM ADECL LIST>]>)
+ <COND (<NOT .NOT-YET?>
+ <SET SLABEL <MAKE-LABEL>>
+ <EMIT-LABEL .SLABEL <>>
+ <INDICATE-TEMP-PATCH <ADD-PATCH TEMPORARIES>>)>
+ <MAPF <>
+ <FCN (TMP "AUX" TBL TC)
+ <COND (<TYPE? .TMP VARTBL> <CREATE-VAR .TMP T .NOT-YET?>)
+ (<TYPE? .TMP ATOM> <CREATE-VAR .TMP T .NOT-YET?>)
+ (<TYPE? .TMP LIST>
+ <COND (<TYPE? <SET ADL <1 .TMP>> ADECL>
+ <SET TBL <CREATE-VAR <1 .ADL> T .NOT-YET?>>
+ <INDICATE-VAR-DECL .TBL <2 .ADL>>)
+ (ELSE <SET TBL <CREATE-VAR .ADL T .NOT-YET?>>)>
+ <COND (<NOT .NOT-YET?>
+ <COND (<AND <TYPE? <SET TC <2 .TMP>> FORM>
+ <==? <LENGTH .TC> 2>
+ <==? <1 .TC> QUOTE>
+ <TYPE? <2 .TC> ATOM>>
+ <SET TC <2 .TC>>)>
+ <INDICATE-VAR-INIT .TBL .TC>)>)
+ (<TYPE? .TMP ADECL>
+ <SET TBL <CREATE-VAR <1 .TMP> T .NOT-YET?>>
+ <INDICATE-VAR-DECL .TBL <2 .TMP>>)
+ (<ERROR "BAD TEMP STATEMENT" TEMP-PROCESS>)>>
+ .TEMPS>
+ NORMAL>
+
+<DEFINE ISTYPE? (DCL)
+ #DECL ((DCL) <OR ATOM FORM>)
+ <COND (<TYPE? .DCL ATOM> <AND <VALID-TYPE? .DCL> .DCL>)
+ (<AND <TYPE? <SET DCL <1 .DCL>> ATOM> <VALID-TYPE? .DCL>> .DCL)>>
+
+<DEFINE END-GEN () UNCONDITIONAL-BRANCH>
+
+<DEFINE UCBRANCH-GEN (DIR LABEL)
+ #DECL ((DIR LABEL) ATOM)
+ <GEN-BRANCH ,INST-BRB .LABEL UNCONDITIONAL-BRANCH>
+ UNCONDITIONAL-BRANCH>
+
+<DEFINE LOCATION-GEN (DIR LABEL RES "AUX" VAC)
+ #DECL ((DIR LABEL) ATOM (RES) VARTBL)
+ <PROTECT <SET VAC <GET-AC ANY-AC T>>>
+ <EMIT-MOVE-LABEL .LABEL <MA-REG .VAC>>
+ <DEST-DECL .VAC .RES FIX>
+ NORMAL>
+
+<DEFINE LOAD-VAR-APP (VAR
+ "OPTIONAL" (MUNG T) (DCL <VARTBL-DECL .VAR>) (USE? T))
+ #DECL ((VAR) VARTBL)
+ <COND (<OR <NOT .DCL> <STRUCTURED-TYPE? .DCL>>
+ <LOAD-VAR .VAR VALUE .MUNG PREF-VAL .DCL .USE?>)
+ (ELSE <LOAD-VAR .VAR VALUE .MUNG PREF-VAL .DCL .USE?>)>>
+
+<DEFINE PROCESS-DESTINATION-HINT (HINT DEST "AUX" DCL)
+ #DECL ((HINT) <OR FALSE HINT ATOM> (DEST) <OR ATOM VARTBL>)
+ <COND (<AND <TYPE? .DEST VARTBL>
+ <COND (<TYPE? .HINT LIST>
+ <SET DCL <PARSE-HINT .HINT TYPE>>)
+ (<TYPE? .HINT ATOM> <SET DCL .HINT>)>>
+ <INDICATE-VAR-TEMP-DECL .DEST .DCL>)>>
+
+<DEFINE MOVE-TYPE (VAL TEADDR
+ "OPTIONAL" (CEADDR <>)
+ "AUX" DCL RADDR ADDR1 LVAR)
+ #DECL ((VAL) ANY (TEADDR) <OR AC EFF-ADDR> (CEADDR) <OR FALSE EFF-ADDR>)
+ <COND (<TYPE? .TEADDR AC> <SET RADDR <MA-REG .TEADDR>>)
+ (<SET RADDR .TEADDR>)>
+ <COND (<TYPE? .VAL VARTBL>
+ <COND (<OR <SAFE-TYPE-WORD? .VAL>
+ <AND <SET LVAR <FIND-CACHE-VAR .VAL>>
+ <OR <AND <NOT <LINKVAR-TYPE-AC .LVAR>>
+ <NOT <LINKVAR-TYPE-WORD-AC .LVAR>>
+ <NOT <LINKVAR-COUNT-AC .LVAR>>
+ <NOT <VARTBL-DECL .VAL>>>
+ <AND <LINKVAR-TYPE-STORED .LVAR>
+ <LINKVAR-COUNT-STORED .LVAR>>>>>
+ <EMIT-MOVE <VAR-TYPE-ADDRESS .VAL TYPE-WORD> .RADDR LONG>
+ <AND <TYPE? .TEADDR AC>
+ <LOAD-AC .TEADDR <VAR-TYPE-ADDRESS .VAL TYPE-WORD>>>)
+ (<SET DCL <VARTBL-DECL .VAL>>
+ <COND (<COUNT-NEEDED? .DCL>
+ <SET ADDR1 <VAR-COUNT-ADDRESS .VAL>>
+ <COND (<TYPE? .TEADDR AC>
+ <EMIT-MOVE <TYPE-WORD .DCL> .RADDR LONG>
+ <EMIT ,INST-BISW2 .ADDR1 <MA-REG .TEADDR>>
+ <USE-AC .TEADDR>)
+ (ELSE
+ <EMIT-MOVE .ADDR1 .CEADDR WORD>
+ <EMIT-MOVE <TYPE-CODE .DCL WORD>
+ .TEADDR
+ WORD>)>)
+ (ELSE
+ <EMIT-MOVE <TYPE-WORD .DCL> .RADDR LONG>
+ <AND <TYPE? .TEADDR AC>
+ <LOAD-AC .TEADDR <TYPE-WORD .DCL>>>)>)
+ (<ERROR "NO TYPE WORD" MOVE-TYPE>)>)
+ (<FIX-CONSTANT? .VAL>
+ <EMIT-MOVE <TYPE-WORD <TYPE .VAL>> .RADDR LONG>
+ <AND <TYPE? .TEADDR AC> <LOAD-AC .TEADDR <TYPE-WORD <TYPE .VAL>>>>)
+ (ELSE
+ <SET ADDR1 <ADDR-TYPE-M <ADD-MVEC .VAL>>>
+ <EMIT-MOVE .ADDR1 .TEADDR LONG>
+ <AND <TYPE? .TEADDR AC> <LOAD-AC .TEADDR .ADDR1>>)>>
+
+<DEFINE GEN-CONSTANT (RCNS VALUE-AC TYPE-AC GEN-PREF
+ "AUX" (CNS .RCNS) VAC TAC (TYP <TYPE .CNS>))
+ #DECL ((CNS) ANY (VALUE-AC TYPE-AC) <OR ATOM AC> (GEN-PREF) ATOM)
+ <PROTECT <SET VAC <GET-AC .VALUE-AC T>>>
+ <MOVE-VALUE .CNS .VAC>
+ <COND (<AND <N==? .GEN-PREF TYPE-WORD> <NOT <COUNT-NEEDED? .TYP>>>
+ <SETG CONSTANT-TYPE-AC <>>
+ <SETG CONSTANT-COUNT-AC <>>)
+ (ELSE
+ <SET TAC <GET-AC PREF-TYPE>>
+ <MUNG-AC .TAC>
+ <COND (<==? .GEN-PREF TYPE-WORD>
+ <COND (<SET CNS <FIX-CONSTANT? .CNS>>
+ <EMIT-MOVE <TYPE-WORD .TYP> <MA-REG .TAC> LONG>
+ <LOAD-AC .TAC <TYPE-WORD .TYP>>)
+ (ELSE
+ <EMIT-MOVE <ADDR-TYPE-MQUOTE .RCNS>
+ <MA-REG .TAC>
+ LONG>
+ <LOAD-AC .TAC <ADDR-TYPE-MQUOTE .RCNS>>)>
+ <SETG CONSTANT-TYPE-AC .TAC>)
+ (ELSE
+ <LOAD-CONSTANT .TAC <LENGTH .RCNS>>
+ <SETG CONSTANT-COUNT-AC .TAC>)>)>
+ .VAC>
+
+<DEFINE LOAD-CONSTANT (DEST RVAL "AUX" VAL ADDR)
+ #DECL ((AC) AC (VAL) FIX)
+ <COND (<TYPE? .DEST AC> <SET ADDR <MA-REG .DEST>>)
+ (ELSE <SET ADDR .DEST>)>
+ <SET VAL <FIX-CONSTANT? .RVAL>>
+ <COND (<0? .VAL> <EMIT ,INST-CLRL .ADDR>)
+ (<AND <G=? .VAL 1> <L=? .VAL 63>>
+ <EMIT ,INST-MOVL <MA-LIT .VAL> .ADDR>)
+ (<AND <G=? .VAL -63> <L=? .VAL -1>>
+ <EMIT ,INST-MNEGL <MA-LIT <- .VAL>> .ADDR>)
+ (<AND <G=? .VAL 64> <L=? .VAL 255>>
+ <EMIT ,INST-MOVZBL <MA-BYTE-IMM .VAL> .ADDR>)
+ (<AND <G=? .VAL -127> <L=? .VAL -64>>
+ <EMIT ,INST-CVTBL <MA-BYTE-IMM .VAL> .ADDR>)
+ (<AND <G=? .VAL 255> <L=? .VAL ,MAXP16C>>
+ <EMIT ,INST-MOVZWL <MA-WORD-IMM .VAL> .ADDR>)
+ (<AND <G=? .VAL ,MIN16C> <L=? .VAL -128>>
+ <EMIT ,INST-CVTWL <MA-WORD-IMM .VAL> .ADDR>)
+ (<TYPE? .RVAL FLOAT>
+ <COND (<G=? .RVAL 0.0>
+ <EMIT ,INST-MOVF <FLOAT-IMM .VAL> .ADDR>)
+ (ELSE
+ <EMIT ,INST-MNEGF <FLOAT-IMM <FLOATCONVERT <- .RVAL>>>
+ .ADDR>)>)
+ (ELSE <EMIT ,INST-MOVL <MA-LONG-IMM .VAL> .ADDR>)>>
+
+<DEFINE DEST-DECL (AC DEST DCL "OPTIONAL" (STATUS? <>))
+ #DECL ((AC) AC (DEST) <OR ATOM VARTBL> (DCL) ATOM
+ (STATUS?) <OR FALSE ATOM>)
+ <COND (<==? .DEST STACK> <PUSH-PAIR .DCL .AC> <CLEAR-STATUS>)
+ (<TYPE? .DEST VARTBL>
+ <DEAD-VAR .DEST>
+ <LINK-VAR-TO-AC .DEST .AC VALUE <>>
+ <INDICATE-CACHED-VARIABLE-DECL .DEST .DCL>
+ <COND (.STATUS?
+ <SET-STATUS-AC .AC>
+ <SET-STATUS-VAR .DEST .STATUS?>)>)>>
+
+<DEFINE DEST-COUNT-DECL (VAC CAC DEST DCL "OPTIONAL" (STATUS? <>))
+ #DECL ((VAC CAC) AC (DEST) <OR ATOM VARTBL> (DCL) ATOM
+ (STATUS?) <OR FALSE ATOM>)
+ <COND (<==? .DEST STACK>
+ <PUSH-PAIR-WITH-CNT .DCL .VAC .CAC>
+ <CLEAR-STATUS>)
+ (<TYPE? .DEST VARTBL>
+ <DEAD-VAR .DEST>
+ <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
+ <INDICATE-CACHED-VARIABLE-DECL .DEST .DCL>
+ <LINK-VAR-TO-AC .DEST .CAC COUNT <>>
+ <COND (.STATUS?
+ <SET-STATUS-AC .VAC>
+ <SET-STATUS-VAR .DEST .STATUS?>)>)>>
+
+<DEFINE DEST-PAIR (VAC CAC DEST "OPTIONAL" (STATUS? <>))
+ #DECL ((CAC VAC) AC (DEST) <OR ATOM VARTBL> (STATUS?) <OR FALSE ATOM>)
+ <COND (<==? .DEST STACK>
+ <AND ,GC-MODE
+ <EMIT ,INST-BICW2
+ <MA-IMM ,SHORT-TYPE-MASK>
+ <MA-REG .CAC>>>
+ <COND (<==? <+ <AC-NUMBER .CAC> 1> <AC-NUMBER .VAC>>
+ <EMIT-PUSH <MA-REG .CAC> DOUBLE>)
+ (ELSE
+ <EMIT-PUSH <MA-REG .CAC> LONG>
+ <EMIT-PUSH <MA-REG .VAC> LONG>)>
+ <CLEAR-STATUS>)
+ (<TYPE? .DEST VARTBL>
+ <DEAD-VAR .DEST>
+ <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
+ <LINK-VAR-TO-AC .DEST .CAC TYPE-WORD <>>
+ <COND (.STATUS?
+ <SET-STATUS-AC .VAC>
+ <SET-STATUS-VAR .DEST VALUE>)>)>>
+
+<DEFINE DEST-TYPE-VALUE (VAC TAC DEST "OPTIONAL" (STATUS? <>) LVAR)
+ #DECL ((VAC TAC) AC (DEST) <OR ATOM VARTBL> (STATUS?) <OR FALSE ATOM>
+ (LVAR) LINKVAR)
+ <COND (<==? .DEST STACK>
+ <EMIT-PUSH <MA-REG .TAC> WORD>
+ <CLEAR-PUSH WORD>
+ <EMIT-PUSH <MA-REG .VAC> LONG>
+ <CLEAR-STATUS>)
+ (<TYPE? .DEST VARTBL>
+ <DEAD-VAR .DEST>
+ <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
+ <LINK-VAR-TO-AC .DEST .TAC TYPE <>>
+ <SET LVAR <FIND-CACHE-VAR .DEST>>
+ <PUT .LVAR ,LINKVAR-COUNT-STORED T>
+ <COND (.STATUS?
+ <SET-STATUS-AC .VAC>
+ <SET-STATUS-VAR .DEST VALUE>)>)>>
+
+<DEFINE PUSH-PAIR (TYP VAC)
+ #DECL ((TYP) ATOM (VAC) AC)
+ <EMIT-PUSH <TYPE-WORD .TYP> LONG>
+ <EMIT-PUSH <MA-REG .VAC> LONG>>
+
+<DEFINE PUSH-PAIR-WITH-CNT (DCL VAC DAC)
+ #DECL ((VAC DAC) AC (DCL) ATOM)
+ <EMIT-PUSH <TYPE-CODE .DCL> WORD>
+ <EMIT-PUSH <MA-REG .DAC> WORD>
+ <EMIT-PUSH <MA-REG .VAC> LONG>>
+
+<DEFINE PUSH-GEN (VAL)
+ #DECL ((VAL) ANY)
+ <COND (<TYPE? .VAL VARTBL> <PUSH-VAR .VAL>) (<PUSH-CONSTANT .VAL>)>
+ NORMAL>
+
+<DEFINE POP-GEN (RES "AUX" VAC TAC)
+ #DECL ((RES) VARTBL)
+ <SET TAC <GET-AC DOUBLE>>
+ <EMIT-POP .TAC DOUBLE>
+ <DEST-PAIR <NEXT-AC .TAC> .TAC .RES>>
+
+<DEFINE INIT-OPERATIONS ()
+ <SETG OP-APPLY-VECTOR <IVECTOR ,MAX-NUMBER-OPS ,BAD-OPERATION>>
+ <SETG OP-COUNT 1>
+ <SETG MIMOP-OBLIST <MOBLIST MIMOP 51>>
+ <SETG VAR-OBLIST <MOBLIST VARS 51>>>
+
+<DEFINE DEFINE-MIMOP (NAME FCN "OPT" (PROTECT? <>) "AUX" (CNT ,OP-COUNT) ANAME)
+ #DECL ((NAME) STRING)
+ <COND (<G? .CNT ,MAX-NUMBER-OPS>
+ <ERROR "TOO MANY OPERATIONS" DEFINE-MIMOP>)>
+ <PUT ,OP-APPLY-VECTOR .CNT .FCN>
+ <SET ANAME
+ <OR <LOOKUP .NAME ,MIMOP-OBLIST> <INSERT .NAME ,MIMOP-OBLIST>>>
+ <SETG .ANAME <COND (.PROTECT? <- .CNT>)
+ (.CNT)>>
+ <SETG OP-COUNT <+ .CNT 1>>>
+
+<DEFINE STRUCTURED-TYPE? (DCL)
+ #DECL ((DCL) ATOM)
+ <COND (<ISTYPE? .DCL>
+ <MEMQ <TYPEPRIM .DCL>
+ '[OFFSET RECORD UVECTOR STRING LIST VECTOR ATOM]>)
+ (T)>>
+
+<DEFINE COUNT-NEEDED? (DCL)
+ #DECL ((DCL) ATOM)
+ <SET DCL <CLEAN-DECL .DCL>>
+ <AND <ISTYPE? .DCL>
+ <MEMQ <TYPEPRIM .DCL>
+ '[OFFSET STRING VECTOR RECORD UVECTOR TUPLE BYTES]>>>
+
+<DEFINE PARSE-HINT (HINT NAME "AUX" HTYP VAL)
+ #DECL ((HINT) HINT (NAME) ATOM)
+ <COND (<AND <TYPE? <SET HTYP <1 .HINT>> FORM>
+ <==? <LENGTH .HTYP> 2>
+ <==? <1 .HTYP> QUOTE>>
+ <SET HTYP <2 .HTYP>>)>
+ <COND (<==? .HTYP .NAME>
+ <COND (<AND <==? .HTYP TYPE>
+ <NOT <VALID-TYPE? <2 .HINT>>>
+ <SET VAL <CHECK-MIMOP-TYPE <2 .HINT>>>>
+ .VAL)
+ (<2 .HINT>)>)>>
+
+<DEFINE ADD-TO-AC (VAC VADDR)
+ #DECL ((VAC) AC (VADDR) EFF-ADDR)
+ <EMIT ,INST-ADDL2 .VADDR <MA-REG .VAC>>>
+
+<DEFINE SUB-FROM-AC (VAC VADDR)
+ #DECL ((VAC) AC (VADDR) EFF-ADDR)
+ <EMIT ,INST-SUBL2 .VADDR <MA-REG .VAC>>>
+
+<DEFINE MOVE-VALUE (VAL EADDR "AUX" FX? ADDR1)
+ #DECL ((VAL) ANY (EADDR) <OR AC EFF-ADDR>)
+ <COND (<TYPE? .VAL VARTBL>
+ <SET ADDR1 <VAR-VALUE-ADDRESS .VAL>>
+ <COND (<TYPE? .EADDR AC>
+ <EMIT-MOVE .ADDR1 <MA-REG .EADDR> LONG>
+ <LOAD-AC .EADDR .ADDR1>)
+ (<EMIT-MOVE .ADDR1 .EADDR LONG>)>)
+ (<FIX-CONSTANT? .VAL> <LOAD-CONSTANT .EADDR .VAL>)
+ (ELSE
+ <SET ADDR1 <ADDR-VALUE-MQUOTE .VAL>>
+ <COND (<TYPE? .EADDR AC>
+ <EMIT-MOVE .ADDR1 <MA-REG .EADDR> LONG>
+ <LOAD-AC .EADDR .ADDR1>)
+ (<EMIT-MOVE .ADDR1 .EADDR LONG>)>)>>
+
+
+
+<DEFINE ADD-CONSTANT-TO-AC (VAL DEST
+ "AUX" SDATA (ACADDR <MA-REG .DEST>) SZ DADDR)
+ #DECL ((VAL) FIX (DEST) AC)
+ <SET VAL <FIX-CONSTANT? .VAL>>
+ <COND (<0? .VAL>)
+ (<==? .VAL 1> <EMIT ,INST-INCL .ACADDR>)
+ (<==? .VAL -1> <EMIT ,INST-DECL .ACADDR>)
+ (<AND <G=? .VAL 0> <L=? .VAL 63>>
+ <EMIT ,INST-ADDL2 <MA-LIT .VAL> .ACADDR>)
+ (<AND <G=? .VAL -63> <L=? .VAL 0>>
+ <EMIT ,INST-SUBL2 <MA-LIT <- .VAL>> .ACADDR>)
+ (ELSE <EMIT ,INST-ADDL2 <MA-LONG-IMM .VAL> .ACADDR>)>>
+
+<DEFINE CLEAN-DECL (DCL "AUX" (NAME <SPNAME .DCL>) (SNAME .NAME))
+ #DECL ((DCL) ATOM)
+ <COND (<AND <G? <LENGTH .NAME> 2>
+ <==? <2 .NAME> !\$>
+ <==? <1 .NAME> !\T>
+ <SET NAME <LOOKUP <REST .NAME 2> <ROOT>>>
+ <OR <ISTYPE? .NAME> <MEMQ .NAME '[LBIND GBIND]>>>
+ .NAME)
+ (<ISTYPE? .DCL> .DCL)
+ (<LOOKUP .SNAME <ROOT>>)
+ (.DCL)>>
+
+<DEFINE CHECK-MIMOP-TYPE (ITEM)
+ #DECL ((ITEM) ATOM)
+ <COND (<AND <==? <OBLIST? .ITEM> ,MIMOP-OBLIST>
+ <NOT <VALID-TYPE? .ITEM>>
+ <SET ITEM <LOOKUP <SPNAME .ITEM> <ROOT>>>
+ <VALID-TYPE? .ITEM>>
+ .ITEM)>>
+
+<DEFINE PRINT-MSUBR (BYTEOFF "OPTIONAL" (OUTCHAN .OUTCHAN))
+ #DECL ((OUTCHAN) CHANNEL)
+ <COND (<NOT ,BOOT-MODE>
+ <PRINC "<SETG \1a" .OUTCHAN>
+ <PRIN1 ,FUNCTION-NAME .OUTCHAN>
+ <PRINC " " .OUTCHAN>)>
+ <PRINC "#MSUBR [" .OUTCHAN>
+ <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
+ <PRINC !\ .OUTCHAN>
+ <PRIN1 ,FUNCTION-NAME .OUTCHAN>
+ <PRINC !\ .OUTCHAN>
+ <PRIN1 ,FUNCTION-DECL .OUTCHAN>
+ <PRINC !\ .OUTCHAN>
+ <PRIN1 .BYTEOFF .OUTCHAN>
+ <PRINC !\] .OUTCHAN>
+ <OR ,BOOT-MODE <PRINC ">" .OUTCHAN>>
+ <CRLF .OUTCHAN>>
+
+<MSETG INFINITY <CHTYPE <MIN> FIX>>
+
+<DEFINE PRINT-IMSUBR ("OPTIONAL" (OUTCHAN .OUTCHAN) "AUX" (LLEN
+ <M-HLEN .OUTCHAN>))
+ #DECL ((OUTCHAN) CHANNEL)
+ <CRLF .OUTCHAN>
+ <COND (<NOT ,BOOT-MODE>
+ <PRINC "<SETG \1a" .OUTCHAN>
+ <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
+ <PRINC " " .OUTCHAN>)>
+ <PRINC "#IMSUBR [" .OUTCHAN>
+ <COND (,BOOT-MODE <PRINT-HEX-CODE .OUTCHAN>)
+ (ELSE <PRINT-NHEX-CODE .OUTCHAN>)>
+ <PRINC !\ .OUTCHAN>
+ <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
+ <PRINC !\ .OUTCHAN>
+ <PRINT-MVEC-ELEMENTS .OUTCHAN>
+ <PRINC !\] .OUTCHAN>
+ <OR ,BOOT-MODE <PRINC ">" .OUTCHAN>>
+ <CRLF .OUTCHAN>>
+
+<GDECL (MSUBR-BUF) STRING (MSUBR-PTR) FIX>
+<DEFINE PRINT-NHEX-CODE ("OPTIONAL" (OUTCHAN .OUTCHAN) (PTR 1)
+ (MAXPTR ,FBYTE-OFFSET)
+ (LEN </ <+ .MAXPTR 1> 4>))
+ #DECL ((OUTCHAN) CHANNEL (PTR MAXPTR) FIX)
+ <COND (<NOT <GASSIGNED? MSUBR-BUF>>
+ <SETG MSUBR-BUF <ISTRING 1024>>)
+ (<SETG MSUBR-BUF <TOP ,MSUBR-BUF>>)>
+ <SETG MSUBR-PTR 0>
+ <SETG MSUBR-CHAN .OUTCHAN>
+ <WRITE-BYTE !\|>
+ <PRINTBYTE </ .LEN 65536>>
+ <PRINTBYTE </ <MOD .LEN 65536> 256>>
+ <PRINTBYTE <MOD .LEN 256>>
+ <REPEAT (WD)
+ <COND (<L=? <+ .PTR 3> .MAXPTR>
+ <PRINTBYTE <NTH-FCODE <+ .PTR 3>>>)
+ (ELSE <PRINTBYTE 0>)>
+ <COND (<L=? <+ .PTR 2> .MAXPTR>
+ <PRINTBYTE <NTH-FCODE <+ .PTR 2>>>)
+ (ELSE <PRINTBYTE 0>)>
+ <COND (<L=? <+ .PTR 1> .MAXPTR>
+ <PRINTBYTE <NTH-FCODE <+ .PTR 1>>>)
+ (ELSE <PRINTBYTE 0>)>
+ <PRINTBYTE <NTH-FCODE .PTR>>
+ <COND (<G? <SET PTR <+ .PTR 4>> .MAXPTR> <RETURN>)>>
+ <WRITE-BYTE !\|>
+ <CHANNEL-OP .OUTCHAN WRITE-BUFFER <TOP ,MSUBR-BUF> ,MSUBR-PTR>>
+
+<DEFINE PRINTBYTE (NUM)
+ #DECL ((NUM) FIX)
+ <WRITE-BYTE <ASCII <+ <ASCII !\A> <CHTYPE <LSH .NUM -5> FIX>>>>
+ <WRITE-BYTE <ASCII <+ <ASCII !\A> <CHTYPE <ANDB .NUM 31> FIX>>>>>
+
+<DEFINE WRITE-BYTE (BYTE "AUX" (S ,MSUBR-BUF))
+ #DECL ((BYTE) CHARACTER (S) STRING)
+ <COND (<EMPTY? .S>
+ <SET S <TOP .S>>
+ <CHANNEL-OP ,MSUBR-CHAN WRITE-BUFFER .S ,MSUBR-PTR>
+ <SETG MSUBR-PTR 0>)>
+ <1 .S .BYTE>
+ <SETG MSUBR-BUF <REST .S>>
+ <SETG MSUBR-PTR <+ ,MSUBR-PTR 1>>>
projects / pdp10-muddle.git / blobdiff