Return to datab.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt

Initial revision

(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file datab
   "$Header: /var/lib/cvsd/repos/CSRG/42BSD/ucb/lisp/liszt/datab.l,v 1.1 2018/04/24 16:12:54 root 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 #+for-vax
			 (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))))

	      

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.