-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathTSET
622 lines (518 loc) · 18.7 KB
/
TSET
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
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
(FILECREATED " 3-JUN-79 09:49:57" <NEWLISP>TSET.;2 18693
changes to: TRANSORSET LISPXUSERFN TSETCOMS TSETFNS TRANSORSETUSERFN
previous date: " 8-Jul-76 23:22:21" <LISP>TSET.;6)
(PRETTYCOMPRINT TSETCOMS)
(RPAQQ TSETCOMS [(FNS * TSETFNS)
TSETMACROS
(VARS (LISPXMACROS (UNION TSETMACROS LISPXMACROS))|
(TESTFORM)
[LISPXCOMS (UNION LISPXCOMS (MAPCAR TSETMACROS (FUNCTION CAR]|
(MERGE)
(PRETTYDEFMACROS
(CONS [QUOTE (TRANSAVE NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS
(PROP XFORM * TRANSFORMATIONS)
(P (COND [(EQ (EVALV (QUOTE MERGE))
T)
[RPAQ TRANSFORMATIONS
(UNION TRANSFORMATIONS
(LISTP (GETP (QUOTE TRANSFORMATIONS)
(QUOTE VALUE]
(MAPC (GETP (QUOTE USERNOTES)
(QUOTE VALUE))
(FUNCTION (LAMBDA (NOTE)
(OR (ASSOC (CAR NOTE)
USERNOTES)
(SETQ USERNOTES
(CONS NOTE
USERNOTES]
(T (MAPC (GETP (QUOTE TRANSFORMATIONS)
(QUOTE VALUE))
(FUNCTION (LAMBDA
(X)
(AND (NOT (MEMB X TRANSFORMATONS)
)
(/REMPROP X (QUOTE XFORM]
PRETTYDEFMACROS))
(LCASELST (APPEND (QUOTE (DO TRANSFORMATIONS))
LCASELST)))
(PROP UCASE BBN LISP SRI MIT QA3 PLANNER UCI INTERLISP)
(PROP FILEGROUP TSET)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML TRANSUNDER)
(LAMA])
(RPAQQ TSETFNS (TRANSORSET TRANSORINPUTP TRANSORSETUSERFN RUMARK RUMARK1 TRANSUNDER TXFN TXFN1 TXDUMP
|
TXERASE TXERASE1 TXTEST TXSHOW TXEDIT TXEXIT TXNOTE GENREMNAM TXDELNOTE))
(DEFINEQ
(TRANSORSET
[LAMBDA NIL (* wt: " 2-JUN-79 18:53")
(PROG (CURRENTFN)
(COND
((NOT (BOUNDP (QUOTE TRANSFORMATIONS)))|
(RPAQ TRANSFORMATIONS NIL)|
(RPAQ USERNOTES NIL)|
(RPAQ UDRS)))
(* CURRENTFN must be bound in the outer PROG so that
errors don't change its setting to NIL.
LISPXHIST must be bound in the inner PROG so that
the initialization above will go on the history-list
with the call to TRANSORSET, not with the first
input to it. The normal return from TRANSORSET is
via a RETFROM in TRANSEXIT.
The ERSETQ returns only from a control E or error.)
OUTER
(USEREXEC (QUOTE +)|
NIL|
(QUOTE TRANSORSETUSERFN))|
(CLEARBUF T)
(GO OUTER])
(TRANSORINPUTP
[LAMBDA (A B)
(* TRANSORSET has a feature whereby any random edit
commands typed to the + sign will be accepted as
part of the transformation for CURRENTFN.
See LISPXUSERFN. TRANSORINPUTP has to decide if the
input looks like edit commands.
If so, return T. A is the first thing on the input
line, B is a list (possibly NULL) of all the other
inputs on that line.)
(PROG NIL
(* The following test for edit input is more
stringent than the DWIM test which causes LISPX to
edit the nearest reasonable thing.
Numbers, e.g., are not caught by DWIM because they
do not cause errors. However, some mistakes will not
be noticed by this test. Typing BO as if an atomic
editcommand is not legal edit input but will pass
this test if there is something else on the line.
Hopefully that will not matter much.)
(COND
((AND (NULL A)
(NULL B)) (* True only for extra
paren's and NIL's.)
(RETURN))
((EQ A (QUOTE PP))
(RETURN)))
(RETURN (OR (SMALLP A)
[AND (LITATOM A)
(OR (FMEMB A EDITCOMSA)
(AND B (FMEMB A EDITCOMSL]
(AND (LISTP A)
(OR (SMALLP (CAR A))
(AND (LITATOM (CAR A))
(FMEMB (CAR A)
EDITCOMSL])
(TRANSORSETUSERFN
[LAMBDA (A B) (* wt: " 2-JUN-79 19:06")
(PROG (INLINE)
(COND|
((NULL (TRANSORINPUTP A B))|
|
|
(* Not random editcommands, so let LISPX handle it normally. All the other TRANSORSET stuff is implemented as |
vanilla LISPXMACROS so don't have to worry about it here.)|
|
|
(RETURN)))|
(SETQ INLINE (CONS (COPY A)
(COPY B)))
(* Always copy the works, since it will be put onto
the property list and will likely be edited and
added to a lot during the next few history events
and we don't want to show this on the history list.
I.e. show input as typed in, so a REDO does what one
expects.)
(AND (LITATOM A)
(NULL (FMEMB A EDITCOMSA))
(FMEMB A EDITCOMSL)
(SETQ INLINE (LIST INLINE)))
(* Convert an input line such as
"BO 4 5 <carriage return>" to simply be
(BO 4 5).)
(COND
((NULL CURRENTFN)
(ERROR (QUOTE "You must specify a function with the 'fn' command")
(QUOTE "before transformations can be stored")
T)))
(RUMARK INLINE CURRENTFN)
(/PUT CURRENTFN (QUOTE XFORM)
(/NCONC (GETP CURRENTFN (QUOTE XFORM))
INLINE))
(LISPXSTOREVALUE LISPXHIST CURRENTFN)|
(* I want to show where these TRANSFORMATIONS went on history list in case user gets confused;
but I don't want to be printing it at him each time around the loop. The only way to avoid printing is to RETFROM
out of LISPX; but if I do that, I have to put the 'value' on the history myself.)
(RETFROM (QUOTE LISPX])
(RUMARK
[LAMBDA (XFORM FN)
(AND (LISTP XFORM)
(EDITFINDP XFORM (QUOTE (REMARK --))
T)
(EDITE (LIST XFORM)
(QUOTE ((LPQ F (REMARK --)
(E (RUMARK1)
T])
(RUMARK1
[LAMBDA NIL (* dcl: 7 Jul 76 15:57)
(PROG ((CALL (CAR L))
RNAME TEXT)
(COND
((NLISTP (CDR CALL)) (* Illegally formed;
complain.)
(PRIN1 (QUOTE "
Warning - badly formed remark: ")
T)
(PRINT CALL T T))
([AND (NULL (CDDR CALL))
(LITATOM (SETQ RNAME (CADR CALL]
(* Standard use of named
remark: (REMARK REMNAME)
)
)
([OR [LISTP (CDR (SETQ TEXT (CDR CALL]
(LISTP (SETQ TEXT (CADR CALL]
(* The user may type (REMARK RANDOM TEXT) or
(REMARK (RANDOM TEXT)). Either way, we make it into
a named remark and add star
(COMMENTFLG) if necessary.)
[/RPLACD CALL (LIST (SETQ RNAME (GENREMNAM FN]
(* FN is picked up free
from RUMARK.)
(OR (EQ (CAR TEXT)
COMMENTFLG)
(SETQ TEXT (CONS COMMENTFLG TEXT)))
(/SETATOMVAL (QUOTE USERNOTES) |
(CONS (LIST RNAME TEXT) |
USERNOTES])
(TRANSUNDER
[NLAMBDA (TSETFN FLG)
(* This function is used by the TRANSORSET commands
implemented as LISPXMACROS, to do initial checks.
Abort if not at + sign, and make sure that every
element of the input line is atomic, unless FLG=T
(for the TEST command, the only one at present which
can legally take a non-atomic arg.))
(COND
((NEQ (EVALV (QUOTE LISPXID))
(QUOTE +))
(LISPXUNREAD (QUOTE (REDO -1)))
(TRANSORSET))
(T [OR FLG (MAPC LISPXLINE (FUNCTION (LAMBDA (X)
(COND
((NOT (LITATOM X))
(ERROR (QUOTE "Arg not litatom:")
X T]
(APPLY* TSETFN LISPXLINE])
(TXFN
[LAMBDA (LIN)
(COND
((NULL LIN)
(* 'FN' followed by carriage return or NIL at + will
just print current value of CURRENTFN without
changing it.)
CURRENTFN)
(T [MAPC LIN (FUNCTION (LAMBDA (X)
(TXFN1 X T]
(CAR (LAST LIN])
(TXFN1
[LAMBDA (FN OLDMESS) (* dcl: 7 Jul 76 15:58)
(* TXFN1 is used in several ways.
TXFN uses it to reset CURRENTFN, but never to NIL.
Other function use it to reset CURRENTFN to NIL, to
their last arg, or for side effect of 'noticing' a
FN name.)
(AND CURRENTFN (NULL (GETP CURRENTFN (QUOTE XFORM)))
(/SETATOMVAL (QUOTE TRANSFORMATIONS) |
(/DREMOVE CURRENTFN TRANSFORMATIONS))) |
(* It is desirable to avoid accumulating atoms on
TRANSFORMATIONS which never got any entries.
User probably mistyped the arg to a FN command, and
should be able to just do FN again without having to
ERASE the bad entry.)
(AND OLDMESS FN (GETP FN (QUOTE XFORM))
(PRIN1 (QUOTE "You're adding to old xforms.")
T)) (* If the new CURRENTFN
already has some
TRANSFORMATIONS, alert
user.)
(AND FN (NULL (FMEMB FN TRANSFORMATIONS))
(/SETATOMVAL (QUOTE TRANSFORMATIONS) |
(CONS FN TRANSFORMATIONS))) |
(* Put FN on TRANSFORMATIONS if necessary, and
finally reset CURRENTFN. Value of TXFN1 is not
used.)
(SAVESETQ CURRENTFN FN)
NIL])
(TXDUMP
[LAMBDA (LIN) (* dcl: 8 Jul 76 23:22)
(PROG ((FILE (CAR LIN))
F)
(TXFN1)
(SORT TRANSFORMATIONS)
(SORT USERNOTES T)
[COND
(FILE (SETQ F FILE))
((NEQ (QUOTE NOBIND)
DUMPFILE)
(SETQ F DUMPFILE))
(T (PRIN1 (QUOTE "
File to dump on: ")
T)
(SETQ F (RATOM T T]
(COND
((NULL (SETQ FILE (OUTFILEP F)))
(ERROR (QUOTE "Cannot open file:")
F T)))
(/SETATOMVAL (QUOTE DUMPFILE)
F)
(SETQ F (NAMEFIELD F))
[COND
((NOT (ASSOC (QUOTE TRANSAVE)
XFORMSVARS))
(* Initialize VARS if necessary;
if some existing stuff just add TSET's command to
it, otherwise initialize to
((transave)))
(/SETATOMVAL (QUOTE XFORMSVARS)
(CONS (LIST (QUOTE TRANSAVE))
(LISTP XFORMSVARS]
(COND
((EQ XFORMSFNS (QUOTE NOBIND))
(* If we leave it nobind, PRETTYDEF won't write out
an RPAQQ and therefore when FILE is loaded it won't
clobber any possible previous settings of
xformsfns.)
(/SETATOMVAL (QUOTE XFORMSFNS)
NIL)))
(AND XFORMSFNS (NOT (MEMB (QUOTE XFORMSFNS) |
XFORMSVARS)) |
(/SETATOMVAL (QUOTE XFORMSVARS) |
(CONS (QUOTE XFORMSFNS) |
XFORMSVARS))) |
(PRETTYDEF XFORMSFNS FILE (QUOTE XFORMSVARS)) |
(RETURN FILE])
(TXERASE
[LAMBDA (LIN)
(* Forgets the TRANSFORMATIONS for functions.
Undoable. Has to remove the property entry with
REMPROP, and take them off the list TRANSFORMATIONS.
Always resets CURRENTFN to NIL.
ERASE followed by carriage return erases CURRENTFN.)
(COND
((NLISTP LIN)
(TXERASE1 CURRENTFN))
(T (TXFN1 (CAR (LAST LIN)))
(MAPCAR LIN (FUNCTION TXERASE1])
(TXERASE1
[LAMBDA (FN) (* dcl: 7 Jul 76 16:00)
(AND (FMEMB FN TRANSFORMATIONS)
(/SETATOMVAL (QUOTE TRANSFORMATIONS) |
(/DREMOVE FN TRANSFORMATIONS))) |
(COND
((GETP FN (QUOTE XFORM))
(/REMPROP FN (QUOTE XFORM))
FN)
(T (CONS FN (QUOTE (-- NOTHING FOUND.])
(TXTEST
[LAMBDA (LIN) (* dcl: 7 Jul 76 16:00)
(PROG ((TESTRAN T)
(OLDO (OUTPUT T)))
(* TESTRAN is a flag used by the listing machinery
to suppress listing for the tests made my the TEST
command.)
(COND
((LISTP (CAR LIN))
(/SETATOMVAL (QUOTE TESTFORM) |
(CAR LIN))) |
((NULL TESTFORM)
(ERROR (QUOTE "Correct format is:")
(QUOTE
"+TEST (SAMPLE S-EXPRESSION TO BE TRANSOR'ED)")
T)))
(COND
((NULL (GETD (QUOTE TRANSORFORM)))
(ERROR (QUOTE
"You must load <LISP>TRANSOR.COM before using the TEST command.")
(QUOTE "")
T)))
(RETURN (PROG1 (TRANSORFORM (COPY TESTFORM))
(OUTPUT OLDO])
(TXSHOW
[LAMBDA (LIN)
(PROG [(OLDO (OUTPUT T))
(FLG (OR (NULL LIN)
(CDR LIN]
(OR LIN (SETQ LIN (LIST CURRENTFN)))
[MAPC LIN (FUNCTION (LAMBDA (FN)
(TXFN1 FN)
(COND
(FLG
(* Print the name of each transformation being shown
if more than one being done, or if doing the
default)
(PRINT FN NIL T)))
[PRINTDEF (OR (GETP FN (QUOTE XFORM))
(QUOTE (No transformations]
(TERPRI]
(OUTPUT OLDO)
(RETURN (CAR (LAST LIN])
(TXEDIT
[LAMBDA (LIN)
(OR LIN (SETQ LIN (LIST CURRENTFN)))
[MAPC LIN (FUNCTION (LAMBDA (FN)
(TXFN1 FN)
(RUMARK (PUT FN (QUOTE XFORM)
(EDITE (OR (GETP FN (QUOTE XFORM))
(ERROR FN (QUOTE "not editable.")
T))
NIL FN))
FN]
(CAR (LAST LIN])
(TXEXIT
[LAMBDA NIL (* dcl: 7 Jul 76 16:01)
(SETATOMVAL (QUOTE USERINPUTP)) |
(RETFROM (QUOTE TRANSORSET])
(TXNOTE
[LAMBDA (LIN) (* dcl: 7 Jul 76 16:01)
(* Remark has a mandatory arg, the name of the
remark. If old, edits it; if new, demands TEXT and
enters it on USEREMARKS.)
(PROG ((NAME (CAR LIN))
TEXT)
(COND
((OR (NULL NAME)
(NULL (LITATOM NAME)))
(ERROR (QUOTE "Arg not litatom:")
NAME T))
((SETQ TEXT (CADR (FASSOC NAME USERNOTES)))
[EDITE (COND
((EQ (CADR TEXT)
(QUOTE %%)) (* Don't edit the star
and per-cent sign we put
in for him.)
(CDDR TEXT))
(T (CDR TEXT] (* Old remark;
EDIT it.)
(RETURN NAME))
((LISTP (SETQ TEXT (CDR LIN))) (* He should be able to
type either
"REMARK NAME RANDOM TEXT"
)
[COND
((AND (LISTP (CAR TEXT))
(NULL (CDR TEXT))) (* or
"REMARK NAME(RANDOM TEXT]"
)
(SETQ TEXT (CAR TEXT]
(GO CHECKTXT))
((NOT (LISPXREADP))
(PRIN1 (QUOTE "Text: ")
T)))
(SETQ TEXT (READ T T))
[COND
((NLISTP TEXT)
(SETQ TEXT (CONS TEXT (READLINE]
(* Make sure it works whether he types in a list or
a line.)
CHECKTXT
(OR (EQ (CAR TEXT)
COMMENTFLG)
(SETQ TEXT (CONS COMMENTFLG TEXT)))
(* Make sure it has a
star.)
(/SETATOMVAL (QUOTE USERNOTES) |
(CONS (LIST NAME TEXT) |
USERNOTES)) (* Enter on list of |
remarks he has defined.)
(RETURN NAME])
(GENREMNAM
[LAMBDA (FN)
(* Generates a name for a remark which has been used
in the transformation for FN.)
(PROG [(N 0)
(NAM (PACK (LIST FN (QUOTE :]
CHECKIT
(COND
((NULL (FASSOC NAM USERNOTES)) (* Name hasn't been used
already so is ok.)
(RETURN NAM)))
[SETQ NAM (PACK (LIST FN (SETQ N (ADD1 N))
(QUOTE :] (* Otherwise try again,
adding, or incrementing,
a suffix of the FORM n:)
(GO CHECKIT])
(TXDELNOTE
[LAMBDA (LIN) (* dcl: 7 Jul 76 16:02)
(MAPCAR LIN (FUNCTION (LAMBDA (R1 TMP)
(SETQ TMP (FASSOC R1 USERNOTES))
(COND
[(NULL TMP)
(CONS R1 (QUOTE (NOT FOUND]
(T (/SETATOMVAL (QUOTE USERNOTES) |
(/DREMOVE TMP USERNOTES)) |
R1])
)
(RPAQQ TSETMACROS ((SHOW (TRANSUNDER TXSHOW))
(EXIT (TRANSUNDER TXEXIT))
(NOTE (TRANSUNDER TXNOTE T))
(TEST (TRANSUNDER TXTEST T))
(ERASE (TRANSUNDER TXERASE))
(EDIT (TRANSUNDER TXEDIT))
(DUMP (TRANSUNDER TXDUMP))
(FN (TRANSUNDER TXFN))
(DELNOTE (TRANSUNDER TXDELNOTE))))
(RPAQ LISPXMACROS (UNION TSETMACROS LISPXMACROS))
(RPAQ TESTFORM NIL)
(RPAQ LISPXCOMS (UNION LISPXCOMS (MAPCAR TSETMACROS (FUNCTION CAR))))
(RPAQ MERGE NIL)
(RPAQ PRETTYDEFMACROS (CONS [QUOTE (TRANSAVE NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS
(PROP XFORM * TRANSFORMATIONS)
(P (COND [(EQ (EVALV (QUOTE MERGE))
T)
[RPAQ TRANSFORMATIONS
(UNION TRANSFORMATIONS
(LISTP (GETP (QUOTE
TRANSFORMATIONS)
(QUOTE VALUE]
(MAPC (GETP (QUOTE USERNOTES)
(QUOTE VALUE))
(FUNCTION (LAMBDA
(NOTE)
(OR (ASSOC (CAR NOTE)
USERNOTES)
(SETQ USERNOTES
(CONS NOTE
USERNOTES]
(T (MAPC (GETP (QUOTE TRANSFORMATIONS)
(QUOTE VALUE))
(FUNCTION
(LAMBDA (X)
(AND (NOT (MEMB X
TRANSFORMATONS))
(/REMPROP X
(QUOTE XFORM]
PRETTYDEFMACROS))
(RPAQ LCASELST (APPEND (QUOTE (DO TRANSFORMATIONS))
LCASELST))
(PUTPROPS BBN UCASE T)
(PUTPROPS LISP UCASE T)
(PUTPROPS SRI UCASE T)
(PUTPROPS MIT UCASE T)
(PUTPROPS QA3 UCASE T)
(PUTPROPS PLANNER UCASE T)
(PUTPROPS UCI UCASE T)
(PUTPROPS INTERLISP UCASE T)
(PUTPROPS TSET FILEGROUP (TRANSOR TSET))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML TRANSUNDER)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1734 16815 (TRANSORSET 1746 . 2634) (TRANSORINPUTP 2636 . 4331) (TRANSORSETUSERFN 4335
. 6136) (RUMARK 6138 . 6408) (RUMARK1 6410 . 7506) (TRANSUNDER 7508 . 8312) (TXFN 8314 . 8628) (TXFN1
8630 . 9888) (TXDUMP 9890 . 11415) (TXERASE 11417 . 11863) (TXERASE1 11865 . 12214) (TXTEST 12216 .
12999) (TXSHOW 13001 . 13545) (TXEDIT 13547 . 13990) (TXEXIT 13992 . 14156) (TXNOTE 14158 . 15791) (
GENREMNAM 15793 . 16479) (TXDELNOTE 16481 . 16813)))))
STOP
P