3 <ENTRY COMPILE COMPILE-GROUP COMP2>
5 <USE "CODGEN" "SYMANA" "VARANA" "COMCOD" "COMPDEC" "PASS1" "TIMFCN" "ADVMES"
7 "****** TOP LEVEL COMILER CALLS ******"
9 "COMPILE -- compile one function or a group. Compile does not merge a group
10 into one big RSUBR (see COMPILE-GROUP).
12 The arguments to compile are:
14 FCNS -- an atom whose GVAL is a function, a locative to a function
15 or a list of the previous 2.
17 SRC-FLG -- a channel for assembly listing or #FALSE () for none.
19 BIN-FLG -- If false, don't assemble else do.
21 CAREFUL -- If true compile bounds checking else don't.
23 GLOSP -- Whether or not default is SPECIAL.
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>)
34 <COND (<TYPE? .FCNS LIST>
35 <MAPF <> ,VERIFY .FCNS>
37 <FUNCTION (FCN) <PRINC <COMP2 .FCN>> <TERPRI>>
39 <MAPF <> ,UNASSOC .FCNS>)
46 "COMP2 -- compile one thing (atom or locative) print time if second arg
47 missing or false. Assemble result if desired (time entire job)."
49 <DEFINE COMP2 (TH "OPTIONAL" (SILENT <>)
50 "AUX" (CODE:TOP (())) MESS
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>>>)
62 "VERIFY -- check types of arguments prior to compilation."
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>)>>
78 "COMP1 -- compile one object and time compilation. Make noise if second arg
81 <DEFINE COMP1 (THING SUB? INT?
82 "OPTIONAL" (SILENT <>)
83 "EXTRA" (START-TIME <TIME>) (NM1 .THING) RDCL (REALT <RTIME>)
84 (TH .THING) (RDAT <DATE>)
86 #DECL ((SUB? INT? RDCL COMPILER) <SPECIAL ANY> (START-TIME) FLOAT)
87 <COND (<TYPE? .THING ATOM>
88 <COND (<GASSIGNED? SNAME-SETTER> <SNAME-SETTER .THING>)>
93 <COND (<TYPE? ,.THING FUNCTION> <SET TH <GLOC .THING>>)
94 (ELSE <SET TH <AT ,.THING 1>>)>)
96 <OR .SILENT <PRINC "COMPILING LOCATIVE">>
97 <SET NM1 <MAKE:TAG "ANONF">>)>
98 <COMPILE-FUNCTION <IN .TH> .NM1 .THING>
100 <STRING "Compilation done in "
101 <TIME-STR1 <FIX <+ 0.5 <- <TIME> .START-TIME>>>>
105 <TIME-DIF1 .RDAT <DATE> .REALT <RTIME>>
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."
115 <DEFINE <ENTRY COMPILE-GROUP>
116 (FCNS EXTS GROUP-NAME
117 "OPTIONAL" (SRC-FLG <>)
126 "AUX" (FIRST T) (IND (1)) (TAG:COUNT 0)
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)
136 <MAPF <> ,VERIFY .FCNS>
138 <GROUP:INITIAL .GROUP-NAME>
140 <FUNCTION (FCN "AUX" (MESS <COMP1 .FCN T <NOT <MEMQ .FCN .EXTS>>>))
141 <COND (<TYPE? .MESS LIST>)
142 (ELSE <RETURN <CHTYPE (.MESS) FALSE> .COMPILER>)>
145 <ASSEM? .CODE:TOP <>>
146 <COND (.TMPCHN <OUTCOD .CODE:TOP .TMPCHN>
147 <SET CODE:PTR <SET CODE:TOP (())>>)>>
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>>>>
156 <SETG WDCNTLC ![1623294726!]>
158 <SETG WDSPACE ![17315143744!]>
160 <DEFINE OUTCOD (L TMPCH "AUX" (OBLIST (<MOBLIST OP!-PACKAGE> <GET MUDDLE OBLIST>
162 #DECL ((L) LIST (TMPCH) CHANNEL (OBLIST) <SPECIAL LIST> (ACC ACC2) FIX)
163 <SET ACC <17 .TMPCH>>
166 <PRINC <ASCII 12> .TMPCH>
168 <COND (<EMPTY? <SET L <REST .L>>> <RETURN>)>
170 <OR <TYPE? <1 .L> ATOM> <PRINC " " .TMPCH>>
171 <PRIN1 <1 .L> .TMPCH>>
173 <PRINTB ,WDCNTLC .TMPCH>
174 <SET ACC2 <17 .TMPCH>>
175 <ACCESS .TMPCH <- .ACC 1>>
176 <PRINTB ,WDSPACE .TMPCH>
177 <ACCESS .TMPCH .ACC2>
180 <DEFINE UNASSOC (THING)
181 <COND (<TYPE? .THING ATOM>
183 (ELSE <PUT <IN .THING> .IND>)>>
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.
192 <DEFINE COMPILE-FUNCTION (FCN NAME "OPTIONAL" (RNAME .NAME) "AUX" INAME (LOCAL-TAGS ())
194 #DECL ((LOCAL-TAGS) <SPECIAL LIST>)
195 <COND (.VERBOSE <SET VERBOSE .VP>)>
197 <SET INAME <NODE-NAME <SET FCN <PASS1 .FCN .NAME <> .RNAME>>>>
200 <COND (.VERBOSE <ANA-MESS .VP>)>
202 <COND (<ACS .FCN> ;"AC call exists?"
203 <COND (<AND .INT? .SUB?>
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>)
213 <FUNCTION:INITIAL .NAME>)>
215 <CHECK-LOCAL-TAGS .LOCAL-TAGS>
216 <PUT .FCN ,BINDING-STRUCTURE ()>
218 <PUT .FCN ,SYMTAB ,LVARTBL>
220 <COND (.INT? <INT:FINAL .FCN>)
222 <PUT .RDCL 2 <RSUBR-DECLS .FCN>>
223 <FS:INT:FINAL <ACS .FCN>>)>)
225 <PUT .RDCL 2 <RSUBR-DECLS .FCN>>
226 <FCNSUB:FINAL .FCN>)>>
231 <DEFINE TIME-STR1 (NSEC "AUX" (NMIN </ <FIX .NSEC> 60>)
233 #DECL ((NSEC) <OR FIX FLOAT> (NMIN NHRS) FIX (VALUE) STRING)
235 <- .NMIN <* .NHRS 60>>
236 <- .NSEC <* .NMIN 60>>>>
238 <DEFINE TIME-DIF1 (D1 D2 T1 T2
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>
247 <+ <* <1 .T1> 3600> <* <2 .T1> 60> <3 .T1>>>>>
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>>)
257 <STRING <CHTYPE <+ </ .MI 10> 48> CHARACTER>
258 <CHTYPE <+ <MOD .MI 10> 48>
263 <STRING <COND (<OR <NOT <0? .MI>> <NOT <0? .HR>>> "0")
265 <CHTYPE <+ .SE 48> CHARACTER>>)
267 <STRING <CHTYPE <+ </ .SE 10> 48> CHARACTER>
268 <CHTYPE <+ <MOD .SE 10> 48> CHARACTER>>)>>>
270 <ENDPACKAGE>
\ 3\ 3\ 3