-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathLOOPSKERNEL
2735 lines (2217 loc) · 135 KB
/
LOOPSKERNEL
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 "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Aug-2022 14:47:13" {DSK}<home>larry>loops>system>LOOPSKERNEL.;2 137227
:CHANGES-TO (VARS LOOPSKERNELCOMS)
:PREVIOUS-DATE "15-Jun-93 12:34:16" {DSK}<home>larry>loops>system>LOOPSKERNEL.;1)
(* ; "
Copyright (c) 1983-1988, 1990-1991, 1993 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT LOOPSKERNELCOMS)
(RPAQQ LOOPSKERNELCOMS
[(DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT LOOPSKERNEL)
(PROP FILETYPE LOOPSKERNEL))
(* ;;; "Functions called by kernel classses")
(FNS * KERNELFNS)
(* ;;; "The kenel classes themselves")
(CLASSES * KERNELCLASSES)
(INITVARS (Viewed-Categories '(Public))
(DumpMethodsInClass))
(METHODS Class.AllInstances Class.AllMethodCategories Class.CVMissing Class.CVValueMissing
Class.CategorizeMethods Class.ChangeMethodCategory Class.CreateInstance
Class.DefMethod Class.DelFromFile Class.EM! Class.Edit Class.Edit! Class.EditMethod
Class.EditMethodObject Class.FetchMethod Class.FileIn Class.FileOut Class.Fringe
Class.GetClassProp Class.HasAttribute Class.HasAttribute! Class.HasItem
Class.IndexedInstances Class.Initialize Class.InstallEditSource Class.ListAttribute
Class.ListAttribute! Class.MakeEditSource Class.MakeFileSource
Class.MakeFullEditSource Class.MethodCategories Class.MoveToFile Class.MoveToFile!
Class.New Class.NewClass Class.NewWithValues Class.Old Class.PickSelector
Class.Prototype Class.Rename Class.RenameMethod Class.ReplaceSupers
Class.SelectorsInCategories Class.SelectorsWithBreak Class.SetName Class.Specialize
Class.SpecializeMethod Class.SubClasses Class.Subclass Class.TraceMethod
Class.UnSetName DestroyedClass.Destroy DestroyedClass.Destroy!
DestroyedClass.DestroyClass DestroyedClass.DestroyInstance DestroyedClass.SubClasses
DestroyedObject.Destroy! MetaClass.CreateClass MetaClass.DestroyInstance MetaClass.New
MetaClass.NewWithValues Method.ChangeClassName Method.ChangeName Method.DelFromFile
Method.EditMethod Method.FileOut Method.MakeFileSource Method.ObjectModified
Method.OldInstance Method.UnSetName Object.ChangeClass Object.Class Object.ClassName
Object.ConformToClass Object.DelFromFile Object.Destroy Object.Destroy!
Object.DoMethod Object.Edit Object.FileOut Object.HasAttribute Object.HasAttribute!
Object.IVMissing Object.IVValueMissing Object.InstallEditSource
Object.InstallFileSource Object.ListAttribute Object.ListAttribute!
Object.MakeEditSource Object.MakeFileSource Object.MessageNotUnderstood
Object.MoveToFile Object.NewInstance Object.ObjectModified Object.OldInstance
Object.OnFile Object.Rename Object.SaveInstance Object.SaveInstance? Object.SetName
Object.UnSetName Tofu.MessageNotUnderstood Tofu.MethodNotFound
Tofu.SuperMethodNotFound)
(FNS MakeMethodMenu MethodMenuWhenSelectedFn SelectFile)
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \PutValueOnly))
DONTEVAL@LOAD
(FILES (LOADCOMP)
LOOPSDATATYPES LOOPSACTIVEVALUES LOOPSMETHODS))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA METHCOM)
(NLAML OldClass)
(LAMA SelectFile])
(DECLARE%: DONTCOPY
(PUTPROPS LOOPSKERNEL MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10))
(PUTPROPS LOOPSKERNEL FILETYPE :COMPILE-FILE)
)
(* ;;; "Functions called by kernel classses")
(RPAQQ KERNELFNS (AddCIV AddCV AddIV AllSubClasses ClassName CopyCVToIV CopyDeepDescr CopyInstance
CopyLoopsStruc DeleteIV DumpInstanceFacts EnsureFnLoaded FixSelectorSpelling
\LoopsFixSpell \LoopsDwim \FixSelectorSpelling GetMethodObj GetMethodObj!
IVSublis METHCOM MapIVs MapIVs! NewWithValues OldClass
SendMessageNotUnderstood SubsTree TypeInMethods WhoHas))
(DEFINEQ
(AddCIV
[LAMBDA (class varName defaultValue otherProps) (* ; "Edited 25-Jun-87 14:02 by smL")
(* ;; "Add an instance variable to the class, if needed, and add properties of otherProps")
(COND
([AND (NULL varName)
(NULL (SETQ varName (PromptRead "Please type the name of the new IV: "]
NIL)
[(FMEMB varName (_ class ListAttribute 'IVs)) (* ; "Variable is local")
(PutClassIV class varName defaultValue)
(for p on otherProps by (CDDR p) do (PutClassIV class varName (CADR p)
(CAR p]
((OddLengthList otherProps)
(ERROR "Odd length property list"))
(T [InstallInstanceVariables class (NCONC1 (GetSourceIVs class)
(CONS varName (CONS defaultValue otherProps]
(OR (FMEMB 'doc (_ class ListAttribute! 'IVPROPS varName))
(PutClassIV class varName `(,COMMENTFLG IV added by ,(USERNAME NIL T)) 'doc))
varName])
(AddCV
[LAMBDA (class varName newValue) (* ; "Edited 25-Jun-87 14:00 by smL")
(* ;;; "Adds a class variable with given newValue. Returns NIL if variable already is in class -- though it does change the value to newValue. Returns varName if variable was added")
(COND
([AND (NULL varName)
(NULL (SETQ varName (PromptRead "Please type name of new CV: "]
NIL)
((FetchCVDescr class varName)
(AND newValue (PutClassValueOnly class varName newValue))
NIL)
(T (InstallClassVariables class (NCONC1 (GetSourceCVs class)
(LIST varName newValue)))
(OR (_ class HasCV varName 'doc)
(PutClassValue class varName `(,COMMENTFLG CV added by ,(USERNAME NIL T)) 'doc))
varName])
(AddIV
[LAMBDA (self name value prop) (* ; "Edited 14-Aug-90 16:23 by jds")
(* * Adds an IV to instance. If it is not in regular set, puts it in assoc List
on otherIVs)
[COND
((NULL name)
(ERROR "A name must be given to add an IV"))
((NOT (_ self HasIV name))
(push (fetch (instance otherIVs) of self)
(CONS name NotSetValue]
(PutValueOnly self name value prop)
value])
(AllSubClasses
[LAMBDA (class currentSubs) (* ; "Edited 14-Aug-90 16:22 by jds")
(* Gets all subclasses recursively,
making sure there are no duplicates.
Called from Class.List!)
(for SUB in (fetch (class subClasses) of class)
do [OR (FMEMB (SETQ SUB (OR (CAR (LISTP SUB))
SUB))
currentSubs)
(SETQ currentSubs (AllSubClasses SUB (CONS SUB currentSubs]
finally (RETURN currentSubs])
(ClassName
[LAMBDA (self) (* ; "Edited 14-Aug-90 16:23 by jds")
(* Returns className of class of
object)
(COND
((type? class self)
(ffetch (class className) of self))
((type? instance self)
(ffetch (class className) of (ffetch (instance class) of self)))
(T (LET ((class (GetLispClass self)))
(COND
(class (ClassName class))
(T (LoopsHelp self "has no class name"])
(CopyCVToIV
[LAMBDA (self varName) (* ; "Edited 14-Aug-90 16:27 by jds")
(* * Used by the IVMissing protocol to copy a CV down to an IV when there is an
%:allocation property)
(LET ((initForm (GetClassValue self varName '%:initForm))
(classValue (GetClassValueOnly self varName)))
(AddIV self varName (if (ValueFound initForm)
then (EVAL initForm)
elseif (type? annotatedValue classValue)
then (_AV classValue CopyActiveValue classValue)
else classValue)))
(for p on (fetch (IVDescr IVProps) of (FetchCVDescr (_ self Class)
varName)) by (CDDR p)
do (PutValueOnly self varName (if (type? annotatedValue (CADR p))
then (_AV (CADR p)
CopyActiveValue
(CADR p))
else (CADR p))
(CAR p])
(CopyDeepDescr
[LAMBDA (descr newObjAlist) (* ; "Edited 14-Jun-88 12:52 by TAL")
(DECLARE (LOCALVARS . T))
(* ;; "Copies instances active values and lists, but bottoms out on anything else")
(SELECTQ (TYPENAME descr)
(instance (OR (CDR (FASSOC descr newObjAlist))
(_ descr CopyDeep newObjAlist)))
(annotatedValue
(create annotatedValue
annotatedValue _ (CopyDeepDescr (fetch annotatedValue of descr)
newObjAlist)))
(LISTP (bind t2 val for valTail on descr
do [COND
[t2 (FRPLACD t2 (SETQ t2 (LIST (CopyDeepDescr (CAR valTail)
newObjAlist]
(T (SETQ val (SETQ t2 (LIST (CopyDeepDescr (CAR valTail)
newObjAlist]
[COND
((AND (CDR valTail)
(NLISTP (CDR valTail)))
(FRPLACD t2 (CopyDeepDescr (CDR valTail)
newObjAlist]
yield val))
descr])
(CopyInstance
[LAMBDA (oldInstance) (* ; "Edited 16-Sep-88 17:26 by TAL")
(* ;;; "make a new instance with the same contents as self, or copy into an instance if given")
(LET ((newInstance (_ (Class oldInstance)
CreateInstance)))
(* ;; "Creating UID for copy loses big. E.g., AVs as default IV value in class generally have UID. When IV is first accessed, AV is copied and stored in instance. If copy has UID it will never go away, and in the case of LispWindowAV this causes the window, bitmap, stream, etc. to stay around also.")
(* %| "(COND ((AND (fetch OBJUID of oldInstance) (NULL (fetch OBJUID of newInstance))) (* ; %"Old one not temporary, but new one has non OBJUID yet%") (UID newInstance)))")
(* ;; "Copy IVSource down one layer of list structure.")
(FillIVs newInstance (Class oldInstance)
(MAPCAR (IVSource oldInstance)
(FUNCTION APPEND)))
newInstance])
(CopyLoopsStruc
[LAMBDA (desc) (* dgb%: "11-NOV-82 02:29")
(SELECTQ (TYPENAME desc)
(instance (_ desc CopyDeep))
(LISTP (CONS (CopyLoopsStruc (CAR desc))
(CopyLoopsStruc (CDR desc))))
desc])
(DeleteIV
[LAMBDA (self varName propName) (* ; "Edited 14-Aug-90 16:23 by jds")
(* * Removes an IV from an Instance. No longer shares IVName List with class.
Some programs which depend on IV may not work.)
[COND
((NULL (_ self HasIV varName))
(ERROR varName "Not instance variable in this instance"))
[propName (WithIVPropDescr self varName [LAMBDA (self varName propDescr)
(InstRemProp propDescr propName]
(LAMBDA (self varName)
NIL]
((_ (Class self)
HasIV! varName)
(ERROR varName "in class. Cannot be deleted from instance"))
(T (change (fetch (instance instIVProps) of self)
(DREMOVE [WithIVPropDescr self varName [LAMBDA (self varName propDescr)
propDescr]
(LAMBDA (self varName)
NIL]
DATUM))
(FillIVs self (Class self)
(DELASSOC varName (IVSource self]
self])
(DumpInstanceFacts
[LAMBDA (instanceRec fileHandle) (* ; "Edited 14-Aug-90 16:23 by jds")
(* ;;; "This prints an expression on the file which specifies the contents of an instance record. Called by (_ object DumpFacts)")
(PROG ((filePos (GETFILEPTR fileHandle)))
(PRIN1 'i fileHandle)
(PRINT
(CONS (fetch (instance class) of instanceRec)
(NCONC [for name exceptions descr in (fetch (instance iNames)
of instanceRec) as i
from 0 when [NEQ 'Any (SETQ exceptions (GetValueOnly instanceRec
name 'DontSave]
collect (SETQ descr (GetVarNth instanceRec i))
(* ;; "Collect a list of properties, omitting those on the list which is the value of the property DontSave. Value should be on that list if the value is not to be dumped.")
(CONS name (COND
((EQ NotSetValue exceptions)
descr)
((NULL (CDR descr))
(COND
((FMEMB 'Value exceptions)
NIL)
(T descr)))
(T (CONS (COND
((FMEMB 'Value exceptions)
(* ; "value is to be omitted")
NotSetValue)
(T (CAR descr)))
(for pair on (CDR descr)
by (CDDR pair)
when (NOT (FMEMB (CAR pair)
exceptions))
join (LIST (CAR pair)
(CADR pair]
(fetch (instance otherIVs) of instanceRec)))
fileHandle)
(RETURN filePos])
(EnsureFnLoaded
[LAMBDA (fn) (* ; "Edited 17-Jun-87 16:35 by smL")
(OR [GETDEF fn 'FNS 'CURRENT '(NOERROR NOCOPY 'NODWIM]
[GETDEF fn 'METHOD-FNS 'CURRENT '(NOERROR NOCOPY 'NODWIM]
(AND (WHEREIS fn 'FNS)
(LOADFNS fn NIL 'PROP))
(AND (WHEREIS fn 'METHOD-FNS)
(LOADVARS fn NIL 'PROP))
(HELPCHECK "Can't find source for " fn])
(FixSelectorSpelling
[LAMBDA (self selector) (* smL " 8-Apr-87 17:50")
(* * Attempt the correct the spelling of a selector -
If we can, and the containing form can be found, smash it to contain the fixed
selector)
(LET ((containingForm (if (AND (BOUNDP '\SendForm)
(EQ \Obj self)
(EQ \Selector selector))
then \SendForm)))
(\LoopsFixSpell selector (_ (Class self)
ListAttribute!
'METHODS NIL 'verboseFlg)
(CONS '_ containingForm)
(CDR containingForm])
(\LoopsFixSpell
[LAMBDA (originalValue possibleValues containingForm tail) (* smL "13-Aug-86 16:50")
(* * Try to correct the originalValue spelling.)
(if (NULL DWIMFLG)
then
(* DWIM disabled, so don't even try to correct the spelling)
NIL
else (\LoopsDwim originalValue (LET ((FIXSPELL.UPPERCASE.QUIET T))
(DECLARE (SPECVARS FIXSPELL.UPPERCASE.QUIET))
(FIXSPELL originalValue NIL possibleValues 'NO-MESSAGE NIL
NIL 'PICKONE T))
containingForm tail])
(\LoopsDwim
[LAMBDA (originalValue correctValue containingForm tail) (* smL "13-Aug-86 16:56")
(* * Make the change if we should, according to DWIM setting)
(if correctValue
then
(* * Print out a msg about the {proposed} translation)
(printout NIL originalValue)
(if containingForm
then (printout NIL " {in ")
(LVLPRIN1 containingForm NIL 3 4)
(printout NIL "}"))
(printout NIL " -> " correctValue)
(if (NULL APPROVEFLG)
then (printout NIL T))
(* * Find out if we should make the translation)
(if (OR (NULL APPROVEFLG)
(EQ 'Y (ASKUSER DWIMWAIT FIXSPELLDEFAULT " ? ")))
then
(* * Make the correction)
(if tail
then (/RPLACA tail correctValue))
(* * Return the corrected value if we want to make the correction)
correctValue])
(\FixSelectorSpelling
[LAMBDA (original possibleValues containingForm tail) (* smL "13-Aug-86 16:44")
(* * Try to correct the original spelling.)
(if (NULL DWIMFLG)
then
(* * DWIM disabled, so don't even try to correct the spelling)
NIL
else (LET [(correctedValue (LET ((FIXSPELL.UPPERCASE.QUIET T))
(DECLARE (SPECVARS FIXSPELL.UPPERCASE.QUIET))
(FIXSPELL original NIL possibleValues 'NO-MESSAGE NIL NIL
'PICKONE T]
(if correctedValue
then
(* * Print out a msg about the {proposed} translation)
(printout NIL original)
(if containingForm
then (printout NIL " {in ")
(LVLPRIN1 (CONS '_ containingForm)
NIL 3 4)
(printout NIL "}"))
(printout NIL " -> " correctedValue)
(if (NULL APPROVEFLG)
then (printout NIL T))
(* * Find out if we should make the translation)
(if (OR (NULL APPROVEFLG)
(EQ 'Y (ASKUSER DWIMWAIT FIXSPELLDEFAULT " ? ")))
then
(* * Make the correction)
(if tail
then (/RPLACA tail correctedValue))
correctedValue])
(GetMethodObj
[LAMBDA (class selector createIfNotFoundFlg) (* ; "Edited 17-Jun-87 16:08 by smL")
(* ;;; "Method objects have names of form className.selector. If not found, and createIfNotFoundFlg=T then create a new one, filling in className and selector")
(LET ((methName (MethName class selector)))
(OR ($! methName)
(if createIfNotFoundFlg
then (LET ((obj (_ ($ Method)
New methName)))
(PutValueOnly obj 'className (ClassName class))
(PutValueOnly obj 'selector selector)
(PutValueOnly obj 'category (LET [(superCategory (GetMethod class selector
'category]
(if (NoValueFound superCategory)
then (LIST (ClassName class))
else superCategory)))
obj])
(GetMethodObj!
[LAMBDA (class selector) (* smL "30-Oct-86 17:15")
(* ;;; "")
(* ;;; "Return the method object for this class and selector,")
(* ;;; "no matter where the method is inherieted from")
(* ;;; "")
(LET [(holding-class (for c in-supers-of class thereis (GetMethodObj c selector]
(if holding-class
then (GetMethodObj holding-class selector)
else NIL])
(IVSublis
[LAMBDA (value alist) (* ; "Edited 14-Aug-90 16:22 by jds")
(* Copy value putting in
substitutions for items on alist.
Called from Object.Sublis)
(PROG ((pair (FASSOC value alist)))
(RETURN (COND
(pair [COND
((NULL (CDR pair))
(COND
((type? instance value)(* This will fix up alist as a side
effect)
(_ value Sublis alist))
(T (RPLACD pair (LIST (IVSublis value alist]
(CADR pair))
[(LISTP value)
(COND
((EQ '* (CAR value)) (* A comment)
(APPEND value))
(T (CONS (IVSublis (CAR value)
alist)
(IVSublis (CDR value)
alist]
((type? annotatedValue value)
(create annotatedValue
annotatedValue _ (IVSublis (fetch (annotatedValue annotatedValue
) of value)
alist)))
(T value])
(METHCOM
[NLAMBDA MS (* ; "Edited 30-Sep-87 16:14 by smL")
(* ;;; "Computes file package commands for METHODS")
(LET
((instList (for M in MS when (OR ($! M)
(PROGN (printout \TopLevelTtyWindow M
" in METHODS list not an object.
")
NIL)) collect M)))
(* ;; "Don't need to (explicity) dump out the method-object unless it contains info that isn't also contained in the method-body.")
`((P (\BatchMethodDefs))
(INSTANCES ,@(for M in instList
when [LET* [(method-object ($! M))
(method-ivs (AND method-object (_ method-object ListAttribute!
'IVS)]
(for iv in method-ivs
thereis (AND [NOT (MEMB iv '(className selector method args doc]
(NOT (NotSetValue (GetIVHere method-object iv]
collect M))
(METHOD-FNS ,@(for M in instList when (EQ M (@ ($! M)
method)) collect M))
(P (\UnbatchMethodDefs])
(MapIVs
[LAMBDA (self mapfn) (* smL "15-Jan-87 16:37")
(* * maps through self applying (mapfn self ivName propName) for all IVnames
and all props, including NIL for the value itself)
(for ivName in (_ self ListAttribute 'IVs) do (for propName
in (CONS NIL (_ self ListAttribute 'IVPROPS
ivName))
do (APPLY* mapfn self ivName propName])
(MapIVs!
[LAMBDA (self mapfn) (* smL "11-Apr-86 15:02")
(* maps through self applying (mapfn self ivName propName) for all IVnames and
all props including inherited ones and NIL for the value itself)
(for ivName in (_ self ListAttribute! 'IVs) do (for propName
in (CONS NIL (_ self ListAttribute!
'IVPROPS ivName))
do (APPLY* mapfn self ivName propName])
(NewWithValues
[LAMBDA (class description) (* dgb%: "24-DEC-83 12:37")
(* * Creates a new instance, substituting values given explicitly in
description Does not initialize variables in the usual way.)
(FillIVs NIL class description])
(OldClass
[NLAMBDA (name) (* edited%: "19-Dec-84 21:59")
(OR (GetObjectRec name)
(NewClass name])
(SendMessageNotUnderstood
[LAMBDA (messageArguments selector) (* dgb%: "14-Dec-84 10:07")
(* * message arguments include object as first of messageArguments.
These are the arguments pased to the function implementing the method.
The selector is not included)
(COND
((EQ selector 'MessageNotUnderstood)
(HELP "MessageNotUnderstood not understood"))
(T (_ (CAR messageArguments)
MessageNotUnderstood selector messageArguments)])
(SubsTree
[LAMBDA (class currentList) (* smL "11-Apr-86 14:52")
(* Compute the SubsTree starting at class given, adding elements to currentList)
[for cl in (_ (GetClassRec class)
ListAttribute
'Subs) do (COND
((NOT (FMEMB cl currentList))
(SubsTree cl (SETQ currentList (NCONC1 currentList cl]
currentList])
(TypeInMethods
[LAMBDA (com name type) (* ; "Edited 2-Jun-87 19:14 by smL")
(* ;; "This function is part of the implementation of METHODS as a file package type. See page 11.31 of the October 83 Interlisp-D manual.")
(LET [(methList (COND
((EQ (CADR com)
'*)
(EVAL (CADDR com)))
(T (CDR com]
(SELECTQ type
((METHODS INSTANCES FNS METHOD-FNS)
[SELECTQ name
((NIL T)
methList)
(COND
((LITATOM name)
(FMEMB name methList))
(T (INTERSECTION name methList])
NIL])
(WhoHas
[LAMBDA (name type files editFlg) (* smL "15-Aug-86 14:35")
(* * Collect all classes on the files that contain name as a type -
type is one of Method IV or -
if editFlg is true, edit the classes/methods)
(for f in (MKLIST (OR files FILELST))
join (for cl in (FILECOMSLST f 'CLASSES)
collect [COND
(editFlg (COND
((FMEMB type '(NIL Method METHOD))
(_ ($! cl)
EditMethod name))
(T (_ ($! cl)
Edit)]
cl when (SELECTQ type
((NIL Method METHOD)
(FindLocalMethod ($! cl)
name))
(IV (_ ($! cl)
HasIV name))
(CV (_ ($! cl)
HasCV name))
NIL])
)
(* ;;; "The kenel classes themselves")
(RPAQQ KERNELCLASSES (AbstractClass Class DestroyedClass DestroyedObject MetaClass Method Object Tofu
))
(DEFCLASSES AbstractClass Class DestroyedClass DestroyedObject MetaClass Method Object Tofu)
(DEFCLASS AbstractClass
(MetaClass MetaClass doc
(* * Abstract classes are placeholders in the inheritance network, which cannot
themselves be instantiated.)
Edited%: (* mjs%: "30-JUN-82 16:41")
)
(Supers MetaClass))
(DEFCLASS Class
(MetaClass MetaClass doc
(* * This is the default metaClass for all classes)
Edited%: (* smL "18-Sep-86 15:04")
)
(Supers Object))
(DEFCLASS DestroyedClass
(MetaClass AbstractClass Edited%: (* kmk%: "13-Dec-84 15:46")
doc (* Becomes the class for any destroyed
class)
)
(Supers AbstractClass))
(DEFCLASS DestroyedObject
(MetaClass Class Edited%: (* TheCollaborators%: "15-Oct-84 16:23")
)
(Supers Object))
(DEFCLASS MetaClass
(MetaClass MetaClass Edited%: (* mjs%: "30-JUN-82 16:38"))
(Supers Class))
(DEFCLASS Method
(MetaClass Class doc (* Connects class to function
implementing method, plus properties)
Edited%: (* smL " 9-May-86 14:40")
)
(Supers Object)
(ClassVariables (ivProperties (doc args category)
doc (* names of IVs which should be made
properties of the method)
))
(InstanceVariables (className NIL doc (* name of class in which this method
appears))
(selector NIL doc (* An atom which is the selector for
the method;))
(method NIL doc
(* Atom name of function which does the work other properties of this IV are
properties of the method)
)
(args NIL doc (* arguments of the method))
(doc NIL doc (* documentation of the method))
(category NIL doc (* if a LITATOM, a public method.
If a LIST, internal))))
(DEFCLASS Object
(MetaClass Class doc (* Default behavior stored here.)
Edited%: (* dgb%: "16-Nov-84 13:46")
)
(Supers Tofu))
(DEFCLASS Tofu
(MetaClass AbstractClass doc (* Minimum super for objects in
system.)
Edited%: (* ; "Edited 30-Nov-87 09:24 by jrb:")
)
(Supers))
(RPAQ? Viewed-Categories '(Public))
(RPAQ? DumpMethodsInClass )
(\BatchMethodDefs)
(METH Class AllInstances NIL
"Find all instances that you can. Used IndexedObject if possible" (category (Class)))
(METH Class AllMethodCategories (includeCategories okSelectors)
"Return a list of all categories for methods of this class" (category (Class)))
(METH Class CVMissing (object varName propName typeFlag newValue)
"Reference to an Undefined CV. Generate an error." (category (Class)))
(METH Class CVValueMissing (object varName propName typeFlag)
"Returns NotSetValue if a value is not found in a CV" (category (Class)))
(METH Class CategorizeMethods (categorization)
"Change the categorization according to the categorization argument, which must be in format: ((category (selectors ...)) ...) --- If this argument isn't provided, then prompt the user to EDIT a form in this syntax that represents the current categorization --- Note that a selector can be in more than one category"
(category (Class)))
(METH Class ChangeMethodCategory (selector newCategory)
"Change the category of a selected method" (category (Class)))
(METH Class CreateInstance (oldObject oldInstanceFlg)
"Creates the data structure for an instance based on the class. If oldObject is given, then just makes
it blank . If oldInstanceFlg=T, then it does not mark the object as modified." (category (Class)))
(METH Class DefMethod (selector args exp file methodType)
"Adds a method for selector to class. If args and expr are NIL, puts user into editor"
(category (Class)))
(METH Class DelFromFile NIL
"Delete a class from a file" (category (Object)))
(METH Class EM! (selector)
"Edit in place, make local or specialize method" (category (Class)))
(METH Class Edit (commands)
"Use Interlisp editor on source of class" (category (Object)))
(METH Class Edit! (commands)
"Use Interlisp editor on source of class including inherited values" (category (Class)))
(METH Class EditMethod (selector commands okCategories)
"Finds the function associated with selector in class, and calls editor on it" (category (Class
)))
(METH Class EditMethodObject (selector)
"Edit the object corresponding to the method" (category (Class)))
(METH Class FetchMethod (selector)
"Find the name of the function which implements this method in this class" (category (Class)))
(METH Class FileIn (fileSource)
"Create an instance from expr, which was read from a file" (category (Class)))
(METH Class FileOut (file)
"Print out a class definition to a file." (category (Object)))
(METH Class Fringe NIL
"List classes which have now subclasses" (category (Class)))
(METH Class GetClassProp (propName)
"Maps through a class and its metaClasses in order to find the value of a property on the class itself.
Returns if property is set, or NotSetValue if none found. If propName is NIL, then returns the
metaClass of the class." (category (Class)))
(METH Class HasAttribute (type name propname)
"Similar to HasItem, but with right semantics from start." (category (Class)))
(METH Class HasAttribute! (type name propname)
"Similar to HasItem!, but with right semantics from start." (category (Class)))
(METH Class HasItem (itemName prop itemType)
"Generalized Has predicate for IVS, CVS, METHODS." (category (Class)))
(METH Class IndexedInstances NIL
"Find IndexedInstances of this class" (category (Class)))
(METH Class Initialize (self)
"Run initial expression for IVs with active value defaults with ls = INITIAL or gfn = AtCreation. In
that case, makes a value which is the expression in GetFn. Other active values are copied to instance
by PutValue" (category (Class)))
(METH Class InstallEditSource (editedDescription)
"Make class conform to new edited description" (category (Object)))
(METH Class ListAttribute (type name)
"Fn to list local parts of a class." (category (Object)))
(METH Class ListAttribute! (type name verboseFlg)
"Recursive version of ListAttribute message. Omits things inherited from Object and Class unless
verboseFlg is T. Sets it to T for Class and Object" (category (Object)))
(METH Class MakeEditSource NIL
"Make a source for editing the class" (category (Object)))
(METH Class MakeFileSource (file)
"Creates a list structure source of a class to be dumped on a file" (category (Object)))
(METH Class MakeFullEditSource NIL
"Make source including inherited values" (category (Class)))
(METH Class MethodCategories (selector)
"Return the category list of a method" (category (Class)))
(METH Class MoveToFile (file)
"Move this class to a file" (category (Object)))
(METH Class MoveToFile! (file fromfiles)
"Move this class and all its subs to file" (category (Class)))
(METH Class New (name arg1 arg2 arg3 arg4 arg5)
"Creates an instance of a particular class. The variable name if given is used to name the object."
(category (Class)))
(METH Class NewClass (init1 init2 init3)
"Just returns newly created class" (category (Class)))
(METH Class NewWithValues (description)
"Create a new instance of the class, with initial IV values given by the description."
(category (Class)))
(METH Class Old (fileSource)
"Find an old object or create a new one with this uid" (category (Class)))
(METH Class PickSelector (title okCategories okSelectors includeGenerics?)
"Let the user pick a defined method selector for this class" (category (Class)))
(METH Class Prototype (newProtoFlg)
"Find an instance of class on CV Prototype, or create an puts one there. Used to send messages for
effect to a prototype object If newProtoFlg=T then make sure a new prototype is created"
(category (Class)))
(METH Class Rename (newName)
"Same as SetName. Classes can have only one name" (category (Object)))
(METH Class RenameMethod (oldSelector newSelector)
"Rename selector, and change function name" (category (Class)))
(METH Class ReplaceSupers (supers)
"replace supers of class by new supers list" (category (Class)))
(METH Class SelectorsInCategories (okCategories okSelectors)
"Return a sorted list of selectors for the class that match the indicated categories"
(category (Class)))
(METH Class SelectorsWithBreak NIL
"Returns a list of selectors whose implementations have a BREAK" (category (Class)))
(METH Class SetName (newClassName)
"Change the newClassName of the class, forgetting old name. Change the names of all methods which are
of the form oldName.selector" (category (Object)))
(METH Class Specialize (newName)
"Creates a class with name newName with self as its only super. If newName is NIL, then makes up an
unused name consisting of current name followed by integer" (category (Class)))
(METH Class SpecializeMethod (selector file)
"Specialize method for selector given" (category (Class)))
(METH Class SubClasses NIL
"Returns a list of immediate subclasses currently known for this class." (category (Class)))
(METH Class Subclass (super)
"Is self a subclass of super? If it is, return super, else NIL." (category (Class)))
(METH Class TraceMethod (selector)
"Trace selected method, or give choice if selector is NIL" (category (Class)))
(METH Class UnSetName (name)
"Unname entity" (category (Object)))
(METH DestroyedClass Destroy NIL
"you don't have to do anything to destroy a destroyed class" (category (Object)))
(METH DestroyedClass Destroy! NIL
"Similar to DestroyedObject.Destroy! -- Nothing to do once one is dstroyed" (category (Object)))
(METH DestroyedClass DestroyClass (classToDestroy)
"Destroy the class specified by smashing its contents" (category (Class)))
(METH DestroyedClass DestroyInstance (self)
"smash back pointer to entity rec, the list of vars and var descriptions" (category (Class)))
(METH DestroyedClass SubClasses NIL
"Non subclasses" (category (Class)))
(METH DestroyedObject Destroy! NIL
"Do nothing. I am already destroyed" (category (Object)))
(METH MetaClass CreateClass (name supers)
"Create the data object for a class, checking the inputs" (category (MetaClass)))
(METH MetaClass DestroyInstance NIL
"Destroy the class specified by smashing its contents" (category (Class)))
(METH MetaClass New (name supers init1 init2 init3)
"New method for MetaClass. Since MetaClass is its own metaClass, this needs to work correctly whether
the self is Class or MetaClass or a subClass of MetaClass. Work is done by DefineClass in LOOPS."
(category (Class)))
(METH MetaClass NewWithValues (selector superFlg)
"Create a new class, filled in with the given descriptor" (category (Class)))
(METH Method ChangeClassName (newClassName)
"Change name of class -- called when className is changed" (category (Method)))
(METH Method ChangeName (oldMethName newMethName newSelector)
"Change the name of the method and update the file" (category (Method)))
(METH Method DelFromFile NIL
"Delete from a file as a method" (category (Object)))
(METH Method EditMethod NIL
"Edit the method defintion" (category (Method)))
(METH Method FileOut (file)
"Print out filesource for methods" (category (Object)))
(METH Method MakeFileSource NIL