(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "14-Feb-92 13:26:45" IL:|{DSK}local>lde>lispcore>sources>CMLSETF.;4| 35330 IL:|changes| IL:|to:| (IL:VARS IL:CMLSETFCOMS) (IL:FUNCTIONS ROTATEF CL::ROTATEF-INTERNAL CL::MV-LET* SETF GET-SETF-METHOD-MULTIPLE-VALUE PSETF SHIFTF CL::SHIFTF-INTERNAL) IL:|previous| IL:|date:| " 4-Jan-92 15:22:54" IL:|{DSK}local>lde>lispcore>sources>CMLSETF.;2| ) ; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLSETFCOMS) (IL:RPAQQ IL:CMLSETFCOMS ((IL:FUNCTIONS GET-SETF-METHOD GET-SIMPLE-SETF-METHOD GET-SETF-METHOD-MULTIPLE-VALUE CL::DEFUN-SETF-METHOD) (IL:DEFINE-TYPES IL:SETFS) (IL:FUNCTIONS DEFSETF DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD) (IL:COMS (IL:* IL:|;;| "Support for defstruct and friends ") (IL:FUNCTIONS DEFINE-SHARED-SETF-MACRO DEFINE-SHARED-SETF GET-SHARED-SETF-METHOD)) (IL:FUNCTIONS SETF SETF-ERROR) (IL:FUNCTIONS PSETF SHIFTF ROTATEF POP REMF) (IL:* IL:|;;| "A little suppost stuff to make writing the undoable versions easier") (IL:FUNCTIONS CL::SHIFTF-INTERNAL CL::ROTATEF-INTERNAL) (IL:* IL:|;;| "A little support macro to make ROTATEF prettier") (IL:FUNCTIONS CL::MV-LET*) (IL:FUNCTIONS INCF DECF) (IL:FUNCTIONS MAYBE-MAKE-BINDING-FORM COUNT-OCCURRENCES CL::SETF-NAME-P XCL::DEFUN-SETF-NAME XCL::SET-DEFUN-SETF) (IL:FUNCTIONS PUSH PUSHNEW) (IL: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 FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST NTHCDR NTH GETF APPLY LDB MASK-FIELD CHAR-BIT THE CL:FDEFINITION) (IL:COMS (IL:* IL:\; "Some IL setfs, for no especially good reason") (IL:SETFS IL:GETHASH) (IL:FUNCTIONS IL:%SET-IL-GETHASH)) (IL:PROP IL:PROPTYPE :SETF-METHOD-EXPANDER :SETF-INVERSE :SHARED-SETF-INVERSE) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLSETF) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (DEFUN GET-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT) (LET (TEMP) (COND ((SYMBOLP FORM) (IL:* IL:|;;| "Symbols have a simple, constant SETF method.") (VALUES NIL NIL (LIST (SETQ TEMP (IL:GENSYM))) (IL:BQUOTE (SETQ (IL:\\\, FORM) (IL:\\\, TEMP))) FORM)) ((NOT (CONSP FORM)) (IL:* IL:\; "Syntax error") (SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (GET-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETFN)))) (GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) (QUOTE :SHARED-SETF-INVERSE))) (GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR FORM) (QUOTE IL:SETF-METHOD-EXPANDER)))) (IL:* IL:|;;| "Do check number of the Store Variables") (MULTIPLE-VALUE-BIND (TEMPS VALUES STORES SETTER GETTER) (FUNCALL TEMP FORM ENVIRONMENT) (WHEN (/= (LENGTH STORES) 1) (WARN "SETF method contains more than one store variable. Only top of the elements was accepted.") (SETQ STORES (LIST (CAR STORES)))) (VALUES TEMPS VALUES STORES SETTER GETTER))) (T (MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND DONE (NOT (EQ EXPANSION FORM))) (GET-SETF-METHOD EXPANSION ENVIRONMENT) (CL::DEFUN-SETF-METHOD FORM ENVIRONMENT))))))) (DEFUN GET-SIMPLE-SETF-METHOD (FORM SETF-INVERSE) (IL:* IL:|;;| "Produce SETF method for a form that has a setf-inverse. Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (LET ((NEW-VAR (IL:GENSYM)) VARS VALS ARGS SETF-INVERSE-FORM GET-FORM) (SETQ ARGS (MAPCAR (FUNCTION (LAMBDA (ARG) (COND ((IF (CONSP ARG) (EQ (CAR ARG) (QUOTE QUOTE)) (CONSTANTP ARG)) (IL:* IL:|;;| "We don't need gensym for this constant argument. The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") ARG) (T (IL:* IL:|;;| "Anything else might be side-effected, so will need to bind") (PUSH ARG VALS) (LET ((G (IL:GENSYM))) (PUSH G VARS) G))))) (CDR FORM))) (SETQ SETF-INVERSE-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, SETF-INVERSE) (IL:\\\,@ ARGS) (IL:\\\, NEW-VAR))))) (SETQ GET-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS))))) (IL:* IL:|;;| "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (VALUES (SETQ VARS (NREVERSE VARS)) (SETQ VALS (NREVERSE VALS)) (LIST NEW-VAR) SETF-INVERSE-FORM GET-FORM))) (DEFUN GET-SETF-METHOD-MULTIPLE-VALUE (FORM &OPTIONAL ENVIRONMENT) (IL:* IL:\; "Edited 6-Feb-92 15:31 by jrb:") (LET (TEMP) (COND ((SYMBOLP FORM) (IL:* IL:|;;| "Symbols have a simple, constant SETF method.") (VALUES NIL NIL (LIST (SETQ TEMP (IL:GENSYM))) (IL:BQUOTE (SETQ (IL:\\\, FORM) (IL:\\\, TEMP))) FORM)) ((NOT (CONSP FORM)) (IL:* IL:\; "Syntax error") (SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (GET-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETFN)))) (GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) (QUOTE :SHARED-SETF-INVERSE))) (GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR FORM) (QUOTE IL:SETF-METHOD-EXPANDER)))) (IL:* IL:|;;| "Does not check the number of Store Variables.") (FUNCALL TEMP FORM ENVIRONMENT)) (T (MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND DONE (NOT (EQ EXPANSION FORM))) (GET-SETF-METHOD EXPANSION ENVIRONMENT) (CL::DEFUN-SETF-METHOD FORM ENVIRONMENT))))))) (DEFUN CL::DEFUN-SETF-METHOD (CL::FORM CL::ENVIRONMENT) (IL:* IL:|;;| "This doesn't need to do anything special with the ENVIRONMENT; all special search necessary is done by #'(SETF ,(CAR FORM))") (LET* ((CL::NEWVAL (GENSYM)) (CL::LET-LIST (MAPCAR (FUNCTION (LAMBDA (CL::X) (LIST (GENSYM) CL::X))) (CDR CL::FORM))) (CL::TEMPS (MAPCAR (FUNCTION CAR) CL::LET-LIST))) (VALUES CL::TEMPS (CDR CL::FORM) (LIST CL::NEWVAL) (IL:BQUOTE (FUNCALL (FUNCTION (SETF (IL:\\\, (CAR CL::FORM)))) (IL:\\\, CL::NEWVAL) (IL:\\\,@ CL::TEMPS))) (CONS (CAR CL::FORM) CL::TEMPS)))) (XCL:DEF-DEFINE-TYPE IL:SETFS "Common Lisp SETF definitions") (XCL:DEFDEFINER (DEFSETF (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFSETF (IL:\\\, NAME) "Inverse function")))))) IL:SETFS (NAME &REST REST &ENVIRONMENT ENV) (IL:* IL:|;;;| "Associates a SETF update function or macro with the specified access function or macro") (COND ((NULL REST) (ERROR "No body for DEFSETF of ~A" NAME)) ((AND (LISTP (CAR REST)) (CDR REST) (LISTP (CADR REST))) (IL:* IL:|;;| "The complex form:") (IL:* IL:|;;| "(defsetf access-fn args (store-var) {decl | doc}* {form}*)") (XCL:DESTRUCTURING-BIND (ARG-LIST (STORE-VAR &REST OTHERS) &BODY BODY) REST (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))) (ENVIRONMENT (XCL:PACK (LIST NAME "-setf-env") (SYMBOL-PACKAGE NAME))) (EXPANDER (XCL:PACK (LIST NAME "-setf-expander") (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (IL:PARSE-DEFMACRO ARG-LIST WHOLE-VAR BODY NAME ENV :ENVIRONMENT ENVIRONMENT) (IL:BQUOTE (PROGN (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER))) (FUNCTION (LAMBDA (ACCESS-FORM (IL:\\\, ENVIRONMENT)) (LET* ((DUMMIES (MAPCAR (FUNCTION (LAMBDA (X) (IL:GENSYM))) (CDR ACCESS-FORM))) ((IL:\\\, WHOLE-VAR) (CONS (CAR ACCESS-FORM) DUMMIES)) ((IL:\\\, STORE-VAR) (IL:GENSYM))) (VALUES DUMMIES (CDR ACCESS-FORM) (LIST (IL:\\\, STORE-VAR)) (BLOCK (IL:\\\, NAME) (IL:\\\, CODE)) (IL:\\\, WHOLE-VAR)))))) (SET-SETF-METHOD-EXPANDER (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, EXPANDER)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))))) ((SYMBOLP (CAR REST)) (IL:* IL:|;;| "The short form:") (IL:* IL:|;;| "(defsetf access-fn update-fn [doc])") (LET ((UPDATE-FN (CAR REST)) (DOC (CADR REST))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD COMPILE EVAL) (SET-SETF-INVERSE (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, UPDATE-FN)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))) (T (ERROR "Ill-formed DEFSETF for ~S." NAME)))) (XCL:DEFDEFINER (DEFINE-MODIFY-MACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINE-MODIFY-MACRO (IL:\\\, NAME) (IL:\\\,@ (XCL::%MAKE-FUNCTION-PROTOTYPE)))))))) IL: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)) (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) (PUSH ARG OTHER-ARGS)) (T (PUSH (CAR ARG) OTHER-ARGS)))) (SETQ OTHER-ARGS (NREVERSE OTHER-ARGS)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (SI::%$$MODIFY-MACRO-FORM (IL:\\\,@ LAMBDA-LIST) &ENVIRONMENT SI::%$$MODIFY-MACRO-ENVIRONMENT) (IL:\\\, DOC-STRING) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVALS)) (IL:\\\, (IL:\\\, (IF REST-ARG (IL:BQUOTE (LIST* (QUOTE (IL:\\\, FUNCTION)) GETTER (IL:\\\,@ OTHER-ARGS) (IL:\\\, REST-ARG))) (IL:BQUOTE (LIST (QUOTE (IL:\\\, FUNCTION)) GETTER (IL:\\\,@ OTHER-ARGS)))))))) (IL:\\\, SETTER)))))))) (XCL:DEFDEFINER (DEFINE-SETF-METHOD (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINE-SETF-METHOD (IL:\\\, NAME) ("Arg list") "Body")))))) IL: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) (IL:PARSE-DEFMACRO LAMBDA-LIST WHOLE BODY NAME ENV :ENVIRONMENT ENVIRONMENT :ERROR-STRING "Setf expander for ~S cannot be called with ~S args.") (IL:BQUOTE (EVAL-WHEN (EVAL COMPILE LOAD) (DEFUN (IL:\\\, EXPANDER) ((IL:\\\, WHOLE) (IL:\\\, ENVIRONMENT)) (IL:\\\,@ LOCAL-DECS) (BLOCK (IL:\\\, NAME) (IL:\\\, NEWBODY))) (SET-SETF-METHOD-EXPANDER (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, EXPANDER))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC))))))))))) (IL:* IL:|;;| "Support for defstruct and friends ") (XCL:DEFDEFINER DEFINE-SHARED-SETF-MACRO IL:FUNCTIONS (NAME ACCESSOR ARG-LIST STORE-VAR &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "Defines a shared SETF update function for a family of accessores -- used by defstruct") (IF (NOT (AND (CONSP STORE-VAR) (EQ 1 (LENGTH STORE-VAR)))) (ERROR "Store-var should be a list of one element: ~s" STORE-VAR)) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (XCL:PARSE-BODY BODY ENV T) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\, ACCESSOR) (IL:\\\,@ ARG-LIST) (IL:\\\,@ STORE-VAR)) (IL:\\\,@ DOC) (IL:\\\,@ DECLS) (IL:\\\,@ CODE))))) (XCL:DEFDEFINER DEFINE-SHARED-SETF IL:SETFS (NAME SHARED-EXPANDER &OPTIONAL DOC) (IL:* IL:|;;;| "Associates a shared SETF update macro with the specified accessor function -- used by defstruct") (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD COMPILE EVAL) (SET-SHARED-SETF-INVERSE (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, SHARED-EXPANDER)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC))))))))) (DEFUN GET-SHARED-SETF-METHOD (FORM SHARED-SETF-INVERSE) (IL:* IL:|;;| "Produce SETF method for a form that has a shared-setf-inverse. Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (LET ((NEW-VAR (IL:GENSYM)) VARS VALS ARGS SHARED-SETF-INVERSE-FORM GET-FORM) (SETQ ARGS (MAPCAR (FUNCTION (LAMBDA (ARG) (COND ((IF (CONSP ARG) (EQ (CAR ARG) (QUOTE QUOTE)) (CONSTANTP ARG)) (IL:* IL:|;;| "We don't need gensym for this constant argument. The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") ARG) (T (IL:* IL:|;;| "Anything else might be side-effected, so will need to bind") (PUSH ARG VALS) (LET ((G (IL:GENSYM))) (PUSH G VARS) G))))) (CDR FORM))) (SETQ SHARED-SETF-INVERSE-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, SHARED-SETF-INVERSE) (IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS) (IL:\\\, NEW-VAR))))) (SETQ GET-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS))))) (IL:* IL:|;;| "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (VALUES (SETQ VARS (NREVERSE VARS)) (SETQ VALS (NREVERSE VALS)) (LIST NEW-VAR) SHARED-SETF-INVERSE-FORM GET-FORM))) (DEFMACRO SETF (PLACE NEW-VALUE &REST OTHERS &ENVIRONMENT ENV) (IL:* IL:|;;;| "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.") (IL:* IL:|;;;| "We short-circuit the normal SETF-method mechanism for two very common special cases, so as to produce much simpler and more efficient code. The two cases are symbols and forms with simple inverses.") (COND (OTHERS (IL:BQUOTE (PROGN (SETF (IL:\\\, PLACE) (IL:\\\, NEW-VALUE)) (SETF (IL:\\\,@ OTHERS))))) (T (PROG (TEMP) LP (COND ((SYMBOLP PLACE) (RETURN (IL:BQUOTE (SETQ (IL:\\\, PLACE) (IL:\\\, NEW-VALUE))))) ((OR (NOT (CONSP PLACE)) (NOT (SYMBOLP (CAR PLACE)))) (SETF-ERROR PLACE)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR PLACE) ENV)) (IL:* IL:|;;| "Before looking for an inverse, we have to macroexpand until it isn't a reference to a lexical macro, since those can't have SETF methods.") (SETQ PLACE (FUNCALL TEMP PLACE ENV))) ((SETQ TEMP (OR (GET (CAR PLACE) (QUOTE :SETF-INVERSE)) (GET (CAR PLACE) (QUOTE IL:SETF-INVERSE)) (GET (CAR PLACE) (QUOTE IL:SETFN)))) (RETURN (IL:BQUOTE ((IL:\\\, TEMP) (IL:\\\,@ (CDR PLACE)) (IL:\\\, NEW-VALUE))))) ((SETQ TEMP (GET (CAR PLACE) (QUOTE :SHARED-SETF-INVERSE))) (RETURN (IL:BQUOTE ((IL:\\\, TEMP) (IL:\\\, (CAR PLACE)) (IL:\\\,@ (CDR PLACE)) (IL:\\\, NEW-VALUE))))) ((OR (GET (CAR PLACE) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR PLACE) (QUOTE IL:SETF-METHOD-EXPANDER))) (IL:* IL:|;;| "General setf hair") (RETURN (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD-MULTIPLE-VALUE PLACE ENV) (IF (NULL (CDR NEWVALS)) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVALS)) (IL:\\\, NEW-VALUE))) (IL:\\\, SETTER))) (IL:* IL:|;;| "It's one of those multiple-value jobbers...") (IL:BQUOTE (LET* ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS))) (MULTIPLE-VALUE-BIND (IL:\\\, NEWVALS) (IL:\\\, NEW-VALUE) (IL:\\\, SETTER)))))))) ((MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 PLACE ENV) (IL:* IL:|;;| "Try macro expanding") (WHEN (AND DONE (NOT (EQ EXPANSION PLACE))) (SETQ PLACE EXPANSION)))) (T (IL:* IL:|;;| "Nothing worked; we have to assume there's a (defun (setf mumble)...) out there somewhere") (RETURN (LET ((NEW-VALUE-TEMP (GENSYM)) (LET-LIST (MAPCAR (FUNCTION (LAMBDA (X) (LIST (GENSYM) X))) (CDR PLACE)))) (IL:BQUOTE (LET ((IL:\\\,@ LET-LIST) ((IL:\\\, NEW-VALUE-TEMP) (IL:\\\, NEW-VALUE))) (FUNCALL (FUNCTION (SETF (IL:\\\, (CAR PLACE)))) (IL:\\\, NEW-VALUE-TEMP) (IL:\\\,@ (MAPCAR (FUNCTION CAR) LET-LIST))))))))) (GO LP))))) (DEFUN SETF-ERROR (FN &OPTIONAL FORM) (IL:* IL:|;;| "Common error routine for invalid SETF's. FN is the thing we tried to find a setf method for, FORM is its parent (not supplied when the form is a non-list).") (ERROR "~S is not a known location specifier for SETF." FN)) (DEFMACRO PSETF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "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.\"") (DO ((A ARGS (CDDR A)) (LET-LIST NIL) (MV-SET-LIST NIL) (SETF-LIST NIL)) ((ATOM A) (IL:BQUOTE ((IL:\\\, (QUOTE LET)) (IL:\\\, (REVERSE LET-LIST)) (IL:\\\,@ (REVERSE MV-SET-LIST)) (IL:\\\,@ (REVERSE SETF-LIST)) NIL))) (IF (ATOM (CDR A)) (ERROR "Odd number of args to PSETF.")) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD-MULTIPLE-VALUE (CAR A) ENV) (DECLARE (IGNORE GETTER)) (DO* ((D DUMMIES (CDR D)) (V VALS (CDR V))) ((NULL D)) (PUSH (LIST (CAR D) (CAR V)) LET-LIST)) (IF (CDR NEWVAL) (PROGN (SETQ LET-LIST (APPEND NEWVAL LET-LIST)) (PUSH (IL:BQUOTE (MULTIPLE-VALUE-SETQ (IL:\\\, NEWVAL) (IL:\\\, (CADR A)))) MV-SET-LIST)) (PUSH (LIST (CAR NEWVAL) (CADR A)) LET-LIST)) (PUSH SETTER SETF-LIST)))) (DEFMACRO SHIFTF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "Assigns to each place the value of the form to its right, returns old value of 1st") (IL:* IL:|;;| "CLtL2 is ambiguous on whether multiple-values from the first form should be returned or not. Consistencty votes yes, expediency votes no; I choose consistency (screw the New Jersey design philosophy!).") (COND ((OR (NULL ARGS) (NULL (CDR ARGS))) (ERROR "SHIFTF needs at least two arguments")) (T (CL::SHIFTF-INTERNAL ARGS ENV (QUOTE GET-SETF-METHOD-MULTIPLE-VALUE))))) (DEFMACRO ROTATEF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "Assigns to each place the value of the form to its right; last gets first. Returns NIL.") (IL:* IL:|;;| "forms evaluated in order") (COND ((NULL ARGS) NIL) ((NULL (CDR ARGS)) (IL:BQUOTE (PROGN (IL:\\\, (CAR ARGS)) NIL))) (T (CL::ROTATEF-INTERNAL ARGS ENV (QUOTE GET-SETF-METHOD-MULTIPLE-VALUE))))) (DEFMACRO POP (PLACE &ENVIRONMENT ENV) "Pops one item off the front of PLACE and returns it." (IF (SYMBOLP PLACE) (IL:BQUOTE (PROG1 (CAR (IL:\\\, PLACE)) (SETQ (IL:\\\, PLACE) (CDR (IL:\\\, PLACE))))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) (IL:\\\, (LIST (CAR NEWVAL) GETTER))) (PROG1 (CAR (IL:\\\, (CAR NEWVAL))) (SETQ (IL:\\\, (CAR NEWVAL)) (CDR (IL:\\\, (CAR NEWVAL)))) (IL:\\\, SETTER))))))) (DEFMACRO REMF (PLACE INDICATOR &ENVIRONMENT ENV) "Destructively remove INDICATOR from PLACE, returning T if it was present, NIL if not" (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((IND-TEMP (IL:GENSYM)) (LOCAL1 (IL:GENSYM)) (LOCAL2 (IL:GENSYM))) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVAL)) (IL:\\\, GETTER)) ((IL:\\\, IND-TEMP) (IL:\\\, INDICATOR))) (DO (((IL:\\\, LOCAL1) (IL:\\\, (CAR NEWVAL)) (CDDR (IL:\\\, LOCAL1))) ((IL:\\\, LOCAL2) NIL (IL:\\\, LOCAL1))) ((ATOM (IL:\\\, LOCAL1)) NIL) (COND ((ATOM (CDR (IL:\\\, LOCAL1))) (ERROR "Odd-length property list in REMF.")) ((EQ (CAR (IL:\\\, LOCAL1)) (IL:\\\, IND-TEMP)) (COND ((IL:\\\, LOCAL2) (RPLACD (CDR (IL:\\\, LOCAL2)) (CDDR (IL:\\\, LOCAL1))) (RETURN T)) (T (SETQ (IL:\\\, (CAR NEWVAL)) (CDDR (IL:\\\, (CAR NEWVAL)))) (IL:\\\, SETTER) (RETURN T))))))))))) (IL:* IL:|;;| "A little suppost stuff to make writing the undoable versions easier") (DEFUN CL::SHIFTF-INTERNAL (CL::ARGS CL::ENV CL::SETF-METHOD-GETTER) (IL:* IL:\; "Edited 11-Feb-92 15:45 by jrb:") (LET (CL::LET-LIST CL::MV-SET-LIST CL::SETF-LIST CL::GETTER) (FLET ((CL::BIND-LETS (CL::DUMMIES CL::VALS) (DO ((CL::D CL::DUMMIES (CDR CL::D)) (CL::V CL::VALS (CDR CL::V))) ((NULL CL::D)) (PUSH (LIST (CAR CL::D) (CAR CL::V)) CL::LET-LIST))) (CL::HANDLE-GETTER (CL::NEXT-VAR CL::GETTER) (SETQ CL::LET-LIST (APPEND CL::NEXT-VAR CL::LET-LIST)) (PUSH (IF (CDR CL::NEXT-VAR) (IL:BQUOTE (MULTIPLE-VALUE-SETQ (IL:\\\, CL::NEXT-VAR) (IL:\\\, CL::GETTER))) (IL:BQUOTE (SETQ (IL:\\\, (CAR CL::NEXT-VAR)) (IL:\\\, CL::GETTER)))) CL::MV-SET-LIST))) (MULTIPLE-VALUE-BIND (CL::DUMMIES CL::VALS CL::FIRST-NEWVAL CL::SETTER CL::FIRST-GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::ARGS) CL::ENV) (CL::BIND-LETS CL::DUMMIES CL::VALS) (PUSH CL::SETTER CL::SETF-LIST) (DO* ((CL::A (CDR CL::ARGS) (CDR CL::A)) (CL::NEXT-VAR CL::FIRST-NEWVAL) (CL::DUMMIES) (CL::VALS) (CL::NEWVAL) (CL::SETTER)) ((ATOM (CDR CL::A)) (CL::HANDLE-GETTER CL::NEXT-VAR (CAR CL::A)) (IL:BQUOTE (LET* (IL:\\\, (REVERSE CL::LET-LIST)) (MULTIPLE-VALUE-PROG1 (IL:\\\, CL::FIRST-GETTER) (IL:\\\,@ (REVERSE CL::MV-SET-LIST)) (IL:\\\,@ (REVERSE CL::SETF-LIST)))))) (MULTIPLE-VALUE-SETQ (CL::DUMMIES CL::VALS CL::NEWVAL CL::SETTER CL::GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::A) CL::ENV)) (CL::BIND-LETS CL::DUMMIES CL::VALS) (CL::HANDLE-GETTER CL::NEXT-VAR CL::GETTER) (PUSH CL::SETTER CL::SETF-LIST) (SETQ CL::NEXT-VAR CL::NEWVAL)))))) (DEFUN CL::ROTATEF-INTERNAL (CL::ARGS CL::ENV CL::SETF-METHOD-GETTER) (IL:* IL:\; "Edited 12-Feb-92 13:10 by jrb:") (DO ((CL::A CL::ARGS (CDR CL::A)) (CL::LET-LIST NIL) (CL::SETF-LIST NIL) (CL::NEXT-VAR NIL) (CL::FIX-ME NIL)) ((ATOM CL::A) (SETF (FIRST CL::FIX-ME) (IF (CDR CL::NEXT-VAR) CL::NEXT-VAR (CAR CL::NEXT-VAR))) (IL:BQUOTE (CL::MV-LET* (IL:\\\, (REVERSE CL::LET-LIST)) (IL:\\\,@ (REVERSE CL::SETF-LIST)) NIL))) (MULTIPLE-VALUE-BIND (CL::DUMMIES CL::VALS CL::NEWVAL CL::SETTER CL::GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::A) CL::ENV) (DO ((CL::D CL::DUMMIES (CDR CL::D)) (CL::V CL::VALS (CDR CL::V))) ((NULL CL::D)) (PUSH (LIST (CAR CL::D) (CAR CL::V)) CL::LET-LIST)) (PUSH (LIST (IF (CDR CL::NEXT-VAR) CL::NEXT-VAR (CAR CL::NEXT-VAR)) CL::GETTER) CL::LET-LIST) (UNLESS CL::FIX-ME (SETQ CL::FIX-ME (CAR CL::LET-LIST))) (PUSH CL::SETTER CL::SETF-LIST) (SETQ CL::NEXT-VAR CL::NEWVAL)))) (IL:* IL:|;;| "A little support macro to make ROTATEF prettier") (DEFMACRO CL::MV-LET* (CL::BINDING-LIST &REST CL::FORMS) (IF (NULL CL::BINDING-LIST) (IL:BQUOTE (LAMBDA NIL (IL:\\\,@ CL::FORMS))) (LABELS ((CL::MUNCH-CLAUSE (CL::BINDING-LIST) (LET ((CL::CLAUSE (POP CL::BINDING-LIST))) (IF (CONSP (CAR CL::CLAUSE)) (IL:BQUOTE (MULTIPLE-VALUE-BIND (IL:\\\, (CAR CL::CLAUSE)) (IL:\\\, (CADR CL::CLAUSE)) (IL:\\\,@ (IF CL::BINDING-LIST (LIST (CL::MUNCH-CLAUSE CL::BINDING-LIST)) CL::FORMS)))) (IL:BQUOTE ((LAMBDA ((IL:\\\, (CAR CL::CLAUSE))) (IL:\\\,@ (IF CL::BINDING-LIST (LIST (CL::MUNCH-CLAUSE CL::BINDING-LIST)) CL::FORMS))) (IL:\\\, (CADR CL::CLAUSE)))))))) (CL::MUNCH-CLAUSE CL::BINDING-LIST)))) (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.") (DEFUN MAYBE-MAKE-BINDING-FORM (NEWVAL-FORM DUMMIES VALS NEWVAR SETTER GETTER) (IL:* IL:|;;| "For use in SETF-like forms to produce their final expression without using the NEWVAR gensym where possible. DUMMIES thru GETTER are the five values returned from the SETF method. NEWVAL-FORM is an expression to which the (sole) NEWVAR is logically to be bound, written in terms of the GETTER form. If it looks like there are no side-effect problems, we substitute NEWVAL-FORM into SETTER; otherwise we return a binding form that returns SETTER correctly.") (IF (OR DUMMIES (> (COUNT-OCCURRENCES (CAR NEWVAR) SETTER) 1)) (IL:* IL:\; " have to do messy binding form") (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVAR)) (IL:\\\, NEWVAL-FORM))) (IL:\\\, SETTER))) (IL:* IL:\; "No temp vars, setter used only once, so nothing can be side-effected, so store it directly") (SUBST NEWVAL-FORM (CAR NEWVAR) SETTER))) (DEFUN COUNT-OCCURRENCES (SYMBOL FORM) (COND ((CONSP FORM) (+ (COUNT-OCCURRENCES SYMBOL (CAR FORM)) (COUNT-OCCURRENCES SYMBOL (CDR FORM)))) ((EQ SYMBOL FORM) 1) (T 0))) (DEFMACRO CL::SETF-NAME-P (CL::THING) (IL:BQUOTE (AND (CONSP (IL:\\\, CL::THING)) (EQ (CAR (IL:\\\, CL::THING)) (QUOTE SETF)) (CONSP (CDR (IL:\\\, CL::THING))) (SYMBOLP (CADR (IL:\\\, CL::THING)))))) (DEFUN XCL::DEFUN-SETF-NAME (XCL::REAL-NAME) (XCL:PACK (LIST XCL::REAL-NAME "-defun-setf") (SYMBOL-PACKAGE XCL::REAL-NAME))) (DEFUN XCL::SET-DEFUN-SETF (XCL::NAME XCL::DEFUN-SETF-FN) (REMPROP XCL::NAME (QUOTE IL:SETF-METHOD-EXPANDER)) (REMPROP XCL::NAME :SETF-METHOD-EXPANDER) (REMPROP XCL::NAME :SETF-INVERSE) (SETF (GET XCL::NAME :SETF-DEFUN) XCL::DEFUN-SETF-FN)) (DEFMACRO PUSH (OBJ PLACE &ENVIRONMENT ENV) "Conses OBJ onto PLACE, returning the modified list." (IF (SYMBOLP PLACE) (IL:BQUOTE (SETQ (IL:\\\, PLACE) (CONS (IL:\\\, OBJ) (IL:\\\, PLACE)))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (MAYBE-MAKE-BINDING-FORM (IL:BQUOTE (CONS (IL:\\\, OBJ) (IL:\\\, GETTER))) DUMMIES VALS NEWVAL SETTER GETTER)))) (DEFMACRO PUSHNEW (OBJ PLACE &REST KEYS &ENVIRONMENT ENV) "Conses OBJ onto PLACE unless its already there, using :TEST if necessary" (IF (SYMBOLP PLACE) (IL:BQUOTE (SETQ (IL:\\\, PLACE) (ADJOIN (IL:\\\, OBJ) (IL:\\\, PLACE) (IL:\\\,@ KEYS)))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (MAYBE-MAKE-BINDING-FORM (IL:BQUOTE (ADJOIN (IL:\\\, OBJ) (IL:\\\, GETTER) (IL:\\\,@ KEYS))) DUMMIES VALS NEWVAL SETTER GETTER)))) (DEFSETF CAR (X) (V) (IL:BQUOTE (CAR (RPLACA (IL:\\\, X) (IL:\\\, V))))) (DEFSETF CDR (X) (V) (IL:BQUOTE (CDR (RPLACD (IL:\\\, X) (IL:\\\, V))))) (DEFSETF CAAAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAAAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CAAADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAADR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CAAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CAADAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CAADDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CAADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDAAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDADR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADDAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADDDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDAAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAAAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDAADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAADR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDADAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDADDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDAAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDADR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDAR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF CDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF FIRST (X) (V) (IL:BQUOTE (CAR (RPLACA (IL:\\\, X) (IL:\\\, V))))) (DEFSETF SECOND (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF THIRD (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF FOURTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF FIFTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDDR (IL:\\\, X)) (IL:\\\, V))))) (DEFSETF SIXTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (CDDDDR (IL:\\\, X))) (IL:\\\, V))))) (DEFSETF SEVENTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V))))) (DEFSETF EIGHTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V))))) (DEFSETF NINTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V))))) (DEFSETF TENTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (CDDDDR (CDDDDR (IL:\\\, X)))) (IL:\\\, V))))) (DEFSETF REST (X) (V) (IL:BQUOTE (CDR (RPLACD (IL:\\\, X) (IL:\\\, V))))) (DEFSETF NTHCDR (N LIST) (NEWVAL) (IL:BQUOTE (CDR (RPLACD (NTHCDR (1- (IL:\\\, N)) (IL:\\\, LIST)) (IL:\\\, NEWVAL))))) (DEFSETF NTH %SET-NTH) (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 (IL:GENSYM)) (PTEMP (IL:GENSYM)) (DEF-TEMP (IL:GENSYM))) (VALUES (IL:BQUOTE ((IL:\\\,@ TEMPS) (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEF-TEMP))))))) (IL:BQUOTE ((IL:\\\,@ VALUES) (IL:\\\, GET) (IL:\\\, PROP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEFAULT))))))) (IL:BQUOTE ((IL:\\\, NEWVAL))) (IL:BQUOTE (COND ((NULL (IL:\\\, (CAR STORES))) (LET* (IL:\\\, (LIST (APPEND STORES (IL:BQUOTE ((LIST (IL:\\\, PTEMP) (IL:\\\, NEWVAL))))))) (IL:\\\, SET)) (IL:\\\, NEWVAL)) (T (IL:LISTPUT (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\, NEWVAL))))) (IL:BQUOTE (GETF (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEF-TEMP))))))))))) (DEFINE-SETF-METHOD APPLY (FN &REST ARGS &ENVIRONMENT ENV) (IF (AND (CONSP FN) (EQ (LENGTH FN) 2) (MEMBER (FIRST FN) (QUOTE (FUNCTION IL:FUNCTION QUOTE)) :TEST (FUNCTION EQ)) (SYMBOLP (SECOND FN))) (SETQ FN (SECOND FN)) (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 FN ARGS) ENV) (IL:* IL:|;;| "Make sure the place is one that we can handle.") (UNLESS (AND (EQ (CAR (LAST ARGS)) (CAR (LAST VALS))) (EQ (CAR (LAST GETTER)) (CAR (LAST DUMMIES))) (EQ (CAR (LAST SETTER)) (CAR (LAST DUMMIES)))) (ERROR "Apply of ~S not understood as a location for Setf." FN)) (VALUES DUMMIES VALS NEWVAL (IL:BQUOTE (APPLY (FUNCTION (IL:\\\, (CAR SETTER))) (IL:\\\,@ (CDR SETTER)))) (IL:BQUOTE (APPLY (FUNCTION (IL:\\\, (CAR GETTER))) (IL:\\\,@ (CDR GETTER))))))) (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 (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (CONS BTEMP DUMMIES) (CONS BYTESPEC VALS) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (DPB (IL:\\\, GNUVAL) (IL:\\\, BTEMP) (IL:\\\, GETTER)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (LDB (IL:\\\, BTEMP) (IL:\\\, 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 (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (CONS BTEMP DUMMIES) (CONS BYTESPEC VALS) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (DEPOSIT-FIELD (IL:\\\, GNUVAL) (IL:\\\, BTEMP) (IL:\\\, GETTER)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (MASK-FIELD (IL:\\\, BTEMP) (IL:\\\, 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 (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (IL:BQUOTE ((IL:\\\,@ DUMMIES) (IL:\\\, BTEMP))) (IL:BQUOTE ((IL:\\\,@ VALS) (IL:\\\, BIT-NAME))) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (SET-CHAR-BIT (IL:\\\, GETTER) (IL:\\\, BTEMP) (IL:\\\, GNUVAL)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (CHAR-BIT (IL:\\\, GETTER) (IL:\\\, 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 (SUBST (IL:BQUOTE (THE (IL:\\\, TYPE) (IL:\\\, (CAR NEWVAL)))) (CAR NEWVAL) SETTER) (IL:BQUOTE (THE (IL:\\\, TYPE) (IL:\\\, GETTER)))))) (DEFSETF CL:FDEFINITION CL::SET-FDEFINITION) (IL:* IL:\; "Some IL setfs, for no especially good reason") (DEFSETF IL:GETHASH IL:%SET-IL-GETHASH) (DEFMACRO IL:%SET-IL-GETHASH (KEY HASH-TABLE &OPTIONAL NEWVALUE) (IL:* IL:|;;| "SETF inverse for IL:GETHASH. Tricky parts are that args to IL:PUTHASH are in wrong order, and IL:GETHASH might default its second arg (yuck, let's flush that), in which case the third arg is absent and the second is the new value.") (COND ((NOT NEWVALUE) (IL:* IL:\; "Defaulted hash table") (IL:BQUOTE (IL:PUTHASH (IL:\\\, KEY) (IL:\\\, HASH-TABLE)))) ((OR (IL:CONSTANTEXPRESSIONP NEWVALUE) (AND (SYMBOLP NEWVALUE) (SYMBOLP HASH-TABLE))) (IL:* IL:\; "Ok to swap args") (IL:BQUOTE (IL:PUTHASH (IL:\\\, KEY) (IL:\\\, NEWVALUE) (IL:\\\, HASH-TABLE)))) (T (IL:BQUOTE (LET (IL:$$GETHASH-TABLE) (DECLARE (IL:LOCALVARS IL:$$GETHASH-TABLE)) (IL:PUTHASH (IL:\\\, KEY) (PROGN (IL:SETQ IL:$$GETHASH-TABLE (IL:\\\, HASH-TABLE)) (IL:\\\, NEWVALUE)) IL:$$GETHASH-TABLE)))))) (IL:PUTPROPS :SETF-METHOD-EXPANDER IL:PROPTYPE IGNORE) (IL:PUTPROPS :SETF-INVERSE IL:PROPTYPE IGNORE) (IL:PUTPROPS :SHARED-SETF-INVERSE IL:PROPTYPE IGNORE) (IL:PUTPROPS IL:CMLSETF IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:CMLSETF IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA) (IL:ADDTOVAR IL:NLAML) (IL:ADDTOVAR IL:LAMA) ) (IL:PUTPROPS IL:CMLSETF IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP