(FILECREATED " 1-Sep-85 21:06:10" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;12 65158
changes to: (MACROS SETF)
(VARS CMLMACROSCOMS)
(PROPS (SCHAR SETF-INVERSE))
previous date: "31-Aug-85 20:24:09" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;9)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLMACROSCOMS)
(RPAQQ CMLMACROSCOMS ((* * Mainly SETF and friends in sction 7.2. The Rutgers SETF is pretty gross in
terms of CONSes introduced into your environment and just gross in general.
I haven't done anything about it. *)
(* * PUSH PUSHNEW POP already in Interlisp. *)
(PROPS (CAR SETF-INVERSE)
(CDR SETF-INVERSE)
(CAAR SETF-METHOD-EXPANDER)
(CADR SETF-METHOD-EXPANDER)
(CDAR SETF-METHOD-EXPANDER)
(CDDR SETF-METHOD-EXPANDER)
(CAAAR SETF-METHOD-EXPANDER)
(CADAR SETF-METHOD-EXPANDER)
(CDAAR SETF-METHOD-EXPANDER)
(CDDAR SETF-METHOD-EXPANDER)
(CAADR SETF-METHOD-EXPANDER)
(CADDR SETF-METHOD-EXPANDER)
(CDADR SETF-METHOD-EXPANDER)
(CDDDR SETF-METHOD-EXPANDER)
(CAAAAR SETF-METHOD-EXPANDER)
(CADAAR SETF-METHOD-EXPANDER)
(CDAAAR SETF-METHOD-EXPANDER)
(CDDAAR SETF-METHOD-EXPANDER)
(CAADAR SETF-METHOD-EXPANDER)
(CADDAR SETF-METHOD-EXPANDER)
(CDADAR SETF-METHOD-EXPANDER)
(CDDDAR SETF-METHOD-EXPANDER)
(CAAADR SETF-METHOD-EXPANDER)
(CADADR SETF-METHOD-EXPANDER)
(CDAADR SETF-METHOD-EXPANDER)
(CDDADR SETF-METHOD-EXPANDER)
(CAADDR SETF-METHOD-EXPANDER)
(CADDDR SETF-METHOD-EXPANDER)
(CDADDR SETF-METHOD-EXPANDER)
(CDDDDR SETF-METHOD-EXPANDER)
(CL:FIRST SETF-INVERSE)
(SECOND SETF-METHOD-EXPANDER)
(THIRD SETF-METHOD-EXPANDER)
(FOURTH SETF-METHOD-EXPANDER)
(FIFTH SETF-METHOD-EXPANDER)
(SIXTH SETF-METHOD-EXPANDER)
(SEVENTH SETF-METHOD-EXPANDER)
(EIGHTH SETF-METHOD-EXPANDER)
(NINTH SETF-METHOD-EXPANDER)
(TENTH SETF-METHOD-EXPANDER)
(REST SETF-INVERSE)
(CL:ELT SETF-INVERSE)
(AREF SETF-METHOD-EXPANDER)
(SVREF SETF-INVERSE)
(CHAR SETF-INVERSE)
(BIT SETF-INVERSE)
(SCHAR SETF-INVERSE)
(SBIT SETF-INVERSE)
(SYMBOL-VALUE SETF-INVERSE)
(SYMBOL-FUNCTION SETF-INVERSE)
(SYMBOL-PLIST SETF-INVERSE)
(DOCUMENTATION SETF-INVERSE)
(CL:NTH SETF-INVERSE)
(\SP-SVREF SETF-INVERSE)
(\SP-SCHAR SETF-INVERSE)
(\SP-SBIT SETF-INVERSE)
(\SP-SAREF1 SETF-INVERSE)
(\SP-CVREF SETF-INVERSE)
(\SP-CCHAR SETF-INVERSE)
(\SP-CBIT SETF-INVERSE)
(\SP-CAREF1 SETF-INVERSE)
(FILL-POINTER SETF-INVERSE)
(MACRO-FUNCTION SETF-METHOD-EXPANDER)
(SUBSEQ SETF-METHOD-EXPANDER)
(GETF SETF-METHOD-EXPANDER)
(GET SETF-METHOD-EXPANDER)
(GETHASH SETF-METHOD-EXPANDER)
(CL:APPLY SETF-METHOD-EXPANDER)
(LDB SETF-METHOD-EXPANDER)
(MASK-FIELD SETF-METHOD-EXPANDER)
(CHAR-BIT SETF-METHOD-EXPANDER)
(THE SETF-METHOD-EXPANDER))
(P (MOVD (QUOTE RPAQ?)
(QUOTE DEFVAR))
(MOVD (QUOTE RPAQ)
(QUOTE DEFPARAMETER)))
(FNS DEFCONSTANT)
(MACROS CL:WHEN CL:UNLESS DEFINE-SETF-METHOD DEFSETF SETF PSETF SHIFTF ROTATEF
DEFINE-MODIFY-MACRO PUTF REMF CASE TYPECASE ECASE ETYPECASE WITH-OPEN-FILE
WITH-OPEN-STREAM WITH-INPUT-FROM-STRING WITH-OUTPUT-TO-STRING LOCALLY LOOP INCF DECF)
(FNS GET-SETF-METHOD COMPILER-MACROEXPAND-1 COMPILER-MACROEXPAND
GET-SETF-METHOD-MULTIPLE-VALUE DEFSETTER)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DEFCONSTANT)
(NLAML)
(LAMA)))))
(* * Mainly SETF and friends in sction 7.2. The Rutgers SETF is pretty gross in terms of CONSes
introduced into your environment and just gross in general. I haven't done anything about it.
*)
(* * PUSH PUSHNEW POP already in Interlisp. *)
(PUTPROPS CAR SETF-INVERSE RPLACA)
(PUTPROPS CDR SETF-INVERSE RPLACD)
(PUTPROPS CAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CAAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CAAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CAAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CAADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CADR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CADR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CAAAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CAAAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDAAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDAAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CAAAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDAAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDAAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CAADAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CADAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADDAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDADAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CADAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDDAR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDDAR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CAAADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CAADR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDADR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDAADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CAADR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDADR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDADR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CAADDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CADDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CADDDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDADDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CADDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CDDDDR SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACD (CDDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS CL:FIRST SETF-INVERSE RPLACA)
(PUTPROPS SECOND SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS THIRD SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS FOURTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS FIFTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA (\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDDDR (\, X))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS SIXTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA
(\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDR (CDDDDR (\, X)))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS SEVENTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA
(\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDR (CDDDDR (\, X)))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS EIGHTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA
(\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDDR (CDDDDR (\, X)))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS NINTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA
(\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDDDDR (CDDDDR (\, X)))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS TENTH SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION
(CL:LAMBDA
(\ACCESS-ARGLIST V)
(LET* ((X (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (RPLACA (CDR (CDDDDR (CDDDDR (\, X))))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS REST SETF-INVERSE RPLACD)
(PUTPROPS CL:ELT SETF-INVERSE \SETELT)
(PUTPROPS AREF SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((< (LENGTH \LAMBDA-LIST)
2)
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE AREF)
(1- (LENGTH \LAMBDA-LIST))))
(T (LET* ((ARRAY (CAR (CDR \LAMBDA-LIST)))
(SUBSCRIPTS (CDR (CDR \LAMBDA-LIST))))
(LET ((ARRAY-TEMP (GENSYM))
(SUBSCRIPTS-TEMPS (for SUBSCRIPT in SUBSCRIPTS collect (GENSYM)))
(NEW-VALUE-TEMP (GENSYM)))
(VALUES (BQUOTE ((\, ARRAY-TEMP)
(\,@ SUBSCRIPTS-TEMPS)))
(BQUOTE ((\, ARRAY)
(\,@ SUBSCRIPTS)))
(BQUOTE ((\, NEW-VALUE-TEMP)))
(BQUOTE (ASET (\, NEW-VALUE-TEMP)
(\, ARRAY-TEMP)
(\,@ SUBSCRIPTS-TEMPS)))
(BQUOTE (AREF (\, ARRAY-TEMP)
(\,@ SUBSCRIPTS-TEMPS))))))))))
(PUTPROPS SVREF SETF-INVERSE SVSET)
(PUTPROPS CHAR SETF-INVERSE \CHARSET)
(PUTPROPS BIT SETF-INVERSE BITSET)
(PUTPROPS SCHAR SETF-INVERSE SCHARSET)
(PUTPROPS SBIT SETF-INVERSE SBITSET)
(PUTPROPS SYMBOL-VALUE SETF-INVERSE SET)
(PUTPROPS SYMBOL-FUNCTION SETF-INVERSE PUTD)
(PUTPROPS SYMBOL-PLIST SETF-INVERSE SETPROPLIST)
(PUTPROPS DOCUMENTATION SETF-INVERSE \SET-DOCUMENTATION)
(PUTPROPS CL:NTH SETF-INVERSE \SETNTH)
(PUTPROPS \SP-SVREF SETF-INVERSE \SP-SVSET)
(PUTPROPS \SP-SCHAR SETF-INVERSE \SP-SCHARSET)
(PUTPROPS \SP-SBIT SETF-INVERSE \SP-SBITSET)
(PUTPROPS \SP-SAREF1 SETF-INVERSE \SP-SASET1)
(PUTPROPS \SP-CVREF SETF-INVERSE \SP-CVSET)
(PUTPROPS \SP-CCHAR SETF-INVERSE \SP-CCHARSET)
(PUTPROPS \SP-CBIT SETF-INVERSE \SP-CBITSET)
(PUTPROPS \SP-CAREF1 SETF-INVERSE \SP-CASET1)
(PUTPROPS FILL-POINTER SETF-INVERSE \SET-FILL-POINTER)
(PUTPROPS MACRO-FUNCTION SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION (CL:LAMBDA
(\ACCESS-ARGLIST DEF)
(LET* ((SYMBOL (CAR (CDR \ACCESS-ARGLIST))))
(BQUOTE (CDR (\SP-SET-DEFINITION
(\, SYMBOL)
(CONS (QUOTE MACRO)
(\, DEF))))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS SUBSEQ SETF-METHOD-EXPANDER (CL:LAMBDA
(ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL:ATOM ARGS)
(SETQ NEW-ACCESS-FORM (CONS (CAR ACCESS-FORM)
DUMMIES))
(VALUES DUMMIES (CDR ACCESS-FORM)
(LIST NEWVAL-VAR)
(FUNCALL (FUNCTION
(CL:LAMBDA
(\ACCESS-ARGLIST V)
(LET* ((SEQUENCE (CAR (CDR \ACCESS-ARGLIST)))
(START (CAR (CDR (CDR \ACCESS-ARGLIST))))
(END (COND ((CDR (CDR (CDR \ACCESS-ARGLIST)))
(CAR (CDR (CDR (CDR \ACCESS-ARGLIST)))))
(T NIL))))
(BQUOTE (PROGN (CL:REPLACE (\, SEQUENCE)
(\, V)
:START1
(\, START)
:END1
(\, END))
(\, V))))))
NEW-ACCESS-FORM NEWVAL-VAR)
NEW-ACCESS-FORM)))))
(PUTPROPS GETF SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND
((OR (> (CL:LENGTH \LAMBDA-LIST)
4)
(< (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE GETF)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((PLACE (CAR (CDR \LAMBDA-LIST)))
(PROP (CAR (CDR (CDR \LAMBDA-LIST))))
(DEFAULT (COND ((CDR (CDR (CDR \LAMBDA-LIST)))
(CAR (CDR (CDR (CDR \LAMBDA-LIST)))))
(T NIL))))
(MULTIPLE-VALUE-BIND
(TEMPS VALUES STORES SET GET)
(GET-SETF-METHOD PLACE)
(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 (PROGN (SETQ (\, (CAR STORES))
(\PRIMITIVE PUTF (\, (CAR STORES))
(\, PTEMP)
(\, NEWVAL)))
(\, SET)
(\, NEWVAL)))
(BQUOTE (GETF (\, (CAR STORES))
(\, PTEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEF-TEMP)))))))))
))))))
(PUTPROPS GET SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((OR (> (CL:LENGTH \LAMBDA-LIST)
4)
(< (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE GET)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((SYMBOL (CAR (CDR \LAMBDA-LIST)))
(PROP (CAR (CDR (CDR \LAMBDA-LIST))))
(DEFAULT (COND ((CDR (CDR (CDR \LAMBDA-LIST)))
(CAR (CDR (CDR (CDR \LAMBDA-LIST)))))
(T NIL))))
(LET ((SYMBOL-TEMP (GENSYM))
(PROP-TEMP (GENSYM))
(DEF-TEMP (GENSYM))
(NEWVAL (GENSYM)))
(VALUES (BQUOTE ((\, SYMBOL-TEMP)
(\, PROP-TEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEF-TEMP)))))))
(BQUOTE ((\, SYMBOL)
(\, PROP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEFAULT)))))))
(LIST NEWVAL)
(BQUOTE (PUTPROP (\, SYMBOL-TEMP)
(\, PROP-TEMP)
(\, NEWVAL)))
(BQUOTE (GET (\, SYMBOL-TEMP)
(\, PROP-TEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\, DEF-TEMP))))))))
))))))
(PUTPROPS GETHASH SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((OR (> (CL:LENGTH \LAMBDA-LIST)
4)
(< (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE GETHASH)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((KEY (CAR (CDR \LAMBDA-LIST)))
(HASHTABLE (CAR (CDR (CDR \LAMBDA-LIST))))
(DEFAULT (COND ((CDR (CDR (CDR \LAMBDA-LIST)))
(CAR (CDR (CDR (CDR \LAMBDA-LIST)))))
(T NIL))))
(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 (\PUTHASH (\, KEY-TEMP)
(\, HASHTABLE-TEMP)
(\, NEW-VALUE-TEMP)))
(BQUOTE (GETHASH (\, KEY-TEMP)
(\, HASHTABLE-TEMP)
(\,@ (CL:IF DEFAULT (BQUOTE ((\,
DEFAULT-TEMP)))))
)))))))))
(PUTPROPS CL:APPLY SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((< (CL:LENGTH \LAMBDA-LIST)
2)
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE CL:APPLY)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((FUNCTION (CAR (CDR \LAMBDA-LIST)))
(ARGS (CDR (CDR \LAMBDA-LIST))))
(CL:IF (AND (LISTP FUNCTION)
(= (LIST-LENGTH FUNCTION)
2)
(EQ (CL:FIRST FUNCTION)
(QUOTE FUNCTION))
(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))
(* " 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)))))))))))
(PUTPROPS LDB SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((NOT (= (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE LDB)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((BYTESPEC (CAR (CDR \LAMBDA-LIST)))
(PLACE (CAR (CDR (CDR \LAMBDA-LIST)))))
(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))
(DPB (\, GNUVAL)
(\, BTEMP)
(\, GETTER))))
(\, SETTER)
(\, GNUVAL)))
(BQUOTE (LDB (\, BTEMP)
(\, GETTER)))))))))))
(PUTPROPS MASK-FIELD SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((NOT (= (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE MASK-FIELD)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((BYTESPEC (CAR (CDR \LAMBDA-LIST)))
(PLACE (CAR (CDR (CDR \LAMBDA-LIST)))))
(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)))))))))))
(PUTPROPS CHAR-BIT SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((NOT (= (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE CHAR-BIT)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((PLACE (CAR (CDR \LAMBDA-LIST)))
(BIT-NAME (CAR (CDR (CDR \LAMBDA-LIST)))))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD PLACE)
(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)))))))))))
(PUTPROPS THE SETF-METHOD-EXPANDER (CL:LAMBDA
(\LAMBDA-LIST)
(COND ((NOT (= (CL:LENGTH \LAMBDA-LIST)
3))
(CL:ERROR "Setf expander for ~S cannot be called with ~S args." (QUOTE THE)
(1- (CL:LENGTH \LAMBDA-LIST))))
(T (LET* ((TYPE (CAR (CDR \LAMBDA-LIST)))
(PLACE (CAR (CDR (CDR \LAMBDA-LIST)))))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD PLACE)
(VALUES DUMMIES VALS NEWVAL
(CL:SUBST (BQUOTE (THE (\, TYPE)
(\, (CAR NEWVAL))))
(CAR NEWVAL)
SETTER)
(BQUOTE (THE (\, TYPE)
(\, GETTER))))))))))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFVAR))
(MOVD (QUOTE RPAQ)
(QUOTE DEFPARAMETER))
(DEFINEQ
(DEFCONSTANT
(NLAMBDA $FEXPR$ (* kbr: "31-Aug-85 18:49")
((LAMBDA (VAR VAL)
(SETQ VAL (EVAL VAL))
(COND
((BOUNDP VAR)
(COND
((NOT (EQUAL (GETTOPVAL VAR)
VAL))
(CERROR "Go ahead and change the value." "Constant ~S being redefined." VAR)
(SETTOPVAL VAR VAL))))
(T (SETTOPVAL VAR VAL)))
VAR)
(pop $FEXPR$)
(POP $FEXPR$))))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO CL:WHEN (&REST FORMS)
"First arg is a predicate. If it is non-null, the rest of the forms are
evaluated as a PROGN."
(BQUOTE (COND (\, FORMS))))
(DEFMACRO CL:UNLESS (TEST &REST FORMS)
"First arg is a predicate. If it is null, the rest of the forms are
evaluated as a PROGN."
(BQUOTE (COND ((NOT (\, TEST))
(\,@ FORMS)))))
(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 DOC ARG-TEST \ARG-COUNT \MIN-ARGS \RESTP \LET-LIST \KEYWORD-TESTS)
(SETQ LOCAL-DECS NIL)
(SETQ DOC NIL)
(SETQ ARG-TEST NIL)
(SETQ \ARG-COUNT 0)
(SETQ \MIN-ARGS 0)
(SETQ \RESTP NIL)
(SETQ \LET-LIST NIL)
(SETQ \KEYWORD-TESTS NIL)
(CL:DECLARE (SPECIAL \ARG-COUNT \MIN-ARGS \RESTP \LET-LIST \KEYWORD-TESTS))
(COND ((NOT (SYMBOLP ACCESS-FN))
(CL:ERROR "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."
ACCESS-FN)))
(* " Check for local declarations and documentation string." *)
LOOP
(COND ((CL:ATOM BODY)
(SETQ BODY (QUOTE (NIL))))
((AND (NOT (CL:ATOM (CAR BODY)))
(EQ (CAAR BODY)
(QUOTE CL: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 (QUOTE (CDR \LAMBDA-LIST))
ACCESS-FN
(QUOTE \LAMBDA-LIST))
(SETQ ARG-TEST (COND ((AND (ZEROP \MIN-ARGS)
\RESTP)
NIL)
((ZEROP \MIN-ARGS)
(BQUOTE (> (LENGTH \LAMBDA-LIST)
(\, (1+ \ARG-COUNT)))))
(\RESTP (BQUOTE (< (LENGTH \LAMBDA-LIST)
(\, (1+ \MIN-ARGS)))))
((= \MIN-ARGS \ARG-COUNT)
(BQUOTE (NOT (= (LENGTH \LAMBDA-LIST)
(\, (1+ \MIN-ARGS))))))
(T (BQUOTE (OR (> (LENGTH \LAMBDA-LIST)
(\, (1+ \ARG-COUNT)))
(< (LENGTH \LAMBDA-LIST)
(\, (1+ \MIN-ARGS))))))))
(* " Now build the body of the macro." *)
(COND ((NULL LAMBDA-LIST)
(PUSH LOCAL-DECS (QUOTE (IGNORE \LAMBDA-LIST)))))
(SETQ BODY (BQUOTE (LET* (\, (NREVERSE \LET-LIST))
(\,@ (AND LOCAL-DECS (LIST (CONS (QUOTE CL:DECLARE)
LOCAL-DECS))))
(\,@ \KEYWORD-TESTS)
(\,@ BODY))))
(AND ARG-TEST (SETQ BODY (BQUOTE (COND ((\, ARG-TEST)
(CL:ERROR
"Setf expander for ~S cannot be called with ~S args."
(QUOTE (\, ACCESS-FN))
(1- (LENGTH \LAMBDA-LIST))))
(T (\, BODY))))))
(RETURN (BQUOTE (EVAL-WHEN (LOAD CL:COMPILE EVAL)
(REMPROP (QUOTE (\, ACCESS-FN))
(QUOTE SETF-INVERSE))
(PUTPROP (QUOTE (\, ACCESS-FN))
(QUOTE SETF-METHOD-EXPANDER)
(FUNCTION (CL:LAMBDA (\LAMBDA-LIST)
(\, BODY))))
(QUOTE (\, ACCESS-FN)))))))
(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)))
(BQUOTE (EVAL-WHEN (LOAD CL:COMPILE EVAL)
(REMPROP (QUOTE (\, ACCESS-FN))
(QUOTE SETF-METHOD-EXPANDER))
(PUTPROP (QUOTE (\, ACCESS-FN))
(QUOTE SETF-INVERSE)
(QUOTE (\, (CAR REST))))
(QUOTE (\, ACCESS-FN)))))
((AND (LISTP (CAR REST))
(CDR REST)
(LISTP (CADR REST)))
(COND ((NOT (= (LENGTH (CADR REST))
1))
(CERROR "Ignore the extra items in the list."
"Only one new-value variable allowed in DEFSETF."))
(T NIL))
(LET* ((DOC (CL:DO ((X (CDDR REST)
(CDR X)))
((OR (CL:ATOM X)
(CL:ATOM (CDR X)))
NIL)
(COND ((STRINGP (CAR X))
(RETURN (CAR X)))
((AND (LISTP (CAR X))
(EQ (CAAR X)
(QUOTE DECLARATION))))
(T (RETURN NIL)))))
(SETTING-FORM-GENERATOR (DEFSETTER ACCESS-FN REST)))
(BQUOTE (EVAL-WHEN
(LOAD CL:COMPILE EVAL)
(REMPROP (QUOTE (\, ACCESS-FN))
(QUOTE SETF-INVERSE))
(PUTPROP (QUOTE (\, ACCESS-FN))
(QUOTE SETF-METHOD-EXPANDER)
(FUNCTION
(CL:LAMBDA (ACCESS-FORM)
(DO* ((ARGS (CDR ACCESS-FORM)
(CDR ARGS))
(DUMMIES NIL (CONS (GENSYM)
DUMMIES))
(NEWVAL-VAR (GENSYM))
(NEW-ACCESS-FORM NIL))
((CL: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))))))
(QUOTE (\, ACCESS-FN))))))
(T (CL: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 ((CL:ATOM (CAR ARGS))
(BQUOTE (SETQ (\, (CAR ARGS))
(\, (CADR ARGS)))))
((SETQ TEMP (GET (CAAR ARGS)
(QUOTE SETF-INVERSE)))
(BQUOTE ((\, TEMP)
(\,@ (CDAR ARGS))
(\, (CADR ARGS)))))
(T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD (CAR ARGS))
(CL:DECLARE (IGNORE GETTER))
(DO* ((D DUMMIES (CDR D))
(V VALS (CDR V))
(LET-LIST NIL))
((NULL D)
(SETQ LET-LIST
(NREVERSE (CONS (LIST (CAR NEWVAL)
(CADR ARGS))
LET-LIST)))
(BQUOTE (LET* (\, LET-LIST)
(\, SETTER))))
(SETQ LET-LIST (CONS (LIST (CAR D)
(CAR V))
LET-LIST)))))))
((ODDP TEMP)
(CL:ERROR "Odd number of args to SETF."))
(T (CL:DO ((A ARGS (CDDR A))
(L NIL))
((NULL A)
(BQUOTE (PROGN (\,@ (NREVERSE L)))))
(SETQ L (CONS (LIST (QUOTE 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."
(CL:DO ((A ARGS (CDDR A))
(LET-LIST NIL)
(SETF-LIST NIL))
((CL:ATOM A)
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\,@ (NREVERSE SETF-LIST))
NIL)))
(COND ((CL:ATOM (CDR A))
(CL:ERROR "Odd number of args to PSETF."))
(T NIL))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-SETF-METHOD (CAR A))
(CL:DECLARE (IGNORE GETTER))
(DO* ((D DUMMIES (CDR D))
(V VALS (CDR V)))
((NULL D))
(PUSH LET-LIST (LIST (CAR D)
(CAR V))))
(PUSH LET-LIST (LIST (CAR NEWVAL)
(CADR A)))
(PUSH SETF-LIST SETTER))))
(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."
(COND ((< (LENGTH ARGS)
2)
(CL:ERROR "Too few argument forms to a SHIFTF."))
(T NIL))
(LET ((LEFTMOST (GENSYM)))
(CL:DO ((A ARGS (CDR A))
(LET-LIST NIL)
(SETF-LIST NIL)
(NEXT-VAR LEFTMOST))
((CL:ATOM (CDR A))
(PUSH LET-LIST (LIST NEXT-VAR (CAR A)))
(BQUOTE (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 LET-LIST (LIST (CAR D)
(CAR V))))
(PUSH LET-LIST (LIST NEXT-VAR GETTER))
(PUSH SETF-LIST SETTER)
(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))
(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))
(CL:DO ((D DUMMIES (CDR D))
(V VALS (CDR V)))
((NULL D))
(push LET-LIST (LIST (CAR D)
(CAR V))))
(push LET-LIST (LIST NEXT-VAR GETTER))
(*
" 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."
*)
(COND ((NOT FIX-ME)
(SETQ FIX-ME (CAR LET-LIST))))
(push SETF-LIST SETTER)
(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." *)
(CL:DO ((LL LAMBDA-LIST (CDR LL))
(ARG NIL))
((NULL LL))
(SETQ ARG (CAR LL))
(COND ((EQ ARG (QUOTE &OPTIONAL)))
((EQ ARG (QUOTE &REST))
(COND ((SYMBOLP (CADR LL))
(SETQ REST-ARG (CADR LL)))
(T (CL:ERROR "Non-symbol &rest arg in definition of ~S." NAME)))
(COND ((NULL (CDDR LL))
(RETURN NIL))
(T (CL:ERROR "Illegal stuff after &rest arg in Define-Modify-Macro."))))
((MEMQ ARG (QUOTE (&KEY &ALLOW-OTHER-KEYS &AUX)))
(CL:ERROR "~S not allowed in Define-Modify-Macro lambda list." ARG))
((SYMBOLP ARG)
(PUSH OTHER-ARGS ARG))
((AND (LISTP ARG)
(SYMBOLP (CAR ARG)))
(PUSH OTHER-ARGS (CAR ARG)))
(T (CL:ERROR "Illegal stuff in lambda list of Define-Modify-Macro."))))
(SETQ OTHER-ARGS (NREVERSE 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)
(PUSH LET-LIST (LIST (CAR NEWVAL)
(\, (COND (REST-ARG
(BQUOTE (LIST* (QUOTE (\, FUNCTION))
GETTER
(\,@ OTHER-ARGS)
(\, REST-ARG))))
(T (BQUOTE (LIST (QUOTE (\, FUNCTION))
GETTER
(\,@ OTHER-ARGS))))))))
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(\, SETTER))))))))))
(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 LET-LIST (LIST (CAR NEWVAL)
GETTER))
(PUSH LET-LIST (LIST IND-TEMP INDICATOR))
(PUSH LET-LIST (LIST VAL-TEMP VALUE))
(BQUOTE (LET* (\, (NREVERSE LET-LIST))
(SETQ (\, (CAR NEWVAL))
(\PRIMITIVE PUTF (\, (CAR NEWVAL))
(\, IND-TEMP)
(\, VAL-TEMP)))
(\, SETTER)
(\, VAL-TEMP))))
(PUSH LET-LIST (LIST (CAR D)
(CAR V))))))
(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 LET-LIST (LIST (CAR NEWVAL)
GETTER))
(PUSH LET-LIST (LIST IND-TEMP INDICATOR))
(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 (SETQ (\, (CAR NEWVAL))
(CDDR (\, (CAR NEWVAL))))
(\, SETTER)
(RETURN T)))))))))
(PUSH LET-LIST (LIST (CAR D)
(CAR V))))))
(DEFMACRO
CASE
(&WHOLE FORM)
(LET
((KV (GENSYM))
(CLAUSES NIL))
(CL:DO
((C (CDDR FORM)
(CDR C)))
((CL:ATOM C))
(COND
((CL:ATOM (CAR C))
(CL:ERROR "~S -- Bad clause in CASE." (CAR C)))
((MEMQ (CAAR C)
(QUOTE (T OTHERWISE)))
(push CLAUSES (BQUOTE (T (\,@ (CDAR C)))))
(RETURN NIL))
((NULL (CAAR C))
(push CLAUSES (BQUOTE ((NULL (\, KV))
(\,@ (CDAR C))))))
((NOT (LISTP (CAAR C)))
(;;; " Note -- special hack in Maclisp to make chars and other" ;;;)
(;;; " fake types not be LISTP, leaving only true lists." ;;;)
(push CLAUSES (BQUOTE ((EQL (QUOTE (\, (CAAR C)))
(\, KV))
(\,@ (CDAR C))))))
(T (push CLAUSES
(BQUOTE ((OR (\,@ (CL:DO ((X (CAAR C)
(CDR X))
(Y NIL))
((CL:ATOM X)
(NREVERSE Y))
(push Y (BQUOTE (EQL (QUOTE (\, (CAR X)))
(\, KV)))))))
(\,@ (CDAR C))))))))
(BQUOTE (LET (((\, KV)
(\, (CADR FORM))))
(COND (\,@ (NREVERSE CLAUSES)))))))
(DEFMACRO TYPECASE (KEYFORM &REST FORMS)
"Type dispatch, order is important, more specific types should appear first"
(BQUOTE (LET (($$TYPE-VALUE , KEYFORM))
(COND ., (CL:MAPCAR (FUNCTION (LAMBDA (FORM)
(LET ((TYPE (CAR FORM))
(FORM (CDR FORM)))
(BQUOTE ((TYPEP $$TYPE-VALUE
(QUOTE , TYPE))
., FORM)))))
FORMS)))))
(DEFMACRO
ECASE
(&WHOLE FORM)
(LET
((KV (GENSYM))
(CLAUSES NIL))
(CL:DO
((C (CDDR FORM)
(CDR C))
(KEYS NIL (APPEND (COND ((CL:ATOM (CAAR C))
(LIST (CAAR C)))
(T (CAAR C)))
KEYS)))
((CL:ATOM C)
(PUSH CLAUSES (BQUOTE (T (CL:ERROR "Ecase key must be one of ~S" (QUOTE (\, KEYS)))))))
(COND
((CL:ATOM (CAR C))
(CL:ERROR (QUOTE :BAD-MACRO-FORMAT)
"~S -- Bad clause in ECASE."
(CAR C)))
((MEMQ (CAAR C)
(QUOTE (T OTHERWISE)))
(CL:ERROR "T or Otherwise clause is not permitted in ECASE."))
((CL:ATOM (CAAR C))
(PUSH CLAUSES (BQUOTE ((EQL (\, KV)
(QUOTE (\, (CAAR C))))
(\,@ (CDAR C))))))
(T (PUSH CLAUSES
(BQUOTE ((OR (\,@ (CL:DO ((X (CAAR C)
(CDR X))
(Y NIL))
((CL:ATOM X)
(NREVERSE Y))
(PUSH Y (BQUOTE (EQL (\, KV)
(QUOTE (\, (CAR X)))))))))
(\,@ (CDAR C))))))))
(BQUOTE (LET (((\, KV)
(\, (CADR FORM))))
(COND (\,@ (NREVERSE CLAUSES)))))))
(DEFMACRO ETYPECASE (&WHOLE FORM)
(LET ((KV (GENSYM))
(CLAUSES NIL))
(CL:DO ((C (CDDR FORM)
(CDR C))
(KEYS NIL (CONS (CAAR C)
KEYS)))
((CL:ATOM C)
(PUSH CLAUSES (BQUOTE (T (CL:ERROR
"Etypecase key must be one of these types: ~S"
(QUOTE (\, KEYS)))))))
(COND ((CL:ATOM C)
(CL:ERROR "~S -- Bad clause in CASE." (CAR C)))
((MEMQ (CAAR C)
(QUOTE (T OTHERWISE)))
(CL:ERROR "T or Otherwise clause is not permitted in ETYPECASE."))
(T (PUSH CLAUSES (BQUOTE ((TYPEP (\, KV)
(QUOTE (\, (CAAR C))))
(\,@ (CDAR C))))))))
(BQUOTE (LET (((\, KV)
(\, (CADR FORM))))
(COND (\,@ (NREVERSE CLAUSES)))))))
(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."
(BQUOTE (LET (((\, (CAR BINDSPEC))
(OPEN (\,@ (CDR BINDSPEC)))))
(UNWIND-PROTECT (PROGN (\,@ FORMS))
(CLOSE (\, (CAR BINDSPEC)))))))
(DEFMACRO WITH-OPEN-STREAM ((VAR STREAM) . BODY)
(CL:DO ((FORMS BODY (CDR FORMS))
(DECLARATIONS NIL))
((NOT (AND (LISTP (CAR FORMS))
(EQ (CAAR FORMS)
(QUOTE CL:DECLARE))))
(LET ((TEMP (GENSYM)))
(BQUOTE (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."
(CL:DO ((FORMS BODY (CDR FORMS))
(DECLARATIONS NIL))
((NOT (AND (LISTP (CAR FORMS))
(EQ (CAAR FORMS)
(QUOTE CL:DECLARE))))
(LET ((TEMP (GENSYM)))
(BQUOTE (LET (((\, VAR)
(\, (COND (END (BQUOTE (MAKE-STRING-INPUT-STREAM
(\, STRING)
(\, (OR START 0))
(\, END))))
(T (BQUOTE (MAKE-STRING-INPUT-STREAM
(\, STRING)
(\, (OR START 0))))))))
(\, TEMP))
(\,@ DECLARATIONS)
(UNWIND-PROTECT
(SETQ (\, TEMP)
(PROGN (\,@ FORMS)))
(CLOSE (\, VAR))
(\,@ (COND (INDEX (BQUOTE ((SETF (\, INDEX)
(STREAM-INPUT-STRING-CURRENT
(\, VAR))))))
(T NIL))))
(\, 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."
(CL:DO ((FORMS BODY (CDR FORMS))
(DECLARATIONS NIL))
((NOT (AND (LISTP (CAR FORMS))
(EQ (CAAR FORMS)
(QUOTE CL:DECLARE))))
(COND (STRING (LET ((TEMP (GENSYM)))
(BQUOTE (LET (((\, VAR)
(MAKE-FILL-POINTER-OUTPUT-STREAM (\, STRING)))
(\, TEMP))
(\,@ DECLARATIONS)
(UNWIND-PROTECT (SETQ (\, TEMP)
(PROGN (\,@ FORMS)))
(CLOSE (\, VAR)))
(\, TEMP)))))
(T (BQUOTE (LET (((\, VAR)
(MAKE-STRING-OUTPUT-STREAM)))
(\,@ DECLARATIONS)
(UNWIND-PROTECT (PROGN (\,@ FORMS))
(CLOSE (\, VAR)))
(GET-OUTPUT-STREAM-STRING (\, VAR)))))))))
(DEFMACRO LOCALLY (&REST FORMS)
"A form providing a container for locally-scoped variables."
(BQUOTE (LET NIL (\,@ 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)))
(BQUOTE (CL:BLOCK NIL (TAGBODY (\, TAG)
(\,@ BODY)
(GO (\, TAG)))))))
(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."
(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)
(LIST (QUOTE +)
GETTER DELTA))
LET-LIST)
(BQUOTE (LET* (\, (CL:NREVERSE LET-LIST))
(\, SETTER)))))))
(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."
(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)
(LIST (QUOTE -)
GETTER DELTA))
LET-LIST)
(BQUOTE (LET* (\, (CL:NREVERSE LET-LIST))
(\, SETTER)))))))
)
(DEFINEQ
(GET-SETF-METHOD
(CL:LAMBDA (FORM) (* kbr: "31-Aug-85 16:54")
(LET (TEMP)
(COND
((SYMBOLP FORM)
(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 (GET (CAR FORM)
(QUOTE SETF-INVERSE)))
(LET ((NEW-VAR (GENSYM))
(VARS NIL)
(VALS NIL))
(DOLIST (X (CDR FORM))
(push VARS (GENSYM))
(push X VALS))
(SETQ VALS (NREVERSE VALS))
(VALUES VARS VALS (LIST NEW-VAR)
(BQUOTE ((\, TEMP)
(\,@ VARS)
(\, NEW-VAR)))
(BQUOTE ((\, (CAR FORM))
(\,@ VARS))))))
((SETQ TEMP (GET (CAR FORM)
(QUOTE SETF-METHOD-EXPANDER)))
(FUNCALL TEMP FORM))
((AND (BOUNDP (QUOTE *IN-THE-COMPILER*))
*IN-THE-COMPILER*)
(CL:IF (EQ (SETQ TEMP (CAR (COMPILER-MACROEXPAND-1 FORM)))
FORM)
(CL:ERROR "~S is not a known location specifier for SETF." (CAR FORM))
(GET-SETF-METHOD TEMP)))
(T (CL:IF (EQ (SETQ TEMP (CAR (MACROEXPAND-1 FORM)))
FORM)
(CL:ERROR "~S is not a known location specifier for SETF." (CAR FORM))
(GET-SETF-METHOD TEMP)))))))
(COMPILER-MACROEXPAND-1
(CL:LAMBDA (FORM)
(LET (TEMP)
(COND
((NOT (LISTP FORM))
(VALUES FORM NIL))
((NOT (SYMBOLP (CAR FORM)))
(VALUES FORM NIL))
((OR (SETQ TEMP (GET (CAR FORM)
(QUOTE MACRO-IN-COMPILER)))
(SETQ TEMP (MACRO-FUNCTION (CAR FORM))))
(VALUES (FUNCALL *MACROEXPAND-HOOK* TEMP FORM)
T))
(T (VALUES FORM NIL))))))
(COMPILER-MACROEXPAND
(CL:LAMBDA (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))
(CL:IF FLAG (GO LOOP)
(RETURN (VALUES FORM T))))))
(GET-SETF-METHOD-MULTIPLE-VALUE
(CL:LAMBDA (FORM)
"Like Get-Setf-Method, but may return multiple new-value variables."
(GET-SETF-METHOD FORM)))
(DEFSETTER
(CL:LAMBDA (FN REST) (* kbr: "31-Aug-85 12:50")
(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))
(CL:DECLARE (SPECIAL \ARG-COUNT \MIN-ARGS \RESTP \LET-LIST \KEYWORD-TESTS))
(* Check for local declarations and documentation
string. *)
(PROG NIL
LOOP(COND
((CL:ATOM BODY)
(SETQ BODY (QUOTE (NIL))))
((AND (NOT (CL:ATOM (CAR BODY)))
(EQ (CAAR BODY)
(QUOTE CL: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 (QUOTE (CDR \ACCESS-ARGLIST))
FN
(QUOTE \ACCESS-ARGLIST)) (* Now build the body of the transform.
*)
(COND
((NULL ARGLIST)
(PUSH LOCAL-DECS (QUOTE (IGNORE \ACCESS-ARGLIST)))))
(SETQ BODY (BQUOTE (LET* (\, (NREVERSE \LET-LIST))
(\,@ (AND LOCAL-DECS (LIST (CONS (QUOTE CL:DECLARE)
LOCAL-DECS))))
(\,@ \KEYWORD-TESTS)
(\,@ BODY))))
(BQUOTE (CL:LAMBDA (\ACCESS-ARGLIST (\, NEW-VAR))
(\, BODY))))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFCONSTANT)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS CMLMACROS COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (38700 39178 (DEFCONSTANT 38710 . 39176)) (60643 64935 (GET-SETF-METHOD 60653 . 62177) (
COMPILER-MACROEXPAND-1 62179 . 62632) (COMPILER-MACROEXPAND 62634 . 63003) (
GET-SETF-METHOD-MULTIPLE-VALUE 63005 . 63166) (DEFSETTER 63168 . 64933)))))
STOP