--- /dev/null
+
+"CODE IS STORED IN A LIST OF UVECTORS. EACH INSTRUCTION IS A FIX. THE
+ INSTRUCTION CONTAINS THE INSTRUCTION BYTE (8 BITS) + INFORMATION TO FIX UP THE
+ INSTRUCTION. WHEN AN INSTRUCTION DOES NOT FIT INTO A SINGLE FIX IT IS
+ FOLLOWED BY ADDITIONAL FIXES. EVERY INSTRUCTION TAKES UP AN INTEGER NUMBER OF
+ FIXES EVEN THOUGH THE OUTPUT VERSION MAY BE DIFFERENT. THERE IS A TEMPORARY
+ FIXUP TABLE WHICH IS USED TO DETERMINE THE LOCATION OF THE TEMPORARIES AND
+ ALSO A LABEL FIXUP TABLE TO KEEP TRACK OF THE LABELS. THE SYSTEM ATTEMPTS
+ TO FIX UP LABELS IN PARTICULAR INTERVALS SO THAT IT DOESN'T HAVE TO KEEP
+ TRACK OF TOO MANY LABELS. ANY NON-LOOPING LABELS WILL BE FLUSHED AS SOON
+ AS THEY ARE FIXED UP. THERE IS ALSO A CONSTANT TABLE WHICH KEEPS TRACK OF
+ THE LOCATION OF ALL FULL-WORD CONSTANTS. THESE ARE FIXED UP LIKE LABELS. IN
+ GENERAL THE FIRST OCCURANCE OF A 32 BIT CONSTANT WILL BE OUTPUT AS AN
+ IMMEDIATE INSTRUCTION. ALL OTHER OCCURANCES WILL BE OUTPUT AS A REFERENCE
+ TO THAT CONSTANT IN PC-RELATIVE MODE (THIS WILL BE AN OPTION. WE MAY
+ EVENTUALLY GENERATE ALL CONSTANTS IMMEDIATE IF THAT PROVES TO GENERATE
+ FASTER RUNNING CODE"
+
+<DEFINE INIT-CODE ()
+ <SETG CURRENT-CODE <IUVECTOR ,CODEVEC-LENGTH 0>>
+ <SETG CODE-LIST (,CURRENT-CODE)>
+ <SETG CODE-COUNT 1>>
+
+<DEFINE RESET-CODE ()
+ <SETG CURRENT-CODE <1 ,CODE-LIST>>
+ <SETG CODE-COUNT 1>
+ <SETG SAVED-CODE-COUNT <>>
+ <SETG SAVED-CODE-STACK ()>>
+
+<DEFINE NTH-CODE (NUM "AUX" (CL ,CODE-LIST))
+ #DECL ((NUM) FIX (CL) <LIST [REST CODEVEC]>)
+ <REPEAT ((PTR .NUM))
+ <COND (<L=? .PTR ,CODEVEC-LENGTH> <RETURN <NTH <1 .CL> .PTR>>)>
+ <COND (<EMPTY? <SET CL <REST .CL>>>
+ <ERROR OUT-OF-BOUNDS .NUM NTH-CODE>)>
+ <SET PTR <- .PTR ,CODEVEC-LENGTH>>>>
+
+<DEFINE PUT-CODE (NUM VAL "AUX" (CL ,CODE-LIST))
+ #DECL ((NUM VAL) FIX (CL) <LIST [REST CODEVEC]>)
+ <REPEAT ((PTR .NUM))
+ <COND (<L=? .PTR ,CODEVEC-LENGTH>
+ <PUT <1 .CL> .PTR .VAL>
+ <RETURN>)>
+ <COND (<EMPTY? <SET CL <REST .CL>>>
+ <ERROR OUT-OF-BOUNDS .NUM>)>
+ <SET PTR <- .PTR ,CODEVEC-LENGTH>>>>
+
+<DEFINE ADD-WORD-TO-CODE (WD
+ "AUX" RLST (CCODE ,CURRENT-CODE)
+ (COUNT ,CODE-COUNT))
+ #DECL ((WD) FIX)
+ <COND (<EMPTY? .CCODE>
+ <SET RLST
+ <REST ,CODE-LIST <- </ <- .COUNT 1> ,CODEVEC-LENGTH> 1>>>
+ <COND (<1? <LENGTH .RLST>>
+ <SET CCODE <IUVECTOR ,CODEVEC-LENGTH 0>>
+ <PUTREST .RLST (.CCODE)>)
+ (ELSE <SET CCODE <2 .RLST>>)>)>
+ <PUT .CCODE 1 .WD>
+ <SETG CURRENT-CODE <REST .CCODE>>
+ <SETG CODE-COUNT <+ .COUNT 1>>>
+
+<DEFINE PRINT-SPEC-LABEL (X "AUX" (OUTCHAN .OUTCHAN))
+ #DECL ((X) SPEC-LABEL)
+ <PRINC "ITAG" .OUTCHAN>
+ <PRIN1 <CHTYPE .X FIX> .OUTCHAN>>
+
+<COND (<GASSIGNED? PRINT-SPEC-LABEL> <PRINTTYPE SPEC-LABEL ,PRINT-SPEC-LABEL>)>
+
+<DEFINE PRINT-LABEL-REF (LREF "AUX" (OUTCHAN .OUTCHAN))
+ #DECL ((LREF) LABEL-REF)
+ <PRINC "#LABEL-REF " .OUTCHAN>
+ <PRIN1 <LABEL-REF-NAME .LREF> .OUTCHAN>>
+
+<COND (<GASSIGNED? PRINT-LABEL-REF> <PRINTTYPE LABEL-REF ,PRINT-LABEL-REF>)>
+
+<DEFINE INIT-LABEL-TABLE (RESTART "AUX" TMP LAB)
+ <SETG LABEL-TABLE ()>
+ <SET LAB <CREATE-LABEL-REF \ >>
+ <SET TMP <IVECTOR ,MAX-OUTST-LABELS '.LAB>>
+ <SETG OUTST-LABEL-TABLE <REST .TMP <LENGTH .TMP>>>
+ <AND .RESTART <SETG CURRENT-SLABEL 0>>
+ <SETG PTNS-TABLE ()>
+ <SETG PTNS-COUNT 1>>
+
+<DEFINE MAKE-LABEL ("OPTIONAL" (ATM? <>) "AUX" STR
+ (NUM <COND (<NOT <GASSIGNED? CURRENT-SLABEL>> 0)
+ (,CURRENT-SLABEL)>))
+ <SET NUM <+ .NUM 1>>
+ <SETG CURRENT-SLABEL .NUM>
+ <COND (.ATM?
+ <COND (<NOT <TYPE? .ATM? STRING>> <SET ATM? "ITAG">)>
+ <SET STR <STRING .ATM? <UNPARSE .NUM>>>
+ <OR <LOOKUP .STR ,VAR-OBLIST> <INSERT .STR ,VAR-OBLIST>>)
+ (<CHTYPE .NUM SPEC-LABEL>)>>
+
+<DEFINE COPY-PSAVE (PSAVE NCODE "AUX" RES INST)
+ #DECL ((PSAVE) PTN-SAVE (NCODE) CODEVEC)
+ <SET RES
+ <CHTYPE <VECTOR .NCODE
+ <PTNS-VAR .PSAVE>
+ <PTNS-KIND .PSAVE>
+ <PTNS-USE .PSAVE>
+ ()>
+ PTN-SAVE>>
+ <PUT .PSAVE ,PTNS-SUBS (.RES !<PTNS-SUBS .PSAVE>)>
+ <SETG PTNS-TABLE (.RES !,PTNS-TABLE)>
+ <SET INST <PUT-RHW ,INST-PSTORE ,PTNS-COUNT>>
+ <SETG PTNS-COUNT <+ ,PTNS-COUNT 1>>
+ .INST>
+
+<DEFINE KILL-PSAVE (PSAVE)
+ #DECL ((PSAVE) PTN-SAVE)
+ <PUT .PSAVE ,PTNS-USE <>>
+ <MAPF <> <FCN (SPS) <PUT .SPS ,PTNS-USE <>>> <PTNS-SUBS .PSAVE>>>
+
+<DEFINE EMIT-POTENTIAL-STORE (CODE KIND LVAR "AUX" PTN)
+ #DECL ((CODE) CODEVEC (KIND) ATOM (LVAR) LINKVAR)
+ <SET PTN
+ <CHTYPE <VECTOR .CODE <LINKVAR-VAR .LVAR> .KIND T ()> PTN-SAVE>>
+ <SETG PTNS-TABLE (.PTN !,PTNS-TABLE)>
+ <ADD-WORD-TO-CODE <CHTYPE <ORB <LSH ,INST-PSTORE 24>
+ ,PTNS-COUNT>
+ FIX>>
+ <SETG PTNS-COUNT <+ ,PTNS-COUNT 1>>
+ <MAPF <>
+ <FCN (XREF "AUX" (CPSAVE <XREF-INFO-PSAVES .XREF>))
+ <PUT .XREF ,XREF-INFO-PSAVES (.PTN !.CPSAVE)>>
+ <LINKVAR-POTENTIAL-SAVES .LVAR>>>
+
+<DEFINE GET-PTNS (NUM) <NTH ,PTNS-TABLE <- ,PTNS-COUNT .NUM>>>
+
+<DEFINE SAVE-XREF-AC-INFO (XREF SSTATE SLSTATE)
+ #DECL ((XREF) XREF-INFO (SSTATE) AC-STATE (SLSTATE) SLOAD-STATE)
+ <PUT .XREF ,XREF-INFO-SAVED-AC-INFO .SSTATE>
+ <PUT .XREF ,XREF-INFO-SLSTATE .SLSTATE>>
+
+<DEFINE PRINT-XREF-INFO (XREF "AUX" (OUTCHAN .OUTCHAN))
+ #DECL ((XREF) XREF-INFO)
+ <PRINC "#XREF-INFO " .OUTCHAN>
+ <PRIN1 <LABEL-REF-NAME <XREF-INFO-LABEL .XREF>> .OUTCHAN>
+ <PRINC " " .OUTCHAN>
+ <PRIN1 <XREF-INFO-POINT .XREF> .OUTCHAN>>
+
+<COND (<GASSIGNED? PRINT-XREF-INFO> <PRINTTYPE XREF-INFO ,PRINT-XREF-INFO>)>
+
+"UPDATE THE LABEL TABLES FOR A BRANCH"
+
+<DEFINE UPDLT-BRANCH (LABEL CODEPTR STATUS? LILEN FORCEL?
+ "AUX" NLREF (OUTST ,OUTST-LABEL-TABLE) XREF)
+ #DECL ((LABEL) <OR ATOM SPEC-LABEL> (CODEPTR) FIX (FORCEL?) BOOLEAN)
+ <SET NLREF <GET-LREF .LABEL>>
+ <ADD-XREF .NLREF .CODEPTR .STATUS? .LILEN .FORCEL?>>
+
+<DEFINE GET-LREF GL (LABEL "OPTIONAL" (JUST-LOOKING? <>) "AUX" NLR)
+ #DECL ((LABEL) <OR ATOM SPEC-LABEL>)
+ <MAPF <>
+ <FUNCTION (LREF)
+ #DECL ((LREF) LABEL-REF)
+ <COND (<==? <LABEL-REF-NAME .LREF> .LABEL>
+ <COND (<NOT .JUST-LOOKING?>
+ <LABEL-REF-NOT-REAL .LREF <>>)>
+ <RETURN .LREF .GL>)>>
+ ,OUTST-LABEL-TABLE>
+ <SET NLR <CREATE-LABEL-REF .LABEL>>
+ <LABEL-REF-NOT-REAL .NLR .JUST-LOOKING?>
+ <ADD-OUTSTANDING-LABEL .NLR>
+ .NLR>
+
+<DEFINE CREATE-LABEL-REF (NAME)
+ #DECL ((NAME) <OR ATOM SPEC-LABEL>)
+ <CHTYPE [.NAME () -1 0 <> <> () () <>] LABEL-REF>>
+
+<DEFINE ADD-OUTSTANDING-LABEL (LREF "AUX" (OUTST ,OUTST-LABEL-TABLE) NOUTST)
+ #DECL ((LREF) LABEL-REF)
+ <COND (<==? .OUTST <TOP .OUTST>>
+ <SET NOUTST <VECGROW .OUTST ,MAX-OUTST-LABELS>>
+ <SET NOUTST <REST .NOUTST <- ,MAX-OUTST-LABELS 1>>>
+ <PUT .NOUTST 1 .LREF>
+ <SUBSTRUC .OUTST 0 <LENGTH .OUTST> <REST .NOUTST>>
+ <SETG OUTST-LABEL-TABLE .NOUTST>)
+ (ELSE
+ <SET OUTST <BACK .OUTST>>
+ <PUT .OUTST 1 .LREF>
+ <SETG OUTST-LABEL-TABLE .OUTST>)>>
+
+"FINDS AND REMOVES A LABEL FROM THE OUTSTANDING LABEL TABLE. THE LABEL WILL
+ NOT BE REMOVED IF IT IS A LOOP LABEL"
+
+<DEFINE REMOVE-OUTSTANDING-LABEL (LABEL "AUX" (OUTST ,OUTST-LABEL-TABLE))
+ #DECL ((LABEL) <OR SPEC-LABEL ATOM> (OUTST) <VECTOR [REST LABEL-REF]>
+ (VALUE) <OR FALSE LABEL-REF>)
+ <REPEAT ((PTR 1) LREF (LEN <LENGTH .OUTST>))
+ <COND (<G? .PTR .LEN> <RETURN <>>)>
+ <SET LREF <NTH .OUTST .PTR>>
+ <COND (<==? <LABEL-REF-NAME .LREF> .LABEL>
+ <COND (<OR <LABEL-REF-LOOP-LABEL .LREF>
+ <LABEL-REF-NOT-REAL .LREF>>
+ <RETURN .LREF>)
+ (<==? .PTR 1>
+ <SETG OUTST-LABEL-TABLE <REST .OUTST>>
+ <RETURN .LREF>)
+ (ELSE
+ <SUBSTRUC .OUTST 0 <- .PTR 1> <REST .OUTST>>
+ <SETG OUTST-LABEL-TABLE <REST .OUTST>>
+ <RETURN .LREF>)>)>
+ <SET PTR <+ .PTR 1>>>>
+
+"UPDATE LABEL TABLES WHEN ENCOUNTERING AN ACTUAL LABEL"
+
+<DEFINE UPDLT-LABEL (LABEL CODEPTR LOOP?
+ "AUX" LREF (LTAB ,LABEL-TABLE)
+ (TABPTR <+ <LENGTH .LTAB> 1>))
+ #DECL ((LABEL) <OR ATOM SPEC-LABEL> (CODEPTR) FIX
+ (LOOP?) <OR FALSE AC-STATE ATOM>)
+ <SET LREF <REMOVE-OUTSTANDING-LABEL .LABEL>>
+ <COND (<NOT .LREF>
+ <SET LREF <CREATE-LABEL-REF .LABEL>>
+ <ADD-OUTSTANDING-LABEL .LREF>)
+ (<LABEL-REF-NOT-REAL .LREF <>>)>
+ <PUT .LREF ,LABEL-REF-CODE-PTR .CODEPTR>
+ <PUT .LREF ,LABEL-REF-LOOP-LABEL .LOOP?>
+ <COND (<EMPTY? .LTAB> <SETG LABEL-TABLE (.LREF)>)
+ (<PUTREST <REST .LTAB <- <LENGTH .LTAB> 1>> (.LREF)>)>
+ <FIXUP-BRANCH-REFERENCES <LABEL-REF-XREFS .LREF> .TABPTR>
+ <LABEL-REF-LIVE-VARS .LREF ()>
+ <LABEL-REF-DEAD-VARS .LREF ()>
+ .LREF>
+
+<DEFINE FIXUP-BRANCH-REFERENCES (XREFS TABPTR)
+ #DECL ((XREFS) <LIST [REST XREF-INFO]> (TABPTR) FIX)
+ <MAPF <>
+ <FCN (XREF "AUX" (CODPTR <XREF-INFO-POINT .XREF>) INST)
+ <SET INST
+ <CHTYPE <ORB <NTH-CODE .CODPTR> .TABPTR> FIX>>
+ <PUT-CODE .CODPTR .INST>>
+ .XREFS>>
+
+<DEFINE ADD-XREF (LREF CODPTR STATUS? LILEN FORCEL? "AUX" XREF)
+ #DECL ((LREF) LABEL-REF (CODPTR) FIX (VALUE) XREF-INFO (STATUS?) ANY
+ (LILEN) FIX (FORCEL?) BOOLEAN)
+ <SET XREF
+ <CHTYPE <VECTOR .LREF
+ .CODPTR
+ <>
+ <>
+ <>
+ 0
+ .STATUS?
+ .LILEN
+ ,CODE-COUNT
+ <>
+ ()
+ .FORCEL?>
+ XREF-INFO>>
+ <PUT .LREF ,LABEL-REF-XREFS (.XREF !<LABEL-REF-XREFS .LREF>)>
+ .XREF>
+
+<DEFINE EMIT-BRANCH (INST LABEL STATUS? LILEN
+ "OPTIONAL" (ACNUM <>) (FORCEL? <>) (XT <>)
+ "AUX" XREF (CNT 1) LREF)
+ #DECL ((INST) FIX (LABEL) <OR ATOM SPEC-LABEL> (XREF) XREF-INFO
+ (FORCEL?) BOOLEAN)
+ <SET INST <CHTYPE <LSH .INST 24> FIX>>
+ <SET XREF <UPDLT-BRANCH .LABEL ,CODE-COUNT .STATUS? .LILEN .FORCEL?>>
+ <SET LREF <XREF-INFO-LABEL .XREF>>
+ <COND (<NOT <0? <LABEL-REF-CODE-PTR .LREF>>>
+ <MAPF <>
+ <FUNCTION (TREF)
+ <COND (<==? .TREF .LREF> <MAPLEAVE>)>
+ <SET CNT <+ .CNT 1>>>
+ ,LABEL-TABLE>
+ <SET INST <CHTYPE <ORB .INST .CNT> FIX>>)>
+ <COND (.ACNUM <SET INST <CHTYPE <ORB .INST <LSH .ACNUM -8>> FIX>>)>
+ <ADD-WORD-TO-CODE .INST>
+ <SETG LAST-INST-LENGTH 1>
+ .XREF>
+
+<DEFINE EMIT-LABEL (LABEL LOOP?)
+ #DECL ((LABEL) <OR ATOM SPEC-LABEL> (LOOP?) <OR FALSE AC-STATE ATOM>)
+ <UPDLT-LABEL .LABEL ,CODE-COUNT .LOOP?>>
+
+"THE CONSTANT TABLE CONSISTS OF CONSTANT ADDRESS PAIRS. THE ADDRESS MAY HAVE
+ 3 STATES. IF IT IS NON-ZERO. THEN IT IS THE ADDRESS OF THE MOST RECENT
+ EMITTED VERSION OF A CONSTANT. IF IT IS ZERO THEN IT INDICATES THAT A VERSION
+ OF THE CONSTANT WILL BE EMITTED BY SOME INSTRUCTION IN THE CURRENT SUBROUTINE
+ -1 IS USED BY THE SCAN PASS TO INDICATE THAT THE CONSTANT WILL HAVE BEEN
+ BEEN EMITTED BY A PREVIOUS INSTRUCTION"
+
+<DEFINE INIT-CONSTANTS ()
+ <SETG CONSTANT-POINTER 1>
+ <SETG CONSTANT-TABLE <IUVECTOR ,CONSTANT-TABLE-SIZE 0>>>
+
+<DEFINE RESET-CONSTANTS () <SETG CONSTANT-POINTER 1>>
+
+"WARNING: THIS ADDS AN ENTRY TO THE CONSTANT TABLE IF IT IS NOT
+ ALREADY THERE. THE INITIAL VERSION OF THIS ALGORITHM USES LINEAR
+ SEARCH. THIS MAY SLOW DOWN THE WORLD"
+
+<DEFINE AGEN-CONST (NUM "AUX" (TAB ,CONSTANT-TABLE) NTAB)
+ #DECL ((NUM) FIX)
+ <REPEAT ((PTR 1))
+ <COND
+ (<==? .PTR ,CONSTANT-POINTER>
+ <COND (<G? .PTR <LENGTH .TAB>>
+ <SET NTAB
+ <IUVECTOR <+ <LENGTH .TAB> ,CONSTANT-TABLE-INCREMENT>
+ 0>>
+ <MAPR <>
+ <FCN (TAB1 TAB2) <PUT .TAB1 1 <1 .TAB2>>>
+ .TAB
+ .NTAB>
+ <SET TAB .NTAB>
+ <SETG CONSTANT-TABLE .TAB>)>
+ <PUT ,CONSTANT-TABLE .PTR .NUM>
+ <PUT ,CONSTANT-TABLE <+ .PTR 1> 0>
+ <SETG CONSTANT-POINTER <+ ,CONSTANT-POINTER 2>>
+ <RETURN .PTR>)
+ (<==? .NUM <NTH .TAB .PTR>> <RETURN .PTR>)>
+ <SET PTR <+ .PTR 2>>>>
+
+<DEFINE INIT-PATCH-TABLE () <SETG PATCH-TABLE ()> <SETG NUM-PATCH 1>>
+
+<DEFINE ADD-PATCH (PATCHTYPE "AUX" NPATCH INST (NUM ,NUM-PATCH))
+ #DECL ((PATCHTYPE) ATOM)
+ <SET NPATCH <CHTYPE <VECTOR ![!] .PATCHTYPE> PATCH>>
+ <SETG PATCH-TABLE (.NPATCH !,PATCH-TABLE)>
+ <SET INST <CHTYPE <ORB <LSH ,INST-PATCH 24> .NUM> FIX>>
+ <ADD-WORD-TO-CODE .INST>
+ <SETG NUM-PATCH <+ .NUM 1>>
+ .NUM>
+
+<DEFINE GET-PATCH (NUM "AUX" (TAB ,PATCH-TABLE))
+ #DECL ((NUM) FIX (CDV) CODEVEC)
+ <NTH .TAB <- <LENGTH .TAB> <- .NUM 1>>>>
+
+<DEFINE INSERT-PATCH (NUM CDV "AUX" PATCH)
+ #DECL ((NUM) FIX (CDV) CODEVEC)
+ <SET PATCH <GET-PATCH .NUM>>
+ <PUT .PATCH ,PATCH-CODE .CDV>>
+
+<DEFINE EMIT (INST "TUPLE" FIELDS)
+ <COND (<MEMQ .INST ,SPECIAL-OPS>
+ <ADD-WORD-TO-CODE
+ <CHTYPE <ORB <LSH .INST 24> <ANDB .INST *7777*>> FIX>>)
+ (ELSE <REAL-EMIT .INST .FIELDS <>>)>>
+
+<GDECL (LAST-INST-LENGTH) FIX>
+
+
+<DEFINE REAL-EMIT (INST FIELDS WHERE
+ "AUX" (INST-INFO <GET-INST-INFO .INST>)
+ (NUM-OPS <CHTYPE <LSH <2 .INST-INFO> <- ,INIT-SHIFT>>
+ FIX>)
+ (SHFT 16) (FNUM 1))
+ #DECL ((FNUM INST NUM-OPS SHFT) FIX (WHERE) <OR FALSE FIX>
+ (INST-INFO) <UVECTOR [3 FIX]> (FIELDS) TUPLE)
+ <SET INST <CHTYPE <LSH .INST 24> FIX>>
+ <COND (<NOT .WHERE> <SETG LAST-INST-LENGTH 0>)>
+ <MAPF <>
+ <FCN (FLD "AUX" REG-OR-LIT EAC SIZC MODC OPREQ (NBYTES 0) IMWRD)
+ #DECL ((REG-OR-LIT EAC SIZC MODC OPREQ NBYTES IMWRD) FIX)
+ <COND (<0? .NUM-OPS>
+ <ERROR TOO-MANY-OPERANDS!-ERRORS .INST !.FIELDS>)>
+ <COND (<NOT <TYPE? .FLD EFF-ADDR LADDR>>
+ <ERROR BAD-CALL-TO-EMIT!-ERRORS .INST !.FIELDS>)>
+ <COND (<TYPE? .FLD LADDR>
+ <SET IMWRD <CHTYPE <2 .FLD> FIX>>
+ <SET FLD <CHTYPE <LSH <1 .FLD> -24> FIX>>)
+ (ELSE
+ <SET IMWRD <CHTYPE <LSH .FLD 8> FIX>>
+ ; "??? May be loser"
+ <SET FLD <CHTYPE <LSH .FLD -24> FIX>>)>
+ <SET EAC <CHTYPE <ANDB .FLD 240> FIX>>
+ <SET REG-OR-LIT <CHTYPE <ANDB .FLD 15> FIX>>
+ <COND (<N==? .EAC ,AM-INX>
+ <SET NUM-OPS <- .NUM-OPS 1>>
+ <SET OPREQ <GET-OP-INFO .FNUM .INST-INFO>>
+ <SET SIZC <CHTYPE <ANDB .OPREQ 7> FIX>>
+ <SET MODC <CHTYPE <LSH .OPREQ -3> FIX>>
+ <SET FNUM <+ .FNUM 1>>)>
+ <COND (<AND <G=? .EAC ,AM-INX>
+ <L=? .EAC ,AM-ADEC>
+ <==? .REG-OR-LIT ,NAC-PC>>
+ <ERROR CANT-INDEX-PC!-ERRORS .INST !.FIELDS>)
+ (<G=? .EAC ,AM-AINC>
+ <COND (<OR <AND <OR <==? .EAC ,AM-AINCD>
+ <AND <==? .EAC ,AM-AINC>
+ <OR <==? .SIZC ,SZ-L>
+ <==? .SIZC ,SZ-F>>>>
+ <==? .REG-OR-LIT ,NAC-PC>>
+ <==? .EAC ,AM-LD>
+ <==? .EAC ,AM-LDD>>
+ <SET NBYTES 4>)
+ (<OR <==? .EAC ,AM-WD>
+ <==? .EAC ,AM-WDD>
+ <AND <==? .EAC ,AM-AINC>
+ <==? .SIZC ,SZ-W>
+ <==? .REG-OR-LIT ,NAC-PC>>>
+ <SET NBYTES 2>)
+ (<OR <==? .EAC ,AM-BD>
+ <==? .EAC ,AM-BDD>
+ <AND <==? .EAC ,AM-AINC>
+ <==? .SIZC ,SZ-B>
+ <==? .REG-OR-LIT ,NAC-PC>>>
+ <SET NBYTES 1>)
+ (<AND <==? .EAC ,AM-AINC> <==? .REG-OR-LIT ,NAC-PC>>
+ <COND (<OR <==? .SIZC ,SZ-Q> <==? .SIZC ,SZ-D>>
+ <SET NBYTES 8>)
+ (<==? .SIZC ,SZ-O> <SET NBYTES 16>)
+ (ELSE <ERROR FOO!-ERRORS>)>)
+ (ELSE <SET NBYTES 0>)>)
+ (ELSE <SET NBYTES 0>)>
+ <SET INST <CHTYPE <ORB .INST <LSH .FLD .SHFT>> FIX>>
+ <COND (<L? <SET SHFT <- .SHFT 8>> 0>
+ <SET SHFT 24>
+ <COND (.WHERE
+ <PUT-CODE .WHERE .INST>
+ <SET WHERE <+ .WHERE 1>>)
+ (ELSE
+ <ADD-WORD-TO-CODE .INST>
+ <SETG LAST-INST-LENGTH <+ ,LAST-INST-LENGTH 1>>)>
+ <SET INST 0>)>
+ <REPEAT ()
+ <COND (<L? <SET NBYTES <- .NBYTES 1>> 0> <RETURN>)>
+ <SET INST
+ <CHTYPE <ORB .INST
+ <LSH <ANDB .IMWRD *37700000000*>
+ <- .SHFT 24>>>
+ FIX>>
+ <SET IMWRD <CHTYPE <LSH .IMWRD 8> FIX>>
+ <COND (<L? <SET SHFT <- .SHFT 8>> 0>
+ <COND (.WHERE
+ <PUT-CODE .WHERE .INST>
+ <SET WHERE <+ .WHERE 1>>)
+ (ELSE
+ <ADD-WORD-TO-CODE .INST>
+ <SETG LAST-INST-LENGTH
+ <+ ,LAST-INST-LENGTH 1>>)>
+ <SET SHFT 24>
+ <SET INST 0>)>>>
+ .FIELDS>
+ <COND (<N==? .NUM-OPS 0> <ERROR TOO-FEW-FIELDS!-ERRORS .INST !.FIELDS>)>
+ <COND (<N==? .SHFT 24>
+ <COND (.WHERE <PUT-CODE .WHERE .INST> <SET WHERE <+ .WHERE 1>>)
+ (ELSE
+ <ADD-WORD-TO-CODE .INST>
+ <SETG LAST-INST-LENGTH <+ ,LAST-INST-LENGTH 1>>)>)>>
+
+
+<DEFINE EMIT-LABEL-WORD (LABEL "AUX" XREF LREF (INST 0) (CNT 1))
+ #DECL ((LABEL) ATOM (XREF) XREF-INFO)
+ <SET XREF <UPDLT-BRANCH .LABEL ,CODE-COUNT NORMAL 1 <>>>
+ <SET LREF <XREF-INFO-LABEL .XREF>>
+ <COND (<NOT <0? <LABEL-REF-CODE-PTR .LREF>>>
+ <MAPF <>
+ <FUNCTION (TREF)
+ <COND (<==? .TREF .LREF> <MAPLEAVE>)>
+ <SET CNT <+ .CNT 1>>>
+ ,LABEL-TABLE>
+ <SET INST <CHTYPE <ORB .INST .CNT> FIX>>)>
+ <ADD-WORD-TO-CODE .INST>
+ <SETG LAST-INST-LENGTH 1>
+ .XREF>
+
+
+<DEFINE BAD-MOVE (EA1 EA2 MSIZE "OPT" EXTRA "AUX" INST)
+ #DECL ((MSIZE) ATOM)
+ <COND (<==? .MSIZE ZWL> <SET INST ,INST-MOVZWL>)
+ (<==? .MSIZE LONG> <SET INST ,INST-MOVL>)
+ (<==? .MSIZE WORD> <SET INST ,INST-MOVW>)
+ (<==? .MSIZE BYTE> <SET INST ,INST-MOVB>)
+ (<==? .MSIZE DOUBLE> <SET INST ,INST-MOVQ>)>
+ <COND (<AND <ASSIGNED? EXTRA> .EXTRA>
+ <COND (<N==? <PRIMTYPE .EXTRA> FIX>
+ <EMIT .INST .EA1 !.EXTRA .EA2>)
+ (T
+ <EMIT .INST .EA1 .EXTRA .EA2>)>)
+ (T
+ <EMIT .INST .EA1 .EA2>)>>
+
+<DEFINE RE-EMIT-MOVE (PTR EA1 EA2 MSIZE "AUX" INST (X <TUPLE .EA1 .EA2>))
+ #DECL ((EA1 EA2) EFF-ADDR (MSIZE) ATOM (PTR) FIX)
+ <SET PTR <- .PTR 2>>
+ <COND (<==? .MSIZE LONG> <SET INST ,INST-MOVL>)
+ (<==? .MSIZE WORD> <SET INST ,INST-MOVW>)
+ (<==? .MSIZE BYTE> <SET INST ,INST-MOVB>)
+ (<==? .MSIZE DOUBLE> <SET INST ,INST-MOVQ>)>
+ <REAL-EMIT .INST .X .PTR>>
+
+"MAKE SURE CONSTANT IS CORRECT IF IMMEDIATE. IF LONG WORD OPERATION
+ SHOULD USE CONSTANT TABLE"
+
+<DEFINE IMM-CHECK (EA SIZE "AUX" FLD NUM)
+ #DECL ((EA) EFF-ADDR (SIZE) ATOM)
+ <SET FLD <GET-FIELD .EA ,EA-FIELD>>
+ <COND (<==? .SIZE LONG>
+ <COND (<==? .FLD ,ADDRESS-IMM-LONG>
+ <CHTYPE <PUTBITS .EA ,EA-FIELD ,ADDRESS-IMM> EFF-ADDR>)
+ (<==? .FLD ,ADDRESS-IMM>
+ <SET NUM <EXTEND <LHW .EA>>>
+ <SET NUM <AGEN-CONST .NUM>>
+ <CHTYPE <PUT-LHW .FLD .NUM> EFF-ADDR>)
+ (.EA)>)
+ (<==? .FLD ,ADDRESS-IMM-LONG>
+ <ERROR "CANT USE LONG CONSTANT" .EA .SIZE IMM-CHECK>)
+ (.EA)>>
+
+<DEFINE START-CODE-INSERT ("AUX" (CNT ,SAVED-CODE-COUNT))
+ <COND (.CNT <SETG SAVED-CODE-STACK (.CNT !,SAVED-CODE-STACK)>)>
+ <SETG SAVED-CODE-COUNT ,CODE-COUNT>>
+
+<DEFINE END-CODE-INSERT ("AUX" (CCOUNT ,CODE-COUNT) RES
+ (START ,SAVED-CODE-COUNT))
+ #DECL ((VALUE) CODEVEC)
+ <SET RES
+ <MAPF ,UVECTOR
+ <FCN ("AUX" EL)
+ <COND (<==? .CCOUNT .START> <MAPSTOP>)>
+ <SET EL <NTH-CODE .START>>
+ <SET START <+ .START 1>>
+ <MAPRET .EL>>>>
+ <SETG CODE-COUNT ,SAVED-CODE-COUNT>
+ <REPEAT ((PTR ,CODE-COUNT) (CL ,CODE-LIST))
+ #DECL ((CL) <LIST [REST UVECTOR]>)
+ <COND (<L=? <- .PTR 1> ,CODEVEC-LENGTH>
+ <SETG CURRENT-CODE <REST <1 .CL> <- .PTR 1>>>
+ <RETURN>)>
+ <COND (<EMPTY? <SET CL <REST .CL>>>
+ <ERROR OUT-OF-BOUNDS END-CODE-INSERT>)>
+ <SET PTR <- .PTR ,CODEVEC-LENGTH>>>
+ <COND (<EMPTY? ,SAVED-CODE-STACK> <SETG SAVED-CODE-COUNT <>>)
+ (ELSE
+ <SETG SAVED-CODE-COUNT <1 ,SAVED-CODE-STACK>>
+ <SETG SAVED-CODE-STACK <REST ,SAVED-CODE-STACK>>)>
+ .RES>
+
+<DEFINE EMIT-MOVE GM (EA1 EA2 SZ "OPT" (EXTRA <>) "AUX" TMP (ISZ .SZ) ABS TB
+ INST)
+ <COND (<AND <NOT .EXTRA>
+ <TYPE? .EA1 LADDR>
+ <==? <1 .EA1> <MA-AINC ,AC-PC>>
+ <==? <LENGTH .EA1> 2>
+ <N==? .SZ ZWL>>
+ ; "Get constant back"
+ <SET TMP <CHTYPE <LREV <2 .EA1>> FIX>>
+ <IFSYS ("TOPS20"
+ ; "Do sign-extension"
+ <COND (<NOT <0? <ANDB .TMP *020000000000*>>>
+ <SET TMP <PUTBITS .TMP <BITS 4 32> -1>>)>)>
+ <SET ABS <ABS .TMP>>
+ <COND (<AND <L? .TMP 256>
+ <G? .TMP -128>>
+ <SET ISZ BYTE>)
+ (<AND <L? .TMP 65536>
+ <G? .TMP -32768>>
+ <SET ISZ WORD>)
+ (T
+ <SET ISZ LONG>)>)
+ (<AND <TYPE? .EA1 EFF-ADDR>
+ <L=? <SET TMP <LREV .EA1>> *77*>
+ <G=? .TMP 0>>
+ <SET ABS .TMP>
+ <SET ISZ BYTE>)
+ (T
+ ; "can't do anything here"
+ <BAD-MOVE .EA1 .EA2 .SZ .EXTRA>
+ <RETURN T .GM>)>
+ <COND (<==? .TMP 0>
+ <SET INST <COND (<==? .SZ BYTE> ,INST-CLRB)
+ (<==? .SZ WORD> ,INST-CLRW)
+ (<==? .SZ LONG> ,INST-CLRL)
+ (<==? .SZ DOUBLE> ,INST-CLRQ)>>
+ <EMIT .INST .EA2>)
+ (<AND <L=? .ABS *77*>
+ <G=? .ABS 0>>
+ <SET EA1 <MA-LIT .ABS>>
+ <COND (<G? .TMP 0>
+ <BAD-MOVE .EA1 .EA2 .SZ .EXTRA>)
+ (T
+ <SET INST <COND (<==? .SZ BYTE> ,INST-MNEGB)
+ (<==? .SZ WORD> ,INST-MNEGW)
+ (<==? .SZ LONG> ,INST-MNEGL)>>
+ <EMIT .INST .EA1 .EA2>)>)
+ (<==? .SZ .ISZ>
+ <BAD-MOVE .EA1 .EA2 .SZ .EXTRA>)
+ (T
+ <COND (<==? .ISZ BYTE>
+ <SET TB ,BYTE-TAB>)
+ (<==? .ISZ WORD>
+ <SET TB ,WORD-TAB>)>
+ <COND (<L? .TMP 0>
+ <SET TB <1 .TB>>)
+ (T
+ <SET TB <2 .TB>>)>
+ <EMIT <COND (<==? .SZ WORD> <1 .TB>)
+ (T <2 .TB>)>
+ <COND (<==? .ISZ BYTE> <MA-BYTE-IMM .TMP>)
+ (<==? .ISZ WORD> <MA-WORD-IMM .TMP>)
+ (<==? .ISZ LONG> <MA-LONG-IMM .TMP>)>
+ .EA2>)>>
+
+<DEFINE EMIT-PUSH EP (EADDR SZ "AUX" TMP (ISZ .SZ) ABS TB)
+ #DECL ((EADDR) <OR EFF-ADDR LADDR> (SZ) ATOM (TB) VECTOR)
+ <EMIT-MOVE .EADDR <MA-AINC ,AC-TP> .SZ>>
+
+<SETG BYTE-TAB [[,INST-CVTBW ,INST-CVTWL]
+ [,INST-MOVZBW ,INST-MOVZBL]]>
+<SETG WORD-TAB [[0 ,INST-CVTWL]
+ [0 ,INST-MOVZWL]]>
+
+<DEFINE EMIT-POP (EADDR SZ)
+ #DECL ((EADDR) <OR AC EFF-ADDR> (SZ) ATOM)
+ <COND (<TYPE? .EADDR EFF-ADDR> <EMIT-MOVE <MA-ADEC ,AC-TP> .EADDR .SZ>)
+ (ELSE <EMIT-MOVE <MA-ADEC ,AC-TP> <MA-REG .EADDR> .SZ>)>>
+
+<DEFINE CLEAR-PUSH ("OPTIONAL" (LENGTH LONG))
+ <EMIT <COND (<==? .LENGTH LONG> ,INST-CLRL)
+ (<==? .LENGTH WIRD> ,INST-CLRW)
+ (<==? .LENGTH BYTE> ,INST-CLRB)
+ (<==? .LENGTH DOUBLE> ,INST-CLRQ)
+ (ELSE ,INST-CLRO)>
+ <MA-AINC ,AC-TP>>>
+
+<DEFINE FIND-CALL-ENTRY (NAME)
+ #DECL ((NAME) ATOM)
+ <MAPF <>
+ <FCN (CE)
+ <COND (<SAME-NAME? <CET-MSUBR-NAME .CE> .NAME>
+ <MAPLEAVE .CE>)>>
+ ,CALL-ENTRY-TABLE>>
+
+<DEFINE FIND-CALL-POINT (NAME NARGS "AUX" CE)
+ #DECL ((NAME) ATOM (NARGS) FIX)
+ <COND (<SET CE <FIND-CALL-ENTRY .NAME>> <FIND-ENTRY-LOC .CE .NARGS>)>>
+
+<DEFINE FIND-ENTRY-LOC (CE NARGS "AUX" (CUV <CET-DISPATCH .CE>))
+ #DECL ((CE) CALL-ENTRY (NARGS) FIX)
+ <REPEAT ((FINAL <>))
+ <AND <==? <1 .CUV> .NARGS> <RETURN <2 .CUV>>>
+ <AND <==? <1 .CUV> -1> <SET FINAL <2 .CUV>>>
+ <COND (<AND <==? .NARGS -1> .FINAL> <RETURN .FINAL>)
+ (<AND <==? <LENGTH .CUV> 2> <G? .NARGS <1 .CUV>>>
+ <RETURN <2 .CUV>>)
+ (<EMPTY? .CUV> <RETURN .FINAL>)>
+ <SET CUV <REST .CUV 2>>>>
+
+<DEFINE INIT-INTERNAL-ENTRYS () <SETG INTERNAL-ENTRY-TABLE ()>>
+
+<DEFINE INIT-CALL-ENTRYS () <SETG CALL-ENTRY-TABLE ()>>
+
+<DEFINE ADD-INTERNAL-ENTRY (NUMARGS LABEL "AUX" IE)
+ #DECL ((NUMARGS) FIX (LABEL) <OR ATOM SPEC-LABEL>)
+ <MAPF <>
+ <FCN (LREF)
+ <COND (<==? <LABEL-REF-NAME .LREF> .LABEL>
+ <SET IE <CHTYPE <VECTOR .NUMARGS .LREF> INT-ENTRY>>
+ <SETG INTERNAL-ENTRY-TABLE
+ (.IE !,INTERNAL-ENTRY-TABLE)>)>>
+ ,OUTST-LABEL-TABLE>>
+
+<DEFINE UPDATE-CALL-ENTRY-TABLE (FNAME "AUX" CUV CE)
+ #DECL ((FNAME) ATOM)
+ <SET CUV
+ <MAPF ,UVECTOR
+ <FCN (IE
+ "AUX"
+ (NARGS <IE-NUMBER-ARGS .IE>)
+ (LABEL <IE-LABEL-REF .IE>))
+ <MAPRET .NARGS <LABEL-REF-REL-ADDR .LABEL>>>
+ ,INTERNAL-ENTRY-TABLE>>
+ <SET CE <CHTYPE <VECTOR .FNAME .CUV> CALL-ENTRY>>
+ <SETG CALL-ENTRY-TABLE (.CE !,CALL-ENTRY-TABLE)>
+ .CE>
+
+<SETG CALL-TABLE <IVECTOR ,CT-NUMBER-CALLS <>>>
+
+<DEFINE RESET-CALL-TABLE ()
+ <SETG CALL-POINTER 1>
+ <MAPR <> <FCN (X) <PUT .X 1 <>>> ,CALL-TABLE>>
+
+<DEFINE EMIT-CALL (FCN NUMARGS
+ "AUX" UC (CNT ,CALL-POINTER) (TAB ,CALL-TABLE) INST)
+ #DECL ((FCN) ATOM (NUMARGS) FIX)
+ <SET UC <CHTYPE <VECTOR .FCN .NUMARGS 0 0> UNRESOLVED-CALL>>
+ <COND (<G? .CNT <LENGTH .TAB>>
+ <SETG CALL-TABLE <VECGROW ,CALL-TABLE ,CT-NUMBER-CALLS>>)>
+ <PUT ,CALL-TABLE .CNT .UC>
+ <SETG CALL-POINTER <+ .CNT 1>>
+ <ADD-WORD-TO-CODE <CHTYPE <ORB <LSH ,INST-CALL 24>
+ .CNT>
+ FIX>>
+ T>
+
+<DEFINE VECGROW (TAB INCR "AUX" NEWVEC)
+ #DECL ((INCR) FIX (TAB) VECTOR)
+ <SET NEWVEC <IVECTOR <+ <LENGTH .TAB> .INCR>>>
+ <MAPR <> <FCN (OVEC NVEC) <PUT .NVEC 1 <1 .OVEC>>> .TAB .NEWVEC>
+ .NEWVEC>
+
+<SETG PUSH-LABEL-TABLE <IVECTOR 100 <>>>
+
+<DEFINE RESET-PUSH-LABEL-TABLE () <SETG PUSH-LABEL-COUNT 1>>
+
+<DEFINE EMIT-PUSH-LABEL (LABEL
+ "AUX" (CNT ,PUSH-LABEL-COUNT) (TAB ,PUSH-LABEL-TABLE)
+ INST NLREF)
+ #DECL ((LABEL) <OR ATOM SPEC-LABEL>)
+ <SET NLREF <CREATE-LABEL-REF .LABEL>>
+ <ADD-OUTSTANDING-LABEL .NLREF>
+ <COND (<G? .CNT <LENGTH .TAB>>
+ <SETG PUSH-LABEL-TABLE <VECGROW .TAB 100>>)>
+ <PUT ,PUSH-LABEL-TABLE .CNT .NLREF>
+ <SETG PUSH-LABEL-COUNT <+ .CNT 1>>
+ <ADD-WORD-TO-CODE <CHTYPE <ORB <LSH ,INST-PUSHLAB 24> .CNT>
+ FIX>>
+ T>
+
+<SETG MOVE-LABEL-TABLE <IVECTOR 100 <>>>
+
+<DEFINE RESET-MOVE-LABEL-TABLE () <SETG MOVE-LABEL-COUNT 1>>
+
+<DEFINE EMIT-MOVE-LABEL (LABEL EA
+ "AUX" (CNT ,MOVE-LABEL-COUNT) (TAB ,MOVE-LABEL-TABLE)
+ INST NLREF)
+ #DECL ((LABEL) <OR ATOM SPEC-LABEL>)
+ <SET NLREF <CREATE-LABEL-REF .LABEL>>
+ <ADD-OUTSTANDING-LABEL .NLREF>
+ <COND (<G? .CNT <LENGTH .TAB>>
+ <SETG MOVE-LABEL-TABLE <VECGROW .TAB 100>>)>
+ <PUT ,MOVE-LABEL-TABLE .CNT .NLREF>
+ <SETG MOVE-LABEL-COUNT <+ .CNT 1>>
+ <ADD-WORD-TO-CODE <CHTYPE <ORB <LSH ,INST-MOVELAB 24>
+ <LSH <ANDB .EA *37700000000*> -8>
+ .CNT> FIX>>
+ T>
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff