Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/flavors/upsala/frotz.clisp
There are no other files named frotz.clisp in the archive.
(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)))