<mdl.comp>/comsub.mud.10

   1 <PACKAGE "COMSUB">
   2
   3 <ENTRY SUBSTRUC-GEN>
   4
   5 <USE "CODGEN" "CACS" "CHKDCL" "COMCOD" "COMPDEC" "STRGEN">
   6
   7
   8 "ROUTINES TO GENERATE SUBSTRUCT FOR THE COMPILER. CURRENTLY ONLY\r
   9  HACKS UVECTOR AND VECTOR
  10  CASES 1) COPYING  (ALWAYS HACKED) (I.E 1 ARG)
  11        2) COPYING PORTIONS (2 OR 3 ARGS) (ALWAYS HACKED)
  12        3) COPYING INTO STRUCTURES HACKED IN 2 CASES
  13           <SUBSTRUC .X .N1 .N2 <REST .X>>
  14           <SUBSTRUC <REST .X> .N1 .N2 .X>"
  15
  16 "NODE STRUCTURE IS FAIRLY MUNGED TO ALLOW FOR REASONABILITY.
  17  1==> STRUCTURE NODE
  18       THIS IS ACTUALLY RESTED
  19  2==> NUMBER NODE (IF IT EXISTS)
  20  3==> RESTED STRUCTURE NODE (IF IT EXISTS)
  21  DECISION AS TO FOURTH ARG WILL TRY TO BE MADE DURING PASS1 OR SYMANA"
  22
  23 <DEFINE SUBSTRUC-GEN (NOD WHERE
  24                       "AUX" (K <KIDS .NOD>) (STRNOD <1 .K>)
  25                             (TPS <STRUCTYP <RESULT-TYPE .STRNOD>>) L)
  26         #DECL ((NOD) NODE (WHERE) <OR ATOM DATUM> (K) <LIST [REST NODE]>)
  27         <COND (<1? <SET L <LENGTH .K>>> <COPY-SB-GEN .STRNOD .TPS .WHERE>)
  28               (<==? .L 2> <COPY-ELE-SB-GEN .STRNOD .TPS <2 .K> .WHERE>)
  29               (<==? .L 3> <COPY-INTO-SB-GEN .STRNOD .TPS <2 .K> <3 .K> .WHERE>)
  30               (<MESSAGE INCONSISTENCY "BAD NODE TO SUBSTRUC">)>>
  31
  32 \\f
  33
  34 "ROUTINE TO COPY INTO A NEW STRUCTION (1 OR 2 ARGUMENT SUBSTRUCTS."
  35
  36 <DEFINE COPY-SB-GEN (STRNOD TPS WHERE
  37                      "AUX" SDAT TDAT NDAT NAC SAC (END-LABEL <MAKE:TAG "SUB">)
  38                            TAC)
  39         #DECL ((STRNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
  40                (SDAT TDAT NDAT) DATUM (TAC NAC SAC) AC)
  41         <SET SDAT <GEN .STRNOD DONT-CARE>>
  42         <COND (<==? <DATVAL .SDAT> ,AC-A>
  43                <MUNG-AC ,AC-A .SDAT>
  44                <EMIT <INSTRUCTION `HLRE  `A*  `A >>)
  45               (<SGETREG ,AC-A <>>
  46                <EMIT <INSTRUCTION `HLRE  `A*  !<ADDR:VALUE .SDAT>>>)>
  47         <REGSTO T>
  48         <EMIT <INSTRUCTION `MOVNS  `A >>
  49         <EMIT <INSTRUCTION `PUSH  `P*  `A >>
  50         <SET TDAT <GEN-COPY .TPS>>
  51         <SET TAC <DATVAL .TDAT>>
  52         <PUT .TAC ,ACPROT T>
  53         <SET NDAT <DATUM FIX ANY-AC>>
  54         <SET NAC <GETREG .NDAT>>
  55         <PUT .NDAT ,DATVAL .NAC>
  56         <SET NAC <DATVAL .NDAT>>
  57         <EMIT <INSTRUCTION `POP  `P*  <ADDRSYM .NAC>>>
  58         <EMIT <INSTRUCTION `JUMPE  <ACSYM .NAC> .END-LABEL>>
  59         <EMIT <INSTRUCTION `ADDI  <ACSYM .NAC> (<ADDRSYM .TAC>)>>
  60         <PUT .NAC ,ACPROT T>
  61         <TOACV .SDAT>
  62         <SET SAC <DATVAL .SDAT>>
  63         <BLTAC .SAC .TAC .NAC <==? .TPS UVECTOR> .SDAT>
  64         <PUT .NAC ,ACPROT <>>
  65         <RET-TMP-AC .SDAT>
  66         <PUT .TAC ,ACPROT <>>
  67         <PUT .NAC ,ACPROT <>>
  68         <RET-TMP-AC .NDAT>
  69         <LABEL:TAG .END-LABEL>
  70         <MOVE:ARG .TDAT .WHERE>>
  71
  72 \\f
  73
  74 "HERE FOR 3 ARGUMENT SUBSTRUCS"
  75
  76 <DEFINE COPY-ELE-SB-GEN (STRNOD TPS NUMNOD WHERE
  77                          "AUX" TDAT (SDAT <>) NDAT
  78                                (NUM
  79                                 <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
  80                                        <NODE-NAME .NUMNOD>)>) TAC
  81                                (END-LABEL <MAKE:TAG "SUB">) (ONO .NO-KILL)
  82                                (NO-KILL .ONO) NAC SAC)
  83    #DECL ((STRNOD NUMNOD) NODE (TPS) ATOM (WHERE) <OR ATOM DATUM>
  84           (SDAT) <OR FALSE DATUM> (NDAT TDAT) DATUM (TAC NAC SAC) AC
  85           (NO-KILL) <SPECIAL LIST>)
  86    <COND (.NUM
  87           <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
  88           <REGSTO T>
  89           <COND (<==? .TPS VECTOR>
  90                  <EMIT <INSTRUCTION `MOVEI  `A*  <* .NUM 2>>>)
  91                 (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `MOVEI  `A*  .NUM>>)
  92                 (<MESSAGE INCONSISTENCY "BAD SUBSTRUC NODE">)>
  93           <SET TDAT <GEN-COPY .TPS>>
  94           <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
  95           <PUT <SET SAC <DATVAL .SDAT>> ,ACPROT T>
  96           <TOACV .TDAT>
  97           <SET TAC <DATVAL .TDAT>>
  98           <PUT .SAC ,ACPROT <>>
  99           <COND (<==? .NUM 0>)
 100                 (<COND (.CAREFUL <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>)>
 101                  <BLTAC+NUM .SAC .TAC .NUM <> .TPS .SDAT>
 102                  <COND (<==? .TPS UVECTOR>
 103                         <SET NAC <GETREG <>>>
 104                         <EMIT <INSTRUCTION `MOVE
 105                                            <ACSYM .NAC>
 106                                            !<ADDR:VALUE .TDAT>>>
 107                         <EMIT <INSTRUCTION `HLRE  `O*  <ADDRSYM .NAC>>>
 108                         <EMIT <INSTRUCTION `SUB  <ACSYM .NAC> 0>>
 109                         <UVECTOR-MUNG-SB .SDAT .NAC>)>)>)
 110          (ELSE
 111           <COND (<NOT <COMMUTE-STRUC <> .STRNOD .NUMNOD>>
 112                  <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)>
 113           <SET NDAT <DATUM FIX ,AC-A>>
 114           <SET NAC <SGETREG ,AC-A <>>>
 115           <SET NDAT <GEN .NUMNOD .NDAT>>
 116           <COND (.CAREFUL
 117                  <EMIT <INSTRUCTION `JUMPL  <ACSYM <DATVAL .NDAT>> |CERR1 >>)>
 118           <COND (<==? .TPS VECTOR>
 119                  <EMIT <INSTRUCTION `ASH  <ACSYM <DATVAL .NDAT>> 1>>
 120                  <MUNG-AC .NAC .NDAT T>)>
 121           <EMIT <INSTRUCTION `PUSH  `P*  <ADDRSYM .NAC>>>
 122           <RET-TMP-AC .NDAT>
 123           <REGSTO T>
 124           <SET TDAT <GEN-COPY .TPS>>
 125           <COND (.SDAT <TOACV .SDAT>)
 126                 (<SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
 127                  <DELAY-KILL .NO-KILL .ONO>)>
 128           <SET SAC <DATVAL .SDAT>>
 129           <PUT .SAC ,ACPROT T>
 130           <TOACV .TDAT>
 131           <SET TAC <DATVAL .TDAT>>
 132           <PUT .TAC ,ACPROT T>
 133           <SET NAC <GETREG <>>>
 134           <EMIT <INSTRUCTION `POP  `P*  <ADDRSYM .NAC>>>
 135           <EMIT <INSTRUCTION `JUMPE  <ACSYM .NAC> .END-LABEL>>
 136           <COND (.CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>)>
 137           <EMIT <INSTRUCTION `ADDI  <ACSYM .NAC> (<ADDRSYM .TAC>)>>
 138           <PUT .NAC ,ACPROT T>
 139           <BLTAC .SAC .TAC .NAC <> .SDAT>
 140           <PUT .NAC ,ACPROT <>>
 141           <PUT .TAC ,ACPROT <>>
 142           <PUT .SAC ,ACPROT <>>
 143           <RET-TMP-AC .NDAT>
 144           <AND <==? .TPS UVECTOR> <UVECTOR-MUNG-SB .SDAT .NAC>>)>
 145    <RET-TMP-AC .SDAT>
 146    <LABEL:TAG .END-LABEL>
 147    <MOVE:ARG .TDAT .WHERE>>
 148
 149 \\f
 150
 151 "ROUTINE TO COPY INTO A UVECTOR OR VECTOR
 152  <SUBSTRUC .X .N1 .N2 <REST .X>> or
 153  <SUBSTRUC <REST .X> .N1 .N2 .X>."
 154
 155 <DEFINE COPY-INTO-SB-GEN (STRNOD TPS NUMNOD CPYNOD WHERE
 156                           "AUX" NDAT TDAT SDAT SAC TAC NAC
 157                                 (NUM
 158                                  <COND (<==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
 159                                         <NODE-NAME .NUMNOD>)>) RV FLG DDAT DAC
 160                                 (ONO .NO-KILL) (NO-KILL .ONO) TEM TEM2
 161                                 (OTHN <>) END-LABEL RR)
 162    #DECL ((STRNOD NUMNOD CPYNOD) NODE (WHERE) <OR ATOM DATUM>
 163           (NDAT DDAT TDAT SDAT) DATUM (DAC NAC TAC SAC) AC
 164           (NO-KILL) <SPECIAL LIST>)
 165    <SET FLG <SUB-CASE-1 .STRNOD .CPYNOD>>
 166    <COND (<AND <==? <NODE-TYPE <SET TEM <2 <KIDS .STRNOD>>>> ,QUOTE-CODE>
 167                <OR <AND <==? <NODE-TYPE .CPYNOD> ,LVAL-CODE> <SET TEM2 0>>
 168                    <AND <==? <NODE-TYPE .CPYNOD> ,REST-CODE>
 169                         <==? <NODE-TYPE <SET TEM2 <2 <KIDS .CPYNOD>>>>
 170                              ,QUOTE-CODE>
 171                         <SET TEM2 <NODE-NAME .TEM2>>>>>
 172           <SET OTHN <ABS <- <NODE-NAME .TEM> .TEM2>>>
 173           <OR <==? .TPS UVECTOR> <SET OTHN <* .OTHN 2>>>)>
 174    <COND
 175     (.NUM
 176      <SET RV <COMMUTE-STRUC <> .STRNOD .CPYNOD>>
 177      <COND (<L? .NUM 0> <MESSAGE ERROR "OUT OF BOUNDS SUBSTRUC">)>
 178      <COND (.RV
 179             <SET TDAT <GEN .CPYNOD DONT-CARE>>
 180             <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
 181            (ELSE
 182             <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
 183             <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
 184      <COND
 185       (<==? .NUM 0>)
 186       (<COND
 187         (.FLG
 188          <TOACV .SDAT>
 189          <SET SAC <DATVAL .SDAT>>
 190          <PUT .SAC ,ACPROT T>
 191          <TOACV .TDAT>
 192          <SET TAC <DATVAL .TDAT>>
 193          <PUT .SAC ,ACPROT <>>
 194          <COND (.CAREFUL
 195                 <KNOWN-CAREFUL-CHECK .SDAT .TPS .NUM>
 196                 <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)>
 197          <RET-TMP-AC .SDAT>
 198          <BLTAC+NUM .SAC .TAC .NUM <> .TPS <>>)
 199         (ELSE
 200          <TOACV .SDAT>
 201          <SET SAC <DATVAL .SDAT>>
 202          <MUNG-AC .SAC .SDAT <>>
 203          <PUT .SAC ,ACPROT T>
 204          <COND (.OTHN <PUT <SET DAC <GETREG <>>> ,ACPROT T>)
 205                (ELSE
 206                 <SET DDAT <DATUM .TPS ANY-AC>>
 207                 <SET DAC <GETREG .DDAT>>
 208                 <PUT .DDAT ,DATVAL .DAC>
 209                 <EMIT <INSTRUCTION `MOVE  <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>
 210                 <PUT .DAC ,ACPROT T>
 211                 <COND (<NOT .CAREFUL>
 212                        <EMIT <INSTRUCTION `SUBI
 213                                           <ACSYM .DAC>
 214                                           (<ADDRSYM .SAC>)>>)>)>
 215          <REST-IT .SAC <- .NUM 1> .TPS>
 216          <COND (.CAREFUL
 217                 <COND (.OTHN <KNOWN-CAREFUL-CHECK .TDAT .TPS .NUM>)
 218                       (ELSE
 219                        <REST-IT .DAC <- .NUM 1> .TPS>
 220                        <EMIT <INSTRUCTION `SUBI
 221                                           <ACSYM .DAC>
 222                                           (<ADDRSYM .SAC>)>>)>)>
 223          <BBLT .SAC .DAC .NUM .OTHN .TPS>
 224          <PUT .DAC ,ACPROT <>>
 225          <RET-TMP-AC .SDAT>
 226          <OR .OTHN <RET-TMP-AC .DDAT>>)>)>)
 227     (ELSE
 228      <SET RV <COMMUTE-STRUC <> .NUMNOD .STRNOD>>
 229      <SET RR
 230           <AND <COMMUTE-STRUC <> .CPYNOD .NUMNOD>
 231                <COMMUTE-STRUC <> .CPYNOD .STRNOD>>>
 232      <COND (.RR <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
 233      <COND (.RV
 234             <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>
 235             <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>)
 236            (ELSE
 237             <SET SDAT <GEN .STRNOD <DATUM .TPS ANY-AC>>>
 238             <SET NDAT <GEN .NUMNOD <DATUM FIX ANY-AC>>>)>
 239      <DELAY-KILL .NO-KILL .ONO>
 240      <COND (<NOT .RR> <SET TDAT <GEN .CPYNOD DONT-CARE>>)>
 241      <TOACV .NDAT>
 242      <SET NAC <DATVAL .NDAT>>
 243      <PUT .NAC ,ACPROT T>
 244      <EMIT <INSTRUCTION `JUMPE
 245                         <ACSYM .NAC>
 246                         <SET END-LABEL <MAKE:TAG "SUBSTR">>>>
 247      <COND (.CAREFUL <EMIT <INSTRUCTION `JUMPL  <ACSYM .NAC> |CERR1 >>)>
 248      <MUNG-AC .NAC .NDAT T>
 249      <COND
 250       (.FLG
 251        <TOACV .SDAT>
 252        <SET SAC <DATVAL .SDAT>>
 253        <PUT .SAC ,ACPROT T>
 254        <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH  <ACSYM .NAC> 1>>)>
 255        <AND .CAREFUL <UNKNOWN-CAREFUL-CHECK .SDAT .NAC>>
 256        <EMIT <INSTRUCTION `HRLI  <ACSYM .NAC> (<ADDRSYM .NAC>)>>
 257        <EMIT <INSTRUCTION `ADD  <ACSYM .NAC> !<ADDR:VALUE .TDAT>>>
 258        <AND .CAREFUL <RCHK .NAC T>>
 259        <PUT .NAC ,ACPROT <>>
 260        <PUT .SAC ,ACPROT <>>
 261        <BLTAC+DAT .SAC .TDAT .NAC>)
 262       (ELSE
 263        <COND (.OTHN <SET DAC <GETREG <>>>)
 264              (ELSE
 265               <SET DDAT <DATUM .TPS ANY-AC>>
 266               <SET DAC <GETREG .DDAT>>
 267               <PUT .DDAT ,DATVAL .DAC>
 268               <EMIT <INSTRUCTION `MOVE  <ACSYM .DAC> !<ADDR:VALUE .TDAT>>>)>
 269        <EMIT <INSTRUCTION `SUBI  <ACSYM .NAC> 1>>
 270        <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ASH  <ACSYM .NAC> 1>>)>
 271        <EMIT <INSTRUCTION `HRLI  <ACSYM .NAC> (<ADDRSYM .NAC>)>>
 272        <PUT .DAC ,ACPROT T>
 273        <TOACV .SDAT>
 274        <SET SAC <DATVAL .SDAT>>
 275        <PUT .SAC ,ACPROT T>
 276        <COND (<AND <NOT .CAREFUL> <NOT .OTHN>>
 277               <EMIT <INSTRUCTION `SUBI  <ACSYM .DAC> (<ADDRSYM .SAC>)>>)>
 278        <REST-IT .SAC .NAC .TPS>
 279        <COND (.CAREFUL
 280               <COND (.OTHN
 281                      <COND (<NOT <0? .OTHN>>
 282                             <EMIT <INSTRUCTION `CAML
 283                                                <ACSYM .SAC>
 284                                                [<FORM (<- .OTHN>) 0>]>>
 285                             <EMIT '<`JRST  |CERR2 >>)>)
 286                     (ELSE
 287                      <REST-IT .DAC .NAC .TPS>
 288                      <EMIT <INSTRUCTION `SUBI
 289                                         <ACSYM .DAC>
 290                                         (<ADDRSYM .SAC>)>>)>)>
 291        <BBLT .SAC .DAC .NAC .OTHN .TPS>
 292        <PUT .SAC ,ACPROT <>>
 293        <PUT .NAC ,ACPROT <>>
 294        <PUT .DAC ,ACPROT <>>
 295        <OR .OTHN <RET-TMP-AC .DDAT>>)>
 296      <RET-TMP-AC .NDAT>
 297      <LABEL:TAG .END-LABEL>)>
 298    <RET-TMP-AC .SDAT>
 299    <MOVE:ARG .TDAT .WHERE>>
 300
 301 \\f
 302
 303 "ROUTINE TO GENERATE A CALL TO IBLOCK AND ALSO GENERATE THE APPROPRIATE DATUM"
 304
 305 <DEFINE GEN-COPY (TPS "AUX" (DAT <DATUM .TPS ,AC-B>))
 306         #DECL ((DAT) DATUM (TPS) ATOM)
 307         <SGETREG ,AC-B .DAT>
 308         <COND (<==? .TPS UVECTOR>
 309                <EMIT <INSTRUCTION `MOVEI  `O  |IBLOCK >>)
 310               (<EMIT <INSTRUCTION `MOVEI  `O  1 |IBLOK1 >>)>
 311         <EMIT <INSTRUCTION `PUSHJ  `P*  |RCALL >>
 312         .DAT>
 313
 314 "ROUTINES TO DETERMINE THE CASE OF THE SUBSTRUC WITH 4 ARGUMENTS"
 315
 316 "SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
 317  BLTS ARE ALWAYS POSSIBLE.
 318  STRNOD== NODE OF STRUCTURE
 319  CPYNOD== NODE OF STRUCTURE TO COPY INTO"
 320
 321 <DEFINE SUB-CASE-1 (STRNOD CPYNOD
 322                     "AUX" (DATA <GET-SUB-DATA .STRNOD>)
 323                           (DATAC <GET-SUB-DATA .CPYNOD>))
 324         #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
 325         <AND .DATA
 326              .DATAC
 327              <==? <1 .DATA> <1 .DATAC>>
 328              <TYPE? <2 .DATAC> FIX>
 329              <OR <0? <2 .DATAC>>
 330                  <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
 331
 332 <DEFINE SUB-CASE-2 (STRNOD CPYNOD
 333                     "AUX" (DATA <GET-SUB-DATA .STRNOD>)
 334                           (DATAC <GET-SUB-DATA .CPYNOD>))
 335         #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
 336         <AND .DATA
 337              .DATAC
 338              <==? <1 .DATA> <1 .DATAC>>
 339              <TYPE? <2 .DATA> FIX>
 340              <OR <0? <2 .DATA>>
 341                  <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
 342
 343 <DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
 344    #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
 345    <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
 346           (<NODE-NAME .NOD> 0))
 347          (<AND <==? .NTYP ,REST-CODE>
 348                <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
 349                                ,LVAL-CODE>
 350                           <==? .NTYP ,SET-CODE>>
 351                       <SET SYM <NODE-NAME .TNOD>>)>>
 352           (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>>
 353
 354
 355 "ROUTINE TO DO BLT: AC1==> SOURCE
 356                     AC2==> START OF DEST
 357                     AC3==> END OF DEST."
 358
 359 <DEFINE BLTAC (AC1 AC2 AC3 FLG SD)
 360         #DECL ((AC3 AC1 AC2) AC (FLG) <OR FALSE ATOM> (SD) DATUM)
 361         <EMIT <INSTRUCTION `HRLI  `O*  (<ADDRSYM .AC1>)>>
 362         <EMIT <INSTRUCTION `HRRI  `O*  (<ADDRSYM .AC2>)>>
 363         <EMIT <INSTRUCTION `BLT
 364                            `O*
 365                            <COND (.FLG 0) (ELSE -1)>
 366                            (<ADDRSYM .AC3>)>>>
 367
 368 "HERE TO BLT WITH SOME KNOWLEDGE
 369         AC1==> SOURCE
 370         AC2==> START OF DEST
 371         AC3==> NUMBER OF WORDS TO TRANSMIT"
 372
 373 <DEFINE BLTAC+NUM (AC1 AC2 NUM FLG TPS DAT)
 374         #DECL ((AC1 AC2) AC (NUM) FIX (FLG) <OR FALSE ATOM>)
 375         <OR <==? .TPS UVECTOR> <SET NUM <* .NUM 2>>>
 376         <MUNG-AC .AC1 .DAT>
 377         <EMIT <INSTRUCTION `HRLI  <ACSYM .AC1> (<ADDRSYM .AC1>)>>
 378         <EMIT <INSTRUCTION `HRRI  <ACSYM .AC1> (<ADDRSYM .AC2>)>>
 379         <EMIT <INSTRUCTION `BLT
 380                            <ACSYM .AC1>
 381                            <COND (.FLG .NUM) (ELSE <- .NUM 1>)>
 382                            (<ADDRSYM .AC2>)>>>
 383
 384 "HERE TO BLT BUT WITH A DATUM AS DEST SLOT"
 385
 386 <DEFINE BLTAC+DAT (SAC TDAT NAC)
 387         #DECL ((NAC SAC) AC (TDAT) DATUM)
 388         <PUT .SAC ,ACPROT <>>
 389         <SGETREG .SAC <>>
 390         <EMIT <INSTRUCTION `HRLI  <ACSYM .SAC> (<ADDRSYM .SAC>)>>
 391         <EMIT <INSTRUCTION `HRR  <ACSYM .SAC> !<ADDR:VALUE .TDAT>>>
 392         <EMIT <INSTRUCTION `BLT  <ACSYM .SAC> -1 (<ADDRSYM .NAC>)>>>
 393
 394 "ROUTINE TO GENERATE CHECKS FOR THE CASE WHERE THE LENGTH IS KNOWN."
 395
 396 <DEFINE KNOWN-CAREFUL-CHECK (SAC TPS NUM)
 397         #DECL ((SAC) DATUM (TPS) ATOM (NUM) FIX)
 398         <EMIT <INSTRUCTION `HLRE  `O  !<ADDR:VALUE .SAC>>>
 399         <COND (<==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI  `O  .NUM>>)
 400               (<EMIT <INSTRUCTION `ADDI  `O  <* .NUM 2>>>)>
 401         <EMIT <INSTRUCTION `JUMPG  `O  |COMPER >>>
 402
 403 <DEFINE UNKNOWN-CAREFUL-CHECK (SAC NAC)
 404         #DECL ((NAC) AC (SAC) DATUM)
 405         <EMIT <INSTRUCTION `HLRE  `O  !<ADDR:VALUE .SAC>>>
 406         <EMIT <INSTRUCTION `ADDI  `O  (<ADDRSYM .NAC>)>>
 407         <EMIT <INSTRUCTION `JUMPG  `O  |COMPER >>>
 408
 409 "ROUTINE TO REST A VECTOR/UVECTOR AND CHECK FOR BOUNDS
 410  AC==> UV/V
 411  TPS== PRIMTYPE
 412  NUM== AMOUNT TO REST."
 413
 414 <DEFINE REST-IT (AC NUM TPS)
 415         #DECL ((AC) AC (TPS) ATOM (NUM) <OR FIX AC>)
 416         <COND (<TYPE? .NUM AC>
 417                <EMIT <INSTRUCTION `ADD  <ACSYM .AC> <ADDRSYM .NUM>>>)
 418               (ELSE
 419                <COND (<==? .TPS UVECTOR>) (<SET NUM <* .NUM 2>>)>
 420                <EMIT <INSTRUCTION `ADD  <ACSYM .AC> [<FORM (.NUM) .NUM>]>>)>
 421         <COND (.CAREFUL <RCHK .AC T>)>>
 422
 423 <DEFINE BBLT (SAC DAC NUM OTHN TPS "AUX" (TG <MAKE:TAG>))
 424         #DECL ((AC1 AC2) AC (NUM) <OR FIX AC> (OTHN) <OR FALSE FIX>)
 425         <COND (.OTHN
 426                <EMIT <INSTRUCTION `MOVE
 427                                   <ACSYM .DAC>
 428                                   [<FORM (<ADDRSYM .SAC>) .OTHN>]>>)
 429               (ELSE <EMIT <INSTRUCTION `HRLI  <ACSYM .DAC> <ADDRSYM .SAC>>>)>
 430         <COND (<N==? .TPS UVECTOR> <EMIT <INSTRUCTION `ADDI  <ACSYM .SAC> 1>>)>
 431         <EMIT <COND (<TYPE? .NUM FIX> <INSTRUCTION `HRLI  <ACSYM .SAC> .NUM>)
 432                     (ELSE
 433                      <INSTRUCTION `HRLI
 434                                   <ACSYM .SAC>
 435                                   <COND (<==? .TPS UVECTOR> 1) (ELSE 2)>
 436                                   (<ADDRSYM .NUM>)>)>>
 437         <LABEL:TAG .TG>
 438         <EMIT <INSTRUCTION `POP  <ACSYM .SAC> `@  <ADDRSYM .DAC>>>
 439         <EMIT <INSTRUCTION `TLNE  <ACSYM .SAC> -1>>
 440         <EMIT <INSTRUCTION `JRST  .TG>>>
 441
 442 <DEFINE UVECTOR-MUNG-SB (SDAT TAC "AUX" SAC)
 443         #DECL ((SDAT) DATUM (TAC SAC) AC)
 444         <TOACV .SDAT>
 445         <SET SAC <DATVAL .SDAT>>
 446         <EMIT <INSTRUCTION `HLRE  `O*  <ADDRSYM .SAC>>>
 447         <EMIT <INSTRUCTION `SUB  <ACSYM .SAC> `O* >>
 448         <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O*  (<ADDRSYM .SAC>)>>
 449         <EMIT <INSTRUCTION PUTYP!-OP!-PACKAGE `O*  (<ADDRSYM .TAC>)>>
 450         <PUT .TAC ,ACPROT <>>>
 451 <ENDPACKAGE>