(FILECREATED " 6-Aug-85 18:47:49" {DSK}<LISPFILES>ARRAY>CMLSETF.;1
 5460   

      changes to:  (VARS CMLSETFCOMS)

      previous date: " 1-Aug-85 18:14:47" {ERIS}<LISPCORE>LIBRARY>CMLSETF.;3)


(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT CMLSETFCOMS)

(RPAQQ CMLSETFCOMS
 [(MACROS DEFINE-MODIFY-MACRO INCF)
		    (PROP SETF-INVERSE CAR CDR)
		    (FNS NOMV:GET-SETF-METHOD \INCF.EXPAND)
		    (PROP SETFN ARG)
		    (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
				(NLAMA)
				(NLAML)
				(LAMA SVREF])
(DECLARE: EVAL@COMPILE 
[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))
       [CL:DO ((LL LAMBDA-LIST (CDR LL))
	       (ARG NIL))
	      ((NULL LL))
	      (SETQ ARG (CAR LL))
	      (COND ((EQ ARG (QUOTE &OPTIONAL)))
		    ((EQ ARG (QUOTE &REST))
		     (CL:IF (SYMBOLP (CADR LL))
			    (SETQ REST-ARG (CADR LL))
			    (ERROR "Non-symbol &rest arg in definition of ~S." NAME))
		     (CL:IF (NULL (CDDR LL))
			    (RETURN NIL)
			    (ERROR "Illegal stuff after &rest arg in Define-Modify-Macro.")))
		    ((FMEMB ARG (QUOTE (&KEY &ALLOW-OTHER-KEYS &AUX)))
		     (ERROR "~S not allowed in Define-Modify-Macro lambda list." ARG))
		    ((SYMBOLP ARG)
		     (CL:PUSH ARG OTHER-ARGS))
		    ((AND (CONSP ARG)
			  (SYMBOLP (CAR ARG)))
		     (CL:PUSH (CAR ARG)
			      OTHER-ARGS))
		    (T (ERROR "Illegal stuff in lambda list of Define-Modify-Macro."]
       (SETQ OTHER-ARGS (REVERSE OTHER-ARGS))
       (BQUOTE (DEFMACRO
		 (\, NAME)
		 (%%REFERENCE (\,@ LAMBDA-LIST))
		 (\, DOC-STRING)
		 (MULTIPLE-VALUE-BIND
		   (DUMMIES VALS NEWVAL SETTER GETTER)
		   (GET-SETF-METHOD %%REFERENCE)
		   (CL:DO ((D DUMMIES (CDR D))
			   (V VALS (CDR V))
			   (LET-LIST NIL (CONS (LIST (CAR D)
						     (CAR V))
					       LET-LIST)))
			  ((NULL D)
			   (CL:PUSH [LIST (CAR NEWVAL)
					  (\, (CL:IF REST-ARG (BQUOTE (LIST* (QUOTE (\, FUNCTION))
									     GETTER
									     (\,@ OTHER-ARGS)
									     (\, REST-ARG)))
						     (BQUOTE (LIST (QUOTE (\, FUNCTION))
								   GETTER
								   (\,@ OTHER-ARGS]
				    LET-LIST)
			   (BQUOTE (LET* (\, (NREVERSE LET-LIST))
					 (\, SETTER]
(DEFMACRO INCF (%%REFERENCE &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."
	  (\INCF.EXPAND %%REFERENCE DELTA))
)

(PUTPROPS CAR SETF-INVERSE
 RPLACA)

(PUTPROPS CDR SETF-INVERSE
 RPLACD)
(DEFINEQ

(NOMV:GET-SETF-METHOD

  [CL:LAMBDA (FORM)                                          (* lmm "31-Jul-85 04:31")

    (LET (TEMP)
         (
COND

	   ((
SYMBOLP
 FORM)
	     (LET ((NEW-VAR (
GENSYM
)))
	          (
LIST
 NIL NIL (
LIST
 NEW-VAR)
			(
BQUOTE
 (
SETQ
 (\, FORM)
				  (\, NEW-VAR)))
			FORM)))
	   ((
CL:ATOM
 FORM)
	     (
ERROR
 "~S illegal atomic form for GET-SETF-METHOD." FORM))
	   [[
SETQ
 TEMP (
OR
 (
GET
 (
CAR
 FORM)
				(
QUOTE
 SETF-INVERSE))
			   (
GET
 (
CAR
 FORM)
				(
QUOTE
 SETFN]
	     (LET ((NEW-VAR (
GENSYM
))
		   (
VARS
 NIL)
		   (VALS NIL))
	          (DOLIST (X (
CDR
 FORM))
			  (CL:PUSH (
GENSYM
)
				   VARS)
			  (CL:PUSH X VALS))
	          (
SETQ
 VALS (
REVERSE
 VALS))
	          (
LIST
 VARS VALS (
LIST
 NEW-VAR)
			(
BQUOTE
 ((\, TEMP)
				 (\,@ VARS)
				 (\, NEW-VAR)))
			(
BQUOTE
 ((\, (
CAR
 FORM))
				 (\,@ VARS]
	   ((
SETQ
 TEMP (
GET
 (
CAR
 FORM)
			    (
QUOTE
 SETF-METHOD-EXPANDER)))
	     (VALUES-LIST (
FUNCALL
 TEMP FORM)))
	   ((
AND
 (
BOUNDP
 (
QUOTE
 *IN-THE-COMPILER*))*IN-THE-COMPILER*)
	     (CL:IF (
EQ
 (
SETQ
 TEMP (COMPILER-MACROEXPAND-1 FORM))
			FORM)
		    (
ERROR
 "~S is not a known location specifier for SETF." (
CAR
 FORM))
		    (NOMV:GET-SETF-METHOD
 TEMP)))
	   (T (CL:IF (
EQ
 (
SETQ
 TEMP (
MACROEXPAND-1
 FORM))
			 FORM)
		     (
ERROR
 "~S is not a known location specifier for SETF." (
CAR
 FORM))
		     (NOMV:GET-SETF-METHOD
 TEMP])

(\INCF.EXPAND

  [LAMBDA (%%REFERENCE DELTA)                                (* lmm " 1-Aug-85 13:17")

    (DESTRUCTURING-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
			(NOMV:GET-SETF-METHOD
 %%REFERENCE)
			(CL:DO ((D DUMMIES (
CDR
 D))
				(V VALS (
CDR
 V))
				(LET-LIST NIL (
CONS
 (
LIST
 (
CAR
 D)
							  (
CAR
 V))
						    LET-LIST)))
			       ((
NULL
 D)
				(CL:PUSH (
LIST
 (
CAR
 NEWVAL)
					       (
LIST
 (
QUOTE
 +)
						     GETTER DELTA))
					 LET-LIST)
				(
BQUOTE
 (LET* (\, (
REVERSE
 LET-LIST))
					      (\, SETTER])
)

(PUTPROPS ARG SETFN
 SETARG)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 SVREF)
)
(PRETTYCOMPRINT CMLSETFCOMS)

(RPAQQ CMLSETFCOMS
 [(MACROS DEFINE-MODIFY-MACRO INCF)
		    (PROP SETF-INVERSE CAR CDR)
		    (FNS NOMV:GET-SETF-METHOD \INCF.EXPAND)
		    (PROP SETFN ARG)
		    (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
											  (NLAML)
											  (LAMA])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 )
)
(PUTPROPS CMLSETF COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2632 4763 (NOMV:GET-SETF-METHOD 2642 . 4179) (\INCF.EXPAND 4181 . 4761)))))
STOP