(FILECREATED " 1-Aug-85 18:14:47" {ERIS}<LISPCORE>LIBRARY>CMLSETF.;3
 4405   

      changes to:  (VARS CMLSETFCOMS) (PROPS (ARG SETFN) (CDR SETF-INVERSE) (CAR SETF-INVERSE)) (
MACROS INCF DEFINE-MODIFY-MACRO) (FNS \INCF.EXPAND SVREF NOMV:GET-SETF-METHOD)

      previous date: "31-Jul-85 04:48:54" {ERIS}<LISPCORE>LIBRARY>CMLSETF.;1)


(* 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 SVREF \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)))))))

(SVREF

(CL:LAMBDA (ARRAY &REST SUBSCRIPTS) (* lmm "31-Jul-85 04:14") (if (STRINGP ARRAY) then (INT-CHAR (
NTHCHARCODE ARRAY (ADD1 (CAR SUBSCRIPTS)))) else (APPLY (QUOTE XAREF) (CONS ARRAY SUBSCRIPTS)))))

(\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)
)
(PUTPROPS CMLSETF COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2432 4157 (NOMV:GET-SETF-METHOD 2442 . 3543) (SVREF 3545 . 3752) (\INCF.EXPAND 3754 . 
4155)))))
STOP