<mdl.comp>/strana.mud.362

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