mim/development/mim/mimc/strana.mud

   1
   2 <PACKAGE "STRANA">
   3
   4 <ENTRY LENGTH-ANA
   5        EMPTY?-ANA
   6        LENGTH?-ANA
   7        NTH-ANA
   8        REST-ANA
   9        PUT-ANA
  10        PUTREST-ANA
  11        MEMQ-ANA
  12        NTH-REST-ANA
  13        MONAD-ANA
  14        BACK-ANA
  15        TOP-ANA>
  16
  17 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
  18
  19 "Structure hackers for the compiler (analyzers)"
  20
  21 <DEFINE LNTH-MT-ANA (NOD RTYP COD
  22                      "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM (WHO ())
  23                            (TY BOOLEAN)
  24                            (WHON
  25                             <AND <OR <AND <==? .COD ,LNTH-CODE>
  26                                           <ASSIGNED? GLN>
  27                                           <ANCEST .GLN <PARENT .NOD>>>
  28                                      <AND <==? .PRED <PARENT .NOD>>
  29                                           <==? .COD ,MT-CODE>>>
  30                                  .NOD>))
  31    #DECL ((NOD) NODE (LN COD) FIX (K) <LIST [REST NODE]> (WHO) <SPECIAL LIST>
  32           (WHON) <SPECIAL <OR NODE FALSE>>)
  33    <COND
  34     (<SEGFLUSH .NOD .RTYP>)
  35     (ELSE
  36      <ARGCHK .LN 1 <NODE-NAME .NOD> .NOD>
  37      <SET TEM <STRUCTYP <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>>
  38      <COND
  39       (<OR .TEM <==? .COD ,MT-CODE>>
  40        <PUT .NOD ,NODE-TYPE .COD>
  41        <SET TY BOOLEAN>)
  42       (ELSE
  43        <COND (.VERBOSE
  44               <ADDVMESS .NOD
  45                         ("Not open compiled because type is:  "
  46                          <RESULT-TYPE <1 .K>>)>)>
  47        <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
  48    <COND (<==? .COD ,MT-CODE>
  49           <MAPF <>
  50                 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
  51                         #DECL ((L) <LIST <OR FALSE ATOM> SYMTAB> (SYM) SYMTAB)
  52                         '<SET TRUTH
  53                               <ADD-TYPE-LIST .SYM
  54                                              '<STRUCTURED [REST <NOT ANY>]>
  55                                              .TRUTH
  56                                              .FLG
  57                                              <REST .L 2>>>
  58                         <SET UNTRUTH
  59                              <ADD-TYPE-LIST .SYM
  60                                             '<STRUCTURED ANY>
  61                                             .UNTRUTH
  62                                             .FLG
  63                                             <REST .L 2>>>
  64                         T>
  65                 .WHO>)
  66          (ELSE <SET GLE .WHO>)>
  67    <TYPE-OK? <COND (<==? <NODE-SUBR .NOD> ,LENGTH> <FORM FIX (0 ,PLUSINF)>)
  68                    (ELSE .TY)>
  69              .RTYP>>
  70
  71 <DEFINE ANCEST (N1 N2)
  72         #DECL ((N1 N2) NODE)
  73         <REPEAT ()
  74                 <COND (<==? .N1 .N2> <RETURN>)>
  75                 <OR <==? <NODE-TYPE .N2> ,SET-CODE> <RETURN <>>>
  76                 <COND (<TYPE? <PARENT .N2> NODE> <SET N2 <PARENT .N2>>)
  77                       (ELSE <RETURN <>>)>>>
  78
  79 <DEFINE LENGTH-ANA (N R) <LNTH-MT-ANA .N .R ,LNTH-CODE>>
  80
  81 <DEFINE EMPTY?-ANA (N R) <LNTH-MT-ANA .N .R ,MT-CODE>>
  82
  83 <COND (<GASSIGNED? LENGTH-ANA>
  84        <PUTPROP ,EMPTY? ANALYSIS ,EMPTY?-ANA>
  85        <PUTPROP ,LENGTH ANALYSIS ,LENGTH-ANA>)>
  86
  87 <DEFINE LENGTH?-ANA (NOD RTYP
  88                      "AUX" (K <KIDS .NOD>) TEM (WHO ())
  89                            (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>))
  90    #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON) <SPECIAL ANY>
  91           (WHO) <SPECIAL LIST>)
  92    <COND
  93     (<SEGFLUSH .NOD .RTYP>)
  94     (ELSE
  95      <ARGCHK <LENGTH .K> 2 LENGTH? .NOD>
  96      <SET TEM <EANA <1 .K> STRUCTURED LENGTH?>>
  97      <SET WHON <>>
  98      <EANA <2 .K> FIX LENGTH?>
  99      <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>            ;"Constant 2d arg?"
 100             <MAPF <>
 101                   <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
 102                           #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
 103                           <SET UNTRUTH
 104                                <ADD-TYPE-LIST
 105                                 .SYM
 106                                 <FORM STRUCTURED [<NODE-NAME <2 .K>> ANY]>
 107                                 .TRUTH
 108                                 .FLG
 109                                 <REST .L 2>>>>
 110                   .WHO>)>
 111      <COND (<SET TEM <STRUCTYP .TEM>> <PUT .NOD ,NODE-TYPE ,LENGTH?-CODE>)
 112            (ELSE
 113             <COND (.VERBOSE
 114                    <ADDVMESS .NOD
 115                              ("Not open compiled because type is:  "
 116                               <RESULT-TYPE <1 .K>>)>)>
 117             <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
 118      <TYPE-OK? <FORM OR
 119                      <FORM FIX
 120                            (0
 121                             <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 122                                    <NODE-NAME .NOD>)
 123                                   (ELSE ,PLUSINF)>)>
 124                      FALSE>
 125                .RTYP>)>>
 126
 127 <COND (<GASSIGNED? LENGTH?-ANA> <PUTPROP ,LENGTH? ANALYSIS ,LENGTH?-ANA>)>
 128
 129 <DEFINE MONAD-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM)
 130         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
 131         <COND (<SEGFLUSH .NOD .RTYP>
 132                <TYPE-OK? .RTYP BOOLEAN>)
 133               (ELSE
 134                <ARGCHK .LN 1 MONAD? .NOD>
 135                <SET TEM <EANA <1 .K> STRUCTURED <NODE-NAME .NOD>>>
 136                <PUT .NOD ,NODE-TYPE ,MONAD-CODE>
 137                <TYPE-OK? .RTYP BOOLEAN>)>>
 138
 139 <COND (<GASSIGNED? MONAD-ANA> <PUTPROP ,MONAD? ANALYSIS ,MONAD-ANA>)>
 140
 141 <DEFINE NTH-REST-ANA (NOD RTYP COD
 142                       "OPTIONAL" (TF <>)
 143                       "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TS VAL TPS
 144                             (RV <OR .TF <==? <NODE-NAME .NOD> INTH>>)
 145                             (SVWHO ()) AMT PT
 146                             (NM <COND (.RV NTH) (ELSE <NODE-NAME .NOD>)>) XX
 147                             (OWHON <AND <==? .WHON <PARENT .NOD>> .NOD>) NUMB)
 148    #DECL ((COD NUMB LN) FIX (NOD WHON PRED) NODE (K) <LIST [REST NODE]>
 149           (WHO SVWHO) LIST)
 150    <SET VAL
 151     <PROG ((WHO ()) (WHON <>))
 152       #DECL ((WHON) <SPECIAL ANY> (WHO) <SPECIAL LIST>)
 153       <COND
 154        (<SEGFLUSH .NOD .RTYP>)
 155        (ELSE
 156         <COND (<1? .LN>
 157                <PUT .NOD
 158                     ,KIDS
 159                     <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
 160               (ELSE <ARGCHK .LN 2 <NODE-NAME .NOD> .NOD>)>
 161         <COND (.RV
 162                <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>
 163                <SET WHON .NOD>
 164                <SET TS <EANA <1 .K> STRUCTURED .NM>>)
 165               (ELSE
 166                <SET WHON .NOD>
 167                <SET TS <EANA <1 .K> STRUCTURED .NM>>
 168                <SET WHON <>>
 169                <OR .TF <SET TF <EANA <2 .K> '<OR FIX OFFSET> .NM>>>)>
 170         <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 171                     <SET AMT <NODE-NAME <2 .K>>>
 172                     <==? <ISTYPE? .TF> OFFSET>>
 173                <SET TS <TYPE-AND .TS <GET-DECL .AMT>>>
 174                <SET AMT <INDEX .AMT>>
 175                <PUT <1 .K> ,RESULT-TYPE .TS>)>
 176         <COND (<ASSIGNED? AMT>
 177                <COND (<==? .COD ,NTH-CODE>
 178                       <COND (<==? .AMT 1>
 179                              <SET TS <TYPE-AND .TS <FORM STRUCTURED .RTYP>>>)
 180                             (ELSE
 181                              <SET TS <TYPE-AND .TS <FORM STRUCTURED
 182                                                          [<- .AMT 1> ANY]
 183                                                          .RTYP>>>)>)
 184                      (<SET PT <STRUCTYP .RTYP>>
 185                       <COND (<==? .AMT 0>
 186                              <SET TS <TYPE-AND .TS <FORM PRIMTYPE .PT>>>)
 187                             (ELSE
 188                              <SET TS <TYPE-AND .TS <FORM <FORM PRIMTYPE .PT>
 189                                                          [.AMT ANY]>>>)>)
 190                      (<N==? .AMT 0>
 191                       <SET TS <TYPE-AND .TS <FORM STRUCTURED [.AMT ANY]>>>)>)
 192               (<==? .COD ,NTH-CODE>
 193                <SET TS <TYPE-AND .TS <FORM STRUCTURED ANY>>>)
 194               (<SET PT <STRUCTYP .RTYP>>
 195                <SET TS <TYPE-AND .TS <FORM PRIMTYPE .PT>>>)>
 196         <PUT <1 .K> ,RESULT-TYPE .TS>
 197         <SET TPS <STRUCTYP .TS>>
 198         <COND (<AND .TPS <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
 199                <SET SVWHO .WHO>)>
 200         <COND
 201          (<OR <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 202                    <==? <NODE-NAME <2 .K>> 1>>
 203               <AND .TPS
 204                    <OR <==? <ISTYPE? .TF> FIX>
 205                        <AND <==? <ISTYPE? .TF> OFFSET>
 206                             <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
 207                        <AND <TYPE-OK? .TF FIX>
 208                             <N==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>>>
 209           <PUT .NOD ,NODE-TYPE .COD>)
 210          (ELSE
 211           <AND <==? .COD ,NTH-CODE> <PUT .NOD ,NODE-NAME NTH>>
 212           <COND (.VERBOSE
 213                  <ADDVMESS .NOD ("Not open compiled because type is:  " .TS)>)>
 214           <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
 215         <TYPE-OK?
 216          <GET-ELE-TYPE
 217           .TS
 218           <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 219                  <SET NUMB
 220                       <COND (<==? <ISTYPE? .TF> OFFSET>
 221                              <INDEX <NODE-NAME <2 .K>>>)
 222                             (ELSE <NODE-NAME <2 .K>>)>>)
 223                 (ELSE ALL)>
 224           <==? <NODE-SUBR .NOD> ,REST>>
 225          .RTYP>)>>>
 226    <MAPF <>
 227          <FUNCTION (L "AUX" (SYM <2 .L>) (FL <1 .L>) T1 T2)
 228                  #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
 229                  <SET XX (.NM .NUMB !<REST .L 2>)>
 230                  <SET-CURRENT-TYPE
 231                   .SYM
 232                   <TYPE-AND <GET-CURRENT-TYPE .SYM> <TYPE-NTH-REST .VAL .XX>>>
 233                  <COND (.OWHON <SET WHO ((.FL .SYM !.XX) !.WHO)>)>
 234                  <COND (<AND <==? .PRED <PARENT .NOD>>
 235                              <SET T1 <TYPE-OK? .VAL FALSE>>
 236                              <SET T2 <TYPE-OK? .VAL '<NOT FALSE>>>>
 237                         <SET TRUTH <ADD-TYPE-LIST .SYM .T2 .TRUTH .FL .XX>>
 238                         <SET UNTRUTH
 239                              <ADD-TYPE-LIST .SYM .T1 .UNTRUTH .FL .XX>>)>>
 240          .SVWHO>
 241    <COND (<AND <==? .TPS LIST>
 242                <OR <==? <NODE-TYPE <1 .K>> ,LVAL-CODE>
 243                    <==? <NODE-TYPE <1 .K>> ,SET-CODE>>
 244                <LOOK-FOR .NOD <1 .K> <2 .K> <==? <NODE-SUBR .NOD> ,REST>>>
 245           <PUT .NOD ,NODE-TYPE ,ALL-REST-CODE>)
 246          (<AND <==? .TPS LIST>
 247                <==? .COD ,REST-CODE>
 248                <GASSIGNED? PUT-SAME-CODE>
 249                <==? <NODE-TYPE <1 .K>> ,PUTR-CODE>
 250                <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 251                <==? .NUMB 1>>
 252           <PUT .NOD ,NODE-TYPE ,PUTR-CODE>)>
 253    .VAL>
 254
 255 <DEFINE LOOK-FOR (MN N1 N RFLG "AUX" TT K (S ()) (SS (() () ())))
 256         #DECL ((S) <LIST [REST NODE]> (N MN N1) NODE (TT) <OR FALSE NODE>
 257                (K) <LIST [REST NODE]>)
 258         <REPEAT ()
 259                 <COND (<==? <NODE-TYPE .N1> ,LVAL-CODE>
 260                        <SET S (.N1 !.S)>
 261                        <RETURN>)
 262                       (<==? <NODE-TYPE .N1> ,SET-CODE>
 263                        <SET S (.N1 !.S)>
 264                        <SET N1 <2 <KIDS .N1>>>)
 265                       (ELSE <RETURN>)>>
 266         <AND <OR <AND .RFLG
 267                       <SET TT <SET-SEARCH .N ,ARITH-CODE .S .SS>>
 268                       <==? <NODE-SUBR <SET N .TT>> ,->
 269                       <==? <LENGTH <SET K <KIDS .N>>> 2>
 270                       <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 271                       <==? <NODE-NAME <2 .K>> 1>
 272                       <SET N <1 .K>>>
 273                  <NOT .RFLG>>
 274              <SET TT <SET-SEARCH .N ,LNTH-CODE .S <REST .SS>>>
 275              <SET TT <SET-SEARCH <1 <KIDS .TT>> ,LVAL-CODE .S <REST .SS 2>>>
 276              <SMEMQ <NODE-NAME .TT> .S>
 277              <PUT .MN ,TYPE-INFO .SS>>>
 278
 279 <DEFINE SET-SEARCH (N C S SS "AUX" (L ()))
 280         #DECL ((N) NODE (C) FIX (S) <LIST [REST NODE]> (L SS) LIST)
 281         <REPEAT ()
 282                 <COND (<==? .C <NODE-TYPE .N>> <PUT .SS 1 .L> <RETURN .N>)>
 283                 <COND (<OR <N==? <NODE-TYPE .N> ,SET-CODE>
 284                            <SMEMQ <NODE-NAME .N> .S>>
 285                        <RETURN <>>)>
 286                 <SET L (.N !.L)>
 287                 <SET N <2 <KIDS .N>>>>>
 288
 289 <DEFINE SMEMQ (SYM L)
 290         #DECL ((SYM) SYMTAB (L) LIST)
 291         <MAPR <>
 292               <FUNCTION (LL "AUX" (N <1 .LL>))
 293                       #DECL ((N) NODE)
 294                       <COND (<==? <NODE-NAME .N> .SYM> <MAPLEAVE .LL>)>>
 295               .L>>
 296
 297 <DEFINE NTH-ANA (N R) <NTH-REST-ANA .N .R ,NTH-CODE>>
 298
 299 <DEFINE REST-ANA (N R) <NTH-REST-ANA .N .R ,REST-CODE>>
 300
 301 <COND (<GASSIGNED? NTH-ANA>
 302        <PUTPROP ,NTH ANALYSIS ,NTH-ANA>
 303        <PUTPROP ,REST ANALYSIS ,REST-ANA>)>
 304
 305 <DEFINE PUT-ANA (NOD RTYP
 306                  "OPTIONAL" (TF <>)
 307                  "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) (TS ANY) TV (TPS <>)
 308                        VAL (SVWHO ()) WHICH NS TVO TEM (P ()) TFF NUMB
 309                        (RV <OR .TF <==? <NODE-NAME .NOD> IPUT>>) AMT
 310                        (NM <COND (.RV PUT) (ELSE <NODE-NAME .NOD>)>))
 311    #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN NUMB) FIX (WHO P SVWHO) LIST)
 312    <SET VAL
 313     <PROG ((WHO ()) (WHON <>))
 314       #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL <OR FALSE NODE>>)
 315       <COND
 316        (<SEGFLUSH .NOD .RTYP>)
 317        (ELSE
 318         <ARGCHK .LN 3 <NODE-NAME .NOD> .NOD>
 319         <COND (.RV
 320                <SET WHON <>>
 321                <OR .TF <SET TF <SET TFF <EANA <2 .K> '<OR FIX OFFSET> PUT>>>>
 322                <SET WHON .NOD>
 323                <SET TS <ANA <1 .K> STRUCTURED>>
 324                <SET WHON <>>)
 325               (ELSE
 326                <SET WHON .NOD>
 327                <SET TS <ANA <1 .K> STRUCTURED>>
 328                <SET WHON <>>
 329                <OR .TF <SET TFF <SET TF <EANA <2 .K> '<OR FIX OFFSET> PUT>>>>)>
 330         <SET TV <ANA <3 .K> ANY>>
 331         <COND (<AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 332                     <SET AMT <NODE-NAME <2 .K>>>
 333                     <==? <ISTYPE? .TF> OFFSET>>
 334                <SET TS <TYPE-AND .TS <GET-DECL <NODE-NAME <2 .K>>>>>
 335                <SET AMT <INDEX .AMT>>
 336                <PUT <1 .K> ,RESULT-TYPE .TS>)>
 337         <OR <AND <OR <==? <ISTYPE? .TF> FIX>
 338                      <AND <==? <ISTYPE? .TF> OFFSET>
 339                           <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>>
 340                  <==? <NODE-SUBR .NOD> ,PUT>>
 341             <SET TF <>>>
 342         <SET NS
 343              <COND (<AND .TF .TS <ASSIGNED? AMT>>
 344                     <SET WHICH .AMT>
 345                     <FORM STRUCTURED
 346                           !<COND (<1? .WHICH> (ANY))
 347                                  (ELSE ([<- .WHICH 1> ANY] ANY))>>)
 348                    (ELSE <SET WHICH ALL> '<STRUCTURED ANY>)>>
 349         <SET TS <TYPE-AND .TS .NS>>
 350         <COND
 351          (<AND <N==? .WHICH ALL> <N==? .TV ANY>>
 352           <COND
 353            (<OR
 354              <NOT <TYPE? .TS FORM SEGMENT>>
 355              <COND
 356               (<==? <1 .TS> OR>
 357                <MAPF <>
 358                 <FUNCTION (X!-INITIAL)
 359                         <COND
 360                          (<AND <TYPE? .X!-INITIAL FORM>
 361                                <==? <REST .X!-INITIAL
 362                                           <- <LENGTH .X!-INITIAL> 1>>
 363                                     <REST .NS <- <LENGTH .NS> 1>>>>
 364                           <MAPLEAVE <>>)
 365                          (ELSE T)>>
 366                 <REST .TS>>)
 367               (ELSE
 368                <N==? <REST .NS <- <LENGTH .NS> 1>>
 369                      <REST .TS <- <LENGTH .TS> 1>>>)>>
 370             <PUT .NS <LENGTH .NS> .TV>)
 371            (ELSE <PUT <SET NS <FORM !.NS>> <LENGTH .NS> .TV>)>)>
 372         <COND
 373          (<AND .TS .TF <NOT <EMPTY? .WHO>>>
 374           <SET NS
 375            <MAPF ,TYPE-MERGE
 376             <FUNCTION (L "AUX" (S <2 .L>) (ND <DECL-SYM .S>))
 377                #DECL ((L) <LIST ANY SYMTAB> (S) SYMTAB)
 378                <SET ND <DECL-DOWN .ND !<REST .L 2!>>>
 379                <COND (<NOT <SET ND <TYPE-AND .ND .NS>>>
 380                       <COMPILE-ERROR "Bad argument to PUT " .NOD>)>
 381                <SET ND
 382                 <TYPE-AND
 383                  <TOP-TYPE <DECL-DOWN <GET-CURRENT-TYPE .S> !<REST .L 2!>>>
 384                  .ND>>>
 385             .WHO>>
 386           <SET TV <TYPE-AND .TV <GET-ELE-TYPE .NS .WHICH>>>)
 387          (<NOT <EMPTY? .WHO>> <SET TV ANY>)>
 388         <AND .TS
 389              <PUT <1 .K> ,RESULT-TYPE <SET TS <TYPE-AND <TOP-TYPE .NS> .TS>>>>
 390         <COND (.TS
 391                <SET TVO <GET-ELE-TYPE .TS .WHICH>>
 392                <SET TS <GET-ELE-TYPE .TS .WHICH <> .TV>>)>
 393         <COND (<AND .TS .TF <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
 394                <SET SVWHO .WHO>)>
 395         <COND (<AND .TS .TF>
 396                <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD!>)>)>
 397         <COND
 398          (<AND .TS
 399                .TF
 400                <SET TPS <STRUCTYP .TS>>
 401                <OR <==? <ISTYPE? .TF> FIX> <==? <ISTYPE? .TF> OFFSET>>>
 402           <PUT .NOD ,NODE-TYPE ,PUT-CODE>
 403           <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 404                       <NOT ,INTERPRETER-IMPLEMENTOR?>>
 405                  <COMPILE-ERROR "Attempt to PUT in quoted object " .NOD>)>)
 406          (ELSE
 407           <COND (<AND .VERBOSE <==? <NODE-SUBR .NOD> ,PUT>>
 408                  <ADDVMESS .NOD ("Not open compiled because type is: " .TS)>)>
 409           <PUT .NOD ,NODE-TYPE ,IPUT-CODE>
 410           <PUT .NOD ,NODE-NAME PUT>)>)>
 411       <PUT-FLUSH <OR .TPS ALL>>
 412       <TYPE-OK? <COND (.TS .TS) (ELSE ANY)> .RTYP>>>
 413    <COND
 414     (<==? <NODE-TYPE .NOD> ,PUT-CODE>
 415      <MAPF <>
 416       <FUNCTION (L "AUX" (SYM <2 .L>))
 417               #DECL ((L) <LIST ANY SYMTAB [REST ATOM FIX]> (SYM) SYMTAB)
 418               <SET-CURRENT-TYPE
 419                .SYM
 420                <PUT-TYPE-HACK <GET-CURRENT-TYPE .SYM>
 421                               .TS
 422                               <LPR <REST .L 2>>
 423                               .WHICH
 424                               0>>>
 425       .SVWHO>)>
 426    <COND (<AND <==? <NODE-TYPE .NOD> ,PUT-CODE>
 427                <GASSIGNED? PUT-SAME-CODE>
 428                <MEMQ .TPS '[LIST VECTOR UVECTOR TUPLE STRING BYTES]>
 429                <MAPF <>
 430                      <FUNCTION (N)
 431                              <COND (<AND <G=? <LENGTH .N>
 432                                               <INDEX ,SIDE-EFFECTS>>
 433                                          <SIDE-EFFECTS .N>>
 434                                     <MAPLEAVE <>>)
 435                                    (ELSE T)>>
 436                      .K>
 437                <MEMQ <NODE-TYPE <3 .K>> ,HACK-NODES>
 438                <==? <ISTYPE? <RESULT-TYPE <3 .K>>> FIX>
 439                <NOT <EMPTY? <SET TEM <KIDS <3 .K>>>>>
 440                <NOT <OR <==? <NODE-SUBR <3 .K>> ,/>
 441                         <AND <==? <NODE-SUBR <3 .K>> ,->
 442                              <NOT <AND <==? <LENGTH .TEM> 2>
 443                                        <==? <NODE-NAME <2 .TEM>> 1>>>>>>
 444                <MAPR <>
 445                      <FUNCTION (L "AUX" (N <1 .L>))
 446                              <COND (<AND <==? <NODE-TYPE .N> ,NTH-CODE>
 447                                          <SAME-OBJ <1 .K> <1 <KIDS .N>>>
 448                                          <SAME-OBJ <2 .K> <2 <KIDS .N>>>>
 449                                     <COND (<NOT <EMPTY? .P>>
 450                                            <PUTREST .P <REST .L>>
 451                                            <SET TEM (.N !.TEM)>)>
 452                                     <MAPLEAVE>)>
 453                              <SET P .L>
 454                              <>>
 455                      .TEM>>
 456           <PUT <3 .K> ,KIDS .TEM>
 457           <PUT .NOD ,NODE-TYPE ,PUT-SAME-CODE>)>
 458    .VAL>
 459
 460 <DEFINE PUT-TYPE-HACK (TY TS L WHICH EX)
 461         #DECL ((L) <LIST [REST FIX ATOM]>)
 462         <COND
 463          (<EMPTY? .L> .TS)
 464          (<AND <EMPTY? <REST .L 2>> <==? <2 .L> REST>>
 465           <GET-ELE-TYPE .TY
 466                         <+ <1 .L> .WHICH>
 467                         <>
 468                         <PUT-TYPE-HACK <GET-ELE-TYPE .TS .WHICH>
 469                                        .TS
 470                                        <REST .L 2>
 471                                        .WHICH
 472                                        0>>)
 473          (<==? <2 .L> REST> <PUT-TYPE-HACK .TY .TS <REST .L 2> .WHICH <1 .L>>)
 474          (ELSE
 475           <GET-ELE-TYPE
 476            .TY
 477            <+ <1 .L> .EX>
 478            <>
 479            <PUT-TYPE-HACK <GET-ELE-TYPE .TY <+ <1 .L> .EX>>
 480                           .TS
 481                           <REST .L 2>
 482                           .WHICH
 483                           0>>)>>
 484
 485 <DEFINE LPR (L)
 486         #DECL ((VALUE L) LIST)
 487         <COND (<EMPTY? .L> .L) (ELSE (!<LPR <REST .L>> <1 .L>))>>
 488
 489 <SETG HACK-NODES [,ABS-CODE ,ARITH-CODE]>
 490
 491 <COND (<GASSIGNED? PUT-ANA> <PUTPROP ,PUT ANALYSIS ,PUT-ANA>)>
 492
 493 <DEFINE SAME-OBJ (N1 N2)
 494         #DECL ((N1 N2) NODE)
 495         <COND (<==? <NODE-TYPE .N1> <NODE-TYPE .N2>>
 496                <COND (<MEMQ <NODE-TYPE .N1> ,SNODES>
 497                       <==? <NODE-NAME .N1> <NODE-NAME .N2>>)
 498                      (ELSE
 499                       <MAPF <>
 500                             <FUNCTION (N3 N4)
 501                                     <COND (<SAME-OBJ .N3 .N4>)
 502                                           (ELSE <MAPLEAVE <>>)>>
 503                             <KIDS .N1>
 504                             <KIDS .N2>>)>)>>
 505
 506 <DEFINE DECL-DOWN ("TUPLE" TUP "AUX" (ND <1 .TUP>) (LN <- <LENGTH .TUP> 1>))
 507         #DECL ((TUP) TUPLE (LN) FIX)
 508         <REPEAT ()
 509                 <COND (<L? .LN 2> <RETURN .ND>)
 510                       (ELSE
 511                        <SET ND
 512                             <GET-ELE-TYPE .ND
 513                                           <NTH .TUP <+ .LN 1>>
 514                                           <==? <NTH .TUP .LN> REST>>>)>
 515                 <SET LN <- .LN 2>>>>
 516
 517 <DEFINE DECL-UP (NX L)
 518         #DECL ((L) LIST)
 519         <REPEAT ((FIRST T) (NUM 0))
 520                 #DECL ((NUM) FIX (L) LIST)
 521                 <COND (<EMPTY? .L> <RETURN .NX>)>
 522                 <COND (<==? <1 .L> NTH>
 523                        <SET NX
 524                             <FORM STRUCTURED
 525                                   !<COND (<0? <SET NUM <+ .NUM <2 .L> -1>>> ())
 526                                          (<1? .NUM> (ANY))
 527                                          (ELSE ([.NUM ANY]))>
 528                                   .NX>>
 529                        <SET NUM 0>
 530                        <SET FIRST <>>)
 531                       (.FIRST <SET NX <REST-DECL .NX <2 .L>>>)
 532                       (ELSE <SET NUM <+ .NUM <2 .L>>>)>
 533                 <SET L <REST .L 2>>>>
 534
 535 <DEFINE PUTREST-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) T1 T2)
 536         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
 537         <COND (<==? <NODE-SUBR .NOD> ,REST> <REST-ANA .NOD .RTYP>)
 538               (<SEGFLUSH .NOD .RTYP>
 539                <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
 540                <TYPE-OK? '<PRIMTYPE LIST> .RTYP>)
 541               (ELSE
 542                <ARGCHK <LENGTH .K> 2 PUTREST .NOD>
 543                <SET T1 <EANA <1 .K> '<PRIMTYPE LIST> PUTREST>>
 544                <SET T2 <EANA <2 .K> '<PRIMTYPE LIST> PUTREST>>
 545                <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 546                       <COMPILE-ERROR "Attempt to PUTREST in quoted object "
 547                                      .NOD>)>
 548                <PUT .NOD ,NODE-TYPE ,PUTR-CODE>
 549                <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
 550                <TYPE-OK? .T1 .RTYP>)>>
 551
 552 <COND (<GASSIGNED? PUTREST-ANA> <PUTPROP ,PUTREST ANALYSIS ,PUTREST-ANA>)>
 553
 554 <DEFINE MEMQ-ANA (N R "AUX" (K <KIDS .N>) TYP VTYP STYP ETY)
 555    #DECL ((N) NODE (K) <LIST [REST NODE]>)
 556    <COND
 557     (<SEGFLUSH .N .R>)
 558     (ELSE
 559      <ARGCHK <LENGTH .K> 2 MEMQ .N>
 560      <SET VTYP <EANA <1 .K> ANY MEMQ>>
 561      <SET TYP <EANA <2 .K> STRUCTURED MEMQ>>
 562      <COND (<NOT <TYPE-OK? .VTYP <SET ETY <GET-ELE-TYPE .TYP ALL>>>>
 563             <COMPILE-WARNING "MEMQ never true " .N>)>
 564      <COND (<AND <SET STYP <STRUCTYP .TYP>> <N==? .STYP TEMPLATE>>
 565             <PUT .N ,NODE-TYPE ,MEMQ-CODE>)
 566            (ELSE
 567             <COND (.VERBOSE
 568                    <ADDVMESS .N
 569                              ("Not efficiently  open compiled because type is:  " .TYP)>)>
 570             <PUT .N ,NODE-TYPE ,MEMQ-CODE>)>
 571      <TYPE-OK? <TYPE-MERGE BOOL-FALSE
 572                            <COND (<AND .ETY <N==? .ETY ANY>>
 573                                   <FORM <COND (.STYP) (STRUCTURED)>
 574                                         .ETY
 575                                         [REST .ETY]>)
 576                                  (.STYP <FORM .STYP ANY>)
 577                                  ('<STRUCTURED ANY>)>>
 578                .R>)>>
 579
 580 <DEFINE TOP-ANA (N R "AUX" (K <KIDS .N>))
 581         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 582         <COND (<SEGFLUSH .N .R>)
 583               (ELSE
 584                <ARGCHK <LENGTH .K> 1 TOP .N>
 585                <SET TYP <EANA <1 .K> STRUCTURED TOP>>
 586                <COND (<AND <SET TYP <STRUCTYP .TYP>> <==? .TYP LIST>>
 587                       <COMPIL-ERROR "Cant TOP a list: " .N>)>
 588                <PUT .N ,NODE-TYPE ,TOP-CODE>
 589                <TYPE-OK? <COND (.TYP) (ELSE STRUCTURED)> .R>)>>
 590
 591 <DEFINE BACK-ANA (N R "AUX" (K <KIDS .N>))
 592         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 593         <COND (<SEGFLUSH .N .R>)
 594               (ELSE
 595                <ARGCHK <LENGTH .K> '(1 2) BACK .N>
 596                <SET TYP <EANA <1 .K> STRUCTURED TOP>>
 597                <COND (<AND <SET TYP <STRUCTYP .TYP>> <==? .TYP LIST>>
 598                       <COMPIL-ERROR "Cant BACK a list: " .N>)>
 599                <COND (<NOT <EMPTY? <REST .K>>> <EANA <2 .K> FIX BACK>)>
 600                <PUT .N ,NODE-TYPE ,BACK-CODE>
 601                <TYPE-OK? <COND (.TYP) (ELSE STRUCTURED)> .R>)>>
 602
 603 <COND (<GASSIGNED? BACK-ANA> <PUTPROP ,BACK ANALYSIS ,BACK-ANA>)>
 604
 605 <COND (<GASSIGNED? TOP-ANA> <PUTPROP ,TOP ANALYSIS ,TOP-ANA>)>
 606
 607 <COND (<GASSIGNED? MEMQ-ANA> <PUTPROP ,MEMQ ANALYSIS ,MEMQ-ANA>)>
 608
 609 <ENDPACKAGE>