(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)))
`(progn (putprop ,atm ,arg ,prp) ,atm))
(cadr x) (caddr x) (cadddr x))))
(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))))
(cond ((null (cdar v-l)) (go loop2)))
(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)
(t (setq v-t (f-leap (f-if (cdr v-l)
(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))
(setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t))
(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
; This will do the top level of prog bodies
(do ((l (reverse v-l) (cdr 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
; This generates intermediate codes to calculate the s-expressions
; in v-l. This does not look for labels.
(do ((l (reverse v-l) (cdr l))
(setq v-t (f-exp (car l) reg v-t)))))
;--- f-pusha - v-l : list of forms to evaluate and push on stack
; - v-r : register to place result of last expr in
; emits code to to evaluate and push forms on the stack.
(t (do ((ll (reverse v-l) (cdr ll))
(f-addi `(push ,(f-use reg)) 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.
(cond ((null v-e) (return t))
((ifflag (setq v-y (car v-v)) x-spec) (go bad))
((equal (car v-e) v-y) (go usable))
(setq w-vars (cons v-y w-vars))
(cond ((f-nice (car v-e)) (go next)))
(cond ((atom v-e) (not (member v-e w-vars)))
(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)))))
; mapc function v-f over v-l as long as the result is non nil
((funcall v-f (car v-l)) (f-all (cdr v-l) v-f))
; 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.
(cond ((not (setq s-inst (get (caar v-t) x-leap)))
(setq v-t (f-labl v-t nil))
(setq s-inst (list s-inst (cadar v-t)))
; - 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
; 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
(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))
((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)))))
(and (eq (caar v-t) 'minus)
(cond ((not (symbolp 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))
(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)))
(return (cons v-i v-t)))))
(cond ((numberp v-f) (put (Gensym nil) x-reg v-f))
(v-f (flag (Gensym nil) v-f))
(cond ((ifflag v-v x-spec) nil)
(t (ifflag v-v x-con)))))
(cond ((eq (caar v-t) 'get) (f-swap (cdr v-t)))
(cond ((eq (caar v-t) 'true) 'false)
(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-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
(cond (curv (cond ((not (eq curv 'force))
(putprop v-r 'force 'x-count))))
(t (putprop v-r 'used 'x-count)))
(cond ((or (eq (caar v-t) 'label)
(eq (caar v-t) 'end)) v-t)
(t (f-chop (cdr 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))))))
((equal (caar v-t) (car v-p)) (f-like (cdr v-t) (cdr v-p)))
(lambda (v-l v-e v-r v-t)
(f-addi (list 'get (f-use v-r) (eq v-e 'and)) v-t))
(t (prog (v-j v-dv v-tr v-tr2)
(cond ((eq v-e 'and) 'false)
(cond ((null (cdr v-l)) (go loop))
(not (eq (caadr v-t) 'get)))
(cond ((eq (caddadr v-t) 'amb)
(setq v-tr2 (f-reg nil)))
((not (equal (caddadr v-t) v-dv))
(cond ((equal (caadr v-t) v-e)
(rplacd (cdr v-t) (f-leap (cddr v-t))))
(t (setq v-t (f-leap v-t))))
(setq v-t (f-exp (car v-l) v-tr v-t))
(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))
(cons (ucar (car v-e)) (cdr v-e))))
;this seems out of date, must change to mapconvert
(cond ((setq v-x (f-chkf (cadr v-e) 4))
;--- mapconvert - access : function to access parts of lists
; - join : function to join results
; - resu : function to apply to result
; This function converts maps to an equivalent do form.
(lambda (access join resu form )
(prog (vrbls finvar acc accform compform tmp)
(setq finvar (Gensym 'X) ; holds result
vrbls (maplist '(lambda (arg)
(cond ((or resu (cdr arg))
(setq ,finvar ,(car arg))
acc (mapcar '(lambda (tem)
(cond (access `(,access ,(car tem)))
accform (cond ((or (atom (setq tmp (car form)))
(null (setq tmp (cmacroexpand tmp)))
(not (member (car tmp) '(quote function))))
(t `(,(cadr tmp) ,@acc))))
,(cond (join `(setq ,finvar (,join ,accform ,finvar)))
,(cond (resu `(,resu ,finvar))
(putprop 'mapc 'f-mapc 'x-spfm)
(mapconvert 'car nil nil (cdr v-e))))
(putprop 'mapcar 'f-mapcar 'x-spfm)
(mapconvert 'car 'cons 'reverse (cdr v-e))))
(putprop 'map 'f-map 'x-spfm)
(mapconvert nil nil nil (cdr v-e))))
(putprop 'maplist 'f-maplist 'x-spfm)
(mapconvert nil 'cons 'reverse (cdr v-e))))
(mapcar 'car (car v-l))))
(mapcar 'cadr (car v-l))))
(cond ((null v-l) (return (reverse v-x))))
(cond ((cddar v-l) (setq v-x (cons (caar v-l) v-x))))
(cond ((null v-l) (return (reverse v-x))))
(setq v-y (caddar v-l)) (setq v-x (cons v-y v-x))))
(putprop 'do 'f-do 'x-spf)
(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)
(setq w-ret `(,v-r . (go ,v-retl)))
(setq w-labs (Gensym nil))
`((begin ,(length v-initv))
,@(mapcar '(lambda (arg) (setq w-locs
,@(f-exp (f-endtest v-l) v-r
,@(f-seqp (f-dobody v-l) v-r
,@(f-seq (f-endbody v-l) v-r
`(((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
(putprop 'cond 'f-cond 'x-spf)
(f-if v-l v-r s-inst v-t)))
(putprop 'quote 'f-quote 'x-spf)
(f-addi (list 'get v-r (cons 'quote v-l)) v-t)))
(putprop 'prog 'f-prog 'x-spf)
(putprop 'setq 'f-setq 'x-spf)
(cond ((null (car v-l)) v-t))
(do ((ll (reverse v-l) (cddr ll))
(setq v-t (f-exp (car ll)
`((set ,(f-use reg) ,(g-specialchk (cadr ll)))
(putprop 'rplaca 'f-rplaca 'x-spf)
(cond ((f-one (cadr v-l))
(f-addi (list 'seta (f-use v-r) (f-use v-l))
(f-addi (list 'setas v-r) v-t))))))
(putprop 'rplacd 'f-rplacd 'x-spf)
(cond ((f-one (cadr v-l))
(f-addi (list 'setd (f-use v-r) (f-use v-l)) v-t))))
(f-addi (list 'setds (f-use v-r)) v-t))))))
(putprop 'go 'f-go 'x-spf)
;--- f-go - v-l : label to go to
; We allow non local go to's, however the goto must go no further than the
; 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
; 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.
; if this is a local goto only the (go gensymedlabl) will be emitted.
(t (do ((ll w-save (cdr ll))
(comp-err " go not within prog"))
(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))))
(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)
(f-aor v-l 'and v-r v-t)))
(putprop 'or 'f-or 'x-spf)
(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))
(putprop 'progn 'f-seq 'x-spf)
(putprop 'return 'f-return 'x-spfn)
;--- f-return - v-l : arg to return, may be nil meaning return nil
; - v-r : psreg in which to store result
; 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
; (go retlb) then go to the return spot.
(t (do ((ll w-save (cdr ll))
(comp-err " return not within a prog"))
(comp-warn " non local return used")
(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)
(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)
(lambda (v-l v-r v-t v-bits)
(setq v-t (f-xval (cdr v-t) v-r))
(f-addi (list 'getype (f-use v-r) v-bits) v-t))))))
(putprop 'atom 'f-atom 'x-spfn)
(f-type v-l v-r v-t '(0 1 2 4 5 6 7 9 10))))
(putprop 'numberp 'f-numberp 'x-spfn)
(f-type v-l v-r v-t '(2 4 9))))
(putprop 'symbolp 'f-symbolp 'x-spfn)
(putprop 'dtpr 'f-dtpr 'x-spfn)
(putprop 'bcdp 'f-bcdp 'x-spfn)
(putprop 'stringp 'f-stringp 'x-spfn)
(putprop 'type 'f-ty 'x-spfn)
(f-addi (list 'getype (f-use v-r) 'name) v-t))))
(putprop 'eq 'f-eq 'x-spfn)
(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))
(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)
(list 'equal 0 (cadr v-e))))
(putprop 'plist 'f-plist 'x-spfm)
(putprop 'go 'f-xgo 'x-opt)
(cond ((equal (cadr v-i) (cadar v-t)) v-t)
(putprop 'return 'f-xreturn 'x-opt)
(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)
(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
; This compiles a catch by emiting these intermediate codes:
; (catchent <gensym> <tag> nil)
; .. code to eval (car v-l) ..
; 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.
(prog (v-loop v-tag x y z v-nr)
; we check to make sure we can force v-r to be r0, else
(cond ((and (get v-r 'x-reg)
(not (equal (get v-r 'x-reg) 0)))
(err '"Can't compile catch correctly"))
(f-addi `(catchent ,(setq v-loop (Gensym nil))
(f-exp (cadr v-l) (f-use v-r)
(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.
; 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.
(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"))
; flag tells if error message will be reported, t if so.
(cond ((cdr v-l) (setq v-flag (cadr v-l)))
(f-addi `(catchent ,(setq v-loop (Gensym nil))
(putprop '*throw 'f-*throw 'x-spf)
;--- f-*throw - v-l : list of (tag exp)
; - v-r : loc to eval exp to
(let ((v-nr (Gensym nil)))
(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
(f-addi `(arg ,(f-use v-r))