The macroexpansion of UNDOABLY shouldn't depend on runtime rebinding of LISPXHIST (#1023)
The history and undo code was written before the record package; but someone introduced a DEFMACRO UNDOABLY macro to do the work. But cached macroexpansions shouldn't depend on load/run/compile time values.
This commit is contained in:
Larry Masinter
GitHub
150
sources/CMLUNDO
150
sources/CMLUNDO
@@ -1,10 +1,10 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10)
|
||||||
|
|
||||||
(IL:FILECREATED "18-Oct-2022 16:24:32" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;2| 31891
|
(IL:FILECREATED " 7-Nov-2022 09:54:34" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;2| 31437
|
||||||
|
|
||||||
:CHANGES-TO (IL:FUNCTIONS UNDOABLY)
|
:CHANGES-TO (IL:FUNCTIONS UNDOABLY)
|
||||||
|
|
||||||
:PREVIOUS-DATE "15-Oct-2022 17:21:17" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;1|)
|
:PREVIOUS-DATE "18-Oct-2022 16:24:32" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;1|)
|
||||||
|
|
||||||
|
|
||||||
; Copyright (c) 1986-1988, 1990, 2022 by Venue & Xerox Corporation.
|
; Copyright (c) 1986-1988, 1990, 2022 by Venue & Xerox Corporation.
|
||||||
@@ -69,75 +69,71 @@
|
|||||||
(DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
|
(DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
|
||||||
(APPLY FN ARGS))
|
(APPLY FN ARGS))
|
||||||
|
|
||||||
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (IL:* IL:\; "Edited 18-Oct-2022 16:20 by lmm")
|
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (IL:* IL:\; "Edited 7-Nov-2022 09:52 by lmm")
|
||||||
(IL:* IL:\; "Edited 15-Oct-2022 11:47 by lmm")
|
(WALK-FORM
|
||||||
(IF (NULL IL:LISPXHIST)
|
(IL:MKPROGN FORMS)
|
||||||
(IL:MKPROGN FORMS)
|
:ENVIRONMENT ENV :WALK-FUNCTION
|
||||||
(WALK-FORM
|
#'(LAMBDA
|
||||||
(IL:MKPROGN FORMS)
|
(X CONTEXT)
|
||||||
:ENVIRONMENT ENV :WALK-FUNCTION
|
(COND
|
||||||
#'(LAMBDA
|
((NOT (CONSP X))
|
||||||
(X CONTEXT)
|
X)
|
||||||
(COND
|
((NOT (SYMBOLP (CAR X)))
|
||||||
((NOT (CONSP X))
|
X)
|
||||||
X)
|
(T
|
||||||
((NOT (SYMBOLP (CAR X)))
|
(CASE (CAR X)
|
||||||
X)
|
((SETQ IL:SETQ SETF)
|
||||||
(T
|
(VALUES
|
||||||
(CASE (CAR X)
|
(IL:MKPROGN
|
||||||
((SETQ IL:SETQ SETF)
|
(WITH-COLLECTION
|
||||||
(VALUES
|
(DO ((TAIL (CDR X)
|
||||||
(IL:MKPROGN
|
(CDDR TAIL)))
|
||||||
(WITH-COLLECTION
|
((NULL TAIL))
|
||||||
(DO ((TAIL (CDR X)
|
(COLLECT
|
||||||
(CDDR TAIL)))
|
(IF (SYMBOLP (CAR TAIL))
|
||||||
((NULL TAIL))
|
(IF (VARIABLE-LEXICAL-P (CAR TAIL))
|
||||||
(COLLECT
|
`(,(CAR X)
|
||||||
(IF (SYMBOLP (CAR TAIL))
|
,(CAR TAIL)
|
||||||
(IF (VARIABLE-LEXICAL-P (CAR TAIL))
|
,(WALK-FORM-INTERNAL (CADR TAIL)))
|
||||||
`(,(CAR X)
|
(PROGN (COND
|
||||||
,(CAR TAIL)
|
((NOT (OR (VARIABLE-SPECIAL-P (CAR TAIL))
|
||||||
,(WALK-FORM-INTERNAL (CADR TAIL)))
|
(BOUNDP (CAR TAIL))))
|
||||||
(PROGN (COND
|
|
||||||
((NOT (OR (VARIABLE-SPECIAL-P (CAR TAIL))
|
|
||||||
(BOUNDP (CAR TAIL))))
|
|
||||||
|
|
||||||
(IL:* IL:|;;| "should possibly spelling correct? ")
|
(IL:* IL:|;;| "should possibly spelling correct? ")
|
||||||
|
|
||||||
(WHEN NIL
|
(WHEN NIL
|
||||||
|
|
||||||
(IL:* IL:|;;| "this warning just seems uselsss; it doesn't proclaim anything or mark it as changed in FILEPKG or ...")
|
(IL:* IL:|;;| "this warning just seems uselsss; it doesn't proclaim anything or mark it as changed in FILEPKG or ...")
|
||||||
|
|
||||||
(WARN
|
(WARN "Variable ~S proclaimed SPECIAL UNDOABLY.. SETQ"
|
||||||
"Variable ~S proclaimed SPECIAL UNDOABLY.. SETQ"
|
(CAR TAIL)))))
|
||||||
(CAR TAIL)))))
|
`(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
|
||||||
`(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
|
,(WALK-FORM-INTERNAL (CADR TAIL)))))
|
||||||
,(WALK-FORM-INTERNAL (CADR TAIL)))))
|
(MULTIPLE-VALUE-BIND
|
||||||
(MULTIPLE-VALUE-BIND
|
(FORMALS ACTUALS NEW-VALUE SETTER GETTER)
|
||||||
(FORMALS ACTUALS NEW-VALUE SETTER GETTER)
|
(GET-UNDOABLE-SETF-METHOD (CAR TAIL))
|
||||||
(GET-UNDOABLE-SETF-METHOD (CAR TAIL))
|
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
|
||||||
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
|
(LIST X (WALK-FORM-INTERNAL Y)))
|
||||||
(LIST X (WALK-FORM-INTERNAL Y)))
|
FORMALS ACTUALS)
|
||||||
FORMALS ACTUALS)
|
(,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
|
||||||
(,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
|
,(CADR TAIL)))
|
||||||
,(CADR TAIL)))
|
,SETTER)))))))
|
||||||
,SETTER)))))))
|
T))
|
||||||
T))
|
(STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
|
||||||
(STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
|
T))
|
||||||
T))
|
(T (LET ((UNDONAME (CDR (ASSOC (CAR X)
|
||||||
(T (LET ((UNDONAME (CDR (ASSOC (CAR X)
|
IL:LISPXFNS :TEST #'EQ))))
|
||||||
IL:LISPXFNS :TEST #'EQ))))
|
(IF UNDONAME
|
||||||
(IF UNDONAME
|
(CONS UNDONAME (CDR X))
|
||||||
(CONS UNDONAME (CDR X))
|
(IF (AND (OR (GET (CAR X)
|
||||||
(IF (AND (OR (GET (CAR X)
|
':DEFINER-FOR)
|
||||||
':DEFINER-FOR)
|
(GET (CAR X)
|
||||||
(GET (CAR X)
|
'IL:DEFINER-FOR))
|
||||||
'IL:DEFINER-FOR))
|
(NOT *IN-DEFINER*))
|
||||||
(NOT *IN-DEFINER*))
|
(LET ((*IN-DEFINER* T))
|
||||||
(LET ((*IN-DEFINER* T))
|
(VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
|
||||||
(VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
|
T))
|
||||||
T))
|
X))))))))))
|
||||||
X)))))))))))
|
|
||||||
|
|
||||||
(DEFUN UNDOABLY-FMAKUNBOUND (SYMBOL)
|
(DEFUN UNDOABLY-FMAKUNBOUND (SYMBOL)
|
||||||
(IL:/PUTD SYMBOL NIL)
|
(IL:/PUTD SYMBOL NIL)
|
||||||
@@ -692,14 +688,14 @@
|
|||||||
)
|
)
|
||||||
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 2022))
|
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 2022))
|
||||||
(IL:DECLARE\: IL:DONTCOPY
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
(IL:FILEMAP (NIL (4227 4310 (NOHOOK 4227 . 4310)) (4312 7992 (UNDOABLY 4312 . 7992)) (7994 8214 (
|
(IL:FILEMAP (NIL (4227 4310 (NOHOOK 4227 . 4310)) (4312 7538 (UNDOABLY 4312 . 7538)) (7540 7760 (
|
||||||
UNDOABLY-FMAKUNBOUND 7994 . 8214)) (8216 8792 (UNDOABLY-MAKUNBOUND 8216 . 8792)) (8794 9521 (
|
UNDOABLY-FMAKUNBOUND 7540 . 7760)) (7762 8338 (UNDOABLY-MAKUNBOUND 7762 . 8338)) (8340 9067 (
|
||||||
UNDOABLY-SETF 8794 . 9521)) (9523 11417 (UNDOHOOK 9523 . 11417)) (11419 11766 (UNDOABLY-PSETF 11419 .
|
UNDOABLY-SETF 8340 . 9067)) (9069 10963 (UNDOHOOK 9069 . 10963)) (10965 11312 (UNDOABLY-PSETF 10965 .
|
||||||
11766)) (11768 12368 (UNDOABLY-POP 11768 . 12368)) (12370 12930 (UNDOABLY-PUSH 12370 . 12930)) (12932
|
11312)) (11314 11914 (UNDOABLY-POP 11314 . 11914)) (11916 12476 (UNDOABLY-PUSH 11916 . 12476)) (12478
|
||||||
13391 (UNDOABLY-PUSHNEW 12932 . 13391)) (13393 14759 (UNDOABLY-REMF 13393 . 14759)) (14761 15907 (
|
12937 (UNDOABLY-PUSHNEW 12478 . 12937)) (12939 14305 (UNDOABLY-REMF 12939 . 14305)) (14307 15453 (
|
||||||
UNDOABLY-ROTATEF 14761 . 15907)) (15909 17049 (UNDOABLY-SHIFTF 15909 . 17049)) (18845 20667 (
|
UNDOABLY-ROTATEF 14307 . 15453)) (15455 16595 (UNDOABLY-SHIFTF 15455 . 16595)) (18391 20213 (
|
||||||
UNDOABLY-PROCLAIM 18845 . 20667)) (20669 20740 (MAKE-UNDOABLE 20669 . 20740)) (20742 20888 (
|
UNDOABLY-PROCLAIM 18391 . 20213)) (20215 20286 (MAKE-UNDOABLE 20215 . 20286)) (20288 20434 (
|
||||||
STOP-UNDOABLY 20742 . 20888)) (20890 22570 (UNDOABLY-SETF-SYMBOL-FUNCTION 20890 . 22570)) (22572 23161
|
STOP-UNDOABLY 20288 . 20434)) (20436 22116 (UNDOABLY-SETF-SYMBOL-FUNCTION 20436 . 22116)) (22118 22707
|
||||||
(UNDOABLY-SETF-MACRO-FUNCTION 22572 . 23161)) (24059 27459 (GET-UNDOABLE-SETF-METHOD 24059 . 27459))
|
(UNDOABLY-SETF-MACRO-FUNCTION 22118 . 22707)) (23605 27005 (GET-UNDOABLE-SETF-METHOD 23605 . 27005))
|
||||||
(27461 30185 (UNDOABLY-SET-SYMBOL 27461 . 30185)) (30186 30514 (UNDOABLY-SETQ 30199 . 30512)))))
|
(27007 29731 (UNDOABLY-SET-SYMBOL 27007 . 29731)) (29732 30060 (UNDOABLY-SETQ 29745 . 30058)))))
|
||||||
IL:STOP
|
IL:STOP
|
||||||
|
|||||||
Binary file not shown.
Reference in New Issue
Block a user