![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tlev.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt|
Return to tlev.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file tlev
3: "$Header: tlev.l,v 1.17 87/12/15 17:08:51 sklower Exp $")
4:
5: ;;; ---- t l e v top level interface
6: ;;;
7: ;;; -[Tue Nov 22 09:21:27 1983 by jkf]-
8:
9: ;--- lisztinit : called upon compiler startup. If there are any args
10: ; on the command line, we build up a call to liszt, which
11: ; will do the compile. Afterwards we exit.
12: ;
13: (def lisztinit
14: (lambda nil
15: (setq fl-asm nil) ; insure it as correct value in case of int
16: (let ((args (command-line-args)))
17: (if args
18: then (signal 2 'liszt-interrupt-signal) ; die on int
19: (signal 15 'liszt-interrupt-signal) ; die on sigterm
20: (setq user-top-level nil)
21: (exit (apply 'liszt args))
22: else (patom compiler-name)
23: (patom " [")(patom franz-minor-version-number)(patom "]")
24: (terpr poport)
25: (setq user-top-level nil)))))
26:
27: (setq user-top-level 'lisztinit)
28:
29: ;--- liszt - v-x : list containing file name to compile and optionaly
30: ; and output file name for the assembler source.
31: ;
32: (def liszt
33: (nlambda (v-x)
34: (prog (piport v-root v-ifile v-sfile v-ofile
35: vp-ifile vp-sfile vps-crap
36: vps-include vns-include
37: asm-exit-status ntem temgc temcp
38: rootreal g-arrayspecs out-path
39: g-decls g-stdref pre-eval include-files
40: g-fname g-trueop g-falseop g-didvectorcode
41: tem temr starttime startptime startgccount
42: fl-asm fl-warn fl-warnfatal fl-verb fl-inter
43: fl-xref fl-uci fl-run fl-case fl-anno g-optionalp
44: liszt-process-forms in-line-lambda-number
45: g-skipcode g-dropnpcnt g-complrname g-fname)
46:
47: ;in case "S" switch given, set asm-exit-status
48: ; to 0 (so garbage won't be returned).
49: (setq asm-exit-status 0)
50:
51: ; turn on monitoring if it exists
52: #+monitoring
53: (errset (progn (monitor t) ; turn it on
54: (print 'monitor-on)
55: (terpr))
56: nil)
57: (setq starttime (sys:time) ; real time in seconds
58: startptime (ptime)
59: startgccount $gccount$)
60: (setq in-line-lambda-number (sys:time))
61: (cond ((null (boundp 'internal-macros))
62: (setq internal-macros nil)))
63: (cond ((null (boundp 'macros))
64: (setq macros nil)))
65: (setq er-fatal 0 er-warn 0)
66: (setq vps-include nil
67: vns-include nil) ;stack of ports and names
68: (setq twa-list nil)
69: (setq liszt-eof-forms nil)
70:
71: ; look for lisztrc file and return if error occured
72: ; in reading it
73: (cond ((eq (do-lisztrc-check) 'error)
74: (return 1)))
75:
76: ; set up once only g variables
77: (setq g-comments nil
78: g-current nil ; current function name
79: g-funcs nil
80: g-lits nil
81: g-trueloc nil
82: g-tran nil
83: g-allf nil ; used in xrefs
84: g-reguse #+(or for-vax for-tahoe)
85: (copy '((r4 0 . nil) (r3 0 . nil)
86: (r2 0 . nil); (r7 0 . nil)
87: (r1 0 . nil)))
88: #+for-68k (copy '((a0 0 . nil) (a1 0 . nil)
89: (d1 0 . nil) (d2 0 . nil)
90: (d4 0 . nil) (d5 0 . nil)))
91: g-trancnt 0
92: g-ignorereg nil
93: g-trueop #+(or for-vax for-tahoe) 'jneq ;used in e-gotot
94: #+for-68k 'jne
95: g-falseop #+(or for-vax for-tahoe) 'jeql ;u. in e-gotonil
96: #+for-68k 'jeq
97: g-compfcn nil
98: g-litcnt 0)
99: (setq g-spec (gensym 'S)) ; flag for special atom
100: (setq g-fname "") ; no function yet
101: (setq special nil) ; t if all vrbs are special
102: (setq g-functype (gensym)
103: g-vartype (gensym)
104: g-bindtype (gensym)
105: g-calltype (gensym)
106: g-bindloc (gensym)
107: g-localf (gensym)
108: g-arrayspecs (gensym)
109: g-tranloc (gensym)
110: g-stdref (gensym)
111: g-optionalp (gensym))
112:
113: ; declare these special
114:
115: (sstatus feature complr)
116: (d-makespec 't) ; always special
117:
118: ; process input form
119: (setq fl-asm t ; assembler file assembled
120: fl-warn t ; print warnings
121: fl-warnfatal nil ; warnings are fatal
122: fl-verb t ; be verbose
123: fl-macl nil ; compile maclisp file
124: fl-anno nil ; annotate
125: fl-inter nil ; do interlisp compatablity
126: fl-tty nil ; put .s on tty
127: fl-comments nil ; put in comments
128: fl-profile nil ; profiling
129: fl-tran t ; use transfer tables
130: fl-vms nil ; vms hacks
131: fl-case nil ; trans uc to lc
132: fl-xref nil ; xrefs
133: fl-run nil ; autorun capability
134: fl-uci nil ; uci lisp compatibility
135: )
136:
137: ; look in the environment for a LISZT variable
138: ; if it exists, make it the first argument
139: (if (not (eq '|| (setq tem (getenv 'LISZT))))
140: then (setq v-x (cons (concat "-" tem) v-x)))
141:
142: (do ((i v-x (cdr i))) ; for each argument
143: ((null i))
144: (setq tem (aexplodec (car i)))
145:
146: (cond ((eq '- (car tem)) ; if switch
147: (do ((j (cdr tem) (cdr j)))
148: ((null j))
149: (cond ((eq 'S (car j)) (setq fl-asm nil))
150: ((eq 'C (car j)) (setq fl-comments t))
151: ((eq 'm (car j)) (setq fl-macl t))
152: ((eq 'o (car j)) (setq v-ofile (cadr i)
153: i (cdr i)))
154: ((eq 'e (car j)) (setq pre-eval (cadr i)
155: i (cdr i)))
156: ((eq 'i (car j)) (push (cadr i)
157: include-files)
158: (pop i))
159: ((eq 'w (car j)) (setq fl-warn nil))
160: ((eq 'W (car j)) (setq fl-warnfatal t))
161: ((eq 'q (car j)) (setq fl-verb nil))
162: ((eq 'Q (car j)) (setq fl-verb t))
163: ((eq 'T (car j)) (setq fl-tty t))
164: ((eq 'a (car j)) (setq fl-anno t))
165: ((eq 'i (car j)) (setq fl-inter t))
166: ((eq 'p (car j)) (setq fl-profile t))
167: ((eq 'F (car j)) (setq fl-tran nil))
168: ((eq 'v (car j)) (setq fl-vms t))
169: ((eq 'r (car j)) (setq fl-run t))
170: ((eq 'x (car j)) (setq fl-xref t))
171: ((eq 'c (car j)) (setq fl-case t))
172: ((eq 'u (car j)) (setq fl-uci t))
173: ((eq '- (car j))) ; ignore extra -'s
174: (t (comp-gerr "Unknown switch: "
175: (car j))))))
176: ((null v-root)
177: (setq temr (reverse tem))
178: (cond ((and (eq 'l (car temr))
179: (eq '\. (cadr temr)))
180: (setq rootreal nil)
181: (setq v-root
182: (apply 'concat
183: (reverse (cddr temr)))))
184: (t (setq v-root (car i)
185: rootreal t))))
186:
187: (t (comp-gerr "Extra input file name: " (car i)))))
188:
189: ;no transfer tables in vms
190: (cond (fl-vms (setq fl-tran nil)))
191:
192: ; if verbose mode, print out the gc messages and
193: ; fasl messages, else turn them off.
194: (cond (fl-verb (setq $gcprint t
195: $ldprint t))
196: (t (setq $gcprint nil
197: $ldprint nil)))
198:
199: ; eval arg after -e
200: (if pre-eval
201: then (if (null (errset
202: (eval (readlist (exploden pre-eval)))))
203: then (comp-gerr "-e form caused error: "
204: pre-eval)))
205:
206: ; load file after -i arg
207: (if include-files
208: then (catch
209: (mapc
210: '(lambda (file)
211: (if (null (errset (load file)))
212: then (comp-err
213: "error when loading -i file: "
214: file)))
215: include-files)
216: Comp-error))
217:
218: ; -c says set reader to xlate uc to lc
219: (cond (fl-case (sstatus uctolc t)))
220:
221: ; If we are a cross compiler, then don't try to
222: ; assemble our output...
223: ;
224: #+for-vax
225: (if (or (status feature 68k) (status feature tahoe))
226: then (setq fl-asm nil))
227: #+for-tahoe
228: (if (or (status feature vax) (status feature 68k))
229: then (setq fl-asm nil))
230: #+for-68k
231: (if (or (status feature vax) (status feature tahoe))
232: then (setq fl-asm nil))
233:
234: ; now see what the arguments have left us
235: (cond ((null v-root)
236: (comp-gerr "No file for input"))
237: ((or (portp
238: (setq vp-ifile
239: (car (errset (infile
240: (setq v-ifile
241: (concat v-root '".l")))
242: nil))))
243: (and rootreal
244: (portp
245: (setq vp-ifile
246: (car (errset
247: (infile (setq v-ifile v-root))
248: nil)))))))
249: (t (comp-gerr "Couldn't open the source file :"
250: (or v-ifile))))
251:
252:
253: ; determine the name of the .s file
254: ; strategy: if fl-asm is t (assemble) use (v-root).s
255: ; else use /tmp/(PID).s
256: ;
257: ; direct asm to tty temporarily
258: (setq v-sfile "tty")
259: (setq vp-sfile nil)
260: (if (null fl-tty) then
261: (cond (fl-asm (setq v-sfile
262: (concat '"/tmp/Lzt"
263: (boole 1 65535
264: (sys:getpid))
265: '".s")))
266: (t (setq v-sfile
267: (if v-ofile
268: then v-ofile
269: else (concat v-root '".s")))))
270:
271: (cond ((not (portp (setq vp-sfile
272: (car (errset (outfile v-sfile)
273: nil)))))
274: (comp-gerr "Couldn't open the .s file: "
275: (or v-sfile)))))
276:
277:
278: ; determine the name of the .o file (object file)
279: ; strategy: if we aren't supposed to assemble the .s file
280: ; don't worry about a name
281: ; else if a name is given, use it
282: ; else if use (v-root).o
283: ; if profiling, use .o
284: (cond ((or v-ofile (null fl-asm))) ;ignore
285: ((null fl-profile) (setq v-ofile (concat v-root ".o")))
286: (t (setq v-ofile (concat v-root ".o"))))
287:
288: ; determine the name of the .x file (xref file)
289: ; strategy: if fl-xref and v-ofile is true, then use
290: ; v-ofile(minus .o).x, else use (v-root).x
291: ;
292: (if fl-xref
293: then ; check for ending with .X for any X
294: (setq v-xfile
295: (if v-ofile
296: then (let ((ex (nreverse
297: (exploden v-ofile))))
298: (if (eq #/. (cadr ex))
299: then (implode
300: (nreverse
301: `(#/x #/.
302: ,@(cddr ex))))
303: else (concat v-ofile ".x")))
304: else (concat v-root ".x")))
305: (if (portp
306: (setq vp-xfile
307: (car (errset (outfile v-xfile)))))
308: thenret
309: else (comp-gerr "Can't open the .x file: "
310: v-xfile)))
311: (cond ((checkfatal) (return 1)))
312:
313: ; g-complrname is a symbol which should be unique to
314: ; each fasl'ed file. It will contain the string which
315: ; describes the name of this file and the compiler
316: ; version.
317: (if fl-anno
318: then (setq g-complrname (concat "fcn-in-" v-ifile))
319: (Push g-funcs
320: `(eval (setq ,g-complrname
321: ,(get_pname
322: (concat v-ifile
323: " compiled by "
324: compiler-name
325: " on "
326: (status ctime)))))))
327:
328:
329: (setq readtable (makereadtable nil)) ; use new readtable
330:
331:
332: ; if the macsyma flag is set, change the syntax to the
333: ; maclisp standard syntax. We must be careful that we
334: ; dont clobber any syntax changes made by files preloaded
335: ; into the compiler.
336:
337: (cond (fl-macl (setsyntax '\/ 'vescape) ; 143 = vesc
338:
339: (cond ((eq 'vescape (getsyntax '\\))
340: (setsyntax '\\ 'vcharacter)))
341:
342: (cond ((eq 'vleft-bracket (getsyntax '\[))
343: (setsyntax '\[ 'vcharacter)
344: (setsyntax '\] 'vcharacter)))
345: (setq ibase 8.)
346: (sstatus uctolc t)
347:
348: (d-makespec 'ibase) ; to be special
349: (d-makespec 'base)
350: (d-makespec 'tty)
351:
352: (errset (cond ((null (getd 'macsyma-env))
353: (load 'machacks)))
354: nil))
355: (fl-uci (load "ucifnc")
356: (cvttoucilisp)))
357:
358: (cond (fl-inter (putprop '* 'cc-ignore 'fl-exprcc) ;comment
359: (remprop '* 'fl-expr)
360: ))
361:
362: (cond ((checkfatal) (return 1))) ; leave if fatal errors
363:
364: (if fl-verb
365: then (comp-msg "Compilation begins with " compiler-name )
366: (comp-msg "source: " v-ifile ", result: "
367: (cond (fl-asm v-ofile) (t v-sfile))))
368:
369: (setq piport vp-ifile) ; set to standard input
370: (setq liszt-root-name v-root
371: liszt-file-name v-ifile)
372:
373:
374: (if fl-run then (d-printautorun))
375:
376: (if fl-profile then (e-write1 '".globl mcount"))
377: loop
378:
379: ; main loop of the compiler. It reads a form and
380: ; compiles it. It continues to compile forms from
381: ; liszt-process-forms was long at that list is
382: ; non-empty. This allows one form to spawn off other
383: ; forms to be compiled (an alternative to (progn 'compile))
384: ;
385: (cond ((atom (list ; list for debugging,
386: ; errset for production.
387: (do ((i (read piport '<<end-of-file>>)
388: (read piport '<<end-of-file>>)))
389: ((eq i '<<end-of-file>>) nil)
390: (setq liszt-process-forms
391: (cons i liszt-process-forms))
392: (do ((this (car liszt-process-forms)
393: (car liszt-process-forms)))
394: ((null liszt-process-forms))
395: (unpush liszt-process-forms)
396: (catch (liszt-form this) Comp-error)))))
397: (catch (comp-err "Lisp error during compilation")
398: Comp-error)
399: (setq piport nil)
400: (setq er-fatal (1+ er-fatal))
401: (return 1)))
402:
403: (close piport)
404:
405: ; if doing special character stuff (maclisp) reassert
406: ; the state
407:
408: (cond (vps-include
409: (comp-note " done include")
410: (setq piport (car vps-include)
411: vps-include (cdr vps-include)
412: v-ifile (car vns-include)
413: vns-include (cdr vns-include))
414: (go loop)))
415:
416: (cond (liszt-eof-forms
417: (do ((ll liszt-eof-forms (cdr ll)))
418: ((null ll))
419: (cond ((atom (errset (liszt-form (car ll))))
420: (catch
421: (comp-note "Lisp error during eof forms")
422: Comp-error)
423: (setq piport nil)
424: (return 1))))))
425:
426: ; reset input base
427: (setq ibase 10.)
428: (setq readtable (makereadtable t))
429: (sstatus uctolc nil) ; turn off case conversion
430: ; so bindtab will not have |'s
431: ; to quote lower case
432: (d-bindtab)
433:
434: (d-printdocstuff) ; describe this compiler
435:
436: (cond ((portp vp-sfile)
437: (close vp-sfile))) ; close assembler language file
438:
439: ; if warnings are to be considered fatal, and if we
440: ; have seen to many warnings, make it fatal
441: (cond ((and fl-warnfatal (> er-warn 0))
442: (comp-gerr "Too many warnings")))
443:
444: ; check for fatal errors and don't leave if so
445: (cond ((checkfatal)
446: (if fl-asm ; unlink .s file
447: then (sys:unlink v-sfile)) ; if it is a tmp
448: (return 1))) ; and ret with error status
449:
450: (comp-note "Compilation complete")
451:
452: (setq tem (Divide (difference (sys:time) starttime) 60))
453: (setq ntem (ptime))
454:
455: (setq temcp (Divide (difference (car ntem) (car startptime))
456: 3600))
457:
458: (setq temgc (Divide (difference (cadr ntem) (cadr startptime))
459: 3600))
460:
461: (comp-note " Time: Real: " (car tem) ":" (cadr tem)
462: ", CPU: " (car temcp) ":" (quotient (cadr temcp) 60.0)
463: ", GC: " (car temgc) ":" (quotient (cadr temgc) 60.0)
464: " for "
465: (difference $gccount$ startgccount)
466: " gcs")
467:
468: (cond (fl-xref
469: (comp-note "Cross reference being generated")
470: (print (list 'File v-ifile) vp-xfile)
471: (terpr vp-xfile)
472: (do ((ii g-allf (cdr ii)))
473: ((null ii))
474: (print (car ii) vp-xfile)
475: (terpr vp-xfile))
476: (close vp-xfile)))
477:
478:
479: ; the assember we use must generate the new a.out format
480: ; with a string table. We will assume that the assembler
481: ; is in /usr/lib/lisp/as so that other sites can run
482: ; the new assembler without installing the new assembler
483: ; as /bin/as
484: (cond (fl-asm ; assemble file
485: (comp-note "Assembly begins")
486: (cond ((not
487: (zerop
488: (setq asm-exit-status
489: (*process
490: (concat
491: lisp-library-directory
492: "/as "
493: #+(or for-vax for-tahoe) "-V" ; use virt mem
494: " -o "
495: v-ofile
496: " "
497: v-sfile)))))
498: (comp-gerr "Assembler detected error, code: "
499: asm-exit-status)
500: (comp-note "Assembler temp file " v-sfile
501: " is not unlinked"))
502: (t (comp-note "Assembly completed successfully")
503: (errset (sys:unlink v-sfile)); unlink tmp
504: ; file
505: (if fl-run
506: then (errset
507: (sys:chmod v-ofile #O775)))))))
508:
509: #+(and sun (not unisoft))
510: (if (and v-ofile fl-run)
511: then (if (null
512: (errset (let ((port (fileopen v-ofile "r+")))
513: (fseek port 20 0)
514: (tyo 0 port)
515: (tyo 0 port)
516: (tyo 128 port)
517: (tyo 0 port)
518: (close port))))
519: then (comp-err
520: "Error while fixing offset in object file: "
521: v-ofile)))
522:
523: (setq readtable original-readtable)
524: #+monitoring
525: (errset (progn (monitor) ; turn off monitoring
526: (print 'monitor-off))
527: nil)
528: (sstatus nofeature complr)
529: (return asm-exit-status))))
530:
531: (def checkfatal
532: (lambda nil
533: (cond ((greaterp er-fatal 0)
534: (catch (comp-err "Compilation aborted due to previous errors")
535: Comp-error)
536: t))))
537:
538: ;--- do-lisztrc-check
539: ; look for a liszt init file named
540: ; .lisztrc or lisztrc or $HOME/.lisztrc or $HOME/lisztrc
541: ; followed by .o or .l or nothing
542: ; return the symbol 'error' if an error occured while reading.
543: ;
544: (defun do-lisztrc-check nil
545: (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
546: (val)
547: ($gcprint nil)
548: ($ldprint nil))
549: ((null dirs))
550: (if (setq val
551: (do ((name '(".lisztrc" "lisztrc") (cdr name))
552: (val))
553: ((null name))
554: (if (setq val
555: (do ((ext '(".o" ".l" "") (cdr ext))
556: (file))
557: ((null ext))
558: (if (probef
559: (setq file (concat (car dirs)
560: "/"
561: (car name)
562: (car ext))))
563: then (if (atom (errset (load file)))
564: then (comp-msg
565: "Error loading liszt init file "
566: file N
567: "Compilation aborted" N)
568: (return 'error)
569: else (return t)))))
570: then (return val))))
571: then (return val))))
572:
573:
574: ;--- liszt-form - i : form to compile
575: ; This compiles one form.
576: ;
577: (def liszt-form
578: (lambda (i)
579: (prog (tmp v-x)
580: ; macro expand
581: loop
582: (setq i (d-macroexpand i))
583: ; now look at what is left
584: (cond ((not (dtpr i)) (Push g-funcs `(eval ,i)))
585: ((eq (car i) 'def)
586: (cond (fl-verb (print (cadr i)) (terpr)(drain)))
587: (d-dodef i))
588: ((memq (car i) '(liszt-declare declare))
589: (funcall 'liszt-declare (cdr i)))
590: ((eq (car i) 'eval-when) (doevalwhen i))
591: ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile)))
592: ((lambda (internal-macros) ; compile macros too
593: (mapc 'liszt-form (cddr i)))
594: t))
595: ((or (and (eq (car i) 'includef) (setq tmp (eval (cadr i))))
596: (and (eq (car i) 'include ) (setq tmp (cadr i))))
597: (cond ((or (portp (setq v-x
598: (car (errset (infile tmp) nil))))
599: (portp (setq v-x
600: (car
601: (errset
602: (infile
603: (concat
604: lisp-library-directory
605: "/"
606: tmp))
607: nil))))
608: (portp (setq v-x
609: (car (errset (infile (concat tmp
610: '".l"))
611: nil)))))
612: (setq vps-include (cons piport vps-include))
613: (setq piport v-x)
614: (comp-note " INCLUDEing file: " tmp)
615: (setq vns-include (cons v-ifile vns-include)
616: v-ifile tmp))
617: (t (comp-gerr "Cannot open include file: " tmp))))
618: ((eq (car i) 'comment) nil) ; just ignore comments
619: (t ; we have to macro expand
620: ; certain forms we would normally
621: ; just dump in the eval list. This is due to hacks in
622: ; the mit lisp compiler which are relied upon by certain
623: ; code from mit.
624: (setq i (d-fullmacroexpand i))
625:
626: (Push g-funcs `(eval ,i)))))))
627:
628: ;--- d-dodef :: handle the def form
629: ; - form : a def form: (def name (type args . body))
630: ;
631: (defun d-dodef (form)
632: (prog (g-ftype g-args body lambdaform symlab g-arginfo g-compfcn g-decls)
633:
634:
635: (setq g-arginfo 'empty)
636:
637: loop
638: ; extract the components of the def form
639: (setq g-fname (cadr form))
640: (if (dtpr (caddr form))
641: then (setq g-ftype (caaddr form)
642: g-args (cadaddr form)
643: body (cddaddr form)
644: lambdaform (caddr form)
645: symlab (gensym 'F))
646: else (comp-gerr "bad def form " form))
647:
648: ; check for a def which uses the mit hackish &xxx forms.
649: ; if seen, convert to a standard form and reexamine
650: ; the vax handles these forms in a special way.
651: #+for-68k
652: (if (or (memq '&rest g-args)
653: (memq '&optional g-args)
654: (memq '&aux g-args))
655: then (setq form
656: `(def ,(cadr form) ,(lambdacvt (cdr lambdaform))))
657: (go loop))
658:
659: ; check for legal function name.
660: ; then look at the type of the function and update the data base.
661: (if (null (atom g-fname))
662: then (comp-err "bad function name")
663: else (setq g-flocal (get g-fname g-localf)) ; check local decl.
664: ; macros are special, they are always evaluated
665: ; and sometimes compiled.
666: (if (and (not g-flocal) (eq g-ftype 'macro))
667: then (eval form)
668: (if (and (null macros)
669: (null internal-macros))
670: then (comp-note g-fname
671: " macro will not be compiled")
672: (return nil))
673: (Push g-funcs `(macro ,symlab ,g-fname))
674: (if fl-anno then (setq g-arginfo nil)) ; no arg info
675: elseif g-flocal
676: then (if (null (or (eq g-ftype 'lambda)
677: (eq g-ftype 'nlambda)))
678: then (comp-err
679: "bad type for local fcn: " g-ftype))
680: (if (or (memq '&rest g-args)
681: (memq '&optional g-args)
682: (memq '&aux g-args))
683: then (comp-err
684: "local functions can't use &keyword's "
685: g-fname))
686: elseif (or (eq g-ftype 'lambda)
687: (eq g-ftype 'lexpr))
688: then (push `(lambda ,symlab ,g-fname) g-funcs)
689: (putprop g-fname 'lambda g-functype)
690: elseif (eq g-ftype 'nlambda)
691: then (Push g-funcs `(nlambda ,symlab ,g-fname))
692: (putprop g-fname 'nlambda g-functype)
693: else (comp-err " bad function type " g-ftype)))
694: (setq g-skipcode nil) ;make sure we aren't skipping code
695: (forcecomment `(fcn ,g-ftype ,g-fname))
696: (if g-flocal
697: then (comp-note g-fname " is a local function")
698: (e-writel (car g-flocal))
699: else (if (null fl-vms) then (e-write2 '".globl" symlab))
700: (e-writel symlab))
701: (setq g-locs nil g-loccnt 0 g-labs nil g-loc 'reg g-cc nil
702: g-ret t g-topsym (d-genlab))
703: (if fl-xref then (setq g-refseen (gensym) g-reflst nil))
704: (d-clearreg)
705: #+for-68k (init-regmaskvec)
706: ; set up global variables which maintain knowledge about
707: ; the stack. these variables are set up as if the correct
708: ; number of args were passed.
709: (setq g-compfcn t) ; now compiling a function
710: (push nil g-labs) ; no labels in a lambda
711: (setq g-currentargs (length g-args))
712: (d-prelude) ; do beginning stuff
713:
714: ; on the vax, we handle & keywords in a special way in
715: ; d-outerlambdacomp. This function also sets g-arginfo.
716: #+(or for-vax for-tahoe)
717: (d-outerlambdacomp g-fname g-args (cddr lambdaform))
718:
719: #+for-68k
720: (progn
721: (push (cons 'lambda 0) g-locs)
722: (mapc '(lambda (x)
723: (push nil g-locs)
724: (incr g-loccnt))
725: g-args)
726: ; set g-arginfo if this is a lambda. If it is a lexpr, then
727: ; we don't give all the info we could.
728: (setq g-arginfo
729: (if (eq g-ftype 'lambda)
730: then (cons g-loccnt g-loccnt)))
731: (d-lambbody lambdaform))
732:
733: (d-fini)
734: (setq g-compfcn nil) ; done compiling a fcn
735: (if fl-xref then
736: (Push g-allf
737: (cons g-fname
738: (cons (cond (g-flocal (cons g-ftype 'local))
739: (t g-ftype))
740: g-reflst))))
741: (if (and fl-anno (not (eq 'empty g-arginfo)))
742: then (Push g-funcs `(eval (putprop
743: ',g-fname
744: (list ',g-arginfo
745: ,g-complrname)
746: 'fcn-info))))
747: ; by storing argument count information during compilation
748: ; we can arg number check calls to this function which occur
749: ; further on.
750: (if (not (eq 'empty g-arginfo))
751: then (putprop g-fname (list g-arginfo) 'fcn-info))))
752:
753: ;--- d-lambdalistcheck :: scan lambda var list for & forms
754: ; return
755: ; (required optional rest op-p body)
756: ; required - list of required args
757: ; optional - list of (variable default [optional-p])
758: ; rest - either nil or the name of a variable for optionals
759: ; op-p - list of variables set to t or nil depending if optional exists
760: ; body - body to compile (has &aux's wrapped around it in lambdas)
761: ;
762: #+(or for-vax for-tahoe)
763: (defun d-lambdalistcheck (list body)
764: (do ((xx list (cdr xx))
765: (state 'req)
766: (statechange)
767: (arg)
768: (req)(optional)(rest)(op-p)(aux))
769: ((null xx)
770: (list (nreverse req)
771: (nreverse optional)
772: rest
773: (nreverse op-p)
774: (d-lambda-aux-body-convert body (nreverse aux))))
775: (setq arg (car xx))
776: (if (memq arg '(&optional &rest &aux))
777: then (setq statechange arg)
778: else (setq statechange nil))
779: (caseq state
780: (req
781: (if statechange
782: then (setq state statechange)
783: elseif (and (symbolp arg) arg)
784: then (push arg req)
785: else (comp-err " illegal lambda variable " arg)))
786: (&optional
787: (if statechange
788: then (if (memq statechange '(&rest &aux))
789: then (setq state statechange)
790: else (comp-err "illegal form in lambda list "
791: xx))
792: elseif (symbolp arg)
793: then ; optional which defaults to nil
794: (push (list arg nil) optional)
795: elseif (dtpr arg)
796: then (if (and (symbolp (car arg))
797: (symbolp (caddr arg)))
798: then ; optional with default
799: (push arg optional)
800: ; save op-p
801: (if (cddr arg)
802: then (push (caddr arg) op-p)))
803: else (comp-err "illegal &optional form "
804: arg)))
805: (&rest
806: (if statechange
807: then (if (eq statechange '&aux)
808: then (setq state statechange)
809: else (comp-err "illegal lambda variable form "
810: xx))
811: elseif rest
812: then (comp-err
813: "more than one rest variable in lambda list"
814: arg)
815: else (setq rest arg)))
816: (&aux
817: (if statechange
818: then (comp-err "illegal lambda form " xx)
819: elseif (and (symbolp arg) arg)
820: then (push (list arg nil) aux)
821: elseif (and (dtpr arg) (and (symbolp (car arg))
822: (car arg)))
823: then (push arg aux)))
824: (t (comp-err "bizzarro internal compiler error ")))))
825:
826: ;--- d-lambda-aux-body-convert :: convert aux's to lambdas
827: ; give a function body and a list of aux variables
828: ; and their inits, place a lambda initializing body around body
829: ; for each lambda (basically doing a let*).
830: ;
831: #+(or for-vax for-tahoe)
832: (defun d-lambda-aux-body-convert (body auxlist)
833: (if (null auxlist)
834: then body
835: else `(((lambda (,(caar auxlist))
836: ,@(d-lambda-aux-body-convert body (cdr auxlist)))
837: ,(cadar auxlist)))))
838:
839: ;--- d-outerlambdacomp :: compile a functions outer lambda body
840: ; This function compiles the lambda expression which defines
841: ; the function. This lambda expression differs from the kind that
842: ; appears within a function because
843: ; 1. we aren't sure that the correct number of arguments have been stacked
844: ; 2. the keywords &optional, &rest, and &aux may appear
845: ;
846: ; funname - name of function
847: ; lambdalist - the local argument list, (with possible keywords)
848: ; body - what follows the lambdalist
849: ;
850: ;
851: ;
852: #+(or for-vax for-tahoe)
853: (defun d-outerlambdacomp (funname lambdalist body)
854: (let (((required optional rest op-p newbody)
855: (d-lambdalistcheck lambdalist body))
856: (g-decls g-decls)
857: (reqnum 0) maxwithopt labs (maxnum -1) args)
858: (d-scanfordecls body)
859: ; if this is a declared lexpr, we aren't called
860: ;
861: (if (and (null optional) (null rest))
862: then ; simple, the number of args is required
863: ; if lexpr or local function, then don't bother
864: (if (and (not g-flocal)
865: (not (eq g-ftype 'lexpr)))
866: then (d-checkforfixedargs
867: funname
868: (setq reqnum (setq maxnum (length required)))))
869: else ; complex, unknown number of args
870: ; cases:
871: ; optional, no rest
872: ; optional, with rest
873: ; no optional, rest + required
874: ; no optional, rest + no required
875: (setq reqnum (length required)
876: maxwithopt (+ reqnum (length optional))
877: maxnum (if rest then -1 else maxwithopt))
878: ; determine how many args were given
879: (e-sub3 '#.lbot-reg '#.np-reg '#.lbot-reg)
880: #+for-vax (e-write4 'ashl '$-2 '#.lbot-reg '#.lbot-reg)
881: #+for-tahoe (e-write4 'shar '$2 '#.lbot-reg '#.lbot-reg)
882: ;
883: (if (null optional)
884: then ; just a rest
885: (let ((oklab (d-genlab))
886: (lllab (d-genlab))
887: (nopushlab (d-genlab)))
888: (if (> reqnum 0)
889: then (e-cmp '#.lbot-reg `($ ,reqnum))
890: (e-write2 'jgeq oklab)
891: ; not enough arguments given
892: (d-wnaerr funname reqnum -1)
893: (e-label oklab))
894: (e-pushnil 1)
895: (if (> reqnum 0)
896: then (e-sub `($ ,reqnum) '#.lbot-reg)
897: else (e-tst '#.lbot-reg))
898: (e-write2 'jleq nopushlab)
899: (e-label lllab)
900: (e-quick-call '_qcons)
901: (d-move 'reg 'stack)
902: #+for-vax (e-write3 'sobgtr '#.lbot-reg lllab)
903: #+for-tahoe (progn (e-sub '($ 1) '#.lbot-reg)
904: (e-write2 'bgtr lllab))
905: (e-label nopushlab))
906: else ; has optional args
907: ; need one label for each optional plus 2
908: (do ((xx optional (cdr xx))
909: (res (list (d-genlab) (d-genlab))))
910: ((null xx) (setq labs res))
911: (push (d-genlab) res))
912: ; push nils for missing optionals
913: ; one case for required amount and one for
914: ; each possible number of optionals
915: (e-write4 'casel
916: '#.lbot-reg `($ ,reqnum)
917: `($ ,(- maxwithopt reqnum)))
918: #+for-tahoe (e-write2 '.align '1)
919: (e-label (car labs))
920: (do ((xx (cdr labs) (cdr xx))
921: (head (car labs)))
922: ((null xx))
923: (e-write2 '.word (concat (car xx) "-" head)))
924: ; get here (when running code) if there are more
925: ; than the optional number of args or if there are
926: ; too few args. If &rest is given, it is permitted
927: ; to have more than the required number
928: (let ((dorest (d-genlab))
929: (again (d-genlab))
930: (afterpush (d-genlab)))
931: (if rest
932: then ; check if there are greater than
933: ; the required number
934: ; preserve arg #
935: (C-push '#.lbot-reg)
936: (e-sub `($ ,maxwithopt) '#.lbot-reg)
937: (e-write2 'jgtr dorest)
938: (C-pop '#.lbot-reg))
939: ; wrong number of args
940: (d-wnaerr funname reqnum maxnum)
941: (if rest
942: then ; now cons the rest forms
943: (e-label dorest)
944: (e-pushnil 1) ; list ends with nil
945: (e-label again)
946: (e-quick-call '_qcons)
947: (d-move 'reg 'stack)
948: ; and loop
949: #+for-vax (e-write3 'sobgtr '#.lbot-reg again)
950: #+for-tahoe (progn (e-sub '($ 1) '#.lbot-reg)
951: (e-write2 'bgtr again))
952: ; arg #
953: (C-pop '#.lbot-reg)
954: (e-goto afterpush))
955: ; push the nils on the optionals
956: (do ((xx (cdr labs) (cdr xx)))
957: ((null xx))
958: (e-label (car xx))
959: ; if we have exactly as many arguments given
960: ; as the number of optionals, then we stack
961: ; a nil if there is a &rest after
962: ; the optionals
963: (if (null (cdr xx))
964: then (if rest
965: then (e-pushnil 1))
966: else (e-pushnil 1)))
967: (e-label afterpush))))
968: ; for optional-p's stack t's
969: (mapc '(lambda (form) (d-move 'T 'stack)) op-p)
970:
971: ; now the variables must be shallow bound
972: ; creat a list of all arguments
973: (setq args (append required
974: (mapcar 'car optional)
975: (if rest then (list rest))
976: op-p))
977:
978: (push (cons 'lambda 0) g-locs)
979: (mapc '(lambda (x)
980: (push nil g-locs))
981: args)
982: (setq g-loccnt (length args))
983: (d-bindlamb args) ; do shallow binding if necessary
984: ;
985: ; if any of the optionals have non null defaults or
986: ; optional-p's, we have to evaluate their defaults
987: ; or set their predicates.
988: ; first, see if it is necessary
989: (if (do ((xx optional (cdr xx)))
990: ((null xx) nil)
991: (if (or (cadar xx) ; if non null default
992: (caddar xx)); or predicate
993: then (return t)))
994: then (makecomment '(do optional defaults and preds))
995: ; create labels again
996: ; need one label for each optional plus 1
997: (do ((xx optional (cdr xx))
998: (res (list (d-genlab) )))
999: ((null xx) (setq labs res))
1000: (push (d-genlab) res))
1001: ; we need to do something if the argument count
1002: ; is between the number of required arguments and
1003: ; the maximum number of args with optional minus 1.
1004: ; we have one case for the required number and
1005: ; one for each optional except the last optional number
1006: ;
1007: (let ((afterthis (d-genlab)))
1008: (e-write4 'casel
1009: '#.lbot-reg `($ ,reqnum)
1010: `($ ,(- maxwithopt reqnum 1)))
1011: #+for-tahoe (e-write2 '.align '1)
1012: (e-label (car labs))
1013: (do ((xx (cdr labs) (cdr xx))
1014: (head (car labs)))
1015: ((null xx))
1016: (e-write2 '.word (concat (car xx) "-" head)))
1017: (e-goto afterthis)
1018: (do ((ll (cdr labs) (cdr ll))
1019: (op optional (cdr op))
1020: (g-loc nil)
1021: (g-cc nil)
1022: (g-ret nil))
1023: ((null ll))
1024: (e-label (car ll))
1025: (if (caddar op)
1026: then (d-exp `(setq ,(caddar op) nil)))
1027: (if (cadar op)
1028: then (d-exp `(setq ,(caar op) ,(cadar op)))))
1029: (e-label afterthis)))
1030:
1031: ; now compile the function
1032: (d-clearreg)
1033: (setq g-arginfo
1034: (if (eq g-ftype 'nlambda)
1035: then nil
1036: else (cons reqnum (if (>& maxnum 0) then maxnum else nil))))
1037: (makecomment '(begin-fcn-body))
1038: (d-exp (do ((ll newbody (cdr ll))
1039: (g-loc)
1040: (g-cc)
1041: (g-ret))
1042: ((null (cdr ll)) (car ll))
1043: (d-exp (car ll))))
1044: (d-unbind)))
1045:
1046: #+(or for-vax for-tahoe)
1047: (defun d-checkforfixedargs (fcnname number)
1048: (let ((oklab (d-genlab)))
1049: (makecomment `(,fcnname should-have-exactly ,number args))
1050: ; calc -4*# of args
1051: (e-sub '#.np-reg '#.lbot-reg)
1052: (e-cmp '#.lbot-reg `($ ,(- (* number 4))))
1053: (e-write2 'jeql oklab)
1054: (d-wnaerr fcnname number number)
1055: (e-label oklab)))
1056:
1057: ;--- d-wnaerr :: generate code to call wrong number of args error
1058: ; name is the function name,
1059: ; min is the minumum number of args for this function
1060: ; max is the maximum number (-1 if there is no maximum)
1061: ; we encode the min and max in the way shown below.
1062: ;
1063: #+(or for-vax for-tahoe)
1064: (defun d-wnaerr (name min max)
1065: (makecomment `(arg error for fcn ,name min ,min max ,max))
1066: (e-move 'r10 '#.lbot-reg)
1067: (C-push `($ ,(+ (* min 1000) (+ max 1))))
1068: (C-push (e-cvt (d-loclit name nil)))
1069: #+for-vax (e-write3 'calls '$2 '_wnaerr)
1070: #+for-tahoe (e-write3 'callf '$12 '_wnaerr))
1071:
1072: ;--- d-genlab :: generate a pseudo label
1073: ;
1074: (defun d-genlab nil
1075: (gensym 'L))
1076:
1077: ;--- liszt-interrupt-signal
1078: ; if we receive a interrupt signal (commonly a ^C), then
1079: ; unlink the .s file if we are generating a temporary one
1080: ; and exit
1081: (defun liszt-interrupt-signal (sig)
1082: (if (and fl-asm (boundp 'v-sfile) v-sfile)
1083: then (sys:unlink v-sfile))
1084: (exit 1))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.