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