(FILECREATED " 2-Oct-85 16:05:49" {ERIS}<LISPCORE>LIBRARY>CMLSETF.;4
 4898   

      changes to:  (MACROS DECF) (VARS CMLSETFCOMS)

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


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

(PRETTYCOMPRINT CMLSETFCOMS)

(RPAQQ CMLSETFCOMS
 ((MACROS DEFINE-MODIFY-MACRO INCF DECF) (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: 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))
(DEFMACRO DECF (%%REFERENCE &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." (\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
 )
)
(PUTPROPS CMLSETF COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2524 4655 (NOMV:GET-SETF-METHOD 2534 . 4071) (\INCF.EXPAND 4073 . 4653)))))
STOP