![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to complrb.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / liszt|
Return to complrb.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / liszt |
1.1 root 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:
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:
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:
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:
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:
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:
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:
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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.