Explorer patch for beta PCL

[hastings@sumex.ARPA]

Add the following forms to walk.lisp to have
the new beta version of PCL run on a TI Explorer.

;;;   --- TI Explorer --
;;;An environment is a two element list, whose car we can
;;;ignore and whose cadr is list of the
;;;local-definitions-frames. Each local-definitions-frame
;;;holds either macros or functions, but not both.
;;;Each frame is a plist of <name> <def> <name> <def> ...
;;;where <name> is a locative to the function cell of
;;;the symbol that names the function or macro, and
;;;<def> is either NIL if this is function redefinition
;;;or the macro-expansion function if this is a macro
;;;redefinition.

;;;   Here's an example.  For the form
;;;(defun foo ()
;;;  (macrolet ((bar (a b) (list a b))
;;;	        (bar2 (a b) (list a b)))
;;;    (flet ((some-local-fn (c d) (print (list c d)))
;;;	      (another (c d) (print (list c d))))
;;;      (bar (some-local-fn 1 2) 3))))

;;;the environment arg to macroexpand-1 when called on (bar (some-local-fn 1 2)
3)
;;;is 
;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL
;;;       #<DTP-LOCATIVE 4710671> NIL)
;;;      (#<DTP-LOCATIVE 7346562>
;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B)))
;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
;;;		   (BLOCK BAR ....))
;;;       #<DTP-LOCATIVE 4710664>
;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B)))
;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
;;;		   (BLOCK BAR2 ....))))
#+TI
(progn 

;;; from sys:site;macros.lisp
(eval-when (compile load eval)
  (DEFMACRO MACRO-DEF? (thing)
    `(AND (CONSP ,thing) (EQ (CAR ,thing) 'MACRO)))

;; the following macro generates code to check the 'local' environment for a
macro definition for
;; THE SYMBOL <name>. Such a definition would be set up only by a MACROLET. If a
macro definition 
;; for <name> is found, its expander function is returned.

  (DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
    `(IF ,local-function-environment
	 (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name))))
	   (DOLIST (frame  ,local-function-environment)
	     (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) vcell)))  ;;
<value> is nil or a locative
	       (When value (RETURN (CAR value))))))
	 nil)))

 
;;;Edited by Reed Hastings         13 Jan 88  16:29
(defun environment-macro (env macro)
  ;;some code picked off macroexpand-1
  (let* ((local-definitions (cadr env))
	 (local-def (find-local-definition macro local-definitions)))
    (if (macro-def? local-def)
	local-def)))

;;;Edited by Reed Hastings         13 Jan 88  16:29
(defun environment-function (env fn)
  (let* ((local-definitions (cadr env)))
    (dolist (frame local-definitions)
      (when (not (getf (ticl::locf (symbol-function fn))
		       frame
		       :not-found-marker))
	(return t)))))
	     

;;;Edited by Reed Hastings         13 Jan 88  16:29
(defun with-augmented-environment-internal (env functions macros)
  (let  ((local-definitions (cadr env))
	 (new-local-fns-frame (mapcan #'(lambda (fn)
					  (list (ticl:locf (symbol-function (car fn))) nil))
				      functions))
	 (new-local-macros-frame (mapcan #'(lambda (m)
					     (list (ticl:locf (symbol-function (car m))) (cadr m)))
					 macros)))
    (when new-local-fns-frame 
      (push new-local-fns-frame local-definitions))
    (when new-local-macros-frame
      (push new-local-macros-frame local-definitions))   
    `(,(car env) ,local-definitions)))


(defmacro with-augmented-environment
	  ((new-env old-env &key functions macros) &body body)
  `(let ((,new-env (with-augmented-environment-internal ,old-env
							,functions
							,macros)))
     ,@body))

 ) ;#+TI