Return to vanilla.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/vanilla.l, revision 1.1

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.