-
-
Notifications
You must be signed in to change notification settings - Fork 25
/
Copy pathGENERIC-INIT
1343 lines (648 loc) · 101 KB
/
GENERIC-INIT
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
995
996
997
998
999
1000
(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL")
(filecreated "21-Sep-88 11:02:16" |{EG:PARC:XEROX}<LANNING>LISP>USERS>GENERIC-INIT.;108| 102770
|changes| |to:| (advice files? cl:compile makefile getpromptwindow) (vars rooms-init-commands mail-init-commands unix-init-commands loops-init-commands tedit-init-commands pcl-init-commands generic-initcoms who-line-commands display-control-init-commands chat-init-commands)
(commands "MORE" "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY")
(functions xcl-user::log-generic-init-user eval-at-greet notice make oam de file |PickOneAtRandom| atom-neighbors load-nova-fonts)
|previous| |date:| "19-Sep-88 09:26:30" |{EG:PARC:XEROX}<LANNING>LISP>USERS>GENERIC-INIT.;107|
)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(prettycomprint generic-initcoms)
(rpaqq generic-initcoms ((* |;;| "Macro to avoid problems when trying to maintain file.") (coms (p (cl:proclaim (quote (global *generic-init-loaded*)))) (initvars (*generic-init-loaded* nil)) (functions eval-at-greet)) (* |;;| "Silent loads") (coms (p (cl:proclaim (quote (global *load-silent* prettyheader)))) (initvars (*load-silent* nil)) (vars (\\original-load-verbose *load-verbose*) (\\original-prettyheader prettyheader) (*load-verbose* (if *load-silent* then nil else *load-verbose*)) (prettyheader (if *load-silent* then nil else prettyheader)))) (* |;;| "Environment setup") (coms * compute-directories-init-commands) (coms * env-tailoring-init-commands) (coms * patch-init-commands) (coms (* |;;| "Wants to be (COMS * FILECACHE-INIT-COMMANDS), but the FileCrasher doesn't exist in Lyric, yet. Probably never will.") (vars filecache-init-commands)) (coms * font-setup-init-commands) (declare\: eval@loadwhen (not *generic-init-loaded*) donteval@compile docopy (files (sysload from lispusers) loadmenuitems)) (* |;;| "Machine status") (coms * who-line-commands) (coms * vstats-init-commands) (* |;;| "Display control") (coms * screen-setup-init-commands) (coms * rooms-init-commands) (coms * change-background-init-commands) (coms * display-control-init-commands) (coms * idle-init-commands) (coms * clock-init-commands) (* |;;| "Programming stuff") (coms * programming-init-commands) (coms * old-utils-commands) (coms * wizard-init-commands) (coms * dinfo-init-commands) (coms * pcl-init-commands) (coms * loops-init-commands) (* |;;| "Documentation") (coms * tedit-init-commands) (coms * sketch-init-commands) (coms * notecards-init-commands) (* |;;| "Communication & Info") (coms * mail-init-commands) (coms * chat-init-commands) (coms * talk-init-commands) (coms * calendar-init-commands) (coms * printer-init-commands) (coms * db-init-commands) (coms * nfs-init-commands) (* |;;| "Files") (coms * file-watch-init-commands) (coms * file-server-init-commands) (coms * dirgrapher-init-commands) (coms * fb-init-commands) (coms * compare-files-init-commands) (* |;;| "Random stuff") (coms * unix-init-commands) (coms * demos-init-commands) (coms * games-init-commands) (* |;;| "Cleanup") (coms * background-menu-cleanup-init-commands) (coms * do-load-utilities-init-commands) (coms (* |;;| "Send the Tool Work's a message telling it about this user.") (functions xcl-user::log-generic-init-user) (initvars (\\cc-generic-init-msg t)) (p (eval-at-greet (cl:unless *generic-init-loaded* (xcl-user::log-generic-init-user))))) (vars (*load-verbose* \\original-load-verbose) (prettyheader \\original-prettyheader) (*generic-init-loaded* t)) (* |;;| "Make the FileManager happy") (declare\: dontcopy (prop makefile-environment generic-init))))
(* |;;| "Macro to avoid problems when trying to maintain file.")
(cl:proclaim (quote (global *generic-init-loaded*)))
(rpaq? *generic-init-loaded* nil)
(defmacro eval-at-greet (&body forms) "Evaluate the forms only when loading the compiled file, and then only when greeting" (bquote (cl:eval-when (cl:load) (cl:unless (or *generic-init-loaded* (memb dfnflg (quote (prop allprop)))) (\\\,@ forms)))))
(* |;;| "Silent loads")
(cl:proclaim (quote (global *load-silent* prettyheader)))
(rpaq? *load-silent* nil)
(rpaq \\original-load-verbose *load-verbose*)
(rpaq \\original-prettyheader prettyheader)
(rpaq *load-verbose* (if *load-silent* then nil else *load-verbose*))
(rpaq prettyheader (if *load-silent* then nil else prettyheader))
(* |;;| "Environment setup")
(rpaqq compute-directories-init-commands ((* |;;| "Who am I?") (declare\: donteval@compile (vars (|\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name)))) (loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (concat "{PHYLUM}<" |\\BasicUserName| ">LISP>")) (t loginhost/dir))))) (initvars (|\\UserHomeDirectory| (u-case (packfilename.string (quote host) (filenamefield loginhost/dir (quote host)) (quote directory) |\\BasicUserName|))) (tempdir (concat |\\UserHomeDirectory| "TEMP>")) (home-machine-name "") (private-lispusersdirectories nil) (*cache-directories* nil))))
(* |;;| "Who am I?")
(declare\: donteval@compile
(rpaq |\\BasicUserName| (let* ((name (username)) (registry-pos (strpos "." name nil nil nil nil nil t))) (cond (registry-pos (substring name 1 (sub1 registry-pos))) (t name))))
(rpaq loginhost/dir (cond ((or (null loginhost/dir) (eq loginhost/dir (quote {dsk}))) (concat "{PHYLUM}<" |\\BasicUserName| ">LISP>")) (t loginhost/dir)))
)
(rpaq? |\\UserHomeDirectory| (u-case (packfilename.string (quote host) (filenamefield loginhost/dir (quote host)) (quote directory) |\\BasicUserName|)))
(rpaq? tempdir (concat |\\UserHomeDirectory| "TEMP>"))
(rpaq? home-machine-name "")
(rpaq? private-lispusersdirectories nil)
(rpaq? *cache-directories* nil)
(rpaqq env-tailoring-init-commands ((* |;;;| " Misc environmental tailoring") (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) pagehold) (vars (|MaxValueLeftMargin| 512) (scrollbarwidth 20) (fixspelldefault (quote \n)) (\\ethertimeout 3000) (empress#sides 2) (*print-case* :downcase)) (* |;;| "FileManager defaults") (vars (cleanupoptions (quote (rc st))) (copyrightflg (quote default)) (recompiledefault (quote exprs)) (*default-cleanup-compiler* (quote cl:compile-file)) (*default-makefile-environment* (quote (:package "XCL-USER" :readtable "XCL" :base 10)))) (* |;;| "None of us here are system hackers") (vars (*original-give-and-take-directories* *give-and-take-directories*) (*give-and-take-directories* (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*))) (* |;;| "I don't like being told that I haven't listed files...") (advise files?) (* |;;| "Load up the extended vmem stuff") (p (eval-at-greet (cl:when (and (eq makesysname (quote :lyric)) (eq (machinetype) (quote dorado))) (filesload (sysload from lispusers) extendedvmem) (install-extended-virtual-memory)) (cl:when (cl:fboundp (quote describe-virtual-memory)) (describe-virtual-memory)))) (* |;;| "Check greetdates whenever I log back in") (addvars (afterlogoutforms (|for| greet-date |in| greetdates |bind| (today _ (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t)))))))
(* |;;;| " Misc environmental tailoring")
(declare\: donteval@load donteval@compile
(filesload (sysload noerror from lispusers) pagehold)
(rpaqq |MaxValueLeftMargin| 512)
(rpaqq scrollbarwidth 20)
(rpaqq fixspelldefault \n)
(rpaqq \\ethertimeout 3000)
(rpaqq empress#sides 2)
(rpaq *print-case* :downcase)
(rpaqq cleanupoptions (rc st))
(rpaqq copyrightflg default)
(rpaqq recompiledefault exprs)
(rpaqq *default-cleanup-compiler* cl:compile-file)
(rpaqq *default-makefile-environment* (:package "XCL-USER" :readtable "XCL" :base 10))
(rpaq *original-give-and-take-directories* *give-and-take-directories*)
(rpaq *give-and-take-directories* (cl:remove-if (cl:function (cl:lambda (file) (cl:member (cl:pathname-host file) (quote ("ERIS" "ERINYES")) :test (cl:function string-equal)))) *give-and-take-directories*))
(xcl:reinstall-advice (quote files?) :before (quote ((:last (setq notlistedfiles nil)))))
(readvise files?)
(eval-at-greet (cl:when (and (eq makesysname (quote :lyric)) (eq (machinetype) (quote dorado))) (filesload (sysload from lispusers) extendedvmem) (install-extended-virtual-memory)) (cl:when (cl:fboundp (quote describe-virtual-memory)) (describe-virtual-memory)))
(addtovar afterlogoutforms (|for| greet-date |in| greetdates |bind| (today _ (date)) |when| (eql 1 (strpos (car greet-date) today nil nil nil nil (uppercasearray))) |do| (|printout| t t (cdr greet-date) t)))
)
(rpaqq patch-init-commands ((* |;;;| " Patches") (fns purge-file-advice purge-advice) (declare\: donteval@load donteval@compile (* |;;| "") (* |;;| "Start the Lyric-only stuff") (e (printout nil "(" .ppftl (quote (cl:when (eq makesysname :lyric))) t)) (* |;;| "Add NS fileserver random-access support") (initvars (*nsfiling-random-access* t)) (* |;;| "Fix some compiler bogosity") (advise cl:compile) (* |;;| "Add a few missing optimizers") (files (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) base-optimizers) (* |;;| "The interpreted LET* function is busted") (p (/putd (quote let*) nil)) (* |;;| "The var \\BrushAList is broken in the loadup - it ends in (... . NOBIND) instead of (... . NIL)") (* \; "Some people have their system set up to be so paranoid that it is always checking vars to see if they are eq to NOBIND, and generating an error if they are. Since, in the last loop thru the list, the var is indeed bound to NOBIND, we got troubles. The following piece of code is structured in a convoluted way to get around this problem.") (vars (|\\BrushAList| (cl:do ((x |\\BrushAList| (cdr x)) (number-good-brushes 0 (cl:incf number-good-brushes)) (brushes nil) (number-brushes (length |\\BrushAList|))) ((= number-good-brushes number-brushes) (cl:nreverse brushes)) (cl:push (car x) brushes)))) (* |;;| "Advice saved in a file often gets duplicated. This tries to fix it.") (addvars (makefileforms (purge-file-advice file))) (advise makefile) (* |;;| "Fix the SEdit hang bug") (p (changename (quote |\\\\seditA0001|) (quote readp) (quote \\sysbufp))) (* |;;| "") (* |;;| "End the Lyric-only stuff") (e (printout nil " )" t)))))
(* |;;;| " Patches")
(defineq
(purge-file-advice
(lambda (file) (* \; "Edited 30-Oct-87 11:08 by smL")
(|for| f |in| (filecomslst (rootfilename file)
'advice) |do| (purge-advice f))))
(purge-advice
(lambda (fn) (* \; "Edited 30-Oct-87 11:07 by smL")
(|if| (hasdef fn 'advice)
|then| (putdef fn 'advice (let ((advice (getdef fn 'advice)))
(intersection advice advice)))
fn
|else| nil)))
)
(declare\: donteval@load donteval@compile
(cl:when (eq makesysname :lyric)
(rpaq? *nsfiling-random-access* t)
(xcl:reinstall-advice (quote cl:compile) :around (quote ((:last (let (compiler::*input-stream*) (xcl:inner))))))
(readvise cl:compile)
(filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) base-optimizers)
(/putd (quote let*) nil)
(rpaq |\\BrushAList| (cl:do ((x |\\BrushAList| (cdr x)) (number-good-brushes 0 (cl:incf number-good-brushes)) (brushes nil) (number-brushes (length |\\BrushAList|))) ((= number-good-brushes number-brushes) (cl:nreverse brushes)) (cl:push (car x) brushes)))
(addtovar makefileforms (purge-file-advice file))
(xcl:reinstall-advice (quote makefile) :after (quote ((:last (purge-file-advice file)))) :around (quote ((:last (let ((prettyflg (and (not (memb (quote fast) options)) prettyflg))) (declare (cl:special prettyflg)) *)) (:last (let ((|ObjectAlwaysPPFlag| nil)) *)))))
(readvise makefile)
(changename (quote |\\\\seditA0001|) (quote readp) (quote \\sysbufp))
)
)
(* |;;|
"Wants to be (COMS * FILECACHE-INIT-COMMANDS), but the FileCrasher doesn't exist in Lyric, yet. Probably never will."
)
(rpaqq filecache-init-commands ((* |;;;| "File caching stuff") (files (from "{EG:}<Lanning>FileCache>") filecache) (declare\: donteval@load (p (|if| (boundp (quote fcache.version.number)) |then| (* |;;| "Set up some initial parameters") (|for| |propDescr| |in| (quote ((trust.cachelist t) (delay.delete t) (timetoverify 300) (io.block? t))) |do| (* \; "UNDOably, of course") (undosave (bquote (fcache.putprop (\\\, (car |propDescr|)) (\\\, (fcache.getprop (car |propDescr|)))))) (fcache.putprop (car |propDescr|) (cadr |propDescr|))) (* |;;| "Tell the fcache scavenger to ignore some files that I store on the cache partition") (/nconc (assoc (quote dorado) fcache.scavenge.ignore) (copy (quote (*.sysout updateloops.cm)))) (* |;;| "Treat any mail files as private files if I'm not on my normal machine") (|if| (not (string-equal home-machine-name (etherhostname))) |then| (|/push| private.files (quote *.mail)))))) (* |;;| "File cache msg window stuff") (initvars (file-cache-message-stream-region (|with| region (windowprop promptwindow (quote region)) (createregion left (difference bottom height) width height))) (file-cache-message-stream-icon-position (|with| region (windowprop promptwindow (quote region)) (|create| position xcoord _ (difference left 75) ycoord _ bottom)))) (declare\: donteval@load (p (|if| (boundp (quote fcache.version.number)) |then| (filesload (sysload noerror from lispusers) filecachemsgwindow) (* \; "UNDOably, of course") (undosave (bquote (dspfont (\\\, (dspfont (fontcreate (quote gacha) 8) *file-cache-message-stream*)) (\\\, *file-cache-message-stream*)))) (dspreset *file-cache-message-stream*) (shrinkw *file-cache-message-stream*))))))
(rpaqq font-setup-init-commands ((* |;;;| "Define printing/fonts the way people like. This includes setting prettyprinting fonts used by the editor and others, Lafite fonts, default flags controlling prettyprinting at the top level, ... This needs to be early, so other utils get the desired fonts.") (alists (fontdefs generic-init)) (initvars (\\font-profile-name (quote generic-init))) (declare\: donteval@load donteval@compile (p (eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow))))))) (advise getpromptwindow))))
(* |;;;|
"Define printing/fonts the way people like. This includes setting prettyprinting fonts used by the editor and others, Lafite fonts, default flags controlling prettyprinting at the top level, ... This needs to be early, so other utils get the desired fonts."
)
(addtovar fontdefs (generic-init (fontchangeflg . all) (filelinelength . 102) (commentlinelength 80 . 102) (lambdafontlinelength . 95) (firstcol . 60) (prettylcom . 25) (listfilestr . "
") (|ObjectDontPPFlag| . t) (sysprettyflg . t) (**comment**flg) (fontprofile (defaultfont 1 (gacha 10) (gacha 8) (terminal 8)) (boldfont 2 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (littlefont 3 (helvetica 8) (helvetica 6 mir) (modern 6 mir)) (bigfont 4 (helvetica 12 brr) (helvetica 10 brr) (modern 10 brr)) (userfont boldfont) (commentfont littlefont) (lambdafont bigfont) (systemfont) (clispfont boldfont) (changefont) (prettycomfont boldfont) (tinyfont littlefont) (font1 defaultfont) (font2 boldfont) (font3 littlefont) (font4 bigfont) (font5 5 (helvetica 10 bir) (helvetica 8 bir) (modern 8 bir)) (font6 6 (helvetica 10 brr) (helvetica 8 brr) (modern 8 brr)) (font7 7 (gacha 12) (gacha 12) (terminal 12)) (font8 8 (cream 10) (cream 10) (modern 10 mir)) (font9 9 (cream 10 brr) (cream 10 brr) (modern 10 bir)) (font10 10 (cream 12) (cream 12) (modern 12 mir)) (font11 11 (timesroman 10) (timesroman 10) (classic 10)) (|\\WindowTitleFont| bigfont) (lafitetitlefont |\\WindowTitleFont|) (chat.font font7))))
(rpaq? \\font-profile-name (quote generic-init))
(declare\: donteval@load donteval@compile
(eval-at-greet (fontset \\font-profile-name t) (cl:when (boundp (quote promptfont)) (undosave (bquote (dspfont (\\\, (dspfont promptfont promptwindow)) (\\\, promptwindow))))))
(xcl:reinstall-advice (quote getpromptwindow) :before (quote ((:last (cond ((and (null font) (boundp (quote promptfont))) (setq font promptfont)))))))
(readvise getpromptwindow)
)
(declare\: eval@loadwhen (not *generic-init-loaded*) donteval@compile docopy
(filesload (sysload from lispusers) loadmenuitems)
)
(* |;;| "Machine status")
(rpaqq who-line-commands ((* |;;;| "Give us a Who-Line") (* |;;| "Load and start the who-line") (declare\: donteval@load donteval@compile (files (sysload from lispusers) who-line) (* |;;| "Define these now, instead of with an INITVARS, because (i) Who-Line might have been in the sysout, and (ii) you can't define the entries untill the Who-Line code is loaded.") (vars (*who-line-anchor* (quote (:justify :top))) (*who-line-display-names?* t) (*who-line-directories* (list |\\UserHomeDirectory|)) (*who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*))) (p (eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*))))))))))
(* |;;;| "Give us a Who-Line")
(* |;;| "Load and start the who-line")
(declare\: donteval@load donteval@compile
(filesload (sysload from lispusers) who-line)
(rpaqq *who-line-anchor* (:justify :top))
(rpaqq *who-line-display-names?* t)
(rpaq *who-line-directories* (list |\\UserHomeDirectory|))
(rpaq *who-line-entries* (list *who-line-vmem-entry* *who-line-symbol-space-entry* *who-line-package-entry* *who-line-readtable-entry* *who-line-tty-proc-entry* *who-line-tty-state-entry* *who-line-directory-entry* *who-line-time-entry*))
(eval-at-greet (install-who-line-options) (cl:when (and (boundp (quote *who-line*)) (windowp *who-line*)) (undosave (bquote (closew (\\\, *who-line*))))))
)
(rpaqq vstats-init-commands ((* |;;;| "Storage stuff") (initvars (vstats.clock.interval 0) (vstats.mutil.interval nil) (vstats.position (createposition (difference screenwidth 147) 0))) (declare\: donteval@load donteval@compile (loadmenuitems "System-Aids" (((sysload from lispusers) "VStats") (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|)))) (((sysload from lispusers) |Storage|) (showstorage (quote item)))))))
(* |;;;| "Storage stuff")
(rpaq? vstats.clock.interval 0)
(rpaq? vstats.mutil.interval nil)
(rpaq? vstats.position (createposition (difference screenwidth 147) 0))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) "VStats")) (quote (let ((vstats-item (|for| item |in| |BackgroundMenuCommands| |thereis| (string-equal "VStats" (car item))))) (cl:when vstats-item (/dremove vstats-item |BackgroundMenuCommands|)))))
(|AddLoadMenuItem| (quote "System-Aids") (quote ((sysload from lispusers) |Storage|)) (quote (showstorage (quote item))))
)
(* |;;| "Display control")
(rpaqq screen-setup-init-commands ((* |;;;| "Screen layout stuff") (declare\: donteval@load donteval@compile (vars (windowtitleshade grayshade)) (* |;;| "Some interesting background shades") (files (sysload from "{FS8:PARC:XEROX}<Foster>Lisp>Users>") "BITMAP-GALLERY" "GRANITE") (* |;;| "Rearrange the screen") (initvars (\\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal))))) (p (eval-at-greet (cl:when \\rearrange-screen (* |;;| "Change the background shade") (|GraniteBG|) (* |;;| "Fix up the prompt window") (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (* |;;| "Rearrange the screen a bit") (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height))))))) (* |;;| "Make the standard icon functions be cute") (initvars (\\load-grid-icons t) (enforce.icon.grid t)) (p (eval-at-greet (cl:when \\load-grid-icons (filesload (from lispusers) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100)))))))
(* |;;;| "Screen layout stuff")
(declare\: donteval@load donteval@compile
(rpaq windowtitleshade grayshade)
(filesload (sysload from "{FS8:PARC:XEROX}<Foster>Lisp>Users>") "BITMAP-GALLERY" "GRANITE")
(rpaq? \\rearrange-screen (not (cl:member "ROOMS" *modules* :test (cl:function string-equal))))
(eval-at-greet (cl:when \\rearrange-screen (* |;;| "Change the background shade") (|GraniteBG|) (* |;;| "Fix up the prompt window") (undosave (bquote (dsptexture (\\\, (dsptexture 42405 promptwindow)) (\\\, promptwindow)))) (undosave (bquote (dspoperation (\\\, (dspoperation (quote replace) promptwindow)) (\\\, promptwindow)))) (undosave (bquote (windowprop (\\\, promptwindow) border (\\\, (windowprop promptwindow (quote border)))))) (windowprop promptwindow (quote border) 1) (undosave (bquote (windowprop (\\\, promptwindow) title (\\\, (windowprop promptwindow (quote title)))))) (windowprop promptwindow (quote title) nil) (clearw promptwindow) (* |;;| "Rearrange the screen a bit") (cl:when (openwp logow) (undosave (bquote (openw (\\\, logow)))) (closew logow)) (let* ((window-gap 2) (window-width (difference (quotient screenwidth 2) (plus window-gap window-gap)))) (undosave (bquote (shapew (\\\, promptwindow) (\\\, (windowprop promptwindow (quote region)))))) (shapew promptwindow (let ((height (heightifwindow (times 4 (fontprop (dspfont nil promptwindow) (quote height))) (windowprop promptwindow (quote title)) (windowprop promptwindow (quote border))))) (createregion window-gap (difference (|if| (and (boundp (quote *who-line*)) (windowp *who-line*)) |then| (difference screenheight (|fetch| (region height) |of| (windowprop *who-line* (quote region)))) |else| screenheight) (plus window-gap height)) window-width height))) (undosave (bquote (shapew (\\\, |\\TopLevelTtyWindow|) (\\\, (windowprop |\\TopLevelTtyWindow| (quote region)))))) (shapew |\\TopLevelTtyWindow| (let ((height (heightifwindow (times 17 (fontprop (dspfont nil |\\TopLevelTtyWindow|) (quote height))) (windowprop |\\TopLevelTtyWindow| (quote title)) (windowprop |\\TopLevelTtyWindow| (quote border))))) (createregion window-gap (difference (|fetch| (region bottom) |of| (windowprop promptwindow (quote region))) (plus window-gap height)) window-width height))))))
(rpaq? \\load-grid-icons t)
(rpaq? enforce.icon.grid t)
(eval-at-greet (cl:when \\load-grid-icons (filesload (from lispusers) grid-icons)) (cl:when (and \\rearrange-screen (boundp (quote loaded-files-icon-window)) (windowp loaded-files-icon-window)) (movew loaded-files-icon-window 5 100)))
)
(rpaqq rooms-init-commands ((declare\: donteval@load donteval@compile (initvars (user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>"))) (roomsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Sources>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Sources>"))))) (roomsusersdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Users>" "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>")))))) (* \; "Force CL:EVAL instead of the default IL:EVAL, since IL:EVAL doesn't understand some things.") (loadmenuitems "Screen-Maintanance" (((sysload from rooms) "ROOMS") (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}<CommonLens>CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" (\\\,@ (if (eq makesysname :lyric) then nil else (quote ("WallPaper"))))))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility)))))))))))))
(declare\: donteval@load donteval@compile
(rpaq? user-suite-directories (list (concat |\\UserHomeDirectory| "ROOMS>")))
(rpaq? roomsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Sources>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Sources>")))))
(rpaq? roomsusersdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Rooms>Medley>Users>" "{NB:PARC:XEROX}<Rooms>Lyric>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Medley>Users>" "{Pogo:AISNorth:XEROX}<Rooms>Lyric>Users>")))))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from rooms) "ROOMS")) (quote (cl:eval (quote (progn (set (cl:intern "*SUITE-DIRECTORIES*" "ROOMS") (append user-suite-directories (cl:eval (cl:intern "*SUITE-DIRECTORIES*" "ROOMS")))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from "{NB:PARC:Xerox}<CommonLens>CURRENT>") "CLens-Rooms"))) (cl:dolist (utility (quote ("Rooms-Intro" "Rooms-Notes"))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from rooms) (\\\, utility))))) (cl:dolist (utility (bquote ("Background-Menu-Buttons" "Office.suite" "Touchy-Buttons" "Random-Window-Types" "Snuggle" "Notecards-Window-Types" (\\\,@ (if (not (cl:fboundp (quote lafite))) then nil elseif (not (cl:fboundp (quote \\lafite.getmailfolder))) then (quote ("New-Lafite-Window-Types")) else (quote ("Lafite-Window-Types")))) "Un-Hide-Tty" "Rooms-Videohax" (\\\,@ (if (eq makesysname :lyric) then nil else (quote ("WallPaper"))))))) (|AddLoadMenuItem| "Rooms" (bquote ((sysload from roomsusers) (\\\, utility))))))))))
)
(rpaqq change-background-init-commands ((* |;;;| "Make it easy to change your background") (declare\: donteval@load donteval@compile (loadmenuitems nil (((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{PHYLUM}<Loops>Faces>") "Dead") (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) (\\\,@ (|for| item |in| menu-items |collect| (car item))) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image)))))))))))))))))))
(* |;;;| "Make it easy to change your background")
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "BackgroundImages" "StarBG" (nil from "{PHYLUM}<Loops>Faces>") "Dead")) (quote (|push| |BackgroundMenuCommands| (let ((bitmaps (quote (("Standard texture" . windowbackgroundshade) ("Gray shade" . grayshade) ("Light wall paper" . lightwallpaper) ("Medium wall paper" . wallpaper) ("Dark wall paper" . darkwallpaper) ("Waves" . wave-texture) ("Tweed" . xcl-user::*tweed-bm*) ("Chambray" . xcl-user::*chambray-bm*) ("Canvas" . xcl-user::*canvas-bm*) ("Corduroy" . xcl-user::*corduroy-bm*) ("Seersucker" . xcl-user::*seersucker-bm*) ("Burlap" . xcl-user::*burlap-bm*) ("Mesh" . mesh-texture)))) (images (background.files)) (menu-items (quote (("Stars" (quote (starbg)) "Fill the background with stars" (subitems ("ET go home" (quote (|SaucerOff|)) "Get rid of the saucer"))) ("Granite" (quote (|GraniteBG|)) "Fill the background with a pleasing, almost random shade") ("Dead" (changebackground (expandbitmap dead-bm 2 2)) "Put a Deadhead on the background"))))) (bquote ("Change background" (quote (changebackground)) "Change the background to the default texture" (subitems ("Random texture" (quote (let ((shade (|\\Pick-One-At-Random| (quote ((\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| bm |else| (cdr bm)))) (\\\,@ (|for| item |in| menu-items |collect| (car item))) (\\\,@ images) "Rand"))))) (cond ((for item in menu-items thereis (and (cl:consp item) (stringp (car item)) (string-equal shade (car item))) finally (if $$val then (eval (cadr item))))) ((equal shade "Rand") (changebackground (rand 0 blackshade))) ((listp shade) (background.fetch (car shade) (cdr shade))) ((litatom shade) (changebackground (evalv shade))) (t (changebackground shade))))) "Change the background texture to a randomly selected shade") (\\\,@ (|for| bm |in| bitmaps |collect| (|if| (cl:symbolp bm) |then| (bquote ((\\\, bm) (changebackground (\\\, bm)))) |else| (bquote ((\\\, (car bm)) (changebackground (\\\, (cdr bm)))))))) (\\\,@ menu-items) (\\\,@ (|for| image |in| images |collect| (bquote ((\\\, (car image)) (quote (background.fetch (quote (\\\, (car image))) (quote (\\\, (cdr image))))))))))))))))
)
(rpaqq display-control-init-commands ((declare\: donteval@load donteval@compile (loadmenuitems "Screen-Maintanance" (((sysload from lispusers) "WDWHacks")) (((sysload from lispusers) "Turbo-Windows")) (((sysload from lispusers) "Solid-Movew")) (((sysload from lispusers) "NSDisplaySizes")) (((sysload from lispusers) "SNAPW-ICON"))))))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "WDWHacks")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Turbo-Windows")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "Solid-Movew")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "NSDisplaySizes")))
(|AddLoadMenuItem| (quote "Screen-Maintanance") (quote ((sysload from lispusers) "SNAPW-ICON")))
)
(rpaqq idle-init-commands ((* |;;;| "The Idle package") (declare\: donteval@load donteval@compile (loadmenuitems "IdlePatterns" (((sysload from lispusers) "IdleHax")) (((sysload from lispusers) "IdleDrain") (/listput idle.profile (quote displayfn) (quote idle-drain))) (((sysload from lispusers) "ReadBrush")) (((sysload from "{PHYLUM}<Colab>Andes>Users>") "Bouncing-Face")) (((sysload from lispusers) "StarBG") (/listput idle.profile (quote displayfn) (quote |Cosmos|))) (((sysload from lispusers) "Pac-Man-Idle") (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|))) (((sysload from "{QV}<Bagley>Lisp>") "Idle-Cost")) (((sysload) "ScreenPaper") (/listput idle.profile (quote displayfn) (quote screenpaper))) (((sysload from private-lispusers) "Idle-Lyrics") (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics)))) (p (eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil))))))
(* |;;;| "The Idle package")
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleHax")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "IdleDrain")) (quote (/listput idle.profile (quote displayfn) (quote idle-drain))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "ReadBrush")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{PHYLUM}<Colab>Andes>Users>") "Bouncing-Face")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "StarBG")) (quote (/listput idle.profile (quote displayfn) (quote |Cosmos|))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from lispusers) "Pac-Man-Idle")) (quote (/listput idle.profile (quote displayfn) (quote |Pac-Man-Idle|))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from "{QV}<Bagley>Lisp>") "Idle-Cost")))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload) "ScreenPaper")) (quote (/listput idle.profile (quote displayfn) (quote screenpaper))))
(|AddLoadMenuItem| (quote "IdlePatterns") (quote ((sysload from private-lispusers) "Idle-Lyrics")) (quote (/listput idle.profile (quote displayfn) (quote xcl-user::idle-lyrics))))
(eval-at-greet (/listput idle.profile (quote forget) nil) (/listput idle.profile (quote allowed.logins) nil))
)
(rpaqq clock-init-commands ((* |;;;| "Telling the time") (* |;;| "Standard clock is the Biclock, in the lower-left corner") (initvars (biclockinitialprops (quote (horizontal left vertical bottom size 95)))) (* |;;| "Optional clock is CROCK, also in the lower-left corner") (declare\: donteval@load donteval@compile (files (sysload noerror from lispusers) biclock) (loadmenuitems nil (((sysload from lispusers) "Crock") (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow)))))))
(* |;;;| "Telling the time")
(* |;;| "Standard clock is the Biclock, in the lower-left corner")
(rpaq? biclockinitialprops (quote (horizontal left vertical bottom size 95)))
(* |;;| "Optional clock is CROCK, also in the lower-left corner")
(declare\: donteval@load donteval@compile
(filesload (sysload noerror from lispusers) biclock)
(|AddLoadMenuItem| (quote nil) (quote ((sysload from lispusers) "Crock")) (quote (cl:when (and (boundp (quote biclockwindow)) (windowp biclockwindow)) (closew biclockwindow))))
)
(* |;;| "Programming stuff")
(rpaqq programming-init-commands ((* |;;;| "Editing code") (functions notice) (* |;;| "Saving files") (functions make) (* |;;| "For testing optimizers") (functions oam) (* |;;| "Handy exec commands") (commands "BREAK" "UNBREAK" "CALLS" "DESCRIBE" "EC" "EFF" "FILES?" "IC" "NOTICE" "MAKE" "SPY") (* |;;| "never really worked - (loadmenuitems \"ProgrammingAids\" (((sysload from lispusers) \"Step-Command-Menu\")))") (* |;;| "") (* |;;| "SEDIT stuff") (declare\: donteval@load donteval@compile (p (eval-at-greet (* |;;| "Give us a META key if running on a Dorado") (selectq (machinetype) (dorado (metashift t)) nil) (* |;;| "Reset SEdit so it gets the correct fonts") (case makesysname (:lyric (sedit.reset)) (cl:otherwise (cl:funcall (cl:intern "RESET" (cl:find-package "SEDIT"))))) (* |;;| "Hacking SEdit so it uses better package/readtable defaults") (case makesysname (:lyric (filesload (sysload noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "SEDIT-HACK")) (cl:otherwise (filesload (sysload from lispusers) "sedit-profile"))))) (* |;;| "Change the SEdit EXPAND behavior to expand definers in a reasonable way") (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers"))) (* |;;| "The Eval&Insert hook") (loadmenuitems "ProgrammingAids" (((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval"))) (* |;;| "Exit/Compile hooks") (p (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "SEdit-Compile")))))) (* |;;| "TTY editor stuff") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "CL-TTYEdit")))) (declare\: donteval@load donteval@compile (* |;;| "Better WHEREIS facility") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "New-Where-Is"))) (* |;;| "Checking out lexical contexts in a break") (p (case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "Debugger-Context")))))) (* |;;| "Save-Your-Ass") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Checkpoint"))) (* |;;| "Spy button") (initvars (\spy.button.pos nil)) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) spy) (spy.button \spy.button.pos))) (* |;;| "Graph calls") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "GraphCalls"))) (* |;;| "The Source Manager") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "Manager"))) (* |;;| "Better file listing tools") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "PP-Code-File")) (((sysload from lispusers) "PrettyFileIndex"))) (* |;;| "TEdit executive") (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "TExec"))) (* |;;| "Iteration packages") (loadmenuitems "ProgrammingAids" (((sysload from "{Phylum}<Brotsky>rcw>") "OSS")))) (declare\: donteval@load donteval@compile (* |;;| "Moving between Xerox Lisp and the rest of the world") (p (|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge")))))))))
(* |;;;| "Editing code")
(cl:defun notice (&rest files) "Notice a set of files, so things on them can be edited" (* |;;;| "Return 4 values: a list of all files that were noticed, a list of files that were already noticed, a list of files that weren't noticed because they weren't loaded, and a list of files that couldn't be found.") (cl:labels ((canonocal-filemanager-name (path) "Return the canonical FileManager name of a file" (cl:intern (cl:string-upcase (cl:pathname-name path)) (cl:find-package "IL"))) (find-source-file (file-name &optional (search-path-list directories)) "Return the full pathname of the source file" (or (* \; "In case we are given enough to find the file") (cl:probe-file file-name) (* \; "Check for the original source, in it's original location") (let ((original-source-file-name (cdr (cl:first (get (canonocal-filemanager-name (pathname file-name)) (quote filedates)))))) (cl:if original-source-file-name (cl:probe-file original-source-file-name) nil)) (* \; "As a last resort, check the list of directories") (cl:find-if (cl:function cl:probe-file) (cl:mapcar (cl:function (cl:lambda (dir) (cl:merge-pathnames file-name dir))) search-path-list)))) (file-noticed-p (path) "Has the file been noticed?" (cl:member (canonocal-filemanager-name path) filelst :test (quote eq))) (file-loaded-p (path) "Has the file been loaded?" (not (null (get (canonocal-filemanager-name path) (quote filedates))))) (notice-file (path) "Notice the file" (load path (quote prop)))) (let ((alread-noticed-files nil) (not-loaded-files nil) (noticed-files nil) (not-found-files nil)) (cl:mapc (cl:function (cl:lambda (file) (let ((pathname (find-source-file file))) (cond ((null pathname) (cl:push file not-found-files)) ((file-noticed-p pathname) (cl:push pathname alread-noticed-files)) ((file-loaded-p pathname) (loadfrom pathname nil (quote prop)) (cl:push pathname noticed-files)) (t (cl:push pathname not-loaded-files)))))) files) (cl:values noticed-files alread-noticed-files not-loaded-files not-found-files))))
(* |;;| "Saving files")
(cl:defun make (files) (let ((files (or files (cl:remove-if-not (cl:function (cl:lambda (file-name) (cdr (get file-name (quote file))))) filelst))) (original-dir *default-pathname-defaults*) file-dir roopt-file) (cl:unwind-protect (cl:dolist (file files) (cl:setq roopt-file (cl:pathname-name file)) (cl:setq roopt-file (cl:typecase roopt-file (string (cl:intern (cl:string-upcase roopt-file) (cl:find-package "IL"))) (cl:symbol (cl:intern (cl:symbol-name roopt-file) (cl:find-package "IL"))))) (cndir (cl:if (get roopt-file (quote filedates)) (let ((file-dir (unpackfilename.string (cdr (cl:first (get roopt-file (quote filedates))))))) (packfilename.string (quote host) (cl:getf file-dir (quote host)) (quote device) (cl:getf file-dir (quote device)) (quote directory) (cl:getf file-dir (quote directory)))) original-dir)) (cl:when (cl:funcall (quote cleanup) roopt-file) (cl:load (packfilename.string (quote name) roopt-file (quote extension) "dfasl")))) (cndir original-dir))))
(* |;;| "For testing optimizers")
(cl:defun oam (form) "Optimize and Macroexpand the form. For use as an SEdit mutator." (compiler:optimize-and-macroexpand-1 form (compiler:make-empty-env) (compiler:make-context)))
(* |;;| "Handy exec commands")
(defcommand "BREAK" (&rest fns) "Set a breakpoint on the named functions." (eval (bquote (break (\\\,@ fns)))))
(defcommand "UNBREAK" (&rest fns) "Remove a breakpoint from the named functions." (eval (bquote (unbreak (\\\,@ fns)))))
(defcommand "CALLS" (fn) "Print out information about what the function calls." (cond ((not (cl:fboundp fn)) (cl:format t "~%~S has no function definition" fn)) ((cl:macro-function fn) (cl:format t "~%~S is a macro" fn)) ((cl:special-form-p fn) (cl:format t "~%~S is a special-form" fn)) (t (destructuring-bind (calls binds uses-free uses-global) (calls fn) (cl:format t "~%--- ~S ---" fn) (let ((format-string "~%~A:~{ ~S~}")) (cl:when (not (null calls)) (cl:format t format-string "CALLS" calls)) (cl:when (not (null binds)) (cl:format t format-string "BINDS" binds)) (cl:when (not (null uses-free)) (cl:format t format-string "SPECIALS USED" uses-free)) (cl:when (not (null uses-global)) (cl:format t format-string "GLOBALS USED" uses-global)))))) (cl:values))
(defcommand "DESCRIBE" (&rest objects) "Describe the named objects." (cl:mapc (cl:function (cl:lambda (x) (cl:format t "~&-- ~A --" x) (cl:describe x))) objects) (cl:values))
(defcommand "EC" (form) "Evaluate a compiled version of the form" (cl:funcall (prog2 (cl:format t "~%Compiling...") (cl:compile nil (bquote (cl:lambda nil (\\\, form)))) (cl:format t "done.~%"))))
(defcommand "EFF" (&rest patterns-commands) "Edit any uses of any of the patterns on any noticed file. Args are ..patterns - ..edit comands." (let* ((position (cl:position "-" patterns-commands :key (cl:function (lambda (pattern) (if (cl:symbolp pattern) then (cl:symbol-name pattern) else ""))) :test (cl:function string-equal))) (patterns (if (null position) then patterns-commands else (cl:butlast patterns-commands (- (length patterns-commands) position)))) (edit-commands (if position then (cl:subseq patterns-commands (1+ position)) else nil))) (case (cl:length patterns) (0 nil) (1 (editfromfile nil nil (cl:first patterns) edit-commands)) (cl:otherwise (editfromfile nil nil (bquote (*any* (\\\,@ patterns))) edit-commands)))) (cl:values))
(defcommand "FILES?" nil "Tell you about what source files need to be dumped." (files?) (cl:values))
(defcommand "IC" (fn) "Inspect the code for the function." (inspectcode (if (cl:symbolp fn) then (if (ccodep (getd fn)) then fn else (cl:compile nil (getd fn))) else (cl:compile nil (if (cl:member (car fn) (quote (cl:lambda lambda)) :test (cl:function eq)) then fn else (bquote (cl:lambda nil (\\\, fn))))))) (cl:values))
(defcommand "NOTICE" (&rest files) "Notice a set of files, so things on them can be edited" (cl:flet ((tell-user (files msg) (cl:when files (cl:format t "~%~A" msg) (cl:mapcar (cl:function (cl:lambda (path) (cl:format t "~%~5T~A" (cl:pathname-name path)))) files)))) (cl:multiple-value-bind (just-noticed previously-noticed not-loaded not-found) (cl:apply (cl:function notice) files) (tell-user just-noticed "Noticed files") (tell-user previously-noticed "Previously noticed files") (tell-user not-loaded "Not loaded, so not noticed files") (tell-user not-found "Could not find files")) (cl:values)))
(defcommand "MAKE" (&rest files) "Save, recompile, and reload the files." (make files) (cl:values))
(defcommand "SPY" (form) (cl:unwind-protect (progn (spy.start) (prog1 (cl:eval form) (spy.end))) (spy.end) (spy.tree)))
(* |;;|
"never really worked - (loadmenuitems \"ProgrammingAids\" (((sysload from lispusers) \"Step-Command-Menu\")))"
)
(* |;;| "")
(* |;;| "SEDIT stuff")
(declare\: donteval@load donteval@compile
(eval-at-greet (* |;;| "Give us a META key if running on a Dorado") (selectq (machinetype) (dorado (metashift t)) nil) (* |;;| "Reset SEdit so it gets the correct fonts") (case makesysname (:lyric (sedit.reset)) (cl:otherwise (cl:funcall (cl:intern "RESET" (cl:find-package "SEDIT"))))) (* |;;| "Hacking SEdit so it uses better package/readtable defaults") (case makesysname (:lyric (filesload (sysload noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "SEDIT-HACK")) (cl:otherwise (filesload (sysload from lispusers) "sedit-profile"))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Definers")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from valueof (append private-lispusersdirectories lispusersdirectories)) "SEdit-Eval")))
(case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "SEdit-Compile")))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "CL-TTYEdit")))
)
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "New-Where-Is")))
(case makesysname (:lyric (|AddLoadMenuItem| "ProgrammingAids" (quote ((sysload from lispusers) "Debugger-Context")))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Checkpoint")))
(rpaq? \spy.button.pos nil)
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) spy)) (quote (spy.button \spy.button.pos)))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "GraphCalls")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "Manager")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PP-Code-File")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "PrettyFileIndex")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "TExec")))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from "{Phylum}<Brotsky>rcw>") "OSS")))
)
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| "ProgrammingAids" (case makesysname (:lyric (quote ((sysload from lispusers) "Port-CLFile"))) (cl:otherwise (quote ((sysload from lispusers) "XCL-Bridge")))))
)
(rpaqq old-utils-commands ((* |;;| "Used to be in the seperate file UTILS.") (* |;;| "Making sure that breaks happen") (fns |DebugMode|) (* |;;| "Used to be in Loops") (fns selectw) (functions de file) (usermacros de ee fv) (* |;;| "Print out a doc file") (fns |PrintDocFile|) (* |;;| "Just what is says") (fns |\\Pick-One-At-Random|) (functions |PickOneAtRandom|) (* |;;| "Ways to quit a sysout") (fns |GoodNight| |NewLisp|) (* |;;| "Make the KEY3.CM file on the top partition put you back in you last used partition, and the KEY2.CM restart the vmem, assuming that KEY1.CM starts a fresh sysout") (fns |RememberLastPartition| |RememberLispState|) (declare\: donteval@load donteval@compile (addvars (beforelogoutforms (|RememberLispState|) (|RememberLastPartition|))))))
(* |;;| "Used to be in the seperate file UTILS.")
(* |;;| "Making sure that breaks happen")
(defineq
(|DebugMode|
(lambda (debug-on-p all-execs-p) (* \; "Edited 25-Jan-88 08:19 by smL")
(|if| debug-on-p
|then| (setq nlsetqgag nil)
(setq helpflag break!)
(|if| all-execs-p
|then| (putassoc 'helpflag (list 'break!)
*per-exec-variables*))
|else| (setq nlsetqgag t)
(setq helpflag t)
(|if| all-execs-p
|then| (putassoc 'helpflag (list t)
*per-exec-variables*)))))
)
(* |;;| "Used to be in Loops")
(defineq
(selectw
(lambda nil (* \; "Edited 15-Jan-88 09:17 by smL")
(* |;;;| "Let the user select a window")
(|first| (clrprompt)
(|printout| promptwindow "Move mouse to desired window." t
"Then press down the CTRL key or click mouse")
|until| (or (keydownp 'ctrl)
(not (mousestate up))) |do| nil |finally| (getmousestate)
(clrprompt)
(return (whichw)))))
)
(defmacro de (|fn-name| |arg-list| &rest |body|) (* |;;;| "Shorthand for defineing functions") (bquote (defineq ((\\\, |fn-name|) (\\\, |arg-list|) (\\\,@ |body|)))))
(defmacro file (|file-name| &rest |file-package-commands|) (* |;;;| "Allows one to create a file giving the commands explicitly e.g. - (FILE FOO (VARS * FUMVARS) (FNS * FNSLIST)) - will create FOOCOMS and make file FOO") (let ((|real-file-name| (u-case |file-name|))) (bquote (progn (\\\, (|if| (null |file-package-commands|) |then| nil |elseif| (and (litatom (car |file-package-commands|)) (null (cdr |file-package-commands|))) |then| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (getatomval (quote (\\\, (car |file-package-commands|)))))) |else| (bquote (/setatomval (filecoms (quote (\\\, |real-file-name|))) (quote (\\\, |file-package-commands|)))))) (resetform (radix 10) (makefile (quote (\\\, |real-file-name|))))))))
(addtovar usermacros (fv nil (e (freevars (\## (orr (up 1) nil)) t))) (ee nil (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (ee (dummy) (e (cursor t) t) (e (windowprop ttyineditwindow (quote title) (concat "TtyInEdit of " type " " atm)) t) (coms (tted do.ee ee))) (de nil (comsq (bi 1 -1) (e (dedite (\## 1)) t) (bo 1))))
(addtovar editcomsa de ee)
(addtovar editcomsl ee)
(* |;;| "Print out a doc file")
(defineq
(|PrintDocFile|
(lambda (utility-name print-server) (* \; "Edited 17-Mar-88 16:24 by smL")
(* |;;;| "Print out the documentation file for the named package")
(setq print-server (or print-server (car defaultprintinghost)))
(cl:flet ((find-doc-source-file nil (or (findfile (packfilename 'name utility-name 'extension
'tedit)
nil directories)
(findfile (packfilename 'name utility-name 'extension
'ted)
nil directories)
(findfile (packfilename 'name utility-name 'extension
'txt)
nil directories)
(findfile (packfilename 'name utility-name 'extension
'doc)
nil directories))))
(|if| (eq print-server t)
|then| (let ((doc-file (find-doc-source-file)))
(|if| doc-file
|then| (tedit doc-file)
|else| "No doc file found"))
|elseif| print-server
|then| (let ((doc-file (or (findfile (packfilename 'name utility-name 'extension
(selectq (printertype print-server)
((press fullpress)
'press)
(interpress 'ip)
(help "Unknown printer type!")))
nil directories)
(find-doc-source-file))))
(|if| doc-file
|then| (add.process `(empress ',doc-file nil ',print-server))
(concat "Printing file " doc-file " on printer " print-server)
|else| "No doc file found"))
|else| "No printer specified"))))
)
(* |;;| "Just what is says")
(defineq
(|\\Pick-One-At-Random|
(lambda (|list|) (* \; "Edited 15-Jan-88 09:20 by smL")
(* |;;;| "Return a random element of the list")
(resetlst (resetsave (randset t)
`(randset ,(randset)))
(car (nth |list| (rand 1 (length |list|)))))))
)
(defmacro |PickOneAtRandom| (&rest |elements|) (bquote (|\\Pick-One-At-Random| (quote (\\\, (mapcar |elements| (quote eval)))))))
(* |;;| "Ways to quit a sysout")
(defineq
(|GoodNight|
(lambda (|flag| |altoCommandString|) (* |smL| "20-Sep-85 14:43")
(let ((|stream| (openstream '{dsk}rem.cm\;1 'output 'old/new)))
(prin1 (or |altoCommandString| "Q")
|stream|)
(terpri |stream|)
(closef |stream|))
(logout |flag|)))
(|NewLisp|
(lambda nil (* \; "Edited 15-Jan-88 09:20 by smL")
(* |;;;| "Start up a new system, assuming that {DSK}KEY1.CM starts one up.")
(|if| (mouseconfirm "Do you really want to start up a new system?")
|then| (|GoodNight| t "@KEY1.CM"))))
)
(* |;;|
"Make the KEY3.CM file on the top partition put you back in you last used partition, and the KEY2.CM restart the vmem, assuming that KEY1.CM starts a fresh sysout"
)
(defineq
(|RememberLastPartition|
(lambda nil (* \; "Edited 15-Jan-88 09:21 by smL")
(* |;;;|
"Sets up the KEY3 CM file in the last partition (19 or 5) to put you back in this partition.")
(selectq (machinetype)
(dorado (|for| |partitionNumber| |in| '(19 5) |bind| |stream| |key3File|
|eachtime| (setq |key3File| (concat "{DSK" |partitionNumber| "}KEY3.CM;1"))
(setq |stream| (car (nlsetq (getstream |key3File|))))
(and |stream| (closef? |stream|))
(setq |stream| (car (nlsetq (openstream |key3File| 'output 'old/new))))
|thereis| (streamp |stream|)
|finally| (|if| (and (streamp |stream|)
(openp |stream|))
|then| (|printout| |stream| "// "
"This will set you back in your last used partition, "
firstname t "// [last used " (date)
"]" t "Par " (diskpartition)
t)
(closef |stream|))))
nil)))
(|RememberLispState|
(lambda nil (* \; "Edited 15-Jan-88 09:21 by smL")
(* |;;;| "Make KEY2.CM restart this lisp if the logout was not FAST...")
(nlsetq (|if| (and (stkpos 'logout)
(eq (machinetype)
'dorado))
|then| (|if| (nlsetq (getstream '{dsk}key2.cm\;1))
|then| (closef? (getstream '{dsk}key2.cm\;1)))
(resetlst (let ((logout-arg (stkarg 1 'logout))
(stream (openstream '{dsk}key2.cm\;1 'output 'old/new)))
(resetsave nil (list (function closef?)
stream))
(|printout| stream "// You did a (LOGOUT")
(selectq logout-arg
(nil nil)
(|printout| stream " " logout-arg))
(|printout| stream ") last time [" (date)
"], so this will ")
(selectq logout-arg
((nil ?)
(|printout| stream "restart your old"))
(|printout| stream "start a new"))
(|printout| stream " LISP, " firstname t)
(selectq logout-arg
((nil ?)
(|printout| stream "Lisp")
(|if| (eqp (realmemorysize)
21845)
|then| (|printout| stream " 52525/c")))
(|printout| stream "@KEY1.CM"))
(|printout| stream t)))))))
)
(declare\: donteval@load donteval@compile
(addtovar beforelogoutforms (|RememberLispState|) (|RememberLastPartition|))
)
(rpaqq wizard-init-commands ((* |;;;| "Some tools for wizards, or people who occasionally think they are.") (* |;;| "Find out what other symbols were interned at about the same time as a given symbol. Useful to find out what file defined a symbol.") (functions atom-neighbors)))
(* |;;;| "Some tools for wizards, or people who occasionally think they are.")
(* |;;|
"Find out what other symbols were interned at about the same time as a given symbol. Useful to find out what file defined a symbol."
)
(cl:defun atom-neighbors (cl:symbol &optional (xcl-user::number-of-neighbors 8)) (cl:if (cl:symbolp cl:symbol) (let ((xcl-user::atom-number (\\loloc cl:symbol)) (xcl-user::neighbors (list cl:symbol))) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (+ xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) (cl:setf xcl-user::neighbors (cl:nreverse xcl-user::neighbors)) (cl:dotimes (xcl-user::i xcl-user::number-of-neighbors) (cl:push (\\vag2 0 (- xcl-user::atom-number 1 xcl-user::i)) xcl-user::neighbors)) xcl-user::neighbors) "Not a symbol"))
(rpaqq dinfo-init-commands ((* |;;| "Set up the on-line documentation") (declare\: donteval@load donteval@compile (vars (irm.host&dir (cond ((infilep "{DSK}<LISPFILES>HELPSYS>IRMTOP.TEDIT") "{DSK}<LISPFILES>HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}<Lisp>Lyric>LispUsers>IRM>"))) (dinfomodes (quote (graph)))) (initvars (irm.font (fontcreate (quote (helvetica 10)))) (irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2))))) (loadmenuitems "ProgrammingAids" (((sysload from lispusers) "DInfo" "Helpsys") (dinfo (irm.get.dinfograph t) irmwindowregion)) (((sysload from lispusers) "LispNerd"))))))
(* |;;| "Set up the on-line documentation")
(declare\: donteval@load donteval@compile
(rpaq irm.host&dir (cond ((infilep "{DSK}<LISPFILES>HELPSYS>IRMTOP.TEDIT") "{DSK}<LISPFILES>HELPSYS>") ((and (boundp (quote irm.host&dir)) irm.host&dir) irm.host&dir) (t "{Pallas:AISNorth:XEROX}<Lisp>Lyric>LispUsers>IRM>")))
(rpaqq dinfomodes (graph))
(rpaq? irm.font (fontcreate (quote (helvetica 10))))
(rpaq? irmwindowregion (let ((width (widthifwindow (cl:* 60 (stringwidth "w" irm.font))))) (createregion (- screenwidth width 5) 5 width (quotient screenheight 2))))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "DInfo" "Helpsys")) (quote (dinfo (irm.get.dinfograph t) irmwindowregion)))
(|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((sysload from lispusers) "LispNerd")))
)
(rpaqq pcl-init-commands ((* |;;| "PCL fun and games") (initvars (pcldirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<PCL>LYRIC>" "{PHYLUM}<PCL>LYRIC>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{pooh/n}<pooh>pcl>medley>" "{NB:PARC:XEROX}<PCL>MEDLEY>" "{PHYLUM}<PCL>MEDLEY>")))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL")) (quote (cl:when (eq makesysname :lyric) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((from pcl) "Clos-Browser"))))))))))))
(* |;;| "PCL fun and games")
(rpaq? pcldirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<PCL>LYRIC>" "{PHYLUM}<PCL>LYRIC>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{pooh/n}<pooh>pcl>medley>" "{NB:PARC:XEROX}<PCL>MEDLEY>" "{PHYLUM}<PCL>MEDLEY>")))))
(declare\: donteval@load donteval@compile
(eval-at-greet (cl:unless (cl:find-package "PCL") (|AddLoadMenuItem| "Subsystems" (quote ((from pcl) "Load-PCL")) (quote (cl:when (eq makesysname :lyric) (|AddLoadMenuItem| (quote "ProgrammingAids") (quote ((from pcl) "Clos-Browser"))))))))
)
(rpaqq loops-init-commands ((* |;;;| "Loops initialization") (initvars (loopsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Lyric>Sources>" "{PHYLUM}<Loops>Lyric>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Medley>Sources>" "{PHYLUM}<Loops>Medley>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>"))))) (\\loops-init-form (quote (progn (filesload (from "{EG:PARC:XEROX}<Lanning>Loops>") initloops))))) (declare\: donteval@load donteval@compile (p (eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form))))))))
(* |;;;| "Loops initialization")
(rpaq? loopsdirectories (case makesysname (:lyric (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Lyric>Sources>" "{PHYLUM}<Loops>Lyric>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>"))) (cl:otherwise (bquote ((\\\,@ *cache-directories*) "{NB:PARC:XEROX}<Loops>Medley>Sources>" "{PHYLUM}<Loops>Medley>Sources>" "{POGO:AISNorth:XEROX}<LOOPSCORE>SYSTEM>")))))
(rpaq? \\loops-init-form (quote (progn (filesload (from "{EG:PARC:XEROX}<Lanning>Loops>") initloops))))
(declare\: donteval@load donteval@compile
(eval-at-greet (cond ((cl:member "LOOPS" *features* :test (cl:function string-equal)) (eval \\loops-init-form)) (t (|AddLoadMenuItem| "Subsystems" (quote ((from loops) "Loops")) \\loops-init-form))))
)
(* |;;| "Documentation")
(rpaqq tedit-init-commands ((* |;;;| "TEDIT stuff") (functions load-nova-fonts) (declare\: donteval@load donteval@compile (vars (tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t)) (* \; "Set up default tabs to be 8 spaces, so we can edit code files.") (tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A"))))))))) (p (eval-at-greet (cl:when (getd (quote tedit)) (* |;;| "Make the ESC key REDO the previous TEdit operation") (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)) (* |;;| "Make TEdit close files when shrunk") (filesload (sysload from lispusers) tedit-close-on-shrink)))) (loadmenuitems "WritingAids" (((sysload from lispusers) "ProofReader")) (((sysload from lispusers) "TMAX")) (((sysload from lispusers) "DictTool")) (((sysload from lispusers) "TEditDoradoKeys")) (((sysload from lispusers) "EditKeys")) (((sysload from lispusers) "VirtualKeyboards") (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file)))) (((sysload from lispusers) "KeyboardEditor")) (((sysload from lispusers) "Equations" "Sketch")) (((sysload from lispusers) "NovaFont") (load-nova-fonts))) (coms (initvars (docobjectsmenufont menufont)) (alists (imageobjgetfns docobj-filestamp-getfn docobj-timestamp-getfn docobj-include-getfn)) (loadmenuitems "WritingAids" (((sysload from lispusers) "Doc-Objects")))))))
(* |;;;| "TEDIT stuff")
(cl:defun load-nova-fonts nil (let ((nova-font-host "Starfile Public:Parc:Xerox") (nova-fonts-to-load (quote ("<VP Applications>VP Optima XSG Fonts>OptimaItalic" "<VP Applications>VP Optima XSG Fonts>OptimaMedium"))) (nova-fonts-to-notice (quote ("<VP Applications>Xerox Logo Fonts>XeroxLogo" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzBIR" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzBRR" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzMIR" "<VP Applications>Xerox VP Quartz Fonts!2>QuartzMRR")))) (cl:flet ((find-nova-font (font) "Find the Novafont file" (cl:probe-file (cl:make-pathname :host nova-font-host :type "NovaFont" :defaults font)))) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Loading Novafont ~A" (cl:pathname-name font-file)) (load-novafont-file font-file) (notice-novafont-file font-file))))) nova-fonts-to-load) (cl:mapc (cl:function (cl:lambda (font) (let ((font-file (find-nova-font font))) (cl:when font-file (cl:format (getstream promptwindow (quote output)) "~%Noticing Novafont ~A" (cl:pathname-name font-file)) (notice-novafont-file font-file))))) nova-fonts-to-notice))) (cl:mapc (cl:function (cl:lambda (item) (cl:pushnew item tedit.known.fonts :test (quote cl:equal)))) (quote (("XeroxLogo" (quote xeroxlogo)) ("Quartz" (quote quartz)) ("Optima" (quote optima))))))
(declare\: donteval@load donteval@compile
(rpaq tedit.default.window (createw (let ((width (widthifwindow (times 80 (tedit.stringwidth "A")))) (height (heightifwindow (times 35 (fontprop defaultfont (quote height))) t))) (createregion (min 475 (- screenwidth (+ width 10))) (max 85 (- screenheight height 100)) width height)) "TEDIT window" nil t))
(rpaq tedit.default.props (bquote ((\\\,@ tedit.default.props) paralooks (tabs ((\\\, (times 8 (tedit.stringwidth "A"))))))))
(eval-at-greet (cl:when (getd (quote tedit)) (* |;;| "Make the ESC key REDO the previous TEdit operation") (undosave (bquote (tedit.setsyntax (\\\, (charcode esc)) (\\\, (tedit.getsyntax (charcode esc)))))) (tedit.setsyntax (charcode esc) (quote redo)) (* |;;| "Make TEdit close files when shrunk") (filesload (sysload from lispusers) tedit-close-on-shrink)))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "ProofReader")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TMAX")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "DictTool")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "TEditDoradoKeys")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "EditKeys")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "VirtualKeyboards")) (quote (let ((keyboard-file (findfile "Code.Keyboard" t private-lispusersdirectories))) (cl:when keyboard-file (vkbd.load-keyboard-file keyboard-file)))))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "KeyboardEditor")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Equations" "Sketch")))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "NovaFont")) (quote (load-nova-fonts)))
(rpaq? docobjectsmenufont menufont)
(addtovar imageobjgetfns (docobj-filestamp-getfn file doc-objects) (docobj-timestamp-getfn file doc-objects) (docobj-include-getfn file doc-objects))
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Doc-Objects")))
)
(rpaqq sketch-init-commands ((* |;;;| "SKETCH Stuff") (alists (imageobjgetfns skio.getfn skio.getfn.2)) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from lispusers) "Sketch"))))))
(* |;;;| "SKETCH Stuff")
(addtovar imageobjgetfns (skio.getfn) (skio.getfn.2 file sketch))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from lispusers) "Sketch")))
)
(rpaqq notecards-init-commands ((* |;;;| "NOTECARDS stuff") (initvars (|NC.NoteCardsIconPosition| (createposition 891 2)) (ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil))) (notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}<NoteCards>1.3L>" "{NB:PARC:XEROX}<NoteCards>1.3L>")))) (declare\: donteval@load donteval@compile (loadmenuitems "WritingAids" (((sysload from notecards) "NoteCards") (|NoteCards| |NC.NoteCardsIconPosition|))))))
(* |;;;| "NOTECARDS stuff")
(rpaq? |NC.NoteCardsIconPosition| (createposition 891 2))
(rpaq? ncinitialglobalparams (quote (|ForceFiling| nil |MarkersInFileBoxes| nil |UseDeletedLinkIconIndicators| nil)))
(rpaq? notecardsdirectories (bquote ((\\\,@ *cache-directories*) "{QV}<NoteCards>1.3L>" "{NB:PARC:XEROX}<NoteCards>1.3L>")))
(declare\: donteval@load donteval@compile
(|AddLoadMenuItem| (quote "WritingAids") (quote ((sysload from notecards) "NoteCards")) (quote (|NoteCards| |NC.NoteCardsIconPosition|)))
)
(* |;;| "Communication & Info")
(rpaqq mail-init-commands ((* |;;;| "LAFITE stuff") (declare\: donteval@load donteval@compile (* |;;| "These have to be VARS instead of INITVARS since they come set to default values in the FULL sysout.") (vars (*new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder)))) (defaultmailfoldername (quote active.mail)) (lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>")) (lafitehardcopybatchflg t) (lafitemovetoconfirmflg (quote left)) (lafiteshowmodeflg (quote always)) (lafitebrowserregion (createregion 360 5 650 165)) (lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175)))) (lafitestatuswindowposition (createposition 100 45)) (lafitemodedefault (or lafitemodedefault (quote gv)))) (* |;;| "In latest Lafite. Of course, it doesn't hurt to set them even if they aren't used.") (vars (lafite.dont.display.headers (quote ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References"))) (lafite.dont.forward.headers lafite.dont.display.headers) (lafite.dont.hardcopy.headers lafite.dont.display.headers)) (* |;;| "There are lots of optional mail utilities") (loadmenuitems "MailTools" (((sysload from lispusers) "LafiteTimedDelete")) (((sysload from lispusers) "LafiteFind")) (((sysload from lispusers) "Maintain")) (((sysload from lispusers) "NSMaintain")) (((sysload from lispusers) "MailScavenge")) (((sysload from lispusers) "Undigestify")) (((from lispusers) "Lafite-Indent")) (((sysload from lispusers) "MailShare")) (((sysload from "{QV}<Briggs>Lisp>") "LafiteFolderIcon")) (((sysload from "{ERIS}<Lafite>Sources>") "AppendMail"))) (p (eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{PHYLUM}<Bobrow>Lisp>") "Short-Lafite-Header"))))))) (* |;;| "") (* |;;| "Additional text at the start and end of a msg") (declare\: donteval@load donteval@compile (p (eval-at-greet (if *new-lafite-p* then (* |;;| "New Lafite running, set the appropriate vars.") (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (* |;;| "Use the hack I wrote") (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg"))))) (* |;;| "Private DL support") (initvars (lafitedldirectories nil)) (declare\: donteval@load donteval@compile (p (eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL"))))))) (* |;;| "Patches to Lafite to put the MOVE-TO folder first in the title.") (p (eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{Phylum}<Bobrow>Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv))))) (coms (* |;;;| "COMMON-LENS stuff") (initvars (\\use-lens? nil) (user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail"))))))) (vars (user::lens-loader-dir "{NB:PARC:Xerox}<CommonLens>Current>")) (p (eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (* \; "Common-Lens already loaded") (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (* \; "Want to use Common-Lens, so load it now") (cl:load (cl:make-pathname :name "LOAD-CLENS" :defaults user::lens-loader-dir))) (t (* \; "Give the user the option of using it later") (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "LOAD-CLENS")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on))))))))) (* |;;| "Turn on mailer (no, no, not Norman -- but he is easy to turn on. Or so I've heard.)") (initvars (\\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber)))) (p (eval-at-greet (cond ((not (getd (quote lafite))) (* \; "Don't turn on mail if it doesn't exist") nil) ((not \\turn-on-mailer) (* \; "Don't turn on if the user doesn't want to") nil) ((and \\use-lens? (not (null (cl:find-package "CLENS")))) (* \; "Use COMMON-LENS if it's here and the user wants it") (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)) (t (* \; "Use Lafite") (lafite (quote on))))))))
(* |;;;| "LAFITE stuff")
(declare\: donteval@load donteval@compile
(rpaq *new-lafite-p* (not (cl:fboundp (quote \\lafite.getmailfolder))))
(rpaqq defaultmailfoldername active.mail)
(rpaq lafitedefaulthost&dir (pack* |\\UserHomeDirectory| "MAIL>"))
(rpaqq lafitehardcopybatchflg t)
(rpaqq lafitemovetoconfirmflg left)
(rpaqq lafiteshowmodeflg always)
(rpaq lafitebrowserregion (createregion 360 5 650 165))
(rpaq lafitedisplayregion (|with| region (windowprop |\\TopLevelTtyWindow| (quote region)) (createregion (max left scrollbarwidth) 175 (widthifwindow (min (quotient (times 2 screenwidth) 3) (times 85 (stringwidth "W" lafitedisplayfont)))) (difference bottom 175))))
(rpaq lafitestatuswindowposition (createposition 100 45))
(rpaq lafitemodedefault (or lafitemodedefault (quote gv)))
(rpaqq lafite.dont.display.headers ("Return-Path" "Redistributed" "Received" "Message-Id" "Comments" "Zippy-Says" "X-Mailer" "Organization" "References"))
(rpaq lafite.dont.forward.headers lafite.dont.display.headers)
(rpaq lafite.dont.hardcopy.headers lafite.dont.display.headers)
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteTimedDelete")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "LafiteFind")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Maintain")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "NSMaintain")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailScavenge")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "Undigestify")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((from lispusers) "Lafite-Indent")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from lispusers) "MailShare")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{QV}<Briggs>Lisp>") "LafiteFolderIcon")))
(|AddLoadMenuItem| (quote "MailTools") (quote ((sysload from "{ERIS}<Lafite>Sources>") "AppendMail")))
(eval-at-greet (cl:unless (not *new-lafite-p*) (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafiteHighlight"))) (|AddLoadMenuItem| "MailTools" (quote ((sysload from "{PHYLUM}<Bobrow>Lisp>") "Short-Lafite-Header")))))
)
(* |;;| "")
(* |;;| "Additional text at the start and end of a msg")
(declare\: donteval@load donteval@compile
(eval-at-greet (if *new-lafite-p* then (* |;;| "New Lafite running, set the appropriate vars.") (rpaq lafite.signature (or lafite.signature (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol))))) (rpaq lafite.gv.from.field (or lafite.gv.from.field (concat (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">"))) else (* |;;| "Use the hack I wrote") (rpaq? lafitemsgtagstring (concat (character (charcode eol)) (character (charcode eol)) "----- " (or (caddr (car initialslst)) "me") (character (charcode eol)))) (rpaq? lafitemsgheaderstring (concat "From: " (or (cadr (car initialslst)) "") " " (username nil nil t) " <" (cond ((cl:fboundp (quote fullusername)) (fullusername)) (t (username))) ">" (character (charcode eol)))) (filesload (noerror from valueof (append private-lispusersdirectories lispusersdirectories)) "Tailor-Lafite-Msg")))
)
(* |;;| "Private DL support")
(rpaq? lafitedldirectories nil)
(declare\: donteval@load donteval@compile
(eval-at-greet (cl:unless *new-lafite-p* (|AddLoadMenuItem| "MailTools" (quote ((sysload from lispusers) "LafitePrivateDL")))))
)
(* |;;| "Patches to Lafite to put the MOVE-TO folder first in the title.")
(eval-at-greet (cl:when (and (cl:fboundp (quote lafite)) (not *new-lafite-p*)) (filesload (sysload noerror from "{Phylum}<Bobrow>Lisp>") "LafiteTitlePatch") (changename (quote la.opentempfile) (quote dsk) (quote scratch)) (lafitemode (quote gv))))
(* |;;;| "COMMON-LENS stuff")
(rpaq? \\use-lens? nil)
(rpaq? user::*lens-user-parameters* (bquote ((:default-host-and-dir lafitedefaulthost&dir) (:icon-pos (createposition 98 8)) (:mailweb-pos (createposition 194 7)) (:mailweb-icon-pos (createposition 194 7)) (:mailweb-font (fontcreate (quote (helvetica 8)))) (:feedback-p nil) (:filing-rule "Filing Rules") (:room-name (quote ("Mail"))))))
(rpaq user::lens-loader-dir "{NB:PARC:Xerox}<CommonLens>Current>")
(eval-at-greet (cond ((cl:member "Common-Lens" *modules* :test (cl:function string-equal)) (* \; "Common-Lens already loaded") (cl:funcall (cl:intern "LOAD-LENS-PATCHES" "CLENS"))) ((and \\use-lens? (not (null (cl:find-package "PCL")))) (* \; "Want to use Common-Lens, so load it now") (cl:load (cl:make-pathname :name "LOAD-CLENS" :defaults user::lens-loader-dir))) (t (* \; "Give the user the option of using it later") (|AddLoadMenuItem| "MailTools" (quote ((from valueof user::lens-loader-dir) "LOAD-CLENS")) (quote (ignore-errors (lafite (quote off)) (cl:funcall (cl:intern "COMMON-LENS" (cl:find-package "CLENS")) :on)))))))
(* |;;| "Turn on mailer (no, no, not Norman -- but he is easy to turn on. Or so I've heard.)")
(rpaq? \\turn-on-mailer (equal (etherhostnumber home-machine-name) (etherhostnumber)))