1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10 -*-


;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;*
;1;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.*

;1;; DEFMACRO
;;; note: DEFMACRO does not use PROCESS-DEFUN-BODY since DEFMACRO operates in a null lexical
;;;   environment.
;;; Note: differences from Common Lisp specs:
;;;  except at the top level of destructuring, all args are optional.
;;;  Thus, if the arglist is (X (Y Z &OPTIONAL A) &REST B)
;;;  then Y and Z are optional just like A, and the &OPTIONAL is
;;;  really a no-op.
;;;  Extra args are only checked for at the top level, too.
;;;  This is for backward compatibility with lots of old macro definitions.
;;;  Also, when &KEY is used, unrecognized keywords are not checked for.*

(Defparameter *DEFMACRO-CHECK-ARGS* T
  1"T means DEFMACRO puts code in the macro definition to check the number of args."*)
(Defvar *VARLIST* :UNBOUND
  1"Used within DEFMACRO."*)
(Defvar *VALLIST* :UNBOUND
  1"Used within DEFMACRO."*)

(Defvar *OPTIONAL-SPECIFIED-FLAGS* :unbound)
1;; Onto *OPTIONAL-SPECIFIED-FLAGS*  are pushed all the specified-flags of optional args
;; (such as, FOOP in &OPTIONAL (FOO 69 FOOP)).

;; The following variable is set to T if the pattern used &body instead of &rest*
;1; so that the indentation-function will be invoked [which tells ZWEI how to indent *
;1; invocations of the macro]*
(Defvar *DEFMACRO-&BODY-FLAG* :unbound)




1;; X is the cdr of the DEFMACRO form.
;; Return a LAMBDA expression for the expander function.*
(eval-when (compile load eval)
(DEFUN MAKE-EXPANDER-FUNCTION (X)
  ;; 09/08/87 CLM - Fixed to do error checking for bad keyword args.
  ;; 10/13/87 CLM - For PHD, fixed the macro keyword argument check to use the
  ;;                the actual argument list instead of the args listed in a DECLARE.
  ;; 01/08/88 CLM - Fixed so that error checking for bad keyword args is transparent to
  ;;                macros without keywords.
  (declare (values expander-function name))
  (flet ((safe-memq (item list)
		    (do ((items list (cdr items)))
			((atom items) nil)
		      (when (eq item (car items))
			(return items)))))
    (LET (*VARLIST* *VALLIST* *OPTIONAL-SPECIFIED-FLAGS* *defmacro-&body-flag*
	  (ARGLIST (CADR X))
	  WHOLE-ARG-DATA)
      (WHEN (AND (CONSP arglist) (EQ (CAR arglist) '&WHOLE))
	(SETQ WHOLE-ARG-DATA `((,(CADR ARGLIST) *MACROARG*))
	      ARGLIST (CDDR ARGLIST)))
      (LET* ((ARGS-DATA (DEFMACRO-&MUMBLE-CHEVEUX ARGLIST '(CDR *MACROARG*) 0))
	     (min-args (CAR args-data))
	     (opt-args (cadr args-data))
	     (max-args (CADDR args-data)))
	(MULTIPLE-VALUE-BIND (macrobody decls-for-debug-info decls-for-body doc-string)
	    (PARSE-MACRO-BODY (CDDR x))
	  ;;; now make a :descriptive-arglist for the macro using the arglist of the macro as defined. Omit
	  ;;; this step if the user has a (declare (arglist ...
	  (UNLESS (GETF decls-for-debug-info :descriptive-arglist)
	    (SETQ decls-for-debug-info
		  (LIST* :descriptive-arglist (ALL-MACRO-ARGLIST-BEFORE-&AUX arglist) decls-for-debug-info)))
	  ;;; now make a named-lambda
	  ;;; begin with the innermost stuff and work outwards.....
	  (LET* ((name (STANDARDIZE-FUNCTION-SPEC (CAR x)))
		 (named-lambda-symbol (IF (COMMON-LISP-ON-P) 'named-lambda 'zlc:named-lambda))
		 (arglist-before-aux (ALL-MACRO-ARGLIST-BEFORE-&AUX arglist))
		 tem
		 (innermost-body
		   `(
		     *MACROENVIRONMENT*                         ;; silences the compiler
		     ,@(AND *defmacro-check-args*
			    (NOT (AND (ZEROP min-args) (NULL max-args)))
			    (setq tem `((AND ,(COND ((ZEROP min-args)
					       `(> (LENGTH *macroarg*)
						   ,(1+ max-args)))
					      ((NULL max-args)
					       `(< (LENGTH *macroarg*)
						   ,(1+ min-args)))
					      (T `(OR (< (LENGTH *macroarg*)
							 ,(1+ min-args))
						      (> (LENGTH *macroarg*)
							 ,(1+ max-args)))))
				       (MACRO-REPORT-ARGS-ERROR *MACROARG* ,MIN-ARGS ,MAX-ARGS))))
			    (if (and (cdr (safe-memq '&key arglist-before-aux ))
				     (null (safe-memq '&allow-other-keys arglist-before-aux )))
				(setq tem `((or ,(car tem)
						,(let ((feux (cdr (safe-memq '&key arglist-before-aux ))))
						      `(MACRO-KEYARG-CHECK
							  (nthcdr ,(+ 1 min-args opt-args) *macroarg*)
							  ',(mapcar #'(lambda (k)
									(intern (if (consp k)
										    (if (consp (car k)) (caar k) (car k))
										    k)
										*keyword-package*))
								    feux)))) ))
				tem))
		     (LET* (,@*OPTIONAL-SPECIFIED-FLAGS*
			    ,@WHOLE-ARG-DATA
			    . ,(MAPCAR #'(lambda (x y) (LIST x y)) 
				       (NREVERSE (the list *VARLIST*)) 
				       (NREVERSE (the list *VALLIST*))))
		       ,@(WHEN decls-for-body `((DECLARE . ,decls-for-body)))
		       . ,macrobody))))
	    
	    ;; wrap an implicit block around the body unless <name> is not literal
	    (WHEN (SYMBOLP name)
	      (SETQ innermost-body `((block ,name . ,innermost-body))))
	    
	    (VALUES
	      `(,named-lambda-symbol 
		,(IF (OR decls-for-debug-info (NOT (SYMBOLP name))) (LIST name decls-for-debug-info) name)
		(*MACROARG* &OPTIONAL *MACROENVIRONMENT*)  ;; expander function arglist
		,@(WHEN doc-string (LIST doc-string))
		. ,innermost-body)
	      name
	      )))))))
)

(defun macro-keyarg-check (arglist macro-key-args)
  ;; 09/08/87 CLM - Original; fix for checking bad keyword args.
  (unless (getf arglist :allow-other-keys)
    (do ((x arglist (cddr x)))
	((null x))
      (let ((keyarg (car x)))
	(unless (member keyarg macro-key-args :test #'eq)
	  (ferror 'sys:undefined-keyword-argument
		  "Keyword arg keyword ~S unrecognized."
		  keyarg))) ) ))


(eval-when (compile load eval)
;; 12/23/88 DNG - Add special handling for :EXPR-SXHASH declarations - fixes SPR 6038.
;; 03/15/89 clm - Integrated CLOS version into Kernel.
(Defun PARSE-MACRO-BODY (x)
;;; if the defmacro form is (defmacro foo arglist . body), then parse-macro-body is called with arg (body)
  
  (MULTIPLE-VALUE-BIND (body decls doc-string)
      (PARSE-BODY x nil t)
    (LET (declarations-for-debug-info
	  declarations-for-body)
      (DOLIST (dec (FLATTEN-DECLARATIONS decls))
	(LET ((temp (CDR (ASSOC (CAR dec) *DEBUG-STRUCT-LOCAL-DECLARATION-TYPES* :test #'EQ))))
	  (IF temp
	      (setq declarations-for-debug-info (LIST* temp (COPY-TREE (CDR dec)) declarations-for-debug-info))
	    (if (eq (first dec) ':expr-sxhash)
		(setq declarations-for-debug-info (LIST* (first dec) (second dec) declarations-for-debug-info))
	      (PUSH dec  declarations-for-body)))))
      (values body declarations-for-debug-info declarations-for-body doc-string))))

(Defun ALL-MACRO-ARGLIST-BEFORE-&AUX (arglist)
  (do ((x arglist (cdr x)))
      ((atom x) arglist)
    (when (eq (car x) '&aux)
	  (return (ldiff arglist x)))))
)

(DEFPROP MACRO-REPORT-ARGS-ERROR T :ERROR-REPORTER)
(DEFUN MACRO-REPORT-ARGS-ERROR (MACRO-FORM MIN MAX &AUX (NARGS (1- (LENGTH MACRO-FORM))))
  (IF (< NARGS MIN)
      (FERROR NIL 1"Too few arguments to macro: ~D passed, ~D required."*
	      NARGS MIN)
    (IF (AND MAX (> NARGS MAX))
	(FERROR NIL 1"Too many arguments to macro: ~D passed, ~D allowed."*
		NARGS MAX))))



1;; STATE is 0 for mandatory args, 1 for optional args, 2 for rest args, 3 for aux vars,
;; 4 for &key args.
;; If it is #o10 or more, the 10 bit signifies &LIST-OF and the low three bits
;; are as usual.
;; If it is #o20 or more, it signifies that the next arg is an &ENVIRONMENT arg;
;; the low 4 bits say what state to revert to following that arg.
;; PATH is the form which, using CAR and CDR, would extract the part of the macro arg
;; which corresponds to this arg and the following args at the same level.
;; Thus, a simple arg would be set to `(CAR ,PATH).
;; PATTERN is the rest of the arglist at this level.
;; We push arg names on *VARLIST* and their appropriate values on *VALLIST*.
;; We return a list describing how many args are wanted:
;;  its car is the minimum number of args needed,
;;  its cadr is the number of optional args accepted,
;;  its caddr is the maximum number of args accepted, or NIL if any number are allowed.
;;    If non-NIL, this is normally the sum of the car and cadr.*
;;;PHD 3/23/87 Fixed &environment following a &rest arg Pb.
(eval-when (compile load eval)
(DEFUN DEFMACRO-&MUMBLE-CHEVEUX (pattern path state)
  (COND ((NULL pattern) (LIST 0 0 0))
	((ATOM pattern)
	 (IF (> state 1)
	     (FERROR NIL "Non-NIL end of list, ~S, following ~S in destructuring pattern."
		     pattern
		     (CASE state
		       (2 '&REST)
		       (3 '&AUX)
		       (4 '&KEY)
		       (T (IF (>= state #o20) '&ENVIRONMENT '&LIST-OF))))
	1     ;; else*
	     (DEFMACRO-CHEVEUX pattern path)
	     (LIST 0 0 NIL)))
	((EQ (CAR pattern) '&OPTIONAL)
	 (IF (> STATE 1) (FERROR NIL "&OPTIONAL in bad context in destructuring pattern.")
	     (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path 1)))



	((OR (EQ (CAR pattern) '&REST)(EQ (CAR pattern) '&BODY))
	 (WHEN (EQ (CAR pattern) '&BODY) (SETQ *DEFMACRO-&BODY-FLAG* T))
	 (WHEN (NULL (CDR pattern)) (FERROR NIL "&REST or &BODY followed by no argument, in destructuring pattern."))
	 (IF (> state 1) (FERROR NIL "&REST or &BODY in bad context in destructuring pattern.")
	     (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path 2)))
	((EQ (CAR pattern) '&AUX)
	 (IF (>= state #o10) (FERROR NIL "&AUX following a &LIST-OF in destructuring pattern.")
	     (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path 3)))
	((EQ (CAR pattern) '&KEY)
	 (IF (> STATE 2) (FERROR NIL "&KEY in bad context in destructuring pattern.")
	     (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path 4)))
	((EQ (CAR pattern) '&ENVIRONMENT)
	 (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path (+ state #o20)))
	((EQ (CAR pattern) '&LIST-OF)
	 (IF (< STATE 3) (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path (+ #o10 state))
	     (FERROR NIL "&LIST-OF used incorrectly in destructuring pattern.")))
	((EQ (CAR pattern) '&ALLOW-OTHER-KEYS)
	 (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path state))
	((= state 0)
	 (DEFMACRO-CHEVEUX (CAR pattern) (LIST 'CAR path))
	 (DEFMACRO-REQUIRED (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) (LIST 'CDR path) 0)))
	((= state 1)
	 (IF (ATOM (CAR pattern)) (DEFMACRO-CHEVEUX (CAR pattern) `(CAR ,path))
	     ;; else
	     (WHEN (CADDAR pattern) (PUSH (CADDAR pattern) *OPTIONAL-SPECIFIED-FLAGS*))
	     (DEFMACRO-CHEVEUX (CAAR pattern)
			       `(COND (,path
				       ,(AND (CADDAR pattern)
					     `(SETQ ,(CADDAR pattern) T))
				       (CAR ,path))
				      (T ,(CADAR pattern)))))
	 (DEFMACRO-OPTIONAL (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) (LIST 'CDR path) 1)))
	((= STATE 2)
	 (DEFMACRO-CHEVEUX (CAR pattern) path)
	 (WHEN (CDR pattern)
	   (WHEN (OR (ATOM (CDR pattern))
		     (NOT (MEMBER (CADR pattern) '(&AUX &KEY &environment))))
	     (FERROR NIL "More than one &REST argument in a macro."))
	   (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path 2))
	 (LIST 0 0 NIL))
	((= state 3)
	 (IF (ATOM (CAR pattern)) (DEFMACRO-CHEVEUX (CAR pattern) NIL)
	     (DEFMACRO-CHEVEUX (CAAR pattern) (CADAR pattern)))
	 (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) (LIST 'CDR path) 3))
	((= state 4)
	 (LET* ((SYMBOL
		  (COND ((ATOM (CAR pattern)) (CAR pattern))
			((ATOM (CAAR pattern)) (CAAR pattern))
			(T (CADAAR pattern))))
		(KEYWORD
		  (IF (AND (CONSP (CAR pattern)) (CONSP (CAAR pattern)))
		      (CAAAR pattern)
		    (INTERN (STRING symbol) 'KEYWORD)))
		(DEFAULT
		  (IF (CONSP (CAR pattern)) (CADAR pattern) NIL))
		(FLAGVAR (IF (CONSP (CAR pattern)) (CADDAR pattern))))
	   (PUSH symbol *VARLIST*)
	   (PUSH `(GET (LOCF ,path) ',keyword ,default) *VALLIST*)
	   (WHEN flagvar
	     (PUSH flagvar *VARLIST*)
	     (PUSH `(NOT (NULL (GET-LOCATION-OR-NIL (LOCF ,path) ',keyword))) *VALLIST*))
	   (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path 4)
	   (LIST 0 0 NIL)))



	((= state #o10)				;&LIST-OF not optional
	 (DEFMACRO-&LIST-OF-CHEVEUX (CAR pattern) `(CAR ,path))
	 (DEFMACRO-REQUIRED (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) `(CDR ,path) 0)))
	((= state #o11)				;&LIST-OF optional
	 (WHEN (ATOM (CAR pattern)) (FERROR NIL "Incorrect use of &LIST-OF in destructuring pattern."))
	 (WHEN (CADDAR pattern) (PUSH (CADDAR pattern) *OPTIONAL-SPECIFIED-FLAGS*))
	 (DEFMACRO-&LIST-OF-CHEVEUX (CAAR pattern)
				    `(COND (,path
					    ,(WHEN (CADDAR pattern)`(SETQ ,(CADDAR pattern) T))
					    (CAR ,path))
					   (T ,(CADAR pattern))))
	 (DEFMACRO-OPTIONAL (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) `(CDR ,path) 1)))
	((= state #o12)
	 (DEFMACRO-&LIST-OF-CHEVEUX (CAR pattern) path)
	 (WHEN (CDR pattern)
	   (WHEN (OR (ATOM (CDR pattern))
		     (NOT (EQ (CADR pattern) '&AUX)))
	     (FERROR NIL "More than one &REST argument in destructuring pattern."))
	   (DEFMACRO-&MUMBLE-CHEVEUX (CDDR pattern) path 3))
	 (LIST 0 0 NIL))
	((>= state #o20)
	 (DEFMACRO-CHEVEUX (CAR pattern) '*MACROENVIRONMENT*)
	 (DEFMACRO-&MUMBLE-CHEVEUX (CDR pattern) path (LOGAND state #o17)))
	))


(DEFUN DEFMACRO-&LIST-OF-CHEVEUX (PATTERN PATH)
  (SETQ *VALLIST*
	(LET (*VALLIST* (VALS *VALLIST*))
	  (DEFMACRO-CHEVEUX PATTERN 'X)
	  (DO ((NVALS (NREVERSE *VALLIST*) (CDR NVALS))
	       (VALS VALS
		     (CONS `(MAPCAR (FUNCTION
				      (LAMBDA (X) ,(CAR NVALS)))
			            ,PATH)
			   VALS)))
	      ((NULL NVALS) VALS)))))

(DEFUN DEFMACRO-CHEVEUX (pattern path)
       (COND ((NULL pattern))
	     ((ATOM pattern)
	      (WHEN (AND (SYMBOLP pattern)
			 (= (CHAR (SYMBOL-NAME pattern) 0) #\&))
		(IF (EQ pattern '&whole)
		    (FERROR nil "&WHOLE must appear first in a DEFMACRO lambda-list.")
		    (FERROR nil "Unrecognized & keyword in DEFMACRO:  ~S." pattern)))
	      (SETQ *VARLIST* (CONS pattern *VARLIST*)
		    *VALLIST* (CONS path *VALLIST*)))
	     (T 
	      (DEFMACRO-&MUMBLE-CHEVEUX pattern path 0))))

;Returns ARGS-DATA modified for one additional optional argument.
(DEFUN DEFMACRO-OPTIONAL (ARGS-DATA)
  (LIST (CAR ARGS-DATA) (1+ (CADR ARGS-DATA))
	(IF (CADDR ARGS-DATA) (1+ (CADDR ARGS-DATA)) NIL)))

;Returns ARGS-DATA modified for one additional required argument.
(DEFUN DEFMACRO-REQUIRED (ARGS-DATA)
  (LIST (1+ (CAR ARGS-DATA)) (CADR ARGS-DATA)
	(IF (CADDR ARGS-DATA) (1+ (CADDR ARGS-DATA)) NIL)))
)



(Defmacro DEFMACRO (&REST x)
  1"Define FUNCTION-SPEC as a macro.
When a call to the macro is expanded, the argument list LAMBDA-LIST
is matched against the arguments supplied to the macro.
The variables in it are bound.  Then the BODY is executed,
and the value of the last form in it is the expansion of the macro."*
  (DECLARE (ARGLIST FUNCTION-SPEC LAMBDA-LIST &BODY BODY))
  (LET (*VARLIST* *VALLIST* *OPTIONAL-SPECIFIED-FLAGS* *defmacro-&body-flag* (ARGLIST (CADR X)))
    (AND (LISTP ARGLIST)
	 (EQ (CAR ARGLIST) '&WHOLE)
	 (SETQ ARGLIST (CDDR ARGLIST)))
    (LET* ((args-data (DEFMACRO-&MUMBLE-CHEVEUX ARGLIST '(CDR *MACROARG*) 0))
	   (min-args (CAR ARGS-DATA))
	   (max-args (CADR ARGS-DATA)))
      (MULTIPLE-VALUE-BIND (expander-fct name)
	  (MAKE-EXPANDER-FUNCTION x)
	`(PROGN
	   ,(WHEN *defmacro-&body-flag*
		  `(EVAL-WHEN (EVAL COMPILE LOAD)
		      (DEFMACRO-SET-INDENTATION-FOR-ZWEI ',name ',(+ min-args max-args))
		      ))
	   (FDEFINE (QUOTE ,name) (FUNCTION (MACRO . ,expander-fct)) t)
	   (QUOTE ,name))))))

(DEFF MACRO-DISPLACE 'MACRO)
(DEFF DEFMACRO-DISPLACE 'DEFMACRO)