<mdl.comp>/notana.mud.116

   1 <PACKAGE "NOTANA">
   2
   3 <ENTRY NOT-ANA TYPE?-ANA ==?-ANA>
   4
   5 <USE "SYMANA" "CHKDCL" "COMPDEC" "CARANA" "ADVMESS">
   6
   7
   8 "       This module contains analysis and generation functions for
   9 NOT, TYPE? and ==?.  See SYMANA for more details about ANALYSIS and
  10 CODGEN for more detali abour code generation.
  11 "
  12
  13 "Analyze NOT usage make sure arg can be FALSE."
  14
  15 <DEFINE NOT-ANA (NOD RTYP
  16                  "AUX" TEM (FLG <==? .PRED <PARENT .NOD>>) (STR .TRUTH)
  17                        (SUNT .UNTRUTH))
  18         #DECL ((NOD) NODE)
  19         <PROG ((PRED <AND .FLG .NOD>) (TRUTH ()) (UNTRUTH ()))
  20               #DECL ((PRED) <SPECIAL ANY> (TRUTH UNTRUTH) <SPECIAL LIST>)
  21               <COND (<SET TEM <SEGFLUSH .NOD .RTYP>> <SET FLG <>>)
  22                     (ELSE
  23                      <OR <1? <LENGTH <KIDS .NOD>>>
  24                              <MESSAGE ERROR "WRONG NUMBER OF ARGS TO  NOT " .NOD>>
  25                      <SET TEM <ANA <1 <KIDS .NOD>> ANY>>
  26                      <PUT .NOD ,NODE-TYPE ,NOT-CODE>
  27                      <SET TEM
  28                           <COND (<==? <ISTYPE? .TEM> FALSE>
  29                                  <TYPE-OK? ATOM .RTYP>)
  30                                 (<TYPE-OK? .TEM FALSE>
  31                                  <TYPE-OK? '<OR FALSE ATOM> .RTYP>)
  32                                 (ELSE <TYPE-OK? FALSE .RTYP>)>>
  33                      <SET STR .UNTRUTH>
  34                      <SET SUNT .TRUTH>)>>
  35         <COND (.FLG
  36                <SET TRUTH (!.STR !.TRUTH)>
  37                <SET UNTRUTH (!.SUNT !.UNTRUTH)>)>
  38         .TEM>
  39
  40 <PUT ,NOT ANALYSIS ,NOT-ANA>
  41
  42 "       Analyze N==? and ==? usage.  Complain if types differ such that
  43  the args  can never be ==?."
  44
  45 <DEFINE ==?-ANA (NOD RTYP
  46                  "AUX" (K <KIDS .NOD>)
  47                        (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
  48                        (GLN .NOD) (GLE ()))
  49         #DECL ((NOD) NODE (K) <LIST [REST NODE]> (WHON GLN) <SPECIAL NODE>
  50                (WHO GLE) <SPECIAL LIST>)
  51         <COND (<SEGFLUSH .NOD .RTYP>)
  52               (ELSE
  53                <ARGCHK 2 <LENGTH .K> ==?>
  54                <ANA <1 .K> ANY>
  55                <ANA <2 .K> ANY>
  56                <PUT .NOD ,NODE-TYPE ,EQ-CODE>
  57                <COND (<AND <==? <ISTYPE? <RESULT-TYPE <1 .K>>> FIX>
  58                            <==? <ISTYPE? <RESULT-TYPE <2 .K>>> FIX>>
  59                       <PUT .NOD ,NODE-TYPE ,TEST-CODE>
  60                       <HACK-BOUNDS .WHO .GLE .NOD .K>)>
  61                <TYPE-OK? '<OR FALSE ATOM> .RTYP>)>>
  62
  63 <PUT ,==? ANALYSIS ,==?-ANA>
  64
  65 <PUT ,N==? ANALYSIS ,==?-ANA>
  66
  67 "       Ananlyze TYPE? usage warn about any potential losers by using
  68 TYPE-OK?. "
  69
  70 <DEFINE TYPE?-ANA (NOD RTYP
  71                    "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) ITYP (ALLGOOD T)
  72                          (WHO ()) (FTYP ()) (FNOK <>)
  73                          (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) TTYP)
  74    #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX (ITYP) ANY
  75           (ALLGOOD) <OR FALSE ATOM> (WHON) <SPECIAL <OR NODE FALSE>>
  76           (WHO) <SPECIAL LIST> (FTYP) LIST)
  77    <COND
  78     (<SEGFLUSH .NOD .RTYP>)
  79     (ELSE
  80      <OR <G? .LN 1>
  81              <MESSAGE ERROR "TOO FEW ARGS TO TYPE? " .NOD>>
  82      <SET ITYP <EANA <1 .K> ANY TYPE?>>
  83      <MAPF <>
  84            <FUNCTION (N "AUX" FLG)
  85                    #DECL ((N) NODE)
  86                    <PROG ()
  87                          <EANA .N ATOM TYPE?>
  88                          <OR <==? <NODE-TYPE .N> ,QUOTE-CODE>
  89                                  <RETURN <SET ALLGOOD <>>>>
  90                          <OR <MEMQ <NODE-NAME .N> <ALLTYPES>>
  91                                  <MESSAGE ERROR
  92                                           "ARG TO TYPE? NOT A TYPE "
  93                                           .NOD>>
  94                          <AND <TYPE-OK? <NODE-NAME .N> .ITYP>
  95                              <SET FTYP (<NODE-NAME .N> !.FTYP)>>>>
  96            <REST .K>>
  97      <COND (<AND .ALLGOOD <NOT <EMPTY? .FTYP>>>
  98             <SET TTYP
  99                  <COND (<EMPTY? <REST .FTYP>> <1 .FTYP>)
 100                        (ELSE <CHTYPE (OR !.FTYP) FORM>)>>
 101             <PUT .NOD ,NODE-TYPE ,TY?-CODE>
 102             <SET FNOK <NOT <TYPE-OK? <FORM NOT .TTYP> .ITYP>>>
 103             <MAPF <>
 104                   <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
 105                           #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
 106                           <SET TRUTH
 107                                <ADD-TYPE-LIST .SYM
 108                                               .TTYP
 109                                               .TRUTH
 110                                               .FLG
 111                                               <REST .L 2>>>
 112                           <OR .FNOK
 113                               <SET UNTRUTH
 114                                    <ADD-TYPE-LIST .SYM
 115                                                   <FORM NOT .TTYP>
 116                                                   .UNTRUTH
 117                                                   .FLG
 118                                                   <REST .L 2>>>>>
 119                   .WHO>)
 120            (.ALLGOOD <PUT .NOD ,NODE-TYPE ,TY?-CODE>)
 121            (ELSE
 122             <AND .VERBOSE <ADDVMESS .NOD ("Not open compiled.")>>
 123             <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>)>
 124    <TYPE-OK? <COND (<NOT .ALLGOOD> '<OR FALSE ATOM>)
 125                    (<EMPTY? .FTYP> FALSE)
 126                    (.FNOK ATOM)
 127                    (ELSE '<OR FALSE ATOM>)>
 128              .RTYP>>
 129
 130 <PUT ,TYPE? ANALYSIS ,TYPE?-ANA>
 131 \f
 132 <ENDPACKAGE>\ 3\ 3\ 3\ 3