<mdl.comp>/cback.mud.18

   1 <PACKAGE "CBACK">
   2
   3 <ENTRY BACK-GEN TOP-GEN>
   4
   5 <USE "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD" "STRGEN">
   6
   7
   8 <DEFINE BACK-GEN (NOD WHERE
   9                   "AUX" (K <KIDS .NOD>) (TYP <RESULT-TYPE <1 .K>>)
  10                         (TPS <STRUCTYP .TYP>)
  11                         (NUMKN <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>)
  12                         (NUM <COND (.NUMKN <NODE-NAME <2 .K>>) (ELSE 0)>))
  13         #DECL ((NUMKN) <OR ATOM FALSE> (NUM) FIX (TPS) ATOM (NOD) NODE
  14                (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
  15         <APPLY <NTH ,BACKERS <LENGTH <MEMQ .TPS ,STYPES>>>
  16                .NOD
  17                .WHERE
  18                .TYP
  19                .TPS
  20                .NUMKN
  21                .NUM
  22                <1 .K>
  23                <2 .K>>>
  24
  25 <DEFINE NO-BACK-ERROR (NOD "TUPLE" ERR)
  26         <MESSAGE INCONSISTENCY "CANT OPEN-COMPILE BACK" .ERR .NOD>>
  27
  28 <DEFINE VEC-BACK-GEN (NODE WHERE TYP TPS NUMKN NUM STRNOD NUMNOD
  29                       "AUX" (ONO .NO-KILL) (NO-KILL .ONO)
  30                             (CAREFL <AND .CAREFUL <N==? .TPS TUPLE>>)
  31                             (UV? <==? .TPS UVECTOR>) NAC SAC STR NUMN (RV <>)
  32                             TAC TDAT (W <GOODACS .NODE .WHERE>))
  33    #DECL ((NOD NUMNOD STRNOD) NODE (W TDAT STR NUMN) DATUM (TAC SAC NAC) AC (NUM) FIX
  34           (NO-KILL) <SPECIAL LIST> (RV CAREFL UV?) <OR ATOM FALSE>)
  35    <COND
  36     (.NUMKN
  37      <COND (<L? .NUM 0> <MESSAGE INCONSISTENCY "ARG OUT OF RANGE BACK" .NODE>)
  38            (<0? .NUM> <SET STR <GEN .STRNOD .W>>)
  39            (ELSE
  40             <SET STR <GEN .STRNOD .W>>
  41             <COND (.CAREFL
  42                    <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
  43                    <MUNG-AC .TAC>
  44                    <PUT .TDAT ,DATVAL .TAC>
  45                    <SET TAC <DATVAL .TDAT>>
  46                    <EMIT <INSTRUCTION `HLRE  `O  !<ADDR:VALUE .STR>>>
  47                    <EMIT <INSTRUCTION `MOVE  <ACSYM .TAC> !<ADDR:VALUE .STR>>>
  48                    <EMIT <INSTRUCTION `SUB  <ACSYM .TAC> `O >>
  49                    <EMIT <INSTRUCTION `HLRZ  <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
  50                    <EMIT <INSTRUCTION `ADD  <ACSYM .TAC> `O >>
  51                    <EMIT <INSTRUCTION `SUBI
  52                                       <ACSYM .TAC>
  53                                       <+ <COND (.UV? .NUM) (ELSE <* .NUM 2>)>
  54                                          1>>>
  55                    <EMIT <INSTRUCTION `JUMPLE  <ACSYM .TAC> |COMPER >>
  56                    <RET-TMP-AC .TDAT>)>
  57             <TOACV .STR>
  58             <SET SAC <DATVAL .STR>>
  59             <MUNG-AC .SAC .STR>
  60             <EMIT <INSTRUCTION `SUB
  61                                <ACSYM .SAC>
  62                                <COND (.UV? [<FORM (.NUM) .NUM>])
  63                                      (ELSE
  64                                       [<FORM (<* .NUM 2>) <* .NUM 2>>])>>>)>)
  65     (ELSE
  66      <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
  67      <COND (.RV <SET NUMN <GEN .NUMNOD DONT-CARE>> <SET STR <GEN .STRNOD .W>>)
  68            (<SET STR <GEN .STRNOD .W>> <SET NUMN <GEN .NUMNOD DONT-CARE>>)>
  69      <DELAY-KILL .NO-KILL .ONO>
  70      <TOACV .NUMN>
  71      <SET NAC <DATVAL .NUMN>>
  72      <MUNG-AC .NAC .NUMN>
  73      <COND (<NOT .UV?> <EMIT <INSTRUCTION `ASH  <ACSYM .NAC> 1>>)>
  74      <COND (.CAREFUL
  75             <EMIT <INSTRUCTION `JUMPL  <ACSYM .NAC> |COMPER >>
  76             <SET TAC <GETREG <SET TDAT <DATUM FIX ANY-AC>>>>
  77             <PUT .TDAT ,DATVAL .TAC>
  78             <EMIT <INSTRUCTION `HLRE  `O  !<ADDR:VALUE .STR>>>
  79             <EMIT <INSTRUCTION `MOVE  <ACSYM .TAC> !<ADDR:VALUE .STR>>>
  80             <EMIT <INSTRUCTION `SUB  <ACSYM .TAC> `O >>
  81             <EMIT <INSTRUCTION `HLRZ  <ACSYM .TAC> 1 (<ADDRSYM .TAC>)>>
  82             <EMIT <INSTRUCTION `ADD  <ACSYM .TAC> `O >>
  83             <EMIT <INSTRUCTION `SUB  <ACSYM .TAC> <ADDRSYM .NAC>>>
  84             <EMIT <INSTRUCTION `SOJLE  <ACSYM .TAC> |COMPER >>
  85             <RET-TMP-AC .TDAT>)>
  86      <EMIT <INSTRUCTION `HRLI  <ACSYM .NAC> (<ADDRSYM .NAC>)>>
  87      <TOACV .STR>
  88      <MUNG-AC <DATVAL .STR> .STR>
  89      <EMIT <INSTRUCTION `SUB  <ACSYM <CHTYPE <DATVAL .STR> AC>> <ADDRSYM .NAC>>>
  90      <PUT .NAC ,ACPROT <>>
  91      <RET-TMP-AC .NUMN>
  92      <COND (<N==? .TPS TUPLE>
  93             <RET-TMP-AC <DATTYP .STR> .STR>
  94             <PUT .STR ,DATTYP .TPS>)>)>
  95    <MOVE:ARG .STR .WHERE>>
  96
  97 <GDECL (BACKERS) VECTOR>
  98
  99 <SETG BACKERS
 100       [,NO-BACK-ERROR
 101        ,NO-BACK-ERROR
 102        ,NO-BACK-ERROR
 103        ,VEC-BACK-GEN
 104        ,VEC-BACK-GEN
 105        ,VEC-BACK-GEN
 106        ,VEC-BACK-GEN
 107        ,NO-BACK-ERROR]>
 108
 109 <DEFINE TOP-GEN (N RW
 110                  "AUX" (NN <1 <KIDS .N>>) (TY <RESULT-TYPE .NN>)
 111                        (TPS <STRUCTYP .TY>) OAC SAC (FLG <>) W DAC D)
 112         #DECL ((N NN) NODE (W D) DATUM (TPS) ATOM (OAC SAC DAC) AC)
 113         <SET W <GOODACS .N .RW>>
 114         <SET D <GEN .NN <DATUM <COND (<ISTYPE? .TY>) (ELSE .TPS)> ANY-AC>>>
 115         <PUT <SET SAC <DATVAL .D>> ,ACPROT T>
 116         <COND (<==? <DATVAL .W> <DATVAL .D>> <SET OAC <GETREG <>>> <SET FLG T>)
 117               (<TYPE? <DATVAL .W> AC>
 118                <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT T>
 119                <SET OAC <GETREG <>>>
 120                <PUT <CHTYPE <DATVAL .W> AC> ,ACPROT <>>)
 121               (ELSE <SET OAC <GETREG <>>>)>
 122         <EMIT <INSTRUCTION `HLRE  <ACSYM .OAC> <ADDRSYM .SAC>>>
 123         <EMIT <INSTRUCTION `SUBM  <ACSYM .SAC> <ADDRSYM .OAC>>>
 124         <COND (<AND <NOT .FLG> <TYPE? <DATVAL .W> AC>>
 125                <SET DAC <SGETREG <DATVAL .W> <>>>
 126                <EMIT <INSTRUCTION `MOVEI  <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)
 127               (<OR .FLG <0? <CHTYPE <FREE-ACS T> FIX>>>
 128                <MUNG-AC <SET DAC .SAC> .D>
 129                <EMIT <INSTRUCTION `MOVEI  <ACSYM .SAC> 2 (<ADDRSYM .OAC>)>>)
 130               (ELSE
 131                <PUT .OAC ,ACPROT T>
 132                <SET DAC <GETREG <>>>
 133                <EMIT <INSTRUCTION `MOVEI  <ACSYM .DAC> 2 (<ADDRSYM .OAC>)>>)>
 134         <EMIT <INSTRUCTION `HLR  <ACSYM .OAC> 1 (<ADDRSYM .OAC>)>>
 135         <EMIT <INSTRUCTION `HRLI  <ACSYM .OAC> -2 (<ADDRSYM .OAC>)>>
 136         <EMIT <INSTRUCTION `SUB  <ACSYM .DAC> <ADDRSYM .OAC>>>
 137         <PUT .SAC ,ACPROT <>>
 138         <PUT .OAC ,ACPROT <>>
 139         <RET-TMP-AC .D>
 140         <SET D <DATUM .TPS .DAC>>
 141         <PUT .DAC ,ACLINK (.D)>
 142         <MOVE:ARG .D .RW>>
 143
 144 <ENDPACKAGE>
 145 \f