(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:11:54" IL:|{DSK}local>lde>lispcore>sources>SEDIT-TERMINAL.;2| 6716 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-TERMINALCOMS) IL:|previous| IL:|date:| "17-Nov-87 16:16:24" IL:|{DSK}local>lde>lispcore>sources>SEDIT-TERMINAL.;1|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-TERMINALCOMS) (IL:RPAQQ IL:SEDIT-TERMINALCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-TERMINAL) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-TERMINAL) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:BITMAPS STRUCTURE-CARET-BITMAP ATOM-CARET-BITMAP) (IL:VARS (STRUCTURE-CARET (IL:CURSORCREATE STRUCTURE-CARET-BITMAP 3 4)) (ATOM-CARET (IL:CURSORCREATE ATOM-CARET-BITMAP 3 4))) (IL:FNS ATOM-CHAR-ESCAPED CHARCODE GETKEY PRINT-STRING SHIFT-STRING STRINGWIDTH TTYEXITFN) )) (IL:PUTPROPS IL:SEDIT-TERMINAL IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-TERMINAL 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:RPAQQ STRUCTURE-CARET-BITMAP #*(7 6)A@@@CH@@CH@@GL@@GL@@ON@@) (IL:RPAQQ ATOM-CARET-BITMAP #*(7 6)A@@@CH@@CH@@FL@@FL@@LF@@) (IL:RPAQ STRUCTURE-CARET (IL:CURSORCREATE STRUCTURE-CARET-BITMAP 3 4)) (IL:RPAQ ATOM-CARET (IL:CURSORCREATE ATOM-CARET-BITMAP 3 4)) (IL:DEFINEQ (atom-char-escaped (il:lambda (char read-table) (il:* il:\; "Edited 16-Jul-87 15:28 by DCB") (il:* il:|;;;| "teset if this char must be escaped in an atom. read.table now defaults to *READTABLE* for profiles.") (or read-table (il:setq read-table *readtable*)) (or (and (il:igeq char (il:charcode \a)) (il:ileq char (il:charcode \z)) (il:fetch (readtablep il:caseinsensitive) il:of read-table)) (il:fetch (il:readcode il:innerescquote) il:of (il:\\syncode (il:fetch il:readsa il:of read-table) char)))) ) (charcode (il:lambda (char) (il:* il:\; "Edited 7-Jul-87 12:57 by DCB") (or (il:smallp char) (funcall (il:function il:charcode) char))) ) (getkey (il:lambda (context) (il:* il:\; "Edited 17-Nov-87 11:28 by DCB") (declare (il:globalvars il:\\linebuf.ofd)) (cond ((and (il:this.process) (il:fetch il:proctypeahead il:of (il:this.process))) (il:pop (il:fetch il:proctypeahead il:of (il:this.process)))) (t (il:bind il:c (point il:_ (il:fetch caret-point il:of context)) (window il:_ (il:windowprop (il:fetch display-window il:of context) (quote il:dsp))) il:do (il:wait.for.tty) (when (il:setq il:c (il:\\getsysbuf)) (return il:c)) (when (eq (il:fetch il:keyboardstream il:of il:\\linebuf.ofd) il:\\keyboard.stream) (il:* il:|;;| "now call the TTYBACKGROUND stuff explicitly, so can call CARET.FLASH? directly") (when (and (or (not selection-pending?) (and pending-shift (il:neq pending-shift (quote delete)))) (il:type? edit-node (il:fetch point-node il:of point))) (il:\\caret.flash? window (il:fetch caret il:of context) nil nil (il:fetch point-x il:of point) (il:fetch base-line-y il:of (il:fetch point-line il:of point)))) (il:\\savevmbackground)) (il:\\background))))) ) (print-string (il:lambda (str window prin-2?) (il:* il:\; "Edited 7-Jul-87 12:57 by DCB") (il:* il:|;;;| "immitate PRIN2 with respect to *readtable* if print2?. otherwise just prin1, except control chars, which are always printed as ^") (il:|bind| (stream il:_ (il:|fetch| (il:window il:dsp) il:|of| window)) (esc-char il:_ (escape-char)) display-data il:|for| c il:|instring| str il:|first| (il:setq display-data (il:\\getdisplaydata stream)) (and prin-2? (il:\\bltchar (il:charcode il:\") stream display-data)) il:|do| (cond ((and prin-2? (or (eq c (il:charcode il:\")) (eq c esc-char))) (il:* il:|;;| "immitate prin2 of double quotes and escape char") (il:\\bltchar esc-char stream display-data)) ((il:ilessp c (il:charcode il:space)) (il:* il:|;;| "echo control chars as ^ followed by capital letter") (il:setq c (il:iplus c 64)) (il:\\bltchar (il:charcode il:^) stream display-data))) (il:\\bltchar c stream display-data) il:|finally| (and prin-2? (il:\\bltchar (il:charcode il:\") stream display-data)))) ) (shift-string (il:lambda (string from to length) (il:* il:\; "Edited 17-Jul-87 10:08 by DCB") (il:* il:|;;;| "ugly hack. shift the characters in a fat string left or right. move length characters, from from to to. if we're shifting right, we can use \\BLT, but otherwise have to move them ourselves (in the opposite order)") (il:setq string (il:\\addbase (il:fetch (il:stringp il:base) il:of string) (il:fetch (il:stringp il:offst) il:of string))) (il:setq from (il:sub1 from)) (il:setq to (il:sub1 to)) (cond ((il:ilessp from to) (il:\\blt (il:\\addbase string to) (il:\\addbase string from) length) nil) ((il:igreaterp from to) (il:to length il:do (il:\\putbase string to (il:\\getbase string from)) (il:setq from (il:add1 from)) (il:setq to (il:add1 to)))))) ) (stringwidth (il:lambda (str font prin-2? read-table) (il:* il:\; "Edited 17-Nov-87 09:25 by DCB") (il:* il:|;;;| "can take a readtable, but sedit under profile doesn't pass in readtable. will cause *readtable* to be used properly.") (if (il:stringp str) (il:for c il:instring (il:mkstring str) il:bind (length il:_ (if prin-2? (il:itimes 2 (il:charwidth (il:charcode il:\") font)) 0)) (escape il:_ (and prin-2? (escape-char read-table))) il:do (cond ((and prin-2? (or (eq c (il:charcode il:\")) (eq c escape))) (il:add length (il:charwidth escape font))) ((il:ilessp c (il:charcode il:space)) (il:add length (il:charwidth (il:charcode il:^) font)) (il:setq c (il:iplus c 64)))) (il:add length (il:charwidth c font)) il:finally (return length)) (il:stringwidth str font prin-2? read-table))) ) (ttyexitfn (il:lambda (oldproc newproc) (il:* il:\; "Edited 7-Jul-87 12:57 by DCB") (il:* il:\; "the TTY is being taken from an SEdit command process. restore the old caret") (and (il:setq newproc (il:processprop oldproc (quote il:window))) (il:setq newproc (il:windowprop newproc (quote edit-context))) (il:fetch open-node-changed? il:of newproc) (il:process.eval oldproc (list (quote close-node) newproc)))) ) ) (IL:PUTPROPS IL:SEDIT-TERMINAL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (1871 6597 (ATOM-CHAR-ESCAPED 1884 . 2392) (CHARCODE 2394 . 2536) (GETKEY 2538 . 3578 ) (PRINT-STRING 3580 . 4604) (SHIFT-STRING 4606 . 5376) (STRINGWIDTH 5378 . 6176) (TTYEXITFN 6178 . 6595))))) IL:STOP