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