;;;   DEFMAX 	-*-mode:lisp;package:si-*- 		  -*-LISP-*-   
;;;   **************************************************************
;;;   ***** NIL ******* DEFMACRO Auxilliary helpers ****************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

;;; See second page for documentation

(eval-when (eval compile)
	   (or (status nofeature MACLISP) 
	       (STATUS macro /#)
	       (setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO)) 
	   )

#-MACLISP
    (globalize  "DEFMACRO-CHECK-ARGS"  
		"DEFMACRO-DISPLACE-CALL"  
		"DEFMACRO-FOR-COMPILING"  
		"forget-macromemos/|" 
		"DEFMAX-DISPLACE"
		"GRIND-MACROEXPANDED" 
		"MACROEXPANDED-grindmacro/|"
		"GRINDMACRO"
		"MACRO-EXPANSION-USE"  
		"MACROEXPAND"
		"MACROEXPAND-1*"
 		"MACROMEMO" 
		"MACROFETCH" 
		"MACROEXPANDED")
 

(herald DEFMAX /44)

(DECLARE (SPECIAL DEFMACRO-CHECK-ARGS  		;These are user-settable
		  DEFMACRO-DISPLACE-CALL 	; switches.
		  DEFMACRO-FOR-COMPILING 
 		  MACRO-EXPANSION-USE 
		  GRIND-MACROEXPANDED )
	 (*EXPR MACROMEMO MACROFETCH |forget-macromemos/||)
	 (SPECIAL MACROMEMO MACROEXPANDED ))


(AND (NOT (BOUNDP 'GRIND-MACROEXPANDED))
     (SETQ GRIND-MACROEXPANDED () ))
(AND (NOT (BOUNDP 'MACRO-EXPANSION-USE)) 
     (SETQ MACRO-EXPANSION-USE 'MACROEXPANDED ))
(AND (OR (NOT (BOUNDP 'MACROEXPANDED))
	 (NOT (SAMEPNAMEP MACROEXPANDED 'MACROEXPANDED )))
     (SETQ MACROEXPANDED (COPYSYMBOL 'MACROEXPANDED () )))

(AND (OR (NOT (BOUNDP 'MACROMEMO)) 			;Check size setting
	 (ATOM MACROMEMO) 				; for MACROMEMO table
	 (NOT (EQ (TYPEP (CAR MACROMEMO)) 'FIXNUM))	;Defaults to 103.
	 (< (CAR MACROMEMO) 3)				;On non-MACLISP systems
	 (> (CAR MACROMEMO) 100000.))			; this number is mean-
     (SETQ MACROMEMO (NCONS 103.)))			; ingless


;;; Three flags controlling the macro-producing macros:
;;;   DEFMACRO-DISPLACE-CALL if non-null, the resultant macros do a runtime
;;; 	(default = T)	     test of MACRO-EXPANSION-USE for possible 
;;;			     displacement and/or "memoizing" in a hasharray.
;;;   DEFMACRO-FOR-COMPILING determines whether the macros produced will be
;;; 	(default = T)		of the form that gets compiled by COMPLR 
;;; 				(in either case, COMPLR "remembers" them).
;;;   DEFMACRO-CHECK-ARGS determines whether there should be code to carry 
;;;	(default = T)		out number-of-args checking at runtime.

;;;   In the runtime environment, macros produced while 
;;; DEFMACRO-DISPLACE-CALL is non-null will pay attention to the global 
;;; variable MACRO-EXPANSION-USE, which if null means merely to run the
;;; code just produced, but otherwise is a function of two arguments for
;;; doing some kind of "displaceing".  The user can supply his own function,
;;; or accept one of the system-supplied ones. (These particular three 
;;; system functions should not be clobbered by the user since other parts
;;; of the system depend upon them).  System-supplied "functions":
;;;     =  ()	 	 - run no function, but merely expand the macro
;;;			   and return that value.
;;; 	=  MACROEXPANDED - Displace the original cell with a form like
;;; 			   (MACROEXPANDED <name> 
;;; 					  <version-number> 
;;;					  <original-form> 
;;; 					  <expansion>)
;;; 			   Thereafter, the macro named MACROEXPANDED will 
;;; 			   return the <expansion> until either the value of
;;; 			   MACRO-EXPANSION-USE changes, or the <version-number>
;;; 			   of the original macro changes (such as by loading
;;; 			   in a new definition of the macro).
;;;     =  MACROMEMO 	 - Remember the expansions is a hasharray, where the
;;; 			   global variable MACROMEMO is a dotted pair of the
;;; 			   number-of-buckets and the array pointer itself.
;;; 			   All "memorized" expansions can be forgotten merely
;;; 			   by doing (RPLACD MACROMEMO () ).
;;; 	=  DISPLACE 	 - Displace the original cell with the expansion of the
;;; 			   macro-form.  There is no general way to un-do, or 
;;; 			   "go back" after this kind of displacement.
;;; Pretty-printing of forms displaced with MACROEXPANDED is controlled by
;;;  the global variable GRIND-MACROEXPANDED:  if T, then only the
;;;  expanded form will be printed; if (), then only the original form
;;;  will be printed.  (Default = () )



(eval-when (eval compile)
	   (or (status feature MACAID) (load '((LISP) MACAID)))
	   (and (status feature MACLISP)
		(status nofeature MULTICS)
		(sstatus feature PDP10))
)

;;; If "MACROMEMO" is the working mode, the under maclisp, 
;;;  (CDR MACROMEMO) is a ptr to the hasharray;  but under non-maclisp
;;;  it is a ptr to a "tconc" cell, namely cdr of the cell is a datalist.
;;; Note that we don't really expect to use the "MACROMEMO" mode
;;;  on any implementation other than MACLISP

(DECLARE (SETQ DEFMACRO-FOR-COMPILING () 
	       DEFMACRO-DISPLACE-CALL () 
	       DEFMACRO-CHECK-ARGS () ))

(macro HASH-GET (x) 
    `(CDR (ASSQ ,(cadr x)
   #-MACLISP    (CDDR MACROMEMO)
   #+MACLISP    (ARRAYCALL T (CDR MACROMEMO) 
			     (\ (MAKNUM ,(cadr x)) (CAR MACROMEMO)))
	   )))

(macro HASH-PUTPROP (x)
   (let ((oldform (cadr x)) (expansion (caddr x)))
   #-MACLISP `(PROG2 (OR (CDR MACROMEMO) 
			 (RPLACD MACROMEMO (LIST (GENSYM))))
		     (RPLACD (CDR MACROMEMO) (CONS ,oldform ,expansion)))
   #+MACLISP `(PROG2 (OR (CDR MACROMEMO)
			 (RPLACD MACROMEMO (*ARRAY NIL T (CAR MACROMEMO))))
		      ;Initialize memo table if necessary
		     (LET ((HASHNO (\ (MAKNUM ,oldform) (CAR MACROMEMO))))
			  (DECLARE (FIXNUM HASHNO))
			  (STORE (ARRAYCALL T (CDR MACROMEMO) HASHNO)	
				 (CONS (CONS ,oldform ,expansion)
				       (ARRAYCALL T (CDR MACROMEMO) HASHNO)))))
   ))


#+PDP10 (macro DEFMAX-DISPLACE (x) `(DISPLACE ,.(cdr x)))
#-PDP10 (defun DEFMAX-DISPLACE (x y)
	   (prog () 
	      A  (cond ((atom x) 
			(setq x (error '|Not a list - DEFMAX-DISPLACE|
				       x 
				       'WRNG-TYPE-ARG))
			(go a)))
		 (rplacd x (cond ((atom y)
				  (rplaca x 'PROGN)
				  (list y))
				 ('t (rplaca x (car y))
				     (cdr y))))
		 (return x)))


(COMMENT MACRO FETCH and MEMO)
(COMMENT |forget-macromemos/||)

(DEFUN MACROFETCH (FORM)
   ; Look up form in memo-izing hash table
   (AND (CDR MACROMEMO)
	(EQ MACRO-EXPANSION-USE 'MACROMEMO)
	(HASH-GET FORM 'MACROMEMO)))

(DEFUN MACROMEMO (OLDFORM EXPANSION NAME)
   (AND MACRO-EXPANSION-USE 
	#-LISPM (MEMQ COMPILER-STATE '(() TOPLEVEL))
	(CASEQ MACRO-EXPANSION-USE 
	       (MACROMEMO 
		 (HASH-PUTPROP OLDFORM EXPANSION 'MACROMEMO))
	       ((MACROEXPANDED MACROEXPAND) 
		 (DEFMAX-DISPLACE 
		      OLDFORM 
		      `(MACROEXPANDED ,name 
				      ,(get name macroexpanded)
				      ,(cons (car oldform) (cdr oldform)) 
				      ,expansion))) 
	       (T (FUNCALL MACRO-EXPANSION-USE OLDFORM EXPANSION)) ))
   EXPANSION)


(DEFUN |forget-macromemos/|| (NAME)
 (COND ((CDR MACROMEMO)					;Flush any old memos
    #M	(DO I (1- (CAR MACROMEMO)) (1- I) (< I 0)	; for this macro name
	    (MAP  '(LAMBDA (LL)
		     (PROG (OK Y BP)
			   (SETQ OK T Y LL)
			A  (AND Y 
				(NOT (ATOM (CAR Y)))	;(<pair> ...)
				(NOT (ATOM (CAAR Y)))	;(<old> . <expansion>)
				(EQ NAME (CAAAR Y))	;(<fun> ...)
				(COND ((OR (NULL BP) (NULL OK))
				       (RPLACA Y (SETQ OK () )))
				      ('T (SETQ Y (RPLACD BP (CDR Y)))
					  (GO A))))
			   (AND (SETQ Y (CDR (SETQ BP Y))) (GO A))
			   (AND (NOT OK)
				(STORE (ARRAYCALL T (CDR MACROMEMO) I)
				       (DELQ () LL)))))
		  (ARRAYCALL T (CDR MACROMEMO) I)))
    #-MACLISP (PROG (OK Y BP)
		    (SETQ OK T Y (CDR (SETQ BP (CDR MACROMEMO))))
		 A  (COND ((AND Y 
				(NOT (ATOM (CAR Y)))	;(<pair> ...)
				(NOT (ATOM (CAAR Y)))	;(<old> . <expansion>)
				(EQ NAME (CAAAR Y)))	;(<fun> ...)
			   (SETQ Y (RPLACD BP (CDR Y)))
			   (GO A))
			  ((SETQ Y (CDR (SETQ BP Y))) (GO A))))))
 (PUTPROP NAME (1+ (OR (GET NAME MACROEXPANDED) 0)) MACROEXPANDED))


(COMMENT MACROEXPAND)

#-LISPM (progn 'compile 

(defun MACROEXPAND (form)
   (cond ((atom form) form)
	 ((prog (x)
	    A	(cond ((null (setq x (macroexpand-1* form)))
		       (return form))
		      ((atom (setq form (car x)))
		       (return form)))
		(go a)))))

;;; MACROEXPAND-1 returns the one-step expansion of a macro.  
(defun MACROEXPAND-1 (x) 
       (cond ((atom x) x)
	     ('t (let ((nx (macroexpand-1* x)))
		      (cond (nx (car nx))
			    ('t x))))))

;Following is like MACROEXPAND-1, but arg is guaranteed non-atomic, and
;returns () if no expansion happens, or NCONS of the expansion otherwise.
(defun MACROEXPAND-1* (x) 	
  (prog (mcx fun)
 	(setq fun (car x))
     A  (cond ((not (atom fun))
	       (return (cond ((eq (car fun) 'LAMBDA) ())
			     ((setq mcx (macroexpand-1* fun))
			      (list (cons (car mcx) (cdr x)))))))
	      ((not (symbolp (car x))) (return () )))
   #M 	(setq mcx (get fun 'MACRO)) 
   #-MACLISP 
	(and (fboundp fun)
	     (setq mcx (fsymeval fun))
	     (eq (car mcx) 'MACRO)
	     (setq mcx (cdr mcx)))
	(cond (mcx (return (list (funcall mcx x))))
	      ((and (setq mcx (get fun 'AUTOLOAD)) 
		    (not (fboundp fun)))
	       (funcall autoload (cons fun mcx))
	       (cond ((not (fboundp fun))
		      (setq fun (error '|Fun undefined after autoload| 
				       fun 
				       'WRNG-TYPE-ARG))
		      (setq x (cons fun (cdr x)))))
	       (go A)))))

)	;end of #-LISPM 

#Q (defun MACROEXPAND-1* (x) 	
      ((lambda (ocarx ocdrx val)
	       (setq val (macroexpand-1 x))
	       (cond ((atom x) (ferror nil "~SAtomic arg to MACROEXPAND-1*" X))
		     ((and (eq x val) (eq ocarx (car x)) (eq ocdrx (cdr x)))
		      () )
		     ((list val))))
          (car x) (cdr x) () ))

(COMMENT MACROEXPANDED)

(DECLARE (SETQ DEFMACRO-FOR-COMPILING 'T 
	       DEFMACRO-DISPLACE-CALL () 
	       DEFMACRO-CHECK-ARGS () ))


(MACRO MACROEXPANDED (FORM)
   ;Format: (MACROEXPANDED <name> <version> <original-form> <expanded-form>)
   (LET ((TAIL (CDDDR FORM)))
	(COND ((AND (MEMQ MACRO-EXPANSION-USE '(MACROEXPANDED MACROEXPAND))
		    (= (GET (CADR FORM) MACROEXPANDED) (CADDR FORM)))
	        ;Use the expanded-form, if valid
	       (CADR TAIL))
	      ('T ;Revert to original form otherwise, and try expanding again
	          (DEFMAX-DISPLACE FORM (CAR TAIL))))))


(DEFPROP MACROEXPANDED |MACROEXPANDED-grindmacro/|| GRINDMACRO)