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