BSD 4_4 development

[unix-history] / usr / src / old / lisp / liszt / decl.l

(include-if (null (get 'chead 'version)) "../chead.l")
(Liszt-file decl
   "$Header: decl.l,v 1.9 87/12/15 17:00:21 sklower Exp $")

;;; ----	d e c l		declaration handling
;;;
;;;				-[Sat Aug  6 23:58:35 1983 by layer]-


(setq original-readtable readtable)
(setq raw-readtable (makereadtable t))

;--- compile-fcn  :: declare a open coded function
; name - name of the function
; fcnname - function to be funcall'ed to handle the open coding
; indicator -  describes what the fcnname will do, one of
;		fl-expr : will compile the expression and leave the
;			result in r0.  Will ignore g-cc and g-loc
;		fl-exprcc: will compile the expression and leave the
;			result in g-loc.  Will handle g-cc
;		fl-exprm: will just return another form to be d-exp'ed
; args - (optional) description of the arguments to this function.
;	form: (min-args . max-args) .  If max-args is nil, then there is
;		no max.  This is usually done in /usr/lib/lisp/fcninfo.l.
;
(defmacro compile-fcn (name fcnname indicator &optional (args nil args-p))
   `(progn (putprop ',name ',fcnname ',indicator)
	   ;; don't do this here, done in fcn-info
	   ,@(cond (args-p `((putprop ',name (list ',args) 'fcn-info))))))

	   
;--- special handlers
(compile-fcn and	cc-and		fl-exprcc)
(compile-fcn arg  	cc-arg		fl-exprcc)
(compile-fcn assq 	cm-assq		fl-exprm)
(compile-fcn atom 	cc-atom		fl-exprcc)
(compile-fcn bigp	cc-bigp		fl-exprcc)
(compile-fcn bcdcall	c-bcdcall	fl-expr)
(compile-fcn Internal-bcdcall c-Internal-bcdcall fl-expr)
(compile-fcn bcdp	cc-bcdp		fl-exprcc)
#+(or for-vax for-tahoe)
(compile-fcn boole 	c-boole		fl-expr)
(compile-fcn *catch	c-*catch 	fl-expr)
(compile-fcn comment	cc-ignore	fl-exprcc)
(compile-fcn cond	c-cond  	fl-expr)
(compile-fcn cons	c-cons		fl-expr)
(compile-fcn cxr 	cc-cxr		fl-exprcc)
(compile-fcn declare	c-declare	fl-expr)
(compile-fcn do		c-do     	fl-expr)
(compile-fcn liszt-internal-do 	c-do   	fl-expr)
(compile-fcn dtpr	cc-dtpr		fl-exprcc)
(compile-fcn eq		cc-eq    	fl-exprcc)
(compile-fcn equal 	cc-equal	fl-exprcc)
(compile-fcn errset 	c-errset 	fl-expr)
(compile-fcn fixp	cc-fixp		fl-exprcc)
(compile-fcn floatp	cc-floatp	fl-exprcc)
(compile-fcn funcall	c-funcall 	fl-expr)
(compile-fcn function	cc-function 	fl-exprcc)
(compile-fcn get	c-get		fl-expr)
(compile-fcn getaccess  cm-getaccess    fl-exprm)
(compile-fcn getaux	cm-getaux 	fl-exprm)
(compile-fcn getd 	cm-getd 	fl-exprm)
(compile-fcn getdata	cm-getdata 	fl-exprm)
(compile-fcn getdisc	cm-getdisc 	fl-exprm)
(compile-fcn go		c-go	  	fl-expr)
(compile-fcn list	c-list	  	fl-expr)
(compile-fcn map	cm-map	  	fl-exprm)
(compile-fcn mapc	cm-mapc  	fl-exprm)
(compile-fcn mapcan 	cm-mapcan 	fl-exprm)
(compile-fcn mapcar 	cm-mapcar 	fl-exprm)
(compile-fcn mapcon	cm-mapcon 	fl-exprm)
(compile-fcn maplist	cm-maplist 	fl-exprm)
(compile-fcn memq	cc-memq		fl-exprcc)
(compile-fcn ncons	cm-ncons	fl-exprm)
(compile-fcn not	cc-not   	fl-exprcc)
(compile-fcn null	cc-not   	fl-exprcc)
(compile-fcn numberp	cc-numberp	fl-exprcc)
(compile-fcn or		cc-or    	fl-exprcc)
(compile-fcn prog	c-prog   	fl-expr)
(compile-fcn progn	cm-progn 	fl-exprm)
(compile-fcn prog1 	cm-prog1	fl-exprm)
(compile-fcn prog2	cm-prog2 	fl-exprm)
(compile-fcn progv 	c-progv		fl-expr)
(compile-fcn quote	cc-quote 	fl-exprcc)
(compile-fcn return 	c-return 	fl-expr)
(compile-fcn rplaca 	c-rplaca 	fl-expr)
(compile-fcn rplacd 	c-rplacd 	fl-expr)
(compile-fcn rplacx 	c-rplacx 	fl-expr)
(compile-fcn *rplacx 	c-rplacx 	fl-expr)
(compile-fcn setarg 	c-setarg	fl-expr)
(compile-fcn setq	cc-setq  	fl-exprcc)
(compile-fcn stringp 	cc-stringp 	fl-exprcc)
(compile-fcn symbolp 	cc-symbolp	fl-exprcc)
(compile-fcn symeval 	cm-symeval	fl-exprm)
(compile-fcn *throw 	c-*throw 	fl-expr)
(compile-fcn typep   	cc-typep	fl-exprcc)
(compile-fcn vectorp   	cc-vectorp	fl-exprcc)
(compile-fcn vectorip  	cc-vectorip	fl-exprcc)
(compile-fcn vset	cc-vset 	fl-exprcc)
(compile-fcn vseti-byte cc-vseti-byte 	fl-exprcc)
(compile-fcn vseti-word cc-vseti-word 	fl-exprcc)
(compile-fcn vseti-long cc-vseti-long 	fl-exprcc)
(compile-fcn vref	cc-vref 	fl-exprcc)
(compile-fcn vrefi-byte cc-vrefi-byte 	fl-exprcc)
(compile-fcn vrefi-word cc-vrefi-word 	fl-exprcc)
(compile-fcn vrefi-long cc-vrefi-long 	fl-exprcc)
(compile-fcn vsize	c-vsize		fl-expr)
(compile-fcn vsize-byte	c-vsize-byte	fl-expr)
(compile-fcn vsize-word	c-vsize-word	fl-expr)

(compile-fcn zerop   	cm-zerop	fl-exprm)
; functions which expect fixnum operands 


(compile-fcn + c-fixnumop  fl-expr)
#+(or for-vax for-tahoe) (putprop '+ 'addl3 'fixop)
#+for-68k (putprop '+ 'addl 'fixop)

(compile-fcn - c-fixnumop fl-expr)
#+(or for-vax for-tahoe) (putprop '- 'subl3 'fixop)
#+for-68k (putprop '- 'subl 'fixop)

#+(or for-vax for-tahoe)
(progn 'compile
   (compile-fcn * c-fixnumop fl-expr)
   (putprop '* 'mull3 'fixop)

   (compile-fcn / c-fixnumop fl-expr)
   (putprop '/ 'divl3 'fixop))

;-- boole's derivatives
#+for-vax
(progn 'compile
   (compile-fcn fixnum-BitOr c-fixnumop fl-expr)
   (putprop 'fixnum-BitOr 'bisl3 'fixop)

   (compile-fcn fixnum-BitAndNot c-fixnumop fl-expr)
   (putprop 'fixnum-BitAndNot 'bicl3 'fixop)

   (compile-fcn fixnum-BitXor c-fixnumop fl-expr)
   (putprop 'fixnum-BitXor 'xorl3 'fixop))

#+for-tahoe
(progn 'compile
   (compile-fcn fixnum-BitOr c-fixnumop fl-expr)
   (putprop 'fixnum-BitOr 'orl3 'fixop)

   (compile-fcn fixnum-BitAnd c-fixnumop fl-expr)
   (putprop 'fixnum-BitAnd 'andl3 'fixop)

   (compile-fcn fixnum-BitXor c-fixnumop fl-expr)
   (putprop 'fixnum-BitXor 'xorl3 'fixop))

(compile-fcn 1+ 	cc-oneplus  fl-exprcc)
(compile-fcn 1-		cc-oneminus fl-exprcc)

#+(or for-vax for-tahoe)
(compile-fcn \\	c-\\	fl-expr)   ; done in the old way, should be modified

; these have typically fixnum operands, but not always 


; these without the & can be both fixnum or both flonum
;
(compile-fcn 	< 	cm-< 	fl-exprm)
(compile-fcn 	<& 	cc-<& 	fl-exprcc)

(compile-fcn 	> 	cm-> 	fl-exprm)
(compile-fcn 	>& 	cc->& 	fl-exprcc)

(compile-fcn 	= 	cm-=		fl-exprm)
(compile-fcn 	=&	cm-=&		fl-exprm)

; functions which can only be compiled
(compile-fcn assembler-code c-assembler-code fl-expr)
(compile-fcn fixnum-cxr cm-fixnum-cxr fl-exprm)
(compile-fcn internal-fixnum-box c-internal-fixnum-box fl-expr)
(compile-fcn offset-cxr cc-offset-cxr fl-exprcc)
(compile-fcn internal-bind-vars c-internal-bind-vars fl-expr)
(compile-fcn internal-unbind-vars c-internal-unbind-vars fl-expr)

; functions which can be converted to fixnum functions if
; proper declarations are done
(mapc
   '(lambda (arg) (putprop (car arg) (cdr arg) 'if-fixnum-args))
   '((lessp . <&) (greaterp . >&) (= . =&) (equal . =&)))
     

;--- doevalwhen, process evalwhen directive. This is inadequate.
;
(def doevalwhen 
      (lambda (v-f)
	      (prog (docom dolod)
		    (setq docom (memq 'compile (cadr v-f))
			  
			  dolod (memq 'load (cadr v-f)))
		    (mapc '(lambda (frm) (cond (docom (eval frm)))
					 (cond (dolod 
						((lambda (internal-macros) 
							 (liszt-form frm))
						 t))))
			  (cddr v-f)))))

\f
;---- declare - the compiler version of the declare function
;	process the declare forms given. We evaluate each arg
;
(defun liszt-declare fexpr (forms)
   (cond ((status feature complr)
	  (do ((i forms (cdr i)))
	      ((null i))
	      (cond ((and (atom (caar i))
			  (getd (caar i)))
		     (eval (car i))) ; if this is a function
		    (t (comp-warn "Unknown declare attribute: " (car i))))))))

;---> handlers for declare forms
; declaration information for declarations which occur outside of
; functions is stored on the property list for rapid access.
; The indicator to look under is the value of one of the symbols:
;	g-functype, g-vartype, g-bindtype, or g-calltype
;  The value of the property is the declared function, declaration, binding
;	or call type for that variable.
; For local declarations, the information is kept on the g-decls stack.
; It is an assq list, the car of which is the name of the variable or
; function name, the cdr of which is the particular type.  To tell
; whether the particular type is a function type declaration, check the
; property list of the particular type for a 'functype' indicator.
; Likewise, to see if a particular type is a variable declaration, look
; for a 'vartype' indicator on the particular type's property list.
;
(defmacro declare-handler (args name type toplevind)
   `(mapc '(lambda (var)
	      (cond ((symbolp var)
		     (cond (g-compfcn	; if compiling a function
			      (Push g-decls (cons var ',name)))
			   (t          ; if at top level
			      (putprop var ',name ,toplevind))))))
	  ,args))

   
(defun *fexpr fexpr (args)
   (declare-handler args nlambda functype g-functype))

(defun nlambda fexpr (args)
   (declare-handler args nlambda functype g-functype))

(defun *expr fexpr (args)
   (declare-handler args lambda functype g-functype))

(defun lambda fexpr (args)
   (declare-handler args lambda functype g-functype))

(defun *lexpr fexpr (args)
   (declare-handler args lexpr functype g-functype))

(defun special fexpr (args)
   (declare-handler args special bindtype g-bindtype))

(defun unspecial fexpr (args)
   (declare-handler args unspecial bindtype g-bindtype))

(defun fixnum fexpr (args)
   (declare-handler args fixnum vartype g-vartype))

(defun flonum fexpr (args)
   (declare-handler args flonum vartype g-vartype))

(defun notype fexpr (args)
   (declare-handler args notype vartype g-vartype))



;--- special case, this is only allowed at top level.  It will
; be removed when vectors are fully supported
(def macarray 
  (nlambda (v-l)
	   (mapc '(lambda (x)
			  (if (dtpr x)
			      then (putprop (car x) (cdr x) g-arrayspecs)
				   (putprop (car x) 'array  g-functype)
			      else (comp-err "Bad macerror form" x)))
		 v-l)))


(def macros 
  (nlambda (args) (setq macros (car args))))

(def specials
  (nlambda (args) (setq special (car args))))

;--- *args
; form is (declare (*args minargs maxargs))
; this must occur within a function definition or it is an error
;
(def *args
   (nlambda (args)
	    (if (not g-compfcn)
	       then (comp-err
		       " *args declaration not given within a function definition "
		       args))
	    (let (min max)
	       (if (not (= (length args) 2))
		  then (comp-err " *args declaration must have two args: "
				 args))
	       (setq min (car args) max (cadr args))
	       (if (not (and (or (null min) (fixp min))
			     (or (null max) (fixp max))))
		  then (comp-err " *args declaration has illegal values: "
				 args))
	       (setq g-arginfo (cons min max))
	       (putprop g-fname (list g-arginfo) 'fcn-info))))

;--- *arginfo
; designed to be used at top level, but can be used within  function
; form: (declare (*arginfo (append 2 nil) (showstack 0 1)))
;
(def *arginfo
   (nlambda (args)
      (do ((xx args (cdr xx))
	   (name)
	   (min)
	   (max))
	  ((null xx))
	  (if (and (dtpr (car xx))
		   (eq (length (car xx)) 3))
	     then (setq name (caar xx)
			min  (cadar xx)
			max  (caddar xx))
		  (if (not (and (symbolp name)
				(or (null min) (fixp min))
				(or (null max) (fixp max))))
		     then (comp-err " *arginfo, illegal declaration "
				    (car xx))
		     else (putprop name (list (cons min max)) 'fcn-info))))))
						    
   
;--- another top level only.
;
(def localf
  (nlambda (args)
     (mapc '(lambda (ar)
	       (if (null (get ar g-localf))
		  then (putprop ar
				(cons (d-genlab) -1)
				g-localf))
	       (if (get ar g-stdref)
		  then (comp-err
			 "function " ar " is being declared local" N
		       " yet it has already been called in a non local way")))
	   args)))

; g-decls is a stack of forms like
;  ((foo . special) (bar . fixnum) (pp . nlambda))
; there are 4 types of cdr's:
;	function types (lambda, nlambda, lexpr)
;	variable types (fixnum, flonum, notype)
;	call types     (localf, <unspecified>)
;	bind types     (special, unspecial)
;
(mapc '(lambda (x) (putprop x t 'functype)) '(lambda nlambda lexpr))
(mapc '(lambda (x) (putprop x t 'vartype))  '(fixnum flonum notype))
(mapc '(lambda (x) (putprop x t 'calltype)) '(localf))
(mapc '(lambda (x) (putprop x t 'bindtype)) '(special unspecial))

;---> end declare form handlers






;--- d-makespec :: declare a variable to be special
;
(defun d-makespec (vrb)
  (putprop vrb 'special g-bindtype))