(include-if (null (get 'chead 'version)) "../chead.l") (Liszt-file funa "$Header: funa.l,v 1.11 83/08/28 17:14:35 layer Exp $") ;;; ---- f u n a function compilation ;;; ;;; -[Mon Aug 22 22:01:01 1983 by layer]- ;--- cc-and :: compile an and expression ; We evaluate forms from left to right as long as they evaluate to ; a non nil value. We only have to worry about storing the value of ; the last expression in g-loc. ; (defun cc-and nil (let ((finlab (d-genlab)) (finlab2) (exps (if (cdr v-form) thenret else '(t)))) ; (and) ==> t (if (null (cdr g-cc)) then (d-exp (do ((g-cc (cons nil finlab)) (g-loc) (g-ret) (ll exps (cdr ll))) ((null (cdr ll)) (car ll)) (d-exp (car ll)))) (if g-loc then (setq finlab2 (d-genlab)) (e-goto finlab2) (e-label finlab) (d-move 'Nil g-loc) (e-label finlab2) else (e-label finlab)) else ;--- cdr g-cc is non nil, thus there is ; a quick escape possible if one of the ; expressions evals to nil (if (null g-loc) then (setq finlab (cdr g-cc))) (d-exp (do ((g-cc (cons nil finlab)) (g-loc) (g-ret) (ll exps (cdr ll))) ((null (cdr ll)) (car ll)) (d-exp (car ll)))) ; if g-loc is non nil, then we have evaled the and ; expression to yield nil, which we must store in ; g-loc and then jump to where the cdr of g-cc takes us (if g-loc then (setq finlab2 (d-genlab)) (e-goto finlab2) (e-label finlab) (d-move 'Nil g-loc) (e-goto (cdr g-cc)) (e-label finlab2)))) (d-clearreg)) ; we cannot predict the state of the registers ;--- cc-arg :: get the nth arg from the current lexpr ; ; the syntax for Franz lisp is (arg i) ; for interlisp the syntax is (arg x i) where x is not evaluated and is ; the name of the variable bound to the number of args. We can only handle ; the case of x being the variable for the current lexpr we are compiling ; (defun cc-arg nil (prog (nillab finlab) (setq nillab (d-genlab) finlab (d-genlab)) (if (not (eq 'lexpr g-ftype)) then (comp-err " arg only allowed in lexprs")) (if (and (eq (length (cdr v-form)) 2) fl-inter) then (if (not (eq (car g-args) (cadr v-form))) then (comp-err " arg expression is for non local lexpr " v-form) else (setq v-form (cdr v-form)))) (if (and (null g-loc) (null g-cc)) then ;bye bye, wouldn't do anything (return nil)) (if (and (fixp (cadr v-form)) (>& (cadr v-form) 0)) then ; simple case (arg n) for positive n (d-move `(fixnum ,(cadr v-form)) 'reg) #+for-68k (progn (e-sub `(-4 #.olbot-reg) 'd0) (if g-loc then (e-move '(% -8 #.olbot-reg d0) (e-cvt g-loc))) (if g-cc then (e-cmpnil '(% -8 #.olbot-reg d0)))) #+for-vax (progn (e-sub3 '(* -4 #.olbot-reg) '(0 r0) 'r0) (if g-loc then (e-move '(-8 #.olbot-reg r0) (e-cvt g-loc)) elseif g-cc then (e-tst '(-8 #.olbot-reg r0)))) (d-handlecc) elseif (or (null (cadr v-form)) (and (fixp (cadr v-form)) (=& 0 (cadr v-form)))) then ;---the form is: (arg nil) or (arg) or (arg 0). ; We have a private copy of the number of args right ; above the arguments on the name stack, so that ; the user can't clobber it... (0 olbot) points ; to the user setable copy, and (-4 olbot) to our ; copy. (if g-loc then (e-move '(-4 #.olbot-reg) (e-cvt g-loc))) ; Will always return a non nil value, so ; don't even test it. (if (car g-cc) then (e-goto (car g-cc))) else ; general (arg