(FILECREATED "24-Apr-85 16:53:19" {ERIS}<LISPUSERS>SETF.;10 10398
changes to: (VARS SETFCOMS)
(FNS SETF.DECLARERECORD SETF.DECLARERECORD1 SETF.TYPE&FIELD)
previous date: "24-Apr-85 16:49:22" {ERIS}<LISPUSERS>SETF.DCOM;1)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SETFCOMS)
(RPAQQ SETFCOMS ((* SETF -- By Kelly Roach *)
(PROPS (setf CLISPWORD)
(SETF CLISPWORD)
(CAR SETFDEF)
(CDR SETFDEF)
(ELT SETFDEF)
(SETF.CLISP ARGNAMES)
(SETF TRAN)
(SETF.TRAN ARGNAMES))
(FNS SETF.DECLARERECORD SETF.DECLARERECORD1 SETF.TYPE&FIELD SETF.FIXDATUM SETF.ELT
SETF.CLISP SETF.CLISP1 SETF.TRAN SETF.HELPER)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? 'DECLARERECORD 'SETF.OLD.DECLARERECORD)
(MOVD 'SETF.DECLARERECORD 'DECLARERECORD)
(MOVD? '\RECORDBLOCK/FIXDATUM 'SETF.OLD.FIXDATUM)
(MOVD 'SETF.FIXDATUM '\RECORDBLOCK/FIXDATUM)
(FOR R IN USERRECLST DO (SETF.DECLARERECORD1
R))
(FOR R IN SYSTEMRECLST DO (SETF.DECLARERECORD1
R))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SETF.TRAN SETF.CLISP)
(NLAML)
(LAMA)))))
(* SETF -- By Kelly Roach *)
(PUTPROPS setf CLISPWORD (SETF.CLISP . setf))
(PUTPROPS SETF CLISPWORD (SETF.CLISP . SETF))
(PUTPROPS CAR SETFDEF (RPLACA DATUM NEWVALUE))
(PUTPROPS CDR SETFDEF (RPLACD DATUM NEWVALUE))
(PUTPROPS ELT SETFDEF SETF.ELT)
(PUTPROPS SETF.CLISP ARGNAMES (SEX))
(PUTPROPS SETF TRAN SETF.TRAN)
(PUTPROPS SETF.TRAN ARGNAMES (SEX))
(DEFINEQ
(SETF.DECLARERECORD
(LAMBDA (DEC) (* kbr: "24-Apr-85 16:50")
(* Redefine Interlisp DECLARERECORD to give SETFing
capability. *)
(PROG (ANSWER)
(SETQ ANSWER (SETF.OLD.DECLARERECORD DEC))
(SETF.DECLARERECORD1 DEC)
(RETURN ANSWER))))
(SETF.DECLARERECORD1
(LAMBDA (DEC) (* kbr: "24-Apr-85 16:50")
(PROG (TYPE ANSWER)
(SETQ TYPE (CADR DEC)) (* Flush old definition? *)
(* New definition. *)
(COND
((LITATOM TYPE)
(PUTPROP TYPE 'SETF (for FIELD in (RECORDFIELDNAMES TYPE) collect (SETF.TYPE&FIELD
TYPE FIELD)))))
(RETURN ANSWER))))
(SETF.TYPE&FIELD
(LAMBDA (TYPE FIELD) (* kbr: "24-Apr-85 16:50")
(* Define SETF access form for FIELD of TYPE.
*)
(PROG (TYPE.FIELD TYPE&FIELD)
(SETQ TYPE.FIELD (PACK* TYPE "." FIELD))
(SETQ TYPE&FIELD `(,TYPE ,FIELD))
(PUTPROP TYPE.FIELD 'TYPE&FIELD TYPE&FIELD)
(PUTPROP TYPE.FIELD 'CLISPWORD `(SETF.CLISP . ,TYPE.FIELD))
(PUTPROP TYPE.FIELD 'TRAN 'SETF.TRAN)
(RETURN TYPE&FIELD))))
(SETF.FIXDATUM
(LAMBDA (FORM DECLST) (* kbr: "14-Mar-85 19:04")
(PROG (TYPE&FIELD ANSWER)
(COND
((AND (LISTP FORM)
(SETQ TYPE&FIELD (GETPROP (CAR FORM)
'TYPE&FIELD)))
(SETQ ANSWER (SETF.OLD.FIXDATUM `(fetch ,(COPY TYPE&FIELD) of ,(CADR FORM))
DECLST)))
(T (SETQ ANSWER (SETF.OLD.FIXDATUM FORM DECLST))))
(RETURN ANSWER))))
(SETF.ELT
(LAMBDA (SEX) (* kbr: " 8-Jul-84 12:17")
(* SEX has form "(SETF (ELT ARRAY N) NEWVALUE)" *)
`(SETA ,(CADR (CADR SEX))
,(CADDR (CADR SEX))
,(CADDR SEX))))
(SETF.CLISP
(NLAMBDA $FEXPR$ (* kbr: " 8-Jul-84 12:17")
((LAMBDA (SEX) (* Trying to imitate RECORD package RECORDTRAN here.
*)
(DECLARE (GLOBALVARS PATGENSYMVARS))
(LISPXWATCH RECORDSTATS)
(RESETVARS ((PATGENSYMVARS PATGENSYMVARS))
(SETQ CLISPCHANGE T)
(RETURN (SETF.CLISP1 SEX))))
(POP $FEXPR$))))
(SETF.CLISP1
(LAMBDA (SEX)
(DECLARE (GLOBALVARS DWIMESSGAG NOSPELLFLG)) (* kbr: "13-Aug-84 22:44")
(PROG (REF TYPE.FIELD TYPE&FIELD TYPE FIELD DATUM NEWVALUE ACCESS BINDINGS DECLST DEF)
(COND
((MEMB (CAR SEX)
(LIST 'setf 'SETF))
(SETQ REF (CADR SEX)))
(T (SETQ REF SEX)))
(SETQ TYPE.FIELD (CAR REF)) (* NONRECORD CASE *)
(COND
((SETQ DEF (GETPROP TYPE.FIELD 'SETFDEF))
(COND
((LITATOM DEF)
(SETQ DEF (APPLY* DEF SEX)))
(T (SETQ DATUM (CADR REF))
(SETQ NEWVALUE (CADDR SEX))
(SETQ DEF (DSUBST NEWVALUE 'NEWVALUE (SUBST DATUM 'DATUM DEF)))))
(CLISPTRAN SEX DEF)
(RETURN SEX))) (* RECORD CASE *)
RETRY
(SETQ TYPE&FIELD (GETPROP TYPE.FIELD 'TYPE&FIELD))
(COND
((NULL TYPE&FIELD)
(SETQ FAULTX SEX)
(SETF.HELPER)
(SETQ TYPE&FIELD (GETPROP TYPE.FIELD 'TYPE&FIELD))
(COND
((NULL TYPE&FIELD)
(PRINT `(No TYPE&FIELD property for ,TYPE.FIELD)
T)
(BREAK1 NIL T)
(GO RETRY)))))
(SETQ TYPE (CAR TYPE&FIELD))
(SETQ FIELD (CADR TYPE&FIELD))
(SETQ DATUM (CADR REF)) (* Use \RECORDBLOCK fns from RECORD package to compute
expansion. *)
(SETQ ACCESS (\RECORDBLOCK/ACCESSDEF TYPE&FIELD DATUM `(,TYPE&FIELD of ,DATUM)
NIL))
(COND
((MEMB (CAR SEX)
(LIST 'setf 'SETF))
(SETQ NEWVALUE (CADDR SEX))
(\RECORDBLOCK/DWIMIFYREC (CDR (CADR SEX))
NIL
(CADR SEX)
T)
(\RECORDBLOCK/DWIMIFYREC (CDDR SEX)
NIL SEX)
(SETQ DEF (\RECORDBLOCK/MAKEACCESS ACCESS DATUM `(,NEWVALUE)
'replace)))
(T (\RECORDBLOCK/DWIMIFYREC (CDR SEX)
NIL SEX)
(SETQ DEF (\RECORDBLOCK/MAKEACCESS ACCESS DATUM NIL 'fetch))))
(COND
(BINDINGS (SETQ DEF (\RECORDBLOCK/EMBEDPROG DEF))))
(RESETVARS ((DWIMESSGAG T)
(NOSPELLFLG T))
(RETURN (PROG (LISPXHIST)
(DECLARE (SPECVARS LISPXHIST DWIMESSGAG NOSPELLFLG))
(DWIMIFY0? DEF DEF NIL NIL NIL FAULTFN 'VARBOUND))))
(COND
((NOT (LISTP DEF))
(SETQ DEF `(PROGN ,DEF))))
(CLISPTRAN SEX DEF)
(RETURN SEX))))
(SETF.TRAN
(NLAMBDA $FEXPR$ (* kbr: "14-Mar-85 19:06")
((LAMBDA (SEX)
(PROG (REF TYPE.FIELD TYPE&FIELD TYPE FIELD DATUM NEWVALUE ACCESS DEF ANSWER)
(COND
((MEMB (CAR SEX)
(LIST 'setf 'SETF))
(SETQ REF (CADR SEX)))
(T (SETQ REF SEX)))
(SETQ TYPE.FIELD (CAR REF)) (* NONRECORD CASE *)
(COND
((SETQ DEF (GETPROP TYPE.FIELD 'SETFDEF))
(COND
((LITATOM DEF)
(SETQ DEF (APPLY* DEF SEX)))
(T (SETQ DATUM (CADR REF))
(SETQ NEWVALUE (CADDR SEX))
(SETQ DEF (DSUBST NEWVALUE 'NEWVALUE (SUBST DATUM 'DATUM DEF)))))
(RPLACA SEX (CAR DEF))
(RPLACD SEX (CDR DEF))
(RETURN SEX))) (* RECORD CASE *)
RETRY
(SETQ TYPE&FIELD (GETPROP TYPE.FIELD 'TYPE&FIELD))
(COND
((NULL TYPE&FIELD)
(SETQ FAULTX SEX)
(SETF.HELPER)
(SETQ TYPE&FIELD (GETPROP TYPE.FIELD 'TYPE&FIELD))
(COND
((NULL TYPE&FIELD)
(PRINT `(No TYPE&FIELD property for ,TYPE.FIELD)
T)
(BREAK1 NIL T)
(GO RETRY)))))
(SETQ DATUM (CADR REF))
(COND
((MEMB (CAR SEX)
(LIST 'setf 'SETF))
(SETQ NEWVALUE (CADDR SEX))
(SETQ ANSWER `(replace ,(COPY TYPE&FIELD) of ,DATUM with ,NEWVALUE)))
(T (SETQ ANSWER `(fetch ,(COPY TYPE&FIELD) of ,DATUM))))
(RPLACA SEX (CAR ANSWER))
(RPLACD SEX (CDR ANSWER))
(RETURN SEX)))
(POP $FEXPR$))))
(SETF.HELPER
(LAMBDA NIL (* kbr: " 8-Jul-84 12:17")
(* Placed on DWIMUSERFORMS. *)
(* Lets SETF work on other user%'s and system records.
*)
(DECLARE (USEDFREE FAULTX))
(PROG (P TYPE.FIELD TYPE FIELD DEC)
(COND
((NOT (LISTP FAULTX))
(RETURN NIL))
((EQ (CAR FAULTX)
'SETF)
(SETQ TYPE.FIELD (CAR (CADR FAULTX))))
(T (SETQ TYPE.FIELD (CAR FAULTX))))
(COND
((OR (NOT (LITATOM TYPE.FIELD))
(GETPROP TYPE.FIELD 'TYPE&FIELD))
(RETURN NIL)))
(SETQ P (STRPOS "." TYPE.FIELD))
(COND
((OR (NULL P)
(IEQP P 1)
(IEQP P (NCHARS TYPE.FIELD)))
(RETURN NIL)))
(SETQ TYPE (SUBATOM TYPE.FIELD 1 (SUB1 P)))
(SETQ FIELD (SUBATOM TYPE.FIELD (ADD1 P)
-1))
(SETQ DEC (RECLOOK TYPE))
(COND
((MEMB FIELD (RECORDFIELDNAMES DEC)) (* Simply redeclare. *)
(EVAL DEC)
(RETURN FAULTX))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD? 'DECLARERECORD 'SETF.OLD.DECLARERECORD)
(MOVD 'SETF.DECLARERECORD 'DECLARERECORD)
(MOVD? '\RECORDBLOCK/FIXDATUM 'SETF.OLD.FIXDATUM)
(MOVD 'SETF.FIXDATUM '\RECORDBLOCK/FIXDATUM)
(FOR R IN USERRECLST DO (SETF.DECLARERECORD1 R))
(FOR R IN SYSTEMRECLST DO (SETF.DECLARERECORD1 R))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SETF.TRAN SETF.CLISP)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS SETF COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1633 9848 (SETF.DECLARERECORD 1643 . 2060) (SETF.DECLARERECORD1 2062 . 2614) (
SETF.TYPE&FIELD 2616 . 3236) (SETF.FIXDATUM 3238 . 3740) (SETF.ELT 3742 . 4041) (SETF.CLISP 4043 .
4504) (SETF.CLISP1 4506 . 6909) (SETF.TRAN 6911 . 8682) (SETF.HELPER 8684 . 9846)))))
STOP