-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathBOOTSTRAP
994 lines (831 loc) · 47.5 KB
/
BOOTSTRAP
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
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Sep-2021 10:25:31"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;60 47698
changes to%: (FNS PRINT-READER-ENVIRONMENT READ-READER-ENVIRONMENT)
previous date%: "17-Aug-2021 00:08:39"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58)
(* ; "
Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT BOOTSTRAPCOMS)
(RPAQQ BOOTSTRAPCOMS
[(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO")
(FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP
PROPNAMES ADDPROP REMPROP MEMB CLOSEF?))
(COMS (* ;
"Need these in order to load even compiled files SYSLOAD")
(FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD
PUTPROPS DECLARE%: DECLARE%:1 ROOTFILENAME))
[COMS (* ; "For DEFINE-FILE-INFO")
(FNS DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO PRINT-READER-ENVIRONMENT
READ-READER-ENVIRONMENT MAKE-DEFINE-FILE-INFO-ENV)
(INITVARS (*DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV]
(INITVARS (EOLCHARCODE (CHCON1 "
"))
(PRETTYHEADER)
(DWIMFLG)
(UPDATEMAPFLG)
(DFNFLG)
(ADDSPELLFLG)
(BUILDMAPFLG)
(FILEPKGFLG)
(SYSFILES)
(NOTCOMPILEDFILES)
(RESETVARSLST)
[LOADPARAMETERS '((SEQUENTIAL T]
(LISPXHIST)
(LISPXPRINTFLG T)
(PRETTYHEADER "File created ")
(LOAD-VERBOSE-STREAM T)
(BELLS '"")
(LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP))
(PRETTYDEFMACROS NIL)
(PRETTYTYPELST NIL)
(FILEPKGTYPES NIL))
(ADDVARS (LOADEDFILELST))
(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
(DECLARE%: DONTEVAL@LOAD DOCOPY [P [MAPC '((PUTD . /PUTD)
(PUTPROP . /PUTPROP)
(PUTPROP . PUT)
(PUTPROP . SAVEPUT)
(ADDPROP . /ADDPROP)
(PUT . /PUT)
(PRIN1 . LISPXPRIN1)
(PRIN2 . LISPXPRIN2)
(PRINT . LISPXPRINT)
(TERPRI . LISPXTERPRI)
(SPACES . LISPXSPACES)
(GETPROP . GETP)
(SET . SAVESET)
(SET . /SET)
(NILL . MISSPELLED?)
(SETTOPVAL . /SETTOPVAL)
(BOOTSTRAP-NAMEFIELD . NAMEFIELD)
(NILL . RESETRESTORE))
(FUNCTION (LAMBDA (X)
(OR (CCODEP (CDR X))
(MOVD (CAR X)
(CDR X)
NIL T]
(AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
(PUTD 'BOOTSTRAP-NAMEFIELD]
(P (RADIX 10)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL")
(CONSTANTS FASL:SIGNATURE))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
(NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
(LAMA])
(* ;
"Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO"
)
(DEFINEQ
(GETPROP
[LAMBDA (ATM PROP) (* lmm " 5-SEP-83 22:29")
(* ; "Used to be called GETP")
(AND (LITATOM ATM)
(PROG ((PLIST (GETPROPLIST ATM)))
LP [COND
((OR (NLISTP PLIST)
(NLISTP (CDR PLIST)))
(RETURN NIL))
((EQ (CAR PLIST)
PROP)
(RETURN (CADR PLIST]
(SETQ PLIST (CDDR PLIST))
(GO LP])
(SETATOMVAL
[LAMBDA (X Y) (* bvm%: "29-Sep-86 16:14")
(SETTOPVAL X Y])
(RPAQQ
[NLAMBDA (X Y)
(SETATOMVAL X Y])
(RPAQ
[NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:10")
(* ;
"RPAQ and RPAQQ are used by PRETTYDEF to save VARS.")
(SETTOPVAL RPAQX (EVAL RPAQY])
(RPAQ?
[NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:12")
(* ;
"RPAQ? and RPAQQ are used by PRETTYDEF to save VARS.")
(OR (NEQ (GETTOPVAL RPAQX)
'NOBIND)
(SETTOPVAL RPAQX (EVAL RPAQY])
(MOVD
[LAMBDA (FROM TO COPYFLG DONTCOPY) (* ;
"Edited 2-Nov-92 03:50 by sybalsky:mv:envos")
(COND
((AND DONTCOPY (NULL COPYFLG))
(* ;; "He really wants NO copy made, not a renamed version.")
(* ;;
"This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.")
(LET ((FROMCELL (fetch (LITATOM DEFINITIONCELL) of FROM))
(TOCELL (fetch (LITATOM DEFINITIONCELL) of TO)))
(UNINTERRUPTABLY
(replace (DEFINITIONCELL DEFPOINTER) of TOCELL with (fetch
(DEFINITIONCELL
DEFPOINTER)
of FROMCELL))
(replace (DEFINITIONCELL DEFCELLFLAGS) of TOCELL with
(fetch (DEFINITIONCELL
DEFCELLFLAGS)
of FROMCELL))
(replace (DEFINITIONCELL AUXDEFCELLFLAGS) of TOCELL
with (fetch (DEFINITIONCELL AUXDEFCELLFLAGS) of FROMCELL))
TO)))
(T (LET [(NEWFLG (NULL (GETD TO]
(PUTD TO (COND
(COPYFLG (COPY (VIRGINFN FROM)))
(T (GETD FROM)))
DONTCOPY)
(AND FILEPKGFLG (EXPRP TO)
(MARKASCHANGED TO 'FNS NEWFLG))
TO])
(MOVD?
[LAMBDA (FROM TO COPYFLG DONTCOPY) (* bvm%: "10-Jul-85 13:00")
(* ;; "Like MOVD but only does it if TO is not defined.")
(COND
((NULL (GETD TO))
(PUTD TO (COND
(COPYFLG (COPY (VIRGINFN FROM)))
(T (GETD FROM)))
DONTCOPY)
(AND FILEPKGFLG (EXPRP TO)
(MARKASCHANGED TO 'FNS T))
TO])
(SELECTQ
[NLAMBDA SELCQ
(APPLY 'PROGN (SELECTQ1 (EVAL (CAR SELCQ)
'SELECTQ)
(CDR SELCQ))
'SELECTQ])
(SELECTQ1
[LAMBDA (M L)
(PROG (C)
LP (SETQ C L)
[COND
((NULL (SETQ L (CDR L)))
(RETURN C))
([OR (EQ (CAR (SETQ C (CAR C)))
M)
(AND (LISTP (CAR C))
(FMEMB M (CAR C]
(RETURN (CDR C]
(GO LP])
(NCONC1
[LAMBDA (LST X)
(* included in wtmisc so can make the call to nconc be linked.
so that user can then break on nconc.)
(NCONC LST (FRPLACD (CONS X LST])
(PUTPROP
[LAMBDA (ATM PROP VAL) (* ; "Edited 28-May-87 09:16 by jop")
(* ;; "Included because it must be defined before the MOVD's in BOOTSTRAPCOMS that initialize /PUTPROP are executed.")
[COND
((NOT (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0)
LP (COND
((NLISTP X)
(COND
((AND (NULL X)
X0) (* ;
"typical case. property list ran out on an even parity position. e.g. (A B C D)")
(FRPLACD (CDR X0)
(LIST PROP VAL))
(RETURN VAL)))
(* ;; "propety list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")
)
((NLISTP (CDR X))
(* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g. (A B C) or (A B C . D) fall through and add at beginning")
)
((EQ (CAR X)
PROP)
(FRPLACA (CDR X)
VAL)
(RETURN VAL))
(T (SETQ X (CDDR (SETQ X0 X)))
(GO LP)))
[SETPROPLIST ATM (CONS PROP (CONS VAL (GETPROPLIST ATM]
(RETURN VAL])
(PROPNAMES
[LAMBDA (ATM) (* wt%: " 3-AUG-78 01:23")
(MAPLIST (GETPROPLIST ATM)
(FUNCTION CAR)
(FUNCTION CDDR])
(ADDPROP
[LAMBDA (ATM PROP NEW FLG) (* ;
"If FLG is T, NEW is consed onto the front, otherwise NCONCED onto the end.")
(* ; "Value is new PROP value.")
[COND
[(NULL ATM)
(ERRORX (LIST 7 (LIST PROP NEW]
((NOT (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0)
LP (COND
((NLISTP X)
(COND
((AND (NULL X)
X0) (* ;
"typical case. property list ran out on an even parity position.")
[FRPLACD (CDR X0)
(LIST PROP (SETQ NEW (LIST NEW]
(RETURN NEW)))
(* ;; "proprty list was initially NIL or a non-lit, or ele it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add property at beginning of property list.")
)
((NLISTP (CDR X))
(* ;; "property list runs out on an odd parity, or else ends in a non-list following an odd parity, e.g. (A B C) or (A B C . D) fall through and add at beginning")
)
((EQ (CAR X)
PROP) (* ; "PROP found")
[FRPLACA (CDR X)
(SETQ NEW (COND
(FLG (CONS NEW (CADR X)))
(T (NCONC1 (CADR X)
NEW]
(RETURN NEW))
(T (SETQ X (CDDR (SETQ X0 X)))
(GO LP))) (* ;
"Add to beginning of property list.")
[SETPROPLIST ATM (CONS PROP (CONS (SETQ NEW (LIST NEW))
(GETPROPLIST ATM]
(RETURN NEW])
(REMPROP
[LAMBDA (ATM PROP) (* bvm%: "17-Sep-86 17:29")
[COND
((NULL (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0 VAL)
LP [COND
((OR (NLISTP X)
(NLISTP (CDR X)))
(RETURN VAL))
((EQ (CAR X)
PROP)
(SETQ VAL (OR PROP T)) (* ; "T in case indicator is NIL")
[COND
(X0 (FRPLACD (CDR X0)
(CDDR X)))
(T (SETPROPLIST ATM (CDDR X] (* ; "iterate in case there are more occurrences. Shouldn't happen unless users manually clobber prop list")
(SETQ X (CDDR X)))
(T (SETQ X (CDDR (SETQ X0 X]
(GO LP])
(MEMB
[LAMBDA (X Y)
(PROG NIL
LP (RETURN (COND
((NLISTP Y)
NIL)
((EQ X (CAR Y))
Y)
(T (SETQ Y (CDR Y))
(GO LP])
(CLOSEF?
[LAMBDA (FL) (* wt%: 18-MAR-77 12 20)
(* ;
"useful for resetsaves, in case somebody else might close the file.")
(AND FL (OPENP FL)
(CLOSEF FL])
)
(* ; "Need these in order to load even compiled files SYSLOAD")
(DEFINEQ
(LOAD
[LAMBDA (FILE LDFLG PRINTFLG PACKAGE) (* ; "Edited 9-Apr-87 18:44 by bvm:")
(RESETLST (PROG (STREAM TEM)
TOP (if (FMEMB LDFLG LOADOPTIONS)
elseif (AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
then (SETQ LDFLG TEM)
else (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
(GO TOP))
[if (AND PACKAGE (NOT (CL:PACKAGEP PACKAGE)))
then (* ;
"Make sure package arg is ok, too")
(SETQ PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
(\DTEST PACKAGE 'PACKAGE]
[RESETSAVE NIL (LIST 'CLOSEF? (SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD
LOADPARAMETERS]
(RETURN (\LOAD-STREAM STREAM LDFLG PRINTFLG (AND PRETTYHEADER T)
PACKAGE])
(\LOAD-STREAM
[LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)
(DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM))
(* ; "Edited 17-Jul-2021 21:58 by rmk:")
(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
(PROG ((*STANDARD-INPUT* STREAM)
(FILE (FULLNAME STREAM))
(*PACKAGE* *PACKAGE*)
(*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")
))
(DFNFLG DFNFLG)
(BUILDMAPFLG BUILDMAPFLG)
(FILEPKGFLG FILEPKGFLG)
(ADDSPELLFLG ADDSPELLFLG)
(LISPXHIST LISPXHIST)
(PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
(DEFINEDENV)
FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P
FILECREATEDLOC)
(DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST
DEFINEDENV FILECREATEDLOC FILE))
(if (AND LOAD-VERBOSE-STREAM FILE)
then (LISPXTERPRI LOAD-VERBOSE-STREAM)
(if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
"CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; Loading " LOAD-VERBOSE-STREAM))
(* ;
"Might use EXEC-FORMAT here except that it isn't defined early in loadup")
(LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
(LISPXTERPRI LOAD-VERBOSE-STREAM))
(if (EQ (SETQ DFNFLG LDFLG)
'SYSLOAD)
then (SETQ DFNFLG T)
(SETQ ADDSPELLFLG NIL)
(SETQ BUILDMAPFLG NIL)
(SETQ FILEPKGFLG NIL)
(SETQ LISPXHIST NIL))
(if LISPXHIST
then (* ;
"Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
(if (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
then (FRPLACA (CADR LOADA)
-1)
else (LISPXPUT 'SIDE (LIST -1)
NIL LISPXHIST)))
(if (EQ (SETQ TEM (SKIPSEPRCODES STREAM))
FASL:SIGNATURE)
then (* ;
"FASL file handled by FASL loader")
(FASL:PROCESS-FILE STREAM)
[LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T))
'FILEDATES]
(if (NOT (MEMB FILE LOADEDFILELST))
then (* ;
"Keep track of every file loaded.")
(SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
(if MANAGED-FILE-P
then (if (EQ LDFLG 'SYSLOAD)
then
(* ;;
"Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")
(if (NOT (MEMB ROOTNAME SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES
ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then (ADDFILE ROOTNAME 'Compiled]
(RETURN FILE)
elseif (NEQ TEM (CHARCODE "("))
then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)))
(if (AND BUILDMAPFLG (RANDACCESSP STREAM))
then (SETQ MAYBEWANTFILEMAP T))
(* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.")
(SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM *OLD-INTERLISP-READ-ENVIRONMENT*))
(CL:WHEN PACKAGE
(* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.")
[SETQ DEFINEDENV (CREATE READER-ENVIRONMENT USING DEFINEDENV REPACKAGE _
(SETQ *PACKAGE*
(\DTEST PACKAGE 'PACKAGE])
(* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.")
(WITH-READER-ENVIRONMENT DEFINEDENV
(PROG (ADR)
LP (if FILEMAP
then (* ;
"need to build map, so read carefully")
(SETQ LOADA (SKIPSEPRCODES STREAM))
(if (OR (SYNTAXP LOADA 'LEFTPAREN)
(SYNTAXP LOADA 'LEFTBRACKET))
then (* ; "See if we have a DEFINEQ")
(SETQ ADR (GETFILEPTR STREAM))
(READCCODE STREAM) (* ; "Eat paren")
(if (EQ (RATOM STREAM)
'DEFINEQ)
then (SETQ FNADRLST (TCONC NIL ADR))
(TCONC FNADRLST NIL)
(TCONC FILEMAP (CAR FNADRLST))
(GO DEFQLP))
(* ; "Not a DEFINEQ, so back out")
(SETFILEPTR STREAM ADR)))
(SELECTQ (SETQ LOADA (READ STREAM))
((STOP NIL)
(if (EQ LDFLG 'SYSLOAD)
then (if (NOT (MEMB (SETQ ROOTNAME
(ROOTFILENAME FILE
(CDR FILECREATEDLST)))
SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES
ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then
(* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
(ADDFILE FILE T PRLST FILECREATEDLST))
[if FILEMAP
then (PUTFILEMAP FILE (CAR FILEMAP)
FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC)
(if UPDATEMAPFLG
then (SETFILEPTR STREAM ADR)
(* ;
"address of last expression read. good hint for finding filemap")
(UPDATEFILEMAP STREAM (CAR FILEMAP]
(if (NOT (MEMB FILE LOADEDFILELST))
then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
(RETURN))
NIL)
[if (LISTP LOADA)
then
(SELECTQ (CAR LOADA)
(FILECREATED (if MAYBEWANTFILEMAP
then (* ; "See if we have a valid file map")
(SETQ ADR (GETFILEPTR STREAM))
(if [AND (FIXP (SETQ TEM (CADDDR LOADA)))
[SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
TEM)
(READ STREAM]
(EQ (CAR TEM)
'FILEMAP)
(NULL (CAR (SETQ TEM (CADR TEM]
then (* ; "Has ok map")
(PUTFILEMAP FILE TEM NIL DEFINEDENV)
else (* ;
"Need to build a file map as we go")
(SETQ FILEMAP (TCONC NIL NIL)))
(SETFILEPTR STREAM ADR)
(SETQ MAYBEWANTFILEMAP NIL))
(SETQ LOADA (\EVAL LOADA)))
(SETQ LOADA (\EVAL LOADA)))
else (* ;
"Atom found. Compiled code definition.")
(if ADDSPELLFLG
then (ADDSPELL LOADA))
(if FILEMAP
then (SETQ ADR (GETFILEPTR STREAM)))
(LAPRD LOADA)
(if FILEMAP
then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
LOADA]
LP1 (if PRINTFLG
then (PRINT LOADA PRINTFLG))
(GO LP)
DEFQLP
(SELCHARQ (SKIPSEPRCODES STREAM)
((%) %]) (* ; "Closes DEFINEQ.")
(READCCODE STREAM)
(if FNADRLST
then (RPLACA (CDAR FNADRLST)
(GETFILEPTR STREAM)))
(* ;
"FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
(SETQ LOADA (DEFINE (DREVERSE LOADA)))
(GO LP1))
((%( %[) (* ;
"another function/definition pair")
(SETQ ADR (GETFILEPTR STREAM))
(SETQ LOADA (CONS (READ STREAM)
LOADA))
[if FNADRLST
then (TCONC FNADRLST (CONS (CAAR LOADA)
(CONS ADR (GETFILEPTR STREAM]
(GO DEFQLP))
NIL)
(ERROR "illegal argument in defineq")))
(RETURN FILE])
(FILECREATED
[NLAMBDA X (* ; "Edited 12-Jan-88 10:44 by bvm")
(DECLARE (USEDFREE FILECREATEDLST LOAD-VERBOSE-STREAM))
(PROG ((FILEDATE (CAR X))
(FILE (CADR X)))
(SETQ FILECREATEDLST (NCONC1 FILECREATEDLST X))
(COND
(LOAD-VERBOSE-STREAM
(* ;; "Presumably if user sets prettyheader to NIL, he doesnt want to see any file created messages, even those frm compiled files.")
(if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
"CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; " LOAD-VERBOSE-STREAM))
(LISPXPRIN1 (FILECREATED1 X)
LOAD-VERBOSE-STREAM)
(LISPXPRIN1 FILEDATE LOAD-VERBOSE-STREAM)
(LISPXTERPRI LOAD-VERBOSE-STREAM)))
(COND
((AND FILE (NLISTP FILE))
(* ;; "This is just temporary, primarily for keeping dates of system files which are loaded with FILEPKGFLG=NIL. The real setting up of file property lists is done when ADDFILE is called.")
(/PUT (ROOTFILENAME FILE)
'FILEDATES
(LIST (CONS FILEDATE FILE])
(FILECREATED1
[LAMBDA (X) (* ; "Edited 12-Jan-88 10:44 by bvm")
(* ;; "performs error checking on filecreated expressions. returns the thing to be printed. used by filecreated, and loadfns.")
(* ;; "FILECREATED expression for source file is of form (FILECREATED date filename mapaddress . historyinfo). For compiled file, is of form (FILECREATED date (%"compiled on%" sourceFile)). ")
(LET ((FILE (CADR X)))
(COND
((AND NIL (STRINGP FILE)) (* ;
"old way of doing COMPILED ON -- we no longer have such files, and the file name can be a string.")
FILE)
((LISTP FILE) (* ;
"New. also used for printing COMPILED ON message. CDR is a list of files that were compiled.")
(CAR FILE))
(T (* ;
"FILE is atomic, the name of the file")
PRETTYHEADER])
(PRETTYCOMPRINT
[NLAMBDA (X) (* bvm%: "22-Sep-86 17:02")
(if LOAD-VERBOSE-STREAM
then (if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
"CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; " LOAD-VERBOSE-STREAM))
(LISPXPRINT X LOAD-VERBOSE-STREAM])
(BOOTSTRAP-NAMEFIELD
[LAMBDA (FILE SUFFIXFLG) (* bvm%: " 2-Aug-86 14:50")
(* ;; "BOOTSTRAP VERSION -- this is replaced by real version from MACHINEINDEPENDENT")
(PROG ((START 1)
POS END)
(while (SETQ POS (OR (STRPOS '} FILE START)
(STRPOS '> FILE START)
(STRPOS '/ FILE START))) do (SETQ START (ADD1 POS)))
[COND
((SETQ POS (STRPOS '; FILE))
(SETQ END (SUB1 POS))
(COND
((EQ (NTHCHARCODE FILE END)
(CHARCODE ".")) (* ; "eliminates null suffix")
(SETQ END (SUB1 END]
[COND
((SETQ POS (STRPOS '%. FILE START))
(COND
((NULL SUFFIXFLG)
(SETQ END (SUB1 POS]
(RETURN (SUBATOM FILE START END])
(PUTPROPS
[NLAMBDA X (* bvm%: " 8-Sep-86 11:20")
(* ;; "Later in the loadup, the PUTPROP is changed to SAVEPUT")
(MAP (CDR X)
[FUNCTION (LAMBDA (Y)
(PUTPROP (CAR X)
(CAR Y)
(CADR Y]
(FUNCTION CDDR])
(DECLARE%:
[NLAMBDA X (* wt%: "20-OCT-77 13:00")
(DECLARE%:1 X T])
(DECLARE%:1
[LAMBDA (X EVALFLG) (* wt%: "20-OCT-77 13:09")
(PROG NIL
LP (COND
((NLISTP X)
(RETURN))
[(LISTP (CAR X))
(AND EVALFLG (COND
((EQ (CAAR X)
'DECLARE%:)
(DECLARE%:1 (CDAR X)
T))
(T (EVAL (CAR X]
(T (SELECTQ (CAR X)
((EVAL@LOAD DOEVAL@LOAD)
(SETQ EVALFLG T))
(EVAL@LOADWHEN (SETQ EVALFLG (EVAL (CADR X)))
(SETQ X (CDR X)))
(DONTEVAL@LOAD (SETQ EVALFLG NIL))
NIL)))
(SETQ X (CDR X))
(GO LP])
(ROOTFILENAME
[LAMBDA (NAME COMPFLG) (* ; "Edited 22-May-92 11:59 by jds")
(* ;; "Returns the root of the filename NAME, the atom that all file package properties will be associated with. If NAME names a compiled file, then COMPFLG~=NIL and we assume that the extension is COMPILE.EXT, which is to be stripped off. We thus have something of an anomaly: We can keep track of 2 symbolic files whose names differ only in extension, but we confuse them when we deal with their compiled versions.")
(* ;; "The name is always returned in upper case, so that file-system case dependencies don't carry over into Medley, where source file names are NOT case dependent. JDS, fixing AR 11518 5/21/92")
(U-CASE (NAMEFIELD (COND
((TYPEP NAME 'STREAM)
(FULLNAME NAME))
(T NAME))
(NOT COMPFLG])
)
(* ; "For DEFINE-FILE-INFO")
(DEFINEQ
(DEFINE-FILE-INFO
[NLAMBDA ARGS (* bvm%: "13-Oct-86 17:24")
(* ;; "Evaluated when it appears at top of file. Caller (e.g., LOAD) binds reader environment, so we just set it. Also return the env in case someone wants it.")
(DECLARE (USEDFREE FILECREATEDLOC))
(SETQ FILECREATEDLOC (GETFILEPTR))
(SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL ARGS])
(\DO-DEFINE-FILE-INFO
[LAMBDA (STREAM ARGS) (* ; "Edited 17-Aug-2021 00:05 by rmk:")
(* ;;; "Processes the (DEFINE-FILE-INFO . ARGS) at the front of STREAM. This converts the ARGS list to a READER-ENVIRONMENT, and also imposes the external format on STREAM, if non-NIL.")
(* ;; "Include the :PACKAGE... for bootstrapping before in sysouts without an updated version of \LOAD-STREAM")
(* ;;; "")
(* ;;; "The LISTP forms for package and readtable are to allow for those to be created if they don't already exist. If they do exist, the forms should not make any incompatiblel changes--those should be in a file command somewhere.")
(* ;;; "It doesn't make sense to produce an a new number base by evaluation in a particular runtime environment. I'm leaving this in for reading, for backward compatibility. Presumably future writing will instantiate to the particular number.")
(LET (PACKAGE READTABLE BASE FORMAT VALUE PACKAGEFORM READTABLEFORM)
[for TAIL on ARGS by (CDDR TAIL)
do (SETQ VALUE (CADR TAIL))
(SELECTQ (CAR TAIL)
((:PACKAGE %:PACKAGE)
(SETQ PACKAGE (if (LISTP VALUE)
then (SETQ PACKAGEFORM VALUE)
(EVAL VALUE)
ELSE VALUE))
(IF (TYPEP PACKAGE 'PACKAGE)
ELSEIF (SETQ PACKAGE (CL:FIND-PACKAGE PACKAGE))
ELSE
(* ;; "Better message than just \DTEST")
(ERROR
"Can't find package for DEFINE-FILE-INFO reader environment"
VALUE)))
((:READTABLE %:READTABLE)
(SETQ READTABLE (if (LISTP VALUE)
then (SETQ READTABLEFORM VALUE)
(EVAL VALUE)
ELSE VALUE))
(IF (TYPEP READTABLE 'READTABLEP)
ELSEIF (SETQ READTABLE (FIND-READTABLE READTABLE))
ELSE
(* ;; "Better message than just \DTEST")
(ERROR
"Can't find read table for DEFINE-FILE-INFO reader environment"
VALUE)))
((:BASE %:BASE) (* ;
"RMK: An EVAL form here makes no sense. ")
(SETQ BASE (OR (\CHECKRADIX (if (LISTP VALUE)
then (EVAL VALUE)
else VALUE))
(ERROR
"Bad read base for DEFINE-FILE-INFO reader environment"
VALUE))))
((:FORMAT FORMAT %:FORMAT)
(SETQ FORMAT (FETCH (EXTERNALFORMAT NAME) OF (FIND-FORMAT
VALUE))))
(ERROR "Unrecognized file info key" (CAR TAIL]
(* ;; "Set the defaults. Is this essentially ignoring the *DEFAULT-MAKEFILE-ENVIRONMENT*? Maybe the defaults should be take from there?")
(CL:UNLESS FORMAT (SETQ FORMAT :XCCS))
(CL:WHEN STREAM (\EXTERNALFORMAT STREAM FORMAT))
(create READER-ENVIRONMENT
REPACKAGE _ (OR PACKAGE *INTERLISP-PACKAGE*)
REREADTABLE _ (OR READTABLE FILERDTBL)
REBASE _ (OR BASE 10)
REFORMAT _ FORMAT
REPACKAGEFORM _ PACKAGEFORM
REREADTABLEFORM _ READTABLEFORM])
(PRINT-READER-ENVIRONMENT
[LAMBDA (ENV STREAM) (* ; "Edited 27-Sep-2021 10:24 by rmk:")
(* ;;; "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.")
(CL:UNLESS (EQUAL-READER-ENVIRONMENT ENV *OLD-INTERLISP-READ-ENVIRONMENT*)
(LET ((*PACKAGE* *INTERLISP-PACKAGE*)
(*PRINT-BASE* 10)
PKG RDTBL)
[SETQ PKG (IF (FETCH REPACKAGEFORM OF ENV)
ELSEIF (fetch REPACKAGE of ENV)
THEN (CL:PACKAGE-NAME (fetch REPACKAGE of ENV]
[SETQ RDTBL (IF (FETCH REREADTABLEFORM OF ENV)
ELSEIF (fetch REREADTABLE of ENV)
THEN (READTABLEPROP (fetch REREADTABLE of ENV)
'NAME]
(PRINT [CONS 'DEFINE-FILE-INFO
`(,@[AND PKG `(:PACKAGE ,PKG]
,@[AND RDTBL `(:READTABLE ,RDTBL]
:BASE
,(fetch REBASE of ENV)
,@(CL:UNLESS (EQ :XCCS (FETCH REFORMAT OF ENV))
`(:FORMAT ,(FETCH REFORMAT OF ENV)))]
STREAM
(FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*))
(TERPRI STREAM)))])
(READ-READER-ENVIRONMENT
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:")
(* ;; "Starting environment is the old interlisp file, just for the seprchar scans.")
(* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE")
(CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*))
(LET ((START (GETFILEPTR STREAM))
ARGS
(ENV DEFAULTENV)
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF
*OLD-INTERLISP-READ-ENVIRONMENT*
)))
(DECLARE (SPECVARS *READTABLE*))
(SELCHARQ (SKIPSEPRCODES STREAM)
(";" (* ; "Assume it's a common lisp file")
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
*COMMON-LISP-READ-ENVIRONMENT*
))
*COMMON-LISP-READ-ENVIRONMENT*)
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
*DEFINE-FILE-INFO-ENV*
)) (* ;
"Should we reset the format if we fail?")
(READCCODE STREAM)
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
(IF (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
THEN
(* ;;
"After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.")
[SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS
(CL:READ-DELIMITED-LIST
(CHARCODE ")")
STREAM]
ELSE (* ; "Hope we are RANDACCESSP")
(SETFILEPTR STREAM START))
(* ;;
"If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.")
(CL:IF (AND RETURNFORM ARGS)
(CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS))
ENV)))
DEFAULTENV])
(MAKE-DEFINE-FILE-INFO-ENV
[LAMBDA NIL (* ; "Edited 29-Jul-2021 20:29 by rmk:")
(* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim")
(LET [(RTBL (COPYREADTABLE (FETCH REREADTABLE OF *OLD-INTERLISP-READ-ENVIRONMENT*]
(* ;;
"But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ")
(* (READTABLEPROP RTBL
(QUOTE PACKAGECHAR)
(CHARCODE %:)))
(SETSYNTAX (CHARCODE %:)
'PACKAGEDELIM RTBL) (* ;
"In transition: read : but don't yet put it out")
(* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP")
(CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL
])
)
(RPAQ? *DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV))
(RPAQ? EOLCHARCODE (CHCON1 "
"))
(RPAQ? PRETTYHEADER )
(RPAQ? DWIMFLG )
(RPAQ? UPDATEMAPFLG )
(RPAQ? DFNFLG )
(RPAQ? ADDSPELLFLG )
(RPAQ? BUILDMAPFLG )
(RPAQ? FILEPKGFLG )
(RPAQ? SYSFILES )
(RPAQ? NOTCOMPILEDFILES )
(RPAQ? RESETVARSLST )
(RPAQ? LOADPARAMETERS '((SEQUENTIAL T)))
(RPAQ? LISPXHIST )
(RPAQ? LISPXPRINTFLG T)
(RPAQ? PRETTYHEADER "File created ")
(RPAQ? LOAD-VERBOSE-STREAM T)
(RPAQ? BELLS '"")
(RPAQ? LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP))
(RPAQ? PRETTYDEFMACROS NIL)
(RPAQ? PRETTYTYPELST NIL)
(RPAQ? FILEPKGTYPES NIL)
(ADDTOVAR LOADEDFILELST )
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
[MAPC '((PUTD . /PUTD)
(PUTPROP . /PUTPROP)
(PUTPROP . PUT)
(PUTPROP . SAVEPUT)
(ADDPROP . /ADDPROP)
(PUT . /PUT)
(PRIN1 . LISPXPRIN1)
(PRIN2 . LISPXPRIN2)
(PRINT . LISPXPRINT)
(TERPRI . LISPXTERPRI)
(SPACES . LISPXSPACES)
(GETPROP . GETP)
(SET . SAVESET)
(SET . /SET)
(NILL . MISSPELLED?)
(SETTOPVAL . /SETTOPVAL)
(BOOTSTRAP-NAMEFIELD . NAMEFIELD)
(NILL . RESETRESTORE))
(FUNCTION (LAMBDA (X)
(OR (CCODEP (CDR X))
(MOVD (CAR X)
(CDR X)
NIL T]
(AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
(PUTD 'BOOTSTRAP-NAMEFIELD))
(RADIX 10)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ FASL:SIGNATURE 145)
(CONSTANTS FASL:SIGNATURE)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
(ADDTOVAR NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
(ADDTOVAR LAMA )
)
(PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
1992 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4751 14423 (GETPROP 4761 . 5333) (SETATOMVAL 5335 . 5464) (RPAQQ 5466 . 5519) (RPAQ
5521 . 5833) (RPAQ? 5835 . 6205) (MOVD 6207 . 8071) (MOVD? 8073 . 8503) (SELECTQ 8505 . 8692) (
SELECTQ1 8694 . 9036) (NCONC1 9038 . 9234) (PUTPROP 9236 . 10720) (PROPNAMES 10722 . 10913) (ADDPROP
10915 . 12978) (REMPROP 12980 . 13834) (MEMB 13836 . 14095) (CLOSEF? 14097 . 14421)) (14496 35060 (
LOAD 14506 . 15675) (\LOAD-STREAM 15677 . 28751) (FILECREATED 28753 . 30171) (FILECREATED1 30173 .
31281) (PRETTYCOMPRINT 31283 . 31768) (BOOTSTRAP-NAMEFIELD 31770 . 32730) (PUTPROPS 32732 . 33100) (
DECLARE%: 33102 . 33234) (DECLARE%:1 33236 . 34108) (ROOTFILENAME 34110 . 35058)) (35098 45530 (
DEFINE-FILE-INFO 35108 . 35543) (\DO-DEFINE-FILE-INFO 35545 . 39891) (PRINT-READER-ENVIRONMENT 39893
. 41475) (READ-READER-ENVIRONMENT 41477 . 44252) (MAKE-DEFINE-FILE-INFO-ENV 44254 . 45528)))))
STOP