InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/bsd_srcs/usr.bin/lisp/liszt/func.l

Text File | 1987-12-15 | 16.5 KB | 587 lines

(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file func
   "$Header: func.l,v 1.14 87/12/15 17:02:38 sklower Exp $")

;;; ----    f u n c                function compilation
;;;
;;;            -[Wed Aug 24 10:51:11 1983 by layer]-

; cm-ncons :: macro out an ncons expression
;
(defun cm-ncons nil
  `(cons ,(cadr v-form) nil))

; cc-not :: compile a "not" or "null" expression
;
(defun cc-not nil
  (makecomment '(beginning not))
  (if (null g-loc)
      then (let ((g-cc (cons (cdr g-cc) (car g-cc)))
         (g-ret nil))
        (d-exp (cadr v-form)))
      else (let ((finlab (d-genlab))
         (finlab2 (d-genlab))
         (g-ret nil))
        ; eval arg and jump to finlab if nil
        (let ((g-cc (cons finlab nil))
              g-loc)
             (d-exp (cadr v-form)))
        ; didn't jump, answer must be t
        (d-move 'T g-loc)
        (if (car g-cc)
            then (e-goto (car g-cc))
            else (e-goto finlab2))
        (e-label finlab)
        ; answer is nil
        (d-move 'Nil g-loc)
        (if (cdr g-cc) then (e-goto (cdr g-cc)))
        (e-label finlab2))))

;--- cc-numberp :: check for numberness
;
(defun cc-numberp nil
  (d-typecmplx (cadr v-form)
           '#.(immed-const (plus 1_2 1_4 1_9))))

;--- cc-or :: compile an "or" expression
;
(defun cc-or nil
  (let ((finlab (d-genlab))
    (finlab2)
    (exps (if (cdr v-form) thenret else '(nil)))) ; (or) => nil
       (if (null (car g-cc))
       then (d-exp (do ((g-cc (cons finlab nil))
                (g-loc (if g-loc then 'reg))
                (g-ret nil)
                (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 'reg g-loc)
             (e-label finlab2)
            else (e-label finlab))
       else (if (null g-loc) then (setq finlab (car g-cc)))
        (d-exp (do ((g-cc (cons finlab nil))
                (g-loc (if g-loc then 'reg))
                (g-ret nil)
                (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 'reg g-loc)
             (e-goto (car g-cc))    ; result is t
             (e-label finlab2)))
       (d-clearreg)))  ;we are not sure of the state due to possible branches.

;--- c-prog :: compile a "prog" expression
;
; for interlisp compatibility, we allow the formal variable list to
; contain objects of this form (vrbl init) which gives the initial value
; for that variable (instead of nil)
;
(defun c-prog nil
   (let ((g-decls g-decls))
      (let (g-loc g-cc seeninit initf
        (p-rettrue g-ret) (g-ret nil)
        ((spcs locs initsv . initsn) (d-classify (cadr v-form))))

     (e-pushnil (length locs))    ; locals initially nil
     (d-bindprg spcs locs)        ; bind locs and specs

     (cond (initsv (d-pushargs initsv)
               (mapc '(lambda (x)
                 (d-move 'unstack (d-loc x))
                 (decr g-loccnt)
                 (unpush g-locs))
                 (nreverse initsn))))

     ; determine all possible labels
     (do ((ll (cddr v-form) (cdr ll))
          (labs nil))
         ((null ll) (setq g-labs `((,(d-genlab) ,@labs)
                       ,@g-labs)))
         (if (and (car ll) (symbolp (car ll)))
        then (if (assq (car ll) labs)
            then (comp-err "label is mulitiply defined " (car ll))
            else (setq labs (cons (cons (car ll) (d-genlab))
                          labs)))))

     ; compile each form which is not a label
     (d-clearreg)        ; unknown state after binding
     (do ((ll (cddr v-form) (cdr ll)))
         ((null ll))
         (if (or (null (car ll)) (not (symbolp (car ll))))
        then (d-exp (car ll))
        else (e-label (cdr (assq (car ll) (cdar g-labs))))
             (d-clearreg))))        ; dont know state after label

      ; result is nil if fall out and care about value
      (if (or g-cc g-loc) then (d-move 'Nil 'reg))

      (e-label (caar g-labs))        ; return to label
      (setq g-labs (cdr g-labs))
      (d-unbind)))            ; unbind our frame

;--- d-bindprg :: do binding for a prog expression
;    - spcs : list of special variables
;    - locs : list of local variables
;    - specinit : init values for specs (or nil if all are nil)
;
(defun d-bindprg (spcs locs)
   ; place the local vrbls and prog frame entry on the stack
   (setq g-loccnt (+ g-loccnt (length locs))
     g-locs (nconc locs `((prog . ,(length spcs)) ,@g-locs)))

   ; now bind the specials, if any, to nil
   (if spcs then (e-setupbind)
       (mapc '(lambda (vrb)
          (e-shallowbind vrb 'Nil))
         spcs)
       (e-unsetupbind)))

;--- d-unbind :: remove one frame from g-locs
;
(defun d-unbind nil
   (do ((count 0 (1+ count)))
       ((dtpr (car g-locs))
    (if (not (zerop (cdar g-locs)))
        then (e-unshallowbind (cdar g-locs)))
    (cond ((not (zerop count))
           (e-dropnp count)

           (setq g-loccnt (- g-loccnt count))))
    (setq g-locs (cdr g-locs)))
       (setq g-locs (cdr g-locs))))

;--- d-classify :: seperate variable list into special and non-special
;    - lst : list of variables
; returns ( xxx yyy zzz . aaa)
;        where xxx is the list of special variables and
;        yyy is the list of local variables
;        zzz are the non nil initial values for prog variables
;        aaa are the names corresponding to the values in zzz
;
(defun d-classify (lst)
   (do ((ll lst (cdr ll))
    (locs) (spcs) (init) (initsv) (initsn)
    (name))
       ((null ll) (cons spcs (cons locs (cons initsv initsn))))
       (if (atom (car ll))
       then (setq name (car ll))
       else (setq name (caar ll))
        (push name initsn)
        (push (cadar ll) initsv))
       (if (d-specialp name)
       then (push name spcs)
       else (push name locs))))

; cm-progn :: compile a "progn" expression
;
(defun cm-progn nil
  `((lambda nil ,@(cdr v-form))))

; cm-prog1 :: compile a "prog1" expression
;
(defun cm-prog1 nil
  (let ((gl (d-genlab)))
       `((lambda (,gl)
         ,@(cddr v-form)
         ,gl)
     ,(cadr v-form))))

; cm-prog2 :: compile a "prog2" expression
;
(defun cm-prog2 nil
   (let ((gl (d-genlab)))
       `((lambda (,gl)
         ,(cadr v-form)
         (setq ,gl ,(caddr v-form))
         ,@(cdddr v-form)
         ,gl)
     nil)))

;--- cm-progv :: compile a progv form
;  a progv form looks like (progv 'l-vars 'l-inits 'g-exp1 ... 'g-expn)
; l-vars should be a list of variables, l-inits a list of initial forms
; We cannot permit returns and go-s through this form.
;
; we stack a (progv . 0) form on g-locs so that return and go will know
; not to try to go through this form.
;
(defun c-progv nil
   (let ((gl (d-genlab))
     (g-labs (cons nil g-labs))
     (g-locs (cons '(progv . 0) g-locs)))
       (d-exp `((lambda (,gl)
            (prog1 (progn ,@(cdddr v-form))
               (internal-unbind-vars ,gl)))
        (internal-bind-vars ,(cadr v-form) ,(caddr v-form))))))

(defun c-internal-bind-vars nil
   (let ((g-locs g-locs)
     (g-loccnt g-loccnt))
       (d-pushargs (cdr v-form))
       (d-calldirect '_Ibindvars (length (cdr v-form)))))

(defun c-internal-unbind-vars nil
   (let ((g-locs g-locs)
     (g-loccnt g-loccnt))
       (d-pushargs (cdr v-form))
       (d-calldirect '_Iunbindvars (length (cdr v-form)))))

;--- cc-quote : compile a "quote" expression
;
; if we are just looking to set the ; cc, we just make sure
; we set the cc depending on whether the expression quoted is
; nil or not.
(defun cc-quote nil
   (let ((arg (cadr v-form))
     argloc)
       (if (null g-loc)
       then (if (and (null arg) (cdr g-cc))
            then (e-goto (cdr g-cc))
         elseif (and arg (car g-cc))
            then (e-goto (car g-cc))
         elseif (null g-cc)
            then (comp-warn "losing the value of this expression "
                    (or v-form)))
       else (d-move (d-loclit arg nil) g-loc)
        (d-handlecc))))

;--- c-setarg :: set a lexpr's arg
; form is (setarg index value)
;
(defun c-setarg nil
   (if (not (eq 'lexpr g-ftype))
       then (comp-err "setarg only allowed in lexprs"))
   (if (and fl-inter (eq (length (cdr v-form)) 3))    ; interlisp setarg
       then (if (not (eq (cadr v-form) (car g-args)))
        then (comp-err "setarg: can only compile local setargs "
                   v-form)
        else (setq v-form (cdr v-form))))
   ; compile index into fixnum-reg, was (d-pushargs (list (cadr v-form)))
   (let ((g-cc) (g-ret)
     (g-loc '#.fixnum-reg))
       (d-exp (cadr v-form)))
   (let ((g-loc 'reg)
     (g-cc nil)
     (g-ret nil))
       (d-exp (caddr v-form)))
   #+(or for-vax for-tahoe)
   (progn
       (e-sub3 `(* -4 #.olbot-reg) '(0 #.fixnum-reg) '#.fixnum-reg)
       (e-move 'r0 '(-8 #.olbot-reg #.fixnum-reg)))
   #+for-68k
   (progn
       (e-sub `(-4 #.olbot-reg) '#.fixnum-reg)
       (e-write3 'lea '(% -8 #.olbot-reg #.fixnum-reg) 'a5)
       (e-move 'd0 '(0 a5))))

;--- cc-stringp :: check for string ness
;
(defun cc-stringp nil
  (d-typesimp (cadr v-form) #.(immed-const 0)))

;--- cc-symbolp :: check for symbolness
;
(defun cc-symbolp nil
  (d-typesimp (cadr v-form) #.(immed-const 1)))

;--- c-return :: compile a "return" statement
;
(defun c-return nil
   ; value is always put in reg
   (let ((g-loc 'reg)
     g-cc
     g-ret)
       (d-exp (cadr v-form)))

   ; if we are doing a non local return, compute number of specials to unbind
   ; and locals to pop
   (if (car g-labs)
       then (e-goto (caar g-labs))
       else (do ((loccnt 0)        ;; locals
         (speccnt 0)        ;; special
         (catcherrset 0)        ;; catch/errset frames
         (ll g-labs (cdr ll))
         (locs g-locs))
        ((null ll) (comp-err "return used not within a prog or do"))
        (if (car ll)
            then  (comp-note g-fname ": non local return used ")
             ; unbind down to but not including
             ; this frame.
             (if (greaterp loccnt 0)
                 then (e-pop loccnt))
             (if (greaterp speccnt 0)
                 then (e-unshallowbind speccnt))
             (if (greaterp catcherrset 0)
                 then (comp-note
                      g-fname
                      ": return through a catch or errset"
                      v-form)
                  (do ((i 0 (1+ i)))
                      ((=& catcherrset i))
                      (d-popframe)))
             (e-goto (caar ll))
             (return)
            else ; determine number of locals and special on
             ; stack for this frame, add to running
             ; totals
             (do ()
                 ((dtpr (car locs))
                  (if (eq 'catcherrset (caar locs)) ; catchframe
                  then (incr catcherrset)
                   elseif (eq 'progv (caar locs))
                  then (comp-err "Attempt to 'return' through a progv"))
                  (setq speccnt (+ speccnt (cdar locs))
                    locs (cdr locs)))
                 (incr loccnt)
                 (setq locs (cdr locs)))))))

; c-rplaca :: compile a "rplaca" expression
;
#+(or for-vax for-tahoe)
(defun c-rplaca nil
  (let ((ssimp (d-simple (caddr v-form)))
    (g-ret nil))
       (let ((g-loc (if ssimp then 'reg else 'stack))
         (g-cc nil))
        (d-exp (cadr v-form)))
       (if (null ssimp)
       then (push nil g-locs)
        (incr g-loccnt)
        (let ((g-loc 'r1)
              (g-cc nil))
            (d-exp (caddr v-form)))
        (d-move 'unstack 'reg)
        (unpush g-locs)
        (decr g-loccnt)
        (e-move 'r1 '(4 r0))
       else (e-move (e-cvt ssimp)  '(4 r0)))
       (d-clearreg)))        ; cant tell what we are clobbering

#+for-68k
(defun c-rplaca nil
   (let ((ssimp (d-simple (caddr v-form)))
     (g-ret nil))
       (makecomment `(c-rplaca starting :: v-form = ,v-form))
       (let ((g-loc (if ssimp then 'areg else 'stack))
         (g-cc nil))
       (d-exp (cadr v-form)))
       (if (null ssimp)
       then (push nil g-locs)
        (incr g-loccnt)
        (let ((g-loc 'd1)
              (g-cc nil))
            (d-exp (caddr v-form)))
        (d-move 'unstack 'areg)
        (unpush g-locs)
        (decr g-loccnt)
        (e-move 'd1 '(4 a0))
       else (e-move (e-cvt ssimp)  '(4 a0)))
       (e-move 'a0 'd0)
       (d-clearreg)
       (makecomment `(c-rplaca done))))

; c-rplacd :: compile a "rplacd" expression
;
#+(or for-vax for-tahoe)
(defun c-rplacd nil
  (let ((ssimp (d-simple (caddr v-form)))
    (g-ret nil))
       (let ((g-loc (if ssimp then 'reg else 'stack))
         (g-cc nil))
        (d-exp (cadr v-form)))
       (if (null ssimp)
       then (push nil g-locs)
        (incr g-loccnt)
        (let ((g-loc 'r1)
              (g-cc nil))
            (d-exp (caddr v-form)))
        (d-move 'unstack 'reg)
        (unpush g-locs)
        (decr g-loccnt)
        (e-move 'r1 '(0 r0))
       else (e-move (e-cvt ssimp)  '(0 r0)))
       (d-clearreg)))

#+for-68k
(defun c-rplacd nil
   (let ((ssimp (d-simple (caddr v-form)))
     (g-ret nil))
       (makecomment `(c-rplacd starting :: v-form = ,v-form))
       (let ((g-loc (if ssimp then 'areg else 'stack))
         (g-cc nil))
       (d-exp (cadr v-form)))
       (if (null ssimp)
       then (push nil g-locs)
        (incr g-loccnt)
        (let ((g-loc 'd1)
              (g-cc nil))
            (d-exp (caddr v-form)))
        (d-move 'unstack 'areg)
        (unpush g-locs)
        (decr g-loccnt)
        (e-move 'd1 '(0 a0))
       else (e-move (e-cvt ssimp) '(0 a0)))
       (e-move 'a0 'd0)
       (d-clearreg)
       (makecomment `(d-rplacd done))))

;--- cc-setq :: compile a "setq" expression
;
(defun cc-setq nil
  (prog nil
  (let (tmp tmp2)
       (if (null (cdr v-form))
        then (d-exp nil)  ; (setq)
         (return)
        elseif (oddp (length (cdr v-form)))
       then (comp-err "wrong number of args to setq "
              (or v-form))
    elseif (cdddr v-form)        ; if multiple setq's
       then (do ((ll (cdr v-form) (cddr ll))
             (g-loc)
             (g-cc nil))
            ((null (cddr ll)) (setq tmp ll))
            (setq g-loc (d-locv (car ll)))
            (d-exp (cadr ll))
            (d-clearuse (car ll)))
    else (setq tmp (cdr v-form)))

       ; do final setq
       (let ((g-loc (d-locv (car tmp)))
         (g-cc (if g-loc then nil else g-cc))
         (g-ret nil))
        (d-exp (cadr tmp))
        (d-clearuse (car tmp)))
       (if g-loc
       then (d-move (setq tmp2 (d-locv (car tmp))) g-loc)
        (if g-cc
            then #+for-68k (d-cmpnil tmp2)
             (d-handlecc))))))

; cc-typep :: compile a "typep" expression
;
; this returns the type of the expression, it is always non nil
;
#+(or for-vax for-tahoe)
(defun cc-typep nil
  (let ((argloc (d-simple (cadr v-form)))
    (g-ret))
       (if (null argloc)
       then (let ((g-loc 'reg) g-cc)
            (d-exp (cadr v-form)))
        (setq argloc 'reg))
       (if g-loc
       then #+for-vax (e-write4 'ashl '($ -9) (e-cvt argloc) 'r0)
            #+for-tahoe (e-write4 'shar '($ 9) (e-cvt argloc) 'r0)
        (e-write3 'cvtbl "_typetable+1[r0]" 'r0)
        (e-move "_tynames+4[r0]" 'r0)
        (e-move '(0 r0) (e-cvt g-loc)))
       (if (car g-cc) then (e-goto (car g-cc)))))

#+for-68k
(defun cc-typep nil
  (let ((argloc (d-simple (cadr v-form)))
    (g-ret))
       (if (null argloc)
       then (let ((g-loc 'reg) g-cc)
            (d-exp (cadr v-form)))
        (setq argloc 'reg))
       (if g-loc
       then (e-move (e-cvt argloc) 'd0)
        (e-sub '#.nil-reg 'd0)
        (e-write3 'moveq '($ 9) 'd1)
        (e-write3 'asrl 'd1 'd0)
        (e-write3 'lea '"_typetable+1" 'a5)
        (e-add 'd0 'a5)
        (e-write3 'movb '(0 a5) 'd0)
        (e-write2 'extw 'd0)
        (e-write2 'extl 'd0)
        (e-write3 'asll '($ 2) 'd0)
        (e-write3 'lea "_tynames+4" 'a5)
        (e-add 'd0 'a5)
        (e-move '(0 a5) 'a5)
        (e-move '(0 a5) (e-cvt g-loc)))
       (if (car g-cc) then (e-goto (car g-cc)))))

; cm-symeval :: compile a symeval expression.
; the symbol cell in franz lisp is just the cdr.
;
(defun cm-symeval nil
  `(cdr ,(cadr v-form)))

; c-*throw :: compile a "*throw" expression
;
; the form of *throw is (*throw 'tag 'val) .
; we calculate and stack the value of tag, then calculate val
; we call Idothrow to do the actual work, and only return if the
; throw failed.
;
(defun c-*throw nil
  (let ((arg2loc (d-simple (caddr v-form)))
    g-cc
    g-ret
    arg1loc)
       ; put on the C runtime stack value to throw, and
       ; tag to throw to.
       (if arg2loc
       then (if (setq arg1loc (d-simple (cadr v-form)))
            then (C-push (e-cvt arg2loc))
             (C-push (e-cvt arg1loc))
            else (let ((g-loc 'reg))
                 (d-exp (cadr v-form))    ; calc tag
                 (C-push (e-cvt arg2loc))
                 (C-push (e-cvt 'reg))))
       else (let ((g-loc 'stack))
            (d-exp (cadr v-form))    ; calc tag to stack
            (push nil g-locs)
            (incr g-loccnt)
            (setq g-loc 'reg)
            (d-exp (caddr v-form))    ; calc value into reg
            (C-push (e-cvt 'reg))
            (C-push (e-cvt 'unstack))
            (unpush g-locs)
            (decr g-loccnt)))
       ; now push the type of non local go we are doing, in this case
       ; it is a C_THROW
       (C-push '($ #.C_THROW))
       #+for-vax
       (e-write3 'calls '$3 '_Inonlocalgo)
       #+for-tahoe
       (e-write3 'callf '$16 '_Inonlocalgo)
       #+for-68k
       (e-quick-call '_Inonlocalgo)))

;--- cm-zerop ::  convert zerop to a quick test
; zerop is only allowed on fixnum and flonum arguments.  In both cases,
; if the value of the first 32 bits is zero, then we have a zero.
; thus we can define it as a macro:
#+(or for-vax for-tahoe)
(defun cm-zerop nil
  (cond ((atom (cadr v-form))
     `(and (null (cdr ,(cadr v-form))) (not (bigp ,(cadr v-form)))))
    (t (let ((gnsy (gensym)))
        `((lambda (,gnsy)
              (and (null (cdr ,gnsy))
                (not (bigp ,gnsy))))
          ,(cadr v-form))))))

#+for-68k
(defun cm-zerop nil
   (cond ((atom (cadr v-form))
      `(and (=& 0 ,(cadr v-form))    ;was (cdr ,(cadr v-form))
        (not (bigp ,(cadr v-form)))))
     (t (let ((gnsy (gensym)))
        `((lambda (,gnsy)
              (and (=& 0 ,gnsy)        ;was (cdr ,gnsy)
               (not (bigp ,gnsy))))
          ,(cadr v-form))))))