(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "16-May-90 21:37:57" IL:|{DSK}local>lde>lispcore>sources>SEDIT-ATOMIC.;3| 43305 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-ATOMICCOMS) IL:|previous| IL:|date:| "30-Mar-90 01:10:14" IL:|{DSK}local>lde>lispcore>sources>SEDIT-ATOMIC.;2|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-ATOMICCOMS) (IL:RPAQQ IL:SEDIT-ATOMICCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-ATOMIC) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-ATOMIC) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:FNS ASSIGN-FORMAT-LITATOM ATOM-POINT-TYPE BACKSPACE-GAP BACKSPACE-LITATOM BACKSPACE-UNKNOWN CLOSE-NODE-LITATOM COMPUTE-POINT-POSITION-LITATOM COMPUTE-SELECTION-POSITION-LITATOM CONS-ATOM COPY-SELECTION-LITATOM COPY-STRUCTURE-STRING DELETE-LITATOM DETRANSLATE-CHARS GET-BUTTON-STRING GROW-SELECTION-LITATOM HASFAT INITIALIZE-ATOMIC INSERT-LITATOM INSERT-STRING OPEN-LITATOM PARSE--BROKEN-ATOM PARSE--LITATOM PARSE--STRING RELEASE-OPEN-STRING REPLACE-CHARS REPLACE-STRING SCAN-STRING SELECT-SEGMENT-LITATOM SET-POINT-LITATOM SET-POINT-STRING SET-SELECTION-LITATOM SET-SELECTION-STRING SPLIT-LITATOM STRINGIFY-ATOM TRANSLATE-CHARS UNDO-ATOM-CHANGE))) (IL:PUTPROPS IL:SEDIT-ATOMIC IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-ATOMIC IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:DEFINEQ (assign-format-litatom (il:lambda (node context format) (il:* il:\; "Edited 19-Nov-87 16:43 by DCB") (il:* il:|;;;| "atoms have no children, so the format will not propagate further. normal nodes can get relinearized if their placement changes, even if their format type did not change. however, the presentation of an atom changes only when its format type changes (from KeyWord to NIL or back). thus to avoid unnecessary relinearization, the parse method for atoms builds a prelinearized node, and here we fiddle the prelinearized node to account for the change in font between KeyWord atoms and normal ones. ") (il:* il:|;;;| "note that when building the SEdit tree from scratch, the format will necessarily have changed, so this routine will get called whether the prelinearized node needs patching (changed to keyword) or not.") (let* ((atom (il:|fetch| structure il:|of| node)) (broken? (il:|type?| broken-atom atom)) (environment (il:\\dtest (il:|fetch| environment il:|of| context) (quote edit-env))) (font (cond (broken? (il:setq atom (il:fetch atom-chars il:of atom)) (il:fetch broken-atom-font il:of environment)) ((eq format :keyword) (il:|ffetch| keyword-font il:|of| environment)) (t (il:|ffetch| default-font il:|of| environment)))) (string-item (car (il:|ffetch| linear-form il:|of| node))) width) (il:* il:\; "read table specific") (when (and (not (and (il:|ffetch| open-node-changed? il:|of| context) (eq (il:ffetch open-node il:of context) node))) (or (il:ffetch changed? il:of node) (and (not broken?) (il:stringp (il:|ffetch| string il:|of| string-item))) (il:neq font (il:|fetch| font il:|of| string-item)))) (il:* il:|;;| "this stuff gets run only if the prelinearized node is wrong. (see comment above.)") (il:setq width (stringwidth atom font (not broken?))) (il:|freplace| string il:|of| string-item il:|with| atom) (il:|freplace| font il:|of| string-item il:|with| font) (il:|freplace| prin-2? il:|of| string-item il:|with| (not broken?)) (il:|freplace| width il:|of| string-item il:|with| width) (il:|freplace| inline-width il:|of| node il:|with| width) (il:|freplace| preferred-width il:|of| node il:|with| width) (il:|freplace| actual-width il:|of| node il:|with| width) (il:|freplace| actual-llength il:|of| node il:|with| width) (when (eq (il:|ffetch| open-node il:|of| context) node) (il:|freplace| open-node il:|of| context il:|with| nil))))) ) (atom-point-type (il:lambda (str index) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;;| "used to pass read.table, but now under profile just use *READTABLE* directly.") (il:for c il:instring str il:as i il:to index il:bind (result il:_ (quote atom)) (esc-char il:_ (escape-char)) (mult-esc-char il:_ (il:fetch (readtablep il:multescapechar) il:of *readtable*)) escaped il:do (cond (escaped (il:setq escaped nil)) ((eq c esc-char) (il:setq escaped t)) ((eq c mult-esc-char) (il:setq result (if (eq result (quote atom)) (quote esc-atom) (quote atom))))) il:finally (return result))) ) (backspace-gap (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;;| "handle the case of backspacing onto a gap. should pending delete select it.") (cond (index (il:shouldnt "point can't be in a gap")) (t (set-selection-me (il:fetch selection il:of context) context node) (pending-delete (il:fetch caret-point il:of context) (il:fetch selection il:of context))))) ) (backspace-litatom (il:lambda (node context index string) (il:* il:\; "Edited 24-Nov-87 08:14 by DCB") (il:* il:|;;| "the BackSpace method for litatoms and strings") (cond ((null index) (il:* il:|;;| "backspacing from the right boundary puts the caret immediately after the last character") (set-point-litatom (il:fetch caret-point il:of context) context node nil t) (set-selection-nowhere (il:fetch selection il:of context))) ((eq index 0) (cond ((eq 0 (il:nchars string)) (il:* il:|;;| "backspacing from the front of an empty string deletes it") (delete-nodes (il:fetch super-node il:of node) context node nil (il:fetch caret-point il:of context))) (t (il:* il:|;;| "might be at the front of a quote to degrade") (let* ((super-node (il:fetch super-node il:of node)) (super-type (il:fetch node-type il:of super-node))) (when (eq super-type type-quote) (il:* il:|;;| "used to call backspace-quote directly here, now indirect through type") (funcall (il:fetch back-space il:of super-type) super-node context 0)))))) (t (il:* il:|;;| "otherwise, delete the character to the left of the caret") (let ((start index) end) (when (il:neq (il:fetch node-type il:of node) type-string) (il:* il:\; "read table specific") (il:for i il:from (il:sub1 index) il:to 1 il:by -1 il:bind (esc il:_ (escape-char)) il:while (eq (il:nthcharcode string i) esc) il:finally (when (evenp (il:idifference i index)) (il:setq end start) (il:setq start (il:sub1 start))))) (delete-litatom node context start end (il:fetch caret-point il:of context) string) (when (not (dead-node? node)) (il:* il:|;;| "if the atom's still there, cancel the selection. otherwise don't worry about it, the delete method might have set it") (set-selection-nowhere (il:fetch selection il:of context))))))) ) (backspace-unknown (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (cond (index (il:shouldnt "point shouldn't be in an unknown node")) (t (il:* il:|;;| "jump caret to before the unknown node") (set-point (il:fetch caret-point il:of context) context node nil nil nil (quote structure)) (set-selection-nowhere (il:fetch selection il:of context))))) ) (close-node-litatom (il:lambda (context node) (il:* il:\; "Edited 19-Nov-87 16:10 by DCB") (cond ((and (eq node (il:|fetch| atom-started il:|of| context)) (eq (il:|fetch| undo-list il:|of| context) (il:|fetch| atom-started-undo-pointer il:|of| context)) (null (il:|fetch| undo-undo-list il:|of| context))) (il:* il:\; "don't record this as a separate undo event") (il:|replace| atom-started il:|of| context il:|with| nil) (il:|replace| atom-started-undo-pointer il:|of| context il:|with| nil)) (t (undo-by undo-atom-change node (il:|fetch| structure il:|of| node)))) (let* ((string-item (car (il:|fetch| linear-form il:|of| node))) (old-string (il:|fetch| string il:|of| string-item)) (new-string (il:|replace| structure il:|of| node il:|with| (cons-atom old-string (il:neq (il:|fetch| node-type il:|of| node) type-string))))) (il:|replace| string il:|of| string-item il:|with| (cond ((il:stringp new-string) new-string) (t (il:* il:|;;| "this is a litatom, so we have to make sure the string item has a copy") (il:setq new-string (il:concat old-string))))) (release-open-string old-string new-string (il:|fetch| caret-point il:|of| context) (il:|fetch| selection il:|of| context)) (subnode-changed node context) (cond ((eq (il:|fetch| node-type il:|of| node) type-string) (note-change-in-simple node context) (il:replace open-node il:of context il:with nil)) (t (note-change node context))))) ) (compute-point-position-litatom (il:lambda (point context) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;| "implements the ComputePointPosition method for a litatom or string. string.offset does all the work") (let ((node (il:fetch point-node il:of point))) (il:* il:|;;| "read table specific. used to pass read.table as 5th arg to string.offset. now just flag prin2? for it and it will do the right thing using the current readtable.") (string-offset (il:fetch point-string il:of point) nil (il:fetch point-index il:of point) (il:fetch font il:of (car (il:fetch linear-form il:of node))) (eq (il:fetch node-type il:of node) type-string) point (il:fetch start-x il:of node)) (il:replace point-line il:of point il:with (il:fetch first-line il:of node)))) ) (compute-selection-position-litatom (il:lambda (selection context) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;| "implements the ComputeSelectionPosition method for a litatom or string. string.offset does all the work") (let* ((node (il:fetch select-node il:of selection)) (string-item (car (il:fetch linear-form il:of node)))) (il:* il:\; "read table specific") (string-offset (il:fetch select-string il:of selection) (il:fetch select-start il:of selection) (or (il:fetch select-end il:of selection) (il:fetch select-start il:of selection)) (il:fetch font il:of string-item) (eq (il:fetch node-type il:of node) type-string) selection (il:fetch start-x il:of node)) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of node)) (il:replace select-end-line il:of selection il:with (il:fetch select-start-line il:of selection)))) ) (cons-atom (il:lambda (chars atom?) (il:* il:\; "Edited 19-Nov-87 14:37 by DCB") (il:* il:|;;;| "read table specific. used to pass in read.table, but now must run under sedit profile using *readtable*") (if atom? (let (result) (if (il:setq result (il:nlsetq (il:read (il:openstringstream chars (quote il:input))))) (car result) (il:create broken-atom atom-chars il:_ (il:concat chars)))) (cond ((null chars) (il:allocstring 0)) ((hasfat chars) (il:concat chars)) (t (il:\\smashstring (il:allocstring (il:nchars chars)) 0 chars))))) ) (copy-selection-litatom (il:lambda (selection context destination point delete?) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "implements the CopySelection method for a litatom or string. Assume under sedit profile..") (let* ((node (il:fetch select-node il:of selection)) (chars (il:fetch structure il:of node)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (string (il:fetch select-string il:of selection)) (type (il:fetch select-type il:of selection)) not-all-selected) (when (il:type? broken-atom chars) (il:setq chars (il:fetch atom-chars il:of chars))) (when (eq type (quote structure)) (il:setq string (get-button-string node context)) (il:setq type (if (eq (il:fetch node-type il:of node) type-string) (quote string) (quote atom)))) (when (and start (or (il:neq (or end (il:setq end start)) (il:nchars string)) (il:neq start 1))) (il:* il:|;;| "some subset of the atom/string has been selected") (il:setq not-all-selected t)) (cond ((null destination) (il:* il:|;;| "it's going to a foreign sink; bksysbuf it") (il:bksysbuf (if not-all-selected (detranslate-chars (il:substring string start end) type) chars) (if (eq type (quote string)) (null start) (not not-all-selected))) (when delete? (delete-nodes node context start end nil string))) ((and (eq type (quote string)) (null start)) (il:* il:|;;| "strings insert as whole structures") (copy-selection-default selection context destination point delete?)) ((eq (il:fetch point-type il:of point) (quote structure)) (il:* il:|;;| "make the selected characters into a new atom or string") (with-profile (il:fetch profile il:of destination) (cond ((and delete? (il:neq (il:fetch node-type il:of node) type-string) (not not-all-selected) (delete-nodes node context)) (il:* il:|;;| "if we're moving the whole atom, we can just reuse the node") (il:* il:|;;| "assume under sedit profile for this call to stringwidth") (adjust-width node nil (stringwidth chars (il:fetch font il:of (car (il:fetch linear-form il:of node))) t))) (t (when (or (eq (il:fetch node-type il:of node) type-string) not-all-selected (il:type? broken-atom (il:fetch structure il:of node))) (il:setq chars (cons-atom (if start (il:substring string start end) string) t)) (when (and delete? not-all-selected) (delete-nodes node context start end nil string))) (il:* il:|;;| "again here need sedit profile to create.simple.node.") (il:setq node (create-simple-node chars (il:fetch environment il:of destination) type-litatom (if (il:type? broken-atom chars) (il:fetch atom-chars il:of chars) chars) (not (il:type? broken-atom chars)) (if (il:type? broken-atom chars) (il:fetch broken-atom-font il:of (il:fetch environment il:of destination)) (il:fetch default-font il:of (il:fetch environment il:of destination))))))) (insert point destination (list node)) (when start (set-point-litatom point destination node nil t)))) (t (il:* il:|;;| "we're adding characters to an existing string or atom") (with-profile (il:fetch profile il:of destination) (let ((new-chars (il:concat (if not-all-selected (il:substring string start end) string)))) (when delete? (delete-nodes node context start end nil string)) (insert point destination (detranslate-chars new-chars type)))))))) ) (copy-structure-string (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "the CopyStructure method for strings and litatoms. the Structure and LinearForm fields have already been filled in with the values from the node we're a copy of, but we want to copy these structures in case we decide to smash them later. Assume under sedit profile.") (let* ((structure (il:fetch structure il:of node)) (font (il:fetch font il:of (car (il:fetch linear-form il:of node)))) (prin-2? (not (il:type? broken-atom structure)))) (il:replace structure il:of node il:with (cond ((il:stringp structure) (il:setq structure (il:concat structure))) ((il:type? broken-atom structure) (il:create broken-atom atom-chars il:_ (il:setq structure (il:concat (il:fetch atom-chars il:of structure))))) (t structure))) (rplaca (il:fetch linear-form il:of node) (il:create string-item string il:_ structure font il:_ font prin-2? il:_ prin-2?)) (il:* il:|;;| "assume running under sedit profile for this call to stringwidth") (il:* il:\; "read table specific") (adjust-width node nil (stringwidth structure font prin-2?)))) ) (delete-litatom (il:lambda (node context start end set-point? string) (il:* il:\; "Edited 23-Nov-87 19:10 by DCB") (il:* il:|;;| "the Delete method for strings and litatoms") (cond ((and (il:neq (il:fetch node-type il:of node) type-string) (eq start 1) (eq (or end start) (il:nchars string))) (il:* il:|;;| "deleting all the characters in an atom deletes it") (delete-nodes (il:fetch super-node il:of node) context node nil set-point?)) (t (replace-string node context start (or end start) "" set-point? string (and (il:neq (il:fetch node-type il:of node) type-string) (atom-point-type string start))) t))) ) (detranslate-chars (il:lambda (str type) (il:* il:\; "Edited 16-Jul-87 15:42 by DCB") (il:* il:|;;;| "read table specific. used to take read.table, now just uses *READTABLE* for profiles.") (when (il:neq type (quote string)) (il:setq str (il:copyall str)) (il:|for| c il:|instring| str il:|bind| escaped? (length il:_ 0) (esc il:_ (escape-char)) (multi-esc il:_ (il:|fetch| (readtablep il:multescapechar) il:|of| *readtable*)) (upcase? il:_ (il:|fetch| (readtablep il:caseinsensitive) il:|of| *readtable*)) il:|first| (il:setq type (and upcase? (eq type (quote atom)))) il:|do| (cond (escaped? nil) ((eq c multi-esc) (il:setq type (and upcase? (not type))) (il:setq c nil)) ((eq c esc) (il:setq escaped? t) (il:setq c nil)) ((and type (il:igeq c (il:charcode \a)) (il:ileq c (il:charcode \z))) (il:setq c (il:iplus c (il:constant (il:idifference (il:charcode a) (il:charcode \a))))))) (when c (il:rplcharcode str (il:setq length (il:add1 length)) c)) il:|finally| (il:|replace| (il:stringp il:length) il:|of| str il:|with| length))) str) ) (get-button-string (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "assume this is running under sedit profile.") (cond ((eq button-string-node node) button-string) (t (il:setq button-string-node node) (il:setq button-string (car (il:fetch linear-form il:of node))) (il:* il:\; "read table specific") (il:setq button-string (if (and (il:neq (il:fetch node-type il:of node) type-string) (il:fetch prin-2? il:of button-string)) (prin1-to-string (il:fetch string il:of button-string)) (princ-to-string (il:fetch string il:of button-string))))))) ) (grow-selection-litatom (il:lambda (selection context node) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "the GrowSelection method for litatoms and strings. if the whole node is already selected, select the super; otherwise select the whole node") (if (null (il:fetch select-start il:of selection)) (grow-selection-default selection context node) (set-selection-me selection context node))) ) (hasfat (il:lambda (str) (il:* il:\; "Edited 19-Nov-87 14:35 by DCB") (il:for c il:instring str il:thereis (il:igreaterp c il:\\maxthinchar))) ) (initialize-atomic (il:lambda nil (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:setq types (list* (il:setq type-litatom (il:create edit-node-type name il:_ (quote litatom) assign-format il:_ (quote assign-format-litatom) compute-format-values il:_ (quote il:nill) linearize il:_ nil sub-node-changed il:_ (quote il:shouldnt) compute-point-position il:_ (quote compute-point-position-litatom) compute-selection-position il:_ (quote compute-selection-position-litatom) set-point il:_ (quote set-point-litatom) set-selection il:_ (quote set-selection-litatom) grow-selection il:_ (quote grow-selection-litatom) select-segment il:_ (quote select-segment-litatom) insert il:_ (quote insert-litatom) delete il:_ (quote delete-litatom) copy-structure il:_ (quote copy-structure-string) copy-selection il:_ (quote copy-selection-litatom) stringify il:_ (quote stringify-atom) back-space il:_ (quote backspace-litatom) close-node il:_ (quote close-node-litatom))) (il:setq type-string (il:create edit-node-type il:using type-litatom name il:_ (quote string) assign-format il:_ (quote il:nill) set-point il:_ (quote set-point-string) set-selection il:_ (quote set-selection-string) insert il:_ (quote insert-string))) types))) ) (insert-litatom (il:lambda (node context where char point) (il:* il:\; "Edited 17-Jul-87 09:47 by DCB") (il:* il:|;;;| "the Insert method for litatoms") (il:* il:\; "read table specific") (insert-string node context where (and char (translate-chars char (if (il:type? edit-selection where) (il:fetch select-type il:of where) (il:fetch point-type il:of where)) (eq *print-case* :upcase))) point)) ) (insert-string (il:lambda (node context where chars point) (il:* il:\; "Edited 30-Nov-87 12:58 by DCB") (il:* il:|;;;| "the Insert method for strings") (let (start end string type) (cond ((il:type? edit-selection where) (il:setq start (il:fetch select-start il:of where)) (il:setq end (or (il:fetch select-end il:of where) start)) (il:setq string (il:fetch select-string il:of where)) (il:setq type (il:fetch select-type il:of where))) (t (il:setq end (il:fetch point-index il:of where)) (il:setq start (il:add1 end)) (il:setq string (il:fetch point-string il:of where)) (il:setq type (il:fetch point-type il:of where)))) (il:* il:|;;| "first replace any old chars with new chars") (replace-string node context start end (or chars "") point string type) (il:* il:|;;| "now do any indicated split ") (unless (or chars (dead-node? node)) (split-litatom node point context start (1- start) (il:fetch string il:of (car (il:fetch linear-form il:of node))))))) ) (open-litatom (il:lambda (context node string length) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (when (null length) (il:setq length 0)) (cond ((il:neq (il:fetch open-node il:of context) node) (close-open-node context) (il:replace open-node il:of context il:with node) (let ((open-string (il:fetch open-node-info il:of context)) (string-length (il:nchars string)) (string-item (car (il:fetch linear-form il:of node))) sub-string) (il:replace prin-2? il:of string-item il:with (eq (il:fetch node-type il:of node) type-string)) (il:replace real-length il:of open-string il:with string-length) (il:setq sub-string (il:fetch substring il:of open-string)) (when (il:ilessp (il:nchars (il:fetch buffer-string il:of open-string)) (il:setq length (il:iplus string-length (il:imax length 0)))) (il:substring (il:replace buffer-string il:of open-string il:with (il:allocstring length nil nil t)) 1 1 sub-string)) (il:rplstring (il:fetch buffer-string il:of open-string) 1 string) (il:replace (il:stringp il:length) il:of sub-string il:with string-length) (il:replace string il:of string-item il:with sub-string))) (t (let ((open-string (il:fetch open-node-info il:of context))) (when (il:igreaterp length 0) (when (il:ilessp (il:nchars (il:fetch buffer-string il:of open-string)) (il:setq length (il:iplus (il:fetch real-length il:of open-string) length))) (il:substring (il:replace buffer-string il:of open-string il:with (il:rplstring (il:allocstring length nil nil t) 1 (il:fetch buffer-string il:of open-string))) 1 1 (il:fetch substring il:of open-string)))) (il:replace string il:of (car (il:fetch linear-form il:of node)) il:with (il:fetch substring il:of open-string)))))) ) (parse--broken-atom (il:lambda (structure context mode) (il:* il:\; "Edited 17-Jul-87 09:04 by DCB") (il:* il:|;;;| "parse a BrokenAtom structure (presumably left there by a previous editing session)") (build-prelinearized-node structure context type-litatom (il:fetch atom-chars il:of structure) nil (il:fetch broken-atom-font il:of (il:fetch environment il:of context)))) ) (parse--litatom (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (il:* il:|;;;| "parse a litatom (this actually includes numbers). ") (il:* il:|;;;| "this used to take a parse mode as an argument, and if the parse mode was BindingList, it would call parse..list. parse..list now knows to make sure that its second child gets parsed as a list.") (il:* il:|;;;| "when the atom turns to a keyword, its linearization will have to be twiddled. see the comments in assign.format.litatom. ") (build-prelinearized-node structure context type-litatom structure t (il:fetch default-font il:of (il:fetch environment il:of context)))) ) (parse--string (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (il:* il:|;;;| "parse a string") (build-prelinearized-node structure context type-string structure t (il:fetch default-font il:of (il:fetch environment il:of context)))) ) (release-open-string (il:lambda (old-string new-string point selection) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (when (eq (il:fetch point-string il:of point) old-string) (il:replace point-string il:of point il:with new-string)) (when (eq (il:fetch select-string il:of selection) old-string) (il:replace select-string il:of selection il:with new-string))) ) (REPLACE-CHARS (IL:LAMBDA (NODE CONTEXT START END CHARS POINT TYPE STRING-ITEM) (IL:* IL:\; "Edited 28-Mar-90 19:14 by jds") (IL:* IL:|;;;| "replace the substring of this (open) node bounded by start and end (inclusive) with the characters in chars. set point after the inserted characters.") (IL:* IL:|;;| "read table specific") (IL:SETQ BUTTON-STRING-NODE (IL:SETQ BUTTON-STRING NIL)) (LET* ((DELTA-LENGTH (IL:IDIFFERENCE (IL:NCHARS CHARS) (IL:ADD1 (IL:IDIFFERENCE END START)))) (NEW-END (IL:IPLUS END DELTA-LENGTH)) (PRIN-2? (AND (EQ TYPE 'STRING) (IL:|fetch| PRIN-2? IL:|of| STRING-ITEM))) (MULTI-ESCAPE (AND (IL:NEQ TYPE 'STRING) (IL:|fetch| (READTABLEP IL:MULTESCAPECHAR) IL:|of| *READTABLE*) )) (ADD-MULTI-ESCAPE?) (COMPUTE-NEW-POINT-TYPE?) (OPEN-STRING (IL:|fetch| OPEN-NODE-INFO IL:|of| CONTEXT)) (STRING (IL:|fetch| BUFFER-STRING IL:|of| OPEN-STRING)) (LENGTH (IL:|fetch| REAL-LENGTH IL:|of| OPEN-STRING)) (FONT (IL:|fetch| FONT IL:|of| STRING-ITEM)) (DELTA-WIDTH (IL:IDIFFERENCE (STRINGWIDTH (IL:MKSTRING CHARS) FONT PRIN-2?) (STRINGWIDTH (IF (IL:ILEQ START END) (IL:SUBSTRING STRING START END) "") FONT PRIN-2?)))) (WHEN MULTI-ESCAPE (IL:|bind| (ESCAPE IL:_ (ESCAPE-CHAR)) C IL:|for| I IL:|from| START IL:|to| END IL:|do| (IL:SETQ C (IL:NTHCHARCODE STRING I)) (COND ((EQ C ESCAPE) (IL:SETQ I (IL:ADD1 I))) ((EQ C MULTI-ESCAPE) (IL:SETQ ADD-MULTI-ESCAPE? (NOT ADD-MULTI-ESCAPE?))))) (WHEN ADD-MULTI-ESCAPE? (SETF COMPUTE-NEW-POINT-TYPE? T) (IL:SETQ ADD-MULTI-ESCAPE? (COND ((AND (IL:NEQ END LENGTH) (EQ (IL:NTHCHARCODE STRING (IL:ADD1 END)) MULTI-ESCAPE)) (IL:SETQ END (IL:ADD1 END)) -1) (T 1))) (IL:SETQ DELTA-LENGTH (IL:IPLUS DELTA-LENGTH ADD-MULTI-ESCAPE?)) (IL:SETQ DELTA-WIDTH (IL:IPLUS DELTA-WIDTH (IL:ITIMES ADD-MULTI-ESCAPE? (IL:CHARWIDTH MULTI-ESCAPE FONT)) )))) (IL:|replace| REAL-LENGTH IL:|of| OPEN-STRING IL:|with| (IL:IPLUS LENGTH DELTA-LENGTH)) (COND ((AND (EQ 0 (IL:IPLUS LENGTH DELTA-LENGTH)) (IL:NEQ (IL:FETCH NODE-TYPE IL:OF NODE) TYPE-STRING)) (CLOSE-OPEN-NODE CONTEXT) (DELETE-NODES (IL:FETCH SUPER-NODE IL:OF NODE) CONTEXT NODE NIL POINT)) (T (WHEN (IL:NEQ END LENGTH) (IL:* IL:|;;|  "there are characters after the replacement, so shift them forward or backward as appropriate") (SHIFT-STRING STRING (IL:ADD1 END) (IL:IPLUS END DELTA-LENGTH 1) (IL:IDIFFERENCE LENGTH END))) (IL:RPLSTRING STRING START CHARS) (WHEN (EQ ADD-MULTI-ESCAPE? 1) (IL:RPLCHARCODE STRING (IL:ADD1 NEW-END) MULTI-ESCAPE)) (IL:|replace| (IL:STRINGP IL:LENGTH) IL:|of| (IL:SETQ STRING (IL:|fetch| SUBSTRING IL:|of| OPEN-STRING)) IL:|with| (IL:IPLUS LENGTH DELTA-LENGTH)) (ADJUST-WIDTH NODE CONTEXT (IL:IPLUS (IL:|fetch| INLINE-WIDTH IL:|of| NODE) DELTA-WIDTH)) (IL:|replace| OPEN-NODE-CHANGED? IL:|of| CONTEXT IL:|with| T) (WHEN POINT (IL:|replace| POINT-NODE IL:|of| POINT IL:|with| NODE) (IL:|replace| POINT-STRING IL:|of| POINT IL:|with| STRING) (IL:|replace| POINT-INDEX IL:|of| POINT IL:|with| NEW-END) (IL:|replace| POINT-TYPE IL:|of| POINT IL:|with| (IF COMPUTE-NEW-POINT-TYPE? (  ATOM-POINT-TYPE STRING NEW-END) TYPE))) (LET ((CARET (IL:|fetch| CARET-POINT IL:|of| CONTEXT))) (WHEN (AND (IL:NEQ CARET POINT) (EQ (IL:FETCH POINT-NODE IL:OF CARET) NODE) (IL:IGEQ (IL:FETCH POINT-INDEX IL:OF CARET) START)) (IL:* IL:|;;|  "if the caret was within or after replaced characters, it will need to be fixed up") (IL:REPLACE POINT-INDEX IL:OF CARET IL:WITH (IL:IPLUS DELTA-LENGTH (IL:IMAX (IL:FETCH POINT-INDEX IL:OF CARET) END))) (IL:REPLACE POINT-STRING IL:OF CARET IL:WITH STRING)))))))) (replace-string (il:lambda (node context start end chars point string type) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "replace the substring of this string node bounded by start and end (inclusive) with the characters in chars. set point after the inserted characters.") (open-litatom context node string (il:idifference (il:nchars chars) (il:add1 (il:idifference end start)))) (replace-chars node context start end chars point (or type (quote string)) (car (il:fetch linear-form il:of node)))) ) (scan-string (il:lambda (point-or-sel node read-table string font offset string?) (il:* il:\; "Edited 17-Jul-87 09:07 by DCB") (il:* il:|;;;| "given a string item and pixel offset from the start of the string, find the character pointed to. if string?, assume that string delim characters in the string are escaped and the string is preceded and followed by stringdelims") (il:bind in-multi-esc c cwidth (index il:_ 0) (x il:_ 0) (length il:_ (il:nchars string)) (point? il:_ (il:type? edit-point point-or-sel)) (esc-char il:_ (escape-char read-table)) (multi-esc-char il:_ (il:fetch (readtablep il:multescapechar) il:of (or read-table *readtable*))) il:first (when string? (il:setq cwidth (il:charwidth (il:charcode \") font)) (when (and (not point?) (il:ileq offset cwidth)) (set-selection-me point-or-sel nil (il:fetch select-node il:of point-or-sel)) (return)) (il:setq offset (il:idifference offset cwidth)) (il:setq x (il:iplus x cwidth))) il:while (il:ileq (il:setq index (il:add1 index)) length) il:do (il:setq cwidth (il:charwidth (il:setq c (il:nthcharcode string index)) font)) (if string? (cond ((or (eq c esc-char) (eq c (il:charcode \"))) (il:setq cwidth (il:iplus cwidth (il:charwidth esc-char font)))) ((il:ilessp c (il:charcode il:space)) (il:setq cwidth (il:iplus (il:charwidth (il:charcode ^) font) (il:charwidth (il:iplus c 64) font))))) (when (eq c esc-char) (il:setq cwidth (il:iplus cwidth (il:charwidth (il:nthcharcode string (il:add1 index)) font))))) (when (il:ileq offset (if point? (il:half cwidth) cwidth)) (go il:$$out)) (il:setq offset (il:idifference offset cwidth)) (il:setq x (il:iplus x cwidth)) (when (not string?) (cond ((eq c esc-char) (il:setq index (il:add1 index))) ((eq c multi-esc-char) (il:setq in-multi-esc (not in-multi-esc))))) il:finally (when (and string? (not point?) (il:igreaterp index length)) (set-selection-me point-or-sel nil (il:fetch select-node il:of point-or-sel)) (return)) (il:setq in-multi-esc (cond (string? (quote string)) (in-multi-esc (quote esc-atom)) (t (quote atom)))) (cond (point? (il:replace point-index il:of point-or-sel il:with (il:sub1 index)) (il:replace point-type il:of point-or-sel il:with in-multi-esc) (il:replace point-line il:of point-or-sel il:with (il:fetch first-line il:of node)) (il:replace point-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x))) (t (when (and (not string?) (il:igreaterp index length)) (il:shouldnt "select past end of atom")) (cond ((not (il:fetch select-start il:of point-or-sel)) (il:replace select-start il:of point-or-sel il:with index) (il:replace select-end il:of point-or-sel il:with (and (not string?) (eq c esc-char) (il:add1 index))) (il:replace select-type il:of point-or-sel il:with in-multi-esc) (il:replace select-start-line il:of point-or-sel il:with (il:replace select-end-line il:of point-or-sel il:with (il:fetch first-line il:of node))) (il:replace select-end-x il:of point-or-sel il:with (il:iplus cwidth (il:replace select-start-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x))))) (t (il:* il:\; "extending a point.or.sel") (when (not (il:fetch select-end il:of point-or-sel)) (il:replace select-end il:of point-or-sel il:with (il:fetch select-start il:of point-or-sel))) (cond ((il:ilessp index (il:fetch select-start il:of point-or-sel)) (il:* il:\; "extend the point.or.sel to the left") (il:replace select-start il:of point-or-sel il:with index) (il:replace select-start-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x)) (il:replace select-type il:of point-or-sel il:with in-multi-esc)) ((il:igreaterp (if (and (not string?) (eq c esc-char)) (il:setq index (il:add1 index)) index) (il:fetch select-end il:of point-or-sel)) (il:* il:\; "extend the point.or.sel to the right") (il:replace select-end il:of point-or-sel il:with index) (il:replace select-end-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x cwidth)))))))))) ) (select-segment-litatom (il:lambda (selection context node subnode index offset item) (il:* il:\; "Edited 24-Nov-87 09:53 by DCB") (il:* il:|;;;| "the SelectSegment method for litatoms and strings. scan.string does most of the work") (il:* il:|;;| "pass NIL as readtable") (scan-string selection node nil (il:fetch select-string il:of selection) (il:fetch font il:of item) offset (eq (il:fetch node-type il:of node) type-string))) ) (set-point-litatom (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 24-Nov-87 09:54 by DCB") (il:* il:|;;;| "the SetPoint method for litatoms") (cond ((eq type (quote structure)) (il:* il:|;;| "structure points will have to be handled by our super") (punt-set-point point context node (if index (il:igeq offset (il:half (il:fetch width il:of item))) offset) compute-location?)) (t (il:replace point-node il:of point il:with node) (il:replace point-string il:of point il:with (get-button-string node context)) (cond ((not index) (il:* il:|;;| "placing the caret at the beginning or end of the atom") (il:replace point-index il:of point il:with (if offset (il:nchars button-string) 0)) (il:replace point-type il:of point il:with (quote atom)) (when compute-location? (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of node) (if offset (il:fetch inline-width il:of node) 0))) (il:replace point-line il:of point il:with (il:fetch first-line il:of node)))) (t (il:* il:|;;| "pass NIL as readtable") (scan-string point node nil button-string (il:fetch font il:of item) offset)))))) ) (set-point-string (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "the SetPoint method for strings. the point must be *inside* the delimiting quotes") (cond ((eq type (quote structure)) (punt-set-point point context node (if index (il:igeq offset (il:half (il:fetch width il:of item))) offset) compute-location?)) ((not index) (punt-set-point point context node offset compute-location?)) (t (il:replace point-node il:of point il:with node) (il:replace point-string il:of point il:with (get-button-string node context)) (il:* il:|;;| "pass NIL as readtable") (scan-string point node nil button-string (il:fetch font il:of item) offset t)))) ) (set-selection-litatom (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 24-Nov-87 09:55 by DCB") (il:* il:|;;;| "the SetSelection method for litatoms") (cond ((eq type (quote structure)) (il:* il:|;;| "structure selections get it all") (set-selection-me selection context node)) (t (il:replace select-node il:of selection il:with node) (il:replace select-string il:of selection il:with (get-button-string node context)) (il:replace select-start il:of selection il:with nil) (il:* il:|;;| "pass NIL as readtable") (scan-string selection node nil button-string (il:fetch font il:of item) offset)))) ) (set-selection-string (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "the SetSelection method for strings") (cond ((eq type (quote structure)) (il:* il:|;;| "structure selections or pointing at the delimiting quotes gets the whole string") (set-selection-me selection context node)) (t (il:replace select-node il:of selection il:with node) (il:replace select-string il:of selection il:with (get-button-string node context)) (il:replace select-start il:of selection il:with nil) (il:* il:|;;| "pass NIL as readtable") (scan-string selection node nil button-string (il:fetch font il:of item) offset t)))) ) (split-litatom (il:lambda (node point context start end string) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "the Split method for litatoms and strings") (il:setq button-string-node (il:setq button-string nil)) (let ((length (il:nchars string)) suffix) (cond ((and (il:neq (il:fetch node-type il:of node) type-string) (eq start 1) (eq end length)) (il:* il:|;;| "deleting all the characters in an atom deletes it") (close-open-node context) (delete-nodes (il:fetch super-node il:of node) context node nil point)) (t (when (not (and (eq start (il:add1 end)) (or (eq start 1) (eq end length)))) (il:* il:|;;| "something's got to be changed") (open-litatom context node string) (let ((open-string (il:fetch open-node-info il:of context)) new-length) (cond ((eq end length) (il:setq new-length (il:sub1 start))) ((eq start 1) (il:setq new-length (il:idifference length end)) (shift-string (il:fetch buffer-string il:of open-string) (il:add1 end) 1 new-length)) (t (il:setq new-length (il:sub1 start)) (il:setq suffix (il:substring (il:fetch buffer-string il:of open-string) (il:add1 end) length)))) (il:replace real-length il:of open-string il:with new-length) (il:replace (il:stringp il:length) il:of (il:fetch substring il:of open-string) il:with new-length) (il:replace open-node-changed? il:of context il:with t))) (when suffix (start-undo-block)) (close-open-node context) (punt-set-point point context node (or (il:neq start 1) (eq end length)) nil) (when suffix (when (il:fetch point-node il:of point) (let (string) (il:* il:|;;| "use string to handle broken atoms: if the suffix is a broken atom, string will be the chars") (cond ((il:neq (il:fetch node-type il:of node) type-string) (il:* il:\; "read table specific") (il:setq suffix (cons-atom suffix t)) (when (il:type? broken-atom suffix) (il:setq string (il:fetch atom-chars il:of suffix)))) (t (il:setq suffix (il:concat suffix)))) (il:setq suffix (create-simple-node suffix (il:fetch environment il:of context) (il:fetch node-type il:of node) (or string suffix) (null string) (il:fetch default-font il:of (il:fetch environment il:of context))))) (insert point context suffix) (punt-set-point point context suffix nil nil)) (end-undo-block)))))) ) (stringify-atom (il:lambda (node environment) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:\; "read table specific") (il:mkstring (il:fetch structure il:of node) t)) ) (translate-chars (il:lambda (chars point-type upcase?) (il:* il:\; "Edited 16-Jul-87 15:36 by DCB") (il:* il:|;;;| "read table specific. used to take read.table, now just uses *READTABLE* for profiles.") (when (not (il:fetch (readtablep il:caseinsensitive) il:of *readtable*)) (il:setq upcase? t)) (il:bind (esc il:_ (escape-char)) (mult-esc il:_ (il:fetch (readtablep il:multescapechar) il:of *readtable*)) (r il:_ "") il:first (when (eq (il:nchars chars) 1) (il:setq c (il:chcon1 chars)) (return (if (and (il:neq c esc) (il:neq c mult-esc) (or (eq point-type (quote esc-atom)) (not (atom-char-escaped c)))) (if (or upcase? (il:ilessp c (il:charcode a)) (il:igreaterp c (il:charcode z)) (eq point-type (quote esc-atom))) chars (il:character (il:iplus c (il:constant (il:idifference (il:charcode \a) (il:charcode a)))))) (il:concat (il:character esc) chars)))) il:for c il:instring chars il:do (il:setq r (if (and (il:neq c esc) (il:neq c mult-esc) (or (eq point-type (quote esc-atom)) (not (atom-char-escaped c)))) (il:concat r (il:character (if (or upcase? (il:ilessp c (il:charcode a)) (il:igreaterp c (il:charcode z)) (eq point-type (quote esc-atom))) c (il:iplus c (il:constant (il:idifference (il:charcode \a) (il:charcode a))))))) (il:concat r (il:character esc) (il:character c)))) il:finally (return r))) ) (undo-atom-change (il:lambda (context node old-value) (il:* il:\; "Edited 7-Jul-87 08:40 by DCB") (undo-by undo-atom-change node (il:fetch structure il:of node)) (il:replace structure il:of node il:with old-value) (subnode-changed node context) (if (eq (il:fetch node-type il:of node) type-string) (note-change-in-simple node context) (note-change node context))) ) ) (IL:PUTPROPS IL:SEDIT-ATOMIC IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (2049 43188 (ASSIGN-FORMAT-LITATOM 2062 . 4448) (ATOM-POINT-TYPE 4450 . 5048) ( BACKSPACE-GAP 5050 . 5458) (BACKSPACE-LITATOM 5460 . 7222) (BACKSPACE-UNKNOWN 7224 . 7605) ( CLOSE-NODE-LITATOM 7607 . 9006) (COMPUTE-POINT-POSITION-LITATOM 9008 . 9781) ( COMPUTE-SELECTION-POSITION-LITATOM 9783 . 10656) (CONS-ATOM 10658 . 11196) (COPY-SELECTION-LITATOM 11198 . 14457) (COPY-STRUCTURE-STRING 14459 . 15593) (DELETE-LITATOM 15595 . 16207) (DETRANSLATE-CHARS 16209 . 17253) (GET-BUTTON-STRING 17255 . 17841) (GROW-SELECTION-LITATOM 17843 . 18256) (HASFAT 18258 . 18406) (INITIALIZE-ATOMIC 18408 . 19633) (INSERT-LITATOM 19635 . 20036) (INSERT-STRING 20038 . 20998) (OPEN-LITATOM 21000 . 22678) (PARSE--BROKEN-ATOM 22680 . 23059) (PARSE--LITATOM 23061 . 23719) (PARSE--STRING 23721 . 23987) (RELEASE-OPEN-STRING 23989 . 24354) (REPLACE-CHARS 24356 . 30966) ( REPLACE-STRING 30968 . 31487) (SCAN-STRING 31489 . 35443) (SELECT-SEGMENT-LITATOM 35445 . 35882) ( SET-POINT-LITATOM 35884 . 37032) (SET-POINT-STRING 37034 . 37766) (SET-SELECTION-LITATOM 37768 . 38400 ) (SET-SELECTION-STRING 38402 . 39082) (SPLIT-LITATOM 39084 . 41310) (STRINGIFY-ATOM 41312 . 41492) ( TRANSLATE-CHARS 41494 . 42814) (UNDO-ATOM-CHANGE 42816 . 43186))))) IL:STOP