github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-24 09:30:29 +00:00
Code Issues Releases Wiki Activity
Files
lars/float
PDP-10.its/src/libdoc/redo.ejs5
Eric Swenson 3080ca8796 Update various LIBDOC lisp packages to later versions. 
Resolves #1055.
2018-07-13 15:12:49 -07:00

1197 lines
42 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
(DECLARE (SPECIAL LISPXFNS H-LIST H-STACK H-COUNT H-MAX
H-EVAL H-ARCHIVE-P H-1ST-ARCHIVED
H-REDO-INDENT H-FIND-= H-FIND-* H-FIND-REDONE
H-REDO-PRINTF H-PRINT-O H-PRINT-I))
;MACRO FOR SETTING A GLOBAL VARIABLE UNLESS USER HAS ALREADY DONE SO.
;USE: (MAYBESET VARIABLE VALUE). VALUE IS EVALUATED.
(DEFUN MAYBESET MACRO (FORM)
(LIST 'OR
(LIST 'BOUNDP (LIST 'QUOTE (CADR FORM)))
(LIST 'SETQ (CADR FORM) (CADDR FORM))))
;LISPXFNS IS AN ALIST DESCRIBING THE REPLACEMENT OPERATIN TO BE PERFORMED
;BY LISPX// ON FUNCTIONS APPEARING IN ITS ARGUMENT.
(MAYBESET LISPXFNS NIL)
;MAX LENGTH OF HISTORY, AT WHICH POINT EVENTS SHOULD BE FORGOTTEN OFF
;THE END OF THE LIST. NOT NUMBER => INFINITY.
(MAYBESET H-MAX 30.)
;# OF EVENTS SO FAR. BOUND TO 0 AT START OF EACH REDO.
(MAYBESET H-COUNT (* 2 IBASE IBASE))
;H-LIST IS THE LIST OF EVENTS. AT TOP LEVEL, EVENTS ARE CONS'D ONTO THE
;FRONT, AND DELETED FROM NEAR THE END.
;H-LIST IS NOT RELEVANT WHILE REDOING.
(MAYBESET H-LIST NIL)
;H-STACK IS THE STACK OF BINDINGS OF H-REDO-EVL AND H-REDO-INDENT.
;EACH REDO OR USE CONSES ANOTHER 2-LIST ONTO H-STACK.
;EXHAUSTING H-REDO-EVL POPS AN ELEMENT OFF OF H-STACK.
;H-STACK RESEMBLES NEWIO'S INPUT FILE STACK.
(MAYBESET H-STACK NIL)
;WHILE AN EVENT IS BEING EVALUATED, H-ENTRY CONTAINS THAT EVENT.
;THERE, RATHER THAN IN (CAR H-LIST) IS THE CORRECT PLACE TO FIND IT.
(DECLARE (SPECIAL H-ENTRY))
;IF NON-NIL, IT IS A PREDICATE APPLIED TO EACH EVENT ABOUT TO BE THROWN AWAY.
;IF IT RETURNS T, THE EVENT IS ARCHIVED INSTEAD.
(MAYBESET H-ARCHIVE-P NIL)
;USED BY H-CLEAN TO SAVE WORK - SEE COMMENT THERE.
(MAYBESET H-1ST-ARCHIVED NIL)
;DURING A REDO, THE LIST OF EVENTS TO BE REDONE IS IN H-REDO-EVL
(DECLARE (SPECIAL H-REDO-EVL))
(MAYBESET H-REDO-EVL NIL)
;H-REDO-INDENT IS THE NUMBER OF SPACES OF INDENTATION REDO SHOULD USE IN PRINTING
;OUT THE THINGS REDONE AND THEIR VALUES. REDO AND USEU REBIND TO A LARGER
;VALUE SO RECURSIVE REDOS ARE MORE INDENTED.
(MAYBESET H-REDO-INDENT 0)
;H-REDO-PRINTF IS BOUND TO NIL BY SREDO TO PREVENT PRINTING OF REDONE EVENTS.
(MAYBESET H-REDO-PRINTF T)
;H-EVAL, IF NOT NIL, IS WHAT H-EVAL CALLS INSTEAD OF EVAL.
;SO YOU CAN KEEP HISTORY, REDO, ETC. BUT HAVE YOUR OWN EVALUATOR.
(MAYBESET H-EVAL NIL)
;LIKE LISP'S TOP LEVEL, WE USE THE VALUES OF READ AND PRIN1 INSTEAD
;OF THOSE FUNCTIONS THEMSELVES, IF THE VALUES ARE NIL.
(DECLARE (SPECIAL READ PRIN1))
;H-PRINT-I IF NON-NIL IS USED INSTEAD OF PRIN1 FOR PRINTING
;INPUTS WHEN THEY ARE REDONE, OR WHEN H-PR OR H-PV IS DONE.
;H-PRINT-O IS USED FOR PRINTING OUTPUTS (TAKES PRIORITY OVER PRIN1).
;BOTH ARE PASSED ONE ARG: THE EVENT.
(MAYBESET H-PRINT-I NIL)
(MAYBESET H-PRINT-O NIL)
;H-BEFORE IS THE LIST IN WHICH EVENT-SPECS SHOULD DO THEIR SEARCHING.
;NORMALLY IT IS THE HISTORY LIST BEFORE THE CONSING ON OF THE CURRENT EVENT.
;WHEN REDO-ING, IT IS SOME TAIL OF THE HISTORY LIST, CONTAINING EVENTS
;WHOSE NUMBERS ARE LOWER THAN THAT OF THE EVENT BEING REDONE.
(DECLARE (SPECIAL H-BEFORE))
;H-FIND-=, IF T, SAYS MATCH AGAINST VALUES INSTEAD OF INPUTS IN H-FIND
;H-FIND-*, IF T, SAYS MATCH AT TOP LEVEL OF LIST STR ONLY
;H-FIND-REDONE SAYS THAT IT IS OK TO MATCH HISTORY COMMANDS (SET DURING USEH).
(MAYBESET H-FIND-= NIL)
(MAYBESET H-FIND-* NIL)
(MAYBESET H-FIND-REDONE NIL)
;H-FIND-FORM IS THE CURRENT HISTORY-FIND SPEC BEING EVALUATED BY H-FIND-EVAL;
;USED MOSTLY FOR PRITING OUT 'EVENT-NOT-FOUND ERRORS.
(DECLARE (SPECIAL H-FIND-FORM))
;H-FIND-PTR IS THE "CURSOR" THAT THE VARIOUS SEARCH COMMANDS IN EVENT SPECS
;MOVE AROUND. THE CAR OF H.F.PTR'S EVENTUAL VALUE IS THE EVENT FINALLY "FOUND".
(DECLARE (SPECIAL H-FIND-PTR))
;H-TLIST, INSIDE H-TRANSFORM, IS THE LIST OF TRANSFORMATIONS
;THAT ARE TO BE APPLIED AT ALL LEVELS OF THE TRANSFORMED LIST.
;IT IS NEEDED SO THAT THEY CAN BE APPLIED RECURSIVELY TO ANYTHING MATCHED
;BY A 'NIL IN A TRANSFORMATION.
(DECLARE (SPECIAL H-TLIST))
;H-TRANSFORM-NOCHANGE, IF T, CAUSES H-TRANSFORM TO RUN IN "MATCH"
;MODE INSTEAD OF "TRANSFORM" MODE. INSTEAD OF RETURNING THE TRANSFORMED LIST,
;IT RETURNS T IFF ANY OF THE TRANSFORMATIONS WAS EVER APPLICABLE.
(DECLARE (SPECIAL H-TRANSFORM-NOCHANGE))
(DECLARE (COMMENT ;NO NEED TO HAVE LISPX/ WHEN UNDO DOESN'T EXIST YET.
;LISPX/ NOW TAKES ONLY 1 ARG: A FORM, IN WHICH FUNCTION CALLS SHOULD
;BE APPROPRIATELY MUNGED BY SUBSTITUTING FOR FUNCTIONS ON LISPXFNS.
;ARG-EVALING FUNCTIONS' ARGS ARE TRACED, AS ARE PARTS OF CONDS,
;BUT NOT EXPLICIT LAMBDAS, PROGS OR DOS.
(DEFUN LISPX// (X)
(COND
((NULL LISPXFNS) X)
(T (LISPX//1 X))))
;LISPX/TAIL IS LIKE BBN'S LISPX WITH TAILFLG=T.
;ESSENTIALLY (MAPCAR 'LISPX//1 X)
(DEFUN LISPX//TAIL (X)
(PROG (Y Z)
(AND (ATOM X) (RETURN X))
(SETQ Y (LISPX//1 (CAR X)))
(SETQ Z (LISPX//TAIL (CDR X)))
(AND (EQ Y (CAR X)) (EQ Z (CDR X)) (RETURN X))
(RETURN (CONS Y Z))))
(DEFUN LISPX//1 (X)
(PROG (TEM1 TEM2)
EXPANDED
(AND (ATOM X) (RETURN X))
(OR (ATOM (CAR X))
(RETURN (LISPX//TAIL X)))
;TEM1 _ THE FUNCTION BAING CALLED, TRANSLATED BY LISPXFNS IF APPROPRIATE.
(SETQ TEM1 (OR (CDR (ASSQ (CAR X) LISPXFNS))
(CAR X)))
(COND ((EQ TEM1 'COND)
(RETURN (CONS 'COND
(MAPCAR (FUNCTION LISPX//TAIL) (CDR X))))))
(SETQ TEM2 (GETL TEM1 '(FEXPR EXPR SUBR LSUBR FSUBR MACRO AUTOLOAD)))
;SOME FSUBRS DO EVAL ARGS IF THEY USE THEM AT ALL (AND, OR, ERRSET ...)
;THEY SHOULD HAVE A NON-NIL EVALS-ARGS PROPERTY.
;SINCE AUTOLOADED FUNCTIONS ARE ASSUMED NOT TO EVAL ARGS,
;ANY THAT DO SO SHOULD ALSO HAVE SUCH A PROPERTY.
(AND (GET TEM1 'EVALS-ARGS) (SETQ TEM2 NIL))
(AND (EQ (CAR TEM2) 'MACRO) ;ANY MACRO CALLS MUST BE EXPANDED
(PROGN (SETQ X (FUNCALL (GET (CAR X) 'MACRO)
X)) ;SO WE CAN TRANSLATE THE FUNCTIONS
(GO EXPANDED))) ;CALLED BY THEIR EXPANSIONS.
;THIS IS REALLY (CONS TEM1 (COND ((MEMQ ...) (CDR X))
; (T (LISPX/TAIL (CDR X)))))
;JUST RECURSES OVER THE ARGS IF THEY'D BE EVALLED.
;EXTRA HAIR IS TO AVOID COPYING IF NOTHING CHANGES.
(COND ((MEMQ (CAR TEM2) '(FEXPR FSUBR AUTOLOAD))
(RETURN (COND ((EQ TEM1 (CAR X)) X)
(T (CONS TEM1 (CDR X))))))
((AND (EQ (SETQ TEM2 (LISPX//TAIL (CDR X))))
(EQ TEM1 (CAR X)))
(RETURN X))
(T (RETURN (CONS TEM1 TEM2))))))
;DECLARE THAT CERTAIN FUNCTIONS EVAL THEIR ARGS EVEN THOUGH THEY ARE FSUBRS.
(MAPC '(LAMBDA (FN) (PUTPROP FN T 'EVALS-ARGS))
'(AND OR ERRSET IOG SETQ ARRAY BREAK CATCH SIGNP STATUS SSTATUS STORE THROW))
)) ;END DECLARE OF COMMENT.
;H-EVAL EVALS ITS ARG, SAVING INFO ON THE HISTORY LIST IF DESIRED.
;WE ALSO THROW AWAY OLD EVENTS WHEN IT IS APPROPRIATE, BY CALLING H-CLEAN
;H-EVAL'S VALUE SHOULD BE NIL TO EVAL, OR ELSE SOME FUNCTION TO
;USE INSTEAD OF EVAL.
;H-BEFORE IS THE HISTORY LIST THAT HISTORY COMMANDS ARE TO LOOK
;FOR EVENTS IN IF THEY ARE RUN BY THIS CALL TO H-EVAL.
;H-ENTRY IS THE NEW EVENT, WHILE THE EVALUATION IS GOING ON.
(DEFUN H-EVAL (H-EVAL-FORM H-BEFORE)
(PROG (ENTRY H-EVAL-TEM1)
;CREATE THE NEW HISTORY LIST ENTRY, WITH THE INPUTS IN ALREADY IN IT.
(SETQ ENTRY
(LIST H-EVAL-FORM
H-EVAL
;HERE WE "INCREMENT" THE EVENT #,
(SETQ H-COUNT (1+ H-COUNT))
NIL ;NIL HERE MEANS HASN'T FINISHED EVALLING
NIL)) ;VALUE WILL GO HERE.
;NOW ATTACH TO FRONT OF OUR HISTORY LIST,
(SETQ H-LIST (CONS ENTRY H-LIST))
(SETQ H-EVAL-TEM1 (H-EVAL-2 ENTRY))
;NOW THROW AWAY OLD EVENTS IF DESIRED
(AND (NUMBERP H-MAX) (H-CLEAN H-MAX))
(RETURN H-EVAL-TEM1)))
(DEFUN H-EVAL-2 (H-ENTRY)
;NOW "EVALUATE" OR WHATEVER. DURING THE CALL,
;'H-ENTRY POINTS AT THE NEW HISTORY ENTRY JUST BEING MADE,
(CAR (RPLACA (CDDDDR H-ENTRY)
(PROG2 NIL
(COND ((CADR H-ENTRY) (FUNCALL (CADR H-ENTRY) (CAR H-ENTRY)))
(T (EVAL (CAR H-ENTRY))))
;IF THE EVAL RETURNS, SAY SO IN THE HISTORY, AND REMEMBER THE VALUE.
;NOTE THAT REDO, ETC. WILL ALREDAY HAVE SET UP THE VALUE-FLAG,
;SO DON'T OVERRIDE THEM.
(OR (CADDDR H-ENTRY) (RPLACA (CDDDR H-ENTRY) T))))))
;THROW AWAY ANY EVENTS ON THE HISTORY LIST THAT ARE OLD AND NOT ARCHIVED.
;AN EVENT IS NOT OLD IF IT IS AMONG THE LAST H-MAX EVENTS.
;AN EVENT IS ARCHIVED IFF IT HAS AN ARCHIVE PROPERTY THAT IS NOT NIL OR 'DELETE.
;WHEN AN EVENT IS ABOUT TO BE THROWN AWAY, THE VALUE OF H-ARCHIVE-P
;IS CALLED WITH IT; IF THE VALUE IS NON-NIL THE EVENT IS ARCHIVED INSTEAD.
;EXCEPTION: IF THE ARCHIVE PROPERTY IS 'DELETE, THE ARCHIVE FUNCTION IS
;OVERRIDDEN AND THE EVENT IS THROWN AWAY.
;H-1ST-ARCHIVED IS THE FIRST ARCHIVED EVENT SEEN BY THE PREVIOUS
;CALL TO H-CLEAN. EVENTS FROM THAT ONE ON ARE NOT RE-EXAMINED
;SINCE PRESUMABLY THEY ALL STILL NEED TO BE SAVED. THAT CAN BE FALSE
;ONLY IF SOME ARCHIVE PROPERTIES HAVE BEEN REMOVED; IF THAT IS DONE
;H-1ST-ARCHIVED SHOULD BE SET TO NIL TO FORCE ALL EVENTS
;TO BE RE-EXAMINED.
(DEFUN H-CLEAN (NUMPRESERVED)
(DO ((TOP (CONS NIL H-LIST))
;THE NIL IS SO THAT DELETING THE 1ST ELT IS NO SPECIAL PROBLEM.
(PREV) (THIS)
;PREV IS OUR POINTER TO THE "PREVIOUS LINK" TO RPLACD INTO.
;THIS POINTS AT "THIS EVENT" BEING CONSIDERED FOR DELETION.
(OLD-1ST H-1ST-ARCHIVED)
(TEM))
NIL
(SETQ PREV TOP)
(DO ((I NUMPRESERVED (1- I)))
((= I 0))
(DECLARE (FIXNUM I))
(SETQ H-1ST-ARCHIVED (SETQ PREV (CDR PREV))))
LP
(SETQ THIS (CADR PREV))
;IF WE'VE CONSIDERED ALL THE EVENTS, OR ARE ABOUT TO CONSIDER ONE
;THAT WAS EXAMINED LAST TIME (AND MUST THEREFORE HAVE BEEN ARCHIVED THEN)
;THEN WE ARE FINISHED.
(AND (OR (EQ THIS OLD-1ST) (NULL THIS))
(RETURN (SETQ H-1ST-ARCHIVED (CADR H-1ST-ARCHIVED)
H-LIST (CDR TOP))))
(SETQ TEM (H-GET THIS 'ARCHIVE))
(AND (EQ TEM 'DELETE) (GO FLUSH-IT))
(AND TEM (GO SAVE-IT))
(AND H-ARCHIVE-P (FUNCALL H-ARCHIVE-P THIS)
(GO SAVE-IT))
FLUSH-IT
;THIS EVENT GETS DISCARDED; THEN WE LOOK AT THE NEXT
(RPLACD PREV (CDDR PREV))
(GO LP)
SAVE-IT
(SETQ PREV (CDR PREV))
(GO LP)))
;REDO-PRINTF-1=NIL => SUPPRESS PRINTING OF EXPRS AND VALUES AS YOU REDO.
(DEFUN H-REDO-1 (EVSPEC REDO-PRINTF-1)
;IDENTIFY THE REDO EVENT AS A HISTORY COMMAND EVENT.
(RPLACA (CDDDR H-ENTRY) 'REDO-LOSS)
(H-REDO-2 (H-REDO-GOBBLE (H-FIND EVSPEC)
NIL
NIL)
NIL
REDO-PRINTF-1))
;REDO A SPECIFIED LIST OF NEWLY CREATED OR COPIED EVENTS.
;THE EVENTS IN THE LIST HAVE THEIR VALUES AND TYPES CLOBBERED!
;IF INVIS IS T, THE REDONE EVENTS DON'T ARE NOT MADE SUBEVENTS OF THIS ONE.
;IF PRINTF IS NIL, THE EVENTS REDONE ARE NOT PRINTED OUT.
;H-REDO-2 JUST PUSHES THE LIST AS A LIST OF EVENTS WAITING TO BE REDONE,
;THEN LETS H-TOPLEV-ENTER DO THE REAL WORK.
(DEFUN H-REDO-2 (EVL INVIS PRINTF)
;IDENTIFY THIS EVENT (THE ONE WE'RE IN, NOT THE ONES WE ARE REDO-ING)
;AS THAT OF A HISTORY COMMAND WHOSE ARG WAS FOUND.
(OR INVIS (RPLACA (CDDDR H-ENTRY) 'REDO-WIN))
;NOW "PUSH" THE HISTORY CONTEXT.
(SETQ H-STACK (XCONS H-STACK (LIST H-REDO-INDENT H-REDO-EVL H-REDO-PRINTF)))
(SETQ H-REDO-EVL EVL
H-REDO-INDENT (+ H-REDO-INDENT 2 (FLATC H-COUNT))
H-REDO-PRINTF (AND H-REDO-PRINTF PRINTF))
(OR INVIS (H-PUT H-ENTRY
(NCONC (REVERSE EVL) (H-GET H-ENTRY 'GROUP))
'GROUP))
(H-TOPLEV-ENTER NIL))
;H-REDO-GOBBLE TAKES A LIST OF EVENTS AND SOME TRANSFORMATIONS, AND DOES 3 THINGS:
;(1) ANY EVENTS WHICH ARE "GROUP"S ARE REPLACED IN THE LIST BY THEIR SUBEVENTS;
;(2) THE SPECIFIED TRANSFORMATIONS ARE APPLIED TO THE INPUTS ALL OF THE EVENTS.
;(3) THE EVENTS ARE COPIED, AND THE VALUES AND EVENT-TYPES AND PLISTS ARE MADE NIL.
(DEFUN H-REDO-GOBBLE (EVL S-TRANS O-TRANS)
(MAPCAN '(LAMBDA (EV)
(COND ((H-GET EV 'GROUP)
(H-REDO-GOBBLE (H-GET EV 'GROUP) S-TRANS O-TRANS))
(T (LIST (LIST (COND ((OR S-TRANS O-TRANS)
(H-TRANSFORM-TOP S-TRANS O-TRANS
(CAR EV) NIL))
(T (CAR EV)))
(CADR EV)
(CADDR EV)
NIL
NIL)))))
EVL))
;A USER-WRITTEN READ-PROCESS LOOP THAT WANTS TO SAVE HISTORY
;SHOULD CALL THIS FUNCTION AT THE BEGINNING, SO THAT IN CASE THAT
;LOOP WAS ENTERED BY A REDO, AND THAT REDO HAS MORE EVENTS YET TO BE
;REDONE, THEY WILL BE REDONE NOW, BEFORE PROCESSING THE USER'S NEXT INPUT.
;IF PRINTLAST IS NIL, THE VALUE OF THE LAST EVENT REDONE IS NOT PRINTED,
;THE IDEA BEING THAT THE CALLER IS GOING TO PRINT IT.
;IF PRINTLAST IS 1, ONLY 1 EVENT IS REDONE. THE CALLER CAN THEN USE
;ANY CRITERIA TO DECIDE HOW LONG TO KEEP REDOING.
;IF PRINTLAST IS NOT NIL, T OR A NUMBER, REDOING CONTINUES ONLY AS
;LONG AS THE EVENTS' EVAL FUNCTION EQUALS PRINTLAST.
(DEFUN H-TOPLEV-ENTER (PRINTLAST)
(PROG (TEMV)
LP
(OR H-REDO-EVL (RETURN TEMV))
(OR (EQ PRINTLAST (NOT (NOT PRINTLAST)))
(NUMBERP PRINTLAST)
(EQ PRINTLAST (CADAR H-REDO-EVL))
(RETURN TEMV))
(SETQ TEMV (H-REDO-1EV H-REDO-INDENT H-REDO-PRINTF
(OR PRINTLAST (CDR H-REDO-EVL))
(PROG2 NIL (CAR H-REDO-EVL)
(OR (SETQ H-REDO-EVL (CDR H-REDO-EVL))
(SETQ H-REDO-INDENT (CAAR H-STACK)
H-REDO-EVL (CADAR H-STACK)
H-REDO-PRINTF (CADDAR H-STACK)
H-STACK (CDR H-STACK))))))
(AND (NUMBERP PRINTLAST) (= PRINTLAST 1) (RETURN TEMV))
(GO LP)))
;THIS REDOES A SINGLE EVENT, ASSUMING THAT THE ENVIRONMENT FOR REDO-ING
;(INCLUDING H-REDO-INDENT, ETC) HAS BEEN SET UP.
(DEFUN H-REDO-1EV (INDENT PRINTF PRINTVF H-REDO-EVENT)
(DO ((H-BEFORE H-BEFORE))
NIL
;REDO WITH H-BEFORE SET TO THE HISTORY AS IT WAS WHEN
;THIS EVENT WAS ORIGINALLY RUN, SO RE-RUN HISTORY COMMANDS WORK.
(DO ((H-EVNUM (CADDR H-REDO-EVENT)))
((OR (NOT H-BEFORE) (> H-EVNUM (CADDAR H-BEFORE))))
(DECLARE (FIXNUM H-EVNUM))
(SETQ H-BEFORE (CDR H-BEFORE)))
;PRINT THE THING TO BE RE-EVALLED, AND ITS EVENT #.
(AND PRINTF (H-PRINT2 H-REDO-EVENT INDENT NIL NIL))
(RETURN (PROG2 NIL (H-EVAL-2 H-REDO-EVENT)
;NOW PRINT THE VALUE IF USER WANTS PRINTING.
(AND PRINTF PRINTVF
(H-PRINT1 H-REDO-EVENT INDENT T NIL NIL))))))
;THESE ARE THE TOP-LEVEL DEFINITIONS OF REDO, SREDO (DON'T PRINT ANYTHING) AND USE.
(DEFUN H-REDO FEXPR (REDONUM)
(H-REDO-1 REDONUM T))
(DEFUN H-SREDO FEXPR (REDONUM)
(H-REDO-1 REDONUM NIL))
;USE DOES A REDO EXCEPT THAT IT FIRST USES H-REDO-GOBBLE TO TRANSFORM THE EVENTS.
(DEFUN H-USE FEXPR (REDO-USE-LINE)
(DO ((H-USE-NEW-S)
(H-USE-NEW-O)
(REDO-USE-LINE REDO-USE-LINE (CDR REDO-USE-LINE)))
((EQ (CAR REDO-USE-LINE) 'IN)
(H-USE-I (CDR REDO-USE-LINE) H-USE-NEW-S H-USE-NEW-O))
(COND ((NULL REDO-USE-LINE) (SETQ REDO-USE-LINE '(NIL IN)))
(T (SETQ H-USE-NEW-S
(CONS (CAR REDO-USE-LINE) H-USE-NEW-S))))))
;(USE1 X Y 1) = (USE (_ X Y) IN 1)
(DEFUN H-USE1 FEXPR (REDO-USE-LINE)
(H-USE-I (CDDR REDO-USE-LINE)
(LIST (LIST '_ (CAR REDO-USE-LINE) (CADR REDO-USE-LINE)))
NIL))
;(USEF X 1) = (USE ((__ X)) IN 1)
;REPLACES THE TOP-LEVEL FUNCTION WITH X.
(DEFUN H-USEF FEXPR (REDO-USE-LINE)
(H-USE-I (CDR REDO-USE-LINE)
NIL
(LIST (LIST (LIST '__ (CAR REDO-USE-LINE))))))
;(USEA 1 X 1) = (USE (NIL (__ X)) IN 1), WHICH REPLACES THE 1ST ARG WITH X.
;(USEA 2 X 1) = (USE (NIL NIL (__ X)) IN 1), WHICH REPLACES THE 2ND ARG, ETC.
(DEFUN H-USEA FEXPR (REDO-USE-LINE)
(H-USE-I (CDDR REDO-USE-LINE)
NIL
(LIST (DO ((I 0 (1+ I))
(X (LIST (LIST '__ (CADR REDO-USE-LINE)))
(CONS NIL X)))
((= I (CAR REDO-USE-LINE)) X)))))
;(USEQ X 1) = (USE (___ X) IN 1)
;REPLACES X WITH 'X IN 1.
(DEFUN H-USEQ FEXPR (REDO-USE-LINE)
(H-USE-I (CDR REDO-USE-LINE)
(LIST (LIST '___ (CAR REDO-USE-LINE)))
NIL))
(DEFUN H-USE-I (H-USE-LINE H-USE-NEW-S H-USE-NEW-O)
(H-REDO-2 (H-REDO-GOBBLE (H-FIND (COND (H-USE-LINE H-USE-LINE)
(H-USE-NEW-S
(CONS 'OR H-USE-NEW-S))
(T NIL)))
H-USE-NEW-S
H-USE-NEW-O)
NIL
T))
;USEH IS DONE TO REDO WITH CHANGES AN UNSATISFACTORY HISTORY COMMAND
;(THOUGH NOTHING STOPS YOU FROM USING IT AT OTHER TIMES).
;IT REDOES A SINGLE SPECIFIED EVENT WITH SUBSTITUTIONS
;BUT MAKES THAT FROB BE THIS EVENT'S INPUT, NOT A SUBEVENT.
;RETURNS THE RESULT OF THE RE-EVALUATION.
(DEFUN H-USEH FEXPR (REDO-USE-LINE)
(DO ((REDO-USE-SPECS)
(REDO-USE-OUTERMOST)
(H-FIND-REDONE T)
(REDO-USE-LINE REDO-USE-LINE (CDR REDO-USE-LINE)))
((EQ (CAR REDO-USE-LINE) 'IN)
(SETQ REDO-USE-LINE (H-FIND (CDR REDO-USE-LINE)))
(RPLACA (CDDDR H-ENTRY) NIL)
(AND (CDR REDO-USE-LINE) (ERROR 'MORE-THAN-ONE-EVENT))
(RPLACA H-ENTRY
(H-TRANSFORM-TOP REDO-USE-SPECS REDO-USE-OUTERMOST
(CAAR REDO-USE-LINE) NIL)))
(COND ((NULL REDO-USE-LINE) (SETQ REDO-USE-LINE '(NIL IN)))
(T (SETQ REDO-USE-SPECS (CONS (CAR REDO-USE-LINE) REDO-USE-SPECS)))))
(H-PRINT2 H-ENTRY H-REDO-INDENT NIL NIL)
(H-EVAL-2 H-ENTRY))
(DEFUN H-GET (EVENT PROP)
(GET (CDDDDR EVENT) PROP))
(DEFUN H-PUT (EVENT VALUE PROP)
(PUTPROP (CDDDDR EVENT) VALUE PROP))
(DEFUN H-REMPROP (EVENT PROP)
(REMPROP (CDDDDR EVENT) PROP))
;(h-find specs) returns a list of the events specified.
;all the top-level history commands call h-find and pass the
;result to something else. h-find first calls h-spec
;to convert the user's infix language into a lispish internal
;representation. then it "evaluates" that expression.
(defun h-find (redonum)
(setq redonum (h-find-n redonum))
(mapc '(lambda (ev) (h-put ev T 'archive))
redonum)
redonum)
;h-find that doesn't archive.
(defun h-find-n (redonum)
(h-find-1 (cond (redonum (h-spec redonum))
(t '(number -1)))))
(defun h-find-1 (line)
(prog (h-find-ptr)
(or (cadddr h-entry) (rplaca (cdddr h-entry) 'hist-loss))
(setq h-find-ptr (cons nil h-before))
(return (prog2 nil (h-find-eval line)
(or (eq (cadddr h-entry) 'hist-loss)
(rplaca (cdddr h-entry) 'hist-win))))))
;this is a sort of eval function, but it handles internal format event
;specs by performing the searchin or whatever and retrning the specified
;events. it works by dispatching to the h-find property of the
;function in the list, handing it the cdr of the list as argument.
(defun h-find-eval (h-find-form)
(or (get (car h-find-form) 'h-find)
(break h-find-eval t))
(funcall (get (car h-find-form) 'h-find)
(cdr h-find-form)))
;for 'and, nconc together the values of the arguments.
(defprop and h-and h-find)
(defun h-and (spec-list)
(mapcan 'h-find-eval spec-list))
;for 'then, just eval the specs and return the value of the last one.
(defprop then h-find-then h-find)
(defun h-find-then (spec-list)
(prog (val)
(mapc '(lambda (c) (setq val (h-find-eval c)))
spec-list)
(return val)))
;HANDLE 'OR BY SEARCHING FOR EACH OF THE ARGS, AND COMPARING
;THE RESULTS OBTAINED.
(DEFPROP OR H-OR H-FIND)
(DEFUN H-OR (SPEC-LIST)
(SETQ H-FIND-PTR
(DO ((H-FIND-PTR-OLD H-FIND-PTR)
(H-FIND-PTR H-FIND-PTR H-FIND-PTR-OLD)
(SPECTAIL SPEC-LIST (CDR SPECTAIL))
(TEM)
(BEST))
((NULL SPECTAIL)
(OR BEST (ERROR 'EVENT-NOT-FOUND H-FIND-FORM)))
(ERRSET (PROGN (SETQ TEM (H-FIND-EVAL (CAR SPECTAIL)))
(AND TEM (OR (NULL BEST) (> (CADDR TEM) (CADDAR BEST)))
(SETQ BEST H-FIND-PTR)))
NIL)))
(LIST (CAR H-FIND-PTR)))
;HANDLE AN APPEARANCE OF JUST ONE OF FROM, TO, THRU
;JUST PASS THE BUCK TO FROMTO. THE REASON IS THAT GENERAL FORM'S AND TO'S
;APPEAR AS (FROMTO (FROM ...) (TO ...)), BUT SIMPLE ONES MIGHT BE MISSING
;THE OUTER (FROMTO ...) AND WILL BE JUST (FROM ...) OR (TO ...).
;SO WE PRETEND THEY TOO HAD A (FROMTO ...) AROUND THEM.
(DEFPROP FROM H-FIND-FROM H-FIND)
(DEFUN H-FIND-FROM (SPEC-LIST)
SPEC-LIST ;PREVENT ERR MSG FROM NCOMPLR.
(H-FIND-EVAL (LIST 'FROMTO H-FIND-FORM)))
(DEFPROP TO H-FIND-FROM H-FIND)
(DEFPROP THRU H-FIND-FROM H-FIND)
(DEFPROP ALL H-FIND-FROM H-FIND)
;HANDLE FROM, TO, THRU, AND ALL (IN COMBINATIONS)
(DEFPROP FROMTO H-FIND-FROMTO H-FIND)
(DEFUN H-FIND-FROMTO (SPEC-LIST)
(PROG (FROM THRU ALL OTHER TYPE)
;GET ALL THE "FROM"'S IN FROM, ALL THE THRU'S AND TO'S IN THRU,
;AND ALL THE ALL'S IN ALL. UNSPECIFIED THINGS ARE FROM'S.
(SETQ THRU H-BEFORE)
(MAPC '(LAMBDA (SPEC)
(SETQ TYPE 'FROM)
(AND (MEMQ (CAR SPEC) '(FROM TO THRU ALL))
(SETQ TYPE (CAR SPEC))
(SETQ SPEC (CADR SPEC)))
(COND ((EQ TYPE 'ALL)
(SETQ ALL SPEC))
(T
(H-FIND-EVAL SPEC)
(COND ((EQ TYPE 'FROM)
(SETQ FROM (CDR H-FIND-PTR)))
((EQ TYPE 'TO)
(SETQ THRU (CDR H-FIND-PTR)))
((EQ TYPE 'THRU)
(SETQ THRU H-FIND-PTR))))))
SPEC-LIST)
(DO ((TAIL THRU (CDR TAIL)))
((EQ TAIL FROM))
(OR TAIL (ERROR 'FROM//TO-WRONG-ORDER SPEC-LIST))
(SETQ OTHER (CONS (CAR TAIL) OTHER)))
(AND OTHER ALL (RETURN (H-FIND-ALL (NREVERSE OTHER) ALL)))
(RETURN OTHER)))
;THIS FUNCTION RETURNS A LIST OF ALL THE EVENTS IN OTHER
;WHICH THE SEARCH IN ALL WILL FIND. WHEN THAT SEARCH FAILS WE RETURN.
;IF THE SEARCH EVER FAILS TO MOVE THE POINTER WE ASSUME IT ISN'T A
;REASONABLE SEARCH AND GIVE UP. THE RETURNED LIST HAS THE EVENTS
;IN THE OPPOSITE ORDER FROM THE ORIGINAL ARG.
(DEFUN H-FIND-ALL (OTHER ALL)
(DO ((H-BEFORE OTHER)
(H-FIND-PTR (CONS NIL OTHER))
(FOUNDLIST)
(FOUNDEV))
((ATOM (ERRSET (H-FIND-EVAL ALL) NIL))
FOUNDLIST)
(AND (EQ FOUNDEV (CAR H-FIND-PTR))
(ERROR 'WRNG-TYPE-ARG (CONS 'ALL ALL)))
(SETQ FOUNDLIST (CONS (SETQ FOUNDEV (CAR H-FIND-PTR))
FOUNDLIST))))
;HANDLE (@ NAME) WHERE NAME WAS H-DEF'D; GET THE EVENTS THAT NAME IS A NAME FOR.
(DEFPROP @ H-FIND-@ H-FIND)
(DEFUN H-FIND-@ (SPEC-LIST)
(PROG (TEM)
(OR (ATOM (CAR SPEC-LIST)) (GO LOSE))
(OR (SETQ TEM (GET (CAR SPEC-LIST) 'H-EVENTS)) (GO LOSE))
(RETURN (APPEND TEM NIL))
LOSE
(ERROR 'WRNG-TYPE-ARG H-FIND-FORM)))
;SCAN THE HISTORY LIST AT LEAST ONE STEP LOOKING FOR AN EVENT ON WHICH FN
;RETURNS NON-NIL. SEARCH BACKWARD IFF DIRECTION IS NIL.
;IF REACH END OR TOP OF H-BEFORE, MAKE AN ERROR USING ERRCODE.
(DEFUN H-SEARCH (FN ERRCODE DIRECTION)
(DO ((PTR (CDR (COND (DIRECTION (MEMQ (CAR H-FIND-PTR)
(REVERSE H-BEFORE)))
(T H-FIND-PTR)))
(CDR PTR)))
((AND (OR PTR (ERROR 'EVENT-NOT-FOUND ERRCODE))
(FUNCALL FN (CAR PTR)))
(SETQ H-FIND-PTR (COND (DIRECTION (MEMQ (CAR PTR) H-BEFORE))
(T PTR)))
(LIST (CAR H-FIND-PTR)))))
;FOR 'NUMBER, RETURN THE EVENT WITH THAT NUMBER.
(DEFPROP NUMBER H-FIND-NUMBER H-FIND)
(DEFUN H-FIND-NUMBER (SPEC-LIST)
(SETQ H-FIND-PTR (CONS NIL H-BEFORE))
;CONS NIL FAKES OUT H-SEARCH, WHICH ALWAYS SKIPS ONE EVENT.
(COND ((< (CAR SPEC-LIST) 0)
(H-FIND-+- (LIST (- (CAR SPEC-LIST))) NIL))
(T (DO ((ARG (CAR SPEC-LIST)))
(T (H-SEARCH
(FUNCTION (LAMBDA (EV)
(DECLARE (SPECIAL ARG))
(COND ((< ARG (* IBASE IBASE))
(= ARG (\ (CADDR EV) (* IBASE IBASE))))
(T (= (CADDR EV) ARG)))))
SPEC-LIST NIL))
(DECLARE (SPECIAL ARG))))))
;FOR '=, RETURN RESULT OF ARG EVALLED WITH H-FIND-= BOUND TO T.
(DEFPROP = H-FIND-= H-FIND)
(DEFUN H-FIND-= (SPEC-LIST)
(DO ((H-FIND-= T))
(T (H-FIND-EVAL (CAR SPEC-LIST)))))
(DEFPROP * H-FIND-* H-FIND)
(DEFUN H-FIND-* (SPEC-LIST)
(DO ((H-FIND-* T))
(T (H-FIND-EVAL (CAR SPEC-LIST)))))
(DEFPROP - H-FIND-+-1 H-FIND)
(DEFPROP + H-FIND-+-1 H-FIND)
(DEFUN H-FIND-+-1 (SPEC-LIST)
(H-FIND-+- SPEC-LIST (EQ (CAR H-FIND-FORM) '/+)))
(DEFUN H-FIND-+- (SPEC-LIST DIRECTION)
(COND ((NUMBERP (CAR SPEC-LIST))
(PROG (COUNT)
(DECLARE (SPECIAL COUNT))
(AND (= (CAR SPEC-LIST) 0)
(OR (CAR H-FIND-PTR)
(ERROR 'EVENT-NOT-FOUND H-FIND-FORM))
(RETURN (LIST (CAR H-FIND-PTR))))
(SETQ COUNT (+ (COND ((CAR H-FIND-PTR)
(CADDAR H-FIND-PTR))
((CDR H-FIND-PTR)
(1+ (CADDAR (CDR H-FIND-PTR))))
(T (ERROR 'EVENT-NOT-FOUND H-FIND-FORM)))
(COND (DIRECTION (CAR SPEC-LIST))
(T (- (CAR SPEC-LIST))))))
(RETURN (H-SEARCH (FUNCTION (LAMBDA (EV)
(DECLARE (SPECIAL COUNT))
(= COUNT (CADDR EV))))
H-FIND-FORM DIRECTION))))
(T (H-FIND-++-- SPEC-LIST DIRECTION NIL))))
(DEFPROP ++ H-FIND-ST+- H-FIND)
(DEFPROP -- H-FIND-ST+- H-FIND)
(DEFPROP S+T H-FIND-ST+- H-FIND)
(DEFPROP S-T H-FIND-ST+- H-FIND)
(DEFUN H-FIND-ST+- (SPEC-LIST)
(H-FIND-++-- SPEC-LIST
(MEMQ (CAR H-FIND-FORM) '(++ S+T))
(MEMQ (CAR H-FIND-FORM) '(S-T S+T))))
(DEFUN H-FIND-++-- (SPEC-LIST DIRECTION H-FIND-SUCHTHAT)
(DECLARE (SPECIAL SPEC-LIST H-FIND-SUCHTHAT))
(H-SEARCH (FUNCTION
(LAMBDA (EV)
(DECLARE (SPECIAL SPEC-LIST H-FIND-SUCHTHAT))
(COND (H-FIND-= (SETQ EV (CDDDDR EV))))
(COND (H-FIND-SUCHTHAT (FUNCALL (CAR SPEC-LIST) EV))
(H-FIND-*
;* FOO IS DEFINED TO MEAN *(FOO), (ELSE * FOO WOULD BE USELESS)
(AND (ATOM (CAR SPEC-LIST))
(SETQ SPEC-LIST (LIST SPEC-LIST)))
(H-TRANSFORM-TOP NIL SPEC-LIST (CAR EV) T))
;ORDINARY SEARCHES SHOULDN'T FIND HISTORY COMMANDS.
;USEH SETS H-FIND-REDONE, TO INHIBIT THAT FEATURE.
((AND (MEMQ (CADDDR EV) '(REDO-WIN HIST-WIN))
(NOT H-FIND-REDONE))
NIL)
(T (H-TRANSFORM-TOP SPEC-LIST NIL (CAR EV) T)))))
H-FIND-FORM DIRECTION))
;h-spec converts its arg, which looks like (1 foo bar to -5 and + 4)
;into internal lispish form, which looks like
;(and (fromto (then (number 1) (-- foo) (-- bar)) (to (number -5))) (+ 4))
(defun h-spec (infix-expr)
(prog (stack next stacknxt tem)
(declare (special stack))
(setq stack '((-100000000 lose nil)))
loop
(setq next (car infix-expr))
(setq stacknxt (cond ((and (eq (typep next) 'symbol)
(setq tem (get next 'h-spec-syn))
(not (and (numberp (caar stack))
(> (caar stack) 550.))))
(append tem (list next)))
(t (list nil nil next))))
;if stacknxt is not an operator, and an operator is needed,
;generate an appropriate one.
(and (null (car stacknxt))
(or (null (caar stack)) (< (caar stack) 550.))
(h-spec-do-ops (cond ((numberp (caddr stacknxt))
'(600. then number))
((get (caddr stacknxt) 'h-events)
'(600. then @))
(t '(600. then --)))))
;if stacknxt is an infix operator, and top of stack is an operator,
;complain.
(or (cadr stacknxt) (null (car stacknxt)) (null (caar stack))
(error 'infix-event-op-after-op infix-expr))
(h-spec-do-ops stacknxt)
(and (setq infix-expr (cdr infix-expr)) (go loop))
;finish up all remaining ops on the stack.
(h-spec-do-ops '(-1000000 nil nil))
(return (caddr (cadr stack)))))
;put the frob in stacknxt onto the stack. Also, perform any operators
;of higher priority that were already on the stack.
(defun h-spec-do-ops (stacknxt)
(declare (special stack))
(do () ((not (and (car stacknxt) (caadr stack)
(> (1+ (caadr stack)) (car stacknxt)))))
;here perform the op on top of stack and check again.
(cond ((cadr (cadr stack)) ;prefix op on stack?
(setq stack (cons (list nil nil (list (caddr (cadr stack))
(caddr (car stack))))
(cddr stack))))
(t ;infix op on stack.
(setq stack (cons (list nil nil (list (caddr (cadr stack))
(caddr (caddr stack))
(caddr (car stack))))
(cdddr stack)))
(and (not (atom (cadr (caddar stack))))
(eq (car (caddar stack))
(caadr (caddar stack)))
(rplaca (cddar stack)
(append (cadr (caddar stack))
(cddr (caddar stack))))))))
;if stacknxt is a prefix operator, top of stack isn't an operator,
;generate the appropriate infix operator in front.
(and (cadr stacknxt) (null (caar stack))
(h-spec-do-ops (append (get (cadr stacknxt) 'h-spec-int)
(list (cadr stacknxt)))))
(setq stack (cons stacknxt stack)))
(defprop and (100. nil) h-spec-syn)
(defprop fromto (200. nil) h-spec-int)
(defprop from (300. fromto) h-spec-syn)
(putprop 'to (get 'from 'h-spec-syn) 'h-spec-syn)
(putprop 'thru (get 'from 'h-spec-syn) 'h-spec-syn)
(putprop 'all (get 'from 'h-spec-syn) 'h-spec-syn)
(defprop then (400. nil) h-spec-int)
(defprop /= (500. then) h-spec-syn)
(putprop '/* (get '/= 'h-spec-syn) 'h-spec-syn)
(defprop /+ (600. then) h-spec-syn)
(putprop '/- (get '/+ 'h-spec-syn) 'h-spec-syn)
(putprop '/++ (get '/+ 'h-spec-syn) 'h-spec-syn)
(putprop '/-- (get '/+ 'h-spec-syn) 'h-spec-syn)
(putprop '/@ (get '/+ 'h-spec-syn) 'h-spec-syn)
(putprop 's-t (get '/+ 'h-spec-syn) 'h-spec-syn)
(putprop 's+t (get '/+ 'h-spec-syn) 'h-spec-syn)
;H-PR PRINTS OUT SOME HISTORY. H-PV PRINTS THE VALUES TOO.
(DEFUN H-PR FEXPR (NUM) (H-PRINT NUM NIL T NIL))
(DEFUN H-PV FEXPR (NUM) (H-PRINT NUM T T NIL))
(DEFUN H-PB FEXPR (NUM) (H-PRINT NUM T T T))
(DEFUN H-PRINT (NUM VALUEFLG INPUTFLG BACKWARDS)
(MAPC '(LAMBDA (EVENT)
(H-PRINT1 EVENT (+ 2 (FLATC H-COUNT) H-REDO-INDENT)
VALUEFLG INPUTFLG T))
(COND (BACKWARDS (NREVERSE (H-FIND-N NUM)))
(T (H-FIND-N NUM))))
T)
;INTERNAL HISTORY PRINTER. TAKES A SINGLE EVENT, AN INDENTATION TO USE
;(THAT MANY SPACES PRECEDE THE INPUT, AND THAT MANY PLUS AN APPROPRIATE
;EXTRA INDENTATION PRECEDE THE VALUE), AND 3 FLAGS SAYING WHETHER
;TO PRINT THE VALUE, WHETHER TO PRINT THE INPUT, AND WHETHER TO
;RECUR PRINTING THE SUBEVENTS IF ANY (INPUTFLG=NIL OVERRIDES IT).
(DEFUN H-PRINT1 (EVENT INDENT VALUEFLG INPUTFLG RECURFLG)
(PROG (TEM)
(AND INPUTFLG
(H-PRINT2 EVENT INDENT VALUEFLG RECURFLG))
(AND VALUEFLG (PROGN ;MAYBE PRINT THE VALUE TOO.
(TERPRI)
(H-SPACETO (+ 1 INDENT (FLATC (CADDR EVENT))))
(COND ((CADDDR EVENT)
(PRINC '=>/ )
(COND ((SETQ TEM (GET (CADR EVENT) 'H-PRINT-O))
(FUNCALL TEM EVENT))
(H-PRINT-O (FUNCALL H-PRINT-O EVENT))
(PRIN1 (FUNCALL PRIN1 (CAR (CDDDDR EVENT))))
(T (PRIN1 (CAR (CDDDDR EVENT))))))
(T (PRINC '|-EVENT HAD NO VALUE-|)))))))
(DEFUN H-PRINT2 (EVENT INDENT VALUEFLG RECURFLG)
(PROG (TEM INPUT)
(SETQ INPUT (CAR EVENT))
(TERPRI)
(H-SPACETO INDENT)
(PRIN1 (CADDR EVENT)) ;PRINT # OF EVENT.
(PRINC '/:/ )
(COND ((SETQ TEM (GET (CADR EVENT) 'H-PRINT-I))
(FUNCALL TEM EVENT))
(H-PRINT-I (FUNCALL H-PRINT-I EVENT))
(T (PRIN1 INPUT))) ;PRINT THE USER'S INPUT.
(SETQ TEM (H-GET EVENT 'GROUP))
(AND TEM RECURFLG
(MAPC '(LAMBDA (SUBEV)
(H-PRINT1 SUBEV (+ 2 (FLATC (CADDR EVENT)) INDENT)
VALUEFLG T RECURFLG))
TEM))))
(DEFUN H-SPACETO (N)
(DO ((I (- N (- LINEL CHRCT)) (1- I)))
((= I 0))
(TYO 40)))
;APPLY A LIST OF TRANSFORMATIONS H-TLIST TO INPUT,
;AND APPLY THOSE IN OUTER-TLIST ONLY AT THE OUTERMOST LEVEL OF INPUT
;(THAT IS, DON'T TRY IT AT CAR OR CDR OF INPUT).
;AND RETURN A SINGLE OBJECT AS A RESULT (BARFING IF MORE THAN ONE RESULTS
;FROM THE TRANSFORMATIONS).
;H-TRANSFORM-NOCHANGE SAYS IGNORE COMMANDS TO SUBSTITUTE; JUST MATCH.
;IN THAT CASE, WE (AND THE OTHER H-TRANSFORM FUNCTIONS) RETURN NON-NIL
;IFF THERE IS A MATCH.
(DEFUN H-TRANSFORM-TOP (H-TLIST OUTER-TLIST INPUT H-TRANSFORM-NOCHANGE)
(PROG (TEM)
(SETQ TEM (DO ((TLIST1 OUTER-TLIST (CDR TLIST1)))
((NULL TLIST1) (H-TRANSFORM-T INPUT NIL))
(CATCH (RETURN (H-TRANSFORM1 (CAR TLIST1) INPUT NIL))
TRANSFORM)))
(RETURN (COND (H-TRANSFORM-NOCHANGE TEM)
((OR (ATOM TEM)
(CDR TEM))
(ERROR '|USE-ING TURNED AN OBJECT INTO A SEGMENT|
TEM))
(T (CAR TEM))))))
;APPLY THE TRANSFORMATIONS IN H-TLIST RECURSIVELY AT ALL LEVELS IN OBJ.
;IF TAILF IS NIL, ASSUME OBJ IS THE CDR OF SOMETHING.
;IF TAILF IS T, ASSUME OBJ IS THE CAR OF SOMETHING. IN THAT CASE,
;RETURN NOT JUST THE TRANSFORMED OBJ BUT A LIST OF THINGS
;IN CASE OBJ IS REPLACED BY A SEGMENT. THE CALLER MUST SPLICE THE
;LIST RETURNED WHEN TAILF=NIL INTO WHATEVER HE IS CONSTRUCTING.
(DEFUN H-TRANSFORM-T (OBJ TAILF)
(PROG (NEW NCAR NCDR TLIST1)
;A TAIL SHOULDN'T HAVE THE TRANSFORMATIONS APPLIED TO IT;
;IT SHOULD JUST PASS THE BUCK TO ITS CAR AND CDR.
(AND TAILF (GO NOTRAN))
(OR (SETQ TLIST1 H-TLIST) (GO NOTRAN))
LOOP
;TRY APPLYING THE NEXT TRANSFORMATION TO THIS OBJECT.
;IF IT SUCCEEDS (DOESN'T THROW TO TRANSFORM), RETURN THE RESULT.
;IF IT FAILS, TRY THE NEXT TRANSFORMATION.
(OR (CAR TLIST1) (RETURN (LIST OBJ)))
; ^ PREVENTS 'NIL IN H-TLIST FROM CAUSING INFINITE RECURSION.
(CATCH (RETURN (H-TRANSFORM1 (CAR TLIST1) OBJ TAILF))
TRANSFORM)
(AND (SETQ TLIST1 (CDR TLIST1))
(GO LOOP))
NOTRAN
;ALL THE TRANSFORMATIONS FAIL ON THIS OBJECT =>
;TRANSFORM THE CAR AND CDR RECURSIVELY IF POSSIBLE.
(SETQ NEW OBJ)
(AND (ATOM OBJ) (GO OUT))
(OR H-TLIST (GO OUT))
(SETQ NCAR (H-TRANSFORM-T (CAR OBJ) NIL)
NCDR (H-TRANSFORM-T (CDR OBJ) T))
(COND (H-TRANSFORM-NOCHANGE (RETURN (OR NCAR NCDR)))
((AND (EQ (CAR NCAR) (CAR OBJ))
(NULL (CDR NCAR))
(EQ NCDR (CDR OBJ)))
(SETQ NEW OBJ))
(T (SETQ NEW (NCONC NCAR NCDR))))
OUT (RETURN (COND (H-TRANSFORM-NOCHANGE NIL)
(TAILF NEW)
(T (LIST NEW))))))
;H-TRANSFORM1 IS AN INTERFACE TO H-TRANSFORM. IT TREATS ITS PATTER
;AS IF IT WERE A CAR OF ANOTHER PATTERN, SO THAT (_ A B) AND (@ ...)
;ARE RECOGNIZED WHEN THEY APPEAR STAND-ALONE.
(DEFUN H-TRANSFORM1 (PAT OBJ TAILF)
(COND (TAILF (H-TRANSFORM PAT OBJ TAILF))
(T (H-TRANSFORM (LIST PAT) (LIST OBJ) TAILF))))
;H-TRANSFORM TRANSFORMS OBJ BY THE PATTERN PAT. OPTIONS FOR PAT ARE:
;NIL MATCHES ANYTHING AND DOESN'T CHANGE IT.
;AN ATOM MATCHES ONLY ITSELF.
;(_ <PAT> . <NEW>) MATCHES WHAT <PAT> MATCHES, AND REPLACES IT WITH
;THE SEGMENT <NEW> IN THE LIST IT'S IN.
;(@ . <SEGMENT>) MATCHES THAT SEGMENT. USEFUL AS THE 1ST ARG OF A _.
;IF THERE ARE NESTED _'S, THE OUTER ONE'S VALUE SUPERCEDES THE OTHERS.
;(@ ...) AND (_ ...) ARE RECOGNIZED ONLY AS CARS, NOT AS TAILS.
;(__ X) IS THE SAME AS (_ NIL X)
;(___ X) MEANS FIND X AND REPLACE WHATEVER X MATCHES WITH (LIST 'QUOTE OF IT).
;(___ (@ ...)) OR EQUIVALENT DOES NOT WORK.
;(@) IS THE WILD-CARD SEGMENT (IT MATCHES ANY SEGMENT, BUT AS SHORT A ONE
;AS IS OK WITH WHAT FOLLOWS IT).
;IF THE MATCHING FAILS, WE (THROW NIL TRANSFORM). IF WE RETURN,
;THE MATCH SUCCEEDED AND OUR VALUE IS THE TRANSFORMED OBJECT.
;WHENEVER A SUBOBJECT IS PASSED THROUGH BECAUSE IT IS MATCHED BY A NIL
;IN THE PATTERN, IT SHOULD BE SUBJECTED TO H-TRANSFORM-T;
;OTHERWISE, THE RESULTS GIVE THE APPEARANCE ON TRANSFORMATIONS INHIBITING EACH OTHER.
(DEFUN H-TRANSFORM (PAT OBJ TAILF)
(PROG (A B NEWVALPTR NEWVALFLAG QUOTEFLAG)
;IF A _ SPECIFIED A REPLACEMENT IN THIS TRANSF, NEWVALFLAG IS TRUE
;AND NEWVALPTR IS THE SEGMENT TO REPLACE WITH.
;IF A ___ SPECIFIED QUOTE-ING, QUOTEFLAG IS TRUE.
(AND (NULL PAT) (RETURN (COND (TAILF (H-TRANSFORM-T OBJ TAILF))
(T (CAR (H-TRANSFORM-T OBJ TAILF))))))
(AND (NUMBERP PAT) (COND ((AND (NUMBERP OBJ) (EQUAL PAT OBJ))
(RETURN OBJ))
(T (THROW NIL TRANSFORM))))
(AND (ATOM PAT) (COND ((EQ PAT OBJ) (RETURN OBJ))
(T (THROW NIL TRANSFORM))))
(AND (ATOM OBJ) (THROW NIL TRANSFORM))
LP
;IF THE CAR IS A (_ ...), EXTRACT THE NEW VALUE SEGMENT,
;AND REPLACE ((_ FOO ...) . BAR) WITH (FOO . BAR) IN PAT.
;REASON FOR TESTING NEWVALFLAG HERE IS SO OUTERMOST _ WINS.
(AND (NOT (ATOM (CAR PAT)))
(COND ((EQ (CAAR PAT) '_)
(SETQ NEWVALPTR (COND (NEWVALFLAG NEWVALPTR) (T (CDDAR PAT)))
PAT (CONS (CADAR PAT) (CDR PAT))
NEWVALFLAG T)
(GO LP))
((EQ (CAAR PAT) '__)
(SETQ NEWVALPTR (COND (NEWVALFLAG NEWVALPTR) (T (CDAR PAT)))
PAT (CONS NIL (CDR PAT))
NEWVALFLAG T)
(GO LP))
((EQ (CAAR PAT) '___)
(OR NEWVALFLAG (SETQ QUOTEFLAG T))
(SETQ PAT (CONS (CADAR PAT) (CDR PAT)))
(GO LP))))
;HANDLE (___ (_ FOO BAR)) (WHAT A STRANGE CONSTRUCTION!)
;BY TURNING IT INTO (_ FOO 'BAR)
(AND QUOTEFLAG NEWVALPTR
(SETQ NEWVALPTR (MAPCAR '(LAMBDA (X) (LIST 'QUOTE X))
NEWVALPTR)))
;NOW THAT WE'VE COLLECTED REQUESTS TO CHANGE WHAT WE MATCH,
;THROW THEM AWAY IF IN LOOK-BUT-DON'T-TOUCH MODE (INSIDE H-FIND)
(AND H-TRANSFORM-NOCHANGE
(SETQ NEWVALFLAG NIL QUOTEFLAG NIL))
;NOW HANDLE THE CASE THAT OUR CAR IS A (@ ...).
(AND (NOT (ATOM (CAR PAT)))
(EQ (CAAR PAT) '@)
(OR (CDAR PAT)
;HERE IF PAT'S CAR IS (@)
(RETURN
(PROG (OBJ1 OBJHEAD NEW)
;OBJ1 HAS THE TAIL OF OBJ WHICH (WE ARE SUPPOSING)
;IS NOT GOBBLED UP BY THE (@)
;OBJHEAD IS A LIST (REVERSED) OF THE ELTS OF OBJ
;THAT ARE NOT IN OBJ1 (HAVE BEEN CDR'D AWAY).
;IF OUR PATTERN IS JUST ((@)), ASSUME IT MATCHES THE WHOLE
;LIST, SO OBJ1 SHOULD BE NIL. ((@)) IS LIKE NIL
;BUT ALLOWS ((_ (@) ...))
(OR (CDR PAT)
(RETURN (COND (H-TRANSFORM-NOCHANGE T)
(NEWVALFLAG (APPEND NEWVALPTR NIL))
(T (H-TRANSFORM-T OBJ TAILF)))))
;IF THERE'S STUFF IN PAT AFTER THE (@), THAT STUFF MUST MATCH
;WHAT THE (@) DOESN'T GOBBLE, SO TRY VARIOUS AMOUNTS.
(SETQ OBJ1 OBJ)
LP1
(CATCH (PROGN (SETQ NEW (H-TRANSFORM (CDR PAT) OBJ1 T))
(GO WIN))
TRANSFORM)
(SETQ OBJHEAD (CONS (CAR OBJ1) OBJHEAD))
(AND (SETQ OBJ1 (CDR OBJ1))
(GO LP1))
;WE'VE TRIED ALL THE TAILS OF OBJ, AND NONE MATCHES (CDR PAT):
(THROW NIL TRANSFORM)
WIN
(RETURN (COND (H-TRANSFORM-NOCHANGE)
(NEWVALFLAG (APPEND NEWVALPTR NEW))
(T (NRECONC OBJHEAD NEW)))))))
(RETURN (DO ((PAT1 (CDAR PAT) (CDR PAT1)) (NEWOBJ))
((NULL PAT1)
(COND (H-TRANSFORM-NOCHANGE)
(NEWVALPTR (APPEND NEWVALPTR
(H-TRANSFORM PAT1 OBJ T)))
(T (NRECONC NEWOBJ (H-TRANSFORM PAT1 OBJ T)))))
(AND (NULL OBJ) (THROW NIL TRANSFORM))
(SETQ NEWOBJ (CONS (H-TRANSFORM (CAR PAT1)
(CAR OBJ) NIL)
NEWOBJ))
(SETQ OBJ (CDR OBJ)))) )
;PAT'S CAR IS NEITHER (@ ...) NOR (_ ...) (ANY MORE),
;SO SEE IF OUR CAR AND CDR MATCH THE PATTERN.
(SETQ B (H-TRANSFORM (CDR PAT) (CDR OBJ) T))
(SETQ A (H-TRANSFORM (CAR PAT) (CAR OBJ) NIL))
;WE MATCH THE PATTERN; IF PAT'S CAR WAS ORIGINALY (_ ...) PERFORM
;THE DESIRED SUBSTITUTION FOR OUR CAR NOW. IN DON'T TOUCH MODE,
;RETURN T FOR "DOES MATCH"
(AND H-TRANSFORM-NOCHANGE (RETURN T))
(AND NEWVALFLAG (RETURN (APPEND NEWVALPTR B)))
;NOW, IF PAT'S CAR WAS A ___, PUT A QUOTE AROUND THE ALTERED CAR.
(AND QUOTEFLAG (SETQ A (LIST 'QUOTE A)))
(AND (EQ A (CAR OBJ)) (EQ B (CDR OBJ))
(RETURN OBJ))
(RETURN (CONS A B))))
;(h-def foo <event-specs>)
;(h-def (foo <args>) <event specs>)
;(h-def foo <h-def specs> in <event specs>)
;<event specs> are passed to h-find to get a set of events.
;foo is made a name for that set of events. Calling foo will
;redo those events. If args are specified,
;foo is given that set of arg names; when foo is called, the args supplied
;will be substituted for the arg names a la use.
;normally the events redone are not printed. If (print) is among
;the <h-def specs> they will be printed. Atoms among the
;<h-def specs> are stuck at the end of <args>, so that
;(h-def (foo x) ...) = (h-def foo x in ...)
(defun h-def fexpr (line)
(prog (name specs argnames pflag)
(setq name (car line)
specs (cdr line)
line specs)
lp
(or (atom name)
(setq argnames (cdr name)
name (car name)))
(or (atom name)
(setq name (car (error 'wrng-type-arg (list name) 'wrng-type-arg)))
(go lp))
(and (getl name '(expr fexpr lsubr subr fsubr macro autoload))
(error 'already-a-function name))
(cond ((memq 'in line)
(setq specs (cdr (memq 'in line)))
(setq line (subst nil (memq 'in line) line))
(and (member '(print) line)
(setq pflag t)
(setq line (delete '(print) line)))
(and line (setq argnames (append argnames line)))))
(putprop name
(h-find-n specs)
'h-events)
(putprop name argnames 'h-args)
(putprop name 'h-run-name 'macro)
(remprop name 'h-run-print)
(and pflag (putprop name t 'h-run-print))
(return name)))
(defun h-run-name (form)
(prog (hname argl alist tem)
(declare (fixnum tem))
lp
(setq hname (car form)
argl (cdr form))
(or (get hname 'h-events)
(error 'not-a-h-name hname))
(or (= (setq tem (length (get hname 'h-args)))
(length argl))
(progn (setq form (error 'wrng-no-args (list hname tem) 'wrng-no-args))
(go lp)))
(setq alist
(list (cons 'foo (mapcar '(lambda (var val) (list '_ var val))
(get hname 'h-args)
argl))
(cons 'bar (get hname 'h-events))
(cons 'pflag (get hname 'h-run-print))))
(return (sublis alist
'(h-redo-2 (h-redo-gobble 'bar 'foo nil)
t
'pflag)))))
;FUNCTION FOR EXPLICITLY ARCHIVING SOME EVENTS
(DEFUN H-ARCH FEXPR (LINE)
(H-FIND LINE)
T)
(DEFUN H-UNARCH FEXPR (LINE)
(MAPC '(LAMBDA (EV) (H-PUT EV 'DELETE 'ARCHIVE))
(H-FIND LINE))
T)
;(H-VALUE <EVENT-SPEC>) RETURNS THE VALUE THE THE SPECIFIED EVENT HAD.
(DEFUN H-VALUE FEXPR (ARG)
(PROG (LINE)
(SETQ LINE (H-FIND ARG))
(AND (CDR LINE) (ERROR 'MORE-THAN-ONE-EVENT ARG))
(SETQ LINE (CAR LINE))
(OR (MEMQ (CADDDR LINE) '(T REDO-WIN HIST-WIN))
(ERROR 'EVENT-HAD-NO-VALUE LINE))
(RETURN (CAR (CDDDDR LINE)))))
;(H-VALUE <EVENT-SPEC>) RETURNS THE INPUT THAT THE SPECIFIED EVENT HAD.
(DEFUN H-INPUT FEXPR (ARG)
(PROG (LINE)
(SETQ LINE (H-FIND ARG))
(AND (CDR LINE) (ERROR 'MORE-THAN-ONE-EVENT ARG))
(SETQ LINE (CAR LINE))
(RETURN (CAR LINE))))
(DEFUN H-REPEAT FEXPR (REDO-USE-LINE)
(DO ((REPEAT-END (CAR REDO-USE-LINE))
(COUNT 0 (1+ COUNT)))
((= COUNT REPEAT-END) T)
(DECLARE (SPECIAL COUNT) (FIXNUM REPEAT-END))
(EVAL (CADR REDO-USE-LINE))))
(MAPC '(LAMBDA (AT1)
(PROG (AT2 TEM)
(SETQ AT2 (IMPLODE (APPEND '(H -) (EXPLODE AT1))))
(OR (GETL AT1 '(EXPR FEXPR SUBR FSUBR LSUBR MACRO AUTOLOAD))
(AND (SETQ TEM (GETL AT2 '(EXPR FEXPR SUBR FSUBR LSUBR)))
(PUTPROP AT1 (CADR TEM) (CAR TEM))))))
'(USE USE1 USEA USEF USEQ USEH REDO SREDO REPEAT))
(DEFUN H-TOPLEV-MAIN ()
(DO ((H-TOPLEV-FIRST T NIL) (H-TOPLEV-TEM))
(NIL)
(OR (STATUS LINMODE) (TERPRI))
(COND (H-TOPLEV-FIRST (PRIN1 '*))
((SETQ H-TOPLEV-TEM (GET (CADAR H-LIST) 'H-PRINT-O))
(FUNCALL H-TOPLEV-TEM (CAR H-LIST)))
(H-PRINT-O (FUNCALL H-PRINT-O (CAR H-LIST)))
(PRIN1 (FUNCALL PRIN1 *))
(T (PRIN1 *)))
(TERPRI)
(PRIN1 (1+ H-COUNT))
(PRINC '/:/ )
(SETQ - (COND (READ (FUNCALL READ)) (T (READ))))
(COND (LISPXFNS (SETQ - (LISPX// -))))
(DO ((+ (PROG2 NIL + (SETQ + -))))
(T (SETQ * (H-EVAL - H-LIST))))))
(SSTATUS TOPLEV '(H-TOPLEV-MAIN))
Reference in New Issue View Git Blame Copy Permalink