github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-27 01:19:42 +00:00
Code Issues Projects Releases Wiki Activity

make SETQ and typed in calls undoable (first steps) (#996)

Browse Source 
* First steps to make UNDO to work again

* make sure the right SETQ (CL vs IL) is used

* The change surfaced a irritating warning about the variable presumed to be SPECIAL
This commit is contained in:
Larry Masinter
2022-10-25 15:40:41 -07:00
committed by GitHub
parent d5d21397d4
commit d0d952a10d
2 changed files with 149 additions and 128 deletions
Download Patch File Download Diff File Expand all files Collapse all files

277
sources/CMLUNDO
View File

@@ -1,13 +1,13 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
(IL:FILECREATED "16-May-90 14:54:01" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLUNDO.;2| 30797
(DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10)
IL:|changes| IL:|to:| (IL:VARS IL:CMLUNDOCOMS)
(IL:FILECREATED "18-Oct-2022 16:24:32" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;2| 31891
IL:|previous| IL:|date:| "29-Feb-88 19:40:15" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLUNDO.;1|
)
:CHANGES-TO (IL:FUNCTIONS UNDOABLY)
:PREVIOUS-DATE "15-Oct-2022 17:21:17" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;1|)
; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
; Copyright (c) 1986-1988, 1990, 2022 by Venue & Xerox Corporation.
(IL:PRETTYCOMPRINT IL:CMLUNDOCOMS)
@@ -38,7 +38,7 @@
(PSETF . UNDOABLY-PSETF)
(PUSH . UNDOABLY-PUSH)
(PUSHNEW . UNDOABLY-PUSHNEW)
((REMF) . UNDOABLY-REMF)
(REMF . UNDOABLY-REMF)
(ROTATEF . UNDOABLY-ROTATEF)
(SHIFTF . UNDOABLY-SHIFTF)
(DECF . UNDOABLY-DECF)
@@ -69,60 +69,75 @@
(DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
(APPLY FN ARGS))
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV)
(WALK-FORM
(IL:MKPROGN FORMS)
:ENVIRONMENT ENV :WALK-FUNCTION
#'(LAMBDA
(X CONTEXT)
(COND
((NOT (CONSP X))
X)
((NOT (SYMBOLP (CAR X)))
X)
(T
(CASE (CAR X)
((SETQ SETQ SETF)
(VALUES
(IL:MKPROGN
(WITH-COLLECTION
(DO ((TAIL (CDR X)
(CDDR TAIL)))
((NULL TAIL))
(COLLECT
(IF (SYMBOLP (CAR TAIL))
(IF (VARIABLE-LEXICAL-P (CAR TAIL))
`(SETQ ,(CAR TAIL)
,(WALK-FORM-INTERNAL (CADR TAIL)))
(PROGN (WARN "Variable ~S presumed special in UNDOABLY.. SETQ"
(CAR TAIL))
`(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
,(WALK-FORM-INTERNAL (CADR TAIL)))))
(MULTIPLE-VALUE-BIND
(FORMALS ACTUALS NEW-VALUE SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD (CAR TAIL))
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
(LIST X (WALK-FORM-INTERNAL Y)))
FORMALS ACTUALS)
(,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
,(CADR TAIL)))
,SETTER)))))))
T))
(STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
T))
(T (LET ((UNDONAME (CDR (MEMBER (CAR X)
IL:LISPXFNS :TEST #'EQ))))
(IF UNDONAME
(CONS UNDONAME (CDR X))
(IF (AND (OR (GET (CAR X)
':DEFINER-FOR)
(GET (CAR X)
'IL:DEFINER-FOR))
(NOT *IN-DEFINER*))
(LET ((*IN-DEFINER* T))
(VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
T))
X))))))))))
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (IL:* IL:\; "Edited 18-Oct-2022 16:20 by lmm")
(IL:* IL:\; "Edited 15-Oct-2022 11:47 by lmm")
(IF (NULL IL:LISPXHIST)
(IL:MKPROGN FORMS)
(WALK-FORM
(IL:MKPROGN FORMS)
:ENVIRONMENT ENV :WALK-FUNCTION
#'(LAMBDA
(X CONTEXT)
(COND
((NOT (CONSP X))
X)
((NOT (SYMBOLP (CAR X)))
X)
(T
(CASE (CAR X)
((SETQ IL:SETQ SETF)
(VALUES
(IL:MKPROGN
(WITH-COLLECTION
(DO ((TAIL (CDR X)
(CDDR TAIL)))
((NULL TAIL))
(COLLECT
(IF (SYMBOLP (CAR TAIL))
(IF (VARIABLE-LEXICAL-P (CAR TAIL))
`(,(CAR X)
,(CAR TAIL)
,(WALK-FORM-INTERNAL (CADR TAIL)))
(PROGN (COND
((NOT (OR (VARIABLE-SPECIAL-P (CAR TAIL))
(BOUNDP (CAR TAIL))))
(IL:* IL:|;;| "should possibly spelling correct? ")
(WHEN NIL
(IL:* IL:|;;| "this warning just seems uselsss; it doesn't proclaim anything or mark it as changed in FILEPKG or ...")
(WARN
"Variable ~S proclaimed SPECIAL UNDOABLY.. SETQ"
(CAR TAIL)))))
`(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
,(WALK-FORM-INTERNAL (CADR TAIL)))))
(MULTIPLE-VALUE-BIND
(FORMALS ACTUALS NEW-VALUE SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD (CAR TAIL))
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
(LIST X (WALK-FORM-INTERNAL Y)))
FORMALS ACTUALS)
(,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
,(CADR TAIL)))
,SETTER)))))))
T))
(STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
T))
(T (LET ((UNDONAME (CDR (ASSOC (CAR X)
IL:LISPXFNS :TEST #'EQ))))
(IF UNDONAME
(CONS UNDONAME (CDR X))
(IF (AND (OR (GET (CAR X)
':DEFINER-FOR)
(GET (CAR X)
'IL:DEFINER-FOR))
(NOT *IN-DEFINER*))
(LET ((*IN-DEFINER* T))
(VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
T))
X)))))))))))
(DEFUN UNDOABLY-FMAKUNBOUND (SYMBOL)
(IL:/PUTD SYMBOL NIL)
@@ -137,11 +152,9 @@
(IL:* IL:|;;| "Make a symbol unbound.")
(IL:SAVESET SYMBOL 'IL:NOBIND) (IL:* IL:\;
 " unbound symbols are set to IL:NOBIND")
(IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH) (IL:* IL:\;
 "remove any constant entry")
(IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL) (IL:* IL:\;
 " left by PROCLAIM special")
 " unbound symbols are set to IL:NOBIND")
(IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH) (IL:* IL:\; "remove any constant entry")
(IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL) (IL:* IL:\; " left by PROCLAIM special")
(IL:/REMPROP SYMBOL 'IL:GLOBALVAR) (IL:* IL:\; "")
SYMBOL)
@@ -155,19 +168,19 @@
(IL:* IL:|;;| "assumes variable is not lexical !")
`(UNDOABLY-SET-SYMBOL ',PLACE ,NEW-VALUE))
`(UNDOABLY-SET-SYMBOL ',PLACE ,NEW-VALUE))
(T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
(,(CAR NEWVAL)
,NEW-VALUE))
,SETTER)))))
(DEFUN UNDOHOOK (FORM ENV &AUX (*APPLYHOOK* NIL))
(DEFUN UNDOHOOK (FORM ENV &AUX (*APPLYHOOK* NIL)) (IL:* IL:\; "Edited 14-Oct-2022 13:54 by lmm")
(IF (ATOM FORM)
(EVAL FORM ENV)
(CASE (CAR FORM)
((SETQ SETQ SETF)
((SETQ IL:SETQ SETF)
(DO ((TAIL (CDR FORM))
VALUE)
((NULL TAIL)
@@ -175,8 +188,8 @@
(SETQ
VALUE
(IF (SYMBOLP (CAR TAIL))
(UNDOABLY-SET-SYMBOL (POP TAIL)
(UNDOHOOK (POP TAIL)
(UNDOABLY-SET-SYMBOL (POP TAIL)
(UNDOHOOK (POP TAIL)
ENV)
ENV)
(EVAL
@@ -184,13 +197,13 @@
(MULTIPLE-VALUE-BIND
(FORMALS VALS NEW-VALUE SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD (POP TAIL)
(GET-UNDOABLE-SETF-METHOD (POP TAIL)
ENV)
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
(LIST X (LIST 'UNDOABLY Y)))
FORMALS VALS)
(,(CAR NEW-VALUE)
(UNDOABLY ,(POP TAIL))))
(UNDOABLY ,(POP TAIL))))
,SETTER))
ENV)))))
(STOP-UNDOABLY
@@ -199,7 +212,7 @@
(IL:\\EVAL-PROGN (CDR FORM)
ENV))
(T (LET ((UNDONAME (CDR (MEMBER (CAR FORM)
(T (LET ((UNDONAME (CDR (ASSOC (CAR FORM)
IL:LISPXFNS :TEST #'EQ))))
(IF UNDONAME
(EVALHOOK (CONS UNDONAME (CDR FORM))
@@ -215,16 +228,16 @@
((NULL ARGS)
NIL)
(T `(PROG1 NIL
(UNDOABLY-SETF ,(POP ARGS)
(UNDOABLY-SETF ,(POP ARGS)
(PROG1 ,(POP ARGS)
(UNDOABLY-PSETF ,@ARGS)))))))
(UNDOABLY-PSETF ,@ARGS)))))))
(DEFMACRO UNDOABLY-POP (PLACE &ENVIRONMENT ENV)
(IF (SYMBOLP PLACE)
`(PROG1 (CAR ,PLACE)
(UNDOABLY-SETQ ,PLACE (CDR ,PLACE)))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
,(LIST (CAR NEWVAL)
GETTER))
@@ -240,7 +253,7 @@
(IF (SYMBOLP PLACE)
`(UNDOABLY-SETQ ,PLACE (CONS ,OBJ ,PLACE))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
(,(CAR NEWVAL)
(CONS ,OBJ ,GETTER)))
@@ -250,7 +263,7 @@
(IF (SYMBOLP PLACE)
`(UNDOABLY-SETQ ,PLACE (ADJOIN ,OBJ ,PLACE ,@KEYS))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
(,(CAR NEWVAL)
(ADJOIN ,OBJ ,GETTER ,@KEYS)))
@@ -258,7 +271,7 @@
(DEFMACRO UNDOABLY-REMF (PLACE INDICATOR &ENVIRONMENT ENV)
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
(LET ((IND-TEMP (GENSYM))
(LOCAL1 (GENSYM))
(LOCAL2 (GENSYM)))
@@ -303,7 +316,7 @@
,@(REVERSE SETF-LIST)
NIL))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD (CAR A)
(GET-UNDOABLE-SETF-METHOD (CAR A)
ENV)
(DO ((D DUMMIES (CDR D))
(V VALS (CDR V)))
@@ -335,7 +348,7 @@
,@(REVERSE SETF-LIST)
,RESULT))
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD (CAR A)
(GET-UNDOABLE-SETF-METHOD (CAR A)
ENV)
(DO ((D DUMMIES (CDR D))
(V VALS (CDR V)))
@@ -348,8 +361,8 @@
(PUSH SETTER SETF-LIST)
(SETQ NEXT-VAR (CAR NEWVAL)))))))
(DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL
DOC-STRING)
(DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL DOC-STRING
)
(LET
((OTHER-ARGS NIL)
(REST-ARG NIL))
@@ -371,7 +384,7 @@
SI::%$$MODIFY-MACRO-ENVIRONMENT)
,DOC-STRING (MULTIPLE-VALUE-BIND
(DUMMIES VALS NEWVAL SETTER GETTER)
(GET-UNDOABLE-SETF-METHOD SI::%$$MODIFY-MACRO-FORM
(GET-UNDOABLE-SETF-METHOD SI::%$$MODIFY-MACRO-FORM
SI::%$$MODIFY-MACRO-ENVIRONMENT)
(MULTIPLE-VALUE-BIND
(DUMMIES VALS NEWVALS SETTER GETTER)
@@ -384,10 +397,10 @@
,SETTER))))))
(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF (&OPTIONAL (DELTA 1))
-)
-)
(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-INCF (&OPTIONAL (DELTA 1))
+)
+)
(DEFUN UNDOABLY-PROCLAIM (PROCLAMATION)
@@ -396,34 +409,34 @@
(WHEN (CONSP PROCLAMATION)
(CASE (CAR PROCLAMATION)
(SPECIAL (DOLIST (X (CDR PROCLAMATION))
(UNDOABLY (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
(UNDOABLY (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
T)
(SETF (IL:VARIABLE-GLOBAL-P X)
NIL)
(SETF (CONSTANTP X)
NIL))))
(GLOBAL (DOLIST (X (CDR PROCLAMATION))
(UNDOABLY (SETF (IL:VARIABLE-GLOBAL-P X)
(UNDOABLY (SETF (IL:VARIABLE-GLOBAL-P X)
T)
(SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
NIL)
(SETF (CONSTANTP X)
NIL))))
(SI::CONSTANT (DOLIST (X (CDR PROCLAMATION))
(UNDOABLY (SETF (CONSTANTP X)
(UNDOABLY (SETF (CONSTANTP X)
T)
(SETF (IL:VARIABLE-GLOBAL-P X)
NIL)
(SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
NIL))))
(DECLARATION (DOLIST (X (CDR PROCLAMATION))
(UNDOABLY (SETF (DECL-SPECIFIER-P X)
(UNDOABLY (SETF (DECL-SPECIFIER-P X)
T))))
(NOTINLINE (DOLIST (X (CDR PROCLAMATION))
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
T))))
(INLINE (DOLIST (X (CDR PROCLAMATION))
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
NIL)))))))
(DEFUN MAKE-UNDOABLE (FORM &OPTIONAL ENV)
@@ -438,7 +451,7 @@
(DEFUN UNDOABLY-SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION)
(IL:* IL:|;;|
 "NOTE: If you change this version, be sure to change the not-undoable version on LLSYMBOL!")
 "NOTE: If you change this version, be sure to change the not-undoable version on LLSYMBOL!")
(IL:* IL:|;;| " undoable inverse of SYMBOL-FUNCTION")
@@ -449,9 +462,9 @@
(IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.")
(CASE (CAR DEFINITION)
(:MACRO (UNDOABLY-SETF (MACRO-FUNCTION SYMBOL)
(:MACRO (UNDOABLY-SETF (MACRO-FUNCTION SYMBOL)
(CDR DEFINITION)))
(:SPECIAL-FORM (UNDOABLY-SETF (GET SYMBOL 'IL:SPECIAL-FORM)
(:SPECIAL-FORM (UNDOABLY-SETF (GET SYMBOL 'IL:SPECIAL-FORM)
(CDR DEFINITION)))
(T (IL:/PUTD SYMBOL DEFINITION T))))
@@ -480,14 +493,14 @@
(IL:* IL:|;;| "undoable setf of macro-function")
(IL:* IL:|;;|
 "NOTE: If you change this, be sure to change the not-undoable version on CMLMACROS!")
 "NOTE: If you change this, be sure to change the not-undoable version on CMLMACROS!")
(PROG1 (UNDOABLY-SETF (GET X 'IL:MACRO-FN)
(PROG1 (UNDOABLY-SETF (GET X 'IL:MACRO-FN)
BODY)
(AND (IL:GETD X)
(CASE (IL:ARGTYPE X)
((1 3) (IL:* IL:\;
 "Leave Interlisp nlambda definition alone")
 "Leave Interlisp nlambda definition alone")
)
(OTHERWISE (IL:/PUTD X NIL))))))
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY
@@ -498,18 +511,18 @@
)
(IL:ADDTOVAR IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM)
(POP . UNDOABLY-POP)
(PSETF . UNDOABLY-PSETF)
(PUSH . UNDOABLY-PUSH)
(PUSHNEW . UNDOABLY-PUSHNEW)
((REMF) . UNDOABLY-REMF)
(ROTATEF . UNDOABLY-ROTATEF)
(SHIFTF . UNDOABLY-SHIFTF)
(DECF . UNDOABLY-DECF)
(INCF . UNDOABLY-INCF)
(SET . UNDOABLY-SET-SYMBOL)
(MAKUNBOUND . UNDOABLY-MAKUNBOUND)
(FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))
(POP . UNDOABLY-POP)
(PSETF . UNDOABLY-PSETF)
(PUSH . UNDOABLY-PUSH)
(PUSHNEW . UNDOABLY-PUSHNEW)
(REMF . UNDOABLY-REMF)
(ROTATEF . UNDOABLY-ROTATEF)
(SHIFTF . UNDOABLY-SHIFTF)
(DECF . UNDOABLY-DECF)
(INCF . UNDOABLY-INCF)
(SET . UNDOABLY-SET-SYMBOL)
(MAKUNBOUND . UNDOABLY-MAKUNBOUND)
(FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))
(DEFUN GET-UNDOABLE-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT &AUX TEMP)
(COND
@@ -524,7 +537,7 @@
(IL:* IL:|;;| "always expand local macros")
(GET-UNDOABLE-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT)
(GET-UNDOABLE-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT)
ENVIRONMENT))
((SETQ TEMP (GET (CAR FORM)
':UNDOABLE-SETF-INVERSE))
@@ -553,12 +566,12 @@
(T (MULTIPLE-VALUE-BIND (MAC MORE)
(MACROEXPAND-1 FORM ENVIRONMENT)
(IF (AND MORE (NOT (EQ MAC FORM)))
(RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD MAC ENVIRONMENT))
(RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD MAC ENVIRONMENT))
(ERROR "~S is not a known location specifier for SETF."
(CAR FORM))))))
(IL:* IL:|;;|
 "this is lexically correct, but doesn't work in bytecompiler, interlisp")
 "this is lexically correct, but doesn't work in bytecompiler, interlisp")
(IL:* IL:|;;| "(cl:values dummies vals newval `(cl:labels ((undostore (,@newval) (undosave (list #'undostore ,getter)) ,setter)) (undostore ,@newval)) getter)")
@@ -580,7 +593,7 @@
(WHEN ENVIRONMENT
(IL:* IL:|;;|
 "This function only saves undo info when there is no lexical binding for the variable.")
 "This function only saves undo info when there is no lexical binding for the variable.")
(SETQ ENVIRONMENT (IL:ENVIRONMENT-VARS ENVIRONMENT))
(LOOP (IF (NULL ENVIRONMENT)
@@ -593,7 +606,7 @@
IL:*SPECIAL-BINDING-MARK*)
(IL:* IL:|;;|
 "it is a special binding, or a mark that we are using the special value")
 "it is a special binding, or a mark that we are using the special value")
(RETURN NIL) (IL:* IL:\; "return from WHILE")
)
@@ -634,26 +647,25 @@
(IL:\\RPLPTR VP 0 VALUE))))))
(IL:DEFINEQ
(undoably-setq
(il:nlambda varvalue (il:* il:\; "Edited 8-Oct-87 18:54 by jop")
(il:* il:\; "Interlisp version")
(undoably-set-symbol (car varvalue)
(il:\\evprog1 (cdr varvalue)))))
(UNDOABLY-SETQ
(IL:NLAMBDA VARVALUE (IL:* IL:\; "Edited 8-Oct-87 18:54 by jop")
(IL:* IL:\; "Interlisp version")
(UNDOABLY-SET-SYMBOL (CAR VARVALUE)
(IL:\\EVPROG1 (CDR VARVALUE)))))
)
(DEFINE-SPECIAL-FORM UNDOABLY (&REST FORMS &ENVIRONMENT ENV)
(LOOP (IF (NULL (CDR FORMS))
(RETURN (UNDOHOOK (CAR FORMS)
(RETURN (UNDOHOOK (CAR FORMS)
ENV))
(UNDOHOOK (POP FORMS)
(UNDOHOOK (POP FORMS)
ENV))))
(DEFINE-SPECIAL-FORM UNDOABLY-SETQ (&REST TAIL &ENVIRONMENT ENV)
(LET (VALUE)
(LOOP (IF (NULL TAIL)
(RETURN NIL)
(SETQ VALUE (UNDOABLY-SET-SYMBOL (POP TAIL)
(SETQ VALUE (UNDOABLY-SET-SYMBOL (POP TAIL)
(EVAL (POP TAIL)
ENV)
ENV))))
@@ -678,7 +690,16 @@
(IL:ADDTOVAR IL:LAMA )
)
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 2022))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (29112 29437 (UNDOABLY-SETQ 29125 . 29435)))))
(IL:FILEMAP (NIL (4227 4310 (NOHOOK 4227 . 4310)) (4312 7992 (UNDOABLY 4312 . 7992)) (7994 8214 (
UNDOABLY-FMAKUNBOUND 7994 . 8214)) (8216 8792 (UNDOABLY-MAKUNBOUND 8216 . 8792)) (8794 9521 (
UNDOABLY-SETF 8794 . 9521)) (9523 11417 (UNDOHOOK 9523 . 11417)) (11419 11766 (UNDOABLY-PSETF 11419 .
11766)) (11768 12368 (UNDOABLY-POP 11768 . 12368)) (12370 12930 (UNDOABLY-PUSH 12370 . 12930)) (12932
13391 (UNDOABLY-PUSHNEW 12932 . 13391)) (13393 14759 (UNDOABLY-REMF 13393 . 14759)) (14761 15907 (
UNDOABLY-ROTATEF 14761 . 15907)) (15909 17049 (UNDOABLY-SHIFTF 15909 . 17049)) (18845 20667 (
UNDOABLY-PROCLAIM 18845 . 20667)) (20669 20740 (MAKE-UNDOABLE 20669 . 20740)) (20742 20888 (
STOP-UNDOABLY 20742 . 20888)) (20890 22570 (UNDOABLY-SETF-SYMBOL-FUNCTION 20890 . 22570)) (22572 23161
(UNDOABLY-SETF-MACRO-FUNCTION 22572 . 23161)) (24059 27459 (GET-UNDOABLE-SETF-METHOD 24059 . 27459))
(27461 30185 (UNDOABLY-SET-SYMBOL 27461 . 30185)) (30186 30514 (UNDOABLY-SETQ 30199 . 30512)))))
IL:STOP

BIN
sources/CMLUNDO.DFASL
View File

Binary file not shown.