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

(in-package 'flavors)

(defun Method-find (name type structure)
  (let ((list (get-method-types name structure)))
    (and list (cdr (assoc type (car list))))))

(defun calculate-all-components (flavor undefined)
  (with-stacks (components-stack second-stack)
    (let ((undefined-flavors nil) (undefined-includeds nil))
      (labels ((flavor-add-component (flavor)
		 (vector-push-extend flavor components-stack)
		 (dolist (c (flavor-components flavor))
		   (setq c (get-flavor c t))
		   (cond ((flavor-defined-p c)
			  (unless (find c components-stack)
			    (flavor-add-component c)))
			 (t (push (flavor-name c) undefined-flavors))))))
	(flavor-add-component flavor)
	(dotimes (i (length components-stack))
	  (labels
	    ((flavor-add-included (flavor)
	       (cond ((not (flavor-defined-p flavor))
		      (push (flavor-name flavor) undefined-includeds))
		     ((or (find flavor components-stack :start i)
			  (find flavor second-stack)))
		     (t (vector-push-extend flavor second-stack)
			(dolist (c (flavor-components flavor))
			  (flavor-add-included (get-flavor c t)))
			(dolist (incl (flavor-included-flavors flavor))
			  (flavor-add-included (get-flavor incl t)))))))
	    (let ((flav (aref components-stack i)))
	      (vector-push-extend flav second-stack)
	      (dolist (incl (flavor-included-flavors flav))
		(unless
		  (find incl components-stack :test
			#'(lambda (incl c)
			    (member incl (flavor-included-flavors c))))
		  (flavor-add-included incl))))))
	(unless (find-if #'(lambda (c) (not (flavor-has-vanilla-p c)))
			 second-stack)
	  (vector-push-extend (get-flavor 'vanilla-flavor) second-stack)))
      (cond ((car undefined-flavors)
	     (funcall undefined (flavor-name flavor) undefined-flavors))
	    (T (when (car undefined-includeds)
		 (format *error-output* "Undefined included flavors ignored - ~S."
			 undefined-includeds))
	       (coerce second-stack 'list))))))

(in-package "FLAVOR-INTERNALS" :use '("LISP" "SYSTEM") :nicknames '("FI"))
(defun define-set-method (method-fn-name var)
  "Defines a method that sets the given variable name."
  (let ((vec (make-array 1 :initial-element var)))
    (defun-default-handler random-setter (new)
      (setf (%instance-ref self (svref (entry-map %entry) 0)) new))
    (setf (symbol-function method-fn-name)
	  (symbol-function 'random-setter))
    (update-method method-fn-name vec nil)))