(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(filecreated "19-Apr-88 12:01:09" {erinyes}<lispusers>medley>cl-ttyedit.\;2
 4515   

      |changes| |to:|  (vars cl-ttyeditcoms)
                       (usermacros ||)

      |previous| |date:| "29-Oct-87 11:59:24" {erinyes}<lispusers>medley>cl-ttyedit.\;1)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(prettycomprint cl-ttyeditcoms)

(rpaqq cl-ttyeditcoms
 ((vars (**comment**flg ";..")
                                 (editrdtbl nil)
                                 (dummy nil))
                           (p (setq postgreetforms (remove (find x in postgreetforms suchthat
                                                                 (and (eq (car x)
                                                                          'and)
                                                                      (eq (cadr x)
                                                                          'editcharacters)))
                                                          postgreetforms)))
                           (variables edit-atoms)
                           (functions subpat)
                           (p (unadvise editfpat \\editblock/editcoma \\editblock/editcoml editl)
                              (* "This is because EDITCOMA attempts to rebind RDTBL to EDITRDTBL on PP -- a useless thing, but PP will error if *READTABLE* is NIL"
                                 )
                              (changename '\\editblock/editcoma '*readtable* 'dummy))
                           (advise editl editfpat \\editblock/editcoma \\editblock/editcoml)
                           (usermacros ||)))

(rpaq **comment**flg
 ";..")

(rpaqq editrdtbl
 nil)

(rpaqq dummy
 nil)
(setq postgreetforms (remove (find x in postgreetforms suchthat (and (eq (car x)
                                                                         'and)
                                                                     (eq (cadr x)
                                                                         'editcharacters)))
                            postgreetforms))

(cl:defparameter edit-atoms
 '(("--" . --)
                                  ("&" . &)
                                  ("*ANY*" . *any*)
                                  ("---" . |..|)
                                  ("==" . ==)) )


(cl:defun subpat
 (x) (|if|
 (litatom x)
                             |then|
 (|for|
 p |in|
 edit-atoms
                                           |when|
 (strequal (car p)
                                                             x) |do|
 (return (cdr p))
                                           |finally|
 (return x))
                           |else|
 x))

(unadvise editfpat \\editblock/editcoma \\editblock/editcoml editl)
(* "This is because EDITCOMA attempts to rebind RDTBL to EDITRDTBL on PP -- a useless thing, but PP will error if *READTABLE* is NIL"
   )
(changename '\\editblock/editcoma '*readtable* 'dummy)
(xcl:reinstall-advice 'editl :around
       '((:last (let ((*readtable* *readtable*)
                      (name (readtableprop *readtable* 'name)))
                     (if (or (null name)
                             (strpos "EDIT-" name))
                         then
                         (setq editrdtbl *readtable*)
                         else
                         (or (find-readtable (setq name (concat "EDIT-" name)))
                             (progn (setq editrdtbl (copyreadtable *readtable*))
                                    (readtableprop editrdtbl 'name name)
                                    (apply 'settermchars editcharacters)))
                         (setq *readtable* editrdtbl))
                     *))))
(xcl:reinstall-advice 'editfpat :before '((:last (setq pat (subpat pat)))))
(xcl:reinstall-advice '\\editblock/editcoma :before '((:last (setq c (mkatom (u-case (mkstring c)))))
                                                      ))
(xcl:reinstall-advice '\\editblock/editcoml :before
       '((:last (and (litatom (car c))
                     (rplaca c (mkatom (u-case (mkstring (car c)))))))))
(readvise editl editfpat \\editblock/editcoma \\editblock/editcoml)

(addtovar usermacros
 (|| (a . b)
                             up
                             (1 a . b)))

(addtovar editcomsl
 ||)
(putprops cl-ttyedit copyright ("Xerox Corporation" 1987 1988))
(declare\: dontcopy
  (filemap (nil)))
stop