--- /dev/null
+<PACKAGE "COMSUB">
+
+<ENTRY SUBSTRUC-GEN>
+
+<USE "CODGEN" "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN">
+
+
+"ROUTINES TO GENERATE SUBSTRUCT FOR THE COMPILER. CURRENTLY ONLY\r
+ HACKS UVECTOR AND VECTOR
+ CASES 1) COPYING (ALWAYS HACKED) (I.E 1 ARG)
+ 2) COPYING PORTIONS (2 OR 3 ARGS) (ALWAYS HACKED)
+ 3) COPYING INTO STRUCTURES HACKED IN 2 CASES
+ <SUBSTRUC .X .N1 .N2 <REST .X>>
+ <SUBSTRUC <REST .X> .N1 .N2 .X>"
+
+"NODE STRUCTURE IS FAIRLY MUNGED TO ALLOW FOR REASONABILITY.
+ 1==> STRUCTURE NODE
+ THIS IS ACTUALLY RESTED
+ 2==> NUMBER NODE (IF IT EXISTS)
+ 3==> RESTED STRUCTURE NODE (IF IT EXISTS)
+ DECISION AS TO FOURTH ARG WILL TRY TO BE MADE DURING PASS1 OR SYMANA"
+
+<DEFINE SUBSTRUC-GEN (NOD WHERE
+ "AUX" (K <KIDS .NOD>) (STRNOD <1 .K>)
+ (TPS <STRUCTYP <RESULT-TYPE .STRNOD>>) L)
+ #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
+ <COND (<1? <SET L <LENGTH .K>>> <COPY-SB-GEN .STRNOD .TPS .WHERE>)
+ (<==? .L 2> <COPY-ELE-SB-GEN .STRNOD .TPS <2 .K> .WHERE>)
+ (<==? .L 3> <COPY-INTO-SB-GEN .STRNOD .TPS <2 .K> <3 .K> .WHERE>)
+ (<MESSAGE INCONSISTENCY "BAD NODE TO SUBSTRUC">)>>
+
+\\f
+
+"ROUTINE TO COPY INTO A NEW STRUCTION (1 OR 2 ARGUMENT SUBSTRUCTS."
+
+<DEFINE COPY-SB-GEN (STRNOD TPS WHERE
+ "AUX" SDAT TDAT NDAT NAC SAC (END-LABEL <MAKE:TAG "SUB">)
+ TAC)
+ #DECL ((STRNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
+ (SDAT TDAT NDAT) DATUM (TAC NAC SAC) AC)
+ <SET SDAT <GEN .STRNOD DONT-CARE>>
+ <COND (<==? <DATVAL .SDAT> ,AC-A>
+ <MUNG-AC ,AC-A .SDAT>
+ <EMIT <INSTRUCTION `HLRE `A* `A >>)
+ (<SGETREG ,AC-A <>>
+ <EMIT <INSTRUCTION `HLRE `A* !<ADDR:VALUE .SDAT>>>)>
+ <REGSTO T>
+ <EMIT <INSTRUCTION `MOVNS `A >>
+ <EMIT <INSTRUCTION `PUSH `P* `A >>
+ <SET TDAT <GEN-COPY .TPS>>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .TAC ,ACPROT T>
+ <SET NDAT <DATUM FIX ANY-AC>>
+ <SET NAC <GETREG .NDAT>>
+ <PUT .NDAT ,DATVAL .NAC>
+ <SET NAC <DATVAL .NDAT>>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .NAC> .END-LABEL>>
+ <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> (<ADDRSYM .TAC>)>>
+ <PUT .NAC ,ACPROT T>
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <BLTAC .SAC .TAC .NAC <==? .TPS UVECTOR> .SDAT>
+ <PUT .NAC ,ACPROT <>>
+ <RET-TMP-AC .SDAT>
+ <PUT .TAC ,ACPROT <>>
+ <PUT .NAC ,ACPROT <>>
+ <RET-TMP-AC .NDAT>
+ <LABEL:TAG .END-LABEL>
+ <MOVE:ARG .TDAT .WHERE>>
+
+\\f
+
+"HERE FOR 3 ARGUMENT SUBSTRUCS"
+
+<DEFINE COPY-ELE-SB-GEN (STRNOD TPS NUMNOD WHERE
+ "AUX" TDAT (SDAT <>) NDAT
+ (NUM
+ <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
+ <NODE-NAME .NUMNOD>)>) TAC
+ (END-LABEL <MAKE:TAG "SUB">) (ONO .NO-KILL)
+ (NO-KILL .ONO) NAC SAC)
+ #DECL ((STRNOD NUMNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
+ (SDAT) <OR FALSE DATUM> (NDAT TDAT) DATUM (TAC NAC SAC) AC
+ (NO-KILL) <SPECIAL LIST>)
+ <COND (.NUM
+ <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
+ <REGSTO T>
+ <COND (<==? .TPS VECTOR>
+ <EMIT <INSTRUCTION `MOVEI `A* <* .NUM 2>>>)
+ (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `MOVEI `A* .NUM>>)
+ (<MESSAGE INCONSISTENCY "BAD SUBSTRUC NODE">)>
+ <SET TDAT <GEN-COPY .TPS>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <PUT <SET SAC <DATVAL .SDAT>> ,ACPROT T>
+ <TOACV .TDAT>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .SAC ,ACPROT <>>
+ <COND (<==? .NUM 0>)
+ (<COND (.CAREFUL <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>)>
+ <BLTAC+NUM .SAC .TAC .NUM <> .TPS .SDAT>
+ <COND (<==? .TPS UVECTOR>
+ <SET NAC <GETREG <>>>
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .NAC>
+ !<ADDR:VALUE .TDAT>>>
+ <EMIT <INSTRUCTION `HLRE `O* <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .NAC> 0>>
+ <UVECTOR-MUNG-SB .SDAT .NAC>)>)>)
+ (ELSE
+ <COND (<NOT <COMMUTE-STRUC <> .STRNOD .NUMNOD>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)>
+ <SET NDAT <DATUM FIX ,AC-A>>
+ <SET NAC <SGETREG ,AC-A <>>>
+ <SET NDAT <GEN .NUMNOD .NDAT>>
+ <COND (.CAREFUL
+ <EMIT <INSTRUCTION `JUMPL <ACSYM <DATVAL .NDAT>> |CERR1 >>)>
+ <COND (<==? .TPS VECTOR>
+ <EMIT <INSTRUCTION `ASH <ACSYM <DATVAL .NDAT>> 1>>
+ <MUNG-AC .NAC .NDAT T>)>
+ <EMIT <INSTRUCTION `PUSH `P* <ADDRSYM .NAC>>>
+ <RET-TMP-AC .NDAT>
+ <REGSTO T>
+ <SET TDAT <GEN-COPY .TPS>>
+ <COND (.SDAT <TOACV .SDAT>)
+ (<SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <DELAY-KILL .NO-KILL .ONO>)>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <TOACV .TDAT>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .TAC ,ACPROT T>
+ <SET NAC <GETREG <>>>
+ <EMIT <INSTRUCTION `POP `P* <ADDRSYM .NAC>>>
+ <EMIT <INSTRUCTION `JUMPE <ACSYM .NAC> .END-LABEL>>
+ <COND (.CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>)>
+ <EMIT <INSTRUCTION `ADDI <ACSYM .NAC> (<ADDRSYM .TAC>)>>
+ <PUT .NAC ,ACPROT T>
+ <BLTAC .SAC .TAC .NAC <> .SDAT>
+ <PUT .NAC ,ACPROT <>>
+ <PUT .TAC ,ACPROT <>>
+ <PUT .SAC ,ACPROT <>>
+ <RET-TMP-AC .NDAT>
+ <AND <==? .TPS UVECTOR> <UVECTOR-MUNG-SB .SDAT .NAC>>)>
+ <RET-TMP-AC .SDAT>
+ <LABEL:TAG .END-LABEL>
+ <MOVE:ARG .TDAT .WHERE>>
+
+\\f
+
+"ROUTINE TO COPY INTO A UVECTOR OR VECTOR
+ <SUBSTRUC .X .N1 .N2 <REST .X>> or
+ <SUBSTRUC <REST .X> .N1 .N2 .X>."
+
+<DEFINE COPY-INTO-SB-GEN (STRNOD TPS NUMNOD CPYNOD WHERE
+ "AUX" NDAT TDAT SDAT SAC TAC NAC
+ (NUM
+ <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
+ <NODE-NAME .NUMNOD>)>) RV FLG DDAT DAC
+ (ONO .NO-KILL) (NO-KILL .ONO) TEM TEM2
+ (OTHN <>) END-LABEL RR)
+ #DECL ((STRNOD NUMNOD CPYNOD) NODE (WHERE) <OR ATOM DATUM>
+ (NDAT DDAT TDAT SDAT) DATUM (DAC NAC TAC SAC) AC
+ (NO-KILL) <SPECIAL LIST>)
+ <SET FLG <SUB-CASE-1 .STRNOD .CPYNOD>>
+ <COND (<AND <==? <NODE-TYPE <SET TEM <2 <KIDS .STRNOD>>>> ,QUOTE-CODE>
+ <OR <AND <==? <NODE-TYPE .CPYNOD> ,LVAL-CODE> <SET TEM2 0>>
+ <AND <==? <NODE-TYPE .CPYNOD> ,REST-CODE>
+ <==? <NODE-TYPE <SET TEM2 <2 <KIDS .CPYNOD>>>>
+ ,QUOTE-CODE>
+ <SET TEM2 <NODE-NAME .TEM2>>>>>
+ <SET OTHN <ABS <- <NODE-NAME .TEM> .TEM2>>>
+ <OR <==? .TPS UVECTOR> <SET OTHN <* .OTHN 2>>>)>
+ <COND
+ (.NUM
+ <SET RV <COMMUTE-STRUC <> .STRNOD .CPYNOD>>
+ <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
+ <COND (.RV
+ <SET TDAT <GEN .CPYNOD DONT-CARE>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
+ (ELSE
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
+ <COND
+ (<==? .NUM 0>)
+ (<COND
+ (.FLG
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <TOACV .TDAT>
+ <SET TAC <DATVAL .TDAT>>
+ <PUT .SAC ,ACPROT <>>
+ <COND (.CAREFUL
+ <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>
+ <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)>
+ <RET-TMP-AC .SDAT>
+ <BLTAC+NUM .SAC .TAC .NUM <> .TPS <>>)
+ (ELSE
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <MUNG-AC .SAC .SDAT <>>
+ <PUT .SAC ,ACPROT T>
+ <COND (.OTHN <PUT <SET DAC <GETREG <>>> ,ACPROT T>)
+ (ELSE
+ <SET DDAT <DATUM .TPS ANY-AC>>
+ <SET DAC <GETREG .DDAT>>
+ <PUT .DDAT ,DATVAL .DAC>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>
+ <PUT .DAC ,ACPROT T>
+ <COND (<NOT .CAREFUL>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .DAC>
+ (<ADDRSYM .SAC>)>>)>)>
+ <REST-IT .SAC <- .NUM 1> .TPS>
+ <COND (.CAREFUL
+ <COND (.OTHN <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)
+ (ELSE
+ <REST-IT .DAC <- .NUM 1> .TPS>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .DAC>
+ (<ADDRSYM .SAC>)>>)>)>
+ <BBLT .SAC .DAC .NUM .OTHN .TPS>
+ <PUT .DAC ,ACPROT <>>
+ <RET-TMP-AC .SDAT>
+ <OR .OTHN <RET-TMP-AC .DDAT>>)>)>)
+ (ELSE
+ <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
+ <SET RR
+ <AND <COMMUTE-STRUC <> .CPYNOD .NUMNOD>
+ <COMMUTE-STRUC <> .CPYNOD .STRNOD>>>
+ <COND (.RR <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
+ <COND (.RV
+ <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
+ (ELSE
+ <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
+ <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>)>
+ <DELAY-KILL .NO-KILL .ONO>
+ <COND (<NOT .RR> <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
+ <TOACV .NDAT>
+ <SET NAC <DATVAL .NDAT>>
+ <PUT .NAC ,ACPROT T>
+ <EMIT <INSTRUCTION `JUMPE
+ <ACSYM .NAC>
+ <SET END-LABEL <MAKE:TAG "SUBSTR">>>>
+ <COND (.CAREFUL <EMIT <INSTRUCTION `JUMPL <ACSYM .NAC> |CERR1 >>)>
+ <MUNG-AC .NAC .NDAT T>
+ <COND
+ (.FLG
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
+ <AND .CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <EMIT <INSTRUCTION `ADD <ACSYM .NAC> !<ADDR:VALUE .TDAT>>>
+ <AND .CAREFUL <RCHK .NAC T>>
+ <PUT .NAC ,ACPROT <>>
+ <PUT .SAC ,ACPROT <>>
+ <BLTAC+DAT .SAC .TDAT .NAC>)
+ (ELSE
+ <COND (.OTHN <SET DAC <GETREG <>>>)
+ (ELSE
+ <SET DDAT <DATUM .TPS ANY-AC>>
+ <SET DAC <GETREG .DDAT>>
+ <PUT .DDAT ,DATVAL .DAC>
+ <EMIT <INSTRUCTION `MOVE <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>)>
+ <EMIT <INSTRUCTION `SUBI <ACSYM .NAC> 1>>
+ <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH <ACSYM .NAC> 1>>)>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .NAC> (<ADDRSYM .NAC>)>>
+ <PUT .DAC ,ACPROT T>
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <PUT .SAC ,ACPROT T>
+ <COND (<AND <NOT .CAREFUL> <NOT .OTHN>>
+ <EMIT <INSTRUCTION `SUBI <ACSYM .DAC> (<ADDRSYM .SAC>)>>)>
+ <REST-IT .SAC .NAC .TPS>
+ <COND (.CAREFUL
+ <COND (.OTHN
+ <COND (<NOT <0? .OTHN>>
+ <EMIT <INSTRUCTION `CAML
+ <ACSYM .SAC>
+ [<FORM (<- .OTHN>) 0>]>>
+ <EMIT '<`JRST |CERR2 >>)>)
+ (ELSE
+ <REST-IT .DAC .NAC .TPS>
+ <EMIT <INSTRUCTION `SUBI
+ <ACSYM .DAC>
+ (<ADDRSYM .SAC>)>>)>)>
+ <BBLT .SAC .DAC .NAC .OTHN .TPS>
+ <PUT .SAC ,ACPROT <>>
+ <PUT .NAC ,ACPROT <>>
+ <PUT .DAC ,ACPROT <>>
+ <OR .OTHN <RET-TMP-AC .DDAT>>)>
+ <RET-TMP-AC .NDAT>
+ <LABEL:TAG .END-LABEL>)>
+ <RET-TMP-AC .SDAT>
+ <MOVE:ARG .TDAT .WHERE>>
+
+\\f
+
+"ROUTINE TO GENERATE A CALL TO IBLOCK AND ALSO GENERATE THE APPROPRIATE DATUM"
+
+<DEFINE GEN-COPY (TPS "AUX" (DAT <DATUM .TPS ,AC-B>))
+ #DECL ((DAT) DATUM (TPS) ATOM)
+ <SGETREG ,AC-B .DAT>
+ <COND (<==? .TPS UVECTOR>
+ <EMIT <INSTRUCTION `MOVEI `O |IBLOCK >>)
+ (<EMIT <INSTRUCTION `MOVEI `O 1 |IBLOK1 >>)>
+ <EMIT <INSTRUCTION `PUSHJ `P* |RCALL >>
+ .DAT>
+
+"ROUTINES TO DETERMINE THE CASE OF THE SUBSTRUC WITH 4 ARGUMENTS"
+
+"SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
+ BLTS ARE ALWAYS POSSIBLE.
+ STRNOD== NODE OF STRUCTURE
+ CPYNOD== NODE OF STRUCTURE TO COPY INTO"
+
+<DEFINE SUB-CASE-1 (STRNOD CPYNOD
+ "AUX" (DATA <GET-SUB-DATA .STRNOD>)
+ (DATAC <GET-SUB-DATA .CPYNOD>))
+ #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
+ <AND .DATA
+ .DATAC
+ <==? <1 .DATA> <1 .DATAC>>
+ <TYPE? <2 .DATAC> FIX>
+ <OR <0? <2 .DATAC>>
+ <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
+
+<DEFINE SUB-CASE-2 (STRNOD CPYNOD
+ "AUX" (DATA <GET-SUB-DATA .STRNOD>)
+ (DATAC <GET-SUB-DATA .CPYNOD>))
+ #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
+ <AND .DATA
+ .DATAC
+ <==? <1 .DATA> <1 .DATAC>>
+ <TYPE? <2 .DATA> FIX>
+ <OR <0? <2 .DATA>>
+ <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
+
+<DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
+ #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
+ <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
+ (<NODE-NAME .NOD> 0))
+ (<AND <==? .NTYP ,REST-CODE>
+ <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
+ ,LVAL-CODE>
+ <==? .NTYP ,SET-CODE>>
+ <SET SYM <NODE-NAME .TNOD>>)>>
+ (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>>
+
+
+"ROUTINE TO DO BLT: AC1==> SOURCE
+ AC2==> START OF DEST
+ AC3==> END OF DEST."
+
+<DEFINE BLTAC (AC1 AC2 AC3 FLG SD)
+ #DECL ((AC3 AC1 AC2) AC (FLG) <OR FALSE ATOM> (SD) DATUM)
+ <EMIT <INSTRUCTION `HRLI `O* (<ADDRSYM .AC1>)>>
+ <EMIT <INSTRUCTION `HRRI `O* (<ADDRSYM .AC2>)>>
+ <EMIT <INSTRUCTION `BLT
+ `O*
+ <COND (.FLG 0) (ELSE -1)>
+ (<ADDRSYM .AC3>)>>>
+
+"HERE TO BLT WITH SOME KNOWLEDGE
+ AC1==> SOURCE
+ AC2==> START OF DEST
+ AC3==> NUMBER OF WORDS TO TRANSMIT"
+
+<DEFINE BLTAC+NUM (AC1 AC2 NUM FLG TPS DAT)
+ #DECL ((AC1 AC2) AC (NUM) FIX (FLG) <OR FALSE ATOM>)
+ <OR <==? .TPS UVECTOR> <SET NUM <* .NUM 2>>>
+ <MUNG-AC .AC1 .DAT>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .AC1> (<ADDRSYM .AC1>)>>
+ <EMIT <INSTRUCTION `HRRI <ACSYM .AC1> (<ADDRSYM .AC2>)>>
+ <EMIT <INSTRUCTION `BLT
+ <ACSYM .AC1>
+ <COND (.FLG .NUM) (ELSE <- .NUM 1>)>
+ (<ADDRSYM .AC2>)>>>
+
+"HERE TO BLT BUT WITH A DATUM AS DEST SLOT"
+
+<DEFINE BLTAC+DAT (SAC TDAT NAC)
+ #DECL ((NAC SAC) AC (TDAT) DATUM)
+ <PUT .SAC ,ACPROT <>>
+ <SGETREG .SAC <>>
+ <EMIT <INSTRUCTION `HRLI <ACSYM .SAC> (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION `HRR <ACSYM .SAC> !<ADDR:VALUE .TDAT>>>
+ <EMIT <INSTRUCTION `BLT <ACSYM .SAC> -1 (<ADDRSYM .NAC>)>>>
+
+"ROUTINE TO GENERATE CHECKS FOR THE CASE WHERE THE LENGTH IS KNOWN."
+
+<DEFINE KNOWN-CAREFUL-CHECK (SAC TPS NUM)
+ #DECL ((SAC) DATUM (TPS) ATOM (NUM) FIX)
+ <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .SAC>>>
+ <COND (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI `O .NUM>>)
+ (<EMIT <INSTRUCTION `ADDI `O <* .NUM 2>>>)>
+ <EMIT <INSTRUCTION `JUMPG `O |COMPER >>>
+
+<DEFINE UNKNOWN-CAREFUL-CHECK (SAC NAC)
+ #DECL ((NAC) AC (SAC) DATUM)
+ <EMIT <INSTRUCTION `HLRE `O !<ADDR:VALUE .SAC>>>
+ <EMIT <INSTRUCTION `ADDI `O (<ADDRSYM .NAC>)>>
+ <EMIT <INSTRUCTION `JUMPG `O |COMPER >>>
+
+"ROUTINE TO REST A VECTOR/UVECTOR AND CHECK FOR BOUNDS
+ AC==> UV/V
+ TPS== PRIMTYPE
+ NUM== AMOUNT TO REST."
+
+<DEFINE REST-IT (AC NUM TPS)
+ #DECL ((AC) AC (TPS) ATOM (NUM) <OR FIX AC>)
+ <COND (<TYPE? .NUM AC>
+ <EMIT <INSTRUCTION `ADD <ACSYM .AC> <ADDRSYM .NUM>>>)
+ (ELSE
+ <COND (<==? .TPS UVECTOR>) (<SET NUM <* .NUM 2>>)>
+ <EMIT <INSTRUCTION `ADD <ACSYM .AC> [<FORM (.NUM) .NUM>]>>)>
+ <COND (.CAREFUL <RCHK .AC T>)>>
+
+<DEFINE BBLT (SAC DAC NUM OTHN TPS "AUX" (TG <MAKE:TAG>))
+ #DECL ((AC1 AC2) AC (NUM) <OR FIX AC> (OTHN) <OR FALSE FIX>)
+ <COND (.OTHN
+ <EMIT <INSTRUCTION `MOVE
+ <ACSYM .DAC>
+ [<FORM (<ADDRSYM .SAC>) .OTHN>]>>)
+ (ELSE <EMIT <INSTRUCTION `HRLI <ACSYM .DAC> <ADDRSYM .SAC>>>)>
+ <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI <ACSYM .SAC> 1>>)>
+ <EMIT <COND (<TYPE? .NUM FIX> <INSTRUCTION `HRLI <ACSYM .SAC> .NUM>)
+ (ELSE
+ <INSTRUCTION `HRLI
+ <ACSYM .SAC>
+ <COND (<==? .TPS UVECTOR> 1) (ELSE 2)>
+ (<ADDRSYM .NUM>)>)>>
+ <LABEL:TAG .TG>
+ <EMIT <INSTRUCTION `POP <ACSYM .SAC> `@ <ADDRSYM .DAC>>>
+ <EMIT <INSTRUCTION `TLNE <ACSYM .SAC> -1>>
+ <EMIT <INSTRUCTION `JRST .TG>>>
+
+<DEFINE UVECTOR-MUNG-SB (SDAT TAC "AUX" SAC)
+ #DECL ((SDAT) DATUM (TAC SAC) AC)
+ <TOACV .SDAT>
+ <SET SAC <DATVAL .SDAT>>
+ <EMIT <INSTRUCTION `HLRE `O* <ADDRSYM .SAC>>>
+ <EMIT <INSTRUCTION `SUB <ACSYM .SAC> `O* >>
+ <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O* (<ADDRSYM .SAC>)>>
+ <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE `O* (<ADDRSYM .TAC>)>>
+ <PUT .TAC ,ACPROT <>>>
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff