<mdl.comp>/cdrive.mud.12

   1 <PACKAGE "CDRIVE">
   2
   3 <ENTRY COMPILE COMPILE-GROUP COMP2>
   4
   5 <USE "CODGEN" "SYMANA" "VARANA" "COMCOD" "COMPDEC" "PASS1" "TIMFCN" "ADVMES"
   6         "CUP">
   7 "****** TOP LEVEL COMILER CALLS ******"
   8
   9 "COMPILE -- compile one function or a group.  Compile does not merge a group
  10             into one big RSUBR (see COMPILE-GROUP).
  11
  12         The arguments to compile are:
  13
  14         FCNS -- an atom whose GVAL is a function, a locative to a function
  15                 or a list of the previous 2.
  16
  17         SRC-FLG -- a channel for assembly listing or #FALSE () for none.
  18
  19         BIN-FLG -- If false, don't assemble else do.
  20
  21         CAREFUL -- If true compile bounds checking else don't.
  22
  23         GLOSP   -- Whether or not default is SPECIAL.
  24 "
  25
  26 <DEFINE <ENTRY COMPILE> (FCNS
  27                          "OPTIONAL" (SRC-FLG <>) (BIN-FLG T) (CAREFUL T)
  28                                     (GLOSP <>) (REASONABLE T) (GLUE T)
  29                                     (ANALY-OK T) (VERBOSE <>)
  30                          "AUX" (IND (1)) (TAG:COUNT 0) "NAME" COMPILER)
  31         #DECL ((FCNS SRC-FLG BIN-FLG CAREFUL GLOSP REASONABLE GLUE IND
  32                 TAG:COUNT COMPILER ANALY-OK VERBOSE) <SPECIAL ANY>)
  33         <ZTMPLST>
  34         <COND (<TYPE? .FCNS LIST>
  35                <MAPF <> ,VERIFY .FCNS>
  36                <MAPF <>
  37                      <FUNCTION (FCN) <PRINC <COMP2 .FCN>> <TERPRI>>
  38                      .FCNS>
  39                <MAPF <> ,UNASSOC .FCNS>)
  40               (ELSE <VERIFY .FCNS>
  41                <PRINC <COMP2 .FCNS>>
  42                <UNASSOC .FCNS>)>
  43         <TERPRI>
  44         "DONE">
  45
  46 "COMP2 -- compile one thing (atom or locative) print time if second arg
  47          missing or false.  Assemble result if desired (time entire job)."
  48
  49 <DEFINE COMP2 (TH "OPTIONAL" (SILENT <>)
  50                   "AUX" (CODE:TOP (())) MESS
  51                         (CODE:PTR .CODE:TOP)
  52                         (ST <TIME>) (RT <RTIME>) (DAT <DATE>))
  53         #DECL ((CODE:PTR CODE:TOP) <SPECIAL LIST>)
  54         <SET MESS <COMP1 .TH <> <> .SILENT>>
  55         <COND (<TYPE? .MESS LIST>
  56                <SETLOC <1 .MESS> <ASSEM? .SRC-FLG>>
  57                <STRING "Job done in:  "
  58                         <TIME-STR1 <FIX <+ 0.5 <- <TIME> .ST>>>> " / "
  59                         <TIME-DIF1 .DAT <DATE> .RT <RTIME>>>)
  60               (ELSE .MESS)>>
  61
  62 "VERIFY -- check types of arguments prior to compilation."
  63
  64 <DEFINE VERIFY (THING)
  65         <COND (<TYPE? .THING ATOM>
  66                <IF-NOT <GASSIGNED? .THING>
  67                        <MESSAGE ERROR " UNASSIGNED " .THING>>
  68                <IF-NOT <OR <TYPE? ,.THING FUNCTION>
  69                            <AND <TYPE? ,.THING MACRO>
  70                                 <NOT <EMPTY? ,.THING>>
  71                                 <TYPE? <1 ,.THING> FUNCTION>>>
  72                        <MESSAGE ERROR " NOT A FUNCTION " .THING>>)
  73               (<TYPE? .THING LOCL LOCV LOCU LOCA LOCAS LOCD>
  74                <IF-NOT <TYPE? <IN .THING> FUNCTION>
  75                        <MESSAGE ERROR " NOT A FUNCTION " .THING>>)
  76               (ELSE <MESSAGE ERROR " ARG WRONG TYPE " .THING>)>>
  77
  78 "COMP1 -- compile one object and time compilation.  Make noise if second arg
  79           there and not false."
  80
  81 <DEFINE COMP1 (THING SUB? INT?
  82                "OPTIONAL" (SILENT <>)
  83                "EXTRA" (START-TIME <TIME>) (NM1 .THING) RDCL (REALT <RTIME>)
  84                        (TH .THING) (RDAT <DATE>)
  85                "NAME" COMPILER)
  86         #DECL ((SUB? INT? RDCL COMPILER) <SPECIAL ANY> (START-TIME) FLOAT)
  87         <COND (<TYPE? .THING ATOM>
  88                <COND (<GASSIGNED? SNAME-SETTER> <SNAME-SETTER .THING>)>
  89                <COND (<NOT .SILENT>
  90                       <PRINC "COMPILING ">
  91                       <PRIN1 .THING>
  92                       <TERPRI>)>
  93                <COND (<TYPE? ,.THING FUNCTION> <SET TH <GLOC .THING>>)
  94                      (ELSE <SET TH <AT ,.THING 1>>)>)
  95               (ELSE
  96                <OR .SILENT <PRINC "COMPILING LOCATIVE">>
  97                <SET NM1 <MAKE:TAG "ANONF">>)>
  98         <COMPILE-FUNCTION <IN .TH> .NM1 .THING>
  99         (.TH
 100          <STRING "Compilation done in "
 101                  <TIME-STR1 <FIX <+ 0.5 <- <TIME> .START-TIME>>>>
 102                  "cpu time, "
 103                  <ASCII 13>
 104                  <ASCII 10>
 105                  <TIME-DIF1 .RDAT <DATE> .REALT <RTIME>>
 106                  " real time. "
 107                  <ASCII 13>
 108                  <ASCII 10>>)>
 109
 110 "COMPILE-GROUP -- compile into one RSUBR a group of functions.  Eliminate identity
 111                    of internal RSUBRs.  First arg same as for COMPILE.  Second arg
 112                    specifies those FUNCTIONS to become external. Third arg
 113                    name of entire group upon completion of compilation."
 114
 115 <DEFINE <ENTRY COMPILE-GROUP>
 116         (FCNS EXTS GROUP-NAME
 117                    "OPTIONAL" (SRC-FLG <>)
 118                               (BIN-FLG T)
 119                               (CAREFUL T)
 120                               (GLOSP <>)
 121                               (REASONABLE T)
 122                               (GLUE T)
 123                               (TMPCHN <>)
 124                               (ANALY-OK T)
 125                               (VERBOSE <>)
 126                     "AUX" (FIRST T) (IND (1)) (TAG:COUNT 0)
 127                           (STRT <TIME>)
 128                           (RSTRT <RTIME>)
 129                           (RDAT <DATE>)
 130                           (CODE:TOP (()))
 131                           (CODE:PTR .CODE:TOP)
 132                     "NAME" COMPILER)
 133         #DECL ((FCNS GROUP-NAME SEC-FLG BIN-FLG CAREFUL GLOSP REASONABLE GLUE
 134                 IND TAG:COUNT CODE:TOP CODE:PTR COMPILER ANALY-OK VERBOSE)
 135                 <SPECIAL ANY>)
 136         <MAPF <> ,VERIFY .FCNS>
 137         <ZTMPLST>
 138         <GROUP:INITIAL .GROUP-NAME>
 139         <MAPF <>
 140               <FUNCTION (FCN "AUX" (MESS <COMP1 .FCN T <NOT <MEMQ .FCN .EXTS>>>))
 141                 <COND (<TYPE? .MESS LIST>)
 142                       (ELSE <RETURN <CHTYPE (.MESS) FALSE> .COMPILER>)>
 143                 <SET FIRST <>>
 144                 <TERPRI>
 145                 <ASSEM? .CODE:TOP <>>
 146                 <COND (.TMPCHN <OUTCOD .CODE:TOP .TMPCHN>
 147                        <SET CODE:PTR <SET CODE:TOP (())>>)>>
 148               .FCNS>
 149         <MAPF <> ,UNASSOC .FCNS>
 150         <COND (.TMPCHN <CLOSE .TMPCHN>)
 151               (ELSE <SETG .GROUP-NAME <ASSEM? .SRC-FLG>>)>
 152         <STRING "Time for group:  "
 153                 <TIME-STR1 <FIX <+ 0.5 <- <TIME> .STRT>>>> " / "
 154                 <TIME-DIF1 .RDAT <DATE> .RSTRT <RTIME>>>>
 155
 156 <SETG WDCNTLC ![1623294726!]>
 157
 158 <SETG WDSPACE ![17315143744!]>
 159
 160 <DEFINE OUTCOD (L TMPCH "AUX" (OBLIST (<MOBLIST OP!-PACKAGE> <GET MUDDLE OBLIST>
 161                                              !.OBLIST)) ACC ACC2)
 162         #DECL ((L) LIST (TMPCH) CHANNEL (OBLIST) <SPECIAL LIST> (ACC ACC2) FIX)
 163         <SET ACC <17 .TMPCH>>
 164         <RESET .TMPCH>
 165         <ACCESS .TMPCH .ACC>
 166         <PRINC <ASCII 12> .TMPCH>
 167         <REPEAT ()
 168                 <COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>
 169                 <TERPRI .TMPCH>
 170                 <OR <TYPE? <1 .L> ATOM> <PRINC "        " .TMPCH>>
 171                 <PRIN1 <1 .L> .TMPCH>>
 172         <BUFOUT .TMPCH>
 173         <PRINTB ,WDCNTLC .TMPCH>
 174         <SET ACC2 <17 .TMPCH>>
 175         <ACCESS .TMPCH <- .ACC 1>>
 176         <PRINTB ,WDSPACE .TMPCH>
 177         <ACCESS .TMPCH .ACC2>
 178         <CLOSE .TMPCH>>
 179
 180 <DEFINE UNASSOC (THING)
 181         <COND (<TYPE? .THING ATOM>
 182                <PUT ,.THING .IND>)
 183               (ELSE <PUT <IN .THING> .IND>)>>
 184
 185 "COMPILE-FUNCTION -- run the compiler on one function.
 186                      PASS1 builds internal structure.
 187                      ANA further specifies the structure and computes types for all nodes.
 188                      VARS allocates stack slots for variables.
 189                      CODE-GEN generates assembler source.
 190 "
 191
 192 <DEFINE COMPILE-FUNCTION (FCN NAME "OPTIONAL" (RNAME .NAME) "AUX" INAME (LOCAL-TAGS ())
 193         (VP (())))
 194         #DECL ((LOCAL-TAGS) <SPECIAL LIST>)
 195         <COND (.VERBOSE <SET VERBOSE .VP>)>
 196         <REACS>
 197         <SET INAME <NODE-NAME <SET FCN <PASS1 .FCN .NAME <> .RNAME>>>>
 198         <ANA .FCN ANY>
 199         <VARS .FCN>
 200         <COND (.VERBOSE <ANA-MESS .VP>)>
 201         <REACS>
 202         <COND (<ACS .FCN>       ;"AC call exists?"
 203                <COND (<AND .INT? .SUB?>
 204                       <INT:INITIAL .NAME>)
 205                      (.SUB? <SUB:INT:INITIAL .NAME> <ARGS-TO-ACS .FCN>)
 206                      (ELSE <FCN:INT:INITIAL .NAME> <ARGS-TO-ACS .FCN>)>)
 207               (<AND <ASSIGNED? GROUP-NAME>
 208                     <NOT <EMPTY? <ACS .FCN>>>
 209                     <OR .INT? <NOT <EMPTY? .INAME>>>>
 210                <INT:LOSER:INITIAL .NAME .FCN>)
 211               (.SUB? <SUB:INITIAL .NAME>)
 212               (ELSE
 213                <FUNCTION:INITIAL .NAME>)>
 214         <CODE-GEN .FCN>
 215         <CHECK-LOCAL-TAGS .LOCAL-TAGS>
 216         <PUT .FCN ,BINDING-STRUCTURE ()>
 217         <PUT .FCN ,KIDS ()>
 218         <PUT .FCN ,SYMTAB ,LVARTBL>
 219         <COND (<ACS .FCN>
 220                <COND (.INT? <INT:FINAL .FCN>)
 221                      (ELSE
 222                       <PUT .RDCL 2 <RSUBR-DECLS .FCN>>
 223                <FS:INT:FINAL <ACS .FCN>>)>)
 224               (ELSE
 225                <PUT .RDCL 2 <RSUBR-DECLS .FCN>>
 226                <FCNSUB:FINAL .FCN>)>>
 227
 228
 229
 230
 231 <DEFINE TIME-STR1 (NSEC "AUX" (NMIN </ <FIX .NSEC> 60>)
 232                              (NHRS </ .NMIN 60>))
 233         #DECL ((NSEC) <OR FIX FLOAT> (NMIN NHRS) FIX (VALUE) STRING)
 234         <TIMEST1 .NHRS
 235                 <- .NMIN <* .NHRS 60>>
 236                 <- .NSEC <* .NMIN 60>>>>
 237
 238 <DEFINE TIME-DIF1 (D1 D2 T1 T2
 239                    "AUX" (DY
 240                           <- <DAYS <1 .D2> <2 .D2> <3 .D2>>
 241                              <DAYS <1 .D1> <2 .D1> <3 .D1>>>))
 242         #DECL ((D1 D2 T1 T2) <LIST FIX FIX FIX> (VALUE) STRING)
 243         <TIME-STR1 <- <+ <* .DY 3600 24>
 244                          <* <1 .T2> 3600>
 245                          <* <2 .T2> 60>
 246                          <3 .T2>>
 247                       <+ <* <1 .T1> 3600> <* <2 .T1> 60> <3 .T1>>>>>
 248
 249 <DEFINE TIMEST1 (HR MI SE)
 250    #DECL ((HR MI SE) FIX)
 251    <STRING <COND (<NOT <0? .HR>> <STRING <UNPARSE .HR> ":">) (ELSE "")>
 252            <COND (<OR <NOT <0? .MI>> <NOT <0? .HR>>>
 253                   <STRING <COND (<L=? .MI 9>
 254                                  <STRING <COND (<0? .HR> "") (ELSE "0")>
 255                                          <CHTYPE <+ .MI 48> CHARACTER>>)
 256                                 (ELSE
 257                                  <STRING <CHTYPE <+ </ .MI 10> 48> CHARACTER>
 258                                          <CHTYPE <+ <MOD .MI 10> 48>
 259                                                  CHARACTER>>)>
 260                           ":">)
 261                  (ELSE "")>
 262            <COND (<L=? .SE 9>
 263                   <STRING <COND (<OR <NOT <0? .MI>> <NOT <0? .HR>>> "0")
 264                                 (ELSE "")>
 265                           <CHTYPE <+ .SE 48> CHARACTER>>)
 266                  (ELSE
 267                   <STRING <CHTYPE <+ </ .SE 10> 48> CHARACTER>
 268                           <CHTYPE <+ <MOD .SE 10> 48> CHARACTER>>)>>>
 269
 270 <ENDPACKAGE>\ 3\ 3\ 3