- (defun output-translations-initialized-p ()
- (and *output-translations* t))
-
- (defun clear-output-translations ()
- "Undoes any initialization of the output translations."
- (setf *output-translations* '())
- (values))
- (register-clear-configuration-hook 'clear-output-translations)
-
- (defun validate-output-translations-directive (directive)
- (or (member directive '(:enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive)))))))
-
- (defun validate-output-translations-form (form &key location)
- (validate-configuration-form
- form
- :output-translations
- 'validate-output-translations-directive
- :location location :invalid-form-reporter 'invalid-output-translation))
-
- (defun validate-output-translations-file (file)
- (validate-configuration-file
- file 'validate-output-translations-form :description "output translations"))
-
- (defun validate-output-translations-directory (directory)
- (validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive
- :invalid-form-reporter 'invalid-output-translation))
-
- (defun parse-output-translations-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:output-translations :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string) :location location))
- ((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with source = nil
- :with separator = (inter-directory-separator)
- :for i = (or (position separator string :start start) end) :do
- (let ((s (subseq string start i)))
- (cond
- (source
- (push (list source (if (equal "" s) nil s)) directives)
- (setf source nil))
- ((equal "" s)
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push :inherit-configuration directives))
- (t
- (setf source s)))
- (setf start (1+ i))
- (when (> start end)
- (when source
- (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
- string))
- (unless inherit
- (push :ignore-inherited-configuration directives))
- (return `(:output-translations ,@(nreverse directives)))))))))
-
- (defparameter *default-output-translations*
- '(environment-output-translations
- user-output-translations-pathname
- user-output-translations-directory-pathname
- system-output-translations-pathname
- system-output-translations-directory-pathname))
-
- (defun wrapping-output-translations ()
- `(:output-translations
- ;; Some implementations have precompiled ASDF systems,
- ;; so we must disable translations for implementation paths.
- #+(or #|clozure|# ecl mkcl sbcl)
- ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
- (when h `(((,h ,*wild-path*) ()))))
- #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
- ;; All-import, here is where we want user stuff to be:
- :inherit-configuration
- ;; These are for convenience, and can be overridden by the user:
- #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; We enable the user cache by default, and here is the place we do:
- :enable-user-cache))
-
- (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
- (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
-
- (defun user-output-translations-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-file* :direction direction))
- (defun system-output-translations-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-file* :direction direction))
- (defun user-output-translations-directory-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-directory* :direction direction))
- (defun system-output-translations-directory-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-directory* :direction direction))
- (defun environment-output-translations ()
- (getenv "ASDF_OUTPUT_TRANSLATIONS"))
-
- (defgeneric process-output-translations (spec &key inherit collect))
-
- (defun inherit-output-translations (inherit &key collect)
- (when inherit
- (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
-
- (defun* (process-output-translations-directive) (directive &key inherit collect)
- (if (atom directive)
- (ecase directive
- ((:enable-user-cache)
- (process-output-translations-directive '(t :user-cache) :collect collect))
- ((:disable-cache)
- (process-output-translations-directive '(t t) :collect collect))
- ((:inherit-configuration)
- (inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration :ignore-invalid-entries nil)
- nil))
- (let ((src (first directive))
- (dst (second directive)))
- (if (eq src :include)
- (when dst
- (process-output-translations (pathname dst) :inherit nil :collect collect))
- (when src
- (let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :ensure-directory t :wilden t)))
- (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
- (cond
- ((location-function-p dst)
- (funcall collect
- (list trusrc
- (if (symbolp (second dst))
- (fdefinition (second dst))
- (eval (second dst))))))
- ((eq dst t)
- (funcall collect (list trusrc t)))
- (t
- (let* ((trudst (if dst
- (resolve-location dst :ensure-directory t :wilden t)
- trusrc)))
- (funcall collect (list trudst t))
- (funcall collect (list trusrc trudst)))))))))))
-
- (defmethod process-output-translations ((x symbol) &key
- (inherit *default-output-translations*)
- collect)
- (process-output-translations (funcall x) :inherit inherit :collect collect))
- (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
- (cond
- ((directory-pathname-p pathname)
- (process-output-translations (validate-output-translations-directory pathname)
- :inherit inherit :collect collect))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (process-output-translations (validate-output-translations-file pathname)
- :inherit inherit :collect collect))
- (t
- (inherit-output-translations inherit :collect collect))))
- (defmethod process-output-translations ((string string) &key inherit collect)
- (process-output-translations (parse-output-translations-string string)
- :inherit inherit :collect collect))
- (defmethod process-output-translations ((x null) &key inherit collect)
- (declare (ignorable x))
- (inherit-output-translations inherit :collect collect))
- (defmethod process-output-translations ((form cons) &key inherit collect)
- (dolist (directive (cdr (validate-output-translations-form form)))
- (process-output-translations-directive directive :inherit inherit :collect collect)))
-
- (defun compute-output-translations (&optional parameter)
- "read the configuration, return it"
- (remove-duplicates
- (while-collecting (c)
- (inherit-output-translations
- `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
- :test 'equal :from-end t))
-
- (defvar *output-translations-parameter* nil)
-
- (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
- "read the configuration, initialize the internal configuration variable,
-return the configuration"
- (setf *output-translations-parameter* parameter
- (output-translations) (compute-output-translations parameter)))
-
- (defun disable-output-translations ()
- "Initialize output translations in a way that maps every file to itself,
-effectively disabling the output translation facility."
- (initialize-output-translations
- '(:output-translations :disable-cache :ignore-inherited-configuration)))
-
- ;; checks an initial variable to see whether the state is initialized
- ;; or cleared. In the former case, return current configuration; in
- ;; the latter, initialize. ASDF will call this function at the start
- ;; of (asdf:find-system).
- (defun ensure-output-translations ()
- (if (output-translations-initialized-p)
- (output-translations)
- (initialize-output-translations)))
-
- (defun* (apply-output-translations) (path)
- #+cormanlisp (resolve-symlinks* path) #-cormanlisp
- (etypecase path
- (logical-pathname
- path)
- ((or pathname string)
- (ensure-output-translations)
- (loop* :with p = (resolve-symlinks* path)
- :for (source destination) :in (car *output-translations*)
- :for root = (when (or (eq source t)
- (and (pathnamep source)
- (not (absolute-pathname-p source))))
- (pathname-root p))
- :for absolute-source = (cond
- ((eq source t) (wilden root))
- (root (merge-pathnames* source root))
- (t source))
- :when (or (eq source t) (pathname-match-p p absolute-source))
- :return (translate-pathname* p absolute-source destination root source)
- :finally (return p)))))
-
- ;; Hook into asdf/driver's output-translation mechanism
- (setf *output-translation-function* 'apply-output-translations)
-
- #+abcl
- (defun translate-jar-pathname (source wildcard)
- (declare (ignore wildcard))
- (flet ((normalize-device (pathname)
- (if (find :windows *features*)
- pathname
- (make-pathname :defaults pathname :device :unspecific))))
- (let* ((jar
- (pathname (first (pathname-device source))))
- (target-root-directory-namestring
- (format nil "/___jar___file___root___/~@[~A/~]"
- (and (find :windows *features*)
- (pathname-device jar))))
- (relative-source
- (relativize-pathname-directory source))
- (relative-jar
- (relativize-pathname-directory (ensure-directory-pathname jar)))
- (target-root-directory
- (normalize-device
- (pathname-directory-pathname
- (parse-namestring target-root-directory-namestring))))
- (target-root
- (merge-pathnames* relative-jar target-root-directory))
- (target
- (merge-pathnames* relative-source target-root)))
- (normalize-device (apply-output-translations target))))))
-
-;;;; -----------------------------------------------------------------
-;;;; Source Registry Configuration, by Francois-Rene Rideau
-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
-
-(asdf/package:define-package :asdf/source-registry
- (:recycle :asdf/source-registry :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
- (:export
- #:*source-registry* #:*source-registry-parameter* #:*default-source-registries*
- #:invalid-source-registry
- #:source-registry #:source-registry-initialized-p
- #:initialize-source-registry #:clear-source-registry #:*source-registry*
- #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter*
- #:*default-source-registry-exclusions* #:*source-registry-exclusions*
- #:*wild-asd* #:directory-asd-files #:register-asd-directory
- #:collect-asds-in-directory #:collect-sub*directories-asd-files
- #:validate-source-registry-directive #:validate-source-registry-form
- #:validate-source-registry-file #:validate-source-registry-directory
- #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
- #:user-source-registry #:system-source-registry
- #:user-source-registry-directory #:system-source-registry-directory
- #:environment-source-registry #:process-source-registry
- #:compute-source-registry #:flatten-source-registry
- #:sysdef-source-registry-search))
-(in-package :asdf/source-registry)
-
-(with-upgradability ()
- (define-condition invalid-source-registry (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- ;; Using ack 1.2 exclusions
- (defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv"
- ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
- ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
- "_sgbak" "autom4te.cache" "cover_db" "_build"
- "debian")) ;; debian often builds stuff under the debian directory... BAD.
-
- (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
-
- (defvar *source-registry* nil
- "Either NIL (for uninitialized), or an equal hash-table, mapping
-system names to pathnames of .asd files")
-
- (defun source-registry-initialized-p ()
- (typep *source-registry* 'hash-table))
-
- (defun clear-source-registry ()
- "Undoes any initialization of the source registry."
- (setf *source-registry* nil)
- (values))
- (register-clear-configuration-hook 'clear-source-registry)
-
- (defparameter *wild-asd*
- (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
-
- (defun directory-asd-files (directory)
- (directory-files directory *wild-asd*))
-
- (defun collect-asds-in-directory (directory collect)
- (map () collect (directory-asd-files directory)))
-
- (defun collect-sub*directories-asd-files
- (directory &key (exclude *default-source-registry-exclusions*) collect)
- (collect-sub*directories
- directory
- (constantly t)
- #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
- #'(lambda (dir) (collect-asds-in-directory dir collect))))
-
- (defun validate-source-registry-directive (directive)
- (or (member directive '(:default-registry))
- (and (consp directive)
- (let ((rest (rest directive)))
- (case (first directive)
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- ((:default-registry)
- (null rest)))))))
-
- (defun validate-source-registry-form (form &key location)
- (validate-configuration-form
- form :source-registry 'validate-source-registry-directive
- :location location :invalid-form-reporter 'invalid-source-registry))
-
- (defun validate-source-registry-file (file)
- (validate-configuration-file
- file 'validate-source-registry-form :description "a source registry"))
-
- (defun validate-source-registry-directory (directory)
- (validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive
- :invalid-form-reporter 'invalid-source-registry))
-
- (defun parse-source-registry-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:source-registry :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with separator = (inter-directory-separator)
- :for pos = (position separator string :start start) :do
- (let ((s (subseq string start (or pos end))))
- (flet ((check (dir)
- (unless (absolute-pathname-p dir)
- (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
- dir))
- (cond
- ((equal "" s) ; empty element: inherit
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push ':inherit-configuration directives))
- ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
- (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
- (t
- (push `(:directory ,(check s)) directives))))
- (cond
- (pos
- (setf start (1+ pos)))
- (t
- (unless inherit
- (push '(:ignore-inherited-configuration) directives))
- (return `(:source-registry ,@(nreverse directives))))))))))
-
- (defun register-asd-directory (directory &key recurse exclude collect)
- (if (not recurse)
- (collect-asds-in-directory directory collect)
- (collect-sub*directories-asd-files
- directory :exclude exclude :collect collect)))
-
- (defparameter *default-source-registries*
- '(environment-source-registry
- user-source-registry
- user-source-registry-directory
- system-source-registry
- system-source-registry-directory
- default-source-registry))
-
- (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
- (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
-
- (defun wrapping-source-registry ()
- `(:source-registry
- #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
- #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
- :inherit-configuration
- #+cmu (:tree #p"modules:")
- #+scl (:tree #p"file://modules/")))
- (defun default-source-registry ()
- `(:source-registry
- #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
- (subpathname (user-homedir-pathname) ".local/share/"))
- ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share"))))
- ,@(when (os-windows-p)
- (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
- :inherit-configuration))
- (defun user-source-registry (&key (direction :input))
- (in-user-configuration-directory *source-registry-file* :direction direction))
- (defun system-source-registry (&key (direction :input))
- (in-system-configuration-directory *source-registry-file* :direction direction))
- (defun user-source-registry-directory (&key (direction :input))
- (in-user-configuration-directory *source-registry-directory* :direction direction))
- (defun system-source-registry-directory (&key (direction :input))
- (in-system-configuration-directory *source-registry-directory* :direction direction))
- (defun environment-source-registry ()
- (getenv "CL_SOURCE_REGISTRY"))
-
- (defgeneric* (process-source-registry) (spec &key inherit register))
-
- (defun* (inherit-source-registry) (inherit &key register)
- (when inherit
- (process-source-registry (first inherit) :register register :inherit (rest inherit))))
-
- (defun* (process-source-registry-directive) (directive &key inherit register)
- (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
- (ecase kw
- ((:include)
- (destructuring-bind (pathname) rest
- (process-source-registry (resolve-location pathname) :inherit nil :register register)))
- ((:directory)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)))))
- ((:tree)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)
- :recurse t :exclude *source-registry-exclusions*))))
- ((:exclude)
- (setf *source-registry-exclusions* rest))
- ((:also-exclude)
- (appendf *source-registry-exclusions* rest))
- ((:default-registry)
- (inherit-source-registry '(default-source-registry) :register register))
- ((:inherit-configuration)
- (inherit-source-registry inherit :register register))
- ((:ignore-inherited-configuration)
- nil)))
- nil)
-
- (defmethod process-source-registry ((x symbol) &key inherit register)
- (process-source-registry (funcall x) :inherit inherit :register register))
- (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
- (cond
- ((directory-pathname-p pathname)
- (let ((*here-directory* (resolve-symlinks* pathname)))
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register)))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (let ((*here-directory* (pathname-directory-pathname pathname)))
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register)))
- (t
- (inherit-source-registry inherit :register register))))
- (defmethod process-source-registry ((string string) &key inherit register)
- (process-source-registry (parse-source-registry-string string)
- :inherit inherit :register register))
- (defmethod process-source-registry ((x null) &key inherit register)
- (declare (ignorable x))
- (inherit-source-registry inherit :register register))
- (defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
- (dolist (directive (cdr (validate-source-registry-form form)))
- (process-source-registry-directive directive :inherit inherit :register register))))
-
- (defun flatten-source-registry (&optional parameter)
- (remove-duplicates
- (while-collecting (collect)
- (with-pathname-defaults () ;; be location-independent
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register #'(lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude))))))
- :test 'equal :from-end t))
-
- ;; Will read the configuration and initialize all internal variables.
- (defun compute-source-registry (&optional parameter (registry *source-registry*))
- (dolist (entry (flatten-source-registry parameter))
- (destructuring-bind (directory &key recurse exclude) entry
- (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
- (register-asd-directory
- directory :recurse recurse :exclude exclude :collect
- #'(lambda (asd)
- (let* ((name (pathname-name asd))
- (name (if (typep asd 'logical-pathname)
- ;; logical pathnames are upper-case,
- ;; at least in the CLHS and on SBCL,
- ;; yet (coerce-name :foo) is lower-case.
- ;; won't work well with (load-system "Foo")
- ;; instead of (load-system 'foo)
- (string-downcase name)
- name)))
- (cond
- ((gethash name registry) ; already shadowed by something else
- nil)
- ((gethash name h) ; conflict at current level
- (when *verbose-out*
- (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
- found several entries for ~A - picking ~S over ~S~:>")
- directory recurse name (gethash name h) asd)))
- (t
- (setf (gethash name registry) asd)
- (setf (gethash name h) asd))))))
- h)))
- (values))
-
- (defvar *source-registry-parameter* nil)
-
- (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
- ;; Record the parameter used to configure the registry
- (setf *source-registry-parameter* parameter)
- ;; Clear the previous registry database:
- (setf *source-registry* (make-hash-table :test 'equal))
- ;; Do it!
- (compute-source-registry parameter))
-
- ;; Checks an initial variable to see whether the state is initialized
- ;; or cleared. In the former case, return current configuration; in
- ;; the latter, initialize. ASDF will call this function at the start
- ;; of (asdf:find-system) to make sure the source registry is initialized.
- ;; However, it will do so *without* a parameter, at which point it
- ;; will be too late to provide a parameter to this function, though
- ;; you may override the configuration explicitly by calling
- ;; initialize-source-registry directly with your parameter.
- (defun ensure-source-registry (&optional parameter)
- (unless (source-registry-initialized-p)
- (initialize-source-registry parameter))
- (values))
-
- (defun sysdef-source-registry-search (system)
- (ensure-source-registry)
- (values (gethash (primary-system-name system) *source-registry*))))
-
-
-;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility
-
-(asdf/package:define-package :asdf/backward-internals
- (:recycle :asdf/backward-internals :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/system :asdf/component :asdf/operation
- :asdf/find-system :asdf/action :asdf/lisp-action)
- (:export ;; for internal use
- #:load-sysdef #:make-temporary-package
- #:%refresh-component-inline-methods
- #:%resolve-if-component-dep-fails
- #:make-sub-operation
- #:load-sysdef #:make-temporary-package))
-(in-package :asdf/backward-internals)
-
-;;;; Backward compatibility with "inline methods"
-(with-upgradability ()
- (defparameter +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
-
- (defun %remove-component-inline-methods (component)
- (dolist (name +asdf-methods+)
- (map ()
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf
- ;; But this is hardly performance-critical
- #'(lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods component)))
- (component-inline-methods component) nil)
-
- (defun %define-component-inline-methods (ret rest)
- (dolist (name +asdf-methods+)
- (let ((keyword (intern (symbol-name name) :keyword)))
- (loop :for data = rest :then (cddr data)
- :for key = (first data)
- :for value = (second data)
- :while data
- :when (eq key keyword) :do
- (destructuring-bind (op qual? &rest rest) value
- (multiple-value-bind (qual args-and-body)
- (if (symbolp qual?)
- (values (list qual?) rest)
- (values nil (cons qual? rest)))
- (destructuring-bind ((o c) &body body) args-and-body
- (pushnew
- (eval `(defmethod ,name ,@qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (component-inline-methods ret)))))))))
-
- (defun %refresh-component-inline-methods (component rest)
- ;; clear methods, then add the new ones
- (%remove-component-inline-methods component)
- (%define-component-inline-methods component rest)))