-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathLOOPSMETHODS
1224 lines (1012 loc) · 59.3 KB
/
LOOPSMETHODS
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>LOOPSMETHODS.;2 59350
:CHANGES-TO (VARS LOOPSMETHODSCOMS)
:PREVIOUS-DATE " 6-Nov-91 16:29:23" {DSK}<home>larry>loops>system>LOOPSMETHODS.;1)
(* ; "
Copyright (c) 1984-1988, 1990-1991 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT LOOPSMETHODSCOMS)
(RPAQQ LOOPSMETHODSCOMS
[
(* ;; " WARNING: YOU MUST SET *Compile-Local-Message-Cache* TO NIL BEFORE COMPILING THIS FILE. Failing to do so, you'll get a Cached-FetchMethodOrHelp that calls itself recursively forever.")
(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (P (SETQ *Compile-Local-Message-Cache* NIL)))
(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
LOOPSSTRUC))
(* ;;; "Translation of METHOD forms to LAMBDA forms")
(COMS
(* ;; "Ways to send a message")
(FUNCTIONS _ SEND _! __ _New _IV)
(MACROS _Proto _Try _Process _Process! SENDSUPER)
(FNS FetchMethodLocally _Apply)
(MACROS DOAPPLY* DoMethod FetchMethod FindSelectorIndex GetNthMethod MapSupersForm?)
(COMS (* ; "Optimizer for _")
(INITVARS (*Compile-Local-Message-Cache* T))
(OPTIMIZERS _ SEND)))
(FUNCTIONS SubclassResponsibility)
(FNS AddMethod ApplyMethod ApplyMethodInTtyProcess DefMethObj DefineMethod DeleteMethod
DoFringeMethods DoMethod FindSuperMethod IVFunction BootInstallMethod FullInstallMethod
InstanceNotMethod LoopsHelp METH METHOBJ MessageAuthor MethName MoveMethod RenameMethod
\ApplyMethod FindLocalMethod FindSelectorIndex FetchMethod FetchMethodOrHelp
GetCallerClass GetNthMethod GetSuperMethod PutMethodNth DCM)
(P (MOVD? 'BootInstallMethod 'InstallMethod))
(* ;;; "Method lookup caching stuff")
(FNS Cached-FetchMethodOrHelp)
(* ;;; "Other stuff ???")
(MACROS MapSupersForm MapSupersUnlessBadList NextSuperClass)
(FNS GetMethodSource CheckMethodChanged CheckMethodForm)
(INITVARS (LoopsDebugFlg T))
(P (ADDTOVAR NLAMA METH DoMethod DoFringeMethods))
(DECLARE%: DONTCOPY (PROP FILETYPE LOOPSMETHODS)
(PROP MAKEFILE-ENVIRONMENT LOOPSMETHODS))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA METH DoMethod
DoFringeMethods
)
(NLAML METHOBJ)
(LAMA LoopsHelp])
(* ;;
" WARNING: YOU MUST SET *Compile-Local-Message-Cache* TO NIL BEFORE COMPILING THIS FILE. Failing to do so, you'll get a Cached-FetchMethodOrHelp that calls itself recursively forever."
)
(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD
(SETQ *Compile-Local-Message-Cache* NIL)
)
(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
LOOPSSTRUC)
)
(* ;;; "Translation of METHOD forms to LAMBDA forms")
(* ;; "Ways to send a message")
(DEFMACRO _ (self selector &REST args)
`(_! ,self ',selector ,@args))
(DEFMACRO SEND (self selector &REST args)
`(_ ,self ,selector ,@args))
(DEFMACRO _! (self selector &REST args)
[Once-Only (self)
`(APPLY* (FetchMethodOrHelp ,self ,selector)
,self
,@args])
(DEFMACRO __ (self selector &REST args)
`(_ ,self ,selector ,@(for x in args collect (KWOTE x))))
(DEFMACRO _New (class &OPTIONAL (selector NIL selector-supplied-p)
&REST args)
(if selector-supplied-p
then [LET ((self (GENSYM)))
`(LET ((,self (_ ,class New)))
(DECLARE (LOCALVARS ,self))
(_ ,self ,selector ,@args)
,self]
else `(_ ,class New)))
(DEFMACRO _IV (self IVName &REST args)
[Once-Only (self)
`(APPLY* (IVFunction ,self ',IVName)
,self
,@args])
(DECLARE%: EVAL@COMPILE
(PUTPROPS _Proto MACRO ((obj . args)
(_ (_ obj Prototype) . args)))
(PUTPROPS _Try MACRO [(obj action . args)
(PROG ((obj% obj))
(RETURN (DOAPPLY* (OR (FetchMethod (Class obj% )
'action)
(RETURN 'NotSent))
obj% . args])
(PUTPROPS _Process MACRO [X (LET [(obj (CAR X))
(selector (CADR X))
(args (CONS 'LIST (CDDR X]
`(ADD.PROCESS (LIST 'ApplyMethod (KWOTE ,obj)
(KWOTE ',selector)
(KWOTE ,args))
'NAME
',selector])
(PUTPROPS _Process! MACRO [X (LET [(obj (CAR X))
(selector (CADR X))
(args (CONS 'LIST (CDDR X]
`(ADD.PROCESS (LIST 'ApplyMethod (KWOTE ,obj)
(KWOTE ,selector)
(KWOTE ,args))
'NAME
',selector])
(PUTPROPS SENDSUPER MACRO ((obj action . args)
(_Super obj action . args)))
)
(DEFINEQ
(FetchMethodLocally
[LAMBDA (classRec selector) (* ; "Edited 16-Mar-88 16:29 by jrb:")
(LET (index)
(COND
((SETQ index (FindSelectorIndex classRec selector))
(GetNthMethod classRec index])
(_Apply
[LAMBDA (argList) (* ; "Edited 14-Aug-90 16:53 by jds")
(* Apply the selected method to the
already evaluated args in argList.)
(APPLY [OR (FetchMethod (fetch (OBJECT CLASS) of (CAR argList))
(CADR argList))
(ERROR (CADR argList)
(CONCAT "not a selector in " (fetch (OBJECT CLASS) of (CAR argList]
(CONS (CAR argList)
(CDDR argList])
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS DOAPPLY* MACRO (arg (CONS 'CL:FUNCALL arg)))
(PUTPROPS DoMethod MACRO [(obj action class . args)
(LET ((obj% obj)
(class% class))
(if (Class? (OR class% (fetch (OBJECT CLASS) of obj% )))
then (DOAPPLY* (OR (FetchMethod (OR class% (fetch (OBJECT CLASS)
of obj% ))
action)
(ERROR action "not found for DoMethod"))
obj% . args)
else (ERROR (OR class% (fetch (OBJECT CLASS) of obj% ))
"not a class"])
(PUTPROPS FetchMethod MACRO [OPENLAMBDA (classRec selector)
(PROG ((pos (LLSH (LOGAND 1023 (LOGXOR (\LOLOC classRec)
(\LOLOC selector)))
3))
(class classRec)
meth index supers)
(DECLARE (LOCALVARS . T))
[COND
((AND (EQ class (\GETBASEPTR *Global-Method-Cache* pos))
(EQ selector (\GETBASEPTR (\ADDBASE
*Global-Method-Cache* 2
)
pos)))
(RETURN (\GETBASEPTR (\ADDBASE *Global-Method-Cache* 4)
pos]
(SETQ supers (fetch (class supers) of classRec))
LP (COND
((SETQ index (FindSelectorIndex class selector))
(SETQ meth (GetNthMethod class index))
(\PUTBASEPTR *Global-Method-Cache* pos classRec)
(\PUTBASEPTR (\ADDBASE *Global-Method-Cache* 2)
pos selector)
(\PUTBASEPTR (\ADDBASE *Global-Method-Cache* 4)
pos meth)
(RETURN meth))
((SETQ class (pop supers))
(GO LP))
(T (RETURN NIL])
(PUTPROPS FindSelectorIndex MACRO [OPENLAMBDA (classrec selector)
(PROG NIL
(RETURN (\FindEntryIndex selector
(OR (fetch (class selectors) of classrec)
(RETURN])
(PUTPROPS GetNthMethod MACRO [OPENLAMBDA (classrec n)
(LET ((meths (fetch (class methods) of classrec)))
(COND
((LISTP meths)
(GetNth meths n))
(T (\GetNthEntry meths n])
(PUTPROPS MapSupersForm? MACRO ((mappingForm classRec . progArgs)
(PROG (supers (class classRec) . progArgs)
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP
mappingForm
ON (COND
((SETQ class (pop supers))
(GO LP)))
(RETURN NotSetValue))))
)
(* ; "Optimizer for _")
(RPAQ? *Compile-Local-Message-Cache* T)
(DEFOPTIMIZER _ (object selector &REST args)
[if (AND *Compile-Local-Message-Cache* *BYTECOMPILER-IS-EXPANDING*)
then `(LET [(/\obj/\ ,object)
(*LOOPS-INLINE-METHOD-CACHE* (LOADTIMECONSTANT (
\Make-Method-Cache-Entry
]
(DECLARE (LOCALVARS /\obj/\ *LOOPS-INLINE-METHOD-CACHE*))
(LOOPS-FUNCALL (COND
((AND (Object? /\obj/\)
(EQ (\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 0
)
(fetch (OBJECT CLASS) of /\obj/\)))
(* ; "A cache hit")
(\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 2))
(T (* ; "A cache miss")
(Cached-FetchMethodOrHelp /\obj/\
',selector *LOOPS-INLINE-METHOD-CACHE*)))
/\obj/\
,@args))
(* ;; "`((OPENLAMBDA (/\obj/\ *LOOPS-INLINE-METHOD-CACHE*) (DECLARE (LOCALVARS . T)) (CL:FUNCALL (if (AND (Object? /\obj/\) (EQ (\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 0) (fetch (OBJECT CLASS) of /\obj/\))) then ; A cache hit (\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 2) else ; A cache miss (Cached-FetchMethodOrHelp /\obj/\ ',selector *LOOPS-INLINE-METHOD-CACHE*)) /\obj/\ ,@args)) ,object (LOADTIMECONSTANT (\Make-Method-Cache-Entry)))")
elseif *BYTECOMPILER-IS-EXPANDING*
then `(LET ((/\obj/\ ,object))
(DECLARE (LOCALVARS /\obj/\))
(LOOPS-FUNCALL (FetchMethodOrHelp /\obj/\ ',selector)
/\obj/\
,@args))
else
(LET*
[(obj (if (LITATOM object)
then object
else (GENSYM)))
[bindings (if (EQ obj object)
then NIL
else `((,obj ,object]
(localVars (for binding in bindings collect (CAR binding]
(if *Compile-Local-Message-Cache*
then
`(LET (,@bindings)
(* ;;
",@(if localVars then `((DECLARE (LOCALVARS ,@localVars))) else NIL)")
(DECLARE (LOCALVARS . T))
(LOOPS-FUNCALL (LET [(*LOOPS-INLINE-METHOD-CACHE* (LOADTIMECONSTANT
(
\Make-Method-Cache-Entry
]
(* ;; "This bogus SPECVARS stuff is here to prevent the compiler from thinking that the in-line cache is a quoted constant. Note that (almost) no user code gets called within this binding, so it is pretty safe. (The potential exception is when the user has redefined the FetchMethodOrHelp method).")
(* ;;
"(DECLARE (SPECVARS *LOOPS-INLINE-METHOD-CACHE*))")
(if [AND (Object? ,obj)
(EQ (\GETBASEPTR
*LOOPS-INLINE-METHOD-CACHE* 0)
(fetch (OBJECT CLASS)
of ,obj]
then (* ; "A cache hit")
(\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 2)
else (* ; "A cache miss")
(Cached-FetchMethodOrHelp ,obj
',selector *LOOPS-INLINE-METHOD-CACHE*
)))
,obj
,@args))
elseif bindings
then `(LET (,@bindings)
(DECLARE (LOCALVARS ,@localVars))
(LOOPS-FUNCALL (FetchMethodOrHelp ,obj ',selector)
,obj
,@args))
else `(LOOPS-FUNCALL (FetchMethodOrHelp ,obj ',selector)
,obj
,@args])
(DEFOPTIMIZER SEND (object selector &REST args)
[if (AND *Compile-Local-Message-Cache* *BYTECOMPILER-IS-EXPANDING*)
then `(LET [(/\obj/\ ,object)
(*LOOPS-INLINE-METHOD-CACHE* (LOADTIMECONSTANT (
\Make-Method-Cache-Entry
]
(DECLARE (LOCALVARS /\obj/\ *LOOPS-INLINE-METHOD-CACHE*))
(LOOPS-FUNCALL (COND
((AND (Object? /\obj/\)
(EQ (\GETBASEPTR
*LOOPS-INLINE-METHOD-CACHE* 0)
(fetch (OBJECT CLASS) of /\obj/\)))
(* ; "A cache hit")
(\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 2))
(T (* ; "A cache miss")
(Cached-FetchMethodOrHelp /\obj/\
',selector *LOOPS-INLINE-METHOD-CACHE*)
))
/\obj/\
,@args))
(* ;; "`((OPENLAMBDA (/\obj/\ *LOOPS-INLINE-METHOD-CACHE*) (DECLARE (LOCALVARS . T)) (CL:FUNCALL (if (AND (Object? /\obj/\) (EQ (\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 0) (fetch (OBJECT CLASS) of /\obj/\))) then ; A cache hit (\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE* 2) else ; A cache miss (Cached-FetchMethodOrHelp /\obj/\ ',selector *LOOPS-INLINE-METHOD-CACHE*)) /\obj/\ ,@args)) ,object (LOADTIMECONSTANT (\Make-Method-Cache-Entry)))")
elseif *BYTECOMPILER-IS-EXPANDING*
then `(LET ((/\obj/\ ,object))
(DECLARE (LOCALVARS /\obj/\))
(LOOPS-FUNCALL (FetchMethodOrHelp /\obj/\ ',selector)
/\obj/\
,@args))
else
(LET*
[(obj (if (LITATOM object)
then object
else (GENSYM)))
[bindings (if (EQ obj object)
then NIL
else `((,obj ,object]
(localVars (for binding in bindings collect (CAR binding]
(if *Compile-Local-Message-Cache*
then
`(LET (,@bindings)
(* ;;
",@(if localVars then `((DECLARE (LOCALVARS ,@localVars))) else NIL)")
(DECLARE (LOCALVARS . T))
(LOOPS-FUNCALL (LET [(*LOOPS-INLINE-METHOD-CACHE* (LOADTIMECONSTANT
(
\Make-Method-Cache-Entry
]
(* ;; "This bogus SPECVARS stuff is here to prevent the compiler from thinking that the in-line cache is a quoted constant. Note that (almost) no user code gets called within this binding, so it is pretty safe. (The potential exception is when the user has redefined the FetchMethodOrHelp method).")
(* ;;
"(DECLARE (SPECVARS *LOOPS-INLINE-METHOD-CACHE*))")
(if [AND (Object? ,obj)
(EQ (\GETBASEPTR
*LOOPS-INLINE-METHOD-CACHE* 0
)
(fetch (OBJECT CLASS)
of ,obj]
then (* ; "A cache hit")
(\GETBASEPTR *LOOPS-INLINE-METHOD-CACHE*
2)
else (* ; "A cache miss")
(Cached-FetchMethodOrHelp
,obj
',selector *LOOPS-INLINE-METHOD-CACHE*)))
,obj
,@args))
elseif bindings
then `(LET (,@bindings)
(DECLARE (LOCALVARS ,@localVars))
(LOOPS-FUNCALL (FetchMethodOrHelp ,obj ',selector)
,obj
,@args))
else `(LOOPS-FUNCALL (FetchMethodOrHelp ,obj ',selector)
,obj
,@args])
(DEFMACRO SubclassResponsibility ()
(DECLARE (CL:SPECIAL *ArgsOfMethodBeingCompiled* *ClassNameOfMethodOwner*
*SelectorOfMethodBeingCompiled* *SelfOfMethodBeingCompiled*))
`(HELPCHECK (CONCAT "Method " ,*SelectorOfMethodBeingCompiled* " of class "
,*ClassNameOfMethodOwner* " needs to be defined in class ")
(_ ,*SelfOfMethodBeingCompiled* ClassName)))
(DEFINEQ
(AddMethod
[LAMBDA (class selector method) (* ; "Edited 14-Aug-90 16:53 by jds")
(* * Adds a method to a class, or replaces the function named if selecor is
already local to class)
(LET ((index (FindSelectorIndex class selector)))
(COND
(index (* already in class)
(PutMethodNth class index method))
(T
(* This is an efficiency hack. If we flush the cache on new method read in from
a file, we can waste a great deal of time.
This counts on the filepackage def for methods dumping out an explicit call to
FlushMethodCache at the end of a block of methods.)
(if (NOT (\BatchMethodDefs?))
then (FlushMethodCache))
(UNINTERRUPTABLY
(LET* ((sels (fetch (class selectors) of class))
(freePos (\FreeEntryIndex sels)))
(replace (class selectors) of class with (\AddBlockEntry sels
selector freePos
))
(replace (class methods) of class with
(\AddBlockEntry
(fetch (class methods)
of class)
method freePos))))])
(ApplyMethod
[LAMBDA (object selector argList class) (* ; "Edited 14-Aug-90 16:53 by jds")
(* Apply the selected method to the
already evaluated args in argList.)
(if (OR (type? instance object)
(type? class object))
then (APPLY [OR (FetchMethod (OR class (fetch (OBJECT CLASS) of object))
selector)
(ERROR selector (CONCAT "not a selector in " (OR class
(fetch (OBJECT
CLASS)
of object]
(CONS object argList))
else (HELPCHECK object " not an instance or class"])
(ApplyMethodInTtyProcess
(LAMBDA (object selector argList class) (* ; "Edited 27-May-87 17:06 by smL")
(* Apply the selected method to the already evaluated args in argList as a tty
process.)
(EVAL.IN.TTY.CONTEXT `(ApplyMethod ,object ',selector ',argList ,class) selector)))
(DefMethObj
(LAMBDA (cName sel fn arg dcm methodProps otherIVs) (* ; "Edited 17-Jun-87 16:09 by smL")
(* ;; "Creates the method object and fills in its IVs If the UID of the object is there, then use it else create a new object")
(LET ((uid (LISTGET methodProps 'UID))
(methName (AND cName (MethName cName sel)))
(methClass (OR ($! (LISTGET methodProps 'methodClass))
($ Method)))
oldSelf self)
(SETQ oldSelf ($! methName)) (* ;
"If there is already an instance with the same name and class, use it")
(SETQ self (COND
((AND oldSelf (OR (NULL uid)
(NOT (HasUID? oldSelf))
(UIDEqual uid (UID oldSelf)))
(EQ methClass (Class oldSelf))) (* ;
"already have the method instance, so re-use it")
oldSelf)
(T (NewObject methClass (COND
((NULL uid)
(Make-UID))
(T uid))))))
(COND
(methName (NameObject self (CONS methName))))
(PutValueOnly self 'className cName)
(PutValueOnly self 'selector sel)
(PutValueOnly self 'args arg)
(PutValueOnly self 'doc dcm)
(PutValueOnly self 'method fn)
(for p on methodProps do (PutValueOnly self 'method (CADR p)
(CAR p)) by (CDDR p))
(* ;; "method is filled by fn. all the other IVs which the method can have are in oth, and will be filled into the instance")
(COND
(otherIVs (FillInst otherIVs self)))
(InstallMethod self)
self)))
(DefineMethod
[LAMBDA (class selector args expr file methodType) (* ; "Edited 23-Nov-87 16:58 by Bane")
(* ;;; "Define a new method (or replace an old one). If expr is NIL then args should be a list of arguments, and expr should be the function definition. File is the place where this method should be stored. methodType can be a method defining macro or NIL.")
(if (NOT (LITATOM selector))
then (ERROR selector "is not a LIATOM, so cannot be a selector"))
(if (NOT (LITATOM file))
then (ERROR file "is not a LITATOM, so can't be a fileName"))
(if (AND args (LITATOM args))
then (* ;
"Naming a function to be used as a method - this is no longer allowed")
(ERROR "Can't explicitly name the method function"))
(if (NOT (Class? class))
then (ERROR class "is not a Class object"))
(LET* [(className (GoodClassName class))
(methName (MethName className selector))
(doc (if [AND (LISTP expr)
(LISTP (CDR expr))
(OR (AND (LISTP (CAR expr))
(EQ COMMENTFLG (CAAR expr)))
(STRINGP (CAR expr]
then (pop expr)
else (CONCAT "Method documentation"]
(* ;; "Save the method on a file")
(COND
([OR file (AND (NULL (WHEREIS methName 'METHODS))
(SETQ file (CAR (WHEREIS className 'CLASSES]
(ADDTOFILE methName 'METHODS file)))
(* ;; "Build the method")
(EVAL (PACK-METHOD-BODY className selector (CONS 'self args)
NIL
(COND
[(NULL expr) (* ; "No Method Body Given")
(COPY `((SubclassResponsibility]
([AND (LISTP expr)
(NOT (LISTP (CAR expr] (* ;
"This is a single expression, not an implicit PROGN")
(LIST expr))
(T expr))
doc NIL methodType))
(* ;; "Edit it if no body was provided")
(COND
((NOT (OR args expr))
(_ class EditMethod selector)))
(* ;; "Return the name")
methName])
(DeleteMethod
[LAMBDA (class selector prop) (* ; "Edited 14-Aug-90 16:53 by jds")
(* ;; "If prop is NIL or T this means delete the method from the class. Otherwise delete the method property. If prop is T then also delete the function definition")
(PROG (methObj (methName (MethName class selector))
index pl fn freePos sel file)
TRYAGAIN
(SETQ class (GetClassRec class))
(SETQ index (FindSelectorIndex class selector))
(COND
((NULL class)
(SETQ class (HELPCHECK class
" is not a known class. Type
RETURN 'className
to try again"))
(GO TRYAGAIN))
((NULL index)
(SETQ selector (HELPCHECK class " does not contain the selector " selector
"Type
RETURN 'selectorName
to try again"))
(GO TRYAGAIN)))
(SETQ fn (GetMethod class selector))
(COND
(prop (APPLY* (FUNCTION UNBREAK)
fn)))
[COND
((EQ prop T) (* ;
"T is special Flag for deleteing the function definition too")
(SETQ prop NIL)
(CLEARW PROMPTWINDOW)
(printout PROMPTWINDOW (CHARACTER 7)
"Deleting function definition for " fn T)
(\PUTD fn))
[prop (* ;
"This deletes a real property of a method")
(SETQ methObj (GetMethodObj class selector))
(RETURN (COND
((FMEMB prop (GetClassValue methObj 'ivProperties))
(PutValueOnly methObj prop NotSetValue))
(T (DeleteIV methObj 'method prop]
((SETQ file (WHEREIS (SETQ fn (GetMethod class selector))
'METHODS)) (* ; "Remember to save fn")
(ADDTOFILE fn 'FNS (CAR file]
(* ;; "\DeleteNthEntry requires knowing the freePos. Must compute it from selectors because it checks for occurrence of NIL in block to mark end")
(MARKASCHANGED methName 'METHODS 'DELETED)
(FlushMethodCache)
(AND ($! methName)
(_ ($! methName)
Destroy))
(UNINTERRUPTABLY
[SETQ freePos (\FreeEntryIndex (SETQ sel (fetch (class selectors) of class]
(\DeleteNthEntry sel index freePos)
(\DeleteNthEntry (fetch (class methods) of class)
index freePos))])
(DoFringeMethods
[NLAMBDA |obj selector ..args| (* ; "Edited 14-Aug-90 16:53 by jds")
(* * This calls all the methods of an object in the immediate supers of the
object. selector is evaluated.)
(PROG [selector object objClass fn (argList (MAPCAR |obj selector ..args| (FUNCTION EVAL]
(DECLARE (LOCALVARS . T))
(SETQ object (CAR argList))
(SETQ selector (CADR argList))
(SETQ argList (CONS object (CDDR argList)))
(SETQ objClass (Class object))
(COND
((NULL objClass)
(ERROR object "has no class"))
((SETQ fn (FetchMethodLocally objClass selector))
(APPLY fn argList))
(T (for cls in (fetch (class localSupers) of objClass)
do (COND
((SETQ fn (FetchMethod cls selector))
(APPLY fn argList])
(DoMethod
(NLAMBDA |obj selector class ..args| (* smL "29-May-86 17:55")
(* Function for macro so that args are
known)
(DECLARE (LOCALVARS . T)
(SPECVARS classForMethod))
(LET (classForMethod allArgs oBj)
(SETQ allArgs (MAPCAR |obj selector class ..args| (FUNCTION EVAL)))
(SETQ oBj (pop allArgs))
(if (type? class (OR (CADR allArgs)
(Class oBj)))
then (APPLY (OR (FetchMethod (OR (CADR allArgs)
(Class oBj))
(CAR allArgs))
(ERROR (CAR allArgs)
(CONCAT "not a selector for " (OR (CADR allArgs)
(Class oBj)))))
(CONS oBj (CDDR allArgs)))
else (ERROR (OR (CADR allArgs)
(Class oBj))
"not a class")))))
(FindSuperMethod
(LAMBDA (object selector classOfSendingMethod noError?) (* smL " 5-Jun-86 14:29")
(* Searches for an selector up the supers chain.
If none found, calls LISP HELP)
(OR (for class in (LET ((class (Class object)))
(COND
((EQ classOfSendingMethod class)
(Supers class))
(T (CDR (FMEMB classOfSendingMethod (Supers class)))))) bind index
do (COND
((SETQ index (FindSelectorIndex class selector))
(* There is a response in this class)
(RETURN (GetNthMethod class index)))))
noError?
(_ object SuperMethodNotFound selector classOfSendingMethod))))
(IVFunction
(LAMBDA (obj ivName) (* edited%: " 3-Apr-86 17:36")
(LET ((fnName (GetValue obj ivName)))
(COND
((DEFINEDP fnName)
fnName)
(T (LoopsHelp "No iv function" obj ivName fnName))))))
(BootInstallMethod
(LAMBDA (self) (* edited%: "21-Nov-85 14:18")
(* Used in kernel system to add methods.
Replaced by FullInstallMethod after LOOPSKERNEL is loaded by LOADLOOPS)
(AddMethod (GetObjectRec (GetIVHere self 'className))
(GetIVHere self 'selector)
(GetIVHere self 'method))))
(FullInstallMethod
(LAMBDA (self) (* dgb%: " 1-NOV-83 08:02")
(* Used after kernel is installed. Calls a method to install a method)
(_ self OldInstance)))
(InstanceNotMethod
(LAMBDA (name) (* edited%: " 6-Feb-85 17:44")
(* test if this instance is not a
method)
(LET ((inst ($! name)))
(COND
((AND (type? instance inst)
(NOT (_ inst InstOf! 'Method)))
(GetInstanceSource name))))))
(LoopsHelp
(LAMBDA msgs (* smL "25-Apr-86 15:36")
(* * The standard way of generating an error in Loops.
-
If LoopsDebugFlg is set, go into a continuable error, otherwise generate an
un-continuable error.)
(LET ((msg (APPLY (FUNCTION CONCAT)
(CDR (for i from 1 to msgs join (LIST " " (ARG msgs i)))))))
(if LoopsDebugFlg
then (HELP "LoopsHelp:" msg)
else (ERROR "LoopsHelp:" msg)))))
(METH
(NLAMBDA methDescr (* smL "19-Aug-86 11:43")
(* * Put out by the class method. Contains in order the
(className selector methName (if different from className.selector) args doc . other-properties))
(LET (self cName sel fnName methName args doc methodProps (descr methDescr))
(SETQ cName (pop descr))
(SETQ sel (pop descr))
(SETQ methName (MethName cName sel))
(COND
((AND (SETQ fnName (CAR descr))
(LITATOM fnName)) (* Method name which is not identical
to methName)
(SETQ descr (CDR descr)))
(T (SETQ fnName methName)))
(SETQ args (pop descr))
(SETQ doc (pop descr))
(COND
((EQ 'method (CAAR descr))
(* There are methodProps or there is a funny function name)
(SETQ methodProps (pop descr))
(SETQ fnName (CADR methodProps))
(SETQ methodProps (CDDR methodProps))))
(DefMethObj cName sel fnName args doc methodProps descr))))
(METHOBJ
(NLAMBDA (methodInfo doc otherIVs methodType uid) (* kmk%: "22-Feb-85 17:16")
(* * Input form is -- (METHOBJ2 ((selector argListSpec)%.
argList) doc otherIVs methodType uid))
(DefMethObj (CADR (CAR methodInfo))
(CAAR methodInfo)
(MethName (CADR (CAR methodInfo))
(CAAR methodInfo))
(CDR (CDR methodInfo))
doc
(LIST 'methodClass methodType 'UID uid)
otherIVs)))
(MessageAuthor
(LAMBDA NIL (* smL "17-Mar-85 18:53")
(LET ((currentMessage (STKSCAN 'self)))
(AND currentMessage (EVALV 'self (STKNTH 1 currentMessage))))))
(MethName
(LAMBDA (classOrName selector) (* dgb%: " 5-Apr-84 08:14")
(* Make name of form
className.selector)
(PACK* (COND
((type? class classOrName)
(ClassName classOrName))
(T classOrName))
"." selector)))
(MoveMethod
[LAMBDA (oldClassName newClassName selector newSelector files)
(* ; "Edited 16-Mar-88 14:50 by jrb:")
(* ;;; "Move a method from oldClassName to newClassName, renaming function if appropriate")
(SETQ oldClassName (GoodClassName oldClassName NIL T))
(OR newClassName (SETQ newClassName oldClassName))
(SETQ newClassName (GoodClassName newClassName NIL T))
(OR newSelector (SETQ newSelector selector))
(PROG (oldDef newLocalFn delFnFlg (oldClass (GetClassRec oldClassName))
(newClass (GetClassRec newClassName))
(localFn (FindLocalMethod (GetClassRec oldClassName)
selector)))
(* ;; "Punt now for null moves")
(if (AND (EQ oldClass newClass)
(EQ selector newSelector))
then (RETURN NIL))
(COND
((NULL localFn)
(printout T selector " not found in " oldClassName)
(RETURN NIL))
[(STRPOS oldClassName localFn)
(OR (SETQ oldDef (GETDEF localFn 'METHOD-FNS))
(ERROR "No defintion found for " localFn)) (* ;
"Remember to delete fn def Dont use DELDEF since it bitches.")
(SETQ delFnFlg T) (* ; "Define the method")
(SETQ newLocalFn (EVAL (CL:MULTIPLE-VALUE-BIND (cname sel args decls formsd doc quals
method-type)
(PARSE-METHOD-BODY oldDef)
(PACK-METHOD-BODY newClassName newSelector args decls
formsd doc quals method-type]
(T (AddMethod newClass newSelector localFn)))
(for prop in (DREMOVE 'RuleSet (_ oldClass ListAttribute 'Method selector))
do (PutMethodOnly newClass newSelector (GetMethodOnly oldClass selector prop)
prop))
(DeleteMethod oldClass selector delFnFlg)
(RETURN (OR newLocalFn localFn])
(RenameMethod
[LAMBDA (classOrName oldSelector newSelector) (* ; "Edited 17-Nov-87 16:18 by jrb:")
(* ;;; "Rename selector in class, and rename method also if it is composite. If oldClassName is given, then class has been renamed, and not selector changed.")
(PROG (className class newLocalFn oldDef oldMethName newMethName file)
(COND
((NULL classOrName)
(printout T "NIL is not a class" T)
(RETURN))
((OR (NULL oldSelector)
(NULL newSelector))
(printout T "NIL is not a valid selector" T)
(RETURN)))
[COND
((type? class classOrName)
(SETQ class classOrName)
(SETQ className (ClassName class)))
(T (SETQ className (GoodClassName classOrName NIL T))
(SETQ class (GetClassRec className]
(SETQ oldMethName (FindLocalMethod class oldSelector))
(COND
((NULL oldMethName)
(printout T oldSelector " not found in " className T)
(RETURN)))
(SETQ oldDef (GETDEF oldMethName 'METHOD-FNS))
(COND
((NULL oldDef)
(ERROR oldMethName " defn cannot be found for RenameMethod")))
[SETQ file (CAR (WHEREIS oldMethName 'METHODS]
(_ (GetMethodObj class oldSelector T)
ChangeName oldMethName (MethName className newSelector)
newSelector)
(DeleteMethod class oldSelector T)
[SETQ newMethName (EVAL (CL:MULTIPLE-VALUE-BIND (oldClassName oldSelector arg-list decls
forms doc qualifiers method-type)
(PARSE-METHOD-BODY oldDef)
(PACK-METHOD-BODY className newSelector arg-list decls forms
doc qualifiers method-type]
(COND
(file (ADDTOFILE newMethName 'METHODS file)))
(RETURN newMethName])
(\ApplyMethod
(LAMBDA (selector argList class) (* dgb%: "16-Nov-84 16:36")
(* * Apply the selected method to the already evaluated args in argList.
argList includes the object as first item)
(APPLY (OR (FetchMethod (OR class (Class (CAR argList)))
selector)
(ERROR selector (CONCAT "not a selector in " (OR class (Class (CAR argList))))))
argList)))
(FindLocalMethod
(LAMBDA (class selector) (* smL "16-Dec-85 16:25")
(* Return function handling method in this class, or NIL if there is none)
(LET ((index (FindSelectorIndex class selector)))
(AND index (GetNthMethod class index)))))
(FindSelectorIndex
[LAMBDA (class selector) (* ; "Edited 14-Aug-90 16:53 by jds")
(PROG NIL
(* Prog is only so one can bomb out in case of NIL selectors of class)
(RETURN (\FindEntryIndex selector (OR (fetch (class selectors) of class)
(RETURN])
(FetchMethod
[LAMBDA (classRec selector) (* ; "Edited 14-Aug-90 16:53 by jds")
(* Returns the function for selector
or NIL)
(PROG ((pos (LLSH (LOGAND 1023 (LOGXOR (\LOLOC classRec)
(\LOLOC selector)))
3))
(class classRec)
meth index supers)
(DECLARE (LOCALVARS . T))
[COND
((AND (EQ class (\GETBASEPTR *Global-Method-Cache* pos))
(EQ selector (\GETBASEPTR (\ADDBASE *Global-Method-Cache* 2)
pos)))
(RETURN (\GETBASEPTR (\ADDBASE *Global-Method-Cache* 4)
pos]
(SETQ supers (fetch (class supers) of classRec))
LP (COND
((SETQ index (FindSelectorIndex class selector))
(SETQ meth (GetNthMethod class index))
(\PUTBASEPTR *Global-Method-Cache* pos classRec)
(\PUTBASEPTR (\ADDBASE *Global-Method-Cache* 2)
pos selector)
(\PUTBASEPTR (\ADDBASE *Global-Method-Cache* 4)
pos meth)
(RETURN meth))
((SETQ class (pop supers))
(GO LP))
(T (RETURN NIL])
(FetchMethodOrHelp
[LAMBDA (self selector) (* smL "17-Sep-85 17:51")
(* ;; "Searches for method corresponding to selector up the supers chain. If successful returns the name of the lisp function.")
(OR (FetchMethod (Class self)
selector)
(_ self MethodNotFound selector])
(GetCallerClass
(LAMBDA (object selector fromCaller) (* smL "10-Oct-85 15:24")
(* Get the class of the caller for use by _Super)
(PROG (class fn index supersList stkPos (callerName fromCaller))
SETCALLER
(OR (SETQ stkPos (REALSTKNTH -1 (OR stkPos callerName)
NIL stkPos))
(LoopsHelp selector "No caller found in " (OR fromCaller "_Super")))
(SETQ callerName (STKNAME stkPos))
CALLERSET
(SETQ class (Class object))
(SETQ supersList (Supers class))
LP (COND
((SETQ index (FindSelectorIndex class selector))(* There is a method in this class)
(COND
((EQ callerName (SETQ fn (GetNthMethod class index)))
(* Fn here is the same one I am in. Return class as callerName of
DoSuperMethods)
(RELSTK stkPos)
(RETURN class)))))
(COND
((SETQ class (pop supersList)) (* Try next superClass)
(GO LP))
(T (* Never found containing method --
Move Back one callerName)
(GO SETCALLER))))))
(GetNthMethod
[LAMBDA (class n) (* ; "Edited 14-Aug-90 16:53 by jds")
(LET ((meths (fetch (class methods) of class)))
(COND
((LISTP meths)
(GetNth meths n))
(T (\GetNthEntry meths n])
(GetSuperMethod
(LAMBDA (object selector callerName noError?) (* smL " 5-Jun-86 14:30")
(* * THIS IS OBSOLETE AND IS RETAINED BECAUSE COMPILED CODE CALLS IT.
IT HAS BEEN SUPERSEEDED BY FindSuperMethod)