-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathPRETTY
764 lines (643 loc) · 66.2 KB
/
PRETTY
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
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Feb-2024 17:54:23" {DSK}<mnt>e>Interlisp>medley>sources>PRETTY.;2 66897
:EDIT-BY "mth"
:CHANGES-TO (FNS PRINTCOPYRIGHT1 PRINTCOPYRIGHT)
:PREVIOUS-DATE " 8-Feb-2023 16:21:26" {DSK}<mnt>e>Interlisp>medley>sources>PRETTY.;1)
(* ; "
Copyright (c) 1984-1990, 1999, 2018, 2023-2024 by Venue & Xerox Corporation.
The following program was created in 1984 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")
(PRETTYCOMPRINT PRETTYCOMS)
(RPAQQ PRETTYCOMS
[(FNS PRETTYDEF PRETTYDEFCOMS PRETTYDEF0 PRETTYDEF1 PRINTDATE PRINTDATE1 PRINTFNS PRETTYCOM
PRETTYVAR PRETTYVAR1 PRETTYCOM1 ENDFILE MAKEDEFLIST PP PP* PPT PRETTYPRINT PRETTYPRINT1
PRETTYPRINT2 PRETTYPRINT3 PRINTDEF1 SUPERPRINTEQ SUPERPRINTGETPROP CHANGEFONT)
(FNS READARRAY PRINTARRAY READARRAY-FROM-LIST PRINTARRAY-TO-LIST)
(COMS (DECLARE%: DONTCOPY (MACROS CHANGFONT)))
(COMS (* ; "COPYRIGHT")
(FNS PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT)
(BLOCKS (NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T)
(NOLINKFNS PRINTCOPYRIGHT1)))
(GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER
COPYRIGHTSRESERVED)
(INITVARS (COPYRIGHTFLG)
(DEFAULTCOPYRIGHTOWNER)
(COPYRIGHTPRETTYFLG T)
(COPYRIGHTOWNERS)
[DEFAULTCOPYRIGHTKEYLST '((NONE "
" EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE)
[%[ "owner: " EXPLAINSTRING
"[ - new copyright owner -- type one line of text"
NOECHOFLG T KEYLST (( "
" RETURN (SUBSTRING (CADR ANSWER)
2 -2]
(%] "No copyright notice now
" EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL]
(COPYRIGHTSRESERVED T)
(*NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE
"INTERLISP" :FORMAT :XCCS))
(*DEFAULT-MAKEFILE-ENVIRONMENT*))
(GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG
*DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*))
(INITVARS (COMMENTFLG '*)
(**COMMENT**FLG '" **COMMENT** ")
(PRETTYFLG T)
(%#RPARS 4)
(CLISPIFYPRETTYFLG)
(PRETTYTRANFLG)
(FONTCHANGEFLG)
(CHANGECHARTABSTR)
(PRETTYTABFLG T)
(DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD
DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE
EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST))
(AVERAGEVARLENGTH 4)
(AVERAGEFNLENGTH 5)
(%#CAREFULCOLUMNS 0)
(CHANGECHAR '%|)
(ENDLINEUSERFN))
[INITVARS (PRETTYDEFMACROS)
(PRETTYPRINTMACROS)
(PRETTYEQUIVLST)
(PRETTYPRINTYPEMACROS)
(FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS
ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *))
(SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN
NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS
AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF
CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG
CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE
EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP
FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO
LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN
SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER]
(BLOCKS (PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT)
(SPECVARS FNSLST FILEFLG)))
(GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER
FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG
USERWORDS COMMENTFLG)
[DECLARE%: EVAL@COMPILE DOCOPY (P (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT
PRETTYCOMFONT COMMENTFONT
**COMMENT**FLG PRETTYPRINTMACROS]
(DECLARE%: DOEVAL@COMPILE DONTCOPY (* ;
"IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES")
(FILES (IMPORT)
FILEPKG))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP)
(NLAML)
(LAMA])
(DEFINEQ
(PRETTYDEF
[LAMBDA (PRTTYFNS PRTTYFILE PRTTYCOMS REPRINTFNS SOURCEFILE CHANGES FORMAT)
(* ; "Edited 9-Jul-2021 14:12 by rmk:")
(* ; "Edited 29-Jun-2021 17:23 by rmk:")
(DECLARE (SPECVARS PRTTYFILE REPRINTFNS SOURCEFILE CHANGES))
(RESETLST
[RESETSAVE (RESETUNDO)
'(AND RESETSTATE (RESETUNDO OLDVALUE]
(* ;; "Says undo everything if there is an error or control-D This is particularly necessary if user is using the PRINT* prettyprintmacro which updates comments to point to the newest version.")
(PROG ((NEWFILEMAP (AND BUILDMAPFLG (LIST NIL)))
(%#RPARS %#RPARS)
(*PRINT-ARRAY* T)
(XCL:*PRINT-STRUCTURE* T)
(*PRINT-LEVEL* NIL)
(*PRINT-LENGTH* NIL)
FILEFLG FNSLST PRTTYTEM PRETTYCOMSLST PRTTYSPELLFLG OLDFILEMAP MAPADR NLAMALST NLAMLST
LAMALST LAM?LST FILEDATES ORIGFLG ROOTNAME DESTINATIONENV SOURCEFILENV SOURCEFC
FCLOCATION DEFAULTDESTENV)
(DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH*
NEWFILEMAP ORIGFLG FILEFLG NLAMALST PRTTYSPELLFLG PRETTYCOMSLST
PRTTYCOMS LAM?LST FNSLST OLDFILEMAP LAMALST MAPADR ORIGFLG NLAMLST
DESTINATIONENV SOURCEFILENV %#RPARS))
(* ; "NEWFILEMAP corresponds to the map being built for the file being written. OLDFILEMAP corresponds to the map that exists for SOURCEFILE, if any.")
(COND
((OR (NULL (\DTEST PRTTYFILE 'LITATOM))
(EQ PRTTYFILE T)) (* ;
"we no longer support any of the crufty alternatives to writing a brand new file")
(\ILLEGAL.ARG PRTTYFILE)))
(SETQ ROOTNAME (ROOTFILENAME PRTTYFILE))
(if (OR (EQ SOURCEFILE T)
(AND REPRINTFNS (NULL SOURCEFILE)))
then
(* ;; "SOURCEFILE plays the role of CFILE for recompiling. It permits PRETTYPRINT to obtain the definitions from the file withou having to reprettyprint them, or even having them loaded into core. T (or NIL if REPRINTFNS is specified) is the same as PRETTYFILE.")
(* ;; "REPRINTFNS specifies those functions to be printed anew. REPRINTFNS=T means reprint all EXPRS, a la recompile. For example, if you have an entire file loaded in, but only change a few functions, using this option can speed up dumping the file by a factor of two. If REPRINTFNS=ALL, all functions that contain in core exprs, whether on function definition cell or property lists, are reprinted. REPRINTFNS can also be a list. MAKEFILE uses this for the REMAKE option by specifying as REPRINTFNS the list CHANGES. In any case, if the function does not contain an in core defnition, prettyprint will try to find one on the file. i.e., act as though REPRINTFNS were NIL.")
(SETQ SOURCEFILE ROOTNAME))
[if (SETQ DESTINATIONENV (GET ROOTNAME 'MAKEFILE-ENVIRONMENT))
then (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL DESTINATIONENV))
else (* ;
"see if we already know the environment of the source")
(CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC)
(LOOKUP-ENVIRONMENT-AND-FILEMAP (OR SOURCEFILE ROOTNAME)
(OR (NULL SOURCEFILE)
(EQ SOURCEFILE ROOTNAME]
(if SOURCEFILE
then (if [NULL (NLSETQ (SETQ SOURCEFILE (OPENSTREAM SOURCEFILE 'INPUT]
then (* ;
"can't find file to reprint from.")
(* ;
"OPENSTREAM was called in order that 'correction' take place.")
(SETQ SOURCEFILE NIL)
(PRINTOUT T PRTTYFILE " not found, so it will be written anew."
T)
elseif (RANDACCESSP SOURCEFILE)
then (RESETSAVE NIL (LIST 'CLOSEF SOURCEFILE))
(* ; "The typical case: File is open")
(RESETSAVE (INPUT SOURCEFILE))
[if (EQ REPRINTFNS 'EXPRS)
then (SETQ REPRINTFNS T)
elseif (EQ REPRINTFNS 'CHANGES)
then (SETQ REPRINTFNS
(UNION (FILEPKG.CHANGEDFNS CHANGES)
(FILEPKG.CHANGEDFNS (fetch FILECHANGES
of ROOTNAME]
(CL:UNLESS SOURCEFILENV (* ;
"if we didn't have environment cached, look it up from the actual stream now")
(CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC)
(GET-ENVIRONMENT-AND-FILEMAP SOURCEFILE)))
(\EXTERNALFORMAT SOURCEFILE (FETCH (READER-ENVIRONMENT
REFORMAT) OF
SOURCEFILENV
))
(if (NULL OLDFILEMAP)
then (* ;
"no map on file, so we will build one as needed")
(SETFILEPTR SOURCEFILE (OR SOURCEFC 0))
elseif (NULL (CAR OLDFILEMAP))
then (* ; "complete map.")
elseif (LISTP (CAR OLDFILEMAP))
then (* ; "only partial map built up. should only happen for files that were made with BUILDMAPFLG=NIL, since otherwise there would be a coplete map on the file.")
(SETFILEPTR SOURCEFILE (CAAR OLDFILEMAP))
else (* ; "Redundancy check. Should only occur if there was a compiled function in the file. and a partial map was formed that stopped after that function.")
(HELP))
else (* ;
"Can't copy from non-randaccessp source")
(SETQ SOURCEFILE NIL)))
(* ;; "Now figure out what environment to write the new file in.")
(CL:UNLESS DESTINATIONENV (* ;
"Don't yet have a destination environment")
(SETQ DESTINATIONENV (if SOURCEFILENV
then (* ; "use same as source")
(if (EQUAL-READER-ENVIRONMENT SOURCEFILENV
*OLD-INTERLISP-READ-ENVIRONMENT*)
then
(* ; "Coercing to the new style")
(\DO-DEFINE-FILE-INFO NIL
*NEW-INTERLISP-MAKEFILE-ENVIRONMENT*
)
else (* ;
"use same env on new file as old. But copy in case something changes")
(CREATE READER-ENVIRONMENT USING
SOURCEFILENV)
)
elseif *DEFAULT-MAKEFILE-ENVIRONMENT*
then
(* ;; "new file, use default")
(\DO-DEFINE-FILE-INFO NIL
*DEFAULT-MAKEFILE-ENVIRONMENT*))))
(CL:WHEN FORMAT
(REPLACE (READER-ENVIRONMENT REFORMAT) OF DESTINATIONENV WITH FORMAT))
(* ;; "We now have a DESTINATIONENV")
(if (NULL SOURCEFILE)
then (* ;
"get rid of anything we knew about source")
(SETQ OLDFILEMAP NIL)
(SETQ SOURCEFC NIL)
(SETQ SOURCEFILENV NIL)
elseif (AND SOURCEFILENV (EQUAL-READER-ENVIRONMENT SOURCEFILENV DESTINATIONENV))
then (* ;
"source and destination compatible, so we won't need to worry about it in PRETTYPRINT1/2")
(SETQ SOURCEFILENV NIL))
(* ;; "Ready to go. Clean up by closing and deleting file if aborted.")
[RESETSAVE NIL (LIST (FUNCTION PRETTYDEF0)
(SETQ PRTTYFILE (OPENSTREAM PRTTYFILE 'OUTPUT]
(\EXTERNALFORMAT PRTTYFILE (FETCH (READER-ENVIRONMENT REFORMAT) OF
DESTINATIONENV
))
(RESETSAVE (OUTPUT PRTTYFILE))
(PRINT-READER-ENVIRONMENT DESTINATIONENV)
(SETQ FCLOCATION (GETFILEPTR PRTTYFILE))
(WITH-READER-ENVIRONMENT DESTINATIONENV
(CL:UNLESS (SYNTAXP (CHARCODE "[")
'LEFTBRACKET) (* ;
"can't use brackets on this read table")
(SETQ %#RPARS NIL))
(SETQ FILEDATES (PRINTDATE PRTTYFILE CHANGES))
(AND (NEQ COPYRIGHTFLG 'NEVER)
ROOTNAME
(PRINTCOPYRIGHT ROOTNAME))
(SETQ FILEFLG T)
(SETQ CHANGES (FILEPKG.CHANGEDFNS CHANGES))(* ;
"Used freely by PRETTYPRINT to decide clispifying.")
(CL:UNLESS (RANDACCESSP PRTTYFILE) (* ;
"No point building a map, since we won't be able to go back to the start to point at it")
(SETQ NEWFILEMAP NIL))
(CL:WHEN FONTCHANGEFLG (* ; "this is expensive in that it costs as many conses as there are functions, but you can afford it for a makefile.")
(SETQ FNSLST (OR (for FL in (GETPROP ROOTNAME 'FILEGROUP)
when (fetch FILEPROP of FL)
join (FILEFNSLST FL))
(FILEFNSLST ROOTNAME))))
(CL:WHEN (OR (LISTP PRTTYFNS)
(LISTP (GETTOPVAL PRTTYFNS))) (* ;
"Ancient cruft from before the days of MAKEFILE.")
(PRINTFNS PRTTYFNS T)
(PRETTYCOM PRTTYFNS T))
(CL:WHEN [SETQ PRETTYCOMSLST (OR (LISTP PRTTYCOMS)
(AND (LITATOM PRTTYCOMS)
(LISTP (GETTOPVAL PRTTYCOMS]
(PRETTYCOM PRTTYCOMS T) (* ;
"PRTTYCOMS is just like the argument to a COMS command. see comment in prettycom1")
(for L on PRETTYCOMSLST do (PRETTYCOM (CAR L)
NIL L))
(* ; "The original value of PRTTYCOMS is saved so that it can be rewritten if a spelling correction occurs. The list PRTTYCOMSLST is searched by PRETTYCOM1 for * commands to see if the variable has be dumped out as well.")
)
(if (PRETTYDEF1)
then (* ;
"The coms were reprinted by PRETTYDEF1 due to a change to nlama and or nlaml")
elseif PRTTYSPELLFLG
then (* ; "A correction on prettycoms was performed, so dump it out aain to get the corrected version on the file.")
(PRETTYCOM PRTTYCOMS T))
(CL:UNLESS (EQ COPYRIGHTFLG 'NEVER)
(SAVECOPYRIGHT ROOTNAME))
(CL:WHEN NEWFILEMAP
(PRIN1 "(")
(PRIN2 'DECLARE%:)
(SPACES 1)
(PRIN2 'DONTCOPY)
(TERPRI)
(SPACES 2)
(for ADR in MAPADR do (SETQ PRTTYTEM (GETFILEPTR PRTTYFILE))
(SETFILEPTR PRTTYFILE ADR)
(* ; "Write the current file positon into the filecreated expression, and then restores the file pointer.")
(PRIN2 PRTTYTEM)
(SETFILEPTR PRTTYFILE PRTTYTEM))
(PRIN2 (LIST 'FILEMAP NEWFILEMAP)) (* ;
"printed instead of prettyprinted, so wont take up two pages of listing.")
(PRIN1 ")")
(TERPRI)
(* ;; "Also save map, so can be used for subsequent makefiles.")
(PUTFILEMAP (FULLNAME PRTTYFILE)
NEWFILEMAP NIL DESTINATIONENV NIL FCLOCATION))
(ENDFILE PRTTYFILE)
(CL:WHEN (AND FILEDATES ROOTNAME)
(/replace FILEDATES of ROOTNAME with FILEDATES)))
(RETURN (FULLNAME PRTTYFILE))))])
(PRETTYDEFCOMS
(LAMBDA (PRTTYCOMS FNSLST) (* ; "Edited 19-Aug-88 16:07 by raf") (DECLARE (SPECVARS FNSLST)) (PROG ((%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) BUILDMAPFLG PRTTYSPELLFLG ORIGFLG SOURCEFILE) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* BUILDMAPFLG NEWFILEMAP ORIGFLG PRTTYSPELLFLG LAM?LST ORIGFLG SOURCEFILE %#RPARS)) (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (for L on (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS)))) do (PRETTYCOM (CAR L) NIL L))))
)
(PRETTYDEF0
(LAMBDA (MADEFILE) (* bvm%: " 2-Aug-86 16:24") (* ;; "Cleans up after prettydef in case of control-d.") (COND ((OPENP MADEFILE (QUOTE OUTPUT)) (DELFILE (CLOSEF MADEFILE)))))
)
(PRETTYDEF1
(LAMBDA NIL (* wt%: " 9-SEP-78 16:05") (* ; "Updates the DECLARE: for NLAMA/NLAML") (PROG (PRTTYCOM PRTTYTEM PRTTYNEW) (COND ((NULL (SOME PRETTYCOMSLST (FUNCTION (LAMBDA (X) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (SETQ PRTTYTEM (MEMB (QUOTE COMPILERVARS) (SETQ PRTTYCOM X))) (EQ (CAAR (SETQ PRTTYTEM (CDR PRTTYTEM))) (QUOTE ADDVARS))))))) (AND (NULL NLAMALST) (NULL NLAMLST) (NULL LAMALST) (RETURN NIL)) (* ;; "If thee is no DECLARE: and no nlambdas, dont bother to add any. note tha if thee is IS a DECLARE:, then we must check even if there are no nlambdas, because consider what happens when user changes the only nlambda to a lambda
must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NLAMALST NLAMLST LAMALST)) (LIST NLAMALST NLAMLST LAMALST) (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA . NLAMALST) (NLAML . NLAMLST) (LAMA . LAMALST)))))) (COND ((AND (LISTP PRETTYCOMSLST) (NLISTP PRTTYCOMS)) (/NCONC1 PRETTYCOMSLST PRTTYCOM) (PRETTYCOM PRTTYCOMS T)))) ((NOT (EQUAL (CAR PRTTYTEM) (SETQ PRTTYNEW (LIST (QUOTE ADDVARS) (CONS (QUOTE NLAMA) (UNION NLAMALST (INTERSECTION LAM?LST (CDADAR PRTTYTEM)))) (CONS (QUOTE NLAML) (UNION NLAMLST (INTERSECTION LAM?LST (CDR (CADDAR PRTTYTEM))))) (CONS (QUOTE LAMA) (UNION LAMALST (INTERSECTION LAM?LST (CDR (CADDDR (CAR PRTTYTEM)))))))))) (* ;; "The reason for the unions and intersections is that prettydef simply may not know the fntyps of some of the functions in the file, namely those on lam?lst, and theefore tese should not be removed from NLAMA and NLAML if they are there from a previous makefile.") (/RPLACA PRTTYTEM PRTTYNEW) (AND (NLISTP PRTTYCOMS) (PRETTYCOM PRTTYCOMS T))) (T (RETURN NIL))) (PRETTYCOM PRTTYCOM) (RETURN T)))
)
(PRINTDATE
(LAMBDA (OUTSTREAM CHANGES) (* bvm%: " 1-Aug-86 15:51") (* ;;; "assumes that OUTSTREAM is a file open for output, and prints the date information for that file on it") (PROG ((DAT (DATE)) (ROOTNAME (ROOTFILENAME OUTSTREAM)) PREVPAIR FILEDATES) (if FILEPKGFLG then (if ROOTNAME then (/replace FILECHANGES of ROOTNAME with (SETQ CHANGES (FILEPKG.MERGECHANGES CHANGES (fetch FILECHANGES of ROOTNAME))))) (* ;; "The reason for the order of arguments in UNION is so that the changes will be listed in roughly the order made.") (SETQ FILEDATES (CONS (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ (FULLNAME OUTSTREAM)) (SETQ PREVPAIR (LAST (fetch FILEDATES of ROOTNAME))))) (* ;;; "Right now, FILEDATES simply keeps latest version and date, and original version and date. Latter for integrity checks on makefile remake, as described in filepackage. Note that don't want to change FILEDATES property until PRETTDEF completes. In case of control-d, the file will be deleted automatically.")) (PRINTDATE1 OUTSTREAM CHANGES DAT (fetch FILEDATE of (CAR PREVPAIR)) (fetch DATEFILENAME of (CAR PREVPAIR))) (* ; "PRINTDATE1 does the actual printing. It is a separate function so that it can be advised.") (RETURN FILEDATES)))
)
(PRINTDATE1
[LAMBDA (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING)
(* ; "Edited 8-Feb-2023 16:21 by lmm")
(* ; "Edited 30-Nov-2021 21:31 by larry")
(* bvm%: "18-Sep-86 19:08")
(* ;;; "does the printing for PRINTDATE")
(printout OUTSTREAM .FONT DEFAULTFONT "(" .P2 'FILECREATED %, .P2 DAT %, .FONT LAMBDAFONT .P2
(FULLNAME OUTSTREAM)
.FONT DEFAULTFONT)
(* ;; "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL")
(if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM)))
then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM)))
(PRIN3 " " OUTSTREAM)
(* ;; "The address of where the map begins will be stored in this slot. 8 spaces left because when radix is 8, can overflow seven spaces by a file of 300000 characters (Alice did it). The push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")
)
[if FILEPKGFLG
then (if INITIALS
then (printout OUTSTREAM T T 6 .P2 :EDIT-BY %, .P2 INITIALS))
(if CHANGES
then (printout OUTSTREAM T T 6 .P2 :CHANGES-TO %, .PPVTL CHANGES))
(if PREVDATE
then (printout OUTSTREAM T T 6 .P2 :PREVIOUS-DATE %, .P2 PREVDATE)
(if PREVERS
then (printout OUTSTREAM %, .P2 PREVERS]
(PRIN1 (OR TERMINATING.STRING ")
")
OUTSTREAM])
(PRINTFNS
(LAMBDA (X PRETTYDEFLG) (* lmm "13-OCT-82 16:44") (* ; "prettydeflg=T when called from prettydef.") (AND X (PROG (FNADRLST) (COND ((AND PRETTYDEFLG NEWFILEMAP) (SETQ FNADRLST (TCONC NIL (GETFILEPTR PRTTYFILE))) (TCONC FNADRLST NIL) (NCONC1 NEWFILEMAP (CAR FNADRLST)))) (PRIN1 (QUOTE %()) (PRINT (QUOTE DEFINEQ)) (PRETTYPRINT X (AND PRETTYDEFLG (OR FNADRLST T)) FNSLST) (* ; "FNSLST bound in prettydef to list of functions on this file. used for font stuff.") (PRIN1 (QUOTE %))) (AND FNADRLST (RPLACA (CDAR FNADRLST) (GETFILEPTR PRTTYFILE))) (TERPRI))))
)
(PRETTYCOM
(LAMBDA (PRTTYCOM PRTTYFLG PRETTYCOMSTAIL) (* ; "Edited 14-Apr-88 18:26 by bvm") (PROG (PRTTYTEM) (COND ((NULL PRTTYCOM) (* ; "So that RECOMPILE and BRECOMPILE do not have to check before calling PRETTYCOM.") (RETURN)) ((AND PRTTYFLG (NEQ PRTTYFILE T)) (PRINT (COND (LISPXPRINTFLG (* ;; "PRETTYCOMPRINT is an nlambda that does a lispxprint, except when prettyheader is NIL, in hich case it does nothing.") (LIST (QUOTE PRETTYCOMPRINT) PRTTYCOM)) (T (LIST (QUOTE PRINT) (LIST (QUOTE QUOTE) PRTTYCOM) T T)))))) (COND ((LITATOM PRTTYCOM) (COND ((AND (NULL PRTTYFLG) (NOT (BOUNDP PRTTYCOM)) DWIMFLG (SETQ PRTTYTEM (FIXSPELL PRTTYCOM 70 USERWORDS T PRETTYCOMSTAIL (FUNCTION BOUNDP))) (SETQ PRTTYSPELLFLG T)) (SETQ PRTTYCOM PRTTYTEM))) (PRETTYVAR PRTTYCOM PRTTYFLG) (* ;; "FNS and VARS are printed as (RPAQQ atom value T) so that LOAD ALLPROP will still stre them in the value cell.") (RETURN PRTTYCOM)) (PRTTYFLG (* ; "PRETTYDEF called with a list for FNS or VARS,") (RETURN PRTTYCOM))) TOP (COND ((AND (NULL ORIGFLG) (SETQ PRTTYTEM (fetch (FILEPKGCOM MACRO) of (CAR PRTTYCOM)))) (for X on (SUBPAIR (CAR PRTTYTEM) (PRETTYCOM1 PRTTYCOM T T) (CDR PRTTYTEM)) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (T (SELECTQ (CAR PRTTYCOM) (FNS (PROG (PRTTYSPELLFLG) (PRINTFNS (PRETTYCOM1 PRTTYCOM T T) (NOT (NULL PRETTYCOMSTAIL))) (AND PRTTYSPELLFLG (EQ (CADR PRTTYCOM) (QUOTE *)) (LITATOM (SETQ PRTTYTEM (CADDR PRTTYCOM))) (PRETTYCOM PRTTYTEM)) (* ; "The FNSlst had an error in it that was corrected."))) ((VARS ARRAY) (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR X))) (DECLARE%: (* ;; "Normally, expressions appearing in a symbolic file are (1) evaluated upon loading the file, (2) not evaluated when compiling the file, and (3) copied to the compile file. DECLARE: can be used to change state around any PRETTYCOM. The atomic symbols DONTCOPY, DOCOPY, DONTEVAL@COMPILE, DOEVAL@COMPILE, DONTEVAL@LOAD, and DOEVAL@LOAD have the obvious meaning. DECLARE: eliminates the pretty commands DECLARE, COMPROP, COMPROP*, PD, PC, and PC*. DECLARE: is defined as a functionthat evaluates all list expressions except when under a DONTEVAL@LOAD state.") (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (for LST on (PRETTYCOM1 PRTTYCOM T T) do (COND ((NLISTP (CAR LST)) (COND ((NOT (MEMB (CAR LST) DECLARETAGSLST)) (COND ((AND DWIMFLG (FIXSPELL (CAR LST) 70 DECLARETAGSLST T LST)) (SETQ PRTTYSPELLFLG T)) (T (GO ERROR))))) (PRIN2 (CAR LST)) (SPACES 1)) (T (TERPRI) (PRETTYCOM (CAR LST) NIL LST))) (SELECTQ (CAR LST) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (COND ((SETQ LST (CDR LST)) (PRINTDEF (CAR LST)) (SPACES 1)))) NIL)) (PRIN1 (QUOTE ")
"))) ((CL:EVAL-WHEN) (* ;; "Has the syntax (EVAL-WHEN (times ...) coms ...). Dumps an EVAL-WHEN form on the file containing whatever is dumped by the given COMS.") (CL:ASSERT (AND (CL:CONSP (CADR PRTTYCOM)) (CL:SUBSETP (CADR PRTTYCOM) (QUOTE (EVAL CL:EVAL COMPILE CL:COMPILE LOAD CL:LOAD)))) NIL "The first argument to the ~S command must be a list of times") (CL:FORMAT T "(~S ~S" (QUOTE CL:EVAL-WHEN) (CADR PRTTYCOM)) (for LST on (PRETTYCOM1 (CDR PRTTYCOM) T NIL) do (CL:TERPRI) (PRETTYCOM (CAR LST) NIL LST)) (CL:FORMAT T "~&)~%%")) ((SPECVARS LOCALVARS GLOBALVARS) (SETQ PRTTYTEM (CONS (CAR PRTTYCOM) (PRETTYCOM1 PRTTYCOM T T))) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (PRINTDEF1 PRTTYTEM) (PRIN1 ")
")) ((PROP IFPROP) (PROG ((PRTTYFLG (EQ (CAR PRTTYCOM) (QUOTE IFPROP))) (PRTTYTEM (CADR PRTTYCOM)) (PRTTYX (PRETTYCOM1 (CDR PRTTYCOM) T T))) (* ; "IFPROP only dumps those property values that are non-NIL.") (COND ((LISTP PRTTYTEM) (for X in PRTTYTEM do (MAKEDEFLIST PRTTYX X PRTTYFLG))) ((NEQ PRTTYTEM (QUOTE ALL)) (MAKEDEFLIST PRTTYX PRTTYTEM PRTTYFLG PRTTYCOM)) ((ASSOC (QUOTE PUTPROPS) PRETTYPRINTMACROS) (for ATM in PRTTYX do (PRINTDEF1 (CONS (QUOTE PUTPROPS) (CONS ATM (CONS (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) join (LIST (CAR X) (CADR X))))))))) (T (for ATM in PRTTYX do (printout NIL %,, "(" |.P2| (QUOTE PUTPROPS) %, |.P2| ATM) (SETQ PRTTYTEM (ADD1 (POSITION))) (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) do (printout NIL .TAB PRTTYTEM .PPV (CAR X) %, .PPV (CADR X))) (PRIN1 (QUOTE ")
"))))))) (P (* ; "Arbitrary expression to evaluate when loaded. Be sure to prettyprint as code") (for X in (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T)) do (PRINTDEF1 X T))) (INITVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (COND ((LISTP X) (OR (EQ (CAR X) COMMENTFLG) (PRETTYVAR1 (QUOTE RPAQ?) (CAR X) (CDR X) NIL T))) (T (PRETTYVAR1 (QUOTE RPAQ?) X NIL))))) (ADDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE ADDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (APPENDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE APPENDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (E (for X in (PRETTYCOM1 PRTTYCOM T) do (EVAL X))) (COMS (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (ORIGINAL (LET ((ORIGFLG T)) (DECLARE (SPECVARS ORIGFLG)) (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X))))) (BLOCKS (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T T)) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (for X in PRTTYTEM do (PRINTDEF1 (CONS (QUOTE BLOCK%:) X))) (PRIN1 ")
")) ((*) (COND ((EQ (CADR PRTTYCOM) (QUOTE *)) (* ; "Form-feed if super-comment indicated. Use * no matter what current COMMENTFLG is.") (printout NIL .PAGE)) (T (RPTQ 3 (TERPRI)))) (COND ((AND (COND (FILEFLG FONTCHANGEFLG) (T (EQ FONTCHANGEFLG (QUOTE ALL)))) LAMBDAFONT) (CHANGEFONT LAMBDAFONT) (PRIN2 PRTTYCOM) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 PRTTYCOM))) (RPTQ 2 (TERPRI))) (COND ((AND (LITATOM (CAR PRTTYCOM)) (fetch (FILEPKGTYPE GETDEF) of (CAR PRTTYCOM))) (* ; "If its the name of a type with a GETDEF, put out PUTDEF expressions.") (for X in (PRETTYCOM1 PRTTYCOM T T) do (printout NIL "(" |.P2| (QUOTE PUTDEF) %, |.P2| (KWOTE X) %, |.P2| (KWOTE (CAR PRTTYCOM)) %, .PPV (KWOTE (GETDEF X (CAR PRTTYCOM))) ")" T))) ((FIXSPELL (CAR PRTTYCOM) 70 FILEPKGCOMSPLST T PRTTYCOM) (SETQ PRTTYSPELLFLG T) (GO TOP)) (T (GO ERROR)))))) (RETURN PRTTYCOM) ERROR (ERROR "bad file package command" PRTTYCOM)))
)
(PRETTYVAR
(LAMBDA (VAR FLG) (* lmm "27-Aug-84 20:15") (* ; "I don't see what FLG is used for--rmk") (PROG (VAL TEM) (* ;; "Dumps value of VAR for reloading. If VAR is non-atomic, of form (var form) where VAR is to be dumped so as to be set to value of form, computed at LOAD time.") (COND ((LITATOM VAR) (AND (EQ (SETQ VAL (GETTOPVAL VAR)) (QUOTE NOBIND)) (printout T T "****WARNING: " |.P2| VAR " is unbound" T T)) (PRETTYVAR1 (QUOTE RPAQQ) VAR VAL)) ((LISTP VAR) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR)) (COND ((AND (EQ (CAR (SETQ TEM (LISTP (CAR (LISTP VAL))))) (QUOTE QUOTE)) (LISTP (CDR TEM))) (PRETTYVAR1 (QUOTE RPAQQ) VAR (CADR TEM))) ((EQ VAR COMMENTFLG) (* ; "don't print out comments")) ((OR (NULL VAL) (AND (LISTP VAL) (OR (NUMBERP (CAR VAL)) (EQ T (CAR VAL)) (NULL (CAR VAL))) (NULL (CDR VAL)))) (* ; "A minor optimization for RPAQQ's to suppresses unnecessary load-time eval's.") (PRETTYVAR1 (QUOTE RPAQQ) VAR (CAR VAL))) (T (PRETTYVAR1 (QUOTE RPAQ) VAR VAL NIL T)))) (T (ERROR "Bad variable specification" VAR)))))
)
(PRETTYVAR1
(LAMBDA (OP VAR E DEF TAILFLG) (* ; "Edited 10-Feb-87 18:01 by Pavel") (* ;; "does printing for VAR, ADDVAR, and PROP commands. OP is the name of the function, VAR the operand, and E the rest of the expression to be printed, either as an element, or as a tail if TAILFLG=T. VAR is printed in LAMBDAFONT. If VAR is a list, each element is printed in LAMBDAFONT. This option is used to print both the name of the atom and its property for PROP commands.") (PROG ((LASTCOL (LINELENGTH)) TEM (*PRINT-ARRAY* T)) (* ; "This is supposed to be bound above here but isn't in some case I can't find. --Pavel") (TERPRI) (* ;; "because if you have a really bold font, it lines up the bottoms, but you can get crowded into the line above.") (COND ((AND (MEMB OP (QUOTE (RPAQQ RPAQ RPAQ?))) (EQ (TYPENAME (SETQ TEM (COND (TAILFLG (CAR E)) (T E)))) (QUOTE ARRAYP))) (* ;; "dump arrays and bitmaps specially. This really ought to be handled by having *PRINT-ARRAY* say how to dump these, so that only a single expression ends up on the file.") (* ;; "1 December 1986, Pavel: Well, I fixed bitmaps for this. Maybe I'll fix arrays as well...") (* ;; "10 February 1987, Pavel: ARRAYP's are now fixed as well, but not by using *PRINT-ARRAY*. Rather than invent another non-standard reader macro, I simply store the elements in a list and use a non-READing version of READARRAY.") (COND ((EQ OP (QUOTE RPAQQ)) (SETQQ OP RPAQ))) (printout NIL "(" |.P2| OP %, |.P2| VAR %,) (PRIN2 (BQUOTE (READARRAY-FROM-LIST (\, (ARRAYSIZE TEM)) (QUOTE (\, (ARRAYTYP TEM))) (\, (ARRAYORIG TEM)) (QUOTE (\, (PRINTARRAY-TO-LIST TEM)))))) (printout NIL (QUOTE %)) T)) ((ASSOC OP PRETTYPRINTMACROS) (OR TAILFLG (SETQ E (CONS E))) (PRINTDEF (CONS OP (COND ((LISTP VAR) (APPEND VAR E)) (T (CONS VAR E)))) 0 DEF)) (T (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (SETQ TEM (POSITION)) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT))) (COND ((LISTP VAR) (MAPRINT VAR NIL NIL NIL NIL (FUNCTION PRIN2))) (T (PRIN2 VAR))) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT DEFAULTFONT))) (SPACES 1) (PRINTDEF E (COND ((OR (NLISTP E) (FITP E NIL NIL LASTCOL)) (POSITION)) (T TEM)) DEF TAILFLG) (PRIN1 (QUOTE %))))) (TERPRI)))
)
(PRETTYCOM1
(LAMBDA (PRTYCOM PRTYFLG REMOVECOMMENTS) (* rmk%: "13-Feb-85 22:54") (PROG (PRTYX) (COND ((AND (EQ (CAR (LISTP (SETQ PRTYX (CDR PRTYCOM)))) (QUOTE *)) (CDR PRTYX)) (COND ((AND (LITATOM (SETQ PRTYX (CADR PRTYX))) PRTYFLG) (* ; "Checks to see if the variable is already being dumped and dumps it if not.") (PRETTYCOM PRTYX))) (SETQ PRTYX (COND (PRTYFLG (EVAL PRTYX)) ((LITATOM PRTYX) (AND (NEQ (SETQ PRTYX (GETTOPVAL PRTYX)) (QUOTE NOBIND)) PRTYX)) (T (RESETVARS (DWIMLOADFNSFLG) (RETURN (AND (ERSETQ (SETQ PRTYX (EVAL PRTYX))) PRTYX)))))))) (RETURN (if (AND REMOVECOMMENTS (LISTP PRTYX)) then (SUBSET PRTYX (FUNCTION (LAMBDA (X) (OR (NLISTP X) (NEQ (CAR X) COMMENTFLG))))) else PRTYX))))
)
(ENDFILE
(LAMBDA (FILE) (* wt%: "10-SEP-78 13:54") (PRINT (QUOTE STOP) FILE) (CLOSEF FILE)))
(MAKEDEFLIST
(LAMBDA (X PROP FLG) (* ; "Edited 11-Feb-87 11:10 by bvm:") (for Z in X bind TEM do (COND ((AND (LITATOM Z) (SETQ TEM (SOME (GETPROPLIST Z) (FUNCTION (LAMBDA (X) (EQ X PROP))) (QUOTE CDDR)))) (PRETTYVAR1 (QUOTE PUTPROPS) (LIST Z PROP) (CADR TEM) (OR (EQ PROP (QUOTE EXPR)) (MEMB PROP MACROPROPS)))) ((NULL FLG) (* ; "PROP command") (EXEC-FORMAT "(no ~S property for ~S)~%%" PROP Z)))))
)
(PP
(NLAMBDA X (* lmm "15-Nov-86 00:54") (DECLARE (LOCALVARS . T)) (MAPC (NLAMBDA.ARGS X) (FUNCTION (LAMBDA (NAME) (for TYPE in (TYPESOF NAME NIL (QUOTE (FIELDS)) (QUOTE CURRENT)) do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE))))))
)
(PP*
(NLAMBDA X (* lmm "14-Aug-84 19:11") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with comments not suppressed.") (LET ((**COMMENT**FLG NIL) (*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS **COMMENT**FLG *STANDARD-OUTPUT*)) (PRETTYPRINT (NLAMBDA.ARGS X))))
)
(PPT
(NLAMBDA X (* lmm "14-Aug-84 19:12") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with clisp translations shown.") (LET ((*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS *STANDARD-OUTPUT*)) (RESETVARS ((PRETTYTRANFLG T)) (RETURN (PRETTYPRINT (NLAMBDA.ARGS X))))))
)
(PRETTYPRINT
(LAMBDA (FNS PRETTYDEFLG FNSLST) (* ; "Edited 11-Feb-87 11:11 by bvm:") (* ;; "PRETTYDEFLG is supplied when called from PRINTFNS. it is either a paatial file map or T, so that it is also used as a flag for whether you are being called from prettydef.") (* ;; "Note that prettyprint does all of its printing to standard output file and using current readtable. it assumes that higher functions have set these appropriately, as is the case when called from prettydef, pp, pp*,") (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT) (GETSTREAM NIL (QUOTE OUTPUT)))) (PROG ((CLK (CLOCK 0)) (NEWADRLST (LISTP PRETTYDEFLG)) (FILEFLG (NOT (DISPLAYP (OUTPUT)))) FN DEF ADR LST SKIPPEDLST TEM) (* ; "NEWADRLST Corresponds to the current entry on NEWFILEMAP. Is in TCONC format.") (COND ((ATOM (SETQ LST FNS)) (SETQ LST (EVALV FNS)))) LP (COND ((NLISTP LST) (RETURN FNS)) ((AND FILEFLG (IGREATERP (CLOCKDIFFERENCE CLK) 30000)) (* ; "Every 30 seconds say what function we're working on") (SETQ CLK (CLOCK 0)) (PRIN2 (CAR LST) T T) (PRIN1 (QUOTE ", ") T))) (SETQ FN (CAR LST)) (TERPRI) (* ; "The initial TERPRI is not in map") (AND NEWADRLST (TCONC NEWADRLST (LIST FN (GETFILEPTR PRTTYFILE)))) (* ; "Address of start.") LP1 (SETQ DEF (VIRGINFN FN)) (AND PRETTYDEFLG (SELECTQ (ARGTYPE DEF) (1 (SETQ NLAMLST (CONS FN NLAMLST))) (2 (SETQ LAMALST (CONS FN LAMALST))) (3 (SETQ NLAMALST (CONS FN NLAMALST))) (NIL (SETQ LAM?LST (CONS FN LAM?LST))) NIL)) (* ; "So prettydef can add the appropriate DECLARE:") (COND ((NULL DEF) (COND ((AND (NULL PRETTYDEFLG) FN (BOUNDP FN)) (* ; "No fn definition, but is a variable. Only make this check when called via PP or PP*") (PRINTDEF (EVALV FN) 2)) (T (GO NOPRINT)))) ((NULL (EXPRP DEF)) (GO NOPRINT)) (T (AND ADDSPELLFLG (ADDSPELL FN)) (COND ((AND PRETTYDEFLG SOURCEFILE (NULL SOURCEFILENV) (NULL (SELECTQ REPRINTFNS (ALL T) ((T EXPRS) (EXPRP FN)) (AND (LISTP REPRINTFNS) (FMEMB FN REPRINTFNS)))) (PRETTYPRINT1 FN)) (* ; "Was a fn to be copied from old file, and we succeeded")) (T (* ; "Prettyprint afresh") (PRETTYPRINT3 FN DEF PRETTYDEFLG))))) DEFPRINTED (* ;;; "At this point we have prettyprinted FN one way or another") (AND NEWADRLST (RPLACD (CDADR NEWADRLST) (GETFILEPTR PRTTYFILE))) (* ; "Store end address") (TERPRI) (* ; "TERPRI is not included in map address") (SETQ LST (CDR LST)) (GO LP) NOPRINT (COND ((AND FILEFLG SOURCEFILE (PRETTYPRINT1 FN)) (GO DEFPRINTED)) ((AND (NULL PRETTYDEFLG) (SETQ TEM (EDITLOADFNS? FN))) (* ; "only make this check when called from PP or PP*") (LOADFNS FN TEM (QUOTE PROP)) (COND ((GETPROP FN (QUOTE EXPR)) (GO LP1))) (PRINT (CONS FN (QUOTE (not found))) T T)) ((AND DWIMFLG (NULL DEF) (SETQ TEM (MISSPELLED? FN 70 USERWORDS (AND PRETTYDEFLG T) LST)) (NEQ TEM FN)) (/RPLACA LST (SETQ FN TEM)) (AND NEWADRLST (FRPLACA (CADR NEWADRLST) FN)) (* ; "Fixes filemap.") (AND PRETTYDEFLG (SETQ PRTTYSPELLFLG T)) (GO LP1))) (EXEC-FORMAT "(~S not printable)~%%" FN) (AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*) FN NIL (CAAR LISPXHISTORY))) (COND (NEWADRLST (SETQ TEM (NLEFT (CAR NEWADRLST) 2)) (RPLACD TEM) (RPLACD NEWADRLST TEM))) LP3 (SETQ LST (CDR LST)) (GO LP))))
)
(PRETTYPRINT1
(LAMBDA (FN) (* bvm%: "30-Aug-86 17:25") (* ;;; "Like BRECOMPILE1. Obtains FN from SOURCEFILE. works whether the file has previously been mapped by PRETTYDEF, LOAD, or LOADFNS (or patially mapped)") (WITH-READER-ENVIRONMENT (OR SOURCEFILENV DESTINATIONENV) (PROG (ADR TEM) (COND ((NULL OLDFILEMAP) (GO DEFQLP)) ((PRETTYPRINT2 FN) (RETURN FN)) ((NULL (CAR OLDFILEMAP)) (RETURN NIL) (* ; "The entire file has been scanned.")) (T (GO FNLP) (* ; "Already inside of DEFINEQ."))) DEFQLP (* ; "Find DEFINEQ") (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) ((STOP NIL) (* ; "End of file reached.") (SETQ OLDFILEMAP (CONS NIL OLDFILEMAP)) (* ; "Just to inform future calls to PRETTYPRINT1 not to bother scanning.") (RETURN NIL)) (%( (COND ((EQ (SETQ TEM (RATOM SOURCEFILE)) (QUOTE DEFINEQ)) (COND ((NULL OLDFILEMAP) (SETQ OLDFILEMAP (LIST T)) (* ;; "In case functionis found right off, OLDFILEMAP must not be left as NIL or else next call to PRETTYPRINT1 will not realize are alredy inside of DEFINEQ."))) (GO FNLP)) (T (SKREAD SOURCEFILE (QUOTE %())))) (SKREAD SOURCEFILE TEM)) (GO DEFQLP) FNLP (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) (%) (* ; "End of DEFINEQ.") (GO DEFQLP)) ((%( %[) NIL) (SCANFILEHELP)) (SETQ ADR (SUB1 (GETFILEPTR SOURCEFILE))) (SETQ TEM (RATOM SOURCEFILE)) (SETFILEPTR SOURCEFILE ADR) (SKREAD SOURCEFILE) (COND ((EQ TEM FN) (PRETTYPRINT2 FN ADR (GETFILEPTR SOURCEFILE)) (* ; "copies the bytes.") (RETURN FN)) (T (SETQ OLDFILEMAP (CONS (CONS TEM (CONS ADR (GETFILEPTR SOURCEFILE))) OLDFILEMAP)) (* ;; "Note that this situation only occurs when (a) the entire file was not peviously scanned, e.g. if loaded with buildmapflg off, and (b) user is doing a remake, and (c) this functio was either dumped directly because it was changed, or else it has been deleted from the FNS. The function is added to OLDFILEMAP just in case it is out of order.") (GO FNLP))))))
)
(PRETTYPRINT2
(LAMBDA (FN FROM TO) (* bvm%: "30-Aug-86 18:13") (* ;; "Copies function from sourcefile to prettyfile. looking it up on the map when not already given address. returns nil if not there") (PROG (TEM) (COND (FROM) ((for X in OLDFILEMAP thereis (COND ((NLISTP X) NIL) ((EQ (CAR X) FN) (* ;; "occurs when remaking a file without a map, and a function is previously skipped that later is needed.") (SETQ TEM X)) ((LISTP (CDDR X)) (SETQ TEM (FASSOC FN (CDDR X)))))) (SETQ FROM (CADR TEM)) (SETQ TO (CDDR TEM))) (T (RETURN NIL))) (SETFILEPTR SOURCEFILE FROM) (RATOM SOURCEFILE) (* ;; "The RATOM skips the paren. the reason for the RATOM instead of simply setting file ptr to (ADD1 FROM) is that there may be font info there.") (COND ((NEQ FN (SETQ TEM (READ SOURCEFILE))) (* ; "Consistency check.") (LISPXPRINT (CONS FN TEM) T) (ERROR (QUOTE "filemap does not agree with contents of") SOURCEFILE T))) (if (NULL SOURCEFILENV) then (* ; "compatible environments, just copy characters") (COPYCHARS SOURCEFILE PRTTYFILE FROM TO) else (* ; "incompatible, have to read old def and reprettyprint") (SETQ TEM (READ SOURCEFILE)) (* ; "old definition") (WITH-READER-ENVIRONMENT DESTINATIONENV (PRETTYPRINT3 FN TEM T))) (* ; "Initial and final TERPRI's are done by callers; they are not in map.") (RETURN FN)))
)
(PRETTYPRINT3
(LAMBDA (FN DEF PRETTYDEFLG) (* bvm%: "30-Aug-86 17:18") (LET (TEM) (AND (OR (SELECTQ CLISPIFYPRETTYFLG ((T EXPRS) (EXPRP FN)) (ALL T) (CHANGES (AND PRETTYDEFLG (MEMB FN CHANGES))) (MEMB FN CLISPIFYPRETTYFLG)) (AND (SUPERPRINTEQ (CAR (SETQ TEM (CADDR DEF))) COMMENTFLG) (EQ (CADR TEM) (QUOTE DECLARATIONS%:)) (MEMB (QUOTE CLISPIFY) TEM))) (SETQ DEF (CLISPIFY DEF))) (* ;; "If the function is stored on property list, only clispify if user specifically said MAKEFILE (file CLISPIFY), otherwise, assume that functions on property list have already been clispified") (COND ((AND LAMBDAFONT FONTCHANGEFLG) (PRIN1 (QUOTE %()) (* ;; "The font change is after the paren because of problems with updating filemaps when moving back and forth between -10 and -D systems--rmk") (CHANGEFONT LAMBDAFONT) (PRIN2 FN) (CHANGEFONT DEFAULTFONT) (TERPRI)) (T (PRIN1 (QUOTE %()) (PRINT FN))) (PRINTDEF DEF 2 (QUOTE FNS) NIL FNSLST) (PRIN1 (QUOTE %))) FN))
)
(PRINTDEF1
[LAMBDA (EXPR FORMFLG)
(* ;; "Edited 19-Jan-2022 20:35 by rmk: Added DEFMACRO")
(* ;; "Edited 16-Apr-2018 21:35 by rmk:")
(* ;; "Edited 16-Apr-2018 10:14 by rmk:")
(* ;; "Edited 14-Apr-88 18:21 by bvm")
(* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS")
(* ;; "Used by MAKEFILE to print P, etc expressions. ")
(TERPRI)
(LET (STARTPOS ENDPOS)
(IF [AND FORMFLG NEWFILEMAP (MEMB (CAR EXPR)
'(CL:DEFUN DEFMACRO)]
THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE)))
(PRINTDEF EXPR NIL FORMFLG NIL FNSLST)
[IF STARTPOS
THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE))
(NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR)
(CONS STARTPOS ENDPOS]
(TERPRI])
(SUPERPRINTEQ
(LAMBDA (X Y) (OR (EQ X Y) (AND Y (EQ (CDR (FASSOC X PRETTYEQUIVLST)) Y)))))
(SUPERPRINTGETPROP
(LAMBDA (ATM PROP) (* wt%: "17-SEP-79 15:57") (OR (GETPROP (CDR (FASSOC ATM PRETTYEQUIVLST)) PROP) (GETPROP ATM PROP)))
)
(CHANGEFONT
(LAMBDA (FONTCLASS FILE) (* lmm "17-Jan-86 20:59") (* ;; "for calls to changefont when not under prettyprin prettydef. This is only for non-D systems. For D, DSPFONT is moved'ed in.") (* ;; "Don't bother testing for FONTCHANGEFLG=ALL, because presumably the FONTCLASS will have a NULL entry if display printing isn't wanted. FONTCHANGEFLG=ALL tests are really only needed if something expensive can be avoided by advance knowledge.") (AND FONTCHANGEFLG FONTCLASS (DSPFONT FONTCLASS FILE)))
)
)
(DEFINEQ
(READARRAY
(LAMBDA (SIZE TYPE ORIG) (* rrb " 4-JUL-80 17:07") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (COND ((NEQ (READC) (QUOTE %()) (GO LP))) (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (READ)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP2))) OUT (READ) (* ; "Reads the final right parentheses surrounding the elements of the array.") (RETURN A)))
)
(PRINTARRAY
(LAMBDA (V) (* bvm%: " 3-Oct-86 12:57") (* ; "Used by prettydef. Included in ABASIC because it uses LOC and VAG on the 10") (PROG (A N M TYPE FLG DOUBLEFLG ORIG) (COND ((AND (LITATOM V) (ARRAYP (SETQ A (EVALV V (QUOTE PRINTARRAY))))) (PRINT (BQUOTE (SETQ (\, V) (READARRAY (\, (SETQ N (ARRAYSIZE A))) (QUOTE (\, (SETQ TYPE (ARRAYTYP A)))) (\, (SETQ ORIG (ARRAYORIG A)))))))) ((ARRAYP V) (* ; "Just dumps the element expression--assumes that READARRAY has already been written") (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (PRIN1 (QUOTE %()) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (COND ((OR (EQ TYPE (QUOTE POINTER)) DOUBLEFLG) (PRINT (ELT A (SUB1 (IPLUS M ORIG))))) (T (* ; "changed from PRINT to PRIN2 so would look better in file.") (PRIN2 (ELT A (SUB1 (IPLUS M ORIG)))) (SPACES 1))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP)) ((NULL (PRINT FLG)) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (PRINT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (PRIN1 (QUOTE %))) (RETURN A)))
)
(READARRAY-FROM-LIST
(LAMBDA (SIZE TYPE ORIG ELEMENTS) (* ; "Edited 10-Feb-87 17:59 by Pavel") (* ;;; "This is not written in the most straightforward way possible. Rather, in order to minimize the possibility of destabilization, we have kept this as much like READARRAY as possible. In essence, the only change is to use POP instead of READ.") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (pop ELEMENTS)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP2))) OUT (RETURN A)))
)
(PRINTARRAY-TO-LIST
(LAMBDA (V) (* ; "Edited 10-Feb-87 18:09 by Pavel") (* ;;; "This code is not written in the most straighforward way possible. Rather, to minimize the possibility of destabilization, we attempt to make it as much like PRINTARRAY as we can. In essence, the only changes are to PUSH the elements onto RESULT instead of printing them. At the end, we return the reversal of RESULT.") (PROG ((RESULT NIL) A N M TYPE FLG DOUBLEFLG ORIG) (COND ((ARRAYP V) (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (push RESULT (ELT A (SUB1 (IPLUS M ORIG)))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP))) (push RESULT FLG) (COND ((NULL FLG) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (push RESULT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (RETURN (REVERSE RESULT))))
)
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS CHANGFONT MACRO (= . DSPFONT))
)
)
(* ; "COPYRIGHT")
(DEFINEQ
(PRINTCOPYRIGHT
[LAMBDA (FILENAME) (* ; "Edited 2-Feb-2024 17:18 by mth")
(* ; "Edited 11-Sep-2021 09:07 by larry")
(* ; "Edited 31-Aug-99 09:01 by rmk:")
(* edited%: " 1-Jan-85 20:16")
(* ;;; "CALLED BY PRETTYDEF TO PUT a copyright notice on a file. The globalvar COPYRIGHTOWNERS is used to determine the possible copyright owners when it is determined the file doesn't have a copyright yet and has never been asked if the programmer wanted one. The whole copyright mechanism can be turned off by setting COPYRIGHTFLG to NEVER -- originaly NIL. If the file is copyrighted, any year the file is editted the new year is tacked on to the list of copyright years. The copyright notice comes immediately after the FILECREATED expression ")
(* ;;
"9/10/2021 LMM: Add COPYRIGHTFLG value PRESERVE meaning no new copyright (or year) but retain old")
(PROG [(OWNER (GETPROP FILENAME 'COPYRIGHT]
(AND [OR OWNER
(AND COPYRIGHTFLG (NEQ COPYRIGHTFLG 'PRESERVE)
(SETQ OWNER
(ASKUSER (if (EQ COPYRIGHTFLG 'DEFAULT)
then 0
else DWIMWAIT)
(CONSTANT (CHARACTER (CHARCODE LF)))
(CONCAT "Copyright owner for file " FILENAME ": ")
(NCONC [MAPCAR COPYRIGHTOWNERS (FUNCTION (LAMBDA (X)
(LIST (CAR X)
""
'EXPLAINSTRING
(CONCAT (CAR X)
" - "
(CADR X))
'RETURN
(CADR X)
'CONFIRMFLG T]
(CONS (if (SETQ OWNER (ASSOC DEFAULTCOPYRIGHTOWNER
COPYRIGHTOWNERS))
then (LIST (CONSTANT (CHARACTER (CHARCODE LF)))
(CONCAT DEFAULTCOPYRIGHTOWNER "
")
'EXPLAINSTRING
(CONCAT "<LF> - " (CADR OWNER)
" [Default]")
'NOECHOFLG T 'RETURN (CADR OWNER))
else '(%
"No copyright notice now
" EXPLAINSTRING "<LF> - no copyright notice now [Default]" NOECHOFLG T RETURN NIL))
DEFAULTCOPYRIGHTKEYLST))
T T))
(/PUTPROP FILENAME 'COPYRIGHT (SETQ OWNER (LIST OWNER]
(COND
((NEQ (CAR OWNER)
'NONE)
[PROG ((CURRENTYEAR (SUBATOM (DATE (DATEFORMAT YEAR.LONG NO.TIME))
-4 -1))
LATESTOWNER)
(* ;; " see github Interlisp/medley issue #207 (lmm 9/11/2021)")
(if (NEQ COPYRIGHTFLG 'PRESERVE)
then (if (LISTP (CAR OWNER))
then (SETQ LATESTOWNER (CAR (LAST OWNER)))
else (SETQ LATESTOWNER OWNER))
(if (NEQ CURRENTYEAR (CAR (LAST LATESTOWNER)))
then (NCONC1 LATESTOWNER CURRENTYEAR]
(PRINTCOPYRIGHT1 OWNER])
(PRINTCOPYRIGHT1
[LAMBDA (OWNER) (* ; "Edited 2-Feb-2024 17:45 by mth")
(* ; "Edited 21-Feb-2021 10:58 by rmk:")
(* ; "Edited 6-Apr-90 10:36 by jds")
(PROG (DATES CREATEDYEAR (SEMICOLON (AND (READTABLEPROP *READTABLE* 'COMMONLISP)
"; "))
(PRIVATE NIL))
(if (NOT (LISTP (CAR OWNER)))
then (SETQ OWNER (LIST OWNER)) (* ;
"Make the old format into the new format")
)
(COND
(SEMICOLON (* ; "do CommonLisp style comment")
(PRIN1 SEMICOLON))
(T (* ;
"Print IL-style comment, with a ; in it so the pretty printer will render it as a CL-style comment.")
(printout NIL "(* ; %"" T)))
(PRIN3 "Copyright (c) ")
(for OT O on OWNER do [SETQ DATES (CDR (SETQ O (CAR OT]
(COND
((EQ (CAR DATES)
T)
(SETQ PRIVATE T)
(pop DATES)))
[for Y START END on DATES
do (* ;
"print years of copyright, e.g., 1985, 1986. Print intervals for successive years")
(SETQ START (SETQ END (CAR Y)))
(* ;;
"For the PRIVATE notice below. It is always the EARLIEST year")
(SETQ CREATEDYEAR (OR CREATEDYEAR START))
(for NEXT in (CDR Y) while (EQ (ADD1 END)
NEXT) do (SETQ END NEXT)
(pop Y))
(PRIN3 START)
(CL:UNLESS (EQ START END)
(PRIN3 "-")
(PRIN3 END))
(COND
((CDR Y)
(PRIN3 ", "]
(PRIN3 " by ")
(PRIN3 (CAR O))
(PRIN3 ".")
(if (CDR OT)
then (TERPRI)
(COND
(SEMICOLON (PRIN1 SEMICOLON)))
(PRIN3 " And ")))
(AND COPYRIGHTSRESERVED (PRIN3 " All rights reserved."))
(TERPRI)
[COND
(PRIVATE (for LINE in (CONS (CONCAT "The following program was created in " (CAR DATES)
" but has not been published")
'(
"within the meaning of the copyright law, is furnished under license,"
"and may not be used, copied and/or disclosed except in accordance"
"with the terms of said license."))
do (COND
(SEMICOLON (PRIN1 SEMICOLON)))
(PRIN3 LINE)
(TERPRI]
(COND
((NOT SEMICOLON)
(PRIN3 "%")")
(TERPRI)))
(TERPRI])
(SAVECOPYRIGHT
(LAMBDA (FILENAME) (* lmm "25-DEC-82 16:48") (* ;; "Called from PRETTYDEF to save copyright info on end of file") (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) (PROG (X) (COND ((SETQ X (GETPROP FILENAME (QUOTE COPYRIGHT))) (PRINT (LIST (QUOTE PUTPROPS) FILENAME (QUOTE COPYRIGHT) X)))))))
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK%: NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T)
(NOLINKFNS PRINTCOPYRIGHT1))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER
COPYRIGHTSRESERVED)
)
(RPAQ? COPYRIGHTFLG )
(RPAQ? DEFAULTCOPYRIGHTOWNER )
(RPAQ? COPYRIGHTPRETTYFLG T)
(RPAQ? COPYRIGHTOWNERS )
(RPAQ? DEFAULTCOPYRIGHTKEYLST
'((NONE "
" EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE)
[%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T
KEYLST (( "
" RETURN (SUBSTRING (CADR ANSWER)
2 -2]
(%] "No copyright notice now
" EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL)))
(RPAQ? COPYRIGHTSRESERVED T)
(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
:XCCS))
(RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* )
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG
*DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*)
)
(RPAQ? COMMENTFLG '*)
(RPAQ? **COMMENT**FLG '" **COMMENT** ")
(RPAQ? PRETTYFLG T)
(RPAQ? %#RPARS 4)
(RPAQ? CLISPIFYPRETTYFLG )
(RPAQ? PRETTYTRANFLG )
(RPAQ? FONTCHANGEFLG )
(RPAQ? CHANGECHARTABSTR )
(RPAQ? PRETTYTABFLG T)
(RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY
DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD
EVAL@LOADWHEN FIRST NOTFIRST))
(RPAQ? AVERAGEVARLENGTH 4)
(RPAQ? AVERAGEFNLENGTH 5)
(RPAQ? %#CAREFULCOLUMNS 0)
(RPAQ? CHANGECHAR '%|)
(RPAQ? ENDLINEUSERFN )
(RPAQ? PRETTYDEFMACROS )
(RPAQ? PRETTYPRINTMACROS )
(RPAQ? PRETTYEQUIVLST )
(RPAQ? PRETTYPRINTYPEMACROS )
(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS
APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *))
(RPAQ? SYSPROPS
'(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE
DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE
CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP
CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR
FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR
HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE
OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK%: PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT)
(SPECVARS FNSLST FILEFLG))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER
FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS
COMMENTFLG)
)
(DECLARE%: EVAL@COMPILE DOCOPY
(CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG
PRETTYPRINTMACROS))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(FILESLOAD (IMPORT)
FILEPKG)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA PPT PP* PP)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018
2023 2024))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (5946 48598 (PRETTYDEF 5956 . 21629) (PRETTYDEFCOMS 21631 . 22313) (PRETTYDEF0 22315 .
22506) (PRETTYDEF1 22508 . 24271) (PRINTDATE 24273 . 25509) (PRINTDATE1 25511 . 27289) (PRINTFNS 27291
. 27860) (PRETTYCOM 27862 . 34203) (PRETTYVAR 34205 . 35243) (PRETTYVAR1 35245 . 37463) (PRETTYCOM1
37465 . 38169) (ENDFILE 38171 . 38267) (MAKEDEFLIST 38269 . 38673) (PP 38675 . 38951) (PP* 38953 .
39266) (PPT 39268 . 39587) (PRETTYPRINT 39589 . 42741) (PRETTYPRINT1 42743 . 44629) (PRETTYPRINT2
44631 . 45947) (PRETTYPRINT3 45949 . 46904) (PRINTDEF1 46906 . 47842) (SUPERPRINTEQ 47844 . 47938) (
SUPERPRINTGETPROP 47940 . 48084) (CHANGEFONT 48086 . 48596)) (48599 53945 (READARRAY 48609 . 49535) (
PRINTARRAY 49537 . 51277) (READARRAY-FROM-LIST 51279 . 52384) (PRINTARRAY-TO-LIST 52386 . 53943)) (
54072 62953 (PRINTCOPYRIGHT 54082 . 58556) (PRINTCOPYRIGHT1 58558 . 62648) (SAVECOPYRIGHT 62650 .
62951)))))
STOP