Commit | Line | Data |
---|---|---|
c1009b56 TL |
1 | ;--- file: complrb.l |
2 | (include "compmacs.l") | |
3 | ||
4 | (setq compiler-name '"Lisp Compiler V3.0") | |
5 | ||
6 | (setq old-top-level (getd 'top-level)) | |
7 | (setq original-readtable readtable) | |
8 | (setq raw-readtable (makereadtable t)) | |
9 | ||
10 | ;--- lcfinit : called upon compiler startup. If there are any args | |
11 | ; on the command line, we build up a call to lcf, which | |
12 | ; will do the compile. Afterwards we exit. | |
13 | ; | |
14 | (def lcfinit | |
15 | (lambda nil | |
16 | (cond ((greaterp (argv -1) 1) ; build up list of args | |
17 | (do ((i (sub1 (argv -1)) (sub1 i)) (arglis)) | |
18 | ((lessp i 1) | |
19 | (exit (apply 'liszt arglis))) | |
20 | (setq arglis (cons (argv i) arglis)))) | |
21 | (t (patom compiler-name) | |
22 | (terpr poport) | |
23 | (putd 'top-level old-top-level))))) | |
24 | ||
25 | (putd 'top-level (getd 'lcfinit)) | |
26 | ||
27 | ||
28 | ||
29 | \f | |
30 | ;--- lcf - v-x : list containing file name to compile and optionaly | |
31 | ; and output file name for the assembler source. | |
32 | ; | |
33 | (def liszt | |
34 | (nlambda (v-x) | |
35 | (prog (piport v-root v-ifile v-sfile v-ofile | |
36 | vp-ifile vp-sfile vps-crap | |
37 | vps-include | |
38 | k-pid v-crap tmp rootreal | |
39 | tem temr starttime startptime startgccount | |
40 | fl-asm fl-warn fl-verb fl-inter) | |
41 | ||
42 | (setq starttime (syscall 13) ; real time in seconds | |
43 | startptime (ptime) | |
44 | startgccount $gccount$) | |
45 | (setq k-lams (setq k-nlams (setq k-macros nil))) | |
46 | (cond ((null (boundp 'internal-macros)) | |
47 | (setq internal-macros nil))) | |
48 | (cond ((null (boundp 'macros)) | |
49 | (setq macros nil))) | |
50 | (setq k-free nil) | |
51 | (setq er-fatal 0) | |
52 | (setq k-ptrs nil) | |
53 | (setq k-disp -4) | |
54 | (setq k-fnum 0) ; function number | |
55 | (setq w-bind nil) | |
56 | (setq vps-include nil) | |
57 | (setq twa-list nil) | |
58 | ||
59 | (setq x-spec (gensym 'S)) ; flag for special atom | |
60 | ; declare these special | |
61 | (flag nil x-spec) | |
62 | (flag t x-spec) | |
63 | ||
64 | (sstatus feature complr) | |
65 | ||
66 | ; process input form | |
67 | (setq fl-asm t ; assembler file assembled | |
68 | fl-warn t ; print warnings | |
69 | fl-verb t ; be verbose | |
70 | fl-macl nil ; compile maclisp file | |
71 | fl-inter nil ; print intermediate forms | |
72 | ) | |
73 | ||
74 | (do ((i v-x (cdr i))) ; for each argument | |
75 | ((null i)) | |
76 | (setq tem (aexplodec (car i))) | |
77 | ||
78 | (cond ((eq '- (car tem)) ; if switch | |
79 | (do ((j (cdr tem) (cdr j))) | |
80 | ((null j)) | |
81 | (cond ((eq 'S (car j)) (setq fl-asm nil)) | |
82 | ((eq 'm (car j)) (setq fl-macl t)) | |
83 | ((eq 'o (car j)) (setq v-ofile (cadr i) | |
84 | i (cdr i))) | |
85 | ((eq 'w (car j)) (setq fl-warn t)) | |
86 | ((eq 'q (car j)) (setq fl-verb nil)) | |
87 | ((eq 'i (car j)) (setq fl-inter t)) | |
88 | (t (comp-gerr "Unknown switch: " | |
89 | (car j)))))) | |
90 | ((null v-root) | |
91 | (setq temr (reverse tem)) | |
92 | (cond ((and (eq 'l (car temr)) | |
93 | (eq '"." (cadr temr))) | |
94 | (setq rootreal nil) | |
95 | (setq v-root (apply 'concat (reverse (cddr temr))))) | |
96 | (t (setq v-root (car i) | |
97 | rootreal t)))) | |
98 | ||
99 | (t (comp-gerr "Extra input file name: " (car i))))) | |
100 | ||
101 | ||
102 | ||
103 | ; now see what the arguments have left us | |
104 | ||
105 | (cond ((null v-root) | |
106 | (comp-gerr "No file for input")) | |
107 | ((or (portp | |
108 | (setq vp-ifile | |
109 | (car (errset (infile | |
110 | (setq v-ifile | |
111 | (concat v-root '".l"))) | |
112 | nil)))) | |
113 | (and rootreal | |
114 | (portp | |
115 | (setq vp-ifile | |
116 | (car (errset | |
117 | (infile (setq v-ifile v-root)) | |
118 | nil))))))) | |
119 | (t (comp-gerr "Couldn't open the source file :" | |
120 | (or v-ifile)))) | |
121 | ||
122 | ||
123 | (setq k-pid (apply 'concat (cons 'F (cvt (syscall 20))))) | |
124 | ; determine the name of the .s file | |
125 | ; strategy: if fl-asm is t (only assemble) use (v-root).s | |
126 | ; else use /tmp/(k-pid).s | |
127 | ; | |
128 | (cond (fl-asm (setq v-sfile (concat '"/tmp/" | |
129 | k-pid | |
130 | '".s"))) | |
131 | (t (setq v-sfile (concat v-root '".s")))) | |
132 | ||
133 | (cond ((not (portp (setq vp-sfile | |
134 | (car (errset (outfile v-sfile) | |
135 | nil))))) | |
136 | (comp-gerr "Couldn't open the .s file: " | |
137 | (or v-sfile)))) | |
138 | ||
139 | ||
140 | ; determine the name of the .o file (object file) | |
141 | ; strategy: if we aren't supposed to assemble the .s file | |
142 | ; don't worry about a name | |
143 | ; else if a name is given, use it | |
144 | ; else if use (v-root).o | |
145 | (cond ((or v-ofile (null fl-asm))) ;ignore | |
146 | (t (setq v-ofile (concat v-root '".o")))) | |
147 | ||
148 | (cond ((checkfatal) (return 1))) | |
149 | ||
150 | (setq readtable (makereadtable nil)) ; use new readtable | |
151 | ||
152 | ||
153 | ; make i/o descriptors to point to crap file then | |
154 | ; unlink crap file so if we die while compiling the crap | |
155 | ; file will disappear | |
156 | (setq v-crap (concat k-pid k-fnum 'crap)) | |
157 | (setq tmp (outfile v-crap)) ; create output first | |
158 | (setq vps-crap (cons (infile v-crap) tmp)) | |
159 | (apply 'syscall `(10 ',v-crap)) ; unlink it | |
160 | ||
161 | (emit1 `(".." ,k-pid ,k-fnum :)) | |
162 | (emit1 '".long linker") | |
163 | (emit1 '".long BINDER") | |
164 | ||
165 | ; if the macsyma flag is set, change the syntax to the | |
166 | ; maclisp standard syntax. We must be careful that we | |
167 | ; dont clobber any syntax changes made by files preloaded | |
168 | ; into the compiler. | |
169 | ||
170 | (cond (fl-macl (setsyntax '\/ 143) ; 143 = vesc | |
171 | ||
172 | (cond ((equal 143 (status syntax \\)) | |
173 | (setsyntax '\\ 2))) | |
174 | ||
175 | (setsyntax '\| 138) ; 138 = vdq | |
176 | (cond ((equal 138 (status syntax \")) | |
177 | (setsyntax '\" 2))) | |
178 | (cond ((equal 198 (status syntax \[)) | |
179 | (setsyntax '\[ 2) | |
180 | (setsyntax '\] 2))) | |
181 | (setq ibase 8.) | |
182 | (sstatus uctolc t) | |
183 | ||
184 | (flag 'ibase x-spec) ; to be special | |
185 | (flag 'base x-spec) | |
186 | (flag 'tty x-spec) | |
187 | ||
188 | (errset (cond ((null (getd 'macsyma-env)) | |
189 | (load 'machacks))) | |
190 | nil))) | |
191 | ||
192 | (cond ((checkfatal) (return 1))) ; leave if fatal errors | |
193 | ||
194 | (comp-note "Compilation begins with " (or compiler-name)) | |
195 | (comp-note "source: " (or v-ifile) ", result: " | |
196 | (cond (fl-asm v-ofile) (t v-sfile))) | |
197 | (setq piport vp-ifile) ; set to standard input | |
198 | ||
199 | loop | |
200 | ;(cond ((atom (errset (do ((i (read) (read))) | |
201 | ; ((eq i 'eof) nil) | |
202 | ; (cleanup) | |
203 | ; (lcfform i)))) | |
204 | ; (patom '"error during compilation, I quit"))) | |
205 | ||
206 | (cond ((atom (errset | |
207 | (do ((i (read piport '<<end-of-file>>) | |
208 | (read piport '<<end-of-file>>))) | |
209 | ((eq i '<<end-of-file>>) nil) | |
210 | (cleanup) | |
211 | (catch (lcfform i) Comp-error)))) | |
212 | (comp-note "Lisp error during compilation") | |
213 | (setq piport nil) | |
214 | (setq er-fatal (add1 er-fatal)) | |
215 | (return 1))) | |
216 | ||
217 | (close piport) | |
218 | ||
219 | (cond ((checkfatal) (return 1))) | |
220 | ||
221 | ; if doing special character stuff (maclisp) reassert | |
222 | ; the state | |
223 | ||
224 | (cond (vps-include | |
225 | (comp-note " done include") | |
226 | (setq piport (car vps-include)) | |
227 | (setq vps-include (cdr vps-include)) | |
228 | (go loop))) | |
229 | ||
230 | ; reset input base | |
231 | (setq ibase 10.) | |
232 | ||
233 | ||
234 | (close (cdr vps-crap)) | |
235 | ||
236 | (setq vp-ifile (car vps-crap)) ; read crap file | |
237 | ||
238 | ((lambda (readtable) | |
239 | (do ((i (read vp-ifile '<<end-of-file>>) | |
240 | (read vp-ifile '<<end-of-file>>))) | |
241 | ((eq i '<<end-of-file>>) nil) | |
242 | (setq w-bind (cons (list 0 i 'Crap) w-bind))) | |
243 | ||
244 | (cm-alist)) | |
245 | raw-readtable) | |
246 | ||
247 | (close vp-sfile) ; close assembler language file | |
248 | (comp-note "Compilation complete") | |
249 | ||
250 | (setq tem (Divide (difference (syscall 13) starttime) 60)) | |
251 | (comp-note " Real time: " (car tem) " minutes, " | |
252 | (cadr tem) " seconds") | |
253 | (setq tem (ptime)) | |
254 | (setq temr (Divide (difference (car tem) (car startptime)) | |
255 | 3600)) | |
256 | (comp-note " CPU time: " (car temr) " minutes, " | |
257 | (quotient (cadr temr) 60.0) " seconds") | |
258 | (setq temr (Divide (difference (cadr tem) (cadr startptime)) | |
259 | 3600)) | |
260 | (comp-note " of which " (car temr) " minutes and " | |
261 | (quotient (cadr temr) 60.0) | |
262 | " seconds were for the " | |
263 | (difference $gccount$ startgccount) | |
264 | " gcs which were done") | |
265 | ||
266 | ||
267 | (cond (fl-asm ; assemble file | |
268 | (comp-note "Assembly begins") | |
269 | (cond ((not | |
270 | (zerop | |
271 | (setq tmp | |
272 | (apply 'process | |
273 | (ncons (concat '"as -o " | |
274 | v-ofile | |
275 | '" " | |
276 | v-sfile)))))) | |
277 | (comp-gerr "Assembler detected error, code: " | |
278 | (or tmp))) | |
279 | (t (comp-note "Assembly completed successfully"))))) | |
280 | (cond (fl-asm (apply 'syscall `(10 ',v-sfile)))) | |
281 | ||
282 | (setq readtable original-readtable) | |
283 | (return 0)))) | |
284 | ||
285 | (def checkfatal | |
286 | (lambda nil | |
287 | (cond ((greaterp er-fatal 0) | |
288 | (comp-note "Compilation aborted") | |
289 | t)))) | |
290 | \f | |
291 | ||
292 | ;--- lcfform - i : form to compile | |
293 | ; This compiles one form. | |
294 | ; | |
295 | (def lcfform | |
296 | (lambda (i) | |
297 | (prog (tmp v-x) | |
298 | ; macro expand | |
299 | (setq i (cmacroexpand i)) | |
300 | ; now look at what is left | |
301 | (cond ((eq (car i) 'def) ; jkf mod | |
302 | (cond (fl-verb (print (cadr i)) (terpr)(drain))) | |
303 | (dodef i)) | |
304 | ((eq (car i) 'declare) (dodcl i)) | |
305 | ((eq (car i) 'eval-when) (doevalwhen i)) | |
306 | ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile))) | |
307 | ((lambda (internal-macros) ; compile macros too | |
308 | (mapc 'lcfform (cddr i))) | |
309 | t)) | |
310 | ((or (eq (car i) '"%include") | |
311 | (eq (car i) '"include")) | |
312 | (cond ((or (portp (setq v-x | |
313 | (car (errset (infile (cadr i)) nil)))) | |
314 | (portp (setq v-x | |
315 | (car (errset (infile (concat '"/usr/lib/lisp" | |
316 | (cadr i))) | |
317 | nil))))) | |
318 | (setq vps-include (cons piport vps-include)) | |
319 | (setq piport v-x) | |
320 | (comp-note " INCLUDEing file: " (cadr i))) | |
321 | (t (comp-gerr "Cannot open include file: " (cadr i))))) | |
322 | (t ((lambda (readtable) | |
323 | (print i (cdr vps-crap)) | |
324 | (terpr (cdr vps-crap))) | |
325 | raw-readtable)))))) | |
326 | ||
327 | ;--- cmacroexpand - i : functional form | |
328 | ; the form is macro expanded on the top level as many times as | |
329 | ; possible. | |
330 | ; | |
331 | (def cmacroexpand | |
332 | (lambda (i) | |
333 | (cond ((atom i) i) | |
334 | (t (do ((j (ismacro (car i)) (ismacro (car i))) | |
335 | (tmp)) | |
336 | ((null j) i) | |
337 | (cond ((bcdp j) | |
338 | (putd (setq tmp (Gensym nil)) | |
339 | (mfunction (getentry j) 'nlambda))) | |
340 | (t (setq tmp (cons 'nlambda (cdr j))))) | |
341 | (setq i (apply tmp i)) | |
342 | (cond ((atom i) (return i)))))))) | |
343 | \f | |
344 | (def dodef | |
345 | (lambda (v-f) | |
346 | (prog (v-n v-t v-c w-save w-ret w-labs w-locs) | |
347 | (setq k-current (setq v-n (cadr v-f))) ; v-n <= name of func | |
348 | ; add function to approp. list | |
349 | (cond ((or (eq (setq v-t (caaddr v-f)) 'lambda) | |
350 | (eq v-t 'lexpr)) | |
351 | (setq k-lams (cons (list v-n t) k-lams) | |
352 | k-ftype v-t | |
353 | v-t 'lambda)) | |
354 | ((eq v-t 'nlambda) | |
355 | (setq k-nlams (cons (list v-n t) k-nlams) | |
356 | k-ftype 'nlambda)) | |
357 | ((eq v-t 'macro) | |
358 | (setq k-macros (cons (list v-n (caddr v-f)) k-macros)) | |
359 | (setq k-ftype 'macro) | |
360 | (eval v-f) | |
361 | ; if macros is nil, we do not compile this macro | |
362 | (cond ((and (null macros) | |
363 | (null internal-macros)) | |
364 | (return nil)))) | |
365 | (t (comp-err (or v-n) " has an unknown function type" | |
366 | (v-f)))) | |
367 | ||
368 | ||
369 | (setq v-c (concat k-pid k-fnum)) ; v-c <= unique name | |
370 | (setq k-fnum (add1 k-fnum)) | |
371 | (cm-bind v-c v-n v-t) ; update k-regs | |
372 | (setq v-t (f-func (cdaddr v-f))) ; do parse | |
373 | (emit3 '# v-c v-n) ; put out header | |
374 | (cm-alst4 v-n) | |
375 | (cond (fl-inter (print v-t)(terpr))) | |
376 | (cm-emit v-t v-c)))) ; emit code | |
377 | ||
378 | ;--- doevalwhen, process evalwhen directive. This is inadequate. | |
379 | ; | |
380 | (def doevalwhen | |
381 | (lambda (v-f) | |
382 | (prog (docom dolod) | |
383 | (setq docom (member 'compile (cadr v-f)) | |
384 | ||
385 | dolod (member 'load (cadr v-f))) | |
386 | (mapc '(lambda (frm) (cond (docom (eval frm))) | |
387 | (cond (dolod | |
388 | ((lambda (internal-macros) | |
389 | (lcfform frm)) | |
390 | t)))) | |
391 | (cddr v-f))))) | |
392 | ||
393 | \f | |
394 | ;---- dodcl - v-f declare form | |
395 | ; process the declare form given. We evaluate each arg | |
396 | ; | |
397 | (def dodcl | |
398 | (lambda (v-f) | |
399 | (setq v-f (cdr v-f)) | |
400 | (do ((i (car v-f) (car v-f))) | |
401 | ((null i)) | |
402 | (setq v-f (cdr v-f)) | |
403 | (cond ((getd (car i)) (eval i)) ; if this is a function | |
404 | (t (comp-warn "Unknown declare attribute: " (car i))))))) | |
405 | ||
406 | ;---> handlers for declare forms | |
407 | ; | |
408 | (def *fexpr | |
409 | (nlambda (args) | |
410 | (mapc '(lambda (v-x) | |
411 | (setq k-nlams (cons (list v-x t) k-nlams))) | |
412 | args))) | |
413 | (def special | |
414 | (nlambda (v-l) | |
415 | (mapc '(lambda (v-a) | |
416 | (unflag v-a x-con) | |
417 | (flag v-a x-spec)) | |
418 | v-l) | |
419 | t)) | |
420 | (def unspecial | |
421 | (nlambda (v-l) | |
422 | (mapc '(lambda (v-a) | |
423 | (unflag v-a x-spec)) | |
424 | v-l) | |
425 | t)) | |
426 | ||
427 | (def *expr (nlambda (args) nil)) ; ignore | |
428 | ||
429 | (def macros (nlambda (args) (setq macros (car args)))) | |
430 | ;---> end declare form handlers | |
431 | ||
432 | ||
433 | (def cm-bind | |
434 | (lambda (v-lab v-atm v-type) | |
435 | (setq w-bind (cons (list v-lab v-atm v-type) w-bind)))) | |
436 | ||
437 | (def cm-emit | |
438 | (lambda (v-t v-nm) | |
439 | (setq k-back (setq k-regs nil)) | |
440 | (setq k-code v-t) | |
441 | (prog (v-i v-l) | |
442 | (emit2 '".globl" v-nm) | |
443 | (emit1 (list v-nm ':)) | |
444 | next (cond ((null k-code) (return))) | |
445 | (setq v-i (car k-code)) | |
446 | (setq k-code (cdr k-code)) | |
447 | (setq v-l (get (car v-i) x-emit)) | |
448 | (cond ((null (cdr v-i)) | |
449 | (funcall v-l) | |
450 | (go next)) | |
451 | ((ifflag (car v-i) x-asg) | |
452 | (setq v-t (e-reg (cadr v-i) nil))) | |
453 | (t (setq v-t (cadr v-i)))) | |
454 | (apply v-l (rplaca (cdr v-i) v-t)) | |
455 | (go next)))) | |
456 | \f | |
457 | ;--- cm-alist - print out the list of special lispvalues we reference | |
458 | ; in compiled code | |
459 | ; | |
460 | ||
461 | (def cm-alist | |
462 | (lambda nil | |
463 | (prog (cm-alv) | |
464 | (cond (faslflag (emit1 '".text")) | |
465 | (t (emit1 '".data"))) | |
466 | (emit1 '".align 2") | |
467 | (emit1 '"lbnp: .long _bnp") | |
468 | (emit1 '"lfun: .long __qfuncl") | |
469 | (emit1 '"lf4: .long __qf4") | |
470 | (emit1 '"lf3: .long __qf3") | |
471 | (emit1 '"lf2: .long __qf2") | |
472 | (emit1 '"lf1: .long __qf1") | |
473 | (emit1 '"lf0: .long __qf0") | |
474 | (emit2 '"lgc: .long" 0) | |
475 | (emit1 '"linker:" ) | |
476 | (mapc 'cm-alst1 (reverse k-ptrs)) | |
477 | (emit2 '".long" -1) | |
478 | (cond (faslflag (emit1 '".data")) | |
479 | (t (emit1 '".text"))) | |
480 | (emit1 '".align 2") | |
481 | (emit1 '"B:") | |
482 | (emit1 '"BINDER:") | |
483 | (mapc 'cm-alst2 (reverse w-bind)) | |
484 | (emit4 '".long" -1 -1 -1) | |
485 | (emit1 '"litstrt:") | |
486 | (mapc 'cm-alst3 (reverse cm-alv)) | |
487 | (emit1 '"litend:") | |
488 | (cleanup)))) | |
489 | ||
490 | ||
491 | (def cm-alst1 | |
492 | (lambda (v-x) | |
493 | (prog (v-g) | |
494 | (setq v-g (Gensym 's)) | |
495 | (emit2 '".long" (list v-g '-B)) | |
496 | (putprop v-g (car v-x) 'label) | |
497 | (setq cm-alv (cons v-g cm-alv))))) | |
498 | ||
499 | (def cm-alst2 | |
500 | (lambda (v-x) | |
501 | (prog (v-g) | |
502 | (emit2 '".long" (car v-x)) | |
503 | (setq v-g (Gensym 's)) | |
504 | (emit2 '".long" (list v-g '-B)) | |
505 | (putprop v-g (cadr v-x) 'label) | |
506 | (setq cm-alv (cons v-g cm-alv)) | |
507 | (setq v-g (caddr v-x)) | |
508 | (emit2 '".long" | |
509 | (cond ((eq v-g 'lambda) 0) | |
510 | ((eq v-g 'nlambda) 1) | |
511 | ((eq v-g 'macro) 2) | |
512 | ((eq v-g 'Crap) 99) | |
513 | (t 'UDEF_TYPE)))))) | |
514 | ||
515 | (def cm-alst3 | |
516 | (lambda (v-x) | |
517 | ($pr$ v-x) | |
518 | ($pr$ '": ") | |
519 | (setq v-x (get v-x 'label)) | |
520 | (cm-alst4 v-x))) | |
521 | ||
522 | ;--- cm-alst4 - v-x : s-expression | |
523 | ; the given expression is exploded and printed as a string to the | |
524 | ; assembler, this requires that each character be individually | |
525 | ; noted and that the number of bytes on a line be limited. | |
526 | ; | |
527 | (def cm-alst4 | |
528 | (lambda (v-x) | |
529 | ($pr$ '".byte ") | |
530 | (do ((l (explode v-x) (cdr l)) | |
531 | (cnt 1 (add1 cnt))) | |
532 | ((null l) ($pr$ 0) ($terpri)) | |
533 | ($pr$ '\') | |
534 | ($pr$ (car l)) | |
535 | (cond ((greaterp cnt 13) ($terpri) ($pr$ '".byte ") (setq cnt 0)) | |
536 | (t ($pr$ '\,)))))) | |
537 | ;--- w-save | |
538 | ; stack the values of w-ret and w-labs | |
539 | ; | |
540 | (def w-save | |
541 | (lambda nil (setq w-save (cons `(,w-ret ,w-labs ,w-locs) w-save)))) | |
542 | ||
543 | ;--- w-unsave | |
544 | ; restore the values of w-ret and w-labs, popping them | |
545 | ; off the w-save stack | |
546 | ; | |
547 | (def w-unsave | |
548 | (lambda nil (setq w-ret (caar w-save) | |
549 | w-labs (cadar w-save) | |
550 | w-locs (caddar w-save) | |
551 | w-save (cdr w-save)))) | |
552 | \f | |
553 | ||
554 | ;--- f-exp - v-e form to evaluate | |
555 | ; - v-r location to place result in. | |
556 | ; - v-t restof stuff (intermidiate forms) | |
557 | ; | |
558 | ; This is the real workhorse of the compiler. | |
559 | ; | |
560 | (def f-exp | |
561 | (lambda (v-e v-r v-t) | |
562 | (prog (v-f v-i v-tem) | |
563 | begin (cond ; atoms | |
564 | ((f-one v-e) | |
565 | ; if the symbol has not been declared special and is | |
566 | ; not a local variable, we declare it special. | |
567 | (g-specialchk v-e) | |
568 | (return (f-addi (list 'get v-r v-e) v-t))) | |
569 | ||
570 | ; lambda expressions, we do the correct thing. | |
571 | ; should check for bad forms here rather than call | |
572 | ; f-chkf | |
573 | ((not (atom (setq v-f (car v-e)))) | |
574 | (setq v-f (cmacroexpand v-f)) | |
575 | ; must check if the expression changes to an atom | |
576 | (cond ((atom v-f) | |
577 | (setq v-e (cons v-f (cdr v-e))) | |
578 | (go begin))) | |
579 | ||
580 | (cond ((eq 'lambda (car v-f)) | |
581 | (return (f-lambexp v-e v-r v-t))) | |
582 | ; this case is necessary to compile | |
583 | ; ('add 1 2) which the interpreter will | |
584 | ; handle and I guess we should too | |
585 | ((eq 'quote (car v-f)) | |
586 | (comp-warn "Bizzare function name " (or v-f) N) | |
587 | (setq v-e (cons (cadr v-f) (cdr v-e))) | |
588 | (go begin)) | |
589 | (t (comp-err " Illegal expression: " | |
590 | (or v-f) | |
591 | N)))) | |
592 | ||
593 | ; macro expand and continue | |
594 | ((and (or (setq v-e (cmacroexpand v-e)) t) | |
595 | (cond ((or (atom v-e) | |
596 | (not (atom (car v-e)))) | |
597 | (go begin)) ; if reduce to atom | |
598 | ; or lambda exp | |
599 | (t (setq v-f (car v-e)))) | |
600 | nil)) | |
601 | ||
602 | ; special functions | |
603 | ((setq v-i (get v-f x-spf)) (go special)) | |
604 | ((setq v-i (get v-f x-spfq)) | |
605 | (put v-f x-spfq nil) | |
606 | (go special)) | |
607 | ((setq v-i (get v-f x-spfn)) (go special)) | |
608 | ((setq v-i (get v-f x-spfh)) | |
609 | (setq v-e (funcall v-i v-e)) | |
610 | (go normal)) | |
611 | ||
612 | ; macro within compiler | |
613 | ((setq v-i (get v-f 'x-spfm)) | |
614 | (setq v-e (funcall v-i v-e)) | |
615 | (go begin)) | |
616 | ||
617 | ; nlambbdas, we quote the args | |
618 | ((isnlam v-f) | |
619 | (setq v-e (list v-f (list 'quote (cdr v-e)))) | |
620 | (go normal)) | |
621 | ||
622 | ||
623 | ; cxr form where x is elt of {a d} | |
624 | ((setq v-i (chain v-f)) | |
625 | (setq v-t (f-addi | |
626 | (list 'chain | |
627 | v-r | |
628 | (setq v-r (f-use (Gensym nil))) | |
629 | v-i) | |
630 | v-t)) | |
631 | (setq v-e (cadr v-e)) ; calc expr to new v-r | |
632 | (go begin)) | |
633 | ||
634 | ; if this is not the last form before a return, | |
635 | ; we go to normal to do a function invocation | |
636 | ; otherwise we look to see if tail merging is | |
637 | ; possible. | |
638 | ((not (eq (caar v-t) 'return)) (go normal)) | |
639 | ((or (eq (setq v-i w-bv) t) | |
640 | (not (equal v-f w-name))) (go normal)) | |
641 | ((not (f-iter (cdr v-e) (reverse v-i))) (go normal)) ) | |
642 | ||
643 | ; do tail merging. | |
644 | (setq v-t (f-addi '(repeat) v-t)) | |
645 | (setq v-e (reverse (cdr v-e))) | |
646 | iterate (cond ((null v-e) (return v-t)) | |
647 | ((equal (car v-e) (car v-i)) (go next))) | |
648 | (setq v-t (f-addi (list 'set | |
649 | (setq v-r (f-reg 'set)) | |
650 | (car v-i)) | |
651 | v-t)) | |
652 | (setq v-t (f-exp (car v-e) v-r v-t)) | |
653 | next (setq v-e (cdr v-e)) | |
654 | (setq v-i (cdr v-i)) | |
655 | (go iterate) | |
656 | ||
657 | ; the function will be handled specially by the compiler | |
658 | special (cond ((setq v-i (funcall v-i (cdr v-e) v-r v-t)) | |
659 | (return v-i))) | |
660 | ||
661 | ; normal handling, call function. | |
662 | ; if this is a system function, do it quickly | |
663 | normal (cond ((setq v-i (get (car v-e) 'x-sysf)) ; system fcn | |
664 | (setq v-t | |
665 | (f-pusha (cdr v-e) | |
666 | (Gensym nil) | |
667 | (f-addi `(call ,(f-make v-r r-xv) | |
668 | ,v-i | |
669 | ,(length (cdr v-e))) | |
670 | v-t)))) | |
671 | (t (setq v-t | |
672 | (f-pusha `((quote ,(car v-e)) ,@(cdr v-e)) | |
673 | (Gensym nil) | |
674 | (f-addi `(call ,(f-make v-r r-xv) | |
675 | nil | |
676 | ,(length v-e)) | |
677 | v-t))))) | |
678 | ||
679 | (return v-t)))) | |
680 | \f | |
681 | ;--- g-specialchk - v-e : expression | |
682 | ; if v-e is a symbol and not declared special and not a local variable | |
683 | ; we complain and delare it special | |
684 | ; v-e is returned. | |
685 | ; | |
686 | (def g-specialchk | |
687 | (lambda (v-e) | |
688 | (cond ((and (symbolp v-e) | |
689 | (not (get v-e x-spec)) | |
690 | (not (member v-e w-locs))) | |
691 | (flag v-e x-spec) | |
692 | (comp-warn (or v-e) " declared special by compiler"))) | |
693 | v-e)) | |
694 | ||
695 | ||
696 | ;--- f-lambexp - v-e : lambda expression: ((lambda (x y z) exp) a b c) | |
697 | ; - v-r : weather where result should be placed | |
698 | ; - v-t : tail | |
699 | ; | |
700 | ; This compiled a lambda expression. This is a very simple do-expression | |
701 | ; with the difference that returns are not allowed from within it. | |
702 | ||
703 | (def f-lambexp | |
704 | (lambda (v-e v-r v-t) | |
705 | (f-pusha (cdr v-e) | |
706 | (Gensym nil) | |
707 | (f-lambbody (cdar v-e) v-r (length (cadar v-e)) v-t)))) | |
708 | ||
709 | ;--- f-lambbody - v-e : args + body of lambda ((a b c) exp1 exp2 ...) | |
710 | ; - v-ags : number of args pushed for this lambda, it will | |
711 | ; normally equal the length of (cadr v-e) but | |
712 | ; in the case of the top level lambda expression | |
713 | ; in a function it will be 0 | |
714 | ; - v-r : psreg to place result in | |
715 | ; - v-t : tail | |
716 | ; We emit the intermediate expressions necessary to evaluate the | |
717 | ; lambda body | |
718 | ; | |
719 | (def f-lambbody | |
720 | (lambda (v-e v-r v-ags v-t) | |
721 | (w-save) ; stack old values | |
722 | (prog (w-ret w-labs tmp) | |
723 | (setq tmp `((begin ,v-ags) | |
724 | ,@(mapcar '(lambda (arg) (setq w-locs | |
725 | (cons arg w-locs)) | |
726 | `(bind ,arg)) | |
727 | (car v-e)) | |
728 | ,@(f-seq (cdr v-e) | |
729 | v-r | |
730 | `((end nil) | |
731 | ,@v-t)))) | |
732 | (w-unsave) | |
733 | (return tmp)))) | |
734 | ||
735 | ;--- f-func - v-l : function args and body. | |
736 | ; | |
737 | ; result is: (entry type) ; type is lambda,lexpr, macro | |
738 | ; or nlambda | |
739 | ; ..body.. | |
740 | ; | |
741 | ; (fini) | |
742 | ; | |
743 | (def f-func | |
744 | (lambda (v-l) | |
745 | `((entry ,k-ftype) | |
746 | ,@(f-lambbody v-l 'xv 0 '((fini)))))) | |
747 | ||
748 | ||
749 | ;--- f-prog - v-l : args + prog body | |
750 | ; - v-r : psreg to store result in | |
751 | ; - v-t : tail | |
752 | ; | |
753 | (def f-prog | |
754 | (lambda (v-l v-r v-t) | |
755 | (w-save) | |
756 | (prog (w-ret tmp retlb w-labs) | |
757 | (setq tmp (length (car v-l)) ; number of locals | |
758 | retlb (Gensym nil) ; label to leave prog | |
759 | w-labs (Gensym nil) ; hang labels here | |
760 | w-ret `(,v-r . (go ,retlb))) | |
761 | ||
762 | (setq tmp `((pushnil ,tmp) ; start out with nils | |
763 | (begin ,tmp) ; declare variables | |
764 | ,@(mapcar '(lambda (arg) (setq w-locs | |
765 | (cons arg w-locs)) | |
766 | `(bind ,arg)) | |
767 | (car v-l)) ; bind locals | |
768 | ,@(f-seqp (cdr v-l) (Gensym nil) | |
769 | `((get ,v-r nil) | |
770 | (end ,retlb) | |
771 | ,@v-t)))) | |
772 | (w-unsave) | |
773 | (return tmp)))) | |
774 | ||
775 |