Function: PARSE-DECLARATION

Source

(defun parse-declaration (declaration environment parent)
  (let ((declares nil))
    (flet ((funname (form)
	     (if (and (consp form) (eql (car form) 'function))
		 (cadr form)
		 nil)))
      (macrolet ((mkdecl (varname formclass &rest rest)
		   `(make-instance ,formclass :parent parent :source (list type ,varname) ,@rest))		 
		 (extend-env ((var list) newdeclare &rest datum)
		   `(dolist (,var ,list)
		      (when ,newdeclare (push ,newdeclare declares))
                      (extend environment :declare ,@datum))))
	(destructuring-bind (type &rest arguments)
	    declaration
	  (case type
	    (dynamic-extent
	     (extend-env (var arguments)
			 (mkdecl var 'variable-ignorable-declaration-form) 
			 var `(dynamic-extent)))        
	    (ftype
	     (extend-env (function-name (cdr arguments))
			 (make-instance 'ftype-declaration-form 
					:parent parent
					:source `(ftype ,(first arguments) function-name)
					:name function-name
					:type-form (first arguments))
			 function-name `(ftype ,(first arguments))))
	    ((ignore ignorable)
	     (extend-env (var arguments)
			 (aif (funname var)
			      (mkdecl var 'function-ignorable-declaration-form :name it)
			      (mkdecl var 'variable-ignorable-declaration-form :name var))
			 var `(ignorable)))
	    (inline
	      (extend-env (function arguments) 
			  (mkdecl function 'function-ignorable-declaration-form :name function)
			  function `(ignorable)))
	    (notinline
	     (extend-env (function arguments)
			 (mkdecl function 'notinline-declaration-form :name function)
			 function `(notinline)))
	    (optimize
	     (extend-env (optimize-spec arguments) 
			 (mkdecl optimize-spec 'optimize-declaration-form :optimize-spec optimize-spec)
			 'optimize optimize-spec))
	    (special
	     (extend-env (var arguments) 
			 (mkdecl var 'special-declaration-form :name var)
			 var `(special)))
	    (type
	     (extend-env (var (rest arguments))
			 (make-instance 'type-declaration-form 
					:parent parent
					:source `(type ,(first arguments) ,var)
					:name var
					:type-form (first arguments))
			 var `(type ,(first arguments))))
	    (t
	     (extend-env (var arguments)
			 (make-instance 'type-declaration-form 
					:parent parent
					:source `(,type ,var)
					:name var
					:type-form type)
			 var `(type ,type)))))))
    (when (null declares)
      (setq declares (list (make-instance 'declaration-form :parent parent :source declaration))))
    (values environment declares)))