4.4BSD/usr/src/old/lisp/liszt/tlev.l
(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file tlev
"$Header: tlev.l,v 1.17 87/12/15 17:08:51 sklower Exp $")
;;; ---- t l e v top level interface
;;;
;;; -[Tue Nov 22 09:21:27 1983 by jkf]-
;--- lisztinit : called upon compiler startup. If there are any args
; on the command line, we build up a call to liszt, which
; will do the compile. Afterwards we exit.
;
(def lisztinit
(lambda nil
(setq fl-asm nil) ; insure it as correct value in case of int
(let ((args (command-line-args)))
(if args
then (signal 2 'liszt-interrupt-signal) ; die on int
(signal 15 'liszt-interrupt-signal) ; die on sigterm
(setq user-top-level nil)
(exit (apply 'liszt args))
else (patom compiler-name)
(patom " [")(patom franz-minor-version-number)(patom "]")
(terpr poport)
(setq user-top-level nil)))))
(setq user-top-level 'lisztinit)
;--- liszt - v-x : list containing file name to compile and optionaly
; and output file name for the assembler source.
;
(def liszt
(nlambda (v-x)
(prog (piport v-root v-ifile v-sfile v-ofile
vp-ifile vp-sfile vps-crap
vps-include vns-include
asm-exit-status ntem temgc temcp
rootreal g-arrayspecs out-path
g-decls g-stdref pre-eval include-files
g-fname g-trueop g-falseop g-didvectorcode
tem temr starttime startptime startgccount
fl-asm fl-warn fl-warnfatal fl-verb fl-inter
fl-xref fl-uci fl-run fl-case fl-anno g-optionalp
liszt-process-forms in-line-lambda-number
g-skipcode g-dropnpcnt g-complrname g-fname)
;in case "S" switch given, set asm-exit-status
; to 0 (so garbage won't be returned).
(setq asm-exit-status 0)
; turn on monitoring if it exists
#+monitoring
(errset (progn (monitor t) ; turn it on
(print 'monitor-on)
(terpr))
nil)
(setq starttime (sys:time) ; real time in seconds
startptime (ptime)
startgccount $gccount$)
(setq in-line-lambda-number (sys:time))
(cond ((null (boundp 'internal-macros))
(setq internal-macros nil)))
(cond ((null (boundp 'macros))
(setq macros nil)))
(setq er-fatal 0 er-warn 0)
(setq vps-include nil
vns-include nil) ;stack of ports and names
(setq twa-list nil)
(setq liszt-eof-forms nil)
; look for lisztrc file and return if error occured
; in reading it
(cond ((eq (do-lisztrc-check) 'error)
(return 1)))
; set up once only g variables
(setq g-comments nil
g-current nil ; current function name
g-funcs nil
g-lits nil
g-trueloc nil
g-tran nil
g-allf nil ; used in xrefs
g-reguse #+(or for-vax for-tahoe)
(copy '((r4 0 . nil) (r3 0 . nil)
(r2 0 . nil); (r7 0 . nil)
(r1 0 . nil)))
#+for-68k (copy '((a0 0 . nil) (a1 0 . nil)
(d1 0 . nil) (d2 0 . nil)
(d4 0 . nil) (d5 0 . nil)))
g-trancnt 0
g-ignorereg nil
g-trueop #+(or for-vax for-tahoe) 'jneq ;used in e-gotot
#+for-68k 'jne
g-falseop #+(or for-vax for-tahoe) 'jeql ;u. in e-gotonil
#+for-68k 'jeq
g-compfcn nil
g-litcnt 0)
(setq g-spec (gensym 'S)) ; flag for special atom
(setq g-fname "") ; no function yet
(setq special nil) ; t if all vrbs are special
(setq g-functype (gensym)
g-vartype (gensym)
g-bindtype (gensym)
g-calltype (gensym)
g-bindloc (gensym)
g-localf (gensym)
g-arrayspecs (gensym)
g-tranloc (gensym)
g-stdref (gensym)
g-optionalp (gensym))
; declare these special
(sstatus feature complr)
(d-makespec 't) ; always special
; process input form
(setq fl-asm t ; assembler file assembled
fl-warn t ; print warnings
fl-warnfatal nil ; warnings are fatal
fl-verb t ; be verbose
fl-macl nil ; compile maclisp file
fl-anno nil ; annotate
fl-inter nil ; do interlisp compatablity
fl-tty nil ; put .s on tty
fl-comments nil ; put in comments
fl-profile nil ; profiling
fl-tran t ; use transfer tables
fl-vms nil ; vms hacks
fl-case nil ; trans uc to lc
fl-xref nil ; xrefs
fl-run nil ; autorun capability
fl-uci nil ; uci lisp compatibility
)
; look in the environment for a LISZT variable
; if it exists, make it the first argument
(if (not (eq '|| (setq tem (getenv 'LISZT))))
then (setq v-x (cons (concat "-" tem) v-x)))
(do ((i v-x (cdr i))) ; for each argument
((null i))
(setq tem (aexplodec (car i)))
(cond ((eq '- (car tem)) ; if switch
(do ((j (cdr tem) (cdr j)))
((null j))
(cond ((eq 'S (car j)) (setq fl-asm nil))
((eq 'C (car j)) (setq fl-comments t))
((eq 'm (car j)) (setq fl-macl t))
((eq 'o (car j)) (setq v-ofile (cadr i)
i (cdr i)))
((eq 'e (car j)) (setq pre-eval (cadr i)
i (cdr i)))
((eq 'i (car j)) (push (cadr i)
include-files)
(pop i))
((eq 'w (car j)) (setq fl-warn nil))
((eq 'W (car j)) (setq fl-warnfatal t))
((eq 'q (car j)) (setq fl-verb nil))
((eq 'Q (car j)) (setq fl-verb t))
((eq 'T (car j)) (setq fl-tty t))
((eq 'a (car j)) (setq fl-anno t))
((eq 'i (car j)) (setq fl-inter t))
((eq 'p (car j)) (setq fl-profile t))
((eq 'F (car j)) (setq fl-tran nil))
((eq 'v (car j)) (setq fl-vms t))
((eq 'r (car j)) (setq fl-run t))
((eq 'x (car j)) (setq fl-xref t))
((eq 'c (car j)) (setq fl-case t))
((eq 'u (car j)) (setq fl-uci t))
((eq '- (car j))) ; ignore extra -'s
(t (comp-gerr "Unknown switch: "
(car j))))))
((null v-root)
(setq temr (reverse tem))
(cond ((and (eq 'l (car temr))
(eq '\. (cadr temr)))
(setq rootreal nil)
(setq v-root
(apply 'concat
(reverse (cddr temr)))))
(t (setq v-root (car i)
rootreal t))))
(t (comp-gerr "Extra input file name: " (car i)))))
;no transfer tables in vms
(cond (fl-vms (setq fl-tran nil)))
; if verbose mode, print out the gc messages and
; fasl messages, else turn them off.
(cond (fl-verb (setq $gcprint t
$ldprint t))
(t (setq $gcprint nil
$ldprint nil)))
; eval arg after -e
(if pre-eval
then (if (null (errset
(eval (readlist (exploden pre-eval)))))
then (comp-gerr "-e form caused error: "
pre-eval)))
; load file after -i arg
(if include-files
then (catch
(mapc
'(lambda (file)
(if (null (errset (load file)))
then (comp-err
"error when loading -i file: "
file)))
include-files)
Comp-error))
; -c says set reader to xlate uc to lc
(cond (fl-case (sstatus uctolc t)))
; If we are a cross compiler, then don't try to
; assemble our output...
;
#+for-vax
(if (or (status feature 68k) (status feature tahoe))
then (setq fl-asm nil))
#+for-tahoe
(if (or (status feature vax) (status feature 68k))
then (setq fl-asm nil))
#+for-68k
(if (or (status feature vax) (status feature tahoe))
then (setq fl-asm nil))
; now see what the arguments have left us
(cond ((null v-root)
(comp-gerr "No file for input"))
((or (portp
(setq vp-ifile
(car (errset (infile
(setq v-ifile
(concat v-root '".l")))
nil))))
(and rootreal
(portp
(setq vp-ifile
(car (errset
(infile (setq v-ifile v-root))
nil)))))))
(t (comp-gerr "Couldn't open the source file :"
(or v-ifile))))
; determine the name of the .s file
; strategy: if fl-asm is t (assemble) use (v-root).s
; else use /tmp/(PID).s
;
; direct asm to tty temporarily
(setq v-sfile "tty")
(setq vp-sfile nil)
(if (null fl-tty) then
(cond (fl-asm (setq v-sfile
(concat '"/tmp/Lzt"
(boole 1 65535
(sys:getpid))
'".s")))
(t (setq v-sfile
(if v-ofile
then v-ofile
else (concat v-root '".s")))))
(cond ((not (portp (setq vp-sfile
(car (errset (outfile v-sfile)
nil)))))
(comp-gerr "Couldn't open the .s file: "
(or v-sfile)))))
; determine the name of the .o file (object file)
; strategy: if we aren't supposed to assemble the .s file
; don't worry about a name
; else if a name is given, use it
; else if use (v-root).o
; if profiling, use .o
(cond ((or v-ofile (null fl-asm))) ;ignore
((null fl-profile) (setq v-ofile (concat v-root ".o")))
(t (setq v-ofile (concat v-root ".o"))))
; determine the name of the .x file (xref file)
; strategy: if fl-xref and v-ofile is true, then use
; v-ofile(minus .o).x, else use (v-root).x
;
(if fl-xref
then ; check for ending with .X for any X
(setq v-xfile
(if v-ofile
then (let ((ex (nreverse
(exploden v-ofile))))
(if (eq #/. (cadr ex))
then (implode
(nreverse
`(#/x #/.
,@(cddr ex))))
else (concat v-ofile ".x")))
else (concat v-root ".x")))
(if (portp
(setq vp-xfile
(car (errset (outfile v-xfile)))))
thenret
else (comp-gerr "Can't open the .x file: "
v-xfile)))
(cond ((checkfatal) (return 1)))
; g-complrname is a symbol which should be unique to
; each fasl'ed file. It will contain the string which
; describes the name of this file and the compiler
; version.
(if fl-anno
then (setq g-complrname (concat "fcn-in-" v-ifile))
(Push g-funcs
`(eval (setq ,g-complrname
,(get_pname
(concat v-ifile
" compiled by "
compiler-name
" on "
(status ctime)))))))
(setq readtable (makereadtable nil)) ; use new readtable
; if the macsyma flag is set, change the syntax to the
; maclisp standard syntax. We must be careful that we
; dont clobber any syntax changes made by files preloaded
; into the compiler.
(cond (fl-macl (setsyntax '\/ 'vescape) ; 143 = vesc
(cond ((eq 'vescape (getsyntax '\\))
(setsyntax '\\ 'vcharacter)))
(cond ((eq 'vleft-bracket (getsyntax '\[))
(setsyntax '\[ 'vcharacter)
(setsyntax '\] 'vcharacter)))
(setq ibase 8.)
(sstatus uctolc t)
(d-makespec 'ibase) ; to be special
(d-makespec 'base)
(d-makespec 'tty)
(errset (cond ((null (getd 'macsyma-env))
(load 'machacks)))
nil))
(fl-uci (load "ucifnc")
(cvttoucilisp)))
(cond (fl-inter (putprop '* 'cc-ignore 'fl-exprcc) ;comment
(remprop '* 'fl-expr)
))
(cond ((checkfatal) (return 1))) ; leave if fatal errors
(if fl-verb
then (comp-msg "Compilation begins with " compiler-name )
(comp-msg "source: " v-ifile ", result: "
(cond (fl-asm v-ofile) (t v-sfile))))
(setq piport vp-ifile) ; set to standard input
(setq liszt-root-name v-root
liszt-file-name v-ifile)
(if fl-run then (d-printautorun))
(if fl-profile then (e-write1 '".globl mcount"))
loop
; main loop of the compiler. It reads a form and
; compiles it. It continues to compile forms from
; liszt-process-forms was long at that list is
; non-empty. This allows one form to spawn off other
; forms to be compiled (an alternative to (progn 'compile))
;
(cond ((atom (list ; list for debugging,
; errset for production.
(do ((i (read piport '<<end-of-file>>)
(read piport '<<end-of-file>>)))
((eq i '<<end-of-file>>) nil)
(setq liszt-process-forms
(cons i liszt-process-forms))
(do ((this (car liszt-process-forms)
(car liszt-process-forms)))
((null liszt-process-forms))
(unpush liszt-process-forms)
(catch (liszt-form this) Comp-error)))))
(catch (comp-err "Lisp error during compilation")
Comp-error)
(setq piport nil)
(setq er-fatal (1+ er-fatal))
(return 1)))
(close piport)
; if doing special character stuff (maclisp) reassert
; the state
(cond (vps-include
(comp-note " done include")
(setq piport (car vps-include)
vps-include (cdr vps-include)
v-ifile (car vns-include)
vns-include (cdr vns-include))
(go loop)))
(cond (liszt-eof-forms
(do ((ll liszt-eof-forms (cdr ll)))
((null ll))
(cond ((atom (errset (liszt-form (car ll))))
(catch
(comp-note "Lisp error during eof forms")
Comp-error)
(setq piport nil)
(return 1))))))
; reset input base
(setq ibase 10.)
(setq readtable (makereadtable t))
(sstatus uctolc nil) ; turn off case conversion
; so bindtab will not have |'s
; to quote lower case
(d-bindtab)
(d-printdocstuff) ; describe this compiler
(cond ((portp vp-sfile)
(close vp-sfile))) ; close assembler language file
; if warnings are to be considered fatal, and if we
; have seen to many warnings, make it fatal
(cond ((and fl-warnfatal (> er-warn 0))
(comp-gerr "Too many warnings")))
; check for fatal errors and don't leave if so
(cond ((checkfatal)
(if fl-asm ; unlink .s file
then (sys:unlink v-sfile)) ; if it is a tmp
(return 1))) ; and ret with error status
(comp-note "Compilation complete")
(setq tem (Divide (difference (sys:time) starttime) 60))
(setq ntem (ptime))
(setq temcp (Divide (difference (car ntem) (car startptime))
3600))
(setq temgc (Divide (difference (cadr ntem) (cadr startptime))
3600))
(comp-note " Time: Real: " (car tem) ":" (cadr tem)
", CPU: " (car temcp) ":" (quotient (cadr temcp) 60.0)
", GC: " (car temgc) ":" (quotient (cadr temgc) 60.0)
" for "
(difference $gccount$ startgccount)
" gcs")
(cond (fl-xref
(comp-note "Cross reference being generated")
(print (list 'File v-ifile) vp-xfile)
(terpr vp-xfile)
(do ((ii g-allf (cdr ii)))
((null ii))
(print (car ii) vp-xfile)
(terpr vp-xfile))
(close vp-xfile)))
; the assember we use must generate the new a.out format
; with a string table. We will assume that the assembler
; is in /usr/lib/lisp/as so that other sites can run
; the new assembler without installing the new assembler
; as /bin/as
(cond (fl-asm ; assemble file
(comp-note "Assembly begins")
(cond ((not
(zerop
(setq asm-exit-status
(*process
(concat
lisp-library-directory
"/as "
#+(or for-vax for-tahoe) "-V" ; use virt mem
" -o "
v-ofile
" "
v-sfile)))))
(comp-gerr "Assembler detected error, code: "
asm-exit-status)
(comp-note "Assembler temp file " v-sfile
" is not unlinked"))
(t (comp-note "Assembly completed successfully")
(errset (sys:unlink v-sfile)); unlink tmp
; file
(if fl-run
then (errset
(sys:chmod v-ofile #O775)))))))
#+(and sun (not unisoft))
(if (and v-ofile fl-run)
then (if (null
(errset (let ((port (fileopen v-ofile "r+")))
(fseek port 20 0)
(tyo 0 port)
(tyo 0 port)
(tyo 128 port)
(tyo 0 port)
(close port))))
then (comp-err
"Error while fixing offset in object file: "
v-ofile)))
(setq readtable original-readtable)
#+monitoring
(errset (progn (monitor) ; turn off monitoring
(print 'monitor-off))
nil)
(sstatus nofeature complr)
(return asm-exit-status))))
(def checkfatal
(lambda nil
(cond ((greaterp er-fatal 0)
(catch (comp-err "Compilation aborted due to previous errors")
Comp-error)
t))))
;--- do-lisztrc-check
; look for a liszt init file named
; .lisztrc or lisztrc or $HOME/.lisztrc or $HOME/lisztrc
; followed by .o or .l or nothing
; return the symbol 'error' if an error occured while reading.
;
(defun do-lisztrc-check nil
(do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
(val)
($gcprint nil)
($ldprint nil))
((null dirs))
(if (setq val
(do ((name '(".lisztrc" "lisztrc") (cdr name))
(val))
((null name))
(if (setq val
(do ((ext '(".o" ".l" "") (cdr ext))
(file))
((null ext))
(if (probef
(setq file (concat (car dirs)
"/"
(car name)
(car ext))))
then (if (atom (errset (load file)))
then (comp-msg
"Error loading liszt init file "
file N
"Compilation aborted" N)
(return 'error)
else (return t)))))
then (return val))))
then (return val))))
;--- liszt-form - i : form to compile
; This compiles one form.
;
(def liszt-form
(lambda (i)
(prog (tmp v-x)
; macro expand
loop
(setq i (d-macroexpand i))
; now look at what is left
(cond ((not (dtpr i)) (Push g-funcs `(eval ,i)))
((eq (car i) 'def)
(cond (fl-verb (print (cadr i)) (terpr)(drain)))
(d-dodef i))
((memq (car i) '(liszt-declare declare))
(funcall 'liszt-declare (cdr i)))
((eq (car i) 'eval-when) (doevalwhen i))
((and (eq (car i) 'progn) (equal (cadr i) '(quote compile)))
((lambda (internal-macros) ; compile macros too
(mapc 'liszt-form (cddr i)))
t))
((or (and (eq (car i) 'includef) (setq tmp (eval (cadr i))))
(and (eq (car i) 'include ) (setq tmp (cadr i))))
(cond ((or (portp (setq v-x
(car (errset (infile tmp) nil))))
(portp (setq v-x
(car
(errset
(infile
(concat
lisp-library-directory
"/"
tmp))
nil))))
(portp (setq v-x
(car (errset (infile (concat tmp
'".l"))
nil)))))
(setq vps-include (cons piport vps-include))
(setq piport v-x)
(comp-note " INCLUDEing file: " tmp)
(setq vns-include (cons v-ifile vns-include)
v-ifile tmp))
(t (comp-gerr "Cannot open include file: " tmp))))
((eq (car i) 'comment) nil) ; just ignore comments
(t ; we have to macro expand
; certain forms we would normally
; just dump in the eval list. This is due to hacks in
; the mit lisp compiler which are relied upon by certain
; code from mit.
(setq i (d-fullmacroexpand i))
(Push g-funcs `(eval ,i)))))))
;--- d-dodef :: handle the def form
; - form : a def form: (def name (type args . body))
;
(defun d-dodef (form)
(prog (g-ftype g-args body lambdaform symlab g-arginfo g-compfcn g-decls)
(setq g-arginfo 'empty)
loop
; extract the components of the def form
(setq g-fname (cadr form))
(if (dtpr (caddr form))
then (setq g-ftype (caaddr form)
g-args (cadaddr form)
body (cddaddr form)
lambdaform (caddr form)
symlab (gensym 'F))
else (comp-gerr "bad def form " form))
; check for a def which uses the mit hackish &xxx forms.
; if seen, convert to a standard form and reexamine
; the vax handles these forms in a special way.
#+for-68k
(if (or (memq '&rest g-args)
(memq '&optional g-args)
(memq '&aux g-args))
then (setq form
`(def ,(cadr form) ,(lambdacvt (cdr lambdaform))))
(go loop))
; check for legal function name.
; then look at the type of the function and update the data base.
(if (null (atom g-fname))
then (comp-err "bad function name")
else (setq g-flocal (get g-fname g-localf)) ; check local decl.
; macros are special, they are always evaluated
; and sometimes compiled.
(if (and (not g-flocal) (eq g-ftype 'macro))
then (eval form)
(if (and (null macros)
(null internal-macros))
then (comp-note g-fname
" macro will not be compiled")
(return nil))
(Push g-funcs `(macro ,symlab ,g-fname))
(if fl-anno then (setq g-arginfo nil)) ; no arg info
elseif g-flocal
then (if (null (or (eq g-ftype 'lambda)
(eq g-ftype 'nlambda)))
then (comp-err
"bad type for local fcn: " g-ftype))
(if (or (memq '&rest g-args)
(memq '&optional g-args)
(memq '&aux g-args))
then (comp-err
"local functions can't use &keyword's "
g-fname))
elseif (or (eq g-ftype 'lambda)
(eq g-ftype 'lexpr))
then (push `(lambda ,symlab ,g-fname) g-funcs)
(putprop g-fname 'lambda g-functype)
elseif (eq g-ftype 'nlambda)
then (Push g-funcs `(nlambda ,symlab ,g-fname))
(putprop g-fname 'nlambda g-functype)
else (comp-err " bad function type " g-ftype)))
(setq g-skipcode nil) ;make sure we aren't skipping code
(forcecomment `(fcn ,g-ftype ,g-fname))
(if g-flocal
then (comp-note g-fname " is a local function")
(e-writel (car g-flocal))
else (if (null fl-vms) then (e-write2 '".globl" symlab))
(e-writel symlab))
(setq g-locs nil g-loccnt 0 g-labs nil g-loc 'reg g-cc nil
g-ret t g-topsym (d-genlab))
(if fl-xref then (setq g-refseen (gensym) g-reflst nil))
(d-clearreg)
#+for-68k (init-regmaskvec)
; set up global variables which maintain knowledge about
; the stack. these variables are set up as if the correct
; number of args were passed.
(setq g-compfcn t) ; now compiling a function
(push nil g-labs) ; no labels in a lambda
(setq g-currentargs (length g-args))
(d-prelude) ; do beginning stuff
; on the vax, we handle & keywords in a special way in
; d-outerlambdacomp. This function also sets g-arginfo.
#+(or for-vax for-tahoe)
(d-outerlambdacomp g-fname g-args (cddr lambdaform))
#+for-68k
(progn
(push (cons 'lambda 0) g-locs)
(mapc '(lambda (x)
(push nil g-locs)
(incr g-loccnt))
g-args)
; set g-arginfo if this is a lambda. If it is a lexpr, then
; we don't give all the info we could.
(setq g-arginfo
(if (eq g-ftype 'lambda)
then (cons g-loccnt g-loccnt)))
(d-lambbody lambdaform))
(d-fini)
(setq g-compfcn nil) ; done compiling a fcn
(if fl-xref then
(Push g-allf
(cons g-fname
(cons (cond (g-flocal (cons g-ftype 'local))
(t g-ftype))
g-reflst))))
(if (and fl-anno (not (eq 'empty g-arginfo)))
then (Push g-funcs `(eval (putprop
',g-fname
(list ',g-arginfo
,g-complrname)
'fcn-info))))
; by storing argument count information during compilation
; we can arg number check calls to this function which occur
; further on.
(if (not (eq 'empty g-arginfo))
then (putprop g-fname (list g-arginfo) 'fcn-info))))
;--- d-lambdalistcheck :: scan lambda var list for & forms
; return
; (required optional rest op-p body)
; required - list of required args
; optional - list of (variable default [optional-p])
; rest - either nil or the name of a variable for optionals
; op-p - list of variables set to t or nil depending if optional exists
; body - body to compile (has &aux's wrapped around it in lambdas)
;
#+(or for-vax for-tahoe)
(defun d-lambdalistcheck (list body)
(do ((xx list (cdr xx))
(state 'req)
(statechange)
(arg)
(req)(optional)(rest)(op-p)(aux))
((null xx)
(list (nreverse req)
(nreverse optional)
rest
(nreverse op-p)
(d-lambda-aux-body-convert body (nreverse aux))))
(setq arg (car xx))
(if (memq arg '(&optional &rest &aux))
then (setq statechange arg)
else (setq statechange nil))
(caseq state
(req
(if statechange
then (setq state statechange)
elseif (and (symbolp arg) arg)
then (push arg req)
else (comp-err " illegal lambda variable " arg)))
(&optional
(if statechange
then (if (memq statechange '(&rest &aux))
then (setq state statechange)
else (comp-err "illegal form in lambda list "
xx))
elseif (symbolp arg)
then ; optional which defaults to nil
(push (list arg nil) optional)
elseif (dtpr arg)
then (if (and (symbolp (car arg))
(symbolp (caddr arg)))
then ; optional with default
(push arg optional)
; save op-p
(if (cddr arg)
then (push (caddr arg) op-p)))
else (comp-err "illegal &optional form "
arg)))
(&rest
(if statechange
then (if (eq statechange '&aux)
then (setq state statechange)
else (comp-err "illegal lambda variable form "
xx))
elseif rest
then (comp-err
"more than one rest variable in lambda list"
arg)
else (setq rest arg)))
(&aux
(if statechange
then (comp-err "illegal lambda form " xx)
elseif (and (symbolp arg) arg)
then (push (list arg nil) aux)
elseif (and (dtpr arg) (and (symbolp (car arg))
(car arg)))
then (push arg aux)))
(t (comp-err "bizzarro internal compiler error ")))))
;--- d-lambda-aux-body-convert :: convert aux's to lambdas
; give a function body and a list of aux variables
; and their inits, place a lambda initializing body around body
; for each lambda (basically doing a let*).
;
#+(or for-vax for-tahoe)
(defun d-lambda-aux-body-convert (body auxlist)
(if (null auxlist)
then body
else `(((lambda (,(caar auxlist))
,@(d-lambda-aux-body-convert body (cdr auxlist)))
,(cadar auxlist)))))
;--- d-outerlambdacomp :: compile a functions outer lambda body
; This function compiles the lambda expression which defines
; the function. This lambda expression differs from the kind that
; appears within a function because
; 1. we aren't sure that the correct number of arguments have been stacked
; 2. the keywords &optional, &rest, and &aux may appear
;
; funname - name of function
; lambdalist - the local argument list, (with possible keywords)
; body - what follows the lambdalist
;
;
;
#+(or for-vax for-tahoe)
(defun d-outerlambdacomp (funname lambdalist body)
(let (((required optional rest op-p newbody)
(d-lambdalistcheck lambdalist body))
(g-decls g-decls)
(reqnum 0) maxwithopt labs (maxnum -1) args)
(d-scanfordecls body)
; if this is a declared lexpr, we aren't called
;
(if (and (null optional) (null rest))
then ; simple, the number of args is required
; if lexpr or local function, then don't bother
(if (and (not g-flocal)
(not (eq g-ftype 'lexpr)))
then (d-checkforfixedargs
funname
(setq reqnum (setq maxnum (length required)))))
else ; complex, unknown number of args
; cases:
; optional, no rest
; optional, with rest
; no optional, rest + required
; no optional, rest + no required
(setq reqnum (length required)
maxwithopt (+ reqnum (length optional))
maxnum (if rest then -1 else maxwithopt))
; determine how many args were given
(e-sub3 '#.lbot-reg '#.np-reg '#.lbot-reg)
#+for-vax (e-write4 'ashl '$-2 '#.lbot-reg '#.lbot-reg)
#+for-tahoe (e-write4 'shar '$2 '#.lbot-reg '#.lbot-reg)
;
(if (null optional)
then ; just a rest
(let ((oklab (d-genlab))
(lllab (d-genlab))
(nopushlab (d-genlab)))
(if (> reqnum 0)
then (e-cmp '#.lbot-reg `($ ,reqnum))
(e-write2 'jgeq oklab)
; not enough arguments given
(d-wnaerr funname reqnum -1)
(e-label oklab))
(e-pushnil 1)
(if (> reqnum 0)
then (e-sub `($ ,reqnum) '#.lbot-reg)
else (e-tst '#.lbot-reg))
(e-write2 'jleq nopushlab)
(e-label lllab)
(e-quick-call '_qcons)
(d-move 'reg 'stack)
#+for-vax (e-write3 'sobgtr '#.lbot-reg lllab)
#+for-tahoe (progn (e-sub '($ 1) '#.lbot-reg)
(e-write2 'bgtr lllab))
(e-label nopushlab))
else ; has optional args
; need one label for each optional plus 2
(do ((xx optional (cdr xx))
(res (list (d-genlab) (d-genlab))))
((null xx) (setq labs res))
(push (d-genlab) res))
; push nils for missing optionals
; one case for required amount and one for
; each possible number of optionals
(e-write4 'casel
'#.lbot-reg `($ ,reqnum)
`($ ,(- maxwithopt reqnum)))
#+for-tahoe (e-write2 '.align '1)
(e-label (car labs))
(do ((xx (cdr labs) (cdr xx))
(head (car labs)))
((null xx))
(e-write2 '.word (concat (car xx) "-" head)))
; get here (when running code) if there are more
; than the optional number of args or if there are
; too few args. If &rest is given, it is permitted
; to have more than the required number
(let ((dorest (d-genlab))
(again (d-genlab))
(afterpush (d-genlab)))
(if rest
then ; check if there are greater than
; the required number
; preserve arg #
(C-push '#.lbot-reg)
(e-sub `($ ,maxwithopt) '#.lbot-reg)
(e-write2 'jgtr dorest)
(C-pop '#.lbot-reg))
; wrong number of args
(d-wnaerr funname reqnum maxnum)
(if rest
then ; now cons the rest forms
(e-label dorest)
(e-pushnil 1) ; list ends with nil
(e-label again)
(e-quick-call '_qcons)
(d-move 'reg 'stack)
; and loop
#+for-vax (e-write3 'sobgtr '#.lbot-reg again)
#+for-tahoe (progn (e-sub '($ 1) '#.lbot-reg)
(e-write2 'bgtr again))
; arg #
(C-pop '#.lbot-reg)
(e-goto afterpush))
; push the nils on the optionals
(do ((xx (cdr labs) (cdr xx)))
((null xx))
(e-label (car xx))
; if we have exactly as many arguments given
; as the number of optionals, then we stack
; a nil if there is a &rest after
; the optionals
(if (null (cdr xx))
then (if rest
then (e-pushnil 1))
else (e-pushnil 1)))
(e-label afterpush))))
; for optional-p's stack t's
(mapc '(lambda (form) (d-move 'T 'stack)) op-p)
; now the variables must be shallow bound
; creat a list of all arguments
(setq args (append required
(mapcar 'car optional)
(if rest then (list rest))
op-p))
(push (cons 'lambda 0) g-locs)
(mapc '(lambda (x)
(push nil g-locs))
args)
(setq g-loccnt (length args))
(d-bindlamb args) ; do shallow binding if necessary
;
; if any of the optionals have non null defaults or
; optional-p's, we have to evaluate their defaults
; or set their predicates.
; first, see if it is necessary
(if (do ((xx optional (cdr xx)))
((null xx) nil)
(if (or (cadar xx) ; if non null default
(caddar xx)); or predicate
then (return t)))
then (makecomment '(do optional defaults and preds))
; create labels again
; need one label for each optional plus 1
(do ((xx optional (cdr xx))
(res (list (d-genlab) )))
((null xx) (setq labs res))
(push (d-genlab) res))
; we need to do something if the argument count
; is between the number of required arguments and
; the maximum number of args with optional minus 1.
; we have one case for the required number and
; one for each optional except the last optional number
;
(let ((afterthis (d-genlab)))
(e-write4 'casel
'#.lbot-reg `($ ,reqnum)
`($ ,(- maxwithopt reqnum 1)))
#+for-tahoe (e-write2 '.align '1)
(e-label (car labs))
(do ((xx (cdr labs) (cdr xx))
(head (car labs)))
((null xx))
(e-write2 '.word (concat (car xx) "-" head)))
(e-goto afterthis)
(do ((ll (cdr labs) (cdr ll))
(op optional (cdr op))
(g-loc nil)
(g-cc nil)
(g-ret nil))
((null ll))
(e-label (car ll))
(if (caddar op)
then (d-exp `(setq ,(caddar op) nil)))
(if (cadar op)
then (d-exp `(setq ,(caar op) ,(cadar op)))))
(e-label afterthis)))
; now compile the function
(d-clearreg)
(setq g-arginfo
(if (eq g-ftype 'nlambda)
then nil
else (cons reqnum (if (>& maxnum 0) then maxnum else nil))))
(makecomment '(begin-fcn-body))
(d-exp (do ((ll newbody (cdr ll))
(g-loc)
(g-cc)
(g-ret))
((null (cdr ll)) (car ll))
(d-exp (car ll))))
(d-unbind)))
#+(or for-vax for-tahoe)
(defun d-checkforfixedargs (fcnname number)
(let ((oklab (d-genlab)))
(makecomment `(,fcnname should-have-exactly ,number args))
; calc -4*# of args
(e-sub '#.np-reg '#.lbot-reg)
(e-cmp '#.lbot-reg `($ ,(- (* number 4))))
(e-write2 'jeql oklab)
(d-wnaerr fcnname number number)
(e-label oklab)))
;--- d-wnaerr :: generate code to call wrong number of args error
; name is the function name,
; min is the minumum number of args for this function
; max is the maximum number (-1 if there is no maximum)
; we encode the min and max in the way shown below.
;
#+(or for-vax for-tahoe)
(defun d-wnaerr (name min max)
(makecomment `(arg error for fcn ,name min ,min max ,max))
(e-move 'r10 '#.lbot-reg)
(C-push `($ ,(+ (* min 1000) (+ max 1))))
(C-push (e-cvt (d-loclit name nil)))
#+for-vax (e-write3 'calls '$2 '_wnaerr)
#+for-tahoe (e-write3 'callf '$12 '_wnaerr))
;--- d-genlab :: generate a pseudo label
;
(defun d-genlab nil
(gensym 'L))
;--- liszt-interrupt-signal
; if we receive a interrupt signal (commonly a ^C), then
; unlink the .s file if we are generating a temporary one
; and exit
(defun liszt-interrupt-signal (sig)
(if (and fl-asm (boundp 'v-sfile) v-sfile)
then (sys:unlink v-sfile))
(exit 1))