![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vanilla.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to vanilla.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: ;; (c) copywrite 1982, Massachusetts Institute of Technology
2:
3: ;; This flavor system is derived from the original Lisp machine
4: ;; flavor system. As such its distribution may be restricted to
5: ;; Lisp machine software license holders.
6:
7: (environment-lmlisp (eval compile load) (files flavorm))
8:
9: (setq |SCCS-vanilla| "@(#) vanilla.l 1.1 83/01/27 @(#)")
10:
11: ;This is a flavor which is automatically made a component of nearly all
12: ;other flavors. It provides some basic facilities such as PRINT
13: ;and DESCRIBE.
14:
15: (DEFFLAVOR SI:VANILLA-FLAVOR () ()
16: :NO-VANILLA-FLAVOR ;No instance variables, no other flavors
17: (:DOCUMENTATION :MIXIN "The default base flavor.
18: This flavor provides the normal handlers for the :PRINT, :DESCRIBE, and :WHICH-OPERATIONS
19: operations. Only esoteric hacks should give the :NO-VANILLA-FLAVOR option to DEFFLAVOR to
20: prevent this inclusion."))
21:
22:
23: (DEFMETHOD (SI:VANILLA-FLAVOR :PRINT-SELF) (STREAM &REST IGNORE)
24: (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)))
25:
26: (DEFMETHOD (SI:VANILLA-FLAVOR :DESCRIBE) ()
27: (FORMAT T "~&~S, an object of flavor ~S,~% has instance variable values:~%"
28: SELF (:TYPEP SELF))
29: (DO ((IVARS (FLAVOR-ALL-INSTANCE-VARIABLES (INSTANCE-FLAVOR SELF))
30: (CDR IVARS))
31: (I 0 (1+ I)))
32: ((NULL IVARS))
33: ; SMH@EMS VVV
34: ; (FORMAT T "~S~%" (%INSTANCE-REF SELF I))
35: (FORMAT T " ~S:" (CAR IVARS))
36: (MSG (|B| (MAX 1 (DIFF 30 (NWRITN)))))
37: (FORMAT T "~S~%" (INT:FCLOSURE-STACK-STUFF (VREF SELF (+ 3 I))))
38: ; SMH@EMS ^^^
39: ))
40:
41: ;The default response to :WHICH-OPERATIONS is a list of all operations
42: ;handled. The list is consed up just once. It is computed by examination
43: ;of the method hash table, since that has no duplications.
44: ;This goes to some pains to produce a cdr-coded list, for fast MEMQ'ing.
45: (DEFMETHOD (SI:VANILLA-FLAVOR :WHICH-OPERATIONS) ()
46: (LET ((FL (INSTANCE-FLAVOR SELF)))
47: (OR (FLAVOR-WHICH-OPERATIONS FL)
48: (LET ((HT (FLAVOR-METHOD-HASH-TABLE FL))
49: W-O)
50: (DECLARE (SPECIAL W-O))
51: (MAPHASH #'(LAMBDA (OP IGNORE)
52: (DECLARE (SPECIAL W-O))
53: (PUSH OP W-O))
54: HT)
55: (SETF (FLAVOR-WHICH-OPERATIONS FL) W-O)
56: W-O))))
57:
58: #-Franz
59: (DEFMETHOD (SI:VANILLA-FLAVOR :OPERATION-HANDLED-P) (OP)
60: (LET ((FL (INSTANCE-FLAVOR SELF)))
61: (IF (ARRAYP (FLAVOR-METHOD-HASH-TABLE FL))
62: (MULTIPLE-VALUE-BIND (NIL DEFINEDP)
63: (WITHOUT-INTERRUPTS
64: (GETHASH OP (FLAVOR-METHOD-HASH-TABLE FL)))
65: DEFINEDP)
66: (LET ((WO (OR (FLAVOR-WHICH-OPERATIONS FL) (FUNCALL-SELF ':WHICH-OPERATIONS))))
67: (NOT (NOT (MEMQ OP WO)))))))
68:
69: #+Franz ; 8Jul84 SMH@EMS
70: (DEFMETHOD (SI:VANILLA-FLAVOR :OPERATION-HANDLED-P) (OP)
71: (LET ((WO (OR (FLAVOR-WHICH-OPERATIONS (INSTANCE-FLAVOR SELF))
72: (FUNCALL-SELF ':WHICH-OPERATIONS))))
73: (NOT (NOT (MEMQ OP WO)))))
74:
75: #-Franz
76: (DEFMETHOD (SI:VANILLA-FLAVOR :SEND-IF-HANDLES) (OP &REST TO-SEND)
77: (LET ((FL (INSTANCE-FLAVOR SELF)))
78: (IF (ARRAYP (FLAVOR-METHOD-HASH-TABLE FL))
79: (MULTIPLE-VALUE-BIND (FN-LOCATION DEFINEDP)
80: (GETHASH OP (FLAVOR-METHOD-HASH-TABLE FL))
81: (IF DEFINEDP (LEXPR-FUNCALL (CAR FN-LOCATION) OP TO-SEND)))
82: (LET ((WO (OR (FLAVOR-WHICH-OPERATIONS FL)
83: (FUNCALL-SELF ':WHICH-OPERATIONS))))
84: (AND (MEMQ OP WO)
85: (LEXPR-FUNCALL-SELF OP TO-SEND))))))
86:
87: #+Franz ; 8Jul84 SMH@EMS
88: (DEFMETHOD (SI:VANILLA-FLAVOR :SEND-IF-HANDLES) (OP &REST TO-SEND)
89: (LET ((WO (OR (FLAVOR-WHICH-OPERATIONS (INSTANCE-FLAVOR SELF))
90: (FUNCALL-SELF ':WHICH-OPERATIONS))))
91: (AND (MEMQ OP WO)
92: (LEXPR-FUNCALL-SELF OP TO-SEND))))
93:
94: (DEFMETHOD (SI:VANILLA-FLAVOR :GET-HANDLER-FOR) (OP)
95: (GET-HANDLER-FOR SELF OP))
96:
97: ;Useful methods for debugging.
98: ;They all cause the instance variables of SELF to be bound as specials.
99: (DEFMETHOD (SI:VANILLA-FLAVOR :EVAL-INSIDE-YOURSELF) (FORM)
100: (EVAL FORM))
101:
102: (DEFMETHOD (SI:VANILLA-FLAVOR :FUNCALL-INSIDE-YOURSELF) (FUNCTION &REST ARGS)
103: (APPLY FUNCTION ARGS))
104:
105: (DEFMETHOD (SI:VANILLA-FLAVOR :BREAK) ()
106: (*BREAK T SELF))
107:
108: ;;; This flavor is a useful mixin that provides messages for a property list protocol.
109:
110: (DEFFLAVOR SI:PROPERTY-LIST-MIXIN ((PROPERTY-LIST (LIST 'PROPERTY-LIST))) ()
111: :SETTABLE-INSTANCE-VARIABLES
112: (:DOCUMENTATION :MIXIN "A mixin that provides property list messages."))
113:
114: (DEFMETHOD (SI:PROPERTY-LIST-MIXIN :GET) (INDICATOR)
115: (GET PROPERTY-LIST INDICATOR))
116:
117: (DEFMETHOD (SI:PROPERTY-LIST-MIXIN :GETL) (INDICATOR-LIST)
118: (GETL PROPERTY-LIST INDICATOR-LIST))
119:
120: (DEFMETHOD (SI:PROPERTY-LIST-MIXIN :PUTPROP) (PROPERTY INDICATOR)
121: (PUTPROP PROPERTY-LIST PROPERTY INDICATOR))
122:
123: (DEFMETHOD (SI:PROPERTY-LIST-MIXIN :REMPROP) (INDICATOR)
124: (REMPROP PROPERTY-LIST INDICATOR))
125:
126: (DEFMETHOD (SI:PROPERTY-LIST-MIXIN :PUSH-PROPERTY) (PROPERTY INDICATOR)
127: (PUSH PROPERTY (GET PROPERTY-LIST INDICATOR)))
128:
129: (DEFMETHOD (SI:PROPERTY-LIST-MIXIN :PLIST) () PROPERTY-LIST)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.