;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; This file contains the macros that are part of the standard
;;; Spice Lisp environment.

;;; Written and maintained by Scott Fahlman.

;;; *******************************************************************


;;; The following specials are used by the arglist analysis functions in
;;; the DEFMACRO file.

(proclaim '(special %arg-count %min-args %restp %let-list %keyword-tests))

;;; The following tells macros whether they are expanding in the compiler.

(proclaim '(special *in-the-compiler*))

;;;; DEFVAR, etc.

(defmacro defvar (var &optional (val nil valp) (doc nil docp))
  "For defining global variables at top level.  Declares the variable
  SPECIAL and, optionally, initializes it.  If the variable already has a
  value, the old value is not clobbered.  The third argument is an optional
  documentation string for the variable."
  `(progn
    (proclaim '(special ,var))
    ,@(cond (valp `((or (boundp ',var) (setq ,var ,val))))
	    (t nil))
    ,@(cond (docp `((%put ',var '%var-documentation ',doc)))
	    (t nil))
    ',var))

(defmacro defparameter (var val &optional (doc nil docp))
  "Defines a parameter that is not normally changed by the program,
  but that may be changed without causing an error.  Declares the
  variable special and sets its value to VAL.  The third argument is
  an optional documentation string for the parameter."
  `(progn
    (proclaim '(special ,var))
    (setq ,var ,val)
    ,@(cond (docp `((%put ',var '%var-documentation ',doc)))
	    (t nil))
    ',var))


(defmacro defconstant (var val &optional (doc nil docp))
  "For defining global constants at top level.  Declares the variable
  SPECIAL and initializes it.  The DEFCONST says that the value is
  constant and may be compiled into code.  If the variable already has a
  value, and this is not equal to the init, an error is signalled.
  The third argument is an optional documentation string for the variable."
  `(progn
    (proclaim '(special ,var))
    (remprop ',var '%constant)
    (cond ((boundp ',var)
	   (unless (equal ,var ,val)
		   (cerror "Go ahead and change the value."
			   "Constant ~S being redefined." ',var)
		   (setq ,var ,val)))
	  (t (setq ,var ,val)))
    (%put ',var '%constant t)
    ,@(cond (docp `((%put ',var '%var-documentation ',doc)))
	    (t nil))
    ',var))


;;;; ASSORTED CONTROL STRUCTURES

(defmacro when (&rest forms)
  "First arg is a predicate.  If it is non-null, the rest of the forms are
  evaluated as a PROGN."
  `(cond ,forms))

(defmacro unless (test &rest forms)
  "First arg is a predicate.  If it is null, the rest of the forms are
  evaluated as a PROGN."
  `(cond ((not ,test) ,@forms)))


;;;; DO AND FRIENDS

(defmacro do (varlist endlist &body body)
  "Iteration construct."
  (let ((decl nil) (inits nil) (steps nil) (l1 (gensym)) (l2 (gensym)))
    ;; Check for illegal old-style do.
    (if (or (and varlist (atom varlist))
	    (and endlist (atom endlist)))
	(error "Ill-formed DO -- possibly illegal old style DO?" nil))
    ;; Dig out the declarations.
    (do ((b body (cdr b)))
	((or (atom b)
	     (not (and b (car b) (listp (car b))
		       (eq (caar b) 'declare))))
	 (setq decl (nreverse decl))
	 (setq body b))
      (setq decl (cons (car b) decl)))
    ;; Parse the varlist to get inits and steps.
    (do ((vl varlist (cdr vl))
	 (v))
	((atom vl))
      (setq v (car vl))
      (cond ((atom v)
	     (setq inits (cons v inits)))
	    ((and (= (length v) 1) (symbolp (car v)))
	     (setq inits (cons (car v) inits)))
	    ((and (= (length v) 2) (symbolp (car v)))
	     (setq inits (cons v inits)))
	    ((and (= (length v) 3) (symbolp (car v)))
	     (setq inits (cons (list (car v) (cadr v)) inits))
	     (setq steps (cons (caddr v) (cons (car v) steps))))
	    (t (error "~S is illegal form in a DO varlist." v))))
    ;; And finally construct the new form.
    `(block nil
       (let ,(nreverse inits)
	 ,@decl
	 (tagbody
	   (go ,L2)
	  ,L1
	   ,@body
	   (psetq ,@(nreverse steps))
	  ,L2 
	   (unless ,(car endlist) (go ,L1))
	   (return (progn ,@(cdr endlist))))))))


(defmacro do* (varlist endlist &body body)
  "Iteration construct.  Like DO, but does inits and steps in serial,
  not all at once."
  (let ((decl nil) (inits nil) (steps nil) (l1 (gensym)) (l2 (gensym)))
    ;; Check for illegal old-style do.
    (if (or (and varlist (atom varlist))
	    (and endlist (atom endlist)))
	(error "Ill-formed DO -- possibly illegal old style DO?" nil))
    ;; Dig out the declarations.
    (do ((b body (cdr b)))
	((or (atom b)
	     (not (and b (car b) (listp (car b))
		       (eq (caar b) 'declare))))
	 (setq decl (nreverse decl))
	 (setq body b))
      (setq decl (cons (car b) decl)))
    ;; Parse the varlist to get inits and steps.
    (do ((vl varlist (cdr vl))
	 (v))
	((atom vl))
      (setq v (car vl))
      (cond ((atom v)
	     (setq inits (cons v inits)))
	    ((and (= (length v) 1) (symbolp (car v)))
	     (setq inits (cons (car v) inits)))
	    ((and (= (length v) 2) (symbolp (car v)))
	     (setq inits (cons v inits)))
	    ((and (= (length v) 3) (symbolp (car v)))
	     (setq inits (cons (list (car v) (cadr v)) inits))
	     (setq steps (cons (caddr v) (cons (car v) steps))))
	    (t (error "~S is illegal form in a DO varlist." v))))
    ;; And finally construct the new form.
    `(block nil
       (let* ,(nreverse inits)
	 ,@decl
	 (tagbody
	   (go ,L2)
	  ,L1
	   ,@body
	   (setq ,@(nreverse steps))
	  ,L2 
	   (unless ,(car endlist) (go ,L1))
	   (return (progn ,@(cdr endlist))))))))


(defmacro dotimes ((var count &optional (result nil)) &body body)
  "Syntax is (DOTIMES (var count [result]) . body).
  Do body COUNT times with VAR increasing from 0 to COUNT - 1.
  Return result form or NIL."
  (cond ((numberp count)
	 `(do ((,var 0 (1+ ,var)))
	      ((>= ,var ,count) ,result)
	    ,@body))
	(t (let ((v1 (gensym)))
	     `(do ((,var 0 (1+ ,var)) (,v1 ,count))
		  ((>= ,var ,v1) ,result)
		,@body)))))


(defmacro dolist ((var list &optional (result nil)) &body body)
  "Syntax is (DOLIST (var list [result]) . body).
  Do body with VAR bound to each member of LIST, then return result
  form or NIL."
  (let ((v1 (gensym)))
    `(do* ((,v1 ,list (cdr ,v1))
	   (,var (car ,v1) (car ,v1)))
	  ((atom ,v1) ,result)
	,@body)))


;;;; SETF and friends.

;;; Note: The expansions for SETF and friends sometimes create needless
;;; LET-bindings of argument values.  The compiler will remove most of
;;; these spurious bindings, so SETF doesn't worry too much about creating
;;; them. 

;;; The inverse for a generalized-variable reference function is stored in
;;; one of two ways:
;;;
;;; A SETF-INVERSE property corresponds to the short form of DEFSETF.  It is
;;; the name of a function takes the same args as the reference form, plus a
;;; new-value arg at the end.
;;;
;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or
;;; by DEFINE-SETF-METHOD.  It is a function that is called on the reference
;;; form and that produces five values: a list of temporary variables, a list
;;; of value forms, a list of the single store-value form, a storing function,
;;; and an accessing function.

(defun get-setf-method (form)
  "Returns five values needed by the SETF machinery: a list of temporary
  variables, a list of values with which to fill them, the temporary for the
  new value in a list, the setting function, and the accessing function."
  (let (temp)
    (cond ((symbolp form)
	   (let ((new-var (gensym)))
	     (values nil nil (list new-var) `(setq ,form ,new-var) form)))
	  ((atom form)
	   (error "~S illegal atomic form for GET-SETF-METHOD." form))
	  ((setq temp (get (car form) 'setf-inverse))
	   (let ((new-var (gensym))
		 (vars nil)
		 (vals nil))
	     (dolist (x (cdr form))
	       (push (gensym) vars)
	       (push x vals))
	     (setq vals (nreverse vals))
	     (values vars vals (list new-var)
		     `(,temp ,@vars ,new-var)
		     `(,(car form) ,@vars))))
	  ((setq temp (get (car form) 'setf-method-expander))
	   (funcall temp form))
	  ((and (boundp '*in-the-compiler*) *in-the-compiler*)
	   (if (eq (setq temp (compiler-macroexpand form)) form)
	       (error "~S is not a known location specifier for SETF."
		      (car form))
	       (get-setf-method temp)))
	  (t
	   (if (eq (setq temp (macroexpand form)) form)
	       (error "~S is not a known location specifier for SETF."
		      (car form))
	       (get-setf-method temp))))))


;;; The following is like macroexpand, but looks for MACRO-IN-COMPILER
;;; properties as well.

(defun compiler-macroexpand-1 (form)
  (let (temp)
    (cond ((not (listp form)) (values form nil))
	  ((not (symbolp (car form))) (values form nil))
	  ((or (setq temp (get (car form) 'macro-in-compiler))
	       (setq temp (macro-function (car form))))
	   (values (funcall *macroexpand-hook* temp form) t))
	  (t (values form nil)))))

(defun compiler-macroexpand (form)
  (prog (flag)
    (multiple-value-setq (form flag) (compiler-macroexpand-1 form))
    (or flag (return (values form nil)))
    loop
    (multiple-value-setq (form flag) (compiler-macroexpand-1 form))
    (if flag (go loop) (return (values form t)))))


(defun get-setf-method-multiple-value (form)
  "Like Get-Setf-Method, but may return multiple new-value variables."
  (get-setf-method form))


(defmacro define-setf-method (access-fn lambda-list &body body)
  "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body
  must be a form that returns the five magical values."
  (prog ((local-decs nil)
	 (doc nil)
	 (arg-test nil)
	 (%arg-count 0)
	 (%min-args 0)
	 (%restp nil)
	 (%let-list nil)
	 (%keyword-tests nil))
    (declare (special %arg-count %min-args %restp %let-list %keyword-tests))
    (cond ((not (symbolp access-fn))
	   (error
	    "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."
	    access-fn)))
    ;; Check for local declarations and documentation string.
   LOOP
    (cond ((atom body)
	   (setq body '(nil)))
	  ((and (not (atom (car body))) (eq (caar body) 'declare))
	   (setq local-decs (append local-decs (cdar body)))
	   (setq body (cdr body))
	   (go loop))
	  ((and (stringp (car body)) (not (null (cdr body))))
	   (setq doc (list (car body)))
	   (setq body (cdr body))
	   (go loop)))
    ;; Analyze the lambda list.
    (analyze1 lambda-list '(cdr %lambda-list) access-fn '%lambda-list)
    (setq arg-test
	  (cond ((and (zerop %min-args) %restp) nil)
		((zerop %min-args)
		 `(> (length %lambda-list) ,(1+ %arg-count)))
		(%restp
		  `(< (length %lambda-list) ,(1+ %min-args)))
		((= %min-args %arg-count)
		 `(not (= (length %lambda-list) ,(1+ %min-args))))
		(t
		 `(or (> (length %lambda-list) ,(1+ %arg-count))
		      (< (length %lambda-list) ,(1+ %min-args))))))
    ;; Now build the body of the macro.
    (when (null lambda-list) (push '(ignore %lambda-list) local-decs))
    (setq body `(let* ,(nreverse %let-list)
		  ,@ (and local-decs (list (cons 'declare local-decs)))
		  ,@ %keyword-tests
		  ,@ body))
    (and arg-test
	 (setq body
	       `(cond (,arg-test
		       (error
			"Setf expander for ~S cannot be called with ~S args."
			',access-fn (1- (length %lambda-list))))
		      (t ,body))))
    (return `(eval-when (load compile eval)
	       (%put ',access-fn
		     'setf-method-expander
		     #'(lambda (%lambda-list) ,body))
	      ,@(if doc
		    `((%put ',access-fn '%setf-documentation ',doc)))
	      ',access-fn))))

(eval-when (compile load eval)

(defun defsetter (fn rest)
  (let ((arglist (car rest))
	(new-var (car (cadr rest)))
	(body (cddr rest))
	(local-decs nil)
	(%arg-count 0)
	(%min-args 0)
	(%restp nil)
	(%let-list nil)
	(%keyword-tests nil))
    (declare (special %arg-count %min-args %restp %let-list %keyword-tests))
    ;; Check for local declarations and documentation string.
    (tagbody
     LOOP
     (cond ((atom body)
	    (setq body '(nil)))
	   ((and (not (atom (car body))) (eq (caar body) 'declare))
	    (setq local-decs (append local-decs (cdar body)))
	    (setq body (cdr body))
	    (go loop))
	   ((and (stringp (car body)) (not (null (cdr body))))
	    (setq body (cdr body))
	    (go loop))))
    ;; Analyze the defmacro argument list.
    (analyze1 arglist '(cdr %access-arglist) fn '%access-arglist)
    ;; Now build the body of the transform.
    (when (null arglist) (push '(ignore %access-arglist) local-decs))
    (setq body `(let* ,(nreverse %let-list)
		  ,@ (and local-decs (list (cons 'declare local-decs)))
		  ,@ %keyword-tests
		  ,@ body))
    `(lambda (%access-arglist ,new-var) ,body)))

) ; End of Eval-When.

(defmacro defsetf (access-fn &rest rest)
  "Associates a SETF update function or macro with the specified access
  function or macro.  The format is complex.  See the manual for
  details."
  (cond ((not (listp (car rest)))
	 `(eval-when (load compile eval)
	    (remprop ',access-fn 'setf-method-expander)     ; SKH 4/17/84
	    (%put ',access-fn 'setf-inverse ',(car rest))
	    ,@(if (and (car rest) (stringp (cadr rest)))
		  `((eval-when (load eval)
		      (%put ',access-fn '%setf-documentation ,(cadr rest)))))
	    ',access-fn))
	((and (listp (car rest)) (cdr rest) (listp (cadr rest)))
	 (if (not (= (length (cadr rest)) 1))
	     (cerror "Ignore the extra items in the list."
		     "Only one new-value variable allowed in DEFSETF."))
	 (let* ((doc (do ((x (cddr rest) (cdr x)))
			 ((or (atom x) (atom (cdr x))) nil)
		       (cond ((stringp (car x)) (return (car x)))
			     ((and (listp (car x))
				   (eq (caar x) 'declaration)))
			     (t (return nil)))))
		(setting-form-generator (defsetter access-fn rest))) 
	   `(eval-when (load compile eval)
	      (remprop ',access-fn 'setf-inverse)     ;SKH 4/17/84
	      (%put ',access-fn 'setf-method-expander
		    #'(lambda (access-form)
		       (do* ((args (cdr access-form) (cdr args))
			     (dummies nil (cons (gensym) dummies))
			     (newval-var (gensym))
			     (new-access-form nil))
			    ((atom args)
			     (setq new-access-form 
				   (cons (car access-form) dummies))
			     (values
			      dummies
			      (cdr access-form)
			      (list newval-var)
			      (funcall (function ,setting-form-generator)
				       new-access-form newval-var)
			      new-access-form)))))
	      ,@(if doc
		    `((eval-when (load eval)
			(%put ',access-fn '%setf-documentation ',doc)))
		    `((eval-when (load eval)             ;SKH 4/17/84
			(remprop ',access-fn '%setf-documentation))))
	      ',access-fn)))
	(t (error "Ill-formed DEFSETF for ~S." access-fn))))


(defmacro setf (&rest args)
  "Takes pairs of arguments like SETQ.  The first is a place and the second
  is the value that is supposed to go into that place.  Returns the last
  value.  The place argument may be any of the access forms for which SETF
  knows a corresponding setting form."
  (let ((temp (length args)))
    (cond ((= temp 2)
	   (cond ((atom (car args))
		  `(setq ,(car args) ,(cadr args)))
		 ((setq temp (get (caar args) 'setf-inverse))
		  `(,temp ,@(cdar args) ,(cadr args)))
		 (t (multiple-value-bind (dummies vals newval setter getter)
		      (get-setf-method (car args))
                      (declare (ignore getter))
		      (do* ((d dummies (cdr d))
			    (v vals (cdr v))
			    (let-list nil))
			   ((null d)
			    (setq let-list 
				  (nreverse (cons (list (car newval)
							(cadr args))
						  let-list)))
			    `(let* ,let-list ,setter))
			(setq let-list
			      (cons (list (car d) (car v)) let-list)))))))
	  ((oddp temp) 
	   (error "Odd number of args to SETF."))
	  (t (do ((a args (cddr a)) (l nil))
		 ((null a) `(progn ,@(nreverse l)))
	       (setq l (cons (list 'setf (car a) (cadr a)) l)))))))


(defmacro psetf (&rest args)
  "This is to SETF as PSETQ is to SETQ.  Args are alternating place
  expressions and values to go into those places.  All of the subforms and
  values are determined, left to right, and only then are the locations
  updated.  Returns NIL."
  (do ((a args (cddr a))
       (let-list nil)
       (setf-list nil))
      ((atom a)
       `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))
    (if (atom (cdr a))
	(error "Odd number of args to PSETF."))
    (multiple-value-bind (dummies vals newval setter getter)
      (get-setf-method (car a))
      (declare (ignore getter))
      (do* ((d dummies (cdr d))
	    (v vals (cdr v)))
	   ((null d))
	(push (list (car d) (car v)) let-list))
      (push (list (car newval) (cadr a)) let-list)
      (push setter setf-list))))


(defmacro shiftf (&rest args)
  "One or more SETF-style place expressions, followed by a single
  value expression.  Evaluates all of the expressions in turn, then
  assigns the value of each expression to the place on its left,
  returning the value of the leftmost."
  (if (< (length args) 2)
      (error "Too few argument forms to a SHIFTF."))
  (let ((leftmost (gensym)))
    (do ((a args (cdr a))
	 (let-list nil)
	 (setf-list nil)
	 (next-var leftmost))
	((atom (cdr a))
	 (push (list next-var (car a)) let-list)
	 `(let* ,(nreverse let-list) ,@(nreverse setf-list) ,leftmost))
      (multiple-value-bind (dummies vals newval setter getter)
	(get-setf-method (car a))
	(do* ((d dummies (cdr d))
	      (v vals (cdr v)))
	     ((null d))
	  (push (list (car d) (car v)) let-list))
	(push (list next-var getter) let-list)
	(push setter setf-list)
	(setq next-var (car newval))))))


(defmacro rotatef (&rest args)
  "Takes any number of SETF-style place expressions.  Evaluates all of the
  expressions in turn, then assigns to each place the value of the form to
  its right.  The rightmost form gets the value of the leftmost.  Returns NIL."
  (cond ((null args) nil)
	((null (cdr args)) `(progn ,(car args) nil))
	(t (do ((a args (cdr a))
		(let-list nil)
		(setf-list nil)
		(next-var nil)
		(fix-me nil))
	       ((atom a)
		  (rplaca fix-me next-var)
		  `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))
	       (multiple-value-bind (dummies vals newval setter getter)
                 (get-setf-method (car a))
		 (do ((d dummies (cdr d))
		      (v vals (cdr v)))
		     ((null d))
		   (push (list (car d) (car v)) let-list))
		 (push (list next-var getter) let-list)
		 ;; We don't know the newval variable for the last form yet,
		 ;; so fake it for the first getter and fix it at the end.
		 (unless fix-me (setq fix-me (car let-list)))
		 (push setter setf-list)
		 (setq next-var (car newval)))))))


(defmacro define-modify-macro (name lambda-list function &optional doc-string)
  "Creates a new read-modify-write macro like PUSH or INCF."
  (let ((other-args nil)
	(rest-arg nil))
    ;; Parse out the variable names and rest arg from the lambda list.
    (do ((ll lambda-list (cdr ll))
	 (arg nil))
	((null ll))
      (setq arg (car ll))
      (cond ((eq arg '&optional))
	    ((eq arg '&rest)
	     (if (symbolp (cadr ll))
		 (setq rest-arg (cadr ll))
		 (error "Non-symbol &rest arg in definition of ~S." name))
	     (if (null (cddr ll))
		 (return nil)
		 (error "Illegal stuff after &rest arg in Define-Modify-Macro.")))
	    ((memq arg '(&key &allow-other-keys &aux))
	     (error "~S not allowed in Define-Modify-Macro lambda list." arg))
	    ((symbolp arg)
	     (push arg other-args))
	    ((and (listp arg) (symbolp (car arg)))
	     (push (car arg) other-args))
	    (t (error "Illegal stuff in lambda list of Define-Modify-Macro."))))
    (setq other-args (nreverse other-args))
    `(defmacro ,name (%reference ,@lambda-list)
       ,doc-string
       (multiple-value-bind (dummies vals newval setter getter)
	 (get-setf-method %reference)
	 (do ((d dummies (cdr d))
	      (v vals (cdr v))
	      (let-list nil (cons (list (car d) (car v)) let-list)))
	     ((null d)
	      (push 
	       (list (car newval)
		     ,(if rest-arg
			  `(list* ',function getter ,@other-args ,rest-arg)
			  `(list ',function getter ,@other-args)))
	       let-list)
	      `(let* ,(nreverse let-list)
		 ,setter)))))))


(defmacro push (obj place)
  "Takes an object and a location holding a list.  Conses the object onto
  the list, returning the modified list."
  (if (symbolp place)
      `(setq ,place (cons ,obj ,place))
      (multiple-value-bind (dummies vals newval setter getter)
	(get-setf-method place)
	(do* ((d dummies (cdr d))
	      (v vals (cdr v))
	      (let-list nil))
	     ((null d)
	      (push (list (car newval) `(cons ,obj ,getter))
		    let-list)
	      `(let* ,(nreverse let-list)
		 ,setter))
	  (push (list (car d) (car v)) let-list)))))


(defmacro pushnew (obj place &rest keys)
  "Takes an object and a location holding a list.  If the object is already
  in the list, does nothing.  Else, conses the object onto the list.  Returns
  NIL.  If there is a :TEST keyword, this is used for the comparison."
  (if (symbolp place)
      `(setq ,place (adjoin ,obj ,place ,@keys))
      (multiple-value-bind (dummies vals newval setter getter)
	(get-setf-method place)
	(do* ((d dummies (cdr d))
	      (v vals (cdr v))
	      (let-list nil))
	     ((null d)
	      (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
		    let-list)
	      `(let* ,(nreverse let-list)
		 ,setter))
	  (push (list (car d) (car v)) let-list)))))


(defmacro pop (place)
  "The argument is a location holding a list.  Pops one item off the front
  of the list and returns it."
  (if (symbolp place)
      `(prog1 (car ,place) (setq ,place (cdr ,place)))
      (multiple-value-bind (dummies vals newval setter getter)
			   (get-setf-method place)
	(do* ((d dummies (cdr d))
	      (v vals (cdr v))
	      (let-list nil))
	     ((null d)
	      (push (list (car newval) getter) let-list)
	      `(let* ,(nreverse let-list)
		 (prog1 (car ,(car newval))
			(setq ,(car newval) (cdr ,(car newval)))
			,setter)))
	  (push (list (car d) (car v)) let-list)))))


(define-modify-macro incf (&optional (delta 1)) +
  "The first argument is some location holding a number.  This number is
  incremented by the second argument, DELTA, which defaults to 1.")

(define-modify-macro decf (&optional (delta 1)) -
  "The first argument is some location holding a number.  This number is
  decremented by the second argument, DELTA, which defaults to 1.")


(defmacro putf (place indicator value)
  "Place may be any place expression acceptable to SETF, and is expected
  to hold a property list or ().  This list is destructively altered so
  that (GETF place indicator) will find the specified newvalue.  Returns
  the new value."
  (multiple-value-bind (dummies vals newval setter getter)
		       (get-setf-method place)
    (do* ((d dummies (cdr d))
	  (v vals (cdr v))
	  (let-list nil)
	  (ind-temp (gensym))
	  (val-temp (gensym)))
	 ((null d)
	  (push (list (car newval) getter) let-list)
	  (push (list ind-temp indicator) let-list)
	  (push (list val-temp value) let-list)
	  `(let* ,(nreverse let-list)
	     (setq ,(car newval)
		   (%primitive putf ,(car newval) ,ind-temp ,val-temp))
	     ,setter
	     ,val-temp))
      (push (list (car d) (car v)) let-list))))


(defmacro remf (place indicator)
  "Place may be any place expression acceptable to SETF, and is expected
  to hold a property list or ().  This list is destructively altered to
  remove the property specified by the indicator.  Returns T if such a
  property was present, NIL if not."
  (multiple-value-bind (dummies vals newval setter getter)
    (get-setf-method place)
    (do* ((d dummies (cdr d))
	  (v vals (cdr v))
	  (let-list nil)
	  (ind-temp (gensym))
	  (local1 (gensym))
	  (local2 (gensym)))
	 ((null d)
	  (push (list (car newval) getter) let-list)
	  (push (list ind-temp indicator) let-list)
	  `(let* ,(nreverse let-list)
	     (do ((,local1 ,(car newval) (cddr ,local1))
		  (,local2 nil ,local1))
		 ((atom ,local1) nil)
	       (cond ((atom (cdr ,local1))
		      (error "Odd-length property list in REMF."))
		     ((eq (car ,local1) ,ind-temp)
		      (cond (,local2
			     (rplacd (cdr ,local2) (cddr ,local1))
			     (return t))
			    (t (setq ,(car newval) (cddr ,(car newval)))
			       ,setter
			       (return t))))))))
      (push (list (car d) (car v)) let-list))))


;;; The built-in DEFSETFs.

(defsetf car %rplaca)
(defsetf cdr %rplacd)
(defsetf caar (x) (v) `(%rplaca (car ,x) ,v))
(defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v))
(defsetf cdar (x) (v) `(%rplacd (car ,x) ,v))
(defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v))
(defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v))
(defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v))
(defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v))
(defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v))
(defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v))
(defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v))
(defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v))
(defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v))
(defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v))
(defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v))
(defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v))
(defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v))
(defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v))
(defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v))
(defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v))
(defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v))
(defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v))
(defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v))
(defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v))
(defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v))
(defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v))
(defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v))
(defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v))
(defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v))

(defsetf first %rplaca)
(defsetf second (x) (v) `(%rplaca (cdr ,x) ,v))
(defsetf third (x) (v) `(%rplaca (cddr ,x) ,v))
(defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v))
(defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v))
(defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v))
(defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v))
(defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v))
(defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v))
(defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v))
(defsetf rest %rplacd)

(defsetf elt %setelt)
(defsetf aref %aset)
(defsetf svref %svset)
(defsetf char %charset)
(defsetf bit %bitset)
(defsetf schar %scharset)
(defsetf sbit %sbitset)
(defsetf symbol-value set)
(defsetf symbol-function %sp-set-definition)
(defsetf get %put)
(defsetf symbol-plist %sp-set-plist)
(defsetf documentation %set-documentation)
(defsetf nth %setnth)
(defsetf %sp-svref %sp-svset)
(defsetf %sp-schar %sp-scharset)
(defsetf %sp-sbit %sp-sbitset)
(defsetf %sp-saref1 %sp-saset1)
(defsetf %sp-cvref %sp-cvset)
(defsetf %sp-cchar %sp-ccharset)
(defsetf %sp-cbit %sp-cbitset)
(defsetf %sp-caref1 %sp-caset1)
(defsetf getf putf)
(defsetf fill-pointer %set-fill-pointer)

(defsetf macro-function (symbol) (def)
  `(%sp-set-definition ,symbol (cons 'macro ,def)))

(defsetf gethash (k h &optional default) (v) 
  `(%puthash ,k ,h ,v))

(defsetf subseq (sequence start &optional (end nil)) (v)
  `(progn (replace ,sequence ,v :start1 ,start :end1 ,end)
	  ,v))


;;; Evil hack invented by the gnomes of Vassar Street.  The function
;;; arg must be constant.  Get a setf method for this function, pretending
;;; that the final (list) arg to apply is just a normal arg.  If the
;;; setting and access forms produced in this way reference this arg at
;;; the end, then just splice the APPLY back onto the front and the right
;;; thing happens.

(define-setf-method apply (function &rest args)
  (if (and (listp function)
	   (= (list-length function) 2)
	   (eq (first function) 'function)
	   (symbolp (second function)))
      (setq function (second function))
      (error
       "Setf of Apply is only defined for function args of form #'symbol."))
  (multiple-value-bind (dummies vals newval setter getter)
    (get-setf-method (cons function args))
    ;; Make sure the place is one that we can handle.
    (unless (and (eq (car (last args)) (car (last vals)))
		 (eq (car (last getter)) (car (last dummies)))
		 (eq (car (last setter)) (car (last dummies))))
	    (error "Apply of ~S not understood as a location for Setf."
		   function))
    (values dummies vals newval
	    `(apply (function ,(car setter)) ,@(cdr setter))
	    `(apply (function ,(car getter)) ,@(cdr setter)))))


(define-setf-method ldb (bytespec place)
  "The first argument is a byte specifier.  The second is any place form
  acceptable to SETF.  Replaces the specified byte of the number in this
  place with bits from the low-order end of the new value."
  (multiple-value-bind (dummies vals newval setter getter)
    (get-setf-method place)
    (let ((btemp (gensym))
	  (gnuval (gensym)))
      (values (cons btemp dummies)
	      (cons bytespec vals)
	      (list gnuval)
	      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
		 ,setter
		 ,gnuval)
	      `(ldb ,btemp ,getter)))))


(define-setf-method mask-field (bytespec place)
  "The first argument is a byte specifier.  The second is any place form
  acceptable to SETF.  Replaces the specified byte of the number in this place
  with bits from the corresponding position in the new value."
  (multiple-value-bind (dummies vals newval setter getter)
    (get-setf-method place)
    (let ((btemp (gensym))
	  (gnuval (gensym)))
      (values (cons btemp dummies)
	      (cons bytespec vals)
	      (list gnuval)
	      `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
		 ,setter
		 ,gnuval)
	      `(mask-field ,btemp ,getter)))))


(define-setf-method char-bit (place bit-name)
  "The first argument is any place form acceptable to SETF.  Replaces the
  specified bit of the character in this place with the new value."
  (multiple-value-bind (dummies vals newval setter getter)
    (get-setf-method place)
    (let ((btemp (gensym))
	  (gnuval (gensym)))
      (values `(,@dummies ,btemp)
	      `(,@vals ,bit-name)
	      (list gnuval)
	      `(let ((,(car newval)
		      (set-char-bit ,getter ,btemp ,gnuval)))
		 ,setter
		 ,gnuval)
	      `(char-bit ,getter ,btemp)))))


(define-setf-method the (type place)
  (multiple-value-bind (dummies vals newval setter getter)
    (get-setf-method place)
      (values dummies
	      vals
	      newval
	      (subst `(the ,type ,(car newval)) (car newval) setter)
	      `(the ,type ,getter))))



;;;; MAP AND FRIENDS

(defmacro mapc (&whole form)
  "Applies fn to successive elements of lists, returns ()."
  (map1 form))

(defmacro mapcar (&whole form)
  "Applies fn to successive elements of list, returns list of results."
  (map1 form))

(defmacro mapcan (&whole form)
  "Applies fn to successive elements of list, returns NCONC of results."
  (map1 form))

(defmacro mapl (&whole form)
  "Applies fn to successive CDRs of list, returns ()."
  (map1 form))

(defmacro maplist (&whole form)
  "Applies fn to successive CDRs of list, returns list of results."
  (map1 form))

(defmacro mapcon (&whole form)
  "Applies fn to successive CDRs of lists, returns NCONC of results."
  (map1 form))

(eval-when (compile load)
(defun map1 (form)
  (prog (fn take-car arglists do-clauses endtest
	    args-to-fn map-tem map-result funcallp)
    (setq fn (cadr form)
	  take-car (memq (car form) '(mapc mapcar mapcan))
	  arglists (cddr form))
    (cond ((atom fn) (setq funcallp t))
	  ((eq (car fn) 'quote)
	   (error "Use /#/' for functional args.")
	   (setq fn (cadr fn)))
	  ((eq (car fn) 'function) (setq fn (cadr fn)))
	  (t (setq funcallp t)))
    (do ((a arglists (cdr a))
	 (v (gensym) (gensym)))
	((atom a)
	 (setq do-clauses (nreverse do-clauses)
	       endtest `(not (and ,@(nreverse endtest)))
	       args-to-fn (nreverse args-to-fn)))
      (push `(,v ,(car a) (cdr ,v)) do-clauses)
      (push v endtest)
      (cond (take-car (push `(car ,v) args-to-fn))
	    (t (push v args-to-fn))))
    (setq fn (cond (funcallp `(funcall ,fn . ,args-to-fn))
		   (t `(,fn . ,args-to-fn))))
    (cond ((memq (car form) '(mapl mapc))
	   (return `(do ,do-clauses
			(,endtest t)
		      ,fn)))
	  ((memq (car form) '(mapcan mapcon))
	   (setq map-tem (gensym)
		 map-result (gensym))
	   (return `(let ((,map-result (list nil)))
		      (do ((,map-tem ,map-result) . ,do-clauses)
			  (,endtest (cdr ,map-result))
			(setq ,map-tem (nconc ,map-tem ,fn))
			(setq ,map-tem (last ,map-tem))))))
	  ((memq (car form) '(mapcar maplist))
	   (setq map-tem (gensym)
		 map-result (gensym))
	   (return `(let ((,map-result (list nil)))
		      (do ((,map-tem ,map-result) . ,do-clauses)
			  (,endtest (cdr ,map-result))
		        (rplacd ,map-tem
				(setq ,map-tem
				      (list ,fn))))))))))
)


;;;; CASE, TYPECASE, & Friends.

(defmacro case (&whole form)
  (let ((kv (gensym)) (clauses nil))
    (do ((c (cddr form) (cdr c)))
	((atom c))
      (cond ((atom (car c))
	     (error "~S -- Bad clause in CASE." (car c)))
	    ((memq (caar c) '(t otherwise))
	     (push `(t ,@(cdar c)) clauses)
	     (return nil))
	    ((null (caar c))
	     (push `((null ,kv) ,@(cdar c)) clauses))
	    ((not (listp (caar c)))
	     ;; Note -- special hack in Maclisp to make chars and other
	     ;; fake types not be LISTP, leaving only true lists.
	     (push `((eql ',(caar c) ,kv) ,@(cdar c)) clauses))
	    (t (push
		`((or ,@(do ((x (caar c) (cdr x))
			     (y nil))
			    ((atom x) (nreverse y))
			  (push `(eql ',(car x) ,kv) y)))
		  ,@(cdar c))
		clauses))))
    `(let ((,kv ,(cadr form))) (cond ,@(nreverse clauses)))))


(defmacro typecase (&whole form)
  (let ((kv (gensym)) (clauses nil))
    (do ((c (cddr form) (cdr c)))
	((atom c))
      (cond ((atom (car c))
	     (error "~S -- Bad clause in CASE." (car c)))
	    ((memq (caar c) '(t otherwise))
	     (push `(t ,@(cdar c)) clauses)
	     (return nil))
	    (t (push `((typep ,kv ',(caar c)) ,@(cdar c)) clauses))))
    `(let ((,kv ,(cadr form))) (cond ,@(nreverse clauses)))))


(defmacro ecase (&whole form)
  (let ((kv (gensym)) (clauses nil))
    (do ((c (cddr form) (cdr c))
	 (keys nil (append (cond ((atom (caar c)) (list (caar c)))
				 (t (caar c)))
			   keys)))
	((atom c) (push `(t (error "Ecase key must be one of ~S" ',keys))
			clauses))
      (cond ((atom (car c))
	     (error ':bad-macro-format
		    "~S -- Bad clause in ECASE." (car c)))
	    ((memq (caar c) '(t otherwise))
	     (error "T or Otherwise clause is not permitted in ECASE."))
	    ((atom (caar c))
	     (push `((eql ,kv ',(caar c)) ,@(cdar c)) clauses))
	    (t (push
		`((or ,@(do ((x (caar c) (cdr x))
			     (y nil))
			    ((atom x) (nreverse y))
			  (push `(eql ,kv ',(car x)) y)))
		  ,@(cdar c))
		clauses))))
    `(let ((,kv ,(cadr form))) (cond ,@(nreverse clauses)))))



(defmacro etypecase (&whole form)
  (let ((kv (gensym)) (clauses nil))
    (do ((c (cddr form) (cdr c))
	 (keys nil (cons (caar c) keys)))
	((atom c)
	 (push
	  `(t (error "Etypecase key must be one of these types: ~S" ',keys))
	  clauses))
      (cond ((atom c) (error "~S -- Bad clause in CASE." (car c)))
	    ((memq (caar c) '(t otherwise))
	     (error "T or Otherwise clause is not permitted in ETYPECASE."))
	    (t (push `((typep ,kv ',(caar c)) ,@(cdar c)) clauses))))
    `(let ((,kv ,(cadr form))) (cond ,@(nreverse clauses)))))


(defmacro with-open-file (bindspec &rest forms)
  "Bindspec is of the form (Stream File-Name . Options).  The file whose name
  is File-Name is opened using the Options and bound to the variable Stream.
  The Forms are executed, and when they terminate, normally or otherwise,
  the file is closed."
  `(let ((,(car bindspec) (open ,@(cdr bindspec))))
     (unwind-protect
      (progn ,@forms)
      (close ,(car bindspec)))))


(defmacro with-open-stream ((var stream) . body)
  (do ((forms body (cdr forms))
       (declarations ()))
      ((not (and (listp (car forms))
		 (eq (caar forms) 'declare)))
       (let ((temp (gensym)))
	 `(let ((,var ,stream)
		,temp)
	    ,@declarations
	    (unwind-protect
	     (setq ,temp (progn ,@forms))
	     (close ,var))
	    ,temp)))))


(defmacro with-input-from-string ((var string &key index start end) . body)
  "Binds the Var to an input stream that returns characters from String and
  executes the body.  See manual for details."
  (do ((forms body (cdr forms))
       (declarations ()))
      ((not (and (listp (car forms))
		 (eq (caar forms) 'declare)))
       (let ((temp (gensym)))
	 `(let ((,var
		 ,(if end
		      `(make-string-input-stream ,string ,(or start 0) ,end)
		      `(make-string-input-stream ,string ,(or start 0))))
		,temp)
	    ,@declarations
	    (unwind-protect
	     (setq ,temp (progn ,@forms))
	     (close ,var)
	     ,@(if index `((setf ,index (stream-input-string-current ,var)))))
	    ,temp)))))


(defmacro with-output-to-string ((var &optional string) . body)
  "Binds the Var to a string output stream that puts characters into String
  and executes the body.  See manual for details."
  (do ((forms body (cdr forms))
       (declarations ()))
      ((not (and (listp (car forms))
		 (eq (caar forms) 'declare)))
       (if string
	   (let ((temp (gensym)))
	     `(let ((,var (make-fill-pointer-output-stream ,string))
		    ,temp)
		,@declarations
		(unwind-protect
		 (setq ,temp (progn ,@forms))
		 (close ,var))
		,temp))
	   `(let ((,var (make-string-output-stream)))
	      ,@declarations
	      (unwind-protect
	       (progn ,@forms)
	       (close ,var))
	      (get-output-stream-string ,var))))))


(defmacro locally (&rest forms)
  "A form providing a container for locally-scoped variables."
  `(let () ,@forms))


(defmacro loop (&rest body)
  "Executes the body repeatedly until the form is exited by a Throw or
  Return.  The body is surrounded by an implicit block with name NIL."
  (let ((tag (gensym)))
    `(block nil (tagbody ,tag ,@body (go ,tag)))))