<mdl.comp>/backan.mud.3

   1 <PACKAGE "BACKAN">
   2
   3 <ENTRY BACK-ANA TOP-ANA SUBSTRUC-ANA>
   4
   5 <USE "CHKDCL" "COMPDEC" "SYMANA">
   6
   7 <DEFINE BACK-ANA (NOD RTYP "AUX" TF TS (K <KIDS .NOD>) (LN <LENGTH .K>) TPS)
   8    #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
   9    <COND
  10     (<SEGFLUSH .NOD .RTYP>)
  11     (ELSE
  12      <COND (<1? .LN>
  13             <PUT .NOD
  14                  ,KIDS
  15                  <SET K (<1 .K> <NODE1 ,QUOTE-CODE .NOD FIX 1 ()>)>>)
  16            (ELSE <ARGCHK .LN 2 BACK>)>
  17      <SET TS <EANA <1 .K> STRUCTURED BACK>>
  18      <SET TF <EANA <2 .K> FIX BACK>>
  19      <COND (<NOT <OR <NOT <SET TPS <STRUCTYP .TS>>>
  20                      <==? .TPS TUPLE>
  21                      <==? .TPS VECTOR>
  22                      <==? .TPS STRING>
  23                      <==? .TPS TEMPLATE>
  24                      <==? .TPS UVECTOR>>>
  25             <MESSAGE ERROR "BAD 1ST ARG TO BACK" .NOD>)>
  26      <TYPE-OK?
  27       <COND (<OR <NOT .TPS> <==? .TPS STRING> <==? .TPS TEMPLATE>>
  28              <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
  29              .TPS)
  30             (ELSE
  31              <PUT .NOD ,NODE-TYPE ,BACK-CODE>
  32              <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
  33                     <TYPE-AND <REST-DECL .TS <NODE-NAME <2 .K>>> .TPS>)
  34                    (ELSE .TPS)>)>
  35       .RTYP>)>>
  36
  37 <PUT ,BACK ANALYSIS ,BACK-ANA>
  38
  39 <DEFINE TOP-ANA (N R "AUX" (K <KIDS .N>) TS TPS) #DECL ((N) NODE (K) <LIST [REST NODE]>)
  40         <COND (<SEGFLUSH .N .R>)
  41               (ELSE
  42                <ARGCHK <LENGTH .K> 1 TOP>
  43                <SET TS <EANA <1 .K> STRUCTURED TOP>>
  44                <COND (<AND <SET TPS <STRUCTYP .TS>>
  45                            <MEMQ .TPS '![VECTOR UVECTOR TUPLE]>>
  46                       <PUT .N ,NODE-TYPE ,TOP-CODE>
  47                       <TYPE-OK? .R .TPS>)
  48                      (<==? .TPS LIST>
  49                       <MESSAGE ERROR " BAD ARG TO TOP ">)
  50                      (ELSE
  51                       <PUT .N ,NODE-TYPE ,ISUBR-CODE>
  52                       <TYPE-OK? .R <COND (.TPS)(ELSE STRUCTURED)>>)>)>>
  53
  54 <PUT ,TOP ANALYSIS ,TOP-ANA>
  55
  56 "ROUTINE TO ANALYZE SUBSTRUCS"
  57
  58 <DEFINE SUBSTRUC-ANA (NOD RTYP
  59                       "AUX" RNODE K FRST-ARG TS TF TYP LN FD TPS NUM NN SN
  60                             (ALRDY <==? <NODE-TYPE .NOD> ,SUBSTRUC-CODE>) TEM)
  61    #DECL ((FRST-ARG RNODE NOD) NODE (K) <LIST [REST NODE]>
  62           (FLG) <OR ATOM FALSE> (NUM) FIX)
  63    <COND
  64     (<SEGFLUSH .NOD .RTYP>)
  65     (ELSE
  66      <SET K <KIDS .NOD>>
  67      <COND (<0? <SET LN <LENGTH .K>>>
  68             <MESSAGE ERROR "TOO FEW ARGS TO SUBSTRUC">)>
  69      <SET FD <EANA <SET FRST-ARG <1 .K>> STRUCTURED SUBSTRUC>>
  70      <COND (<AND .ALRDY <G? .LN 1> <==? <NODE-TYPE <1 .K>> ,REST-CODE>>
  71             <SET SN <1 <KIDS <1 .K>>>>
  72             <SET NN <2 <KIDS <1 .K>>>>
  73             <PUT .NN ,PARENT .NOD>
  74             <PUT .SN ,PARENT .NOD>
  75             <SET LN <+ .LN 1>>
  76             <PUT .NOD ,KIDS <SET K (.SN .NN !<REST .K>)>>)>
  77      <AND <G? .LN 1> <EANA <2 .K> FIX SUBSTRUC>>
  78      <AND <G? .LN 2> <EANA <3 .K> FIX SUBSTRUC>>
  79      <AND <G? .LN 3> <EANA <4 .K> STRUCTURED SUBSTRUC>>
  80      <COND
  81       (<OR <==? <SET TPS <STRUCTYP .FD>> VECTOR>
  82            <==? .TPS UVECTOR>
  83            <==? .TPS TUPLE>>
  84        <SET TF
  85         <COND
  86          (<1? .LN> <PUT .NOD ,NODE-TYPE ,SUBSTRUC-CODE> <GET-ELE-TYPE .FD 0 T>)
  87          (<G? .LN 4> <MESSAGE ERROR "TOO MANY ARGS TO SUBSTRUC">)
  88          (<OR <L? .LN 4>
  89               <COND (<OR <SUB-CASE-1 .FRST-ARG <4 .K>>
  90                          <SUB-CASE-2 .FRST-ARG <4 .K>>>)>>
  91           <PUT .NOD ,NODE-TYPE ,SUBSTRUC-CODE>
  92           <SET RNODE <BUILD-REST-NODE <1 .K> <2 .K> .NOD>>
  93           <SPLICE-IN-SUB .K .RNODE>
  94           <SET TF <EANA .RNODE .TPS SUBSTRUC>>
  95           <COND (<==? .LN 4> <SET TS <RESULT-TYPE <3 .K>>>) (<SET TS .TF>)>
  96           <SET TF
  97                <COND (<AND <N=? .LN 2> <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
  98                       <SET NUM <NODE-NAME <2 .K>>>
  99                       <TYPE-OK? .TF <FORM STRUCTURED [.NUM ANY]>>)
 100                      (ELSE .TS)>>
 101           <COND
 102            (<N==? .LN 2>
 103             <COND
 104              (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 105               <SET TF
 106                <CHTYPE
 107                 (.TPS
 108                  !<MAPF ,LIST
 109                         <FUNCTION ("AUX" X)
 110                                 <COND (<0? .NUM> <MAPSTOP>)
 111                                       (ELSE
 112                                        <SET X <GET-ELE-TYPE .TF .NUM>>
 113                                        <SET NUM <- .NUM 1>>
 114                                        .X)>>>)
 115                 SEGMENT>>)
 116              (ELSE <SET TF .TPS>)>)>)
 117          (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE> .TPS)>>
 118        <COND
 119         (<L? .LN 4>
 120          <AND <==? .TPS TUPLE> <SET TPS VECTOR>>
 121          <SET TF
 122           <COND
 123            (<AND <TYPE? .TF FORM SEGMENT> <ISTYPE? .TF>>
 124             <COND
 125              (<==? <1 .TF> OR>
 126               <CHTYPE
 127                (OR
 128                 !<MAPF ,LIST
 129                        <FUNCTION (D)
 130                                <COND (<TYPE? .D FORM>
 131                                       <CHTYPE (.TPS !<REST .D>) FORM>)
 132                                      (<TYPE? .D SEGMENT>
 133                                       <CHTYPE (.TPS !<REST .D>) SEGMENT>)
 134                                      (ELSE .TPS)>>
 135                        <REST .TF>>)
 136                FORM>)
 137              (<TYPE? .TF FORM> <CHTYPE (.TPS !<REST .TF>) FORM>)
 138              (ELSE <CHTYPE (.TPS !<REST .TF>) SEGMENT>)>)
 139            (ELSE .TPS)>>)>
 140        <TYPE-OK? .TF .RTYP>)
 141       (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE> <TYPE-OK? STRUCTURED .RTYP>)>)>>
 142
 143 <PUT ,SUBSTRUC ANALYSIS ,SUBSTRUC-ANA>
 144
 145 "BUILD A REST NODE"
 146
 147 <DEFINE BUILD-REST-NODE (NODE NUM PAR)
 148         <NODEFM ,SUBR-CODE .PAR ANY REST (.NODE .NUM) ,REST>>
 149
 150 "SPICE IN A REST NODE"
 151
 152 <DEFINE SPLICE-IN-SUB (K NNODE)
 153         #DECL ((K) <LIST [REST NODE]> (NNODE) NODE)
 154         <PUT .K 1 .NNODE>
 155         <PUTREST .K <REST .K 2>>>
 156
 157
 158 "SUB-CASE-1 LOOKS FOR <SUBSTRUC <REST .X> .N1 .N2 .X> AND SIMILAR CASES WHERE
 159  BLTS ARE ALWAYS POSSIBLE.
 160  STRNOD== NODE OF STRUCTURE
 161  CPYNOD== NODE OF STRUCTURE TO COPY INTO"
 162
 163 <DEFINE SUB-CASE-1 (STRNOD CPYNOD
 164                     "AUX" (DATA <GET-SUB-DATA .STRNOD>)
 165                           (DATAC <GET-SUB-DATA .CPYNOD>))
 166         #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
 167         <AND .DATA
 168              .DATAC
 169              <==? <1 .DATA> <1 .DATAC>>
 170              <TYPE? <2 .DATAC> FIX>
 171              <OR <0? <2 .DATAC>>
 172                  <AND <TYPE? <2 .DATA> FIX> <G=? <2 .DATA> <2 .DATAC>>>>>>
 173
 174 <DEFINE SUB-CASE-2 (STRNOD CPYNOD
 175                     "AUX" (DATA <GET-SUB-DATA .STRNOD>)
 176                           (DATAC <GET-SUB-DATA .CPYNOD>))
 177         #DECL ((STRNOD CPYNOD) NODE (DATAC DATA) <OR FALSE LIST>)
 178         <AND .DATA
 179              .DATAC
 180              <==? <1 .DATA> <1 .DATAC>>
 181              <TYPE? <2 .DATA> FIX>
 182              <OR <0? <2 .DATA>>
 183                  <AND <TYPE? <2 .DATAC> FIX> <L? <2 .DATA> <2 .DATAC>>>>>>
 184
 185
 186 <DEFINE GET-SUB-DATA (NOD "AUX" SYM TNOD (NTYP <NODE-TYPE .NOD>))
 187    #DECL ((NOD TNOD) NODE (SYM) SYMTAB (NTYP) FIX)
 188    <COND (<OR <==? .NTYP ,LVAL-CODE> <==? .NTYP ,SET-CODE>>
 189           (<NODE-NAME .NOD> 0))
 190          (<AND <==? .NTYP ,REST-CODE>
 191                <COND (<OR <==? <SET NTYP <NODE-TYPE <SET TNOD <1 <KIDS .NOD>>>>>
 192                                ,LVAL-CODE>
 193                           <==? .NTYP ,SET-CODE>>
 194                       <SET SYM <NODE-NAME .TNOD>>)>>
 195           (.SYM <NODE-NAME <2 <KIDS .NOD>>>))>><ENDPACKAGE>
 196 \f