(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "16-May-90 21:47:02" IL:|{DSK}local>lde>lispcore>sources>SEDIT-COMMENTS.;2| 42559 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-COMMENTSCOMS) IL:|previous| IL:|date:| "27-Apr-88 11:20:49" IL:|{DSK}local>lde>lispcore>sources>SEDIT-COMMENTS.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-COMMENTSCOMS) (IL:RPAQQ IL:SEDIT-COMMENTSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-COMMENTS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-COMMENTS) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:CONSTANTS (LEVEL-1-COMMENT 'IL:\;) (LEVEL-2-COMMENT 'IL:|;;|) (LEVEL-3-COMMENT 'IL:|;;;|) (LEVEL-4-COMMENT 'IL:|;;;;|) (LEVEL-5-COMMENT 'IL:\|) (COMMENT-LEVEL-TABLE (LIST LEVEL-1-COMMENT 1 LEVEL-2-COMMENT 2 LEVEL-3-COMMENT 3 LEVEL-4-COMMENT 4 LEVEL-5-COMMENT 5)) (COMMENT-MARKERS (LIST LEVEL-1-COMMENT LEVEL-2-COMMENT LEVEL-3-COMMENT LEVEL-4-COMMENT LEVEL-5-COMMENT))) (IL:FNS BACKSPACE-COMMENT CFV-COMMENT CLOSE-NODE-COMMENT COMMENT-LENGTH COMPUTE-COMMENT-COLUMN COMPUTE-POINT-POSITION-COMMENT COMPUTE-SELECTION-POSITION-COMMENT COPY-SELECTION-COMMENT COPY-STRUCTURE-COMMENT COPY-STRUCTURE-COMMENT-WORD CREATE-NEW-COMMENT DEGRADE-COMMENT DELETE-COMMENT INITIALIZE-COMMENTS INSERT-COMMENT SPLIT-COMMENT INSERT-COMMENT-CHARS LINEARIZE-COMMENT MAP-COMMENT-INDEX PARSE--COMMENT PARSE--COMMENT-WORD PARSE-STRING-INTO-WORDS SELECT-SEGMENT-COMMENT SET-POINT-COMMENT SET-POINT-COMMENT-WORD SET-SELECTION-COMMENT SET-SELECTION-COMMENT-WORD SIMPLE-STRING-OFFSET SIMPLE-STRING-SCAN START-COMMENT STRINGIFY-COMMENT CREATE-COMMENT-WORD-NODE CREATE-COMMENT-WORD-NODES UNDO-COMMENT-CHANGE UPGRADE-COMMENT) (IL:FUNCTIONS MAKE-COMMENT-STRING VERIFY-COMMENT))) (IL:PUTPROPS IL:SEDIT-COMMENTS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-COMMENTS 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:DECLARE\: IL:EVAL@COMPILE (IL:RPAQQ LEVEL-1-COMMENT IL:\;) (IL:RPAQQ LEVEL-2-COMMENT IL:|;;|) (IL:RPAQQ LEVEL-3-COMMENT IL:|;;;|) (IL:RPAQQ LEVEL-4-COMMENT IL:|;;;;|) (IL:RPAQQ LEVEL-5-COMMENT IL:\|) (IL:RPAQ COMMENT-LEVEL-TABLE (LIST LEVEL-1-COMMENT 1 LEVEL-2-COMMENT 2 LEVEL-3-COMMENT 3 LEVEL-4-COMMENT 4 LEVEL-5-COMMENT 5)) (IL:RPAQ COMMENT-MARKERS (LIST LEVEL-1-COMMENT LEVEL-2-COMMENT LEVEL-3-COMMENT LEVEL-4-COMMENT LEVEL-5-COMMENT)) (IL:CONSTANTS (LEVEL-1-COMMENT 'IL:\;) (LEVEL-2-COMMENT 'IL:|;;|) (LEVEL-3-COMMENT 'IL:|;;;|) (LEVEL-4-COMMENT 'IL:|;;;;|) (LEVEL-5-COMMENT 'IL:\|) (COMMENT-LEVEL-TABLE (LIST LEVEL-1-COMMENT 1 LEVEL-2-COMMENT 2 LEVEL-3-COMMENT 3 LEVEL-4-COMMENT 4 LEVEL-5-COMMENT 5)) (COMMENT-MARKERS (LIST LEVEL-1-COMMENT LEVEL-2-COMMENT LEVEL-3-COMMENT LEVEL-4-COMMENT LEVEL-5-COMMENT))) ) (IL:DEFINEQ (backspace-comment (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 09:50 by DCB") (il:* il:\; "the BackSpace method for comments") (cond ((null index) (il:* il:\; "backspacing from the right boundary puts the caret immediately after the last character") (let ((point (il:fetch caret-point il:of context))) (close-open-node context) (il:replace point-node il:of point il:with node) (il:replace point-index il:of point il:with (il:nchars (caddr (il:fetch structure il:of node)))) (il:replace point-type il:of point il:with (quote string)))) ((eq 0 index) (cond ((il:igreaterp (il:fetch unassigned il:of node) 1) (il:* il:\; "backspacing over one of the semicolons") (degrade-comment context node)) ((null (cdr (il:fetch sub-nodes il:of node))) (il:* il:\; "backspacing from the front of an empty comment deletes it") (delete-nodes (il:fetch super-node il:of node) context node nil (il:fetch caret-point il:of context))))) (t (il:* il:\; "otherwise, delete the character to the left of the caret") (delete-comment node context index nil (il:fetch caret-point il:of context)))) (set-selection-nowhere (il:fetch selection il:of context))) ) (cfv-comment (il:lambda (node environment context format) (il:* il:\; "Edited 12-Feb-88 16:48 by raf") (il:* il:|;;;| "compute the width estimates for a comment node") (il:replace inline-width il:of node il:with nil) (il:* il:\; "dispatch on the comment level") (let ((width (il:fetch comment-width il:of context))) (il:selectq (il:fetch unassigned il:of node) (1 (il:* il:|;;| "here we know the comment width") (il:replace preferred-width il:of node il:with width)) (2 (il:* il:|;;| "these affect the super-node's formatting. We don't generally want double-semi comments to force us into miser mode, so guess small") (il:replace preferred-width il:of node il:with 30)) ((3 4 5) (il:* il:|;;| "since these won't affect supernode's formattng, just guess small") (il:replace preferred-width il:of node il:with 30)) (il:shouldnt "unexpected value for comment level")))) ) (close-node-comment (il:lambda (context node) (il:* il:\; "Edited 13-Apr-88 14:45 by woz") (undo-by undo-comment-change node (caddr (il:fetch structure il:of node))) (rplaca (cddr (il:|fetch| structure il:|of| node)) (make-comment-string node)) (il:|replace| open-node il:|of| context il:|with| nil))) (comment-length (il:lambda (node number-of-subnodes) (il:* il:\; "Edited 13-Apr-88 14:25 by woz") (il:|for| i il:|from| 1 il:|to| number-of-subnodes il:|as| subnode il:|in| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|sum| (il:nchars (il:|fetch| structure il:|of| subnode))))) (compute-comment-column (il:lambda (context window) (il:* il:\; "Edited 7-Jul-87 09:50 by DCB") (let ((environment (il:fetch environment il:of context))) (il:* il:|;;| "set the context's comment column info based on the window.") (il:replace comment-width il:of context il:with (il:iquotient (il:itimes (il:windowprop window (quote il:width)) (il:fetch comment-width-percent il:of environment)) 100)) (il:replace comment-separation il:of context il:with (il:fetch init-comment-separation il:of environment)))) ) (compute-point-position-comment (il:lambda (point context) (il:* il:\; "Edited 17-Nov-87 11:47 by DCB") (il:* il:|;;;| "implements the ComputePointPosition method for a comment") (let ((node (il:fetch point-node il:of point)) subnode) (map-comment-index context node (il:fetch point-index il:of point)) (il:setq subnode (car (il:fetch \\y il:of context))) (cond ((null subnode) (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:replace point-line il:of point il:with (il:fetch first-line il:of subnode)) (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of subnode) (simple-string-offset (car (il:fetch linear-form il:of subnode)) (il:fetch \\x il:of context)))))))) ) (compute-selection-position-comment (il:lambda (selection context) (il:* il:\; "Edited 17-Nov-87 11:48 by DCB") (il:* il:|;;;| "implements the ComputeSelectionPosition method for a comment") (let ((node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection))) (map-comment-index context node start (or (il:fetch select-end il:of selection) start)) (let ((start-subnode (car (il:fetch \\y il:of context))) (end-subnode (car (il:fetch \\t il:of context)))) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of start-subnode)) (il:replace select-start-x il:of selection il:with (il:iplus (il:fetch start-x il:of start-subnode) (simple-string-offset (car (il:fetch linear-form il:of start-subnode)) (il:sub1 (il:fetch \\x il:of context))))) (il:replace select-end-line il:of selection il:with (il:fetch first-line il:of end-subnode)) (il:replace select-end-x il:of selection il:with (il:iplus (il:fetch start-x il:of end-subnode) (simple-string-offset (car (il:fetch linear-form il:of end-subnode)) (il:fetch \\z il:of context))))))) ) (copy-selection-comment (il:lambda (selection context destination point delete?) (il:* il:\; "Edited 23-Feb-88 11:37 by raf") (il:* il:|;;;| "method for shift selecting a comment anywhere.") (let ((node (il:fetch select-node il:of selection)) (comment (caddr (il:fetch structure il:of (il:fetch select-node il:of selection)))) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (promptwindow (get-prompt-window (or destination context))) insert) (cond ((and start (or (il:neq (or end (il:setq end start)) (il:sub1 (il:nchars comment))) (il:neq start 0))) (il:* il:\; "some subset of the comment has been selected") (il:setq comment (il:substring comment start end))) (t (il:setq comment (stringify-comment node (il:fetch environment il:of context))))) (when delete? (delete-nodes node context start end)) (cond ((null destination) (il:* il:\; "it's going to a foreign sink; bksysbuf it") (il:bksysbuf comment (and (eq (il:fetch node-type il:of node) type-string) (null start)))) ((eq (il:fetch point-type il:of point) (quote string)) (il:* il:\; "comments insert as whole structures") (insert point destination comment)) (t (when (eq (il:fetch point-type il:of point) (quote atom)) (il:* il:\; "first make a structure point") (insert point destination nil)) (cond ((not start) (il:* il:\; "insert whole node") (insert point destination (copy-node node destination))) (t (il:setq insert (il:bind (stream il:_ (il:openstringstream comment)) obj il:while (il:setq obj (il:nlsetq (il:read stream))) il:collect (parse-new (car obj) destination))) (if insert (insert point destination insert) (il:|printout| promptwindow t "Selection not a valid structure.")))))))) ) (copy-structure-comment (il:lambda (node) (il:* il:\; "Edited 13-Apr-88 14:44 by woz") (il:|replace| structure il:|of| node il:|with| (list 'il:* (cadr (il:|fetch| structure il:|of| node)) (make-comment-string node))))) (copy-structure-comment-word (il:lambda (node) (il:* il:\; "Edited 13-Apr-88 14:28 by woz") (il:* il:|;;;| "the structure field of the new comment.word isn't completely built here, since it's supposed to be a list of all the words in the comment starting with this one. instead, we build one element lists for each comment.word, and copy.structure.comment links them all together") (let ((new-string (copy-seq (il:|fetch| structure il:|of| node)))) (il:|replace| structure il:|of| node il:|with| new-string) (rplaca (il:|fetch| linear-form il:|of| node) (il:|create| string-item il:|using| (car (il:|fetch| linear-form il:|of| node)) string il:_ new-string))))) (create-new-comment (il:lambda (context) (il:* il:\; "Edited 6-Apr-88 16:35 by woz") (let* ((width (il:|fetch| comment-width il:|of| context)) (comment (il:|create| edit-node node-type il:_ type-comment structure il:_ (list 'il:* 'il:\; "") depth il:_ 0 inline-width il:_ nil preferred-width il:_ width unassigned il:_ 1 sub-nodes il:_ (list 0)))) (il:|replace| linear-form il:|of| comment il:|with| (create-weak-link comment)) comment))) (degrade-comment (il:lambda (context node) (il:* il:\; "Edited 7-Jul-87 09:53 by DCB") (rplaca (cdr (il:fetch structure il:of node)) (car (il:nth comment-markers (il:add (il:fetch unassigned il:of node) -1)))) (note-change node context) (when (il:fetch super-node il:of (il:fetch super-node il:of node)) (il:* il:\; "this node has a supernode that is not the root") (note-change (il:fetch super-node il:of node) context)) (undo-by upgrade-comment node)) ) (delete-comment (il:lambda (node context start end set-point?) (il:* il:\; "Edited 27-Apr-88 11:14 by woz") (il:* il:|;;;| "the Delete method for comments") (when (il:neq (il:|fetch| open-node il:|of| context) node) (close-open-node context) (il:|replace| open-node il:|of| context il:|with| node)) (il:|replace| open-node-changed? il:|of| context il:|with| t) (when set-point? (il:|replace| point-node il:|of| set-point? il:|with| node) (il:|replace| point-index il:|of| set-point? il:|with| (il:sub1 start)) (il:|replace| point-type il:|of| set-point? il:|with| (quote string))) (map-comment-index context node start (or end start)) (prog* ((start-index (il:|fetch| \\x il:|of| context)) (start-node (car (il:|fetch| \\y il:|of| context))) (end-index (il:|fetch| \\z il:|of| context)) (end-node (car (il:|fetch| \\t il:|of| context))) (number-of-subnodes (car (il:|fetch| sub-nodes il:|of| node))) node-index string length new-width) (when (eq start-node end-node) (il:setq string (il:|fetch| string il:|of| (car (il:|fetch| linear-form il:|of| start-node)))) (il:setq length (il:nchars string)) (il:setq node-index (il:|fetch| sub-node-index il:|of| start-node)) (when (not (or (and (eq start-index 1) (il:neq node-index 1) (or (eq end-index length) (eq (il:nthcharcode string (il:add1 end-index)) (il:charcode il:sp)))) (and (eq end-index length) (il:neq node-index number-of-subnodes) (or (eq start-index 1) (il:neq (il:nthcharcode string (il:sub1 start-index)) (il:charcode il:sp)))))) (il:* il:|;;| "we're not going to merge -- fast case") (cond ((and (eq start-index 1) (eq end-index length)) (il:* il:\; "everything deleted!") (il:|replace| open-node il:|of| context il:|with| nil) (il:|replace| open-node-changed? il:|of| context il:|with| nil) (rplaca (cddr (il:|fetch| structure il:|of| node)) (il:concat "")) (il:|replace| sub-nodes il:|of| node il:|with| (list 0)) (note-change node context)) (t (il:setq new-width (il:idifference (il:|fetch| inline-width il:|of| start-node) (stringwidth (il:substring string start-index end-index) (il:|fetch| font il:|of| (car (il:|fetch| linear-form il:|of| start-node)))))) (il:setq string (il:concat (or (il:substring string 1 (il:sub1 start-index)) "") (or (il:substring string (il:add1 end-index)) ""))) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| start-node)) il:|with| string) (il:|replace| structure il:|of| start-node il:|with| string) (adjust-width start-node context new-width))) (let ((caret (il:|fetch| caret-point il:|of| context))) (when (and (il:neq caret set-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:idifference (il:|fetch| point-index il:|of| caret) (il:idifference (il:add1 end-index) start-index))))) (return))) (il:setq length (il:nchars (caddr (il:|fetch| structure il:|of| node)))) (il:* il:\; "save old length") (il:setq string (il:concat (or (il:substring (il:|fetch| structure il:|of| start-node) 1 (il:sub1 start-index)) "") (or (il:substring (il:|fetch| structure il:|of| end-node) (il:add1 end-index)) ""))) (il:|for| subnode-index il:|from| (il:|fetch| sub-node-index il:|of| start-node) il:|bind| nodes rest-nodes il:|first| (il:setq nodes (il:nth (il:|fetch| sub-nodes il:|of| node) subnode-index)) (il:setq rest-nodes (cdr (il:|fetch| \\t il:|of| context))) (rplacd nodes rest-nodes) il:|while| rest-nodes il:|do| (il:|replace| sub-node-index il:|of| (car rest-nodes) il:|with| subnode-index) (il:setq rest-nodes (cdr rest-nodes)) il:|finally| (rplaca (il:|fetch| sub-nodes il:|of| node) (il:sub1 subnode-index)) (when (il:igreaterp (il:nchars string) 0) (insert-comment-chars context node (and (il:neq (il:|fetch| sub-node-index il:|of| start-node) 1) nodes) nil string))) (note-change node context) (let ((caret (il:|fetch| caret-point il:|of| context))) (when (and (il:neq caret set-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:idifference (il:|fetch| point-index il:|of| caret) (il:idifference (il:add1 (or end start)) start)))))) t) ) (initialize-comments (il:lambda nil (il:* il:\; "Edited 7-Jul-87 09:54 by DCB") (il:setq types (list* (il:setq type-comment (il:create edit-node-type name il:_ (quote comment) assign-format il:_ (quote il:nill) compute-format-values il:_ (quote cfv-comment) linearize il:_ (quote linearize-comment) set-point il:_ (quote set-point-comment) set-selection il:_ (quote set-selection-comment) grow-selection il:_ (quote grow-selection-litatom) select-segment il:_ (quote select-segment-comment) compute-point-position il:_ (quote compute-point-position-comment) compute-selection-position il:_ (quote compute-selection-position-comment) insert il:_ (quote insert-comment) delete il:_ (quote delete-comment) copy-structure il:_ (quote copy-structure-comment) copy-selection il:_ (quote copy-selection-comment) stringify il:_ (quote stringify-comment) back-space il:_ (quote backspace-comment) close-node il:_ (quote close-node-comment))) (il:setq type-comment-word (il:create edit-node-type name il:_ (quote comment-word) assign-format il:_ (quote il:nill) compute-format-values il:_ (quote il:nill) set-point il:_ (quote set-point-comment-word) set-selection il:_ (quote set-selection-comment-word) copy-structure il:_ (quote copy-structure-comment-word))) types))) ) (insert-comment (il:lambda (node context where chars point) (il:* il:\; "Edited 17-Jul-87 09:59 by DCB") (il:* il:|;;;| "the Insert method for comments") (let (start) (cond ((il:type? edit-selection where) (il:setq start (il:sub1 (il:fetch select-start il:of where))) (delete-comment node context (il:add1 start) (or (il:fetch select-end il:of where) (il:add1 start)))) (t (il:setq start (il:fetch point-index il:of where)))) (cond (chars (map-comment-index context node start) (when (il:neq (il:fetch open-node il:of context) node) (close-open-node context) (il:replace open-node il:of context il:with node)) (il:replace open-node-changed? il:of context il:with t) (insert-comment-chars context node (il:fetch \\y il:of context) (il:fetch \\x il:of context) chars) (note-change node context) (when point (il:replace point-node il:of point il:with node) (il:replace point-index il:of point il:with (il:iplus start (il:nchars chars))))) (t (split-comment node point context start))))) ) (split-comment (il:lambda (node point context start) (il:* il:\; "Edited 7-Jul-87 09:54 by DCB") (close-open-node context) (let* ((comment (caddr (il:fetch structure il:of node))) (length (il:nchars comment)) (split-string (il:substring comment (il:add1 start) length))) (set-point point context (il:fetch super-node il:of node) (il:fetch sub-node-index il:of node) t node (quote structure)) (when (il:neq start length) (il:* il:\; "split in middle of comment.") (delete-nodes node context (il:add1 start) length nil comment) (insert point context (parse-new (list (quote il:*) (car (il:nth comment-markers (il:fetch unassigned il:of node))) split-string) context)) (set-point point context (il:fetch super-node il:of node) (il:fetch sub-node-index il:of node) t node (quote structure))))) ) (insert-comment-chars (il:lambda (context node subnodes index chars) (il:* il:\; "Edited 13-Apr-88 16:55 by woz") (il:* il:|;;;| "what a hack. ugh blech.") (let ((length (il:nchars chars)) (subnode (car subnodes)) (font (il:|fetch| comment-font il:|of| (il:|fetch| environment il:|of| context))) string string-length) (when subnode (il:setq string (il:|fetch| structure il:|of| subnode)) (il:setq string-length (il:nchars string)) (when (eq index string-length) (il:setq index nil))) (cond ((and (eq length 1) subnode (if (eq (il:chcon1 chars) (il:charcode il:sp)) (or (null index) (eq (il:nthcharcode string (il:add1 index)) (il:charcode il:sp))) (or (eq index 0) (il:neq (il:nthcharcode string (or index string-length)) (il:charcode il:sp))))) (il:* il:|;;| "fast case") (il:setq chars (il:mkstring chars)) (il:setq string (il:concat (or (il:substring string 1 index) "") chars (or (and index (il:substring string (il:add1 index))) ""))) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)) il:|with| string) (il:|replace| structure il:|of| subnode il:|with| string) (adjust-width subnode context (il:iplus (il:|fetch| inline-width il:|of| subnode) (stringwidth chars font)))) (t (cond ((eq index 0) (il:setq subnodes (and (il:neq (il:|fetch| sub-node-index il:|of| subnode) 1) (il:nth (il:|fetch| sub-nodes il:|of| node) (il:|fetch| sub-node-index il:|of| subnode)))) (il:setq subnode (car subnodes))) (index (let* ((new-string (il:substring string (il:add1 index))) (new-subnode (create-simple-node new-string (il:|fetch| environment il:|of| context) type-comment-word new-string nil font))) (adjust-width subnode context (il:idifference (il:|fetch| inline-width il:|of| subnode) (il:|fetch| inline-width il:|of| new-subnode))) (rplacd subnodes (cons new-subnode (cdr subnodes))) (il:setq new-string (il:substring string 1 index)) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)) il:|with| new-string) (il:|replace| structure il:|of| subnode il:|with| new-string)))) (let ((words (create-comment-word-nodes chars (if subnodes (cdr subnodes) (cdr (il:|fetch| sub-nodes il:|of| node))) (il:|fetch| environment il:|of| context)))) (if subnodes (rplacd subnodes words) (rplacd (il:|fetch| sub-nodes il:|of| node) words))) (il:|for| il:|old| subnodes il:|on| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|bind| (n il:_ 0) next-subnode string (depth il:_ (il:add1 (il:|fetch| depth il:|of| node))) il:|do| (il:setq n (il:add1 n)) (il:setq subnode (car subnodes)) (il:|replace| sub-node-index il:|of| subnode il:|with| n) (il:|replace| super-node il:|of| subnode il:|with| node) (il:|replace| depth il:|of| subnode il:|with| depth) (il:setq string (il:|fetch| structure il:|of| subnode)) (il:|while| (and (il:setq next-subnode (cadr subnodes)) (or (il:neq (il:nthcharcode string (il:nchars string)) (il:charcode il:sp)) (eq (il:chcon1 (car (il:|fetch| structure il:|of| next-subnode))) (il:charcode il:sp)))) il:|do| (il:setq string (il:concat string (il:|fetch| structure il:|of| next-subnode))) (il:|replace| structure il:|of| subnode il:|with| string) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)) il:|with| string) (adjust-width subnode context (il:iplus (il:|fetch| inline-width il:|of| subnode) (il:|fetch| inline-width il:|of| next-subnode))) (rplacd subnodes (cddr subnodes))) il:|finally| (rplaca (il:|fetch| sub-nodes il:|of| node) n)))))) ) (linearize-comment (il:lambda (node context index) (il:* il:\; "Edited 23-Feb-88 11:18 by raf") (let* ((level (il:|fetch| unassigned il:|of| node)) (environment (il:|fetch| environment il:|of| context)) (prefix (il:listget (il:|fetch| comment-string il:|of| environment) level))) (il:|bind| (il:first il:_ t) il:|for| subnode il:|in| (cond (index (cddr (il:nth (il:|fetch| sub-nodes il:|of| node) index))) (t (il:* il:|;;| "we're at the beginning, so display the prefix") (output-constant-string context prefix) (cdr (il:|fetch| sub-nodes il:|of| node)))) il:|do| (cond ((or il:first (il:ileq (il:iplus (il:|fetch| current-x il:|of| context) (il:|fetch| inline-width il:|of| subnode)) (il:|fetch| right-margin il:|of| node))) (linearize subnode context)) (t (output-cr context (il:|fetch| start-x il:|of| node)) (unless (eq 5 level) (output-constant-string context prefix)) (linearize subnode context))) (il:setq il:first nil)) (when (eq 5 level) (output-constant-string context (il:listget (il:fetch comment-string il:of environment) 6))))) ) (map-comment-index (il:lambda (context node start end) (il:* il:\; "Edited 13-Apr-88 14:26 by woz") (il:|bind| length subnode (index il:_ start) (open-node il:_ (il:|fetch| open-node il:|of| context)) il:|for| subnodes il:|on| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|do| (il:setq subnode (car subnodes)) (il:setq length (if (eq subnode open-node) (il:|fetch| real-length il:|of| (il:|fetch| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)))) (il:nchars (il:|fetch| structure il:|of| subnode)))) (cond ((il:igreaterp index length) (il:setq index (il:idifference index length))) (t (when start (il:|replace| \\x il:|of| context il:|with| index) (il:|replace| \\y il:|of| context il:|with| subnodes) (when (null end) (return)) (il:setq index (il:iplus index (il:idifference end start))) (when (il:igreaterp index length) (il:setq index (il:idifference index length)) (il:setq start nil) (il:setq end nil) (go il:$$iterate))) (il:|replace| \\z il:|of| context il:|with| index) (il:|replace| \\t il:|of| context il:|with| subnodes) (return))) il:|finally| (il:|replace| \\x il:|of| context il:|with| nil) (il:|replace| \\y il:|of| context il:|with| nil) (il:|replace| \\z il:|of| context il:|with| nil) (il:|replace| \\t il:|of| context il:|with| nil)))) (parse--comment (il:lambda (structure context) (il:* il:\; "Edited 27-Apr-88 11:12 by woz") (il:* il:|;;;| "try to parse this list as a common lisp comment. the second element should be one or more semicolons, and the rest of the list should be a string") (let (comment-words (level (and (cdr structure) (il:listget comment-level-table (cadr structure))))) (when (and level (cddr structure) (null (cdddr structure)) (il:stringp (caddr structure)) (or (null (il:|fetch| current-node il:|of| context)) (il:fmemb (il:|fetch| name il:|of| (il:|fetch| node-type il:|of| (il:|fetch| current-node il:|of| context))) (quote (form clisp lambda list))))) (build-node structure context type-comment t) (cond ((not (il:|fetch| \\x il:|of| context)) (il:* il:|;;| "if we're here for the first time then parse afresh.") (il:setq comment-words (parse-string-into-words (caddr structure))) (il:|for| word il:|in| comment-words il:|do| (parse word context (il:function parse--comment-word))) (il:|replace| unassigned il:|of| (il:|fetch| current-node il:|of| context) il:|with| level)) ((and nil (not (verify-comment (il:|fetch| current-node il:|of| context)))) (il:* il:|;;| "the comment changed from underneath us. trash the subnodes and reparse.") (il:* il:|;;| "couldn't get this to work. not absolutely at this point, so leave the case out.")) (t (il:* il:|;;| "flag that everything matched.") (il:|replace| \\x il:|of| context il:|with| nil))) t))) ) (parse--comment-word (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:* il:|;;;| "parse a comment word. different from string in that it does not use PRIN2 (does not print quotes round itself) and it uses a different font.") (build-prelinearized-node structure context type-comment-word structure nil (il:fetch comment-font il:of (il:fetch environment il:of context)))) ) (parse-string-into-words (il:lambda (chars) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:bind (end il:_ (il:nchars chars)) ok? result i il:first (il:setq i end) il:while (il:neq i 0) il:do (cond ((il:neq (il:nthcharcode chars i) (il:charcode il:sp)) (il:setq ok? t)) (ok? (il:setq result (cons (il:substring chars (il:add1 i) end) result)) (il:setq end i) (il:setq ok? nil))) (il:setq i (il:sub1 i)) il:finally (return (and (il:neq end 0) (cons (il:substring chars 1 end) result))))) ) (select-segment-comment (il:lambda (selection context node subnode index sub-offset sub-item) (il:* il:\; "Edited 17-Nov-87 11:54 by DCB") (il:* il:|;;;| "the SelectSegment method for comments") (let ((start (il:fetch select-start il:of selection)) new) (when (and start subnode) (il:setq new (il:iplus (comment-length node (il:sub1 (il:fetch sub-node-index il:of subnode))) (simple-string-scan sub-item sub-offset))) (il:replace select-end il:of selection il:with (il:imax new (or (il:fetch select-end il:of selection) start))) (when (il:ilessp new start) (il:replace select-start il:of selection il:with new)) (compute-selection-position-comment selection context)))) ) (set-point-comment (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 11-Apr-88 16:46 by woz") (il:* il:|;;;| "the SetPoint method for comments") (cond ((null index) (setq index (and offset (il:nchars (caddr (il:|fetch| structure il:|of| node)))))) (t (setq item (il:nth (il:|fetch| linear-form il:|of| node) (il:add1 index))) (cond ((il:listp item) (if (il:|type?| weak-link (car item)) (setq item (il:|fetch| destination il:|of| (car item))) (setq item (il:|fetch| destination il:|of| (cadr item)))) (setq index (comment-length node (il:sub1 (il:|fetch| sub-node-index il:|of| item))))) (t (setq index 0))))) (cond (index (il:|replace| point-node il:|of| point il:|with| node) (il:|replace| point-index il:|of| point il:|with| index) (il:|replace| point-type il:|of| point il:|with| (quote string)) (when compute-location? (compute-point-position-comment point context))) (t (set-point-nowhere point)))) ) (set-point-comment-word (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:replace point-node il:of point il:with (il:fetch super-node il:of node)) (il:replace point-index il:of point il:with (il:iplus (comment-length (il:fetch super-node il:of node) (il:sub1 (il:fetch sub-node-index il:of node))) (simple-string-scan (car (il:fetch linear-form il:of node)) offset t))) (il:replace point-type il:of point il:with (quote string)) (when compute-location? (compute-point-position-comment point context))) ) (set-selection-comment (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 17-Nov-87 11:54 by DCB") (il:* il:|;;;| "the SetSelection method for comments") (if (il:type? string-item item) (set-selection-me selection context node) (set-selection-nowhere selection))) ) (set-selection-comment-word (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:replace select-node il:of selection il:with (il:fetch super-node il:of node)) (il:replace select-start il:of selection il:with (il:iplus (comment-length (il:fetch super-node il:of node) (il:sub1 (il:fetch sub-node-index il:of node))) (simple-string-scan (car (il:fetch linear-form il:of node)) offset))) (il:replace select-end il:of selection il:with nil) (il:replace select-type il:of selection il:with (quote string)) (compute-selection-position-comment selection context)) ) (simple-string-offset (il:lambda (stringitem index) (il:* il:\; "Edited 17-Nov-87 11:54 by DCB") (il:* il:|;;;| "compute the width of the first index characters in this stringitem. PRIN2? is assumed to be false!") (il:* il:|;;| "(bind (font _ (fetch Font of stringitem)) (string _ (fetch String of stringitem)) for i from 1 to index sum (CHARWIDTH (NTHCHARCODE string i) font))") (if (il:igreaterp index 0) (stringwidth (il:substring (il:fetch string il:of stringitem) 1 index) (il:fetch font il:of stringitem)) 0)) ) (simple-string-scan (il:lambda (stringitem offset point?) (il:* il:\; "Edited 7-Jul-87 11:13 by DCB") (il:bind (string il:_ (il:fetch string il:of stringitem)) (font il:_ (il:fetch font il:of stringitem)) (index il:_ 0) length cwidth il:first (il:setq length (il:nchars string)) il:while (il:ileq (il:setq index (il:add1 index)) length) il:do (il:setq cwidth (il:nthcharcode string index)) (il:setq cwidth (if (il:ilessp cwidth 32) (il:iplus (il:charwidth (il:charcode il:^) font) (il:charwidth (il:iplus 64 cwidth) font)) (il:charwidth cwidth font))) (if point? (when (il:ileq offset (il:half cwidth)) (return (il:sub1 index))) (when (il:ileq offset cwidth) (return index))) (il:setq offset (il:idifference offset cwidth)) il:finally (return (il:sub1 index)))) ) (start-comment (il:lambda (context charcode) (il:* il:\; "Edited 24-Nov-87 10:22 by DCB") (let* ((caret-point (il:fetch caret-point il:of context)) (point-node (il:fetch point-node il:of caret-point)) (point-type (il:fetch point-type il:of caret-point)) new-node) (cond ((null point-node) nil) ((eq point-type (quote string)) (when (and (il:type? edit-node point-node) (eq (il:fetch node-type il:of point-node) type-comment) (eq 0 (il:fetch point-index il:of caret-point))) (upgrade-comment context point-node) t)) ((eq point-type (quote esc-atom)) nil) (t (when (il:type? edit-selection point-node) (il:setq point-node (if (il:fetch select-start il:of point-node) (il:fetch select-node il:of point-node) (il:fetch super-node il:of (il:fetch select-node il:of point-node))))) (cond ((eq (il:fetch node-type il:of point-node) type-quote) t) (t (insert caret-point context (list (il:setq new-node (create-new-comment context)))) (when (not (dead-node? new-node)) (il:replace point-node il:of caret-point il:with new-node) (il:replace point-index il:of caret-point il:with 0) (il:replace point-type il:of caret-point il:with (quote string)) (set-selection-nowhere (il:fetch selection il:of context))) t)))))) ) (stringify-comment (il:lambda (node environment) (il:* il:\; "Edited 23-Feb-88 11:18 by raf") (let ((level (il:|fetch| unassigned il:|of| node))) (ecase level ((0 1 2 3 4) (il:concat (cadr (il:|fetch| structure il:|of| node)) " " (caddr (il:|fetch| structure il:|of| node)))) (5 (il:concat (il:|fetch| (string-item string) il:|of| (il:listget (il:|fetch| comment-string il:|of| environment) 5)) (caddr (il:|fetch| structure il:|of| node)) (il:|fetch| (string-item string) il:|of| (il:listget (il:|fetch| comment-string il:|of| environment) 6))))))) ) (create-comment-word-node (il:lambda (chars environment) (il:* il:\; "Edited 13-Apr-88 14:51 by woz") (create-simple-node chars environment type-comment-word chars nil (il:|fetch| comment-font il:|of| environment)))) (create-comment-word-nodes (il:lambda (chars subnodes environment) (il:* il:\; "Edited 7-Jul-87 11:13 by DCB") (il:|bind| (end il:_ (il:nchars chars)) i ok? il:|first| (il:setq i end) il:|while| (il:neq i 0) il:|do| (cond ((il:neq (il:nthcharcode chars i) (il:charcode il:sp)) (il:setq ok? t)) (ok? (push (create-comment-word-node (il:substring chars (il:add1 i) end) environment) subnodes) (il:setq end i) (il:setq ok? nil))) (il:setq i (il:sub1 i)) il:|finally| (return (cons (create-comment-word-node (il:substring chars 1 end) environment) subnodes))))) (undo-comment-change (il:lambda (context node old-value) (il:* il:\; "Edited 13-Apr-88 15:31 by woz") (undo-by undo-comment-change node (caddr (il:fetch structure il:of node))) (let ((comment-words (parse-string-into-words old-value)) (subnodes (il:|fetch| sub-nodes il:|of| node))) (rplaca (cddr (il:|fetch| structure il:|of| node)) old-value) (il:|for| word il:|in| comment-words il:|as| sub-node-index il:|from| 1 il:|do| (cond ((cdr subnodes) (il:|replace| structure il:|of| (cadr subnodes) il:|with| word) (note-change-in-simple (cadr subnodes) context)) (t (il:nconc1 subnodes (create-simple-node word (il:|fetch| environment il:|of| context) type-comment-word word nil (il:|fetch| comment-font il:|of| (il:|fetch| environment il:|of| context)))) (il:|replace| super-node il:|of| (cadr subnodes) il:|with| node) (il:|replace| sub-node-index il:|of| (cadr subnodes) il:|with| sub-node-index))) (il:setq subnodes (cdr subnodes)) il:|finally| (il:* il:\;  "throw away extra subnodes") (rplacd subnodes) (rplaca (il:|fetch| sub-nodes il:|of| node) (il:flength comment-words))) (note-change node context)))) (upgrade-comment (il:lambda (context node) (il:* il:\; "Edited 7-Jul-87 11:13 by DCB") (when (il:ilessp (il:fetch unassigned il:of node) (il:constant (il:length comment-markers))) (rplaca (cdr (il:fetch structure il:of node)) (car (il:nth comment-markers (il:add (il:fetch unassigned il:of node) 1)))) (note-change node context) (when (il:fetch super-node il:of (il:fetch super-node il:of node)) (il:* il:\; "this node has a supernode that is not the root") (note-change (il:fetch super-node il:of node) context)) (undo-by degrade-comment node))) ) ) (DEFUN MAKE-COMMENT-STRING (NODE) (IL:* IL:|;;;| "get the comment words from the subnodes and put them together into one string (as efficiently as possible)") (LET* ((SUBNODES (CDR (IL:|fetch| SUB-NODES IL:|of| NODE))) (LENGTH (LET ((SUM 0)) (DOLIST (SUBNODE SUBNODES SUM) (INCF SUM (LENGTH (IL:|fetch| STRUCTURE IL:|of| SUBNODE)))))) (STRING (MAKE-STRING LENGTH)) (POINTER 0)) (DOLIST (SUBNODE SUBNODES STRING) (LET ((WORD (IL:|fetch| STRUCTURE IL:|of| SUBNODE))) (REPLACE STRING WORD :START1 POINTER) (INCF POINTER (LENGTH WORD)))))) (DEFUN VERIFY-COMMENT (NODE) (IL:* IL:|;;;| "check the comment in this node the strings in the subnodes (ie verify-comment). return T if they match, NIL otherwise.") (LET* ((POINTER 0) (STRING (THIRD (IL:FETCH STRUCTURE IL:OF NODE))) (STRING-LENGTH (LENGTH STRING))) (DOLIST (SUBNODE (CDR (IL:|fetch| SUB-NODES IL:|of| NODE)) T) (LET* ((WORD (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (WORD-LENGTH (LENGTH WORD))) (WHEN (MISMATCH STRING WORD :START1 POINTER :END1 (MIN (INCF POINTER (LENGTH WORD)) STRING-LENGTH)) (RETURN NIL)))))) (IL:PUTPROPS IL:SEDIT-COMMENTS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3870 40862 (BACKSPACE-COMMENT 3883 . 5036) (CFV-COMMENT 5038 . 5911) ( CLOSE-NODE-COMMENT 5913 . 6304) (COMMENT-LENGTH 6306 . 6669) (COMPUTE-COMMENT-COLUMN 6671 . 7187) ( COMPUTE-POINT-POSITION-COMMENT 7189 . 8062) (COMPUTE-SELECTION-POSITION-COMMENT 8064 . 9159) ( COPY-SELECTION-COMMENT 9161 . 10868) (COPY-STRUCTURE-COMMENT 10870 . 11376) ( COPY-STRUCTURE-COMMENT-WORD 11378 . 12293) (CREATE-NEW-COMMENT 12295 . 13026) (DEGRADE-COMMENT 13028 . 13488) (DELETE-COMMENT 13490 . 17882) (INITIALIZE-COMMENTS 17884 . 19152) (INSERT-COMMENT 19154 . 20143) (SPLIT-COMMENT 20145 . 20941) (INSERT-COMMENT-CHARS 20943 . 24376) (LINEARIZE-COMMENT 24378 . 25425) (MAP-COMMENT-INDEX 25427 . 27725) (PARSE--COMMENT 27727 . 29172) (PARSE--COMMENT-WORD 29174 . 29581) (PARSE-STRING-INTO-WORDS 29583 . 30076) (SELECT-SEGMENT-COMMENT 30078 . 30753) ( SET-POINT-COMMENT 30755 . 31708) (SET-POINT-COMMENT-WORD 31710 . 32289) (SET-SELECTION-COMMENT 32291 . 32588) (SET-SELECTION-COMMENT-WORD 32590 . 33207) (SIMPLE-STRING-OFFSET 33209 . 33732) ( SIMPLE-STRING-SCAN 33734 . 34502) (START-COMMENT 34504 . 35715) (STRINGIFY-COMMENT 35717 . 36271) ( CREATE-COMMENT-WORD-NODE 36273 . 36608) (CREATE-COMMENT-WORD-NODES 36610 . 37756) (UNDO-COMMENT-CHANGE 37758 . 40305) (UPGRADE-COMMENT 40307 . 40860))))) IL:STOP