(FILECREATED "12-Oct-86 16:30:54" {ERIS}<LISPCORE>SOURCES>CMLSETF.;6 39126
changes to: (FUNCTIONS DEFINE-SETF-METHOD DEFSETF)
previous date: "10-Oct-86 18:05:43" {ERIS}<LISPCORE>SOURCES>CMLSETF.;5)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLSETFCOMS)
(RPAQQ CMLSETFCOMS
((VARS *DEFAULT-DEFAULT*)
(FNS GET-SETF-METHOD GET-SETF-METHOD-MULTIPLE-VALUE GET-SIMPLE-SETF-METHOD)
(DEFINE-TYPES SETFS)
(FUNCTIONS DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD DEFSETF)
(FUNCTIONS INCF DECF)
(FUNCTIONS SETF PSETF SHIFTF ROTATEF CL:PUSH CL:PUSHNEW CL:POP REMF)
(SETFS CAR CDR CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR
CADDR CADR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR
CDDDDR CDDDR CDDR CL:FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH
REST NTHCDR CL:NTH CL:GETHASH GETF CL:APPLY LDB MASK-FIELD CHAR-BIT THE)
(SETFS \GETBASEPTR)
(PROP FILETYPE CMLSETF)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
GET-SETF-METHOD-MULTIPLE-VALUE
GET-SETF-METHOD)))))
(RPAQQ *DEFAULT-DEFAULT* NIL)
(DEFINEQ
(GET-SETF-METHOD
(CL:LAMBDA (FORM ENVIRONMENT) (* Pavel " 9-Sep-86 18:19")
(LET (TEMP)
(COND
((SYMBOLP FORM) (* "The simple variable case;"
"turns into a normal SETQ.")
(LET ((NEW-VAR (GENSYM)))
(VALUES NIL NIL (LIST NEW-VAR)
(BQUOTE (SETQ (\, FORM)
(\, NEW-VAR)))
FORM)))
((CL:ATOM FORM)
(CL:ERROR "~S illegal atomic form for GET-SETF-METHOD." FORM))
((SETQ TEMP (OR (GET (CAR FORM)
(QUOTE SETF-INVERSE))
(GET (CAR FORM)
(QUOTE SETFN)))) (* "Interlisp's SETFN's are exactly"
"like SETF-INVERSE's.")
(GET-SIMPLE-SETF-METHOD FORM TEMP))
((SETQ TEMP (GET (CAR FORM)
(QUOTE SETF-METHOD-EXPANDER)))
(FUNCALL TEMP FORM ENVIRONMENT))
((SETQ TEMP (GET (CAR FORM)
(QUOTE CROPS))) (* "Interlisp hack for representing"
"the C{A|D}*R functions")
(GET-SETF-METHOD (BQUOTE ((\, (PACK* (QUOTE C)
(CAR (LAST TEMP))
(QUOTE R)))
((\, (PACK* (QUOTE C)
(SUBSTRING (CAR FORM)
3 -1)))
(\, (CADR FORM)))))))
(T (CL:IF (EQ (SETQ TEMP (MACROEXPAND-1 FORM ENVIRONMENT))
FORM)
(CL:ERROR "~S is not a known location specifier for SETF." (CAR FORM))
(GET-SETF-METHOD TEMP ENVIRONMENT)))))))
(GET-SETF-METHOD-MULTIPLE-VALUE
(CL:LAMBDA (FORM &OPTIONAL ENVIRONMENT) (* lmm " 6-May-86 09:00")
(GET-SETF-METHOD FORM ENVIRONMENT)))
(GET-SIMPLE-SETF-METHOD
[LAMBDA (FORM SETF-INVERSE) (* lmm " 7-May-86 23:33")
(LET ((NEW-VAR (GENSYM))
(VARS NIL)
(VALS NIL))
(DOLIST (X (CDR FORM))
(CL:PUSH (GENSYM)
VARS)
(CL:PUSH X VALS))
(SETQ VALS (NREVERSE VALS))
(VALUES VARS VALS (LIST NEW-VAR)
(BQUOTE ((\, SETF-INVERSE)
(\,@ VARS)
(\, NEW-VAR)))
(BQUOTE ((\, (CAR FORM))
(\,@ VARS])
)
(DEF-DEFINE-TYPE SETFS "Common Lisp SETF definitions" )
(DEFDEFINER DEFINE-MODIFY-MACRO
FUNCTIONS
(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))
(SETQ REST-ARG (CADR LL))
(RETURN NIL))
((SYMBOLP ARG)
(CL:PUSH ARG OTHER-ARGS))
(T (CL:PUSH (CAR ARG)
OTHER-ARGS))))
(SETQ OTHER-ARGS (REVERSE OTHER-ARGS))
(BQUOTE (DEFMACRO (\, NAME) ($$MODIFY-MACRO-FORM (\,@ LAMBDA-LIST)
&ENVIRONMENT $$MODIFY-MACRO-ENVIRONMENT)
(\, DOC-STRING)
(MULTIPLE-VALUE-BIND
(DUMMY-VARIABLES VALUES NEW-VALUE SETTER GETTER)
(GET-SETF-METHOD $$MODIFY-MACRO-FORM $$MODIFY-MACRO-ENVIRONMENT)
(CL:DO ((D DUMMY-VARIABLES (CDR D))
(V VALUES (CDR V))
(LET-LIST NIL (CONS (LIST (CAR D)
(CAR V))
LET-LIST)))
((NULL D)
(CL:PUSH (LIST (CAR NEW-VALUE)
(\, (CL:IF REST-ARG (BQUOTE (LIST* (QUOTE (\, FUNCTION))
GETTER
(\,@ OTHER-ARGS)
(\, REST-ARG)))
(BQUOTE (LIST (QUOTE (\, FUNCTION))
GETTER
(\,@ OTHER-ARGS))))))
LET-LIST)
(BQUOTE (LET* (\, (REVERSE LET-LIST))
(\, SETTER)))))))
)))
(DEFDEFINER DEFINE-SETF-METHOD
SETFS (NAME LAMBDA-LIST &ENVIRONMENT ENV &BODY BODY)
(LET ((WHOLE (XCL:PACK (LIST "whole-" NAME)
(SYMBOL-PACKAGE NAME)))
(ENVIRONMENT (XCL:PACK (LIST "env-" NAME)
(SYMBOL-PACKAGE NAME)))
(EXPANDER (XCL:PACK (LIST "setf-expander-" NAME)
(SYMBOL-PACKAGE NAME))))
(MULTIPLE-VALUE-BIND
(NEWBODY LOCAL-DECS DOC)
(PARSE-DEFMACRO LAMBDA-LIST WHOLE BODY NAME ENV :ENVIRONMENT ENVIRONMENT :ERROR-STRING
"Setf expander for ~S cannot be called with ~S args.")
(BQUOTE (EVAL-WHEN (EVAL CL:COMPILE LOAD)
(REMPROP (QUOTE (\, NAME))
(QUOTE SETF-INVERSE))
(REMPROP (QUOTE (\, NAME))
(QUOTE SETFN))
(DEFUN (\, EXPANDER) ((\, WHOLE)
(\, ENVIRONMENT)) (\,@ LOCAL-DECS)
(\, NEWBODY))
(PUTPROP (QUOTE (\, NAME))
(QUOTE SETF-METHOD-EXPANDER)
(QUOTE (\, EXPANDER)))
(\,@ (AND DOC (BQUOTE ((SETF (DOCUMENTATION (QUOTE (\, NAME))
(QUOTE SETF))
(\, DOC)))))))))))
(DEFDEFINER DEFSETF
SETFS
(NAME &REST REST &ENVIRONMENT ENV)
"Associates a SETF update function or macro with the specified access function or macro"
(COND
((CL:ATOM (CAR REST)) (* ; "The short form:")
(* ; "(defsetf access-fn update-fn [doc])")
(LET ((UPDATE-FN (CAR REST))
(DOC (CADR REST)))
(BQUOTE (PROGN (EVAL-WHEN (LOAD CL:COMPILE EVAL)
(REMPROP (QUOTE (\, NAME))
(QUOTE SETF-METHOD-EXPANDER))
(PUTPROPS (\, NAME)
SETF-INVERSE
(\, UPDATE-FN)))
(\,@ (AND DOC (BQUOTE ((SETF (DOCUMENTATION (QUOTE (\, NAME))
(QUOTE SETF))
(\, DOC))))))))))
((AND (CL:LISTP (CAR REST))
(CDR REST)
(CL:LISTP (CADR REST))) (* ; "The complex form:")
(* ;
"(defsetf access-fn args (store-var) {decl | doc}* {form}*)")
(DESTRUCTURING-BIND
(ARG-LIST (STORE-VAR . OTHERS)
&BODY BODY)
REST
(CL:IF OTHERS (CERROR "Ignore the extra items in the list."
"Currently only one new-value variable is allowed in DEFSETF."))
(LET ((WHOLE-VAR (XCL:PACK (LIST NAME "-setf-form")
(SYMBOL-PACKAGE NAME)))
(EXPANDER (XCL:PACK (LIST NAME "-setf-expander")
(SYMBOL-PACKAGE NAME))))
(MULTIPLE-VALUE-BIND
(CODE DECLS DOC)
(PARSE-DEFMACRO ARG-LIST WHOLE-VAR BODY NAME ENV)
(BQUOTE (PROGN (EVAL-WHEN (EVAL CL:COMPILE LOAD)
(REMPROP (QUOTE (\, NAME))
(QUOTE SETF-INVERSE))
(SETF (SYMBOL-FUNCTION (QUOTE (\, EXPANDER)))
(FUNCTION (LAMBDA (ACCESS-FORM)
(LET* ((DUMMIES (MAPCAR (CDR ACCESS-FORM)
(FUNCTION (LAMBDA (X)
(GENSYM)))))
((\, WHOLE-VAR)
(CONS (CAR ACCESS-FORM)
DUMMIES))
((\, STORE-VAR)
(GENSYM)))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST (\, STORE-VAR))
(\, CODE)
(\, WHOLE-VAR))))))
(PUTPROPS (\, NAME)
SETF-METHOD-EXPANDER
(\, EXPANDER)))
(\,@ (AND DOC (BQUOTE ((SETF (DOCUMENTATION (QUOTE (\, NAME))
(QUOTE SETF))
(\, DOC))))))))))))
(T (CL:ERROR "Ill-formed DEFSETF for ~S." NAME))))
(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 SETF (PLACE NEWVALUE &REST OTHERS &ENVIRONMENT ENV &AUX TEMP)
(* * "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 ((EXP (COND
((SYMBOLP PLACE)
(BQUOTE (SETQ (\, PLACE)
(\, NEWVALUE))))
((AND (SYMBOLP (CAR PLACE))
(SETQ TEMP (OR (GET (CAR PLACE)
(QUOTE SETF-INVERSE))
(GET (CAR PLACE)
(QUOTE SETFN)))))
(BQUOTE ((\, TEMP)
(\,@ (CDR PLACE))
(\, NEWVALUE))))
(T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER)
(GET-SETF-METHOD PLACE ENV)
(BQUOTE (LET* (,@ (for D in DUMMIES as V in VALS
collect (LIST D V))
(, (CAR NEWVALS)
, NEWVALUE))
(\, SETTER)))))))
TEMP)
(COND
(OTHERS (BQUOTE (PROGN (\, EXP)
(SETF \, OTHERS))))
(T EXP))))
(DEFMACRO PSETF (&REST ARGS &ENVIRONMENT ENV) "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." (CL:DO ((A ARGS (CDDR A))
(LET-LIST NIL)
(SETF-LIST NIL))
((CL:ATOM A)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\,@ (NREVERSE SETF-LIST))
NIL)))
(CL:IF (CL:ATOM (CDR A))
(CL:ERROR "Odd number of args to PSETF."))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD (CAR A)
ENV)
(DECLARE (IGNORE GETTER))
(CL:DO* ((D DUMMIES (CDR D))
(V VALS (CDR V)))
((NULL D))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST))
(CL:PUSH (LIST (CAR NEWVAL)
(CADR A))
LET-LIST)
(CL:PUSH SETTER SETF-LIST))))
(DEFMACRO SHIFTF (&REST ARGS &ENVIRONMENT ENV) "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 is not assigned to. SHIFTF returns the value of the first place before the assignments are made."
(COND
((NULL ARGS)
NIL)
((NULL (CDR ARGS))
(CAR ARGS))
(T (CL:DO ((A ARGS (CDR A))
(LET-LIST NIL)
(SETF-LIST NIL)
(RESULT (GENSYM))
(NEXT-VAR NIL))
((CL:ATOM (CDR A))
(DSUBST (CAR A)
NEXT-VAR
(CAR SETF-LIST))
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\,@ (NREVERSE SETF-LIST))
(\, RESULT))))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD (CAR A)
ENV)
(CL:DO ((D DUMMIES (CDR D))
(V VALS (CDR V)))
((NULL D))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST))
(CL:UNLESS NEXT-VAR (CL:SETQ NEXT-VAR RESULT))
(CL:PUSH (LIST NEXT-VAR GETTER)
LET-LIST)
(CL:PUSH SETTER SETF-LIST)
(SETQ NEXT-VAR (CAR NEWVAL)))))))
(DEFMACRO ROTATEF (&REST ARGS &ENVIRONMENT ENV) "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))
(BQUOTE (PROGN (\, (CAR ARGS))
NIL)))
(T (CL:DO ((A ARGS (CDR A))
(LET-LIST NIL)
(SETF-LIST NIL)
(NEXT-VAR NIL)
(FIX-ME NIL))
((CL:ATOM A)
(RPLACA FIX-ME NEXT-VAR)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\,@ (NREVERSE SETF-LIST))
NIL)))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD (CAR A)
ENV)
(CL:DO ((D DUMMIES (CDR D))
(V VALS (CDR V)))
((NULL D))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST))
(CL: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. *)
(CL:UNLESS FIX-ME (SETQ FIX-ME (CAR LET-LIST)))
(CL:PUSH SETTER SETF-LIST)
(SETQ NEXT-VAR (CAR NEWVAL)))))))
(DEFMACRO CL:PUSH (OBJ PLACE &ENVIRONMENT ENV) "Takes an object and a location holding a list. Conses the object onto
the list, returning the modified list."
(CL:IF (SYMBOLP PLACE)
(BQUOTE (SETQ (\, PLACE)
(CONS (\, OBJ)
(\, PLACE))))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD PLACE ENV)
(CL:DO* ((D DUMMIES (CDR D))
(V VALS (CDR V))
(LET-LIST NIL))
((NULL D)
(CL:PUSH (LIST (CAR NEWVAL)
(BQUOTE (CONS (\, OBJ)
(\, GETTER))))
LET-LIST)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\, SETTER))))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST)))))
(DEFMACRO CL:PUSHNEW (OBJ PLACE &REST KEYS &ENVIRONMENT ENV) "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."
(CL:IF (SYMBOLP PLACE)
(BQUOTE (SETQ (\, PLACE)
(ADJOIN (\, OBJ)
(\, PLACE)
(\,@ KEYS))))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD PLACE ENV)
(CL:DO* ((D DUMMIES (CDR D))
(V VALS (CDR V))
(LET-LIST NIL))
((NULL D)
(CL:PUSH (LIST (CAR NEWVAL)
(BQUOTE (ADJOIN (\, OBJ)
(\, GETTER)
(\,@ KEYS))))
LET-LIST)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\, SETTER))))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST)))))
(DEFMACRO CL:POP (PLACE &ENVIRONMENT ENV) "The argument is a location holding a list. Pops one item off the front
of the list and returns it."
(CL:IF (SYMBOLP PLACE)
(BQUOTE (PROG1 (CAR (\, PLACE))
(SETQ (\, PLACE)
(CDR (\, PLACE)))))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD PLACE ENV)
(CL:DO* ((D DUMMIES (CDR D))
(V VALS (CDR V))
(LET-LIST NIL))
((NULL D)
(CL:PUSH (LIST (CAR NEWVAL)
GETTER)
LET-LIST)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(PROG1 (CAR (\, (CAR NEWVAL)))
(SETQ (\, (CAR NEWVAL))
(CDR (\, (CAR NEWVAL))))
(\, SETTER)))))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST)))))
(DEFMACRO REMF (PLACE INDICATOR &ENVIRONMENT ENV) "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 ENV)
(CL:DO* ((D DUMMIES (CDR D))
(V VALS (CDR V))
(LET-LIST NIL)
(IND-TEMP (GENSYM))
(LOCAL1 (GENSYM))
(LOCAL2 (GENSYM)))
((NULL D)
(CL:PUSH (LIST (CAR NEWVAL)
GETTER)
LET-LIST)
(CL:PUSH (LIST IND-TEMP INDICATOR)
LET-LIST)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(CL:DO (((\, LOCAL1)
(\, (CAR NEWVAL))
(CDDR (\, LOCAL1)))
((\, LOCAL2)
NIL
(\, LOCAL1)))
((CL:ATOM (\, LOCAL1))
NIL)
(COND
((CL:ATOM (CDR (\, LOCAL1)))
(CL:ERROR "Odd-length property list in REMF."))
((EQ (CAR (\, LOCAL1))
(\, IND-TEMP))
(COND
((\, LOCAL2)
(RPLACD (CDR (\, LOCAL2))
(CDDR (\, LOCAL1)))
(RETURN T))
(T (CL:SETQ (\, (CAR NEWVAL))
(CDDR (\, (CAR NEWVAL))))
(\, SETTER)
(RETURN T)))))))))
(CL:PUSH (LIST (CAR D)
(CAR V))
LET-LIST))))
(DEFSETF CAR (X) (V)
(BQUOTE (CAR (RPLACA (\, X)
(\, V)))))
(DEFSETF CDR (X) (V)
(BQUOTE (CDR (RPLACD (\, X)
(\, V)))))
(DEFSETF CAAAAR (X) (V)
(BQUOTE (CAR (RPLACA (CAAAR (\, X))
(\, V)))))
(DEFSETF CAAADR (X) (V)
(BQUOTE (CAR (RPLACA (CAADR (\, X))
(\, V)))))
(DEFSETF CAAAR (X) (V)
(BQUOTE (CAR (RPLACA (CAAR (\, X))
(\, V)))))
(DEFSETF CAADAR (X) (V)
(BQUOTE (CAR (RPLACA (CADAR (\, X))
(\, V)))))
(DEFSETF CAADDR (X) (V)
(BQUOTE (CAR (RPLACA (CADDR (\, X))
(\, V)))))
(DEFSETF CAADR (X) (V)
(BQUOTE (CAR (RPLACA (CADR (\, X))
(\, V)))))
(DEFSETF CAAR (X) (V)
(BQUOTE (CAR (RPLACA (CAR (\, X))
(\, V)))))
(DEFSETF CADAAR (X) (V)
(BQUOTE (CAR (RPLACA (CDAAR (\, X))
(\, V)))))
(DEFSETF CADADR (X) (V)
(BQUOTE (CAR (RPLACA (CDADR (\, X))
(\, V)))))
(DEFSETF CADAR (X) (V)
(BQUOTE (CAR (RPLACA (CDAR (\, X))
(\, V)))))
(DEFSETF CADDAR (X) (V)
(BQUOTE (CAR (RPLACA (CDDAR (\, X))
(\, V)))))
(DEFSETF CADDDR (X) (V)
(BQUOTE (CAR (RPLACA (CDDDR (\, X))
(\, V)))))
(DEFSETF CADDR (X) (V)
(BQUOTE (CAR (RPLACA (CDDR (\, X))
(\, V)))))
(DEFSETF CADR (X) (V)
(BQUOTE (CAR (RPLACA (CDR (\, X))
(\, V)))))
(DEFSETF CDAAAR (X) (V)
(BQUOTE (CDR (RPLACD (CAAAR (\, X))
(\, V)))))
(DEFSETF CDAADR (X) (V)
(BQUOTE (CDR (RPLACD (CAADR (\, X))
(\, V)))))
(DEFSETF CDAAR (X) (V)
(BQUOTE (CDR (RPLACD (CAAR (\, X))
(\, V)))))
(DEFSETF CDADAR (X) (V)
(BQUOTE (CDR (RPLACD (CADAR (\, X))
(\, V)))))
(DEFSETF CDADDR (X) (V)
(BQUOTE (CDR (RPLACD (CADDR (\, X))
(\, V)))))
(DEFSETF CDADR (X) (V)
(BQUOTE (CDR (RPLACD (CADR (\, X))
(\, V)))))
(DEFSETF CDAR (X) (V)
(BQUOTE (CDR (RPLACD (CAR (\, X))
(\, V)))))
(DEFSETF CDDAAR (X) (V)
(BQUOTE (CDR (RPLACD (CDAAR (\, X))
(\, V)))))
(DEFSETF CDDADR (X) (V)
(BQUOTE (CDR (RPLACD (CDADR (\, X))
(\, V)))))
(DEFSETF CDDAR (X) (V)
(BQUOTE (CDR (RPLACD (CDAR (\, X))
(\, V)))))
(DEFSETF CDDDAR (X) (V)
(BQUOTE (CDR (RPLACD (CDDAR (\, X))
(\, V)))))
(DEFSETF CDDDDR (X) (V)
(BQUOTE (CDR (RPLACD (CDDDR (\, X))
(\, V)))))
(DEFSETF CDDDR (X) (V)
(BQUOTE (CDR (RPLACD (CDDR (\, X))
(\, V)))))
(DEFSETF CDDR (X) (V)
(BQUOTE (CDR (RPLACD (CDR (\, X))
(\, V)))))
(DEFSETF CL:FIRST (X) (V)
(BQUOTE (CAR (RPLACA (\, X)
(\, V)))))
(DEFSETF SECOND (X) (V)
(BQUOTE (CAR (RPLACA (CDR (\, X))
(\, V)))))
(DEFSETF THIRD (X) (V)
(BQUOTE (CAR (RPLACA (CDDR (\, X))
(\, V)))))
(DEFSETF FOURTH (X) (V)
(BQUOTE (CAR (RPLACA (CDDDR (\, X))
(\, V)))))
(DEFSETF FIFTH (X) (V)
(BQUOTE (CAR (RPLACA (CDDDDR (\, X))
(\, V)))))
(DEFSETF SIXTH (X) (V)
(BQUOTE (CAR (RPLACA (CDR (CDDDDR (\, X)))
(\, V)))))
(DEFSETF SEVENTH (X) (V)
(BQUOTE (CAR (RPLACA (CDDR (CDDDDR (\, X)))
(\, V)))))
(DEFSETF EIGHTH (X) (V)
(BQUOTE (CAR (RPLACA (CDDDR (CDDDDR (\, X)))
(\, V)))))
(DEFSETF NINTH (X) (V)
(BQUOTE (CAR (RPLACA (CDDDDR (CDDDDR (\, X)))
(\, V)))))
(DEFSETF TENTH (X) (V)
(BQUOTE (CAR (RPLACA (CDR (CDDDDR (CDDDDR (\, X))))
(\, V)))))
(DEFSETF REST (X) (V)
(BQUOTE (CDR (RPLACD (\, X)
(\, V)))))
(DEFSETF NTHCDR (N LIST) (NEWVAL)
(BQUOTE (CDR (RPLACD (NTHCDR (1- (\, N))
(\, LIST))
(\, NEWVAL)))))
(DEFSETF CL:NTH %%SETNTH)
(DEFINE-SETF-METHOD CL:GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT)
(LET ((KEY-TEMP (GENSYM))
(HASHTABLE-TEMP (GENSYM))
(DEFAULT-TEMP (GENSYM))
(NEW-VALUE-TEMP (GENSYM)))
(VALUES (BQUOTE ((\, KEY-TEMP)
(\, HASHTABLE-TEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEFAULT-TEMP)))))))
(BQUOTE ((\, KEY)
(\, HASHTABLE)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEFAULT)))))))
(BQUOTE ((\, NEW-VALUE-TEMP)))
(BQUOTE (CL:PUTHASH (\, KEY-TEMP)
(\, HASHTABLE-TEMP)
(\, NEW-VALUE-TEMP)))
(BQUOTE (CL:GETHASH (\, KEY-TEMP)
(\, HASHTABLE-TEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEFAULT-TEMP))))))))))
(DEFINE-SETF-METHOD GETF (PLACE PROP &OPTIONAL DEFAULT &ENVIRONMENT ENV)
(MULTIPLE-VALUE-BIND
(TEMPS VALUES STORES SET GET)
(GET-SETF-METHOD PLACE ENV)
(LET ((NEWVAL (GENSYM))
(PTEMP (GENSYM))
(DEF-TEMP (GENSYM)))
(VALUES (BQUOTE ((\,@ TEMPS)
(\, (CAR STORES))
(\, PTEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEF-TEMP)))))))
(BQUOTE ((\,@ VALUES)
(\, GET)
(\, PROP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEFAULT)))))))
(BQUOTE ((\, NEWVAL)))
(BQUOTE (COND
((NULL (\, (CAR STORES)))
(LET* (\, (FOR VAR IN (APPEND TEMPS STORES) AS VAL
IN (APPEND VALUES (BQUOTE ((LIST (\, PTEMP)
(\, NEWVAL)))))
COLLECT (LIST VAR VAL)))
(\, SET))
(\, NEWVAL))
(T (LISTPUT (\, (CAR STORES))
(\, PTEMP)
(\, NEWVAL)))))
(BQUOTE (GETF (\, (CAR STORES))
(\, PTEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEF-TEMP)))))))))))
(DEFINE-SETF-METHOD CL:APPLY (FUNCTION &REST ARGS &ENVIRONMENT ENV)
(CL:IF (AND (LISTP FUNCTION)
(= (LIST-LENGTH FUNCTION)
2)
(MEMBER (CL:FIRST FUNCTION)
(QUOTE (FUNCTION CL:FUNCTION QUOTE)))
(SYMBOLP (SECOND FUNCTION)))
(SETQ FUNCTION (SECOND FUNCTION))
(CL: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)
ENV) (* Make sure the place is one that we
can handle. *)
(CL:UNLESS (AND (EQ (CAR (LAST ARGS))
(CAR (LAST VALS)))
(EQ (CAR (LAST GETTER))
(CAR (LAST DUMMIES)))
(EQ (CAR (LAST SETTER))
(CAR (LAST DUMMIES))))
(CL:ERROR "Apply of ~S not understood as a location for Setf." FUNCTION))
(VALUES DUMMIES VALS NEWVAL (BQUOTE (CL:APPLY (FUNCTION (\, (CAR SETTER)))
(\,@ (CDR SETTER))))
(BQUOTE (CL:APPLY (FUNCTION (\, (CAR GETTER)))
(\,@ (CDR SETTER)))))))
(DEFINE-SETF-METHOD LDB (BYTESPEC PLACE &ENVIRONMENT ENV) "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 ENV)
(LET ((BTEMP (GENSYM))
(GNUVAL (GENSYM)))
(VALUES (CONS BTEMP DUMMIES)
(CONS BYTESPEC VALS)
(LIST GNUVAL)
(BQUOTE (LET (((\, (CAR NEWVAL))
(DPB (\, GNUVAL)
(\, BTEMP)
(\, GETTER))))
(\, SETTER)
(\, GNUVAL)))
(BQUOTE (LDB (\, BTEMP)
(\, GETTER)))))))
(DEFINE-SETF-METHOD MASK-FIELD (BYTESPEC PLACE &ENVIRONMENT ENV) "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)
(BQUOTE (LET (((\, (CAR NEWVAL))
(DEPOSIT-FIELD (\, GNUVAL)
(\, BTEMP)
(\, GETTER))))
(\, SETTER)
(\, GNUVAL)))
(BQUOTE (MASK-FIELD (\, BTEMP)
(\, GETTER)))))))
(DEFINE-SETF-METHOD CHAR-BIT (PLACE BIT-NAME &ENVIRONMENT ENV) "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 ENV)
(LET ((BTEMP (GENSYM))
(GNUVAL (GENSYM)))
(VALUES (BQUOTE ((\,@ DUMMIES)
(\, BTEMP)))
(BQUOTE ((\,@ VALS)
(\, BIT-NAME)))
(LIST GNUVAL)
(BQUOTE (LET (((\, (CAR NEWVAL))
(SET-CHAR-BIT (\, GETTER)
(\, BTEMP)
(\, GNUVAL))))
(\, SETTER)
(\, GNUVAL)))
(BQUOTE (CHAR-BIT (\, GETTER)
(\, BTEMP)))))))
(DEFINE-SETF-METHOD THE (TYPE PLACE &ENVIRONMENT ENV)
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD PLACE ENV)
(VALUES DUMMIES VALS NEWVAL (CL:SUBST (BQUOTE (THE (\, TYPE)
(\, (CAR NEWVAL))))
(CAR NEWVAL)
SETTER)
(BQUOTE (THE (\, TYPE)
(\, GETTER))))))
(DEFSETF \GETBASEPTR \PUTBASEPTR)
(PUTPROPS CMLSETF FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA GET-SETF-METHOD-MULTIPLE-VALUE GET-SETF-METHOD)
)
(PUTPROPS CMLSETF COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1615 4714 (GET-SETF-METHOD 1625 . 3934) (GET-SETF-METHOD-MULTIPLE-VALUE 3936 . 4111) (
GET-SIMPLE-SETF-METHOD 4113 . 4712)))))
STOP