(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file tlev
   "$Header:tlev.l 12.0$")
   "$ACIS:tlev.l 12.0$")

;;; ----	t l e v				top level interface
;;;
;;;				-[Fri Sep  2 21:50:34 1983 by layer]-

;--- 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-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)

		 ;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)
		 (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 #+for-vax (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  #+for-vax 'jneq	; used in e-gotot
		       	 	 #+for-68k 'jne
		       g-falseop #+for-vax 'jeql	; used 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-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 '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 (status feature 68k)
		     then (setq fl-asm nil))
		 #+for-68k
		 (if (status feature vax)
		     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 (errset 		; 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

		 ; 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 "
					#+for-vax "-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-fname 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
	
	#+for-vax
	(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)
	    (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)
;
#+for-vax
(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*).
;
#+for-vax
(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
;
; 
;
#+for-vax
(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)
		(e-write4 'ashl '$-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)
			     (e-write3 'sobgtr '#.lbot-reg 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)))
			 (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-sub2 `($ ,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
				      (e-write3 'sobgtr '#.lbot-reg 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)))
		    (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)))

#+for-vax
(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.
;
#+for-vax
(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)))
   (e-write3 'calls '$2 '_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))
