-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathCL-TTYEDIT
91 lines (76 loc) · 4.43 KB
/
CL-TTYEDIT
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
(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