From 780fdea33bb37d9cf4f5f4b9011899875d261532 Mon Sep 17 00:00:00 2001 From: CSRG Date: Tue, 15 Dec 1987 02:00:02 -0800 Subject: [PATCH] BSD 4_4 development Work on file usr/src/old/lisp/liszt/datab.l Synthesized-from: CSRG/cd3/4.4 --- usr/src/old/lisp/liszt/datab.l | 236 +++++++++++++++++++++++++++++++++ 1 file changed, 236 insertions(+) create mode 100644 usr/src/old/lisp/liszt/datab.l diff --git a/usr/src/old/lisp/liszt/datab.l b/usr/src/old/lisp/liszt/datab.l new file mode 100644 index 0000000000..f1b2161f1a --- /dev/null +++ b/usr/src/old/lisp/liszt/datab.l @@ -0,0 +1,236 @@ +(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 +; ::= number +; quoted anything +; local symbol +; t +; nil +; ::= +; (cdr ) +; 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)))) + + + + -- 2.20.1