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
parent
bb637c5b73
commit
306af20e91
150
sources/CMLUNDO
150
sources/CMLUNDO
@ -1,10 +1,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)
|
||||
|
||||
: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.
|
||||
@ -69,75 +69,71 @@
|
||||
(DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
|
||||
(APPLY FN ARGS))
|
||||
|
||||
(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))))
|
||||
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (IL:* IL:\; "Edited 7-Nov-2022 09:52 by lmm")
|
||||
(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? ")
|
||||
(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
|
||||
"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)))))))))))
|
||||
(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)
|
||||
@ -692,14 +688,14 @@
|
||||
)
|
||||
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 2022))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(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:FILEMAP (NIL (4227 4310 (NOHOOK 4227 . 4310)) (4312 7538 (UNDOABLY 4312 . 7538)) (7540 7760 (
|
||||
UNDOABLY-FMAKUNBOUND 7540 . 7760)) (7762 8338 (UNDOABLY-MAKUNBOUND 7762 . 8338)) (8340 9067 (
|
||||
UNDOABLY-SETF 8340 . 9067)) (9069 10963 (UNDOHOOK 9069 . 10963)) (10965 11312 (UNDOABLY-PSETF 10965 .
|
||||
11312)) (11314 11914 (UNDOABLY-POP 11314 . 11914)) (11916 12476 (UNDOABLY-PUSH 11916 . 12476)) (12478
|
||||
12937 (UNDOABLY-PUSHNEW 12478 . 12937)) (12939 14305 (UNDOABLY-REMF 12939 . 14305)) (14307 15453 (
|
||||
UNDOABLY-ROTATEF 14307 . 15453)) (15455 16595 (UNDOABLY-SHIFTF 15455 . 16595)) (18391 20213 (
|
||||
UNDOABLY-PROCLAIM 18391 . 20213)) (20215 20286 (MAKE-UNDOABLE 20215 . 20286)) (20288 20434 (
|
||||
STOP-UNDOABLY 20288 . 20434)) (20436 22116 (UNDOABLY-SETF-SYMBOL-FUNCTION 20436 . 22116)) (22118 22707
|
||||
(UNDOABLY-SETF-MACRO-FUNCTION 22118 . 22707)) (23605 27005 (GET-UNDOABLE-SETF-METHOD 23605 . 27005))
|
||||
(27007 29731 (UNDOABLY-SET-SYMBOL 27007 . 29731)) (29732 30060 (UNDOABLY-SETQ 29745 . 30058)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user