Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

;;; CLC v1.5 compiling SS:<VICTOR.FLAVORS>VANILLA.CLISP.1

(in-package (quote user::flavors)) 
(defcombination-ordering daemon-ordering-primary (order) (order-wrappers :base-flavor-first (quote wrappers) (quote (:wrapper :whopper))) (order-methods :primary (quote primary) (quote (:primary))) (order-methods :primary (quote default) (quote (:default))) (case order (:base-flavor-last (order-methods :base-flavor-last (quote befores) (quote (:before))) (order-methods :base-flavor-first (quote afters) (quote (:after)))) (:base-flavor-first (order-methods :base-flavor-first (quote befores) (quote (:before))) (order-methods :base-flavor-last (quote afters) (quote (:after)))) (t (error "Unknown ordering ~S." order)))) 
(defcombination-ordering daemon-ordering-list (order) (order-wrappers :base-flavor-first (quote wrappers) (quote (:wrapper :whopper))) (case order (:base-flavor-last (order-methods :base-flavor-last (quote primary) (quote (:primary))) (order-methods :base-flavor-last (quote default) (quote (:default))) (order-methods :base-flavor-last (quote befores) (quote (:before))) (order-methods :base-flavor-first (quote afters) (quote (:after)))) (:base-flavor-first (order-methods :base-flavor-first (quote primary) (quote (:primary))) (order-methods :base-flavor-first (quote default) (quote (:default))) (order-methods :base-flavor-first (quote befores) (quote (:before))) (order-methods :base-flavor-last (quote afters) (quote (:after)))) (t (error "Unknown ordering ~S." order)))) 
(defcombination :daemon daemon-ordering-primary (arg) (let ((primary (or (method-list (quote primary)) (method-list (quote default))))) (wrapper-mix (quote wrappers) (cond ((and (null (method-list (quote befores))) (null (method-list (quote afters)))) (car (call-methods (quote primary)))) (t (cons (quote progn) (append (call-methods (quote befores)) (list (cons (quote multiple-value-prog1) (nconc (or (call-methods primary) (quote (nil))) (call-methods (quote afters)))))))))))) 
(defcombination :progn daemon-ordering-list (arg) (let ((primary (or (method-list (quote primary)) (method-list (quote default))))) (wrapper-mix (quote wrappers) (cond ((and (null (method-list (quote befores))) (null (method-list (quote afters)))) (car (call-methods primary))) (t (cons (quote progn) (append (call-methods (quote befores)) (list (list* (quote multiple-value-prog1) (cons (quote progn) (call-methods primary)) (call-methods (quote afters))))))))))) 
(defflavor vanilla-flavor nil nil) 
(defmethod (vanilla-flavor print) (stream depth) (send self :print-self stream depth)) 
(defmethod (vanilla-flavor describe) nil (send self :describe)) 
(defmethod (vanilla-flavor typep) (type) (let ((flavor (get type (quote flavor)))) (and flavor (not (null (member flavor (flavor-all-components (get-flavor (instance-descriptor-type (instance-descriptor self)))))))))) 
(defmethod (vanilla-flavor :print-self) (stream depth) (declare (ignore depth)) (format stream "#<~A ~A>" (instance-descriptor-type (instance-descriptor self)) (pointer-to-fixnum self))) 
(defmethod (vanilla-flavor :describe) nil (let* ((name (instance-descriptor-type (instance-descriptor self))) (vec (iv-env-vector (flavor-instance-env (get-flavor name))))) (format t "~%An instance of flavor ~S." name) (cond ((zerop (length vec)) (format t "~%No instance variables.")) (t (format t "~%Instance variables:"))) (dotimes (i (length vec)) (format t "~%~S ~S" (aref vec i) (symeval-in-instance self (aref vec i) t (quote unbound)))))) 
(defmethod (vanilla-flavor :which-operations) nil (let ((list nil)) (do-handlers ((name function) (flavor-descriptor (get-flavor (instance-descriptor-type (instance-descriptor self))))) (declare (ignore function)) (push name list)) list)) 
(defmethod (vanilla-flavor :operation-handled-p) (operation) (not (null (get-handler operation (instance-descriptor self))))) 
(defmethod (vanilla-flavor :send-if-handles) (operation &rest arguments) (when (get-handler operation (instance-descriptor self)) (apply (function send) self operation arguments)))