Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 6784d57ea1
Fetching contributors…

Cannot retrieve contributors at this time

152 lines (139 sloc) 17.836 kb
;ELC
;;; Compiled by toups@deluge on Tue Oct 18 08:56:56 2011
;;; from file /home/toups/elisp/utils/multi-methods.el
;;; in Emacs version 23.2.1
;;; with all optimizations.
;;; This file uses dynamic docstrings, first added in Emacs 19.29.
;;; This file does not contain utf-8 non-ASCII characters,
;;; and so can be loaded in Emacs versions earlier than 23.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(byte-code "\300\301!\210\300\302!\210\300\303!\210\300\304!\210\305\306!\207" [require defn utils functional cl provide multi-methods] 2)
#@46 Weak table for keeping track of hierarchies.
(defvar *hierarchy-weak-table* (make-hash-table :test 'eql :weakness t) (#$ . 648))
#@59 The default multimethod hierarchy used for isa? dispatch.
(defvar *multi-method-heirarchy* (alist>> :down nil :up nil :resolutions nil) (#$ . 783))
#@47 Create a hierarchy for multi-method dispatch.
(defalias 'make-hierarchy #[nil "\302\303!\304\305 #\210\306\307\")\207" [tag *hierarchy-weak-table* gensym "hierarchy-tag" puthash t alist>> ::::hierarchy-tag] 4 (#$ . 937)])
#@43 Tests to see if an object is a hierarchy.
(defalias 'hierarchyp #[(object) "<\205\303\304\"\211\205\305 \n\")\207" [object tag *hierarchy-weak-table* alist ::::hierarchy-tag gethash] 4 (#$ . 1168)])
#@54 generates the symbol for a dispatch table for METHOD
(defalias 'mk-dispatch-table-name #[(method) "\301\302\"\207" [method internf "--%s-dispatch-table"] 3 (#$ . 1380)])
#@52 generates the symbol for hierarchy name for METHOD
(defalias 'mk-dispatch-hierarchy-name #[(method) "\301\302\"\207" [method internf "--%s-hierarchy-table"] 3 (#$ . 1557)])
#@59 generates the symbol for the dispatch function for METHOD
(defalias 'mk-dispatch-function-name #[(method) "\301\302\"\207" [method internf "--%s-dispatcher"] 3 (#$ . 1737)])
#@56 generates the symbol for the default method for METHOD
(defalias 'mk-default-method-name #[(method) "\301\302\"\207" [method internf "--%s-default-method"] 3 (#$ . 1918)])
#@47 Creates an accessor for tables looking for KW
(defalias 'make-keyword-accessor #[(kw) "\302\303!\211 L\210\304\305\306\307\310D\311FE)\207" [#1=#:--cl-kw-- kw make-symbol "--kw--" lambda (&rest --cl-rest--) apply #[(#2=#:G102810 table &rest args) "\302 J\"\207" [table #2# table-like-get] 3] quote --cl-rest--] 7 (#$ . 2097)])
#@66 Clear the dispatch cache for the hierarchy in the dynamic scope.
(defalias 'clear-dispatch-cache-raw #[nil "\301\302\303#\210\304\207" [*multi-method-heirarchy* alist! ::::dispatch-cache nil t] 4 (#$ . 2433)])
#@92 Retrieve the cache of dispatches for the currently scoped hierarchy, or for one passed in.
(defalias 'clear-dispatch-cache #[(&rest args) "\302G\303\"\203 \304 \207\302G\305\"\203@\304 )\207\306\307!\207" [args *multi-method-heirarchy* memql (0) clear-dispatch-cache-raw (1) error "clear-dispatch-cache: Takes either 0 or 1 arguments."] 3 (#$ . 2650)])
(defalias 'over-all-args #[(kw/f) "\302\303!\211 L\210\304J!\203\305\306\307\310\311D\312FE\202&\305\306\307\313\311D\312FE)\207" [#1=#:--cl-kw/f-- kw/f make-symbol "--kw/f--" functionp lambda #2=(&rest --cl-rest--) apply #[(#3=#:G102811 &rest args) "\306J \307\310\311\f \n$ \205\312 \"-\207" [#3# args cl-rest cl-seq cl-func cl-type vector nil apply mapcar* coerce cl-res] 5] quote --cl-rest-- #[(#4=#:G102813 &rest args) "\306\307\310\311\312\313D\314FE \315\311\316\f \n$ \205\"\317 \"-\207" [#4# args cl-rest cl-seq cl-func cl-type vector lambda #2# apply #[(#5=#:G102812 tble) "\302 J\"\207" [tble #5# table-like-get] 3] quote --cl-rest-- nil mapcar* coerce cl-res] 7]] 7])
(defalias 'macro-functionp #[(object) "\301!\203\302\207<\203G\303U\203@\304=\206\305\207" [object functionp t 2 function nil] 2])
#@210 Define a multi-method NAME with dispatch function DISPATCH. DEFUNMULTI defines specific instances of the method.
(fn NAME DISPATCH &optional (DOC "") (HIERARCHY-EXPRESSION (quote *multi-method-heirarchy*)))
(defalias 'defmulti '(macro . #[(name dispatch &rest #1=#:--cl-rest--) "\203\f\211A@\202 \306\203\211A@\202\307\203*\310\311\312\313G\\D\"\210\314 !\315 !\316 !\317\320 \"\317\321 \"\322 !\323 12345\324\3254\326BB\325 \327\330\331 \"F\332 \nE\3255\333\330\334 \"F\3325\335BB\336\f6DC\3253\f\330\337 \"F\3323\fE\340\3413D\342\330\3433\211FD\3323\3443DEF\257\345 \3462D \347\307 D1\350\35132E5\352\353\354\355 DE\355 DE4\257DD\3561\35112E\357\330\211\360 \"2\35132EFDFE\257\257. \207" [#1# doc hierarchy-expression name temp hierarchy-name "" *multi-method-heirarchy* signal wrong-number-of-arguments defmulti 4 mk-dispatch-table-name mk-default-method-name mk-dispatch-function-name gensymf "multi-%s-args" "multi-%s-holder" mk-dispatch-hierarchy-name gensym progn defvar (nil) nil format "dispatch hierarchy for %s" setq (alist>>) "dispatch-table for %s" ((alist>>)) let "dispatch-function for %s" unless functionp print "Creating a dispatch function for %S. You may need to define %S before declaring the multimethod if you don't mean to use table-based dispatch." make-keyword-accessor defun &rest let* isa-dispatch-memo apply make-resolve-by-table alist *preferred-dispatch-table* quote if error "No known method for args %%S for multimethod %s.\n Dispatch value is: %%S" internal-name args-name dispatch-name default-method-name table-name dispatch] 23 (#$ . 3869)]))
#@140 Define a method of last resort for the method NAME, called when no match is available in the dispatch table.
(fn NAME ARGLIST &body BODY)
(defalias 'defunmethod-default '(macro . #[(name arglist &rest body) "\303\304\305\306!DC\307BB\310\311!\312 \nBBE\313DF\207" [name arglist body progn let *multi-method-heirarchy* mk-dispatch-hierarchy-name ((clear-dispatch-cache)) setq mk-default-method-name lambda quote] 7 (#$ . 5509)]))
#@72 Undefine the method for the multimethod NAME and dispatch value VALUE.
(defalias 'undefunmethod '(macro . #[(name value) "\303!\304\305\306!DC\307\310 \311 \nEEF)\207" [name table-name value mk-dispatch-table-name let *multi-method-heirarchy* mk-dispatch-hierarchy-name (clear-dispatch-cache) setq dissoc-equal] 8 (#$ . 5948)]))
#@102 Define a method using DEFUN syntax for the dispatch value VALUE.
(fn NAME VALUE ARGLIST &body BODY)
(defalias 'defunmethod '(macro . #[(name value arglist &rest body) "\306 \307!\310\n\311 \fBBDC\310\312\313!DC\314BB\315 \316 \nFE\317D\257*\207" [name table-name g arglist body value gensym mk-dispatch-table-name let lambda *multi-method-heirarchy* mk-dispatch-hierarchy-name ((clear-dispatch-cache)) setq alist-equal>> quote] 9 (#$ . 6287)]))
#@66 Define a method using DEFUN syntax for the dispatch value VALUE.
(defalias 'defunmethod/alias '(macro . #[(name value lambda-yielding-expression) "\305 \306!\307\n DC\307\310\311!DC\312BB\313 \314 \f\nFE\315D\257*\207" [name table-name g lambda-yielding-expression value gensym mk-dispatch-table-name let *multi-method-heirarchy* mk-dispatch-hierarchy-name ((clear-dispatch-cache)) setq alist-equal>> quote] 9 (#$ . 6746)]))
#@44 Table of method dispatch resolution rules.
(defvar *preferred-dispatch-table* nil (#$ . 7183))
#@113 Indicate that the NAMEd multimethod should prefer PREF-VAL over NOT-PREF-VAL when dispatching ambiguous inputs.
(defalias 'prefer-method-fun #[(name pref-val not-pref-val) "\305 \"\306\n\307 \f\" #\210\306\n\307\f \" #\210\306 \n#)\207" [*preferred-dispatch-table* name subtbl pref-val not-pref-val alist alist! vector] 5 (#$ . 7285)])
#@117 Declare that a particular dispatch value PREF-VAL is preferred over NOT-PREF-VAL when dispatching the NAMEd method.
(defalias 'prefer-method '(macro . #[(name pref-val not-pref-val) "\303\304D \nF\207" [name pref-val not-pref-val prefer-method-fun quote] 4 (#$ . 7631)]))
#@44 Clear the hierarchy in the dynamic scope. 
(defalias 'clear-mm-heirarchy #[nil "\301\302\303\304\303\305\303&\211\207" [*multi-method-heirarchy* alist>> :down nil :up :resolutions] 8 (#$ . 7910)])
#@72 Add a PARENT CHILD relationship to the hierarchy in the dynamic scope.
(defalias 'add-parent-relation #[(child parent) "\304\305\"\306\305\307 \n ##\210)\207" [*multi-method-heirarchy* parents child parent alist :up alist! alist-add-to-set] 7 (#$ . 8115)])
#@72 Add a PARENT CHILD relationship to the hierarchy in the dynamic scope.
(defalias 'remove-parent-relation #[(child parent) "\304\305\"\306\305\307 \n ##\210)\207" [*multi-method-heirarchy* parents child parent alist :up alist! alist-remove-from-set] 7 (#$ . 8382)])
#@72 Add a CHILD PARENT relationship to the hierarchy in the dynamic scope.
(defalias 'add-child-relation #[(parent child) "\304\305\"\306\305\307 \n ##\210)\207" [*multi-method-heirarchy* children parent child alist :down alist! alist-add-to-set] 7 (#$ . 8657)])
#@76 Removes a CHILD PARENT relationship to the hierarchy in the dynamic scope.
(defalias 'remove-child-relation #[(parent child) "\304\305\"\306\305\307 \n ##\210)\207" [*multi-method-heirarchy* children parent child alist :down alist! alist-remove-from-set] 7 (#$ . 8926)])
#@74 Declare a PARENT-CHILD relationship in the dynamically scoped hierarchy.
(defalias 'derive2 #[(parent child) "\302 \210\303 \"\210\304 \"\207" [parent child clear-dispatch-cache add-child-relation add-parent-relation] 3 (#$ . 9207)])
(defalias 'underive2 #[(parent child) "\302 \210\303 \"\210\304 \"\207" [parent child clear-dispatch-cache remove-child-relation remove-parent-relation] 3])
#@133 derive H PARENT CHILD establishes a parent-child relationship in H, a heirarchy.
derive PARENT CHILD uses the default hierarchy.
(defalias 'derive #[(&rest args) "\302G\303\"\203 \304\305\"\207\302G\306\"\203@\304\305A\")\207\307\207" [args *multi-method-heirarchy* memql (2) apply derive2 (3) "Derive takes 2 or 3 arguments. More or less were given."] 3 (#$ . 9609)])
#@133 derive H PARENT CHILD establishes a parent-child relationship in H, a heirarchy.
derive PARENT CHILD uses the default hierarchy.
(defalias 'underive #[(&rest args) "\302G\303\"\203 \304\305\"\207\302G\306\"\203@\304\305A\")\207\307\207" [args *multi-method-heirarchy* memql (2) apply derive2 (3) "Derive takes 2 or 3 arguments. More or less were given."] 3 (#$ . 9998)])
#@74 Not documented
(fn CHILD PARENT &optional (H *multi-method-heirarchy*))
(defalias 'derives-from #[(child parent &rest #1=#:--cl-rest--) "\203\f\211A@\202 \203\305\306\307\310G\\D\"\210\n\311 \f\"*\207" [#1# *multi-method-heirarchy* h parent child signal wrong-number-of-arguments derives-from 3 derive2] 5 (#$ . 10388)])
#@77 Not documented
(fn CHILDREN PARENT &optional (H *multi-method-heirarchy*))
(defalias 'derive-from #[(children parent &rest #1=#:--cl-rest--) "\203\f\211A@\202 \203\306\307\310\311G\\D\"\210\n\312 \313\"\314\315 T\211\fGW\203B\f H\316\n#\210\202(-\315\207" [#1# *multi-method-heirarchy* h children #2=#:--cl-vec-- #3=#:--cl-idx-- signal wrong-number-of-arguments derive-from 3 coerce vector -1 nil derives-from child parent] 5 (#$ . 10728)])
#@66 Get the PARENTS of CHILD from the hierachy in the dynamic scope.
(defalias 'mm-parents #[(child) "\303\304\"\303 \n\")\207" [*multi-method-heirarchy* parents child alist :up] 3 (#$ . 11201)])
#@68 Get the CHILDREN of PARENT from the hierachy in the dynamic scope.
(defalias 'mm-children #[(parent) "\303\304\"\303 \n\")\207" [*multi-method-heirarchy* children parent alist :down] 3 (#$ . 11401)])
#@33 Get all the ancestors of CHILD.
(defalias 'mm-ancestors #[(child) "\305!\211 ?\205\f\306 \2040\307\310\311\305 #\312\"\211\203*\f\313\314\n\fB\"\202,\306)\202 \n+\207" [child parents ancestors done above mm-parents t unique map&filter identity equal apply append] 7 (#$ . 11609)])
#@35 Get all the descendants of CHILD.
(defalias 'mm-descendants #[(child) "\305!\211 ?\205\f\306 \2040\307\310\311\305 #\312\"\211\203*\f\313\314\n\fB\"\202,\306)\202 \n+\207" [child children descendants done below mm-children t unique map&filter identity equal apply append] 7 (#$ . 11909)])
#@84 Get the multimethod of kind NAME that is the nearest match for the DISPATCH-VALUE.
(defalias 'get-method #[(name dispatch-value) "\304!\305 !\306 \n\307\n\"#*\207" [name method-table-name method-table dispatch-value mk-dispatch-table-name eval isa-dispatch make-resolve-by-table] 6 (#$ . 12217)])
#@77 Get the method associated with NAME and DISPATCH-VALUE and call it on ARGS.
(defalias 'get-method-funcall #[(name dispatch-value &rest args) "\304 \"\211\203\305\n \"\202\306\307 #)\207" [name dispatch-value m args get-method apply error "get-method-funcall: No method for %s with dispatch value %S."] 5 (#$ . 12524)])
#@85 Get the method associated with NAME and DISPATCH-VALUE and call it on ARGS, a list.
(defalias 'get-method-apply #[(name dispatch-value args) "\304 \"\211\203\305\n \"\202\306\307 #)\207" [name dispatch-value m args get-method apply error "get-method-funcall: No method for %s with dispatch value %S."] 5 (#$ . 12856)])
(byte-code "\300\301\302\"\210\300\301\303\"\210\300\301\304\"\210\300\304\305\"\210\300\304\306\"\210\300\302\307\"\210\300\302\310\"\207" [derive :thing :parseable :number :collection :list :vector :string :buffer] 3)
#@54 Underlying implementation of isa on regular objects.
(defalias 'isa_ #[(o1 o2) " \232\203\305\207\306!\211?\205\307\n\205\310 \204B\311\312\313\n\"!\203,\307\211\202\fT\314\315\312\306\n\"\"\211\204\307\316\202\f+\207" [o1 o2 parents done rank 0 mm-parents t 1 any mapcar #[(&rest #1=#:clambdal-arglist-102814) "\302\303\304 C\"\"\207" [#1# o2 apply equal append] 5] apply append nil] 7 (#$ . 13408)])
#@19 A lazy and macro.
(defalias 'lazy-and2 '(macro . #[(e1 e2) "\303\304!\305 DC\306\307D\310\311\nEFE)\207" [e1- e1 e2 gensym "lazy-and-e1-" let if not nil and] 8 (#$ . 13841)]))
#@71 Return the number of objects in list-of which are equilength vectors.
(defalias 'count-equilength-vectors #[(list-of) "\302\303\304\305\306 \")\"\207" [n list-of reduce + nil mapcar #[(v\?) "\302!\203 \204G\303\207 GU\203\303\207\304\207\304\207" [v\? n vectorp 1 0] 2]] 5 (#$ . 14027)])
#@258 ISA? test for equality using the default hierarchy. Child ISA? Parent but not vice versa. Isa? returns a number representing the distance to the nearest ancestor that matches. For vectors of objects, these distances are summed. If nil, o1 is not an o2.
(defalias 'isa\? #[(o1 o2) "\306 D!\307\n\310\"\203\311 \"\202G\307\n\312\"\203\313\202G\307\n\314\"\205G\315\316\317\311 C\320\321 \f $\205E\322\"-\")\207" [o1 o2 #1=#:--cl-var-- cl-rest cl-seq cl-func count-equilength-vectors memql (0) isa_ (1) nil (2) reduce #[(a b) "\247\203 \247\203 \\\207\302\207" [a b nil] 2] vector apply mapcar* coerce cl-type cl-res] 7 (#$ . 14333)])
#@34 Default, dumb conflict resolver.
(defalias 'resolve-by-first #[(o r p1 p2) " D\207" [r p1] 2 (#$ . 15006)])
#@126 Creates a conflict resolution function which checks to see if a method has a specific conflict resolution procedure defined.
(defalias 'make-resolve-by-table #[(resolution-table method-name) "\304\305!\304\306!\211\nL\210 L\210\307\310\311\312\313D\313 D\314\257E*\207" [#1=#:--cl-method-name-- #2=#:--cl-restbl-- resolution-table method-name make-symbol "--restbl--" "--method-name--" lambda (&rest --cl-rest--) apply #[(#3=#:G102815 #4=#:G102816 object rank p1 p2) "\306J\307 @\n@\"\"\211\203\f\306 \nD \"D\202#\310\311 J @\n@$)\207" [#4# p1 p2 resolution rank #3# alist vector error "Method dispatch ambiguity for %s unresolved (%S vs %S)."] 6] quote --cl-rest--] 8 (#$ . 15122)])
#@94 Get the dispatch cache for the hierarchy in the dynamic scope. Create one if not available.
(defalias 'get-dispatch-cache-raw #[nil "\302\303\"\211\203 \202\304\305\306\"\307\303 #\210 ))\207" [*multi-method-heirarchy* cache alist ::::dispatch-cache make-hash-table :test equal alist!] 5 (#$ . 15822)])
#@92 Retrieve the cache of dispatches for the currently scoped hierarchy, or for one passed in.
(defalias 'get-dispatch-cache #[(&rest args) "\302G\303\"\203 \304 \207\302G\305\"\203@\304 )\207\306\307!\207" [args *multi-method-heirarchy* memql (0) get-dispatch-cache-raw (1) error "get-dispatch-cache: Takes either 0 or 1 arguments."] 3 (#$ . 16140)])
#@236 Dispatch from an alist table based on ISA? matches. More specific matches are preferred over less, and ambiguous matches will be resolved by the function resolver. (memoized)
(fn OBJECT ALIST RESOLVER &optional (DEFAULT-METHOD nil))
(defalias 'isa-dispatch-memo #[(object alist resolver &rest #1=#:--cl-rest--) "\211A@\203\306\307\310\311G\\D\"\210\312 \313 \f E\n\"\211\203' \202:\314 \f $\315 \f E \n#\210 )+\207" [#1# default-method cache object resolver method signal wrong-number-of-arguments isa-dispatch-memo 4 get-dispatch-cache gethash isa-dispatch puthash alist] 6 (#$ . 16502)])
#@225 Dispatch from an alist table based on ISA? matches. More specific matches are preferred over less, and ambiguous matches will be resolved by the function resolver.
(fn OBJECT ALIST RESOLVER &optional (DEFAULT-METHOD nil))
(defalias 'isa-dispatch #[(object alist resolver &rest #1=#:--cl-rest--) "\211A@\203\305\306\307\310G\\D\"\210\311\312\313\n#\211A@)\211A@)\211\203,\f\202- *\207" [#1# default-method alist x method signal wrong-number-of-arguments isa-dispatch 4 foldl #[(alist-pair best-so-far) "\306 @\"\211\204 \202F \204\n D\202F\n @W\203%\n D\202F\n @V\2030 \202F\n @U\205F\n\205F\f\n \211A@)$)\207" [object alist-pair rank best-so-far resolver x isa\?] 6] nil] 5 (#$ . 17115)])
Jump to Line
Something went wrong with that request. Please try again.