Google
 

Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/macros.clisp
There are no other files named macros.clisp in the archive.
;;; 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.
;;; 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.

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

(in-package 'lisp)

(export '(defvar defparameter defconstant when unless loop setf defsetf
	  psetf shiftf rotatef push pushnew pop incf decf putf remf case
	  typecase with-open-file with-open-stream with-input-from-string
	  with-output-to-string locally etypecase ecase dotimes dolist do*
	  ldb mask-field char-bit 
	  ccase ctypecase get-setf-method get-setf-method-multiple-value
	  define-modify-macro define-setf-method))

;;;; 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 (equalp ,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 (,(car forms) nil ,@(cdr 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) nil ,@forms)))
;;;; DO AND FRIENDS

;20; DO is in the kernel

(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) (tag (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 ,tag
	   (and ,(car endlist)
		(return (progn ,@(cdr endlist))))
		,@body
		(setq ,@(nreverse steps))
		(go ,tag))))))


(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.

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

(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-1 form)) form)
	       (error "~S is not a known location specifier for SETF."
		      (car form))
	       (get-setf-method temp)))
	  (t
	   (if (eq (setq temp (macroexpand-1 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.

(proclaim '(special *macroexpand-hook*))

(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 (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)
	       (remprop ',access-fn 'setf-inverse)
	       (%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
				  ;;; Next form munged and put back SKH 5/26
				  (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) (%sp-putf ,(car newval) ,ind-temp ,val-temp))
	     ,setter
	     ,val-temp))
      (push (list (car d) (car v)) let-list))))

(defun %sp-putf (place indicator value)
   (do* ((local1 place (cddr local1)))
	((atom local1)
	 (list* indicator value place))
     (cond ((atom (cdr local1))
	    (error "Odd length property list in PUTF"))
	   ((eq (car local1) indicator)
	    (rplaca (cdr local1) value)
	    (return place)))))

(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 symbol-plist %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 fill-pointer %set-fill-pointer)


(define-setf-method getf (place prop &optional default)
  (multiple-value-bind (temps values stores set get)
		       (get-setf-method place)
    (let ((newval (gensym))
	  (ptemp (gensym))
	  (def-temp (gensym)))
      (values `(,@temps ,(car stores) ,ptemp ,@(if default `(,def-temp)))
	      `(,@values ,get ,prop ,@(if default `(,default)))
	      `(,newval)
	      `(progn (setq ,(car stores)
			    (%sp-putf ,(car stores) ,ptemp ,newval))
		      ,set
		      ,newval)
	      `(getf ,(car stores) ,ptemp ,@(if default `(,def-temp)))))))

(define-setf-method get (symbol prop &optional default)
  "Get turns into %put. Don't put in the default unless it really is
  supplied and non-nil, so that we can transform into the get
  instruction whenever possible."
  (let ((symbol-temp (gensym))
	(prop-temp (gensym))
	(def-temp (gensym))
	(newval (gensym)))
    (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
	    `(,symbol ,prop ,@(if default `(,default)))
	    (list newval)
	    `(%put ,symbol-temp ,prop-temp ,newval)
	    `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))



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

(define-setf-method gethash (key hashtable &optional default)
  (let ((key-temp (gensym))
	(hashtable-temp (gensym))
	(default-temp (gensym))
	(new-value-temp (gensym)))
    (values
     `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
     `(,key ,hashtable ,@(if default `(,default)))
     `(,new-value-temp)
     `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
     `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))

(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 (car 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.
    (cond ((and (eq (car (last args)) (car (last vals)))
		 (eq (car (last getter)) (car (last dummies)))
		 (eq (car (last setter)) (car (last dummies))))
	   (values dummies vals newval
	    `(apply (function ,(car setter)) ,@(cdr setter))
	    `(apply (function ,(car getter)) ,@(cdr setter))))
	  ((and (eq (car (last args)) (car (last vals)))
	        (eq (car (last getter)) (car (last dummies)))
	        (eq (penult setter) (car (last dummies))))
	   (values dummies vals newval
	    `(apply-but-last (function ,(car setter)) ,@(cdr setter))
	    `(apply (function ,(car getter)) ,@(cdr setter))))
	  (t (error "Apply of ~S not understood as a location for Setf."
		   function)))))

(defun penult (x)
  (if (null (cddr x))
      (car x)
      (penult (cdr x))))

(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  Moved to LIST.CLISP  6-sep-85  DKS
;;;; CASE, TYPECASE, & Friends.


;;; Case-Body  --  Internal
;;;
;;;    This function is used to implement all of the case-like macros.
;;;

(eval-when (compile load eval)
(defun case-body (name keyform cases multi-p test error-string proceed-string)
  (let ((kv (gensym)) (AGAIN (gensym)) (BLOCK (gensym))
	(clauses ())
	(keys ()))
    (dolist (case cases)
      (cond ((atom case)
	     (error "~S -- Bad clause in ~S." case name))
	    ((memq (car case) '(t otherwise))
	     (if error-string
		 (error "No default clause allowed in ~S: ~S" name case)
		 (push `(t nil ,@(cdr case)) clauses)))
	    ((and multi-p (listp (car case)))
	     (setq keys (append (car case) keys))
	     (push `((member ,kv ',(car case) :test #',test)
		     nil ,@(cdr case))
		   clauses))
	    (t
	     (push (car case) keys)
	     (push `((,test ,kv ',(car case)) nil ,@(cdr case)) clauses))))
    (if proceed-string
	`(let ((,kv ,keyform))
	   (block ,BLOCK
	     (tagbody
	      ,AGAIN
	      (return-from
	       ,BLOCK
	       (cond ,@(nreverse clauses)
		     (t
		      (cerror proceed-string error-string ,kv ',keys)
		      (write-string "Expression for new key value: "
				    *query-io*)
		      (setq ,kv (setf ,keyform (eval (read *query-io*))))
		      (go ,AGAIN)))))))
	`(let ((,kv ,keyform))
	   (cond ,@(nreverse clauses)
		 ,@(if error-string
		       `((t (error ,error-string ,kv ',keys)))))))))

); Eval-When (Compile Load Eval)

(defmacro case (keyform &body cases)
  "CASE Keyform {({(Key*) | Key} Form*)}*
  Evaluates the Forms in the first clause with a Key EQL to the value of
  Keyform.  If a singleton key is T then the clause is a default clause."
  (case-body 'case keyform cases t 'eql nil nil))

(defmacro ccase (keyform &body cases)
  "CCASE Keyform {({(Key*) | Key} Form*)}*
  Evaluates the Forms in the first clause with a Key EQL to the value of
  Keyform.  If none of the keys matches then a correctable error is
  signalled."
  (case-body 'ccase keyform cases t 'eql
	     "CCASE key ~S is not any of the following:~% ~S"
	     "prompt for a new key value to use in its place."))

(defmacro ecase (keyform &body cases)
  "ECASE Keyform {({(Key*) | Key} Form*)}*
  Evaluates the Forms in the first clause with a Key EQL to the value of
  Keyform.  If none of the keys matches then an error is signalled."
  (case-body 'ecase keyform cases t 'eql
	     "ECASE key ~S is not any of the following:~% ~S"
	     nil))

(defmacro typecase (keyform &body cases)
  "TYPECASE Keyform {(Type Form*)}*
  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
  is true."
  (case-body 'typecase keyform cases nil 'typep nil nil))

(defmacro ctypecase (keyform &body cases)
  "CTYPECASE Keyform {(Type Form*)}*
  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
  is true.  If no form is satisfied then a correctable error is signalled."
  (case-body 'ctypecase keyform cases nil 'typep
	     "CTYPECASE key ~S is not of any of the following types:~% ~S."
	     "prompt for a new object to use in its place."))

(defmacro etypecase (keyform &body cases)
  "ETYPECASE Keyform {(Type Form*)}*
  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
  is true.  If no form is satisfied then an error is signalled."
  (case-body 'etypecase keyform cases nil 'typep
	     "ETYPECASE key ~S is not of any of the following types:~% ~S."
	     nil))
(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)
  "The form STREAM is evaluated and must produce a stream.  The variable VAR
  is bound with the stream as its values.  The body is executed (as an implicit
  Progn), and when it terminates, normally or otherwise, the stream is closed."
  (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))
	     ,@(if index `((setf ,index (file-position ,var))))
	     (close ,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	;[Victor] Do get-o-s-s BEFORE closing!
		      (get-output-stream-string ,var))
	       (close ,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)))))