mim/development/mim/mimc/notana.mud

   1
   2 <PACKAGE "NOTANA">
   3
   4 <ENTRY NOT-ANA
   5        TYPE?-ANA
   6        ==?-ANA
   7        VALID-TYPE?-ANA
   8        TYPE-C-ANA
   9        =?-ANA
  10        S=?-ANA
  11        STRCOMP-ANA
  12        SUBSTRUC-ANA
  13        ATOM-PART-ANA
  14        OFFSET-PART-ANA
  15        PUT-GET-DECL-ANA>
  16
  17 <USE "SYMANA" "CHKDCL" "COMPDEC" "CARANA" "ADVMESS" "NPRINT">
  18
  19 "       This module contains analysis and generation functions for
  20 NOT, TYPE? and ==?.  See SYMANA for more details about ANALYSIS and
  21 CODGEN for more detali abour code generation.
  22 "
  23
  24 "Analyze NOT usage make sure arg can be FALSE."
  25
  26 <DEFINE NOT-ANA (NOD RTYP
  27                  "AUX" TEM (FLG <==? .PRED <PARENT .NOD>>) (STR .TRUTH)
  28                        (SUNT .UNTRUTH))
  29         #DECL ((NOD) NODE (STR SUNT) LIST)
  30         <PROG ((PRED <AND .FLG .NOD>) (TRUTH ()) (UNTRUTH ()))
  31               #DECL ((PRED) <SPECIAL ANY> (TRUTH UNTRUTH) <SPECIAL LIST>)
  32               <COND (<SET TEM <SEGFLUSH .NOD .RTYP>> <SET FLG <>>)
  33                     (ELSE
  34                      <ARGCHK <LENGTH <KIDS .NOD>> 1 NOT .NOD>
  35                      <SET TEM <ANA <1 <KIDS .NOD>> ANY>>
  36                      <PUT .NOD ,NODE-TYPE ,NOT-CODE>
  37                      <SET TEM
  38                           <COND (<==? <ISTYPE? .TEM> FALSE>
  39                                  <TYPE-OK? BOOL-TRUE .RTYP>)
  40                                 (<TYPE-OK? .TEM FALSE>
  41                                  <TYPE-OK? BOOLEAN .RTYP>)
  42                                 (ELSE <TYPE-OK? BOOL-FALSE .RTYP>)>>
  43                      <SET STR .UNTRUTH>
  44                      <SET SUNT .TRUTH>)>>
  45         <COND (.FLG
  46                <SET TRUTH (!.STR !.TRUTH)>
  47                <SET UNTRUTH (!.SUNT !.UNTRUTH)>)>
  48         .TEM>
  49
  50 "       Analyze N==? and ==? usage.  Complain if types differ such that
  51  the args  can never be ==?."
  52
  53 <DEFINE ==?-ANA (NOD RTYP
  54                  "AUX" (K <KIDS .NOD>)
  55                        (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
  56                        KT NT (GLN .NOD) (GLE ()))
  57         #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON GLN) <SPECIAL NODE>
  58                (WHO GLE) <SPECIAL LIST>)
  59         <COND (<SEGFLUSH .NOD .RTYP>)
  60               (ELSE
  61                <COND (<AND <==? <LENGTH .K> 1>
  62                            <==? <NODE-TYPE <SET NT <1 <KIDS .NOD>>>>
  63                                 ,SUBR-CODE>
  64                            <==? <NODE-NAME .NT> LENGTH>
  65                            <==? <LENGTH <SET KT <KIDS .NT>>> 2>>
  66                       <COMPILE-WARNING
  67                        "Attempting to repair probable erroneous code:
  68 "
  69                        .NOD
  70                        "
  71 replaced by">
  72                       <PROG ()
  73                              <PUTREST .K <REST .KT>>
  74                              <PUTREST .KT ()>
  75                              <PUT <1 .KT> ,PARENT .NOD>>
  76                       <NODE-COMPLAIN .NOD>
  77                       <CRLF>)>
  78                <ARGCHK 2 <LENGTH .K> ==? .NOD>
  79                <ANA <1 .K> ANY>
  80                <ANA <2 .K> ANY>
  81                <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
  82                            <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
  83                       <COND (<==? <NODE-NAME .NOD> ==?>
  84                              <PUT .NOD ,NODE-NAME <==? <NODE-NAME <1 .K>>
  85                                                        <NODE-NAME <2 .K>>>>)
  86                             (ELSE
  87                              <PUT .NOD ,NODE-NAME <N==? <NODE-NAME <1 .K>>
  88                                                         <NODE-NAME <2 .K>>>>)>
  89                       <PUT .NOD ,KIDS ()>
  90                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  91                       <COND (<NODE-NAME .NOD> <TYPE-OK? ATOM .RTYP>)
  92                             (ELSE <TYPE-OK? FALSE .RTYP>)>)
  93                      (ELSE
  94                       <PUT .NOD ,NODE-TYPE ,EQ-CODE>
  95                       <COND (<AND <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FIX>
  96                                   <==? <ISTYPE? <RESULT-TYPE <2 .K>>> FIX>>
  97                              <PUT .NOD ,NODE-TYPE ,TEST-CODE>
  98                              <HACK-BOUNDS .WHO .GLE .NOD .K>)>
  99                       <TYPE-OK? BOOLEAN .RTYP>)>)>>
 100
 101
 102 "       Ananlyze TYPE? usage warn about any potential losers by using
 103 TYPE-OK?. "
 104
 105 <DEFINE TYPE?-ANA (NOD RTYP
 106                    "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) ITYP (ALLGOOD T)
 107                          (WHO ()) (FTYP ()) (FNOK <>)
 108                          (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) TTYP)
 109    #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX (ITYP) ANY
 110           (ALLGOOD) <OR FALSE ATOM> (WHON) <SPECIAL <OR NODE FALSE>>
 111           (WHO) <SPECIAL LIST> (FTYP) LIST)
 112    <COND
 113     (<SEGFLUSH .NOD .RTYP> <TYPE-OK? .RTYP '<OR ATOM FALSE>>)
 114     (ELSE
 115      <COND (<L? .LN 2>
 116             <COMPILE-ERROR "Too few arguments to TYPE? " .NOD>)>
 117      <SET ITYP <EANA <1 .K> ANY TYPE?>>
 118      <MAPF <>
 119            <FUNCTION (N "AUX" FLG)
 120                    #DECL ((N) NODE)
 121                    <PROG ()
 122                          <EANA .N ATOM TYPE?>
 123                          <COND (<N==? <NODE-TYPE .N> ,QUOTE-CODE>
 124                                 <RETURN <SET ALLGOOD <>>>)>
 125                          <COND (<NOT <ISTYPE? <NODE-NAME .N>>>
 126                                 <COMPILE-ERROR
 127                                           "Argument to TYPE? not a type "
 128                                           .NOD>)>
 129                          <AND <TYPE-OK? <NODE-NAME .N> .ITYP>
 130                              <SET FTYP (<NODE-NAME .N> !.FTYP)>>>>
 131            <REST .K>>
 132      <COND (<AND .ALLGOOD <NOT <EMPTY? .FTYP>>>
 133             <SET TTYP
 134                  <COND (<EMPTY? <REST .FTYP>> <1 .FTYP>)
 135                        (ELSE <CHTYPE (OR !.FTYP) FORM>)>>
 136             <PUT .NOD ,NODE-TYPE ,TY?-CODE>
 137             <SET FNOK <NOT <TYPE-OK? <FORM NOT .TTYP> .ITYP>>>
 138             <MAPF <>
 139                   <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
 140                           #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
 141                           <SET TRUTH
 142                                <ADD-TYPE-LIST .SYM
 143                                               .TTYP
 144                                               .TRUTH
 145                                               .FLG
 146                                               <REST .L 2>>>
 147                           <OR .FNOK
 148                               <SET UNTRUTH
 149                                    <ADD-TYPE-LIST .SYM
 150                                                   <FORM NOT .TTYP>
 151                                                   .UNTRUTH
 152                                                   .FLG
 153                                                   <REST .L 2>>>>>
 154                   .WHO>)
 155            (.ALLGOOD <PUT .NOD ,NODE-TYPE ,TY?-CODE>)
 156            (ELSE
 157             <AND .VERBOSE <ADDVMESS .NOD ("Not open compiled.")>>
 158             <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
 159      <TYPE-OK? <COND (<NOT .ALLGOOD> '<OR FALSE ATOM>)
 160                    (<EMPTY? .FTYP> FALSE)
 161                    (.FNOK ATOM)
 162                    (ELSE '<OR FALSE ATOM>)>
 163              .RTYP>)>>
 164
 165
 166 <DEFINE VALID-TYPE?-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
 167         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
 168         <COND (<SEGFLUSH .N .R>)
 169               (ELSE
 170                <ARGCHK 1 .LN VALID-TYPE? .N>
 171                <EANA <1 .K> ATOM VALID-TYPE?>
 172                <PUT .N ,NODE-TYPE ,VALID-CODE>
 173                <TYPE-OK? .R '<OR FALSE TYPE-C>>)>>
 174
 175 <DEFINE TYPE-C-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>))
 176         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
 177         <COND (<SEGFLUSH .N .R>)
 178               (ELSE
 179                <ARGCHK .LN '(1 2) VALID-TYPE? .N>
 180                <EANA <1 .K> ATOM TYPE-C>
 181                <COND (<==? .LN 2> <EANA <2 .K> ATOM TYPE-C>)>
 182                <PUT .N ,NODE-TYPE ,TYPE-C-CODE>
 183                <TYPE-OK? .R TYPE-C>)>>
 184
 185 <DEFINE =?-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) N1 N2 T1 T2)
 186         #DECL ((N N1 N2) NODE (K) <LIST [REST NODE]> (LN) FIX)
 187         <COND (<SEGFLUSH .N .R>)
 188               (ELSE
 189                <ARGCHK .LN 2 <NODE-NAME .N> .N>
 190                <EANA <SET N1 <1 .K>> ANY <NODE-NAME .N>>
 191                <EANA <SET N2 <2 .K>> ANY <NODE-NAME .N>>
 192                <COND (<==? <NODE-TYPE .N1> ,QUOTE-CODE>
 193                       <SET N1 <2 .K>>
 194                       <SET N2 <1 .K>>)>
 195                <SET T2 <ISTYPE? <RESULT-TYPE .N2>>>
 196                <COND (<OR <==? <SET T1 <ISTYPE? <RESULT-TYPE .N1>>> STRING>
 197                           <==? .T2 STRING>>
 198                       <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
 199                       <TYPE-OK? BOOLEAN .R>)
 200                      (<AND .T1 .T2 <N==? .T1 .T2>> <TYPE-OK? BOOL-FALSE .R>)
 201                      (ELSE <TYPE-OK? BOOLEAN .R>)>)>>
 202
 203 <DEFINE S=?-ANA (N R "AUX" (K <KIDS .N>))
 204         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
 205         <COND (<SEGFLUSH .N .R>)
 206               (ELSE
 207                <ARGCHK <LENGTH .K> 2 <NODE-NAME .N> .N>
 208                <EANA <1 .K> STRING S=?>
 209                <EANA <2 .K> STRING S=?>
 210                <PUT .N ,NODE-TYPE ,=?-STRING-CODE>
 211                <TYPE-OK? BOOLEAN .R>)>>
 212
 213 <DEFINE ATOM-PART-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>) NN)
 214         #DECL ((NN N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
 215         <COND (<SEGFLUSH .N .R>)
 216               (ELSE
 217                <ARGCHK <LENGTH .K> <COND (<OR <==? .NM GBIND>
 218                                               <==? .NM LBIND>> '(1 2))
 219                                          (ELSE 1)> .NM .N>
 220                <EANA <1 .K> ATOM .NM>
 221                <COND (<NOT <EMPTY? <REST .K>>> <EANA <SET NN <2 .K>> ANY .NM>)>
 222                <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 223                            <N==? .NM LBIND>
 224                            <N==? .NM GBIND>>
 225                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>
 226                       <PUT .N ,KIDS ()>
 227                       <PUT .N ,NODE-NAME <APPLY ,.NM <NODE-NAME <1 .K>>>>
 228                       <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
 229                      (ELSE
 230                       <COND (<OR <AND <N==? .NM GBIND> <N==? .NM LBIND>>
 231                                  <EMPTY? <REST .K>>
 232                                  <AND <==? <NODE-TYPE .NN> ,QUOTE-CODE>
 233                                       <NOT <NODE-NAME .NN>>>>
 234                              <PUT .N ,NODE-TYPE ,ATOM-PART-CODE>)>
 235                       <TYPE-OK? .R <COND (<==? .NM SPNAME> STRING)
 236                                          (<==? .NM OBLIST?> '<OR FALSE OBLIST>)
 237                                          (ELSE .NM)>>)>)>>
 238
 239 <DEFINE PUT-GET-DECL-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>) ST)
 240         #DECL ((N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
 241         <COND (<SEGFLUSH .N .R>)
 242               (ELSE
 243                <ARGCHK <LENGTH .K> <COND (<==? .NM PUT-DECL> 2)
 244                                          (ELSE 1)> .NM .N>
 245                <SET ST <EANA <1 .K> '<OR ATOM OFFSET GBIND LBIND> .NM>>
 246                <COND (<==? .NM PUT-DECL>
 247                       <SET ST <OR <TYPE-AND .ST .R> .ST>>
 248                       <EANA <2 .K> '<OR ATOM FALSE FORM SEGMENT> .NM>
 249                       <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>)>
 250                <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE> <==? .NM GET-DECL>>
 251                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>
 252                       <PUT .N ,KIDS ()>
 253                       <PUT .N ,NODE-NAME <GET-DECL <NODE-NAME <1 .K>>>>
 254                       <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
 255                      (ELSE
 256                       <COND (<MEMQ <ISTYPE? .ST> '[LBIND GBIND OFFSET]>
 257                              <PUT .N ,NODE-TYPE ,PUT-GET-DECL-CODE>)
 258                             (.VERBOSE
 259                              <ADDVMESS .N (.NM "Not open compiled because type is "
 260                                           .ST)>)>
 261                       <TYPE-OK? <COND (<==? .NM GET-DECL>
 262                                        '<OR ATOM FALSE FORM SEGMENT>)
 263                                       (ELSE .ST)> .R>)>)>>
 264
 265 <DEFINE OFFSET-PART-ANA (N R "AUX" (K <KIDS .N>) (NM <NODE-NAME .N>))
 266         #DECL ((N) NODE (K) <LIST [REST NODE]> (NM) ATOM)
 267         <COND (<SEGFLUSH .N .R>)
 268               (ELSE
 269                <ARGCHK <LENGTH .K> <COND (<==? .NM INDEX> 1)
 270                                          (ELSE '(1 2))> .NM .N>
 271                <EANA <1 .K> OFFSET .NM>
 272                <COND (<NOT <EMPTY? <REST .K>>>
 273                       <EANA <2 .K> '<OR ATOM FALSE FORM SEGMENT> .NM>)>
 274                <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 275                            <EMPTY? <REST .K>>>
 276                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>
 277                       <PUT .N ,KIDS ()>
 278                       <PUT .N ,NODE-NAME <APPLY ,.NM <NODE-NAME <1 .K>>>>
 279                       <TYPE-OK? <TYPE <NODE-NAME .N>> .R>)
 280                      (ELSE
 281                       <PUT .N ,NODE-TYPE ,OFFSET-PART-CODE>
 282                       <TYPE-OK? .R
 283                                 <COND (<==? .NM INDEX> FIX)
 284                                       (<NOT <EMPTY? <REST .K>>> OFFSET)
 285                                       (ELSE '<OR ATOM FALSE FORM SEGMENT>)>>)>)>>
 286
 287 <DEFINE STRCOMP-ANA (N R "AUX" (K <KIDS .N>))
 288         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
 289         <COND (<SEGFLUSH .N .R>)
 290               (ELSE
 291                <ARGCHK <LENGTH .K> 2 <NODE-NAME .N> .N>
 292                <COND (<AND <STRCOMP-ARG-ANA <1 .K> .N 1>
 293                            <STRCOMP-ARG-ANA <2 .K> .N 2>>
 294                       <PUT .N ,NODE-TYPE ,=?-STRING-CODE>)>
 295                <TYPE-OK? FIX .R>)>>
 296
 297 <DEFINE STRCOMP-ARG-ANA (N:NODE P:NODE IDX:FIX "AUX" TYP ITYP NN:NODE)
 298         <SET TYP <EANA .N ANY STRCOMP>>
 299         <COND (<SET ITYP <ISTYPE? .TYP>>
 300                <COND (<==? .ITYP ATOM>
 301                       <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
 302                              <PUT .N ,NODE-NAME <SPNAME <NODE-NAME .N>>>
 303                              <PUT .N ,RESULT-TYPE STRING>)
 304                             (ELSE
 305                              <SET NN <NODEFM ,ATOM-PART-CODE .P STRING SPNAME
 306                                              (.N) ,SPNAME>>
 307                              <PUT <KIDS .P> .IDX .NN>
 308                              <PUT .N ,PARENT .NN>)>)>
 309                T)
 310               (<=? .TYP '<OR ATOM STRING>> T)
 311               (<NOT <TYPE-OK? .TYP '<OR ATOM STRING>>>
 312                <COMPILE-ERROR "Argument wrong type to: " STRCOMP .P>)
 313               (ELSE <>)>>
 314
 315 <DEFINE SUBSTRUC-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) ST)
 316         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
 317         <COND (<SEGFLUSH .N .R>)
 318               (ELSE
 319                <ARGCHK .LN '(1 4) <NODE-NAME .N> .N>
 320                <SET ST <EANA <1 .K> STRUCTURED SUBSTRUC>>
 321                <COND (<G? .LN 1> <EANA <2 .K> FIX SUBSTRUC>)>
 322                <COND (<G? .LN 2> <EANA <3 .K> FIX SUBSTRUC>)>
 323                <COND (<G? .LN 3>
 324                       <SET ST <STRUCTYP .ST>>
 325                       <SET ST <EANA <4 .K> <COND (.ST <FORM PRIMTYPE .ST>)
 326                                                  (ELSE STRUCTURED)>
 327                                     SUBSTRUC>>
 328                       <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>)>
 329                <COND (<MEMQ <STRUCTYP .ST> '[STRING VECTOR UVECTOR BYTES]>
 330                       <PUT .N ,NODE-TYPE ,SUBSTRUC-CODE>)>
 331                <TYPE-OK? <STRUCTYP .ST> .R>)>>
 332
 333
 334 <COND (<AND <GASSIGNED? NOT-ANA> <GASSIGNED? ELEMENT-DECL>>
 335        <PUTPROP ,NOT ANALYSIS ,NOT-ANA>
 336        <PUTPROP ,==? ANALYSIS ,==?-ANA>
 337        <PUTPROP ,N==? ANALYSIS ,==?-ANA>
 338        <PUTPROP ,TYPE? ANALYSIS ,TYPE?-ANA>
 339        <PUTPROP ,=? ANALYSIS ,=?-ANA>
 340        <PUTPROP ,N=? ANALYSIS ,=?-ANA>
 341        <PUTPROP ,VALID-TYPE? ANALYSIS ,VALID-TYPE?-ANA>
 342        <PUTPROP ,TYPE-C ANALYSIS ,TYPE-C-ANA>
 343        <PUTPROP ,INDEX ANALYSIS ,OFFSET-PART-ANA>
 344        <PUTPROP ,ELEMENT-DECL ANALYSIS ,OFFSET-PART-ANA>
 345        <PUTPROP ,PUT-DECL ANALYSIS ,PUT-GET-DECL-ANA>
 346        <PUTPROP ,GET-DECL ANALYSIS ,PUT-GET-DECL-ANA>
 347        <PUTPROP ,SPNAME ANALYSIS ,ATOM-PART-ANA>
 348        <PUTPROP ,OBLIST? ANALYSIS ,ATOM-PART-ANA>
 349        <PUTPROP ,LBIND ANALYSIS ,ATOM-PART-ANA>
 350        <PUTPROP ,GBIND ANALYSIS ,ATOM-PART-ANA>
 351        <PUTPROP ,S=? ANALYSIS ,S=?-ANA>
 352        <PUTPROP ,STRCOMP ANALYSIS ,STRCOMP-ANA>
 353        <PUTPROP ,SUBSTRUC ANALYSIS ,SUBSTRUC-ANA>)>
 354
 355 <ENDPACKAGE>