-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathEXAMINEDEFS
286 lines (251 loc) · 16.6 KB
/
EXAMINEDEFS
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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 6-Apr-2025 23:54:50" {WMEDLEY}<lispusers>EXAMINEDEFS.;57 16827
:EDIT-BY rmk
:CHANGES-TO (FNS TEDITDEF)
:PREVIOUS-DATE "31-Mar-2025 13:53:38" {WMEDLEY}<lispusers>EXAMINEDEFS.;56)
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEFILES TEDITDEF EXVV)
(COMMANDS exv)
(INITVARS (EXAMINEDEFS-PROCESS-LIST)
(EXAMINEWITH 'COMPARETEXT))
(FILES (SYSLOAD)
COMPARETEXT VERSIONDEFS)))
(DEFINEQ
(EXAMINEDEFS
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 31-Mar-2025 13:53 by rmk")
(* ; "Edited 18-Feb-2025 22:56 by rmk")
(* ; "Edited 6-Dec-2024 20:51 by rmk")
(* ; "Edited 13-Oct-2023 11:11 by rmk")
(* ; "Edited 18-May-2023 22:35 by rmk")
(* ; "Edited 21-Apr-2023 14:42 by rmk")
(* ;; "This provides for side-by-side examination of separate but presumably related expressions. The (LISTP) expressions can be provided directly as the definitions SOURCE1 and SOURCE2 or, if NAME is given, the copies of the definitions of NAME as TYPE on the two sources are examined. If both SOURCE1 and SOURCE2 are NIL, then SOURCE1 is the existing file defintion, NIL is the existing in-memory definition")
(* ;; "")
(if NAME
then (CL:UNLESS [OR SOURCE1 SOURCE2 (SETQ SOURCE2 (CAR (WHEREIS NAME
(OR TYPE '(FNS FUNCTIONS))
T]
(ERROR (CONCAT "Can't find " NAME " definitions to examine")))
else (CL:UNLESS (LISTP SOURCE1)
(ERROR SOURCE1 " cannot be examined"))
(CL:UNLESS (LISTP SOURCE2)
(ERROR SOURCE2 " cannot be examined")))
(* ;; "TITLE1 and TITLE2 are optional strings that will be used to construct the titles of the SEDIT windows. We would like to know where GETDEF got the definition so we can use that, but there isn't an interface that provides that information (extended WHEREIS?)")
(* ;; "")
(* ;; "If SOURCE1 and SOURCE2 are both NIL, SOURCE1 defaults to the current (in memory) definition, SOURCE2 defaults to the definition on the current file.")
(LET (DEF1 DEF2)
(if (SETQ DEF1 (LISTP SOURCE1))
elseif TYPE
then (NEQ (SETQ DEF1 (GETDEF NAME TYPE SOURCE1 'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
elseif (NEQ (SETQ DEF1 (GETDEF NAME (SETQ TYPE 'FNS)
SOURCE1
'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
elseif (NEQ (SETQ DEF1 (GETDEF NAME (SETQ TYPE 'FUNCTIONS)
SOURCE1
'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
else (ERROR NAME (CONCAT "not found on " SOURCE1)))
(if (SETQ DEF2 (LISTP SOURCE2))
elseif (NEQ (SETQ DEF2 (GETDEF NAME TYPE SOURCE2 'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
else (ERROR NAME (CONCAT "not found on " SOURCE2)))
(CL:UNLESS TITLE1
(SETQ TITLE1 (OR (AND (OR (LISTP SOURCE1)
(NULL SOURCE1))
'Current)
(AND (MEMB (U-CASE SOURCE1)
'(PROP SAVED))
'Saved)
(FINDFILE SOURCE1)
SOURCE1)))
(CL:UNLESS TITLE2
(SETQ TITLE2 (OR (AND (OR (LISTP SOURCE2)
(NULL SOURCE2))
'Current)
(AND (MEMB (U-CASE SOURCE2)
'(PROP SAVED))
'Saved)
(FINDFILE SOURCE2)
SOURCE2)))
(SELECTQ (EDITMODE)
(SEDIT:SEDIT
(* ;;
"A kludge to eliminate dangling SEDIT processes from previous examinations")
[SETQ EXAMINEDEFS-PROCESS-LIST
(FOR PAIR IN EXAMINEDEFS-PROCESS-LIST
COLLECT (IF (OPENWP (CAR PAIR))
THEN PAIR
ELSE (DEL.PROCESS (CDR PAIR))
(GO $$ITERATE]
(* ;; "Set it up for new side-by-side regions that are forgotten when the window is closed. Their shape is usually not that useful for regular edits.")
(* ;;
"Crude suggestions for height, width, position. Suggest shorter window for smaller structures")
(SELECTQ EXAMINEWITH
(SEDIT (SETQ DEF1 (COPY DEF1)) (* ; "Copy to simulate read-only")
(SETQ DEF2 (COPY DEF2))
(CL:UNLESS (REGIONP REGION)
(SETQ REGION (GETREGION)))
[LET (R1 R2 HALFWIDTH W1 W2)
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH)
OF REGION)
2))
(SETQ R1 (CREATE REGION USING REGION WIDTH _ HALFWIDTH))
(SETQ R2 (CREATE REGION USING REGION LEFT _
(IPLUS (FETCH (REGION LEFT)
OF REGION)
HALFWIDTH)
WIDTH _ HALFWIDTH))
[SETQ W1
(SEDIT:GET-WINDOW (SEDIT:SEDIT
DEF1
`(:NAME ,(CONCAT NAME " from " TITLE1)
:REGION
,(CREATE REGION
USING REGION WIDTH _
HALFWIDTH)
R1 :DONT-KEEP-WINDOW-REGION T]
[SETQ W2
(SEDIT:GET-WINDOW (SEDIT:SEDIT
DEF2
`(:NAME ,(CONCAT NAME " from " TITLE2)
:REGION
,R2 :DONT-KEEP-WINDOW-REGION T]
(ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
(MODERNWINDOW W2)
(* ;;
"So we can kill the processes on the next call, if they still exist after the windows are closed.")
(PUSH EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP
W1
'PROCESS))
(CONS W2 (WINDOWPROP W2 'PROCESS])
(COMPARETEXT [LET (COMPARETEXT.ALLCHUNKS
CTWINDOW
(KEY (LIST NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2))
(TEXTWIDTH (ITIMES TEDIT.SOURCE.LINELENGTH
(CHARWIDTH (CHARCODE SPACE)
DEFAULTFONT)))
(TEXTHEIGHT 600))
(DECLARE (SPECVARS COMPARETEXT.ALLCHUNKS))
(* ;
"Reuse an existing CT graph window for this DEF")
(OR [FIND W IN (OPENWINDOWS)
SUCHTHAT (EQUAL KEY (WINDOWPROP W
'EXAMINEDEFS]
(PROG1 (SETQ CTWINDOW
(COMPARETEXT (TEDITDEF NAME DEF1 TYPE NIL
TEXTWIDTH)
(TEDITDEF NAME DEF2 TYPE NIL
TEXTWIDTH)
'LINE
(OR REGION (GETPOSITION))
(LIST TITLE1 TITLE2)
(CONCAT "Compare sources of " NAME
" as " TYPE)
TEXTWIDTH TEXTHEIGHT))
(WINDOWPROP CTWINDOW 'EXAMINEDEFS KEY))])
(SHOULDNT)))
(PROGN (EDITE DEF1)
(EDITE DEF2])
(EXAMINEFILES
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 19-Jul-2023 13:48 by rmk")
(* ; "Edited 1-Feb-2022 23:15 by rmk")
(* ; "Edited 25-Jan-2022 10:08 by rmk")
(* ; "Edited 2-Jan-2022 23:15 by rmk")
(* ; "Edited 30-Dec-2021 21:49 by rmk")
(* ;; "We get a region, then split it in half. ")
(CL:UNLESS REGION
(SETQ REGION (GETREGION)))
(LIST (AND (INFILEP FILE1)
(TEDIT-SEE FILE1 (RELCREATEREGION `(,REGION 0.5 -1)
REGION
'RIGHT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE1))
(AND (INFILEP FILE2)
(TEDIT-SEE FILE2 (RELCREATEREGION `(,REGION 0.5 1)
REGION
'LEFT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE2])
(TEDITDEF
[LAMBDA (NAME DEF TYPE READERENVIRONMENT WIDTH) (* ; "Edited 6-Apr-2025 23:53 by rmk")
(* ; "Edited 13-Oct-2023 00:23 by rmk")
(* ; "Edited 23-Jun-2022 17:27 by rmk")
(* ; "Edited 28-Jan-2022 23:36 by rmk")
(* ; "Edited 12-Jan-2022 17:27 by rmk")
(LET [(TSTREAM (OPENTEXTSTREAM NIL NIL `(BOUNDTABLE ,(TEDIT.ATOMBOUND.READTABLE]
(DSPFONT DEFAULTFONT TSTREAM)
(CL:WHEN WIDTH
(LINELENGTH (IQUOTIENT WIDTH (CHARWIDTH (CHARCODE SPACE)
TSTREAM))
TSTREAM))
(SELECTQ (CAR DEF)
([LAMBDA NLAMBDA OPENLAMBDA]
(PRINTOUT TSTREAM .FONT BOLDFONT .P2 NAME T .FONT DEFAULTFONT 2)
(PRINTDEF DEF 2 T NIL NIL TSTREAM))
(DEFINEQ (SETQ DEF (CADR DEF))
(PRINTOUT TSTREAM .FONT BOLDFONT .P2 NAME T .FONT DEFAULTFONT 2)
(PRINTDEF (CADR DEF)
2 T NIL NIL TSTREAM))
((DEFMACRO DEFUN DEFMACRO CL:DEFUN) (* ; "Has args after name")
(PRINTOUT TSTREAM "(" .P2 (CAR DEF)
" " .FONT BOLDFONT .P2 (CADR DEF)
.FONT DEFAULTFONT " " .P2 (CADDR DEF)
T)
(PRINTDEF (CDDDR DEF)
3 T T NIL TSTREAM)
(PRIN3 ")" TSTREAM))
(IF (EQ NAME (CADR DEF))
THEN
(* ;; "Like RPAQQ, bold the name")
[PRINTOUT TSTREAM "(" .P2 (CAR DEF)
" " .FONT BOLDFONT .P2 (CADR DEF)
.FONT DEFAULTFONT T .TAB (IPLUS 2 (NCHARS (CAR DEF]
(PRINTDEF (CDDR DEF)
(IPLUS 2 (NCHARS (CAR DEF)))
T T NIL TSTREAM)
(PRIN3 ")" TSTREAM)
ELSE (PRINTDEF DEF 3 NIL NIL NIL TSTREAM)))
TSTREAM])
(EXVV
[LAMBDA (NAME TYPE FILE VERSION1 VERSION2) (* ; "Edited 20-Jan-2025 21:56 by rmk")
(* ; "Edited 12-Dec-2024 15:09 by rmk")
(* ;; "Compares the definitions of NAME as TYPE on 2 different versions of FILE. TYPE and FILE can be elided, defaulting to NIL and WHEREIS respectively. Versions default to newest.")
(* ;; "If only one version specification, compares with the current (like the EXV command)")
(* ;; "(EXVV 'FOO -1 -2) will compare the newest and second-newest function definitions of FOO.")
(CL:UNLESS (AND (VERSIONP VERSION1)
(VERSIONP VERSION2)) (* ; "Both versions, arguments are good")
(if (VERSIONP TYPE)
then (SETQ VERSION1 TYPE) (* ; "TYPE and FILE are NIL")
(SETQ TYPE NIL)
(CL:WHEN (VERSIONP FILE)
(SETQ VERSION2 FILE)
(SETQ FILE NIL))
elseif (VERSIONP FILE)
then (CL:WHEN (VERSIONP VERSION1) (* ; "Type is good, FILE is NIL")
(SETQ VERSION2 VERSION1))
(SETQ VERSION1 FILE)
(SETQ FILE NIL)))
(CL:UNLESS FILE
(SETQ FILE (OR (CAR (WHEREIS NAME (OR TYPE '(FNS FUNCTIONS))
T))
(ERROR "Can't find " FILE " definition of " NAME))))
(if (AND VERSION1 VERSION2)
then (EXAMINEDEFS NAME TYPE (FINDFILEVERSION FILE VERSION1)
(FINDFILEVERSION FILE VERSION2))
else (EXAMINEDEFS NAME TYPE NIL (FINDFILEVERSION FILE (OR VERSION1 VERSION2 -1])
)
(DEFCOMMAND exv (NAME TYPE FILE VERSION) (EXVV NAME TYPE FILE VERSION))
(RPAQ? EXAMINEDEFS-PROCESS-LIST )
(RPAQ? EXAMINEWITH 'COMPARETEXT)
(FILESLOAD (SYSLOAD)
COMPARETEXT VERSIONDEFS)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (662 16596 (EXAMINEDEFS 672 . 10994) (EXAMINEFILES 10996 . 12478) (TEDITDEF 12480 .
14802) (EXVV 14804 . 16594)))))
STOP