4.4BSD/usr/src/old/lisp/liszt/datab.l
(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file datab
"$Header: datab.l,v 1.6 87/12/15 16:59:55 sklower Exp $")
;;; ---- d a t a b data base
;;;
;;; -[Sat Aug 6 23:59:11 1983 by layer]-
;--- d-tranloc :: locate a function in the transfer table
;
; return the offset we should use for this function call
;
(defun d-tranloc (fname)
(cond ((get fname g-tranloc))
(t (Push g-tran fname)
(let ((newval (* 8 g-trancnt)))
(putprop fname newval g-tranloc)
(incr g-trancnt)
newval))))
;--- d-loc :: return the location of the variable or value in IADR form
; - form : form whose value we are to locate
;
; if we are given a xxx as form, we check yyy;
; xxx yyy
; -------- ---------
; nil Nil is always returned
; symbol return the location of the symbols value, first looking
; in the registers, then on the stack, then the bind list.
; If g-ingorereg is t then we don't check the registers.
; We would want to do this if we were interested in storing
; something in the symbol's value location.
; number always return the location of the number on the bind
; list (as a (lbind n))
; other always return the location of the other on the bind
; list (as a (lbind n))
;
(defun d-loc (form)
(if (null form) then 'Nil
elseif (numberp form) then
(if (and (fixp form) (greaterp form -1025) (lessp form 1024))
then `(fixnum ,form) ; small fixnum
else (d-loclit form nil))
elseif (symbolp form)
then (if (and (null g-ignorereg) (car (d-bestreg form nil))) thenret
else (if (d-specialp form) then (d-loclit form t)
else (do ((ll g-locs (cdr ll)) ; check stack
(n g-loccnt))
((null ll)
(comp-warn (or form)
" declared special by compiler")
(d-makespec form)
(d-loclit form t))
(if (atom (car ll))
then (if (eq form (car ll))
then (return `(stack ,n))
else (setq n (1- n)))))))
else (d-loclit form nil)))
;--- d-loclit :: locate or add litteral to bind list
; - form : form to check for and add if not present
; - flag : if t then if we are given a symbol, return the location of
; its value, else return the location of the symbol itself
;
; scheme: we share the locations of atom (symbols,numbers,string) but always
; create a fresh copy of anything else.
(defun d-loclit (form flag)
(prog (loc onplist symboltype)
(if (null form)
then (return 'Nil)
elseif (symbolp form)
then (setq symboltype t)
(cond ((setq loc (get form g-bindloc))
(setq onplist t)))
elseif (atom form)
then (do ((ll g-lits (cdr ll)) ; search for atom on list
(n g-litcnt (1- n)))
((null ll))
(if (eq form (car ll))
then (setq loc n) ; found it
(return)))) ; leave do
(if (null loc)
then (Push g-lits form)
(setq g-litcnt (1+ g-litcnt)
loc g-litcnt)
(cond ((and symboltype (null onplist))
(putprop form loc g-bindloc))))
(return (if (and flag symboltype) then `(bind ,loc)
else `(lbind ,loc)))))
;--- d-locv :: find the location of a value cell, and dont return a register
;
(defun d-locv (sm)
(let ((g-ignorereg t))
(d-loc sm)))
;--- d-simple :: see of arg can be addresses in one instruction
; we define simple and really simple as follows
; <rsimple> ::= number
; quoted anything
; local symbol
; t
; nil
; <simple> ::= <rsimple>
; (cdr <rsimple>)
; global symbol
;
(defun d-simple (arg)
(let (tmp)
(if (d-rsimple arg) thenret
elseif (atom arg) then (d-loc arg)
elseif (and (memq (car arg) '(cdr car cddr cdar))
(setq tmp (d-rsimple (cadr arg))))
then (if (eq 'Nil tmp) then tmp
elseif (atom tmp)
then #+(or for-vax for-tahoe)
(if (eq 'car (car arg))
then `(racc 4 ,tmp)
elseif (eq 'cdr (car arg))
then `(racc 0 ,tmp)
elseif (eq 'cddr (car arg))
then `(racc * 0 ,tmp)
elseif (eq 'cdar (car arg))
then `(racc * 4 ,tmp))
#+for-68k
(if (eq 'car (car arg))
then `(racc 4 ,tmp)
elseif (eq 'cdr (car arg))
then `(racc 0 ,tmp))
elseif (not (eq 'cdr (car arg)))
then nil
elseif (eq 'lbind (car tmp))
then `(bind ,(cadr tmp))
elseif (eq 'stack (car tmp))
then `(vstack ,(cadr tmp))
elseif (eq 'fixnum (car tmp))
then `(immed ,(cadr tmp))
elseif (atom (car tmp))
then `(0 ,(cadr tmp))
else (comp-err "bad arg to d-simple: " (or arg))))))
(defun d-rsimple (arg)
(if (atom arg) then
(if (null arg) then 'Nil
elseif (eq t arg) then 'T
elseif (or (numberp arg)
(memq arg g-locs))
then (d-loc arg)
else (car (d-bestreg arg nil)))
elseif (eq 'quote (car arg)) then (d-loclit (cadr arg) nil)))
;--- d-specialp :: check if a variable is special
; a varible is special if it has been declared as such, or if
; the variable special is t
(defun d-specialp (vrb)
(or special
(eq 'special (d-findfirstprop vrb 'bindtype)) ; local special decl
(eq 'special (get vrb g-bindtype))))
(defun d-fixnump (vrb)
(and (symbolp vrb)
(or (eq 'fixnum (d-findfirstprop vrb 'vartype))
(eq 'fixnum (get vrb g-vartype)))))
;--- d-functyp :: return the type of function
; - name : function name
;
; If name had a macro function definition, we return `macro'. Otherwise
; we see if name as a declared type, if so we return that. Otherwise
; we see if name is defined and we return that if so, and finally if
; we have no idea what this function is, we return lambda.
; This is not really satisfactory, but will handle most cases.
;
; If macrochk is nil then we don't check for the macro case. This
; is important to prevent recursive macroexpansion.
;
(defun d-functyp (name macrochk)
(let (func ftyp)
(if (atom name)
then
(setq func (getd name))
(setq ftyp (if (and macrochk (get name 'cmacro)) ;compiler macro
then 'cmacro
elseif (bcdp func)
then (let ((type (getdisc func)))
(if (memq type '(lambda nlambda macro))
then type
elseif (stringp type)
then 'lambda ; foreign function
else (comp-warn
"function "
name
" has a strange discipline "
type)
'lambda ; assume lambda
))
elseif (dtpr func)
then (car func)
elseif (and macrochk (get name 'macro-autoload))
then 'macro))
(if (memq ftyp '(macro cmacro)) then ftyp
elseif (d-findfirstprop name 'functype) thenret
elseif (get name g-functype) thenret ; check if declared first
elseif ftyp thenret
else 'lambda)
else 'lambda))) ; default is lambda
;--- d-allfixnumargs :: check if all forms are fixnums
; make sure all forms are fixnums or symbols whose declared type are fixnums
;
(defun d-allfixnumargs (forms)
(do ((xx forms (cdr xx))
(arg))
((null xx) t)
(cond ((and (fixp (setq arg (car xx))) (not (bigp arg))))
((d-fixnump arg))
(t (return nil)))))
(defun d-findfirstprop (name type)
(do ((xx g-decls (cdr xx))
(rcd))
((null xx))
(if (and (eq name (caar xx))
(get (setq rcd (cdar xx)) type))
then (return rcd))))