(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SEDIT" BASE 10) (IL:FILECREATED " 4-Jan-2021 22:52:01" IL:|{DSK}larry>ilisp>medley>SEDIT-COMMONLISP.;1| 56338 IL:|previous| IL:|date:| "11-Jan-91 23:44:41" IL:|{DSK}larry>ilisp>medley>library>SEDIT-COMMONLISP.;1|) ; Copyright (c) 1987, 1988, 1989, 1990, 1991, 2021 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-COMMONLISPCOMS) (IL:RPAQQ IL:SEDIT-COMMONLISPCOMS ((IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:DECLARE\: IL:DOCOPY IL:DOEVAL@COMPILE (IL:FILES (IL:SYSLOAD) IL:TEXTMODULES)) (IL:GLOBALVARS TYPE-NEW-QUOTE TYPE-READABLE-READ-TIME-CONDITIONAL TYPE-UNREADABLE-READ-TIME-CONDITIONAL) (IL:* IL:|;;;| "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP.") (IL:* IL:|;;| "Support for NEW-QUOTE, the type for #, and #.") (IL:FNS COPY-STRUCTURE-NEW-QUOTE INPUT-NEW-QUOTE PARSE--NEW-QUOTE REPLACE-NEW-QUOTE SUBNODE-CHANGED-NEW-QUOTE) (IL:* IL:|;;| "Support for READABLE-READ-TIME-CONDITIONAL and UNREADABLE-READ-TIME-CONDITIONAL, the types for #+ and #-") (IL:FNS ASSIGN-FORMAT-READ-TIME-CONDITIONAL BACKSPACE-READ-TIME-CONDITIONAL CFV-READ-TIME-CONDITIONAL COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COPY-STRUCTURE-READ-TIME-CONDITIONAL CREATE-NEW-READ-TIME-CONDITIONAL DELETE-READ-TIME-CONDITIONAL INPUT-CONDITIONAL-READ INSERT-READ-TIME-CONDITIONAL INSERT-FLIPPED-READ-TIME-CONDITIONAL LINEARIZE-READ-TIME-CONDITIONAL PARSE--CONDITIONAL-READ REPLACE-READ-TIME-CONDITIONAL SET-POINT-READ-TIME-CONDITIONAL SET-SELECTION-READ-TIME-CONDITIONAL STRINGIFY-READ-TIME-CONDITIONAL SUBNODE-CHANGED-READABLE-RTC SUBNODE-CHANGED-UNREADABLE-RTC UNDO-REPLACE-READ-TIME-CONDITIONAL) (IL:* IL:|;;| "Other junk including INITIALIZE-COMMONLISP, the installation function and STRING-FLIP, the convenient string/unstring key ") (IL:FNS CONDITIONALIZE-CURRENT-SELECTION CREATE-NEW-QUOTED-GAP INITIALIZE-COMMONLISP INSERT-NEW-QUOTED-GAP INSERT-NEW-READ-TIME-CONDITIONAL-GAP INPUT-PLUS-OR-MINUS STRING-FLIP) (IL:* IL:|;;| "Advice implementing readtable hack") (IL:FUNCTIONS ADD-NEW-QUOTE-LIKE ICL TM::MUNG-SEDIT-READ-TABLE) (IL:ADVISE SETUP-PROFILE) (IL:VARIABLES TM::*SEDIT-READ-TABLES*) (IL:* IL:|;;| "Temporarily commenting this out for playing-around purposes") (IL:P (INITIALIZE-COMMONLISP)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SEDIT-COMMONLISP))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:DECLARE\: IL:DOCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD (IL:SYSLOAD) IL:TEXTMODULES) ) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS TYPE-NEW-QUOTE TYPE-READABLE-READ-TIME-CONDITIONAL TYPE-UNREADABLE-READ-TIME-CONDITIONAL) ) (IL:* IL:|;;;| "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP." ) (IL:* IL:|;;| "Support for NEW-QUOTE, the type for #, and #.") (IL:DEFINEQ (COPY-STRUCTURE-NEW-QUOTE (IL:LAMBDA (NODE) (IL:* IL:\; "Edited 18-Feb-88 16:07 by raf") (IL:REPLACE STRUCTURE IL:OF NODE IL:WITH (LET ((STRUC (TM::COPY-PREFIX-QUOTE (IL:FETCH STRUCTURE IL:OF NODE)))) (SETF (TM::PREFIX-QUOTE-CONTENTS STRUC) (IL:FETCH STRUCTURE IL:OF (SUBNODE 1 NODE))) STRUC)))) (INPUT-NEW-QUOTE (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 18-Feb-88 17:10 by raf") (IL:* IL:|;;;| "Control character command to insert a new quote type with gap.") (CASE (TYPE-OF-INPUT CONTEXT) (STRUCTURE (IL:* IL:\; "If we're structure pointing (between the hairs of the universe) a new quote object is made and inserted.") (CLOSE-OPEN-NODE CONTEXT) (INSERT-NEW-QUOTED-GAP CONTEXT CHARCODE QUOTE-TYPE)) (ATOM (IL:* IL:\; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (IL:APPLY* (IL:FETCH DEFAULT-CHAR-HANDLER IL:OF (IL:FETCH ENVIRONMENT IL:OF CONTEXT)) CONTEXT CHARCODE))))) (PARSE--NEW-QUOTE (IL:LAMBDA (STRUCTURE CONTEXT MODE) (IL:* IL:\; "Edited 18-Feb-88 17:24 by raf") (WHEN (AND (OR (NULL MODE) (EQ MODE 'DATA)) (TM::PREFIX-QUOTE-CONTENTS STRUCTURE)) (BUILD-NODE STRUCTURE CONTEXT TYPE-NEW-QUOTE) (IL:|replace| UNASSIGNED IL:|of| (IL:|fetch| CURRENT-NODE IL:|of| CONTEXT) IL:|with| (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT) ) (TM::PREFIX-QUOTE-TYPE STRUCTURE))) (PARSE (TM::PREFIX-QUOTE-CONTENTS STRUCTURE) CONTEXT NIL) T))) (REPLACE-NEW-QUOTE (IL:LAMBDA (NODE CONTEXT WHERE SUBNODES POINT) (IL:* IL:\; "Edited 23-Feb-88 18:58 by raf") (LET ((SUBNODE (CAR SUBNODES))) (UNLESS (OR (AND (IL:TYPE? EDIT-SELECTION WHERE) (EQ (IL:FETCH SELECT-START IL:OF WHERE) 1) (EQ (IL:FETCH SELECT-END IL:OF WHERE) 1)) (IL:TYPE? EDIT-NODE WHERE)) (IL:SHOULDNT "weird bounds for replace.quote")) (UNDO-BY UNDO-REPLACE-QUOTE NODE (SUBNODE 1 NODE)) (KILL-NODE (SUBNODE 1 NODE)) (RPLACA (CDR (IL:FETCH SUB-NODES IL:OF NODE)) SUBNODE) (IL:REPLACE SUPER-NODE IL:OF SUBNODE IL:WITH NODE) (IL:REPLACE SUB-NODE-INDEX IL:OF SUBNODE IL:WITH 1) (SETF (TM::PREFIX-QUOTE-CONTENTS (IL:FETCH STRUCTURE IL:OF NODE)) (IL:FETCH STRUCTURE IL:OF SUBNODE)) (SET-DEPTH SUBNODE (IL:ADD1 (IL:FETCH DEPTH IL:OF NODE))) (NOTE-CHANGE NODE CONTEXT) (WHEN POINT (PUNT-SET-POINT POINT CONTEXT NODE T)) (CDR SUBNODES)))) (SUBNODE-CHANGED-NEW-QUOTE (IL:LAMBDA (NODE SUBNODE) (IL:* IL:\; "Edited 18-Feb-88 17:39 by raf") (SETF (TM::PREFIX-QUOTE-CONTENTS (IL:FETCH STRUCTURE IL:OF NODE)) (IL:FETCH STRUCTURE IL:OF SUBNODE)))) ) (IL:* IL:|;;| "Support for READABLE-READ-TIME-CONDITIONAL and UNREADABLE-READ-TIME-CONDITIONAL, the types for #+ and #-" ) (IL:DEFINEQ (ASSIGN-FORMAT-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT FORMAT) (IL:* IL:\; "Edited 2-Jan-91 22:15 by jrb:") (IL:* IL:|;;| "We only have to worry about setting up the expression node's list-format.") (LET ((EXPR-NODE (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (WHEN (EQ TYPE-LIST (IL:|fetch| NODE-TYPE IL:|of| EXPR-NODE)) (IL:|replace| UNASSIGNED IL:|of| EXPR-NODE IL:|with| (COND ((IL:|type?| LIST-FORMAT FORMAT) FORMAT) (T (OR (GETHASH (CAR (IL:|fetch| STRUCTURE IL:|of| EXPR-NODE)) LIST-FORMATS-TABLE) (GET-LIST-FORMAT :DEFAULT)))))))) ) (BACKSPACE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT INDEX) (IL:* IL:\; "Edited 18-Feb-88 15:26 by raf") (COND ((NULL INDEX) (IL:* IL:\;  "backspace from right boundary puts caret into the read.time.conditional's FORM.") (LET ((POINT (IL:FETCH CARET-POINT IL:OF CONTEXT))) (IL:REPLACE POINT-NODE IL:OF POINT IL:WITH NODE) (IL:REPLACE POINT-INDEX IL:OF POINT IL:WITH (CAR (IL:FETCH SUB-NODES IL:OF NODE))) (IL:REPLACE POINT-TYPE IL:OF POINT IL:WITH 'STRUCTURE)) (SET-SELECTION-NOWHERE (IL:FETCH SELECTION IL:OF CONTEXT))) ((EQ 0 INDEX) (IL:* IL:\;  "backspace from before first element deletes the read.time.conditional if its empty.") (IF (NULL (CDR (IL:FETCH SUB-NODES IL:OF NODE))) (DELETE-NODES (IL:FETCH SUPER-NODE IL:OF NODE) CONTEXT NODE NIL (IL:FETCH CARET-POINT IL:OF CONTEXT)))) (T (IL:* IL:\;  "backspacing after an element of the read.time.conditional is handled by that subnode.") (IL:SETQ NODE (SUBNODE INDEX NODE)) (IL:APPLY* (IL:FETCH BACK-SPACE IL:OF (IL:FETCH NODE-TYPE IL:OF NODE)) NODE CONTEXT))))) (CFV-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE ENVIRONMENT CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 13:30 by jrb:") (LET ((HASH-WIDTH (IL:|fetch| WIDTH IL:|of| (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| ENVIRONMENT) (ECASE (TM::READ-TIME-CONDITIONAL-SIGN (IL:|fetch| STRUCTURE IL:|of| NODE)) (#\+ :HASH-PLUS) (#\- :HASH-MINUS))))) (FEATURE (SECOND (IL:|fetch| SUB-NODES IL:|of| NODE))) (FORM (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (LET ((TOTAL-WIDTH (IL:IPLUS HASH-WIDTH (IL:|fetch| INLINE-WIDTH IL:|of| FEATURE) (IL:|fetch| PREFERRED-WIDTH IL:|of| FORM)))) (IL:|replace| INLINE-WIDTH IL:|of| NODE IL:|with| TOTAL-WIDTH) (IL:|replace| PREFERRED-WIDTH IL:|of| NODE IL:|with| TOTAL-WIDTH)))) ) (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL (IL:LAMBDA (POINT CONTEXT) (IL:* IL:\; "Edited 2-Jan-91 16:14 by jrb:") (IL:* IL:|;;| "I'm not !00% sure but I think this will work fof the new RTCs - JRB") (LET ((NODE (IL:|fetch| POINT-NODE IL:|of| POINT)) SUBNODE ITEM) (COND ((EQ 0 (IL:|fetch| POINT-INDEX IL:|of| POINT)) (IL:* IL:|;;| "Before the first element -- right after the hash, which we assume is the first item in the linear form.") (IL:|replace| POINT-X IL:|of| POINT IL:|with| (IL:IPLUS (IL:|fetch| START-X IL:|of| NODE) (IL:|fetch| WIDTH IL:|of| (CAR (IL:|fetch| LINEAR-FORM IL:|of| NODE))))) (IL:|replace| POINT-LINE IL:|of| POINT IL:|with| (IL:|fetch| FIRST-LINE IL:|of| NODE))) (T (IL:* IL:\; "Find the subnode the point will follow.") (SETQ SUBNODE (SUBNODE (IL:FETCH POINT-INDEX IL:OF POINT) NODE)) (IL:|replace| POINT-LINE IL:|of| POINT IL:|with| (IL:|fetch| LAST-LINE IL:|of| SUBNODE)) (SETQ ITEM (CADR (IL:FETCH LINEAR-THREAD IL:OF SUBNODE))) (IL:|replace| POINT-X IL:|of| POINT IL:|with| (IL:IPLUS (IL:|fetch| START-X IL:|of| SUBNODE) (IL:|fetch| ACTUAL-LLENGTH IL:|of| SUBNODE) (IL:|if| (IL:SMALLP ITEM) IL:|then| (IL:* IL:\; "it's followed by space -- put the caret in the middle") (IL:IMIN (IL:HALF ITEM) 6) IL:|else| (IL:* IL:\; "it's followed by something else -- presumably the close paren -- so put the caret immediately after it") 0))))))) ) (COPY-STRUCTURE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE) (IL:* IL:\; "Edited 3-Jan-91 15:57 by jrb:") (IL:|replace| STRUCTURE IL:|of| NODE IL:|with| (LET ((NEWSTRUCT (FUNCALL (ETYPECASE (IL:|fetch| STRUCTURE IL:|of| NODE) (TM::HASH-IL-READABLE (QUOTE TM::COPY-HASH-IL-READABLE)) (TM::HASH-IL-UNREADABLE (QUOTE TM::COPY-HASH-IL-UNREADABLE))) (IL:|fetch| STRUCTURE IL:|of| NODE)))) (IL:* IL:|;;| "Mondo bizarro code below goes out into the node structure, finds the list structures that really belong in the FEATURE and FORM slots of the new node and puts them there. Since COPY-NODE copies the node-tree and THEN the underlying structure, the actual list structure that needs to be in the FEATURE and FORM slots has ALREADY been copied into the node-tree. In my opinion this is a *BUG*, and the structure should be copied FIRST, with the new tree reflecting the copy. Changing this behavior in COPY-NODE is easy, but God only knows what doing so will break, so I'm going to work around it... JRB") (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NEWSTRUCT) (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 1 NODE)) (TM::READ-TIME-CONDITIONAL-FORM NEWSTRUCT) (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 2 NODE))) NEWSTRUCT))) ) (CREATE-NEW-READ-TIME-CONDITIONAL (IL:LAMBDA (GAP CONTEXT TYPE) (IL:* IL:\; "Edited 2-Jan-91 22:55 by jrb:") (IL:* IL:|;;;| "Create a new read time conditional with gaps in it, and the node to represent it.") (LET* ((FEATURE-NODE (CREATE-GAP-NODE GAP)) (FORM-NODE (CREATE-GAP-NODE GAP)) (RTC-NODE (IL:|create| EDIT-NODE NODE-TYPE IL:_ TYPE-READABLE-READ-TIME-CONDITIONAL STRUCTURE IL:_ (TM::MAKE-HASH-IL-READABLE :FEATURE GAP :SIGN TYPE :FORM GAP) SUB-NODES IL:_ (LIST 2 FEATURE-NODE FORM-NODE)))) (IL:|replace| SUPER-NODE IL:|of| FEATURE-NODE IL:|with| RTC-NODE) (IL:|replace| SUPER-NODE IL:|of| FORM-NODE IL:|with| RTC-NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| FEATURE-NODE IL:|with| 1) (IL:|replace| SUB-NODE-INDEX IL:|of| FORM-NODE IL:|with| 2) (IL:|replace| LINEAR-FORM IL:|of| RTC-NODE IL:|with| (CREATE-WEAK-LINK RTC-NODE)) (NOTE-CHANGE RTC-NODE CONTEXT) RTC-NODE)) ) (DELETE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT START END SET.POINT?) (IL:* IL:\; "Edited 18-Feb-88 16:31 by raf") (IL:* IL:|;;| "Replace any deleted subnodes with gaps, since this is a fixed length object.") (WHEN (NOT (IL:SMALLP START)) (SETQ START (IL:FETCH SUB-NODE-INDEX IL:OF START)) (SETQ END START)) (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT START END (IL:FOR I IL:FROM START IL:TO END IL:COLLECT (CREATE-GAP-NODE BASIC-GAP))) (WHEN SET.POINT? (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT (SUBNODE END NODE)) (PENDING-DELETE SET.POINT? (IL:FETCH SELECTION IL:OF CONTEXT))) T)) (INPUT-CONDITIONAL-READ (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 24-Feb-88 18:43 by raf") (CASE (TYPE-OF-INPUT CONTEXT) (STRUCTURE (IL:* IL:\; "If we're structure pointing (between the hairs of the universe) a new read time conditional is made and inserted.") (CLOSE-OPEN-NODE CONTEXT) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP CONTEXT CHARCODE TYPE)) (ATOM (IL:* IL:\; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (IL:APPLY* (IL:FETCH DEFAULT-CHAR-HANDLER IL:OF (IL:FETCH ENVIRONMENT IL:OF CONTEXT)) CONTEXT CHARCODE))))) (INSERT-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT WHERE SUBNODES POINT) (IL:* IL:\; "Edited 18-Feb-88 17:17 by raf") (LET (START END) (IL:|if| (IL:|type?| EDIT-SELECTION WHERE) IL:|then| (SETQ START (IL:FETCH SELECT-START IL:OF WHERE)) (SETQ END (OR (IL:FETCH SELECT-END IL:OF WHERE) START)) IL:|elseif| (IL:|type?| EDIT-POINT WHERE) IL:|then| (SETQ END (IL:FETCH POINT-INDEX IL:OF WHERE)) (SETQ START (IL:ADD1 END)) IL:|else| (SETQ START (IL:FETCH SUB-NODE-INDEX IL:OF WHERE)) (SETQ END START)) (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT START END SUBNODES POINT)))) (INSERT-FLIPPED-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE FEATURE-NODE CONTEXT) (IL:* IL:\; "Edited 9-Jan-91 01:37 by jrb:") (IL:* IL:|;;| "NODE is a read-time-conditional whose FEATURE changed changing its readability; we're replacing it with a new node of the opposite readability, reading and unreading structure as necessary.") (LET ((READABLE? (EQ (IL:|fetch| NODE-TYPE IL:|of| NODE) TYPE-READABLE-READ-TIME-CONDITIONAL)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (OLD-FORM-NODE (SUBNODE 2 NODE)) (NEW-FORM-NODE (SUBNODE 2 NODE)) (OLD-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE)) NEW-FORM) (IL:* IL:|;;| "The following mess sets NEW-FORM and NEW-FORM-NODE to appropriate things. If the current form is a GAP, just use it; otherwise flip it between string-form and structure-form") (IL:|if| (EQ (IL:|fetch| NODE-TYPE IL:|of| OLD-FORM-NODE) TYPE-GAP) IL:|then| (SETQ NEW-FORM (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) IL:|else| (IL:|if| READABLE? IL:|then| (IL:* IL:\; "was readable, stringify it") (SETQ NEW-FORM (FORMAT NIL "~s" (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE))) (SETQ NEW-FORM-NODE (PARSE-NEW NEW-FORM CONTEXT)) IL:|else| (IL:* IL:\; "was unreadable, reread it from string") (WHEN (STRINGP (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (IL:* IL:|;;| "If the current structure ISN'T a string, who knows what may be wrong...") (WITH-INPUT-FROM-STRING (S (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (LET ((FORM (IL:NLSETQ (READ S)))) (COND (FORM (SETQ NEW-FORM (CAR FORM) NEW-FORM-NODE (PARSE-NEW (CAR FORM) CONTEXT))) (T (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Warning: Problem trying to read conditional expression. Not read.") (SETQ NEW-FORM (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE))))))))) (IL:* IL:|;;| "I now think the right thing to do here is to smash the current node's type in place. This may cause problems of its own, but the replace-it strategy was eating us alive.") (SETF (IL:|fetch| NODE-TYPE IL:|of| NODE) (IL:|if| READABLE? IL:|then| TYPE-UNREADABLE-READ-TIME-CONDITIONAL IL:|else| TYPE-READABLE-READ-TIME-CONDITIONAL)) (SETF (IL:|fetch| STRUCTURE IL:|of| NODE) (FUNCALL (IL:|if| READABLE? IL:|then| (FUNCTION TM::MAKE-HASH-IL-UNREADABLE) IL:|else| (FUNCTION TM::MAKE-HASH-IL-READABLE)) :FEATURE (IL:|fetch| STRUCTURE IL:|of| FEATURE-NODE) :SIGN (TM::READ-TIME-CONDITIONAL-SIGN OLD-STRUCTURE) :FORM (TM::READ-TIME-CONDITIONAL-FORM OLD-STRUCTURE))) (UNLESS (EQ OLD-FORM-NODE NEW-FORM-NODE) (REPLACE-NODE CONTEXT OLD-FORM-NODE NEW-FORM-NODE) (IL:* IL:|;;| "The old node is out there on the UNDO list; we need to mung its form so things will undo correctly (trust me...)") (SETF (IL:|fetch| STRUCTURE IL:|of| OLD-FORM-NODE) (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (IL:* IL:|;;| "Maybe this should be done elsewhere; we'll see...")) (IL:* IL:|;;| "The following seems to be sufficient to get the new structure sane before the next operation. These conniptions are necessary for the following strange reason: ") (IL:* IL:|;;| "Assume we're editing #+:interlisp(foo) and we select the 'l' in :interlisp and hit the delete key. We now have #+:interlsp(foo); SEdit hasn't closed the :interlsp node, so no other structure has had a chance to change. Now, take the mouse and click on foo. On the click, SEdit closes the :interlsp node, which changes the #+ from readable to unreadable, which causes this function to be run and (foo) to be replaced with \"(foo)\". Without the reformat-and relinearization below, that mouse-click will select something from the nodes for (foo), but these nodes are dead.") (IL:* IL:|;;| "Of course, with the reformatting below, that last mouse-click will cause the displayed structure to squirm out from under the mouse, but at least SEdit won't BREAK while doing it!") (SUBNODE-CHANGED NODE CONTEXT) (NOTE-CHANGE NODE CONTEXT) (COMPUTE-FORMATS-AND-FORMAT-VALUES NODE CONTEXT) (RELINEARIZE NODE CONTEXT) T)) ) (LINEARIZE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT RIGHT-MARGIN) (IL:* IL:\; "Edited 2-Jan-91 22:11 by jrb:") (LET ((HASH (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) (ECASE (TM::READ-TIME-CONDITIONAL-SIGN (IL:|fetch| STRUCTURE IL:|of| NODE)) (#\+ :HASH-PLUS) (#\- :HASH-MINUS)))) (FEATURE (SECOND (IL:|fetch| SUB-NODES IL:|of| NODE))) (FORM (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (OUTPUT-CONSTANT-STRING CONTEXT HASH) (LINEARIZE FEATURE CONTEXT RIGHT-MARGIN) (IL:* IL:|;;| "Should add some space between FEATURE and FORM here...") (LINEARIZE FORM CONTEXT RIGHT-MARGIN))) ) (PARSE--CONDITIONAL-READ (IL:LAMBDA (STRUCTURE CONTEXT MODE) (IL:* IL:\; "Edited 2-Jan-91 19:58 by jrb:") (COND ((TM::HASH-IL-READABLE-P STRUCTURE) (BUILD-NODE STRUCTURE CONTEXT TYPE-READABLE-READ-TIME-CONDITIONAL) (PARSE (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE) CONTEXT NIL) (PARSE (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) CONTEXT NIL) T) ((TM::HASH-IL-UNREADABLE-P STRUCTURE) (BUILD-NODE STRUCTURE CONTEXT TYPE-UNREADABLE-READ-TIME-CONDITIONAL) (PARSE (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE) CONTEXT NIL) (PARSE (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) CONTEXT NIL) T))) ) (REPLACE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT START END SUBNODES POINT) (IL:* IL:\; "Edited 7-Jan-91 14:33 by jrb:") (UNDO-BY UNDO-REPLACE-READ-TIME-CONDITIONAL NODE (IL:|for| I IL:|from| START IL:|to| END IL:|collect| (SUBNODE I NODE))) (IL:|for| I IL:|from| START IL:|to| END IL:|as| SUBNODE IL:|in| SUBNODES IL:|as| SMASHNODE IL:|on| (IL:NTH (CDR (IL:|fetch| SUB-NODES IL:|of| NODE)) START) IL:|do| (IL:* IL:|;;| "Update the EditNode itself.") (KILL-NODE (SUBNODE I NODE)) (RPLACA SMASHNODE SUBNODE) (IL:|replace| SUPER-NODE IL:|of| SUBNODE IL:|with| NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| SUBNODE IL:|with| I) (SET-DEPTH SUBNODE (IL:ADD1 (IL:|fetch| DEPTH IL:|of| NODE))) (SUBNODE-CHANGED SUBNODE CONTEXT) (IL:* IL:\; "Updates the data underlying this EditNode.")) (NOTE-CHANGE NODE CONTEXT) (WHEN POINT (PUNT-SET-POINT POINT CONTEXT NODE T)) NIL) ) (SET-POINT-READ-TIME-CONDITIONAL (IL:LAMBDA (POINT CONTEXT NODE INDEX OFFSET ITEM TYPE COMPUTE-LOCATION?) (IL:* IL:\; "Edited 2-Jan-91 16:15 by jrb:") (COND ((IL:|type?| STRING-ITEM ITEM) (IL:* IL:\; "pointing to the HASH.") (SETQ OFFSET (IL:ILESSP OFFSET (IL:HALF (IL:FETCH WIDTH IL:OF ITEM))))) (T (IL:|type?| EDIT-NODE ITEM) (SETQ TYPE (QUOTE STRUCTURE)))) (COND ((NULL INDEX) (PUNT-SET-POINT POINT CONTEXT NODE OFFSET COMPUTE-LOCATION?)) (T (COND ((AND (EQ TYPE (QUOTE ATOM)) (IL:NEQ INDEX 0) (IL:ILEQ INDEX 2)) (SET-POINT POINT CONTEXT (SUBNODE INDEX NODE) NIL OFFSET NIL (QUOTE ATOM) COMPUTE-LOCATION?)) ((EQ INDEX 2) (IL:* IL:\; "can't insert structure after the last item") (SET-POINT-NOWHERE POINT)) (T (IL:|replace| POINT-NODE IL:|of| POINT IL:|with| NODE) (IL:|replace| POINT-INDEX IL:|of| POINT IL:|with| (IF OFFSET INDEX (SETQ INDEX (IL:SUB1 INDEX)))) (IL:|replace| POINT-TYPE IL:|of| POINT IL:|with| (QUOTE STRUCTURE)) (WHEN COMPUTE-LOCATION? (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL POINT CONTEXT))))))) ) (SET-SELECTION-READ-TIME-CONDITIONAL (IL:LAMBDA (SELECTION CONTEXT NODE INDEX OFFSET ITEM TYPE) (IL:* IL:\; "Edited 18-Feb-88 17:38 by raf") (IL:* IL:|;;| "Pointing to the hash selects the whole read.time.conditional.") (SET-SELECTION-ME SELECTION CONTEXT NODE))) (STRINGIFY-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE ENVIRONMENT) (IL:* IL:\; "Edited 2-Jan-91 16:38 by jrb:") (IL:* IL:|;;| "There used to be a lot of junk here about getting the sign and the stringification right; (let ((structure (IL:FETCH STRUCTURE IL:OF NODE)))(IL:CONCAT (LET ((*PACKAGE* IL:*KEYWORD-PACKAGE*)) (FORMAT NIL \"#~a~s\" (ETYPECASE STRUCTURE (TM::HASH-PLUS \"+\") (TM::HASH-MINUS \"-\")) (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE))) (IF (TM::READ-TIME-CONDITIONAL-UNREAD-P STRUCTURE) (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) (FORMAT NIL \"~S\" (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE)))))") (IL:* IL:|;;| "All that stuff is supposedly handled by the print methods for the RTC objects, isn't it?") (FORMAT NIL "~s" (IL:FETCH STRUCTURE IL:OF NODE))) ) (SUBNODE-CHANGED-READABLE-RTC (IL:LAMBDA (NODE SUBNODE CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 15:12 by jrb:") (LET ((SUBNODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (NODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE))) (CASE (IL:|fetch| SUB-NODE-INDEX IL:|of| SUBNODE) (1 (IL:* IL:\; "Changing the FEATURE. ") (IL:|if| (ECASE (TM::READ-TIME-CONDITIONAL-SIGN NODE-STRUCTURE) (#\+ (NOT (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE))) (#\- (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE))) IL:|then| (IL:* IL:|;;| "We became unreadable, dump this node and replace with an UNREADABLE-READ-TIME-CONDITIONAL.") (INSERT-FLIPPED-READ-TIME-CONDITIONAL NODE SUBNODE CONTEXT) IL:|else| (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NODE-STRUCTURE) SUBNODE-STRUCTURE))) (2 (IL:* IL:\; "Changing the FORM; just replace it.") (SETF (TM::READ-TIME-CONDITIONAL-FORM NODE-STRUCTURE) SUBNODE-STRUCTURE)) (T (IL:SHOULDNT "Bad subnode index"))) (NOTE-CHANGE NODE CONTEXT))) ) (SUBNODE-CHANGED-UNREADABLE-RTC (IL:LAMBDA (NODE SUBNODE CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 15:23 by jrb:") (LET ((SUBNODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (NODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE))) (CASE (IL:|fetch| SUB-NODE-INDEX IL:|of| SUBNODE) (1 (IL:* IL:\; "Changing the FEATURE. ") (IL:|if| (ECASE (TM::READ-TIME-CONDITIONAL-SIGN NODE-STRUCTURE) (#\+ (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE)) (#\- (NOT (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE)))) IL:|then| (IL:* IL:|;;| "We became readable, dump this node and replace with an UNREADABLE-READ-TIME-CONDITIONAL.") (INSERT-FLIPPED-READ-TIME-CONDITIONAL NODE SUBNODE CONTEXT) IL:|else| (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NODE-STRUCTURE) SUBNODE-STRUCTURE))) (2 (IL:* IL:\; "Changing the FORM; just replace it.") (IL:* IL:|;;| "This is one place where you COULD catch someone putting a non-string into an unreadable-rtc. I think a better thing to do is give users a \"stringify all unreadable-rtcs\" command, and hack the install for unreadable stuff to break and let you stringify (or even do it behind your back, what the heck...).") (SETF (TM::READ-TIME-CONDITIONAL-FORM NODE-STRUCTURE) SUBNODE-STRUCTURE)) (T (IL:SHOULDNT "Bad subnode index"))) (NOTE-CHANGE NODE CONTEXT))) ) (UNDO-REPLACE-READ-TIME-CONDITIONAL (IL:LAMBDA (CONTEXT NODE OLD-SUBNODES) (IL:* IL:\; "Edited 18-Feb-88 17:45 by raf") (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT (IL:FETCH SUB-NODE-INDEX IL:OF (CAR OLD-SUBNODES)) (IL:FETCH SUB-NODE-INDEX IL:OF (CAR (LAST OLD-SUBNODES))) OLD-SUBNODES NIL))) ) (IL:* IL:|;;| "Other junk including INITIALIZE-COMMONLISP, the installation function and STRING-FLIP, the convenient string/unstring key " ) (IL:DEFINEQ (CONDITIONALIZE-CURRENT-SELECTION (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 28-Dec-90 18:40 by jrb:") (CLOSE-OPEN-NODE CONTEXT) (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (CR-NODE)) (IL:* IL:|;;| "I'm unsure about this conditinalization below, and suspect it's wrong.") (WHEN (AND NODE (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) (QUOTE STRUCTURE))) (IL:SETQ CR-NODE (CREATE-NEW-READ-TIME-CONDITIONAL BASIC-GAP CONTEXT QUOTE-TYPE)) (START-UNDO-BLOCK) (REPLACE-NODE CONTEXT NODE CR-NODE) (REPLACE-NODE CONTEXT (SUBNODE 1 CR-NODE) NODE) (NOTE-CHANGE CR-NODE CONTEXT) (IL:* IL:|;;| "Set selection and point to the form-gap") (SET-SELECTION-ME SELECTION CONTEXT (SUBNODE 2 CR-NODE)) (PENDING-DELETE POINT SELECTION) (END-UNDO-BLOCK))) (IL:* IL:|;;| "must return non-NIL if command executed") T) ) (CREATE-NEW-QUOTED-GAP (IL:LAMBDA (GAP CONTEXT QUOTE-TYPE) (IL:* IL:\; "Edited 6-Apr-89 16:50 by raf") (IL:* IL:|;;;| "Create a new quote structure with a gap in it, and the node to represent it.") (LET* ((GAP-NODE (CREATE-GAP-NODE GAP)) (QUOTE-NODE (IL:|create| EDIT-NODE NODE-TYPE IL:_ TYPE-NEW-QUOTE STRUCTURE IL:_ (FUNCALL (CASE QUOTE-TYPE (:HASH-DOT #'TM::MAKE-HASH-DOT) (:HASH-COMMA #'TM::MAKE-HASH-COMMA) (:HASH-O #'TM::MAKE-HASH-O) (:HASH-X #'TM::MAKE-HASH-X) (:HASH-B #'TM::MAKE-HASH-B) (T (IL:SHOULDNT "Bad quote type " QUOTE-TYPE))) :CONTENTS GAP) SUB-NODES IL:_ (LIST 1 GAP-NODE) UNASSIGNED IL:_ (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) QUOTE-TYPE)))) (IL:|replace| SUPER-NODE IL:|of| GAP-NODE IL:|with| QUOTE-NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| GAP-NODE IL:|with| 1) (IL:|replace| LINEAR-FORM IL:|of| QUOTE-NODE IL:|with| (CREATE-WEAK-LINK QUOTE-NODE)) (NOTE-CHANGE QUOTE-NODE CONTEXT) QUOTE-NODE))) (INITIALIZE-COMMONLISP (IL:LAMBDA NIL (IL:* IL:\; "Edited 11-Jan-91 23:41 by jrb:") "Creates SEdit nodes for Common Lisp presentation types. Fully re-entrant." (IL:* IL:|;;| "First, add the handling for #{b,o,x,r,*}; they get parsed and generally handled like litatoms (once we hack the SEdit readtable to generate them)") (DOLIST (P (QUOTE (TM::HASH-BASED-NUMBER TM::HASH-STAR))) (IL:LISTPUT (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT) P (QUOTE PARSE--LITATOM))) (IL:* IL:|;;| "Now for the weirder ones; #. and #, and #+ and #-") (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-NEW-QUOTE (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE NEW-QUOTE) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-QUOTE) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-QUOTE) LINEARIZE IL:_ (QUOTE LINEARIZE-QUOTE) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-NEW-QUOTE) SET-POINT IL:_ (QUOTE SET-POINT-QUOTE) SET-SELECTION IL:_ (QUOTE SET-SELECTION-QUOTE) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE REPLACE-NEW-QUOTE) DELETE IL:_ (QUOTE DELETE-QUOTE) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-NEW-QUOTE) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-QUOTE) BACK-SPACE IL:_ (QUOTE BACKSPACE-QUOTE))) (QUOTE ((TM::HASH-DOT :HASH-DOT "^Q" PARSE--NEW-QUOTE INPUT-NEW-QUOTE) (TM::HASH-COMMA :HASH-COMMA "^F" PARSE--NEW-QUOTE INPUT-NEW-QUOTE))) (QUOTE (("#." :HASH-DOT) ("#," :HASH-COMMA)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-READABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE READABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-READABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) (QUOTE ((TM::HASH-IL-READABLE NIL NIL PARSE--CONDITIONAL-READ) (TM::HASH-IL-UNREADABLE NIL NIL PARSE--CONDITIONAL-READ))) (QUOTE (("#+" :HASH-PLUS) ("#-" :HASH-MINUS)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-UNREADABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE UNREADABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-UNREADABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) NIL NIL) (IL:* IL:|;;| "Just for the heck of it, add a command for stringifying/unstringifying things. I'd put it in the command menu, but it's too much trouble") (SETF (GETHASH (CHARCODE "^S") (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) (QUOTE (STRING-FLIP NIL))) (IL:* IL:|;;| "And for the final indignity, mung the command table to add a minor flakiness in the handling of + and -") (IL:|for| CP IL:|in| (QUOTE ((#\+ INPUT-PLUS-OR-MINUS) (#\- INPUT-PLUS-OR-MINUS))) IL:|bind| (COMTAB IL:_ (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) IL:|do| (SETF (GETHASH (CHAR-CODE (FIRST CP)) COMTAB) (IL:BQUOTE ((IL:\\\, (SECOND CP)) NIL (IL:\\\, (FIRST CP)))))) T) ) (INSERT-NEW-QUOTED-GAP (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 24-Feb-88 18:44 by raf") (IL:* IL:|;;| "implements the ' command: insert a quoted gap") (WHEN (EQ (TYPE-OF-INPUT CONTEXT) 'STRUCTURE) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-QUOTE GAP) (SETQ NEW-QUOTE (CREATE-NEW-QUOTED-GAP BASIC-GAP CONTEXT QUOTE-TYPE)) (SETQ GAP (SUBNODE 1 NEW-QUOTE)) (IL:* IL:\;  "we get our hands on the gap node now, to handle the case where the insert reparses the new.quote") (INSERT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) CONTEXT (LIST NEW-QUOTE)) (UNLESS (DEAD-NODE? NEW-QUOTE) (SET-SELECTION-ME SELECTION CONTEXT GAP) (PENDING-DELETE POINT SELECTION))) (IL:* IL:\;  "must return non-NIL if command executed") T))) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 28-Dec-90 19:19 by jrb:") (IL:* IL:|;;| "implements the command: insert a read time conditional with gaps") (WHEN (EQ (TYPE-OF-INPUT CONTEXT) (QUOTE STRUCTURE)) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-RTC GAP) (SETQ NEW-RTC (CREATE-NEW-READ-TIME-CONDITIONAL BASIC-GAP CONTEXT TYPE)) (SETQ GAP (SUBNODE 1 NEW-RTC)) (IL:* IL:\; "point us at the feature") (INSERT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) CONTEXT (LIST NEW-RTC)) (UNLESS (DEAD-NODE? NEW-RTC) (SET-SELECTION-ME SELECTION CONTEXT GAP) (PENDING-DELETE POINT SELECTION))) (IL:* IL:\; "must return non-NIL if command executed") T)) ) (INPUT-PLUS-OR-MINUS (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 2-Jan-91 22:12 by jrb:") (IL:* IL:|;;| "Serious weirdness afoot below; we're catching the case of typing a +/- right after a # and then creating a new readable-read-time-conditional (what the heck; assume it's readable until forced to believe otherwise). Strategy stolen from INPUT-QUOTE, with suitable modifications.") (SETQ CHARCODE (CODE-CHAR CHARCODE)) (IL:* IL:\; "Oops...") (IL:SELECTQ (TYPE-OF-INPUT CONTEXT) (STRUCTURE) (ATOM (LET* ((POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (NODE (IL:FETCH POINT-NODE IL:OF POINT)) (SUPER-NODE (AND (IL:TYPE? EDIT-NODE NODE) (IL:FETCH SUPER-NODE IL:OF NODE)))) (WHEN (AND SUPER-NODE (EQ 1 (IL:FETCH POINT-INDEX POINT)) (EQ (IL:CHARCODE \#) (IL:CHCON1 (IL:FETCH POINT-STRING IL:OF POINT)))) (COND ((EQ 1 (IL:NCHARS (IL:FETCH POINT-STRING IL:OF POINT))) (IL:* IL:|;;| "Just \"#+\"; close the node, get rid of it, and replace it with a readable-rtc. Oh yeah, do this undoably by just closing and calling an undoable thing,") (CLOSE-OPEN-NODE CONTEXT) (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT NODE) (PENDING-DELETE POINT (IL:FETCH SELECTION IL:OF CONTEXT)) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP CONTEXT CHARCODE CHARCODE) T) (T (IL:* IL:|;;| "Some joker typed a + in the middle of \"#foo\": remove the #, close the node, shove it into a newly created readable-rtc (which might turn it into an unreadable-rtc), and pending-delete the form gap. Oh yeah, do this undoably.") (START-UNDO-BLOCK) (REPLACE-STRING NODE CONTEXT 1 1 "" POINT (IL:FETCH POINT-STRING IL:OF POINT) (QUOTE ATOM)) (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT NODE) (CONDITIONALIZE-CURRENT-SELECTION CONTEXT CHARCODE CHARCODE) (END-UNDO-BLOCK) T))))) NIL)) ) (STRING-FLIP (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 11-Jan-91 23:25 by jrb:") (IL:* IL:|;;| "flip the current selection between structure and string") (IL:SELECTQ (TYPE-OF-INPUT CONTEXT) (STRUCTURE (CLOSE-OPEN-NODE CONTEXT) (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (END (IL:FETCH SELECT-END IL:OF SELECTION))) (IL:IF (AND (NULL START) (NULL END) (STRINGP (IL:FETCH STRUCTURE IL:OF NODE))) IL:THEN (IL:* IL:\; "It's already a string, try and read it") (WITH-INPUT-FROM-STRING (S (IL:|fetch| STRUCTURE IL:|of| NODE)) (LET ((FORM (IL:NLSETQ (READ S)))) (COND (FORM (REPLACE-NODE CONTEXT NODE (PARSE-NEW (CAR FORM) CONTEXT))) (T (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Problem trying to read from string. Not read.")))) T) IL:ELSE (IL:* IL:\; "It's something else, turn it into a string") (IL:IF (AND (NULL START) (NULL END)) IL:THEN (REPLACE-NODE CONTEXT NODE (PARSE-NEW (STRINGIFY NODE) CONTEXT)) IL:ELSE (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Select one thing to stringify/unstringify")) T))) (ATOM (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Select a structure to stringify/unstringify")) NIL)) ) ) (IL:* IL:|;;| "Advice implementing readtable hack") (DEFUN ADD-NEW-QUOTE-LIKE (EDIT-NODE-TYPE SUB-TYPE-LIST NEW-QUOTE-STRING-LIST) (IL:* IL:|;;| "This is a generalization of Ron's old INITIALIZE-COMMONLISP function; it adds a new \"quote-like\" presentation to SEdit's LISP-EDIT-ENVIRONMENT, taking care to do it in re-enterable fashion (you can call this more than once with the same arguments and you won't break SEdit).") (IL:* IL:|;;| "The format of the entries on the sub-type-list is:") (IL:* IL:|;;| "(object-type input-keyword create-key parse-function input-function)") (IL:* IL:|;;| "create-key can be anything ") (IL:* IL:|;;|  "First add the new EDIT-NODE-TYPE; it has all the SEdit method names burned into it") (IL:FOR TL IL:ON TYPES IL:WHEN (EQ (IL:FFETCH (EDIT-NODE-TYPE NAME) IL:OF EDIT-NODE-TYPE ) (IL:FFETCH (EDIT-NODE-TYPE NAME) IL:OF (CAR TL))) IL:DO (RPLACA TL EDIT-NODE-TYPE) (RETURN NIL) IL:FINALLY (PUSH EDIT-NODE-TYPE TYPES)) (IL:* IL:|;;| "Then walk the sub-type list adding everything in") (LET ((PARSE-INFO-TABLE (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT)) (COMMAND-TABLE (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT))) (DOLIST (ST SUB-TYPE-LIST) (DESTRUCTURING-BIND (OBJECT-TYPE QUOTE-KEYWORD CREATE-KEY PARSE-FUNCTION INPUT-FUNCTION) ST (IL:* IL:|;;| "First add the PARSE-- function") (IL:LISTPUT PARSE-INFO-TABLE OBJECT-TYPE PARSE-FUNCTION) (IL:* IL:|;;| "Then the create-key, if any") (SETQ CREATE-KEY (CHARCODE CREATE-KEY)) (WHEN CREATE-KEY (SETF (GETHASH CREATE-KEY COMMAND-TABLE) (LIST INPUT-FUNCTION NIL QUOTE-KEYWORD)))))) (IL:* IL:|;;| "Finally mung the quote strings, which are of the form (\"string\" :keyword)") (IL:FOR QSP IL:IN NEW-QUOTE-STRING-LIST IL:BIND QUOTE-STRING-LIST IL:_ (IL:|fetch| (EDIT-ENV QUOTE-STRING) IL:|of| LISP-EDIT-ENVIRONMENT) QUOTE-STRING-FONT IL:_ (IL:|fetch| (EDIT-ENV DEFAULT-FONT) IL:|of| LISP-EDIT-ENVIRONMENT ) IL:DO (IL:LISTPUT QUOTE-STRING-LIST (SECOND QSP) (CREATE-STRING-ITEM (FIRST QSP) QUOTE-STRING-FONT)))) (DEFUN ICL () (IL:* IL:|;;| "First, add the handling for #{b,o,x,r,*}; they get parsed and generally handled like litatoms (once we hack the SEdit readtable to generate them)") (DOLIST (P '(TM::HASH-BASED-NUMBER TM::HASH-STAR)) (IL:LISTPUT (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT) P 'PARSE--LITATOM)) (IL:* IL:|;;| "Now for the weirder ones; #. and #, and #+ and #-") (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-NEW-QUOTE (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ 'NEW-QUOTE ASSIGN-FORMAT IL:_ 'ASSIGN-FORMAT-QUOTE COMPUTE-FORMAT-VALUES IL:_ 'CFV-QUOTE LINEARIZE IL:_ 'LINEARIZE-QUOTE SUB-NODE-CHANGED IL:_ 'SUBNODE-CHANGED-NEW-QUOTE SET-POINT IL:_ 'SET-POINT-QUOTE SET-SELECTION IL:_ 'SET-SELECTION-QUOTE GROW-SELECTION IL:_ 'GROW-SELECTION-DEFAULT INSERT IL:_ 'REPLACE-NEW-QUOTE DELETE IL:_ 'DELETE-QUOTE COPY-STRUCTURE IL:_ 'COPY-STRUCTURE-NEW-QUOTE COPY-SELECTION IL:_ 'COPY-SELECTION-DEFAULT STRINGIFY IL:_ 'STRINGIFY-QUOTE BACK-SPACE IL:_ 'BACKSPACE-QUOTE)) '((TM::HASH-DOT :HASH-DOT "^Q" PARSE--NEW-QUOTE INPUT-NEW-QUOTE) (TM::HASH-COMMA :HASH-COMMA "^F" PARSE--NEW-QUOTE INPUT-NEW-QUOTE)) '(("#." :HASH-DOT) ("#," :HASH-COMMA))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-READABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ 'READABLE-READ-TIME-CONDITIONAL ASSIGN-FORMAT IL:_ ' ASSIGN-FORMAT-READ-TIME-CONDITIONAL COMPUTE-FORMAT-VALUES IL:_ 'CFV-READ-TIME-CONDITIONAL LINEARIZE IL:_ 'LINEARIZE-READ-TIME-CONDITIONAL SUB-NODE-CHANGED IL:_ 'SUBNODE-CHANGED-READABLE-RTC COMPUTE-POINT-POSITION IL:_ ' COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COMPUTE-SELECTION-POSITION IL:_ 'COMPUTE-SELECTION-POSITION-DEFAULT SET-POINT IL:_ 'SET-POINT-READ-TIME-CONDITIONAL SET-SELECTION IL:_ ' SET-SELECTION-READ-TIME-CONDITIONAL GROW-SELECTION IL:_ 'GROW-SELECTION-DEFAULT INSERT IL:_ 'INSERT-READ-TIME-CONDITIONAL DELETE IL:_ 'DELETE-READ-TIME-CONDITIONAL COPY-STRUCTURE IL:_ ' COPY-STRUCTURE-READ-TIME-CONDITIONAL COPY-SELECTION IL:_ 'COPY-SELECTION-DEFAULT STRINGIFY IL:_ 'STRINGIFY-READ-TIME-CONDITIONAL BACK-SPACE IL:_ 'BACKSPACE-READ-TIME-CONDITIONAL)) '((TM::HASH-IL-READABLE NIL NIL PARSE--CONDITIONAL-READ) (TM::HASH-IL-UNREADABLE NIL NIL PARSE--CONDITIONAL-READ)) '(("#+" :HASH-PLUS) ("#-" :HASH-MINUS))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-UNREADABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ 'UNREADABLE-READ-TIME-CONDITIONAL ASSIGN-FORMAT IL:_ ' ASSIGN-FORMAT-READ-TIME-CONDITIONAL COMPUTE-FORMAT-VALUES IL:_ 'CFV-READ-TIME-CONDITIONAL LINEARIZE IL:_ 'LINEARIZE-READ-TIME-CONDITIONAL SUB-NODE-CHANGED IL:_ 'SUBNODE-CHANGED-UNREADABLE-RTC COMPUTE-POINT-POSITION IL:_ ' COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COMPUTE-SELECTION-POSITION IL:_ 'COMPUTE-SELECTION-POSITION-DEFAULT SET-POINT IL:_ 'SET-POINT-READ-TIME-CONDITIONAL SET-SELECTION IL:_ ' SET-SELECTION-READ-TIME-CONDITIONAL GROW-SELECTION IL:_ 'GROW-SELECTION-DEFAULT INSERT IL:_ 'INSERT-READ-TIME-CONDITIONAL DELETE IL:_ 'DELETE-READ-TIME-CONDITIONAL COPY-STRUCTURE IL:_ ' COPY-STRUCTURE-READ-TIME-CONDITIONAL COPY-SELECTION IL:_ 'COPY-SELECTION-DEFAULT STRINGIFY IL:_ 'STRINGIFY-READ-TIME-CONDITIONAL BACK-SPACE IL:_ 'BACKSPACE-READ-TIME-CONDITIONAL)) NIL NIL) (IL:* IL:|;;| "And for the final indignity, mung the command table to add a minor flakiness in the handling of + and -") (IL:|for| CP IL:|in| '((#\+ INPUT-PLUS-OR-MINUS) (#\- INPUT-PLUS-OR-MINUS)) IL:|bind| (COMTAB IL:_ (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT )) IL:|do| (SETF (GETHASH (CHAR-CODE (FIRST CP)) COMTAB) `(,(SECOND CP) NIL ,(FIRST CP))))) (DEFUN TM::MUNG-SEDIT-READ-TABLE (TM::CONTEXT) (IL:* IL:|;;| "Install a presentation-hacked readtable if the current readtable is IL:COMMONLISP-p and the thing being edited is a definer (and will hence be translated before installation)") (IF (AND (IL:FETCH IL:COMMONLISP IL:OF *READTABLE*) (GET (IL:FETCH EDIT-TYPE IL:OF TM::CONTEXT) :DEFINED-BY)) (LET (TM::NEWTBL) (IF (NULL (SETQ TM::NEWTBL (GETHASH *READTABLE* TM::*SEDIT-READ-TABLES*))) (PROGN (SETQ TM::NEWTBL (COPY-READTABLE *READTABLE*)) (WHEN (IL:FETCH IL:READTBLNAME IL:OF *READTABLE*) (SETF (IL:FETCH IL:READTBLNAME IL:OF TM::NEWTBL) (IL:CONCAT (IL:FETCH IL:READTBLNAME IL:OF *READTABLE*) "-SEDIT"))) (MAPHASH #'(LAMBDA (TM::KEY TM::VAL) (IF (CONSP TM::KEY) (PROGN (MAKE-DISPATCH-MACRO-CHARACTER (CAR TM::KEY) T TM::NEWTBL) (SET-DISPATCH-MACRO-CHARACTER (CAR TM::KEY) (CDR TM::KEY) TM::VAL TM::NEWTBL)) (SET-MACRO-CHARACTER TM::KEY T TM::VAL TM::NEWTBL))) TM::*SEDIT-READ-MACROS*))) (SETQ *READTABLE* TM::NEWTBL)))) (REINSTALL-ADVICE 'SETUP-PROFILE :BEFORE '((:LAST (TM::MUNG-SEDIT-READ-TABLE IL:CONTEXT)))) (IL:READVISE SETUP-PROFILE) (DEFVAR TM::*SEDIT-READ-TABLES* (MAKE-HASH-TABLE) "Cache for readtables modified in support of TEXTMODULES") (IL:* IL:|;;| "Temporarily commenting this out for playing-around purposes") (INITIALIZE-COMMONLISP) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SEDIT" :BASE 10)) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1989 1990 1991 2021)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3684 7861 (COPY-STRUCTURE-NEW-QUOTE 3697 . 4478) (INPUT-NEW-QUOTE 4480 . 5456) ( PARSE--NEW-QUOTE 5458 . 6360) (REPLACE-NEW-QUOTE 6362 . 7588) (SUBNODE-CHANGED-NEW-QUOTE 7590 . 7859)) (7994 27947 (ASSIGN-FORMAT-READ-TIME-CONDITIONAL 8007 . 8561) (BACKSPACE-READ-TIME-CONDITIONAL 8563 . 10149) (CFV-READ-TIME-CONDITIONAL 10151 . 10850) (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL 10852 . 12227) (COPY-STRUCTURE-READ-TIME-CONDITIONAL 12229 . 13439) (CREATE-NEW-READ-TIME-CONDITIONAL 13441 . 14321) (DELETE-READ-TIME-CONDITIONAL 14323 . 15292) (INPUT-CONDITIONAL-READ 15294 . 16208) ( INSERT-READ-TIME-CONDITIONAL 16210 . 17022) (INSERT-FLIPPED-READ-TIME-CONDITIONAL 17024 . 20979) ( LINEARIZE-READ-TIME-CONDITIONAL 20981 . 21615) (PARSE--CONDITIONAL-READ 21617 . 22211) ( REPLACE-READ-TIME-CONDITIONAL 22213 . 23085) (SET-POINT-READ-TIME-CONDITIONAL 23087 . 24117) ( SET-SELECTION-READ-TIME-CONDITIONAL 24119 . 24466) (STRINGIFY-READ-TIME-CONDITIONAL 24468 . 25245) ( SUBNODE-CHANGED-READABLE-RTC 25247 . 26210) (SUBNODE-CHANGED-UNREADABLE-RTC 26212 . 27499) ( UNDO-REPLACE-READ-TIME-CONDITIONAL 27501 . 27945)) (28098 40390 (CONDITIONALIZE-CURRENT-SELECTION 28111 . 29027) (CREATE-NEW-QUOTED-GAP 29029 . 31014) (INITIALIZE-COMMONLISP 31016 . 35451) ( INSERT-NEW-QUOTED-GAP 35453 . 36598) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP 36600 . 37358) ( INPUT-PLUS-OR-MINUS 37360 . 39153) (STRING-FLIP 39155 . 40388)) (40452 43710 (ADD-NEW-QUOTE-LIKE 40452 . 43710)) (43712 53911 (ICL 43712 . 53911)) (53913 55557 (TM::MUNG-SEDIT-READ-TABLE 53913 . 55557)))) ) IL:STOP