BSD 3 development

[unix-history] / usr / src / cmd / liszt / complrc.l

;--- file : complrc.l
(include "compmacs.l")

(declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt))
(def $pr$ (macro (x) `(patom ,(cadr x) compout)))

(def put 
  (macro (x)
	 ((lambda (atm prp arg)
		  `(progn (putprop ,atm ,arg ,prp) ,atm))
	  (cadr x) (caddr x) (cadddr x))))

(def f-if 
  (lambda (v-l v-r v-j v-t) 
	  (cond ((eq (caar v-l) 't) 
		 (cond ((null (cdar v-l)) (f-exp t v-r v-t)) 
		       (t (f-seq (cdar v-l) v-r v-t)))) 
		(t (prog (v-tr v-i v-dv) 
			 (setq v-tr (f-reg nil))
			 (setq v-dv 'amb)
			 (cond ((null (cdr v-l)) 
				(setq v-tr v-r) 
				(cond ((null (cdar v-l)) (go loop2))) 
				(setq v-dv nil) 
				(setq v-i (cadr v-j))) 
			       ((null (cdar v-l)) 
				(setq v-tr v-r) 
				(setq v-t (f-if (cdr v-l) v-r v-j v-t)) 
				(setq v-t (f-addi (list 'true (cadr v-j) t)
						  v-t))
				(go loop1)) 
			       (t (setq v-t (f-leap (f-if (cdr v-l)
							  v-r 
							  v-j 
							  v-t))) 
				  (setq v-t (f-addi v-j v-t)) 
				  (setq v-i (cadr s-inst)))) 
			 (setq v-t (f-seq (cdar v-l) v-r v-t)) 
			 (setq v-t (f-addi (list 'false v-i v-dv) v-t)) 
		 loop1 
			 (setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t)) 
		 loop2 
			 (return (f-exp (caar v-l) v-tr v-t))))))) 
;--- f-seqp - v-l : sequence of s-expressions and labels to evaluate
;	    - v-r : psreg in which to store the final result
;	    - v-t : tail.
;	This will do the top level of prog bodies 
;
(def f-seqp 
  (lambda (v-l v-r v-t) 
	  (do ((l (reverse v-l) (cdr l))
	       (newreg v-r)
	       (reg v-r newreg))
	      ((null l) v-t)
	      (cond ((symbolp (car l))
		     (setq v-t (f-labl v-t (car l))))
		    (t (setq v-t (f-exp (car l) reg v-t))
		       (setq newreg (Gensym nil)))))))

;--- f-seq - v-l : sequence of s-expressions to evaluate
;	   - v-r : psreg in which to store the final result
;	   - v-t : tail
;
;	This generates intermediate codes to calculate the s-expressions
;	in v-l.  This does not look for labels.
;
(def f-seq
  (lambda (v-l v-r v-t)
	  (do ((l (reverse v-l) (cdr l))
	       (reg v-r (Gensym nil)))
	      ((null l) v-t)
	      (setq v-t (f-exp (car l) reg v-t)))))
\f
;--- f-pusha - v-l : list of forms to evaluate and push on stack
;	     - v-r : register to place result of last expr in 
;	     - v-t : tail
;	emits code to to evaluate and push forms on the stack.
(def f-pusha
  (lambda (v-l v-r v-t)
	  (cond ((null v-l) v-t) 
		(t (do ((ll (reverse v-l) (cdr ll)) 
			(reg v-r (Gensym nil))
			(res v-t
			     (f-exp (car ll) 
				    reg
				    (f-addi `(push ,(f-use reg)) res))))
		       ((null ll) res))))))

;--- f-iter - v-e : list of expression to evaluate
;	    - v-v : list of variables those expressions will be bound to
;	This checks of the given expressions can be bound to the given
;	variables with no conflicts.  This is determining if tail
;	merging is possible were we replace recursion by iteration.
;
(def f-iter
  (lambda (v-e v-v) 
	  (prog (v-y w-vars) 

	  loop 
		(cond ((null v-e) (return t)) 
		      ((null v-v) (go bad)) 
		      ((ifflag (setq v-y (car v-v)) x-spec) (go bad)) 
		      ((equal (car v-e) v-y) (go usable))
		      (t (go check)))
	  next 
		(setq w-vars (cons v-y w-vars)) 
	  usable 
		(setq v-e (cdr v-e)) 
		(setq v-v (cdr v-v)) 
		(go loop) 
	  check 
	        (cond ((f-nice (car v-e)) (go next))) 
	  bad 
		(return nil)))) 

(def f-nice 
  (lambda (v-e)
	  (cond ((atom v-e) (not (member v-e w-vars))) 
		((atom (car v-e)) 
		 (cond ((eq (car v-e) 'quote) t) 
		       ((ifflag (car v-e) x-dont) nil) 
		       (t (f-all v-e 'f-nice)))) 
		(t (f-all v-e 'f-nice))))) 

;--- f-all - v-l : list
;	   - v-f : function
;	mapc function v-f over v-l as long as the result is non nil
;
(def f-all 
  (lambda (v-l v-f) 
	  (cond ((null v-l) t) 
		((funcall v-f (car v-l)) (f-all (cdr v-l) v-f)) 
		(t nil)))) 

(def f-make 
  (lambda (v-r v-v) 
	  (put v-r x-reg v-v))) 
\f
;--- f-leap - v-t : tail
;	We generate and place in global variable s-inst an itermediate
;	instructin which will jump to the current top location in v-t.
;	If there is not a label on top of v-t, one is added.
;
(def f-leap 
  (lambda (v-t) 
	  (cond ((not (setq s-inst (get (caar v-t) x-leap))) 
		 (setq v-t (f-labl v-t nil)) 
		 (setq s-inst 'go))) 
	  (setq s-inst (list s-inst (cadar v-t))) 
	  v-t)) 

;--- f-labl - v-t : tail
;	    - v-l : real label or nil
;	We insure that there is a label on top of v-t. If not we
;	create one. If we are given a label, we associate it with
;	a created label. 
;	Labels in v-t are all gensymed and the association is all
;	on the property list of the value of w-labs.
; Errors: duplicate labels
;
(def f-labl 
  (lambda (v-t v-l) 
	  (prog (v-i) 
		(cond ((eq (caar v-t) 'label) 
		       (cond (v-l (cond ((setq v-i (get w-labs v-l)))
					(t (put w-labs v-l (cadar v-t))
					   (return v-t))))
			     (t (return v-t)))) 
		      
		      ((null v-l) (setq v-i (Gensym nil))) 
		      ((setq v-i (get w-labs v-l))) 
		      (t (put w-labs v-l (setq v-i (Gensym nil))))) 
		(return (f-addi (list 'label v-i) v-t))))) 

(def f-test 
  (lambda (v-t) 
	  (and (eq (caar v-t) 'minus) 
	       (null (caddar v-t))))) 

(def f-vble 
  (lambda (v-v v-r) 
	  (f-use v-r) 
	  (cond ((not (symbolp v-v)) v-v) 
		((null v-v) nil)
		((f-con v-v) v-v) 
		((ifflag v-v x-spec) v-v) 
		((member v-v w-vars) v-v) 
		(t (setq k-free (cons v-v k-free)) 
		   (flag v-v x-spec))))) 

(def f-addi 
  (lambda (v-i v-t) 
	  (prog (v-o) 
		(cond ((not (setq v-o (get (car v-i) x-opt))) (go normal)) 
		      ((setq v-o (funcall v-o  v-i v-t)) (return v-o)))
	   normal 
		(return (cons v-i v-t))))) 

(def f-reg 
  (lambda (v-f) 
	  (cond ((numberp v-f) (put (Gensym nil) x-reg v-f)) 
		(v-f (flag (Gensym nil) v-f)) 
		(t (Gensym nil))))) 

(def f-con 
  (lambda (v-v) 
	  (cond ((ifflag v-v x-spec) nil)
		(t (ifflag v-v x-con)))))

(def f-one 
  (lambda (v-e) 
	  (or (atom v-e) 
	      (eq (car v-e) 'quote)))) 

(def f-swap 
  (lambda (v-t) 
	  (cond ((eq (caar v-t) 'get) (f-swap (cdr v-t))) 
		(t (rplaca (car v-t) 
			   (cond ((eq (caar v-t) 'true) 'false) 
				 (t 'true))))) 
	  v-t)) 

(def f-xval 
  (lambda (v-t v-r) 
	  (cond ((or (eq (caar v-t) 'get) 
		     (eq (caddar v-t) 'amb)) v-t) 
		(t (f-addi (list 'get (f-use v-r) (caddar v-t)) v-t))))) 
\f
;--- f-use - v-r :  psreg whose value is being used
;	we keep track of the number of times the value of a register is
;	used,  the count is kept under the indicator x-count in the
;	psreg's property list.  the count starts at nil, goes to `used'
;	and then to `force'.  Once the count goes to `force' all gets
;	must be done. when the count is used get should look to see
;	if the following intermediate code instruction is the one
;	using the register and in that case it can merge with that
;	instruction
;
(def f-use
  (lambda (v-r)
	  ((lambda (curv)
		   (cond (curv (cond ((not (eq curv 'force)) 
				      (putprop v-r 'force 'x-count))))
			 (t (putprop v-r 'used 'x-count)))
		   v-r)
	   (get v-r 'x-count))))


(def f-chop 
  (lambda (v-t) 
	  (cond ((or (eq (caar v-t) 'label) 
		     (eq (caar v-t) 'end)) v-t) 
		(t (f-chop (cdr v-t)))))) 

(def f-tfo 
  (lambda (v-i v-t) 
	  (cond ((not (f-like v-t '(go label))) nil) 
		((not (equal (cadr v-i) (cadadr v-t))) nil) 
		(t (rplaca (cdr v-i) (cadar v-t)) 
		   (f-swap (rplaca v-t v-i)))))) 

(def f-like 
  (lambda (v-t v-p) 
	  (cond ((null v-p) t) 
		((null v-t) nil) 
		((equal (caar v-t) (car v-p)) (f-like (cdr v-t) (cdr v-p))) 
		(t nil)))) 

(def f-aor 
  (lambda (v-l v-e v-r v-t) 
	  (cond ((null v-l) 
		 (f-addi (list 'get (f-use v-r) (eq v-e 'and)) v-t)) 
		(t (prog (v-j v-dv v-tr v-tr2) 
			 (setq v-dv (eq v-e 'or))
			 (setq v-tr v-r)
			 (setq v-tr2 v-r)
			 (setq v-e 
			       (cond ((eq v-e 'and) 'false) 
				     (t 'true))) 
			 (setq v-l (reverse v-l)) 
			 (cond ((null (cdr v-l)) (go loop)) 
			       ((and (f-test v-t) 
				     (not (eq (caadr v-t) 'get))) 
				(cond ((eq (caddadr v-t) 'amb) 
				       (setq v-dv 'amb) 
				       (setq v-tr2 (f-reg nil))) 
				      ((not (equal (caddadr v-t) v-dv)) 
				       (setq v-dv 'amb))) 
				(cond ((equal (caadr v-t) v-e) 
				       (setq v-j (cadadr v-t)) 
				       (go loop))) 
				(rplacd (cdr v-t) (f-leap (cddr v-t)))) 
			       (t (setq v-t (f-leap v-t)))) 
			 (setq v-j (cadr s-inst)) 
		  loop 
			 (setq v-t (f-exp (car v-l) v-tr v-t)) 
			 (setq v-tr v-tr2) 
			 (cond ((null (setq v-l (cdr v-l))) (return v-t))) 
			 (setq v-t (f-addi (list v-e v-j v-dv) v-t)) 
			 (setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t)) 
			 (go loop)))))) 

(def f-repl 
  (lambda (v-e) 
	  (cons (ucar (car v-e)) (cdr v-e)))) 

;this seems out of date, must change to mapconvert
(def f-domap
  (lambda (v-e) 
	  (prog (v-x) 
		(cond ((setq v-x (f-chkf (cadr v-e) 4)) 
		       (return (list (car v-e) 
				     (list 'quote v-x)
				     (caddr v-e)))) 
		      (t (return v-e))))))

\f
;--- mapconvert - access : function to access parts of lists
;		- join	 : function to join results
;		- resu	 : function to apply to result
;		- form	 : mapping form
;	This function converts maps to an equivalent do form.
;
(def mapconvert
  (lambda (access join resu form )
	  (prog (vrbls finvar acc accform compform tmp)

		(setq finvar (Gensym 'X)   ; holds result

		      vrbls (maplist '(lambda (arg)
					((lambda (temp)
					    (cond ((or resu (cdr arg))
						   `(,temp ,(car arg)
							   (cdr ,temp)))
						  (t `(,temp 
						       (setq ,finvar ,(car arg))
						       (cdr ,temp)))))
					 (Gensym 'X)))
				    (cdr form))


		      acc (mapcar '(lambda (tem)
					   (cond (access `(,access ,(car tem)))
						 (t (car tem))))
				  vrbls)

		      accform (cond ((or (atom (setq tmp (car form)))
					 (null (setq tmp (cmacroexpand tmp)))
					 (not (member (car tmp) '(quote function))))
				     `(funcall ,tmp ,@acc))
				    (t `(,(cadr tmp) ,@acc))))
		(return
		 `((lambda (,finvar)
		    (do ( ,@vrbls)
			((null ,(caar vrbls)))
			,(cond (join `(setq ,finvar (,join ,accform ,finvar)))
			       (t accform)))
		    ,(cond (resu `(,resu ,finvar))
			   (t finvar)))
		   nil )))))
(putprop 'mapc 'f-mapc 'x-spfm)
(def f-mapc
  (lambda (v-e)
	  (mapconvert 'car nil nil (cdr v-e))))

(putprop 'mapcar 'f-mapcar 'x-spfm)
(def f-mapcar
  (lambda (v-e)
	  (mapconvert 'car 'cons 'reverse (cdr v-e))))

(putprop 'map 'f-map 'x-spfm)
(def f-map
  (lambda (v-e)
	  (mapconvert nil nil nil (cdr v-e))))


(putprop 'maplist 'f-maplist 'x-spfm)
(def f-maplist
  (lambda (v-e)
	  (mapconvert nil 'cons 'reverse (cdr v-e))))




(def f-initv
  (lambda (v-l)
	  (mapcar 'car (car v-l))))

(def f-inits
  (lambda (v-l)
	  (mapcar 'cadr (car v-l))))

(def f-repv
  (lambda (v-l)
	  (prog (v-x)
		(setq v-l (car v-l))
	   lp 
		(cond ((null v-l) (return (reverse v-x))))
		(cond ((cddar v-l) (setq v-x (cons (caar v-l) v-x))))
		(setq v-l (cdr v-l))
		(go lp))))

(def f-reps
  (lambda (v-l)
	  (prog (v-x v-y)
		(setq v-l (car v-l))
	   lp 
		(cond ((null v-l) (return (reverse v-x))))
		(cond ((cddar v-l) 
		       (setq v-y (caddar v-l)) (setq v-x (cons v-y v-x))))
		(setq v-l (cdr v-l))
		(go lp))))

(def f-endtest
  (lambda (v-l)
	  (caadr v-l)))

(def f-endbody
  (lambda (v-l)
	  (cdadr v-l)))

(def f-dobody
  (lambda (v-l)
	  (cddr v-l)))


(putprop 'do 'f-do 'x-spf)

(def f-do
  (lambda (v-l v-r v-t)
    (prog (v-init v-initv v-rep v-repv v-loop v-outl v-retl)
	(cond ((and (car v-l) (atom (car v-l)))	; look for old do
	       (setq v-l (olddo-to-newdo v-l))))
	(setq v-initv (f-initv v-l)
	      v-init (f-inits v-l)
	      v-repv (f-repv v-l)
	      v-rep (f-reps v-l)
	      v-retl (Gensym nil)
	      v-loop (Gensym nil)
	      v-outl (Gensym nil))
	(w-save)
	(return
	 (f-pusha v-init v-r
	    (prog (w-ret w-labs tmp)
		  (setq w-ret `(,v-r . (go ,v-retl)))
		  (setq w-labs (Gensym nil))
		  (setq tmp 
		   `((begin ,(length v-initv))
		     ,@(mapcar '(lambda (arg) (setq w-locs
							   (cons arg w-locs))
					     `(bind ,arg))
			       v-initv)
		     (label ,v-loop)
		     ,@(f-exp (f-endtest v-l) v-r
			      `((minus ,v-r nil)
				(true ,v-outl nil)
				,@(f-seqp (f-dobody v-l) v-r
					  (f-pusha v-rep v-r
					      `((dopop ,v-repv)
						(go ,v-loop)
						(label ,v-outl)
						,@(f-seq (f-endbody v-l) v-r
							 `((end ,v-retl)
							   ,@v-t)))))))))
		  (w-unsave)
		  (return tmp)))))))

(def olddo-to-newdo
  (lambda (v-l)
	  `(((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
	    (,(cadddr v-l) nil)
	    ,@(cddddr v-l))))
\f
(putprop 'cond 'f-cond 'x-spf)

(def f-cond	
  (lambda (v-l v-r v-t) 
	  (setq v-t (f-leap v-t)) 
	  (f-if v-l v-r s-inst v-t))) 

(putprop 'quote 'f-quote 'x-spf)

(def f-quote 
  (lambda (v-l v-r v-t) 
        (f-addi (list 'get v-r (cons 'quote v-l)) v-t))) 

(putprop 'prog 'f-prog 'x-spf)




(putprop 'setq 'f-setq 'x-spf)

(def f-setq 
  (lambda (v-l v-r v-t)
	  (cond ((null (car v-l)) v-t))
	  (do ((ll (reverse v-l) (cddr ll))
	       (reg v-r (Gensym nil)))
	      ((null ll) v-t)
	      (setq v-t (f-exp (car ll)
			       reg
			       `((set ,(f-use reg) ,(g-specialchk (cadr ll)))
				 ,@v-t))))))


(putprop 'rplaca 'f-rplaca 'x-spf)


(def f-rplaca 
  (lambda (v-l v-r v-t)
	  (cond ((f-one (cadr v-l))
		 (f-exp (car v-l) 
			v-r
			(f-exp (cadr v-l) 
			       (setq v-l (Gensym nil))
			       (f-addi (list 'seta (f-use v-r) (f-use v-l))
				       v-t))))
		(t (f-pusha v-l 
			    (Gensym nil)
			    (f-addi (list 'setas v-r) v-t))))))

(putprop 'rplacd 'f-rplacd 'x-spf)


(def f-rplacd 
  (lambda (v-l v-r v-t)
	  (cond ((f-one (cadr v-l))
		 (f-exp (car v-l)
			v-r
			(f-exp (cadr v-l)
			       (setq v-l (Gensym nil))
			       (f-addi (list 'setd (f-use v-r) (f-use v-l)) v-t))))
		(t (f-pusha v-l 
			    (Gensym nil)
			    (f-addi (list 'setds (f-use v-r)) v-t))))))
\f
(putprop 'go 'f-go 'x-spf)

;--- f-go - v-l : label to go to
;	  - v-r : not used
;	  - v-t : tail
; We allow non local go to's, however the goto must go no further than the
; first inclosing prog.
; f-go works by finding the w-labs associated with the first enclosing prog,
; and keeping track of the number of binding levels which must be traversed
; to get to that prog.o
; when it finds the correct w-labs, it checks if this label has been seen yet,
; if not iit assigns it a gensymed symbol.  
; if a binding level must be traversed, we eimit
;	(unbind n)	n is number of binding levels to traverse, 
;			0 means current level only.
;	(go gensymedlabl)
;
; if this is a local goto only the (go gensymedlabl) will be emitted.
;
(def f-go 
  (lambda (v-l v-r v-t) 
	  (prog (use-labs levels)
		(setq v-l (car v-l)) 
		(setq use-labs
		      (cond (w-ret w-labs)
			    (t (do ((ll w-save (cdr ll))
				    (count 0 (add1 count)))
				   ((null ll)
				    (comp-err " go not within prog"))
				   (cond ((caar ll)
					  (setq levels count)
					  (comp-warn " non-local go used")
					  (return (cadar ll))))))))
		
		(cond ((not (setq v-r (get use-labs v-l))) 
		       (put use-labs v-l (setq v-r (Gensym nil))))) 
		(setq v-t (f-addi (list 'go v-r) v-t))
		(cond (levels (setq v-t (f-addi `(unbind ,levels) v-t))))
		(return v-t)))) 

(putprop 'lambda 'f-lambda 'x-spf)

;--- f-lambda - ?? how is this routine called, certainly this isnt the
;		same as ((lambda (n) form)  arg)
;

(putprop 'and 'f-and 'x-spf)

(def f-and 
  (lambda (v-l v-r v-t) 
        (f-aor v-l 'and v-r v-t))) 

(putprop 'or 'f-or 'x-spf)

(def f-or 
  (lambda (v-l v-r v-t) 
        (f-aor v-l 'or v-r v-t))) 



(putprop 'prog2 'prog2toprog 'x-spfm)


;--- prog2toprog - v-e : prog2 expression
; we convert this (prog2 a b c d e f) to
;	(progn a ((lambda (newsim) c d e f newsim) b))
; simple enough.
;
(def prog2toprog
  (lambda (v-e)
	  ((lambda (newsim)
		   `(progn ,(cadr v-e)
			   ((lambda (,newsim)
				    ,@(cdddr v-e)
				    ,newsim)
			    ,(caddr v-e))))
	   (Gensym nil))))


(putprop 'progn 'f-seq 'x-spf)

(putprop 'return 'f-return 'x-spfn)
\f
;--- f-return - v-l : arg to return, may be nil meaning return nil
;	      - v-r : psreg in which to store result
;	      - v-t : tail
;	this handles the return statement.  While returns should
;	occur in progs, this allows for a return inside a context
;	which is inside a prog (or do).  If this is a simple return
;	from prog or do, we have:
;		... code to place to be returned val in v-r
;	      (go retlb)	jump to label at end of prog body
;				but before special unbinding
;	for non local cases we have
;	 	...   code to place value to be returned into v-r
;	      (unwind levels)  where is levels is the number of enclosing
;		      contexts (which begin with a (begin xx)) to return
;		      from.
;	      (go retlb)	then go to the return spot.
;
(def f-return
  (lambda (v-l v-r v-t) 
	  (prog (use-ret levels)
		(setq use-ret 
		      (cond (w-ret)
			    (t (do ((ll w-save (cdr ll))
				    (count 0 (add1 count)))
				   ((null ll) 
				    (comp-err " return not within a prog"))
				   (cond ((caar ll)
					  (setq levels count)
					  (comp-warn " non local return used")
					  (return (caar ll))))))))
		
		(setq v-t (f-addi (cdr use-ret) v-t)) 
		(cond (levels (setq v-t (f-addi `(unbind ,levels) v-t))))
		(return (f-exp (and v-l (car v-l)) (f-use (car use-ret)) v-t))))) 

(putprop 'null 'f-null 'x-spfn)

(def f-null 
  (lambda (v-l v-r v-t) 
	  (cond ((f-test v-t) 
		 (rplaca (cdar (rplacd v-t (f-xval (f-swap (cdr v-t)) v-r)))
			 (f-use (setq v-r (Gensym nil))))
		 (f-exp (car v-l) v-r v-t)))))

(putprop 'not 'f-null 'x-spfn)


(def f-type 
  (lambda (v-l v-r v-t v-bits) 
	  (cond ((f-test v-t) 
		 (setq v-t (f-xval (cdr v-t) v-r))
		 (f-exp (car v-l) 
			(setq v-r (Gensym nil))
			(f-addi (list 'getype (f-use v-r) v-bits) v-t)))))) 

(putprop 'atom 'f-atom 'x-spfn)

(def f-atom 
  (lambda (v-l v-r v-t)
	  (f-type v-l v-r v-t '(0 1 2 4 5 6 7 9 10))))

(putprop 'numberp 'f-numberp 'x-spfn)

(def f-numberp 
  (lambda (v-l v-r v-t) 
	  (f-type v-l v-r v-t '(2 4 9))))

(putprop 'symbolp 'f-symbolp 'x-spfn)

(def f-symbolp 
  (lambda (v-l v-r v-t)
	(f-type v-l v-r v-t 1)))

(putprop 'dtpr 'f-dtpr 'x-spfn)

(def f-dtpr 
  (lambda (v-l v-r v-t)
	  (f-type v-l v-r v-t 3)))

(putprop 'bcdp 'f-bcdp 'x-spfn)

(def f-bcdp 
  (lambda (v-l v-r v-t)
	  (f-type v-l v-r v-t 5)))

(putprop 'stringp 'f-stringp 'x-spfn)

(def f-stringp 
  (lambda (v-l v-r v-t)
	  (f-type v-l v-r v-t 0)))

(putprop 'type 'f-ty 'x-spfn)

(def f-ty 
  (lambda (v-l v-r v-t)
	  (f-exp (car v-l) 
		 (setq v-r (Gensym nil))
		 (f-addi (list 'getype (f-use v-r) 'name) v-t))))

(putprop 'eq 'f-eq 'x-spfn)

(def f-eq 
  (lambda (v-l v-r v-t)
	  (prog (v-r1)
		(cond ((f-test v-t)
		       (setq v-t (f-xval (cdr v-t) v-r))
		       (cond ((and (f-one (car v-l)) (f-one (cadr v-l)))
			      (return (f-addi (list 'eqv (car v-l) (cadr v-l))
					      v-t))))
		       (return (f-pusha v-l 
					(Gensym nil)
					(f-addi '(eqs) v-t))))))))

(putprop 'cons 'f-repl 'x-spfh)

'(putprop 'map 'f-domap 'x-spfh)

'(putprop 'mapc 'f-domap 'x-spfh)

'(putprop 'mapcar 'f-domap 'x-spfh)

'(putprop 'maplist 'f-domap 'x-spfh)

(putprop 'zerop 'f-zerop 'x-spfm)

(def f-zerop 
  (lambda (v-e)
	  (list 'equal 0 (cadr v-e))))

(putprop 'plist 'f-plist 'x-spfm)

(def f-plist 
  (lambda (v-e)
	  (list 'car (cadr v-e))))

(putprop 'go 'f-xgo 'x-opt)

(def f-xgo 
  (lambda (v-i v-t) 
	  (setq v-t (f-chop v-t)) 
	  (cond ((equal (cadr v-i) (cadar v-t)) v-t) 
		(t (cons v-i v-t))))) 

(putprop 'return 'f-xreturn 'x-opt)

(def f-xreturn 
  (lambda (v-i v-t) 
	  (cons v-i (f-chop v-t)))) 

(putprop 'repeat 'f-xreturn 'x-opt)

(putprop 'false 'f-tfo 'x-opt) 

(putprop 'true 'f-tfo 'x-opt) 

\f
(putprop '*catch 'f-*catch 'x-spf)


;--- f-*catch - v-l : list of (tag exp) , tag is evaled, exp is to be run
;	     - v-r : result register
;	     - v-t : tail
;	This compiles a catch by emiting these intermediate codes:
;	..calculate tag..
;	(catchent <gensym> <tag> nil)
;	 .. code to eval (car v-l) ..
;	(catchexit)
;	(label <gensym>)
;
;	The catchent sets up a catch frame on the c-runtime stack.
;	The (car v-l) is evaluated and the result placed in r0 (it must
;	be since that is where the value would be thrown). If no throw
;	is done, it enters the catchexit which pops our catchframe off
;	the stack. If a throw is done it ends up at the label <gensym>
;	with the catch frame already popped off.
;
(def f-*catch
  (lambda (v-l v-r v-t)
	  (prog (v-loop v-tag x y z v-nr)
		(setq v-tag (car v-l))
		; we check to make sure we can force v-r to be r0, else
		; we must give up.
		(cond ((and  (get v-r 'x-reg) 
			     (not (equal (get v-r 'x-reg) 0)))
		       (err '"Can't compile catch correctly"))
		      (t (f-make v-r 0)))

		(return
		 (f-exp v-tag
			(setq v-nr (Gensym nil))
			(f-addi `(catchent ,(setq v-loop (Gensym nil)) 
					   ,(f-use v-nr)
					   nil)
				(f-exp (cadr v-l) (f-use v-r)
				       (f-addi `(catchexit)
					       (f-addi `(label ,v-loop) v-t)))))))))

(putprop 'errset 'f-errset 'x-spf)
;--- f-errset - v-l : list of (errset form [flag])
;	      - v-r : place to put result.
;	      - v-t : tail
;
;	This sets up an errset frame.  It is different than a catch in
;	that the tag is always (ER%all) and the result returned upon
;	a regular exit is listified.
;	again, we must insure that v-r can be forced to be r0 since
;	an err or error will place the result there.
;
(def f-errset
  (lambda (v-l v-r v-t)
	  (prog (v-loop v-tag v-flag v-nr)
		(cond ((and (get v-r 'x-reg) (not (equal (get v-r 'x-reg) 0)))
		       (err '"Can't compile errset  correctly"))
		      (t (f-make v-r 0)))

		; flag tells if error message will be reported, t if so.
		; t is the default
		(cond ((cdr v-l) (setq v-flag (cadr v-l)))
		      (t (setq v-flag t)))

		(return
		  (f-exp v-flag
			 (setq v-nr (Gensym nil))
			 (f-addi `(catchent ,(setq v-loop (Gensym nil)) 
					    '(ER%all)
					    ,(f-use v-nr))
				 (f-exp (car v-l)
					v-r
					`((catchexit)
					  (push ,v-r)
					  (call ,v-r _Lncons 1)
					  (label ,v-loop)
					  ,@v-t))))))))




(putprop '*throw 'f-*throw 'x-spf)

;--- f-*throw - v-l : list of (tag exp)
;	     - v-r : loc to eval exp to
;	     - v-t : tail
;
(def f-*throw
  (lambda (v-l v-r v-t)
	  (let ((v-nr (Gensym nil)))
	       (f-exp (car v-l) 
		      v-nr
		       (f-exp (cadr v-l) v-r
			      (f-addi `(*throw ,(f-use v-r) ,(f-use v-nr)) v-t))))))


(putprop 'arg 'f-arg 'x-spf)

;--- f-arg - v-l : list of arg to evaluate
;	   - v-r : place to store value
;	   - v-t : tail
(def f-arg
  (lambda (v-l v-r v-t)
	  (f-exp (car v-l) v-r
		 (f-addi `(arg ,(f-use v-r))
			 v-t))))