mim/development/mim/mimc/strgen.mud

   1
   2 <PACKAGE "STRGEN">
   3
   4 <ENTRY NTH-GEN
   5        REST-GEN
   6        PUT-GEN
   7        LNTH-GEN
   8        MT-GEN
   9        PUTREST-GEN
  10        IPUT-GEN
  11        IREMAS-GEN
  12        COMMUTE-STRUC
  13        DEFER-IT
  14        LIST-LNT-SPEC
  15        EMPTY-CHECK
  16        NTH-DO
  17        REST-DO
  18        RECTYPE?
  19        MONAD?-GEN
  20        BACK-GEN
  21        TOP-GEN>
  22
  23 <USE "COMPDEC" "CODGEN" "CHKDCL" "SPCGEN" "CARGEN" "MIMGEN" "ADVMESS">
  24
  25 <SETG MAX-IN-ROW 4>
  26
  27 <SETG CMAX-IN-ROW 2>
  28
  29 <MANIFEST MAX-IN-ROW CMAX-IN-ROW>
  30
  31 <DEFINE LIST-LNT-SPEC (N W NF BR DI NUM SF
  32                        "AUX" (K <KIDS .N>) REG RAC (FLS <==? .W FLUSHED>)
  33                              (B2 <COND (<AND .BR .FLS> .BR) (ELSE <MAKE-TAG>)>)
  34                              (SDIR .DI) (B3 <>) B4 F1 F2 F3
  35                              (SBR <NODE-NAME .N>) TT)
  36         #DECL ((N) NODE (NUM) FIX (K) <LIST [REST NODE]>)
  37         <SET REG
  38              <GEN <SET TT
  39                        <1 <KIDS <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
  40                                        <2 .K>)
  41                                       (ELSE <1 .K>)>>>>>>
  42         <AND .NF <SET DI <NOT .DI>>>
  43         <COND (.SF
  44                <DEALLOCATE-TEMP <MOVE-ARG <REFERENCE <NOT .SDIR>> .W>>)>
  45         <SET DI <COND (<AND .BR <NOT .FLS>> <NOT .DI>) (ELSE .DI)>>
  46         <AND .DI <SET SBR <FLIP .SBR>>>
  47         <SET F1 <MEMQ .SBR '[==? G? G=? 1? 0?]>>
  48         <SET F2 <MEMQ .SBR '[G? G=?]>>
  49         <SET F3 <MEMQ .SBR '[L? L=?]>>
  50         <COND (<OR <==? .SBR L=?> <==? .SBR G?>> <SET NUM <- .NUM 1>>)>
  51         <COND (<L=? .NUM 2>
  52                <REPEAT ((FLG T))
  53                        <EMPTY-LIST .REG
  54                                    <COND (<L=? .NUM 0> .B2)
  55                                          (.F3 .B2)
  56                                          (<OR .F2 <NOT .F1>>
  57                                           <OR .B3 <SET B3 <MAKE-TAG>>>)
  58                                          (ELSE .B2)>
  59                                    <OR <NOT <0? .NUM>> <NOT .F1>>>
  60                        <COND (<L? <SET NUM <- .NUM 1>> 0>
  61                               <AND .B3 <LABEL-TAG .B3>>
  62                               <RETURN>)>
  63                        <SET FLG <>>
  64                        <REST-LIST .REG
  65                                   <COND (<OR <NOT <TYPE? .REG TEMP>>
  66                                              <G=? <TEMP-REFS .REG> 2>>
  67                                          <FREE-TEMP .REG <>>
  68                                          <SET REG <GEN-TEMP LIST>>)
  69                                         (ELSE .REG)>
  70                                   1>>
  71                <FREE-TEMP .REG>)
  72               (ELSE
  73                <COND (<OR <NOT <TYPE? .REG TEMP>> <G=? <TEMP-REFS .REG> 2>>
  74                       <SET REG <MOVE-ARG .REG <GEN-TEMP <>>>>)>
  75                <SET-TEMP <SET RAC <GEN-TEMP FIX>>
  76                          <COND (<OR .F2 .F3> <+ .NUM 1>) (ELSE .NUM)>
  77                          '(`TYPE FIX)>
  78                <IEMIT `LOOP (<TEMP-NAME .REG> VALUE) (<TEMP-NAME .RAC> VALUE)>
  79                <LABEL-TAG <SET B4 <MAKE-TAG>>>
  80                <EMPTY-LIST .REG
  81                            <COND (<AND <NOT .F3> <OR .F2 <NOT .F1>>>
  82                                   <OR .B3 <SET B3 <MAKE-TAG>>>)
  83                                  (ELSE .B2)>
  84                            T>
  85                <REST-LIST .REG .REG 1>
  86                <IEMIT `SUB .RAC 1 = .RAC '(`TYPE FIX)>
  87                <IEMIT `GRTR? .RAC 0 + .B4 '(`TYPE FIX)>
  88                <COND (<OR .F3 .F2> <AND .B3 <BRANCH-TAG .B2>>)
  89                      (ELSE <EMPTY-LIST .REG .B2 <NOT .F1>>)>
  90                <COND (.B3 <LABEL-TAG .B3>)>
  91                <FREE-TEMP .REG>
  92                <FREE-TEMP .RAC>)>
  93         <COND (<NOT .BR> <TRUE-FALSE .N .B2 .W>)
  94               (<NOT .FLS>
  95                <SET W <MOVE-ARG <REFERENCE .SDIR> .W>>
  96                <BRANCH-TAG .BR>
  97                <LABEL-TAG .B2>
  98                .W)>>
  99
 100 <DEFINE LNTH-GEN (NOD WHERE
 101                   "AUX" (STRN <1 <KIDS .NOD>>) T1 T2 STR
 102                         (ITYP <RESULT-TYPE .STRN>) (TYP <STRUCTYP .ITYP>))
 103         #DECL ((STRN NOD) NODE (K) <LIST [REST NODE]> (T1 T2) ATOM)
 104         <SET STR <GEN .STRN DONT-CARE>>
 105         <FREE-TEMP .STR <>>
 106         <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP FIX>>)
 107               (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE FIX>)>
 108         <COND (<==? .TYP LIST> <LENGTH-LIST .STR .WHERE>)
 109               (<OR <==? .TYP VECTOR>
 110                    <==? .TYP TUPLE>>
 111                <LENGTH-VECTOR .STR .WHERE>)
 112               (<==? .TYP STRING> <LENGTH-STRING .STR .WHERE>)
 113               (<==? .TYP BYTES> <LENGTH-BYTES .STR .WHERE>)
 114               (<==? .TYP UVECTOR> <LENGTH-UVECTOR .STR .WHERE>)
 115               (<==? .TYP TEMPLATE> <LENGTH-RECORD .STR .WHERE .ITYP>)
 116               (ELSE <LENGTH-RECORD .STR .WHERE .TYP>)>
 117         .WHERE>
 118
 119 <DEFINE MONAD?-GEN (NOD WHERE) <MT-GEN .NOD .WHERE>>
 120
 121 <DEFINE MT-GEN (NOD WHERE
 122                 "OPTIONAL" (NOTF <>) (BRANCH <>) (DIR <>) (SETF <>)
 123                 "AUX" (STRN <1 <KIDS .NOD>>) STR (ITYP <RESULT-TYPE .STRN>)
 124                       (SDIR .DIR) (TYP <STRUCTYP .ITYP>) (TY <ISTYPE? .ITYP>)
 125                       (FLS <==? .WHERE FLUSHED>)
 126                       (B2
 127                        <COND (<AND .BRANCH .FLS> .BRANCH) (ELSE <MAKE-TAG>)>))
 128         #DECL ((STRN NOD) NODE (B2) ATOM (BRANCH) <OR ATOM FALSE>)
 129         <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP <>>>)>
 130         <AND .NOTF <SET DIR <NOT .DIR>>>
 131         <COND (.SETF
 132                <DEALLOCATE-TEMP <MOVE-ARG <REFERENCE <NOT .SDIR>> .WHERE>>)>
 133         <SET DIR <COND (<AND .BRANCH <NOT .FLS>> <NOT .DIR>) (ELSE .DIR)>>
 134         <SET STR <GEN .STRN>>
 135         <COND (<==? <NODE-TYPE .NOD> ,MONAD-CODE>
 136                <IEMIT `MONAD? .STR <COND (.DIR +) (ELSE -)> .B2>)
 137               (<==? .TYP LIST> <EMPTY-LIST .STR .B2 .DIR .TY>)
 138               (<OR <==? .TYP VECTOR>
 139                    <==? .TYP TUPLE>>
 140                <EMPTY-VECTOR .STR .B2 .DIR .TY>)
 141               (<==? .TYP UVECTOR> <EMPTY-UVECTOR .STR .B2 .DIR .TY>)
 142               (<==? .TYP STRING> <EMPTY-STRING .STR .B2 .DIR .TY>)
 143               (<==? .TYP BYTES> <EMPTY-BYTES .STR .B2 .DIR .TY>)
 144               (<==? .TYP TEMPLATE> <EMPTY-RECORD .STR .B2 .DIR .ITYP>)
 145               (<ISTYPE? .ITYP> <EMPTY-RECORD .STR .B2 .DIR .TYP>)
 146               (ELSE <IEMIT `EMPTY? .STR <COND (.DIR +) (ELSE -)> .B2>)>
 147         <FREE-TEMP .STR>
 148         <COND (<NOT .BRANCH> <TRUE-FALSE .NOD .B2 .WHERE>)
 149               (<NOT .FLS>
 150                <SET WHERE <MOVE-ARG <REFERENCE .SDIR> .WHERE>>
 151                <BRANCH-TAG .BRANCH>
 152                <LABEL-TAG .B2>
 153                .WHERE)>>
 154
 155 <DEFINE REST-GEN (NOD WHERE
 156                   "AUX" (STRNOD <1 <KIDS .NOD>>) (NUMNOD <2 <KIDS .NOD>>)
 157                         (TYP <RESULT-TYPE .STRNOD>) (TPS <STRUCTYP .TYP>)
 158                         (NUMKN <==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>)
 159                         (NUM <COND (.NUMKN
 160                                     ; "TAA 5/20/86"
 161                                     <COND (<TYPE? <NODE-NAME .NUMNOD> OFFSET>
 162                                            <INDEX <NODE-NAME .NUMNOD>>)
 163                                           (T
 164                                            <NODE-NAME .NUMNOD>)>)
 165                                    (ELSE 0)>)
 166                         (ML <MINL .TYP>) STR NUMN (ONO .NO-KILL)
 167                         (NO-KILL .ONO) (LCAREFUL .CAREFUL) (W .WHERE) RV
 168                         (NEED-CHTYPE <OR <N==? <ISTYPE? .TYP> .TPS>
 169                                          <==? <NODE-TYPE .STRNOD>
 170                                               ,CHTYPE-CODE>>)
 171                         (NR <GET-RANGE <RESULT-TYPE .NUMNOD>>))
 172         #DECL ((NOD NUMNOD STRNOD) NODE (ML N MP NUM) FIX
 173                (NUMNK RV) <OR ATOM FALSE> (NR) <OR FALSE <LIST FIX FIX>>
 174                (NO-KILL) <SPECIAL LIST>)
 175         <SET RV <COMMUTE-STRUC <> .STRNOD .NUMNOD>>
 176         <COND (.NUMKN
 177                <COND (<L? .NUM 0>
 178                       <COMPILE-ERROR "Negative " <NODE-NAME .NOD> .NOD>)
 179                      (<0? .NUM>
 180                       <COND (<==? .WHERE DONT-CARE>
 181                              <SET WHERE <SET W <GEN-TEMP>>>)
 182                             (<TYPE? .WHERE TEMP>
 183                              <USE-TEMP .WHERE <COND (.NEED-CHTYPE ANY)
 184                                                     (.TYP)>>)
 185                             (<AND <==? .WHERE ,POP-STACK> .NEED-CHTYPE>
 186                              <SET W <GEN-TEMP ANY>>)>
 187                       <SET STR <GEN .STRNOD .W>>)
 188                      (<AND <==? .TPS LIST>
 189                            <OR <AND .LCAREFUL <G? .NUM .ML>>
 190                                <L=? .NUM ,MAX-IN-ROW>>>
 191                       <COND (<==? .WHERE DONT-CARE>
 192                              <SET WHERE <SET W <GEN-TEMP <>>>>)
 193                             (<TYPE? .WHERE TEMP>)
 194                             (<AND <==? .WHERE ,POP-STACK> .NEED-CHTYPE>
 195                              <SET W <GEN-TEMP <>>>)>
 196                       <SET W
 197                            <EXPANDED-LIST-REST
 198                             <GEN .STRNOD> .NUM .ML .LCAREFUL .W>>)
 199                      (.TPS
 200                       <SET STR <GEN .STRNOD>>
 201                       <COND (<AND .LCAREFUL <G? .NUM .ML>>
 202                              <LENGTH-CHECK .TPS .STR .NUM <RECTYPE? .TYP>>)>
 203                       <FREE-TEMP .STR <>>
 204                       <COND (<==? .WHERE DONT-CARE>
 205                              <SET WHERE <SET W <GEN-TEMP <COND (.NEED-CHTYPE
 206                                                                 ANY)
 207                                                                (.TYP)>>>>)
 208                             (<TYPE? .WHERE TEMP>
 209                              <USE-TEMP .WHERE <COND (.NEED-CHTYPE ANY)
 210                                                     (.TYP)>>)
 211                             (<AND <==? .WHERE ,POP-STACK> .NEED-CHTYPE>
 212                              <SET W <GEN-TEMP>>)>
 213                       <REST-DO .TPS .STR .W .NUM <RECTYPE? .TYP>>)
 214                      (ELSE
 215                       <SET STR <GEN .STRNOD>>
 216                       <FREE-TEMP .STR <>>
 217                       <COND (<==? .WHERE DONT-CARE>
 218                              <SET WHERE <SET W <GEN-TEMP>>>)
 219                             (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE>)>
 220                       <SET NEED-CHTYPE <>>
 221                       <IEMIT `REST1 .STR = .W>)>
 222                <COND (.NEED-CHTYPE
 223                       <GEN-CHTYPE .W .TPS .WHERE>)>
 224                .WHERE)
 225               (ELSE
 226                <COND (.RV
 227                       <SET NUMN <GEN .NUMNOD DONT-CARE>>
 228                       <SET NUMN <INTERF-CHANGE .NUMN .STRNOD>>
 229                       <SET STR <GEN .STRNOD DONT-CARE>>)
 230                      (ELSE
 231                       <SET STR <GEN .STRNOD DONT-CARE>>
 232                       <SET STR <INTERF-CHANGE .STR .NUMNOD>>
 233                       <SET NUMN <GEN .NUMNOD DONT-CARE>>)>
 234                <COND (<AND .LCAREFUL
 235                            <NOT <AND .NR <G=? <1 .NR> 0>>>
 236                            <N==? .TPS LIST>>
 237                       <LENGTH-CHECK .TPS .STR .NUMN <RECTYPE? .TYP>>)>
 238                <COND (<N==? .TPS LIST>
 239                       <FREE-TEMP .STR <>>
 240                       <FREE-TEMP .NUMN <>>)>
 241                <COND (<==? .TPS LIST>
 242                       <COND (<AND <==? .WHERE ,POP-STACK> .NEED-CHTYPE>
 243                              <SET W <GEN-TEMP>>)>
 244                       <SET W
 245                            <EXPANDED-LIST-REST .STR
 246                                                .NUMN
 247                                                .ML
 248                                                .LCAREFUL
 249                                                .W>>
 250                       <COND (<OR <NOT .NEED-CHTYPE>
 251                                  <==? .WHERE DONT-CARE>>
 252                              <SET WHERE .W>)>)
 253                      (ELSE
 254                       <COND (<==? .WHERE DONT-CARE>
 255                              <SET WHERE <SET W <GEN-TEMP <COND (.NEED-CHTYPE
 256                                                                 ANY)
 257                                                                (.TYP)>>>>)
 258                             (<TYPE? .WHERE TEMP>
 259                              <USE-TEMP .WHERE <COND (.NEED-CHTYPE ANY)
 260                                                     (.TYP)>>)
 261                             (<AND <==? .WHERE ,POP-STACK> .NEED-CHTYPE>
 262                              <SET W <GEN-TEMP>>)>
 263                       <REST-DO .TPS .STR .W .NUMN <RECTYPE? .TYP>>)>
 264                <COND (.NEED-CHTYPE
 265                       <GEN-CHTYPE .W .TPS .WHERE>)>
 266                .WHERE)>>
 267
 268 <DEFINE REST-DO (TPS STR WHERE NUM "OPTIONAL" (TYP ANY))
 269         <COND (<OR <==? .TPS VECTOR>
 270                    <==? .TPS TUPLE>>
 271                <REST-VECTOR .STR .WHERE .NUM .TPS>)
 272               (<==? .TPS UVECTOR> <REST-UVECTOR .STR .WHERE .NUM>)
 273               (<==? .TPS STRING> <REST-STRING .STR .WHERE .NUM>)
 274               (<==? .TPS BYTES> <REST-BYTES .STR .WHERE .NUM>)
 275               (<==? .TPS LIST> <REST-LIST .STR .WHERE .NUM>)
 276               (<==? .TPS TEMPLATE> <REST-RECORD .STR .WHERE .NUM .TYP>)
 277               (ELSE <REST-RECORD .STR .WHERE .NUM .TPS>)>>
 278
 279 <DEFINE NTH-GEN (NOD WHERE
 280                  "AUX" (K <KIDS .NOD>) STR (TYP <RESULT-TYPE <1 .K>>)
 281                        (TPS <STRUCTYP .TYP>) (2ARG <2 .K>) NUMN
 282                        (NUMKN <==? <NODE-TYPE .2ARG> ,QUOTE-CODE>)
 283                        (NUM
 284                         <COND (.NUMKN
 285                                <COND (<TYPE? <NODE-NAME .2ARG> OFFSET>
 286                                       <INDEX <NODE-NAME .2ARG>>)
 287                                      (ELSE <NODE-NAME .2ARG>)>)
 288                               (ELSE 1)>) (NR <GET-RANGE <RESULT-TYPE .2ARG>>)
 289                        (TEM <>) (1ARG <1 .K>) NDAT
 290                        (DONE <>) FLS (LCAREFUL .CAREFUL) (ML <MINL .TYP>)
 291                        (RV <==? <NODE-NAME .NOD> INTH>)
 292                        (RESTYP <ISTYPE? <RESULT-TYPE .NOD>>))
 293         #DECL ((NOD) NODE (K) <LIST NODE NODE> (TPS) ANY (NUM ML COD) FIX)
 294         <COND (.NUMKN <PUT .2ARG ,NODE-NAME .NUM>)>
 295         <COND (.NUMKN
 296                <COND (<L=? .NUM 0>
 297                       <COMPILE-ERROR "Negative or 0 "
 298                                      <NODE-NAME .NOD>
 299                                      .NOD>)
 300                      (<1? .NUM>
 301                       <SET STR <GEN .1ARG>>
 302                       <COND (<AND .TPS .LCAREFUL <0? .ML>>
 303                              <EMPTY-CHECK .TPS .STR <RECTYPE? .TYP>>)>
 304                       <FREE-TEMP .STR <>>
 305                       <COND (<==? .WHERE DONT-CARE>
 306                              <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
 307                             (<TYPE? .WHERE TEMP>
 308                              <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
 309                       <COND (.TPS
 310                              <NTH-DO .TPS .STR .WHERE 1 <RECTYPE? .TYP>
 311                                      .RESTYP>)
 312                             (ELSE <IEMIT `NTH1 .STR = .WHERE>)>)
 313                      (<AND <==? .TPS LIST>
 314                            <OR <AND .LCAREFUL <G? .NUM .ML>>
 315                                <L=? .NUM ,MAX-IN-ROW>>>
 316                       <SET STR
 317                            <EXPANDED-LIST-REST
 318                             <GEN .1ARG> .NUM .ML .LCAREFUL>>
 319                       <FREE-TEMP .STR <>>
 320                       <COND (<==? .WHERE DONT-CARE>
 321                              <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
 322                             (<TYPE? .WHERE TEMP>
 323                              <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
 324                       <NTH-DO LIST .STR .WHERE 1 LIST .RESTYP>)
 325                      (ELSE
 326                       <SET STR <GEN .1ARG DONT-CARE>>
 327                       <COND (<AND .LCAREFUL <G? .NUM .ML>>
 328                              <LENGTH-CHECK
 329                               .TPS .STR .NUM <RECTYPE? .TYP>>)>
 330                       <FREE-TEMP .STR <>>
 331                       <COND (<==? .WHERE DONT-CARE>
 332                              <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
 333                             (<TYPE? .WHERE TEMP>
 334                              <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
 335                       <NTH-DO .TPS .STR .WHERE .NUM <RECTYPE? .TYP>
 336                               .RESTYP>)>)
 337               (ELSE
 338                <COND (.RV
 339                       <SET NUMN <GEN .2ARG DONT-CARE>>
 340                       <SET NUMN <INTERF-CHANGE .NUMN .1ARG>>
 341                       <SET STR <GEN .1ARG DONT-CARE>>)
 342                      (ELSE
 343                       <SET STR <GEN .1ARG DONT-CARE>>
 344                       <SET STR <INTERF-CHANGE .STR .2ARG>>
 345                       <SET NUMN <GEN .2ARG DONT-CARE>>)>
 346                <COND (<AND .LCAREFUL
 347                            <NOT <AND .NR <G? <1 .NR> 0>>>
 348                            <N==? .TPS LIST>>
 349                       <LENGTH-CHECK .TPS .STR .NUMN <RECTYPE? .TYP>>)>
 350                <COND (<==? .WHERE DONT-CARE>
 351                       <SET WHERE <GEN-TEMP <RESULT-TYPE .NOD>>>)
 352                      (<TYPE? .WHERE TEMP>
 353                       <USE-TEMP .WHERE <RESULT-TYPE .NOD>>)>
 354                <COND (<==? .TPS LIST>
 355                       <SET STR
 356                            <EXPANDED-LIST-REST .STR .NUMN .ML .LCAREFUL>>
 357                       <NTH-DO LIST .STR .WHERE 1 LIST .RESTYP>
 358                       <FREE-TEMP .STR <>>)
 359                      (ELSE
 360                       <NTH-DO .TPS .STR .WHERE .NUMN <RECTYPE? .TYP>
 361                               .RESTYP>
 362                       <FREE-TEMP .STR <>>
 363                       <FREE-TEMP .NUMN <>>)>)>
 364         .WHERE>
 365
 366 <DEFINE EXPANDED-LIST-REST (STR NUM ML LCAREFUL
 367                             "OPT" W
 368                             "AUX" TG1 TG2 (NUMN .NUM))
 369         #DECL ((ML) FIX)
 370         <COND (<AND <TYPE? .NUM FIX> <NOT <ASSIGNED? W>>>
 371                <SET NUM <- .NUM 1>>)>
 372         <COND (<AND <TYPE? .NUM FIX>
 373                     <L=? .NUM
 374                          <COND (.LCAREFUL ,CMAX-IN-ROW) (ELSE ,MAX-IN-ROW)>>>
 375                <REPEAT ()
 376                        <COND (<AND <L=? .ML 0> .LCAREFUL>
 377                               <EMPTY-CHECK LIST .STR LIST>)>
 378                        <COND (<AND <ASSIGNED? W> <1? .NUM>>
 379                               <FREE-TEMP .STR <>>
 380                               <COND (<==? .W DONT-CARE>
 381                                      <SET W <GEN-TEMP LIST>>)
 382                                     (<TYPE? .W TEMP> <USE-TEMP .W LIST>)>
 383                               <REST-DO LIST .STR .W 1>
 384                               <SET STR .W>)
 385                              (<AND <TYPE? .STR TEMP>
 386                                    <OR <L=? <TEMP-REFS .STR> 1>
 387                                        <AND <ASSIGNED? W> <==? .STR .W>>>>
 388                               <REST-DO LIST .STR .STR 1>)
 389                              (ELSE
 390                               <FREE-TEMP .STR <>>
 391                               <REST-DO LIST .STR <SET STR <GEN-TEMP LIST>> 1>)>
 392                        <COND (<L=? <SET NUM <- .NUM 1>> 0>
 393                               <COND (<AND .LCAREFUL
 394                                           <NOT <ASSIGNED? W>>
 395                                           <L=? .ML 1>>
 396                                      <EMPTY-CHECK LIST .STR LIST>)>
 397                               <RETURN>)>
 398                        <SET ML <- .ML 1>>>)
 399               (ELSE
 400                <COND (<NOT <AND <TYPE? .NUM TEMP> <L=? <TEMP-REFS .NUM> 1>>>
 401                       <SET NUMN <MOVE-ARG .NUM <GEN-TEMP <>>>>)>
 402                <SET TG1 <MAKE-TAG "RESTL">>
 403                <COND (<NOT <AND <TYPE? .STR TEMP>
 404                                 <OR <L=? <TEMP-REFS .STR> 1>
 405                                     <AND <ASSIGNED? W> <==? .W .STR>>>>>
 406                       <SET STR <MOVE-ARG .STR <GEN-TEMP <>>>>)>
 407                <COND (<NOT <TYPE? .NUM FIX>>
 408                       <SET TG2 <MAKE-TAG "RESTL">>
 409                       <COND (<NOT <ASSIGNED? W>>
 410                              <IEMIT `SUB .NUMN 1 = .NUMN '(`TYPE FIX)>)>
 411                       <IEMIT `GRTR? .NUMN 0 - .TG2 '(`TYPE FIX)>)>
 412                <IEMIT `LOOP (<TEMP-NAME .STR> VALUE) (<TEMP-NAME .NUMN> VALUE)>
 413                <LABEL-TAG .TG1>
 414                <IEMIT `INTGO>
 415                <COND (<AND .LCAREFUL <OR <NOT <TYPE? .NUM FIX>> <G? .NUM .ML>>>
 416                       <EMPTY-CHECK LIST .STR LIST>)>
 417                <REST-DO LIST .STR .STR 1>
 418                <IEMIT `SUB .NUMN 1 = .NUMN '(`TYPE FIX)>
 419                <IEMIT `GRTR? .NUMN 0 + .TG1 '(`TYPE FIX)>
 420                <COND (<ASSIGNED? TG2> <LABEL-TAG .TG2>)>
 421                <FREE-TEMP .NUMN>
 422                <COND (<AND .LCAREFUL <NOT <ASSIGNED? W>>>
 423                       <EMPTY-CHECK LIST .STR LIST>)>
 424                <COND (<ASSIGNED? W> <SET STR <MOVE-ARG .STR .W>>)>)>
 425         .STR>
 426
 427 <DEFINE NTH-DO (TPS STR WHERE NUM "OPTIONAL" (TYP ANY) (RESTYP <>))
 428         <COND (<OR <==? .TPS VECTOR>
 429                    <==? .TPS TUPLE>>
 430                <NTH-VECTOR .STR .WHERE .NUM .RESTYP>)
 431               (<==? .TPS UVECTOR> <NTH-UVECTOR .STR .WHERE .NUM .RESTYP>)
 432               (<==? .TPS STRING> <NTH-STRING .STR .WHERE .NUM .RESTYP>)
 433               (<==? .TPS BYTES> <NTH-BYTES .STR .WHERE .NUM .RESTYP>)
 434               (<==? .TPS LIST> <NTH-LIST .STR .WHERE .NUM .RESTYP>)
 435               (<==? .TPS TEMPLATE> <NTH-RECORD .STR .WHERE .NUM .TYP .RESTYP>)
 436               (ELSE <NTH-RECORD .STR .WHERE .NUM .TPS .RESTYP>)>>
 437
 438 <SETG STYPES [LIST TUPLE VECTOR UVECTOR STORAGE STRING BYTES TEMPLATE]>
 439
 440 <DEFINE NTH-PRED (C) #DECL ((C) FIX) <==? .C 1>>
 441
 442 <DEFINE PUT-GEN (NOD WHERE
 443                  "OPTIONAL" (SAME? <>)
 444                  "AUX" (ONO .NO-KILL) (K <KIDS .NOD>) (SNOD <1 .K>)
 445                        (NNOD <2 .K>) (VNOD <3 .K>) (TYP <RESULT-TYPE .SNOD>)
 446                        (TPS <STRUCTYP .TYP>) (ML <MINL .TYP>) VN STR NUMN
 447                        (NUMKN <==? <NODE-TYPE .NNOD> ,QUOTE-CODE>)
 448                        (NUM
 449                         <COND (.NUMKN
 450                                <COND (<TYPE? <NODE-NAME .NNOD> OFFSET>
 451                                       <INDEX <NODE-NAME .NNOD>>)
 452                                      (ELSE <NODE-NAME .NNOD>)>)
 453                               (ELSE 1)>)
 454                        (RV <AND <NOT .SAME?> <COMMUTE-STRUC <> .NNOD .SNOD>>)
 455                        (RR
 456                         <AND <NOT .SAME?>
 457                              <COMMUTE-STRUC <> .VNOD .SNOD>
 458                              <COMMUTE-STRUC <> .VNOD .NNOD>>)
 459                        (NR <GET-RANGE <RESULT-TYPE .NNOD>>) ETYP (W .WHERE)
 460                        FOO)
 461    #DECL ((NOD) NODE (K) <LIST NODE NODE NODE> (NUM ML) FIX)
 462    <COND (.NUMKN <PUT .NNOD ,NODE-NAME .NUM>)>
 463    <SET ETYP <GET-ELE-TYPE .TYP <COND (.NUMKN .NUM) (ALL)>>>
 464    <COND (<AND <MEMQ <STRUCTYP .ETYP> '[VECTOR UVECTOR STRING BYTES]>
 465                <NOT <TYPE? .ETYP SEGMENT>>
 466                <OR <NOT <TYPE? .ETYP ATOM>>
 467                    <NOT <TYPE? <DECL-GET .ETYP> SEGMENT>>>>
 468           <SET ETYP <>>)
 469          (<N==? <SET ETYP <ISTYPE? .ETYP>> <ISTYPE? <RESULT-TYPE .VNOD>>>
 470           <SET ETYP <>>)>
 471    <COND
 472     (.NUMKN
 473      <COND
 474       (<NOT <G? .NUM 0>> <COMPILE-ERROR "PUT Number to small: " .NUM .NOD>)
 475       (<1? .NUM>
 476        <COND (.RR
 477               <SET VN <GEN .VNOD DONT-CARE>>
 478               <SET VN <INTERF-CHANGE .VN .SNOD>>
 479               <SET STR <GEN .SNOD DONT-CARE>>
 480               <COND (<AND <0? .ML> .CAREFUL>
 481                      <EMPTY-CHECK .TPS .STR <RECTYPE? .TYP>>)>)
 482              (ELSE
 483               <SET STR <GEN .SNOD DONT-CARE>>
 484               <COND (<AND .CAREFUL <0? .ML>>
 485                      <EMPTY-CHECK .TPS .STR <RECTYPE? .TYP>>)>
 486               <COND (<NOT .SAME?>
 487                      <SET STR <INTERF-CHANGE .STR .VNOD>>
 488                      <SET VN <GEN .VNOD DONT-CARE>>)>)>
 489        <DELAY-KILL .NO-KILL .ONO>
 490        <COND (.SAME? <SPEC-GEN .VNOD .STR .TPS .NUM>)
 491              (ELSE <DATCLOB .STR .NUM .VN .TPS .TYP .ETYP>)>
 492        <COND (<NOT .SAME?> <FREE-TEMP .VN>)>
 493        <SET W <MOVE-ARG .STR .W>>)
 494       (ELSE
 495        <COND (.RR
 496               <SET VN <GEN .VNOD DONT-CARE>>
 497               <SET VN <INTERF-CHANGE .VN .SNOD>>
 498               <SET STR <GEN .SNOD DONT-CARE>>)
 499              (ELSE
 500               <SET STR <GEN .SNOD DONT-CARE>>
 501               <COND (<NOT .SAME?>
 502                      <SET STR <INTERF-CHANGE .STR .VNOD>>
 503                      <SET VN <GEN .VNOD DONT-CARE>>)>)>
 504        <DELAY-KILL .NO-KILL .ONO>
 505        <COND (<AND .CAREFUL <L? .ML .NUM> <NOT .SAME?> <N==? .TPS LIST>>
 506               <LENGTH-CHECK .TPS .STR .NUM <RECTYPE? .TYP>>)>
 507        <SET FOO .STR>
 508        <COND
 509         (.SAME? <SPEC-GEN .VNOD .STR .TPS 1>)
 510         (ELSE
 511          <COND (<AND <==? .TPS LIST>
 512                      <OR <AND .CAREFUL <G? .NUM .ML>> <L=? .NUM ,MAX-IN-ROW>>>
 513                 <DATCLOB <SET FOO
 514                               <EXPANDED-LIST-REST
 515                                <USE-TEMP .STR> .NUM .ML .CAREFUL>>
 516                          1
 517                          .VN
 518                          .TPS
 519                          .TYP
 520                          .ETYP>)
 521                (ELSE <DATCLOB .STR .NUM .VN .TPS .TYP .ETYP>)>)>
 522        <COND (<N==? .FOO .STR> <FREE-TEMP .FOO>)>
 523        <COND (<NOT .SAME?> <FREE-TEMP .VN>)>
 524        <SET W <MOVE-ARG .STR .W>>)>)
 525     (ELSE
 526      <COND (.RR
 527             <SET VN <GEN .VNOD DONT-CARE>>
 528             <SET VN <INTERF-CHANGE .VN .SNOD>>
 529             <SET VN <INTERF-CHANGE .VN .NNOD>>)>
 530      <COND (.RV
 531             <SET NUMN <GEN .NNOD DONT-CARE>>
 532             <SET NUMN <INTERF-CHANGE .NUMN .SNOD>>
 533             <SET STR <GEN .SNOD DONT-CARE>>
 534             <COND (<NOT .RR>
 535                    <SET NUMN <INTERF-CHANGE .NUMN .VNOD>>
 536                    <SET STR <INTERF-CHANGE .STR .VNOD>>)>)
 537            (ELSE
 538             <SET STR <GEN .SNOD DONT-CARE>>
 539             <SET STR <INTERF-CHANGE .STR .NNOD>>
 540             <SET NUMN <GEN .NNOD DONT-CARE>>
 541             <COND (<NOT .RR>
 542                    <SET NUMN <INTERF-CHANGE .NUMN .VNOD>>
 543                    <SET STR <INTERF-CHANGE .STR .VNOD>>)>)>
 544      <COND (.RR <DELAY-KILL .NO-KILL .ONO>)>
 545      <COND (<AND .CAREFUL <NOT <AND .NR <G? <1 .NR> 0>>>>
 546             <IEMIT `GRTR? .NUMN 0 - `COMPERR '(`TYPE FIX)>)>
 547      <COND (<AND .CAREFUL
 548                  <N==? .TPS LIST>
 549                  <NOT <AND .NR <L=? <2 .NR> <MINL .TYP>>>>>
 550             <LENGTH-CHECK .TPS .STR .NUMN <RECTYPE? .TYP>>)>
 551      <COND (<NOT .RR>
 552             <DELAY-KILL .NO-KILL .ONO>
 553             <COND (<NOT .SAME?> <SET VN <GEN .VNOD DONT-CARE>>)>)>
 554      <COND (.SAME? <SPEC-GEN .VNOD .NUMN .TPS 0>)
 555            (ELSE
 556             <COND (<AND <==? .TPS LIST> .CAREFUL>
 557                    <SET STR <EXPANDED-LIST-REST .STR .NUMN .ML .CAREFUL>>
 558                    <DATCLOB .STR 1 .VN .TPS .TYP .ETYP>)
 559                   (ELSE
 560                    <DATCLOB .STR .NUMN .VN .TPS .TYP .ETYP>
 561                    <FREE-TEMP .NUMN>)>)>
 562      <COND (<NOT .SAME?> <FREE-TEMP .VN>)>
 563      <SET W <MOVE-ARG .STR .W>>)>
 564    .W>
 565
 566 <DEFINE DATCLOB (STR NUM VDAT TPS TYP ETYP "AUX" TT TEM)
 567         <COND (.ETYP <SET ETYP (`TYPE .ETYP)>)>
 568         <COND (<==? .TPS LIST> <PUT-LIST .STR .NUM .VDAT .ETYP>)
 569               (<OR <==? .TPS VECTOR>
 570                    <==? .TPS TUPLE>>
 571                <PUT-VECTOR .STR .NUM .VDAT .ETYP>)
 572               (<==? .TPS UVECTOR> <PUT-UVECTOR .STR .NUM .VDAT>)
 573               (<==? .TPS STRING> <PUT-STRING .STR .NUM .VDAT>)
 574               (<==? .TPS BYTES> <PUT-BYTES .STR .NUM .VDAT>)
 575               (<==? .TPS TEMPLATE>
 576                <PUT-RECORD .STR .NUM .VDAT <RECTYPE? .TYP> .ETYP>)
 577               (ELSE <PUT-RECORD .STR .NUM .VDAT .TPS .ETYP>)>>
 578
 579 <DEFINE RECTYPE? (TYP)
 580         <COND (<ISTYPE? .TYP>)
 581               (<AND <TYPE? .TYP FORM SEGMENT>
 582                     <G? <LENGTH .TYP> 1>
 583                     <==? <1 .TYP> OR>>
 584                <RECTYPE? <2 .TYP>>)>>
 585
 586 <DEFINE PUTREST-GEN (NOD WHERE
 587                      "AUX" ST1 ST2 (K <KIDS .NOD>) (ONO .NO-KILL)
 588                            (NO-KILL .ONO) (2RET <>))
 589         #DECL ((NOD N) NODE (K) <LIST NODE NODE> (NO-KILL) <SPECIAL LIST>
 590                (ONO) LIST)
 591         <COND (<==? <NODE-SUBR .NOD> ,REST>
 592                <SET NOD <1 .K>>
 593                <SET K <KIDS .NOD>>
 594                <SET 2RET T>)>
 595         <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 596                     <==? <NODE-NAME <2 .K>> ()>>
 597                <SET ST1 <GEN <1 .K> DONT-CARE>>)
 598               (ELSE
 599                <SET ST1 <GEN <1 .K> DONT-CARE>>
 600                <SET ST1 <INTERF-CHANGE .ST1 <2 .K>>>
 601                <SET ST2 <GEN <2 .K> DONT-CARE>>)>
 602         <COND (<AND .CAREFUL <G? 1 <MINL <RESULT-TYPE <1 .K>>>>>
 603                <EMPTY-CHECK LIST .ST1 LIST>)>
 604         <COND (<ASSIGNED? ST2> <IEMIT `PUTREST .ST1 .ST2>)
 605               (ELSE <IEMIT `PUTREST .ST1 ()>)>
 606         <MOVE-ARG <COND (.2RET <FREE-TEMP .ST1> .ST2)
 607                         (ELSE <FREE-TEMP .ST2> .ST1)>
 608                   .WHERE>>
 609
 610 <DEFINE SIDE-EFFECTS? (N)
 611         #DECL ((N) NODE)
 612         <AND <N==? <NODE-TYPE .N> ,QUOTE-CODE> <SIDE-EFFECTS .N>>>
 613
 614 <DEFINE COMMUTE-STRUC (RV NUMNOD STRNOD "AUX" N (L .NO-KILL) CD (FLG T))
 615    #DECL ((NO-KILL) LIST (NUMNOD STRNOD) NODE (L) LIST)
 616    <COND (<OR <AND <NOT .RV>
 617                    <OR <AND <==? <NODE-TYPE .NUMNOD> ,QUOTE-CODE>
 618                             <NOT <SET FLG <>>>>
 619                        <NOT <SIDE-EFFECTS .NUMNOD>>>
 620                    <MEMQ <SET CD <NODE-TYPE <SET N .STRNOD>>> ,SNODES>>
 621               <AND .RV
 622                    <OR <AND <==? <NODE-TYPE .STRNOD> ,QUOTE-CODE>
 623                             <NOT <SET FLG <>>>>
 624                        <NOT <SIDE-EFFECTS .STRNOD>>>
 625                    <NOT <MEMQ <SET CD <NODE-TYPE <SET N .NUMNOD>>> ,SNODES>>>>
 626           <COND (<AND .FLG
 627                       <==? .CD ,LVAL-CODE>
 628                       <COND (<==? <LENGTH <SET CD <TYPE-INFO .N>>> 2> <2 .CD>)
 629                             (ELSE T)>
 630                       <SET CD <NODE-NAME .N>>
 631                       <NOT <MAPF <>
 632                                  <FUNCTION (LL)
 633                                          #DECL ((LL) <LIST SYMTAB ANY>)
 634                                          <AND <==? .CD <1 .LL>> <MAPLEAVE>>>
 635                                  .L>>>
 636                  <SET NO-KILL ((.CD <>) !.L)>)>
 637           <NOT .RV>)
 638          (ELSE .RV)>>
 639
 640 \\f
 641
 642 <DEFINE EMPTY-CHECK (TPS STR TYP "OPTIONAL" (DIR T) (TG `COMPERR))
 643         <COND (<OR <==? .TPS VECTOR>
 644                    <==? .TPS TUPLE>>
 645                <EMPTY-VECTOR .STR .TG .DIR>)
 646               (<==? .TPS UVECTOR> <EMPTY-UVECTOR .STR .TG .DIR>)
 647               (<==? .TPS STRING> <EMPTY-STRING .STR .TG .DIR>)
 648               (<==? .TPS BYTES> <EMPTY-BYTES .STR .TG .DIR>)
 649               (<==? .TPS LIST> <EMPTY-LIST .STR .TG .DIR>)
 650               (<==? .TPS TEMPLATE> '<EMPTY-RECORD .STR .TG .DIR .TYP>)
 651               (ELSE '<EMPTY-RECORD .STR .TG .DIR .TPS>)>>
 652
 653 <DEFINE LENGTH-CHECK (TPS STR NUM TYP "AUX" (TMP <GEN-TEMP FIX>))
 654         <PROG ()
 655               <COND (<OR <==? .TPS VECTOR>
 656                          <==? .TPS TUPLE>>
 657                      <LENGTH-VECTOR .STR .TMP>)
 658                     (<==? .TPS LIST> <LENGTH-LIST .STR .TMP>)
 659                     (<==? .TPS UVECTOR> <LENGTH-UVECTOR .STR .TMP>)
 660                     (<==? .TPS STRING> <LENGTH-STRING .STR .TMP>)
 661                     (<==? .TPS BYTES> <LENGTH-BYTES .STR .TMP>)
 662                     (ELSE
 663                      <FREE-TEMP .TMP>
 664                      <RETURN>)>
 665               <IEMIT `LESS? .TMP .NUM + `COMPERR '(`TYPE FIX)>
 666               <FREE-TEMP .TMP>>>
 667
 668 <DEFINE TOP-GEN (N W "AUX" D)
 669         #DECL ((N) NODE)
 670         <SET D <GEN <1 <KIDS .N>> DONT-CARE>>
 671         <FREE-TEMP .D <>>
 672         <IEMIT `TOPU .D = <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP>>)
 673                                 (<TYPE? .W TEMP> <USE-TEMP .W> .W)
 674                                 (ELSE .W)>>
 675         .W>
 676
 677 <DEFINE BACK-GEN (N W "AUX" D NN (K <KIDS .N>))
 678         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 679         <SET D <GEN <1 .K> DONT-CARE>>
 680         <COND (<OR <AND <EMPTY? <REST .K>> <SET NN 1>>
 681                    <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 682                         <SET NN <NODE-NAME <2 .K>>>>>
 683                <COND (<TYPE? .NN OFFSET>
 684                       <SET NN <INDEX .NN>>)>
 685                <FREE-TEMP .D <>>
 686                <IEMIT `BACKU
 687                       .D
 688                       .NN
 689                       =
 690                       <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP>>)
 691                             (<TYPE? .W TEMP> <USE-TEMP .W> .W)
 692                             (ELSE .W)>>)
 693               (ELSE
 694                <FREE-TEMP <SET NN <GEN <2 .K> DONT-CARE>> <>>
 695                <FREE-TEMP .D <>>
 696                <IEMIT `BACKU
 697                       .D
 698                       .NN
 699                       =
 700                       <COND (<==? .W DONT-CARE> <SET W <GEN-TEMP>>)
 701                             (<TYPE? .W TEMP> <USE-TEMP .W> .W)
 702                             (ELSE .W)>>)>
 703         .W>
 704
 705 <ENDPACKAGE>