Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 6784d57ea1
Fetching contributors…

Cannot retrieve contributors at this time

81 lines (68 sloc) 10.566 kb
;;; Compiled by toups@deluge on Wed Jan 18 21:02:45 2012
;;; from file /home/toups/elisp/utils/shadchen.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 "\301\302\303\304#\210\302\305N\204\301\302\305\306#\210\307\301\302\310\311\312!!#\210)\301\207" [file put match-fail-struct-p cl-compiler-macro #[(--cl-whole-arg-- cl-x) "\301\302\303\304\211\211&\207" [cl-x cl-defsubst-expand (cl-x) (block match-fail-struct-p (and (vectorp cl-x) (>= (length cl-x) 1) (memq (aref cl-x 0) cl-struct-match-fail-struct-tags) t)) nil] 7] byte-compile cl-byte-compile-compiler-macro "/home/toups/elisp/utils/shadchen.el" compiler-macro-file purecopy file-name-nondirectory] 6)
(defalias 'match-fail-struct-p #[(cl-x) "\302!\205G\303Y\205\304H >\205\305\207" [cl-x cl-struct-match-fail-struct-tags vectorp 1 0 t] 2])
(defalias 'copy-match-fail-struct #[(x) "\301!\207" [x copy-sequence] 2])
(byte-code "\301\302\303\304#\210\302\305N\204\301\302\305\306#\210\307\301\302\310\311\312!!#\210)\301\207" [file put make-match-fail-struct cl-compiler-macro #[(cl-whole &rest #:--cl-rest--) "\301\302\303\304\302%\207" [cl-whole cl-defsubst-expand nil (block make-match-fail-struct (vector 'cl-struct-match-fail-struct)) t] 6 "Not documented\n\n(fn CL-WHOLE &cl-quote &key)"] byte-compile cl-byte-compile-compiler-macro "/home/toups/elisp/utils/shadchen.el" compiler-macro-file purecopy file-name-nondirectory] 6)
#@27 Not documented
(fn &key)
(defalias 'make-match-fail-struct #[(&rest #1=#:--cl-rest--) "\300\301!\207" [vector cl-struct-match-fail-struct] 2 (#$ . 1773)])
(byte-code "\303B\304C\305\306\307\310#\210\305\306\311\312#\210\305\306\313\314#\210\305\306\315\316#\210\305\317\320\316#\210\305\321\320\316#\210\305\322\320\323#\210\324\nB\325\324!\204B\326\324\327\304!\"\210\314\207" [custom-print-functions cl-struct-match-fail-struct-tags current-load-list #[(cl-x cl-s cl-n) "\303!\205 G\304Y\205 \305H >\205 \306\307\n\"\210\306\310\n\"\210\311\207" [cl-x cl-struct-match-fail-struct-tags cl-s vectorp 1 0 princ "#S(match-fail-struct" ")" t] 3] cl-struct-match-fail-struct put match-fail-struct cl-struct-slots ((cl-tag-slot)) cl-struct-type (vector nil) cl-struct-include nil cl-struct-print t make-match-fail-struct side-effect-free copy-match-fail-struct match-fail-struct-p error-free *match-fail* default-boundp set-default vector] 4)
(defalias 'non-keyword-symbol #[(o) "9\205 \301!?\207" [o keywordp] 2])
(defalias 'match-list-expander* #[(sub-expressions match-value body) "\204\305\306 D\307\nB\310BBB\207@\311\312!\313 DC\305\314\315 D E\316\f\317 D\316\320AB\321 D\nBBBF\322BBBE*\207" [sub-expressions match-value body list-name first-expression if not progn (*match-fail*) gensym "MATCH-LIST-EXPANDER*-" let and listp match1 car list cdr (*match-fail*)] 11])
(defalias 'match-list-expander #[(match-expression match-value body) "\303A \n#\207" [match-expression match-value body match-list-expander*] 4])
(defalias 'match-cons-expander #[(match-expression match-value body) "\306\234\307\234\310\311!\312 \fDC\313\314 D\315 \316 D\315\n\317 D BBBFEE+\207" [match-expression name cdr-match car-match match-value body 1 2 gensym "MATCH-CONS-EXPANDER-" let if listp match1 car cdr] 11])
(defalias 'match-quote-expander #[(match-expression match-value body) "\303\304 E\305\nB\306BBB\207" [match-expression match-value body if equalp progn (*match-fail*)] 4])
(defalias 'match-backquote-expander #[(match-expression match-value body) "\211A@)\211\204\306 B\202y\n<\203/\n@\307=\203/\n\211A@)\310\f )BBB\202y\n<\203p\n@\nA\311\312!\313 DC\314\315\316DE\310\317D\320D\310\317D\321D BBBF\322BBBE+\202y\310\323\nD BBB)\207" [match-expression x datum body sub-match match-value progn uq match1 gensym "MATCH-BACKQUOTE-EXPANDER-" let if and listp bq car cdr (*match-fail*) quote name rest-bq first-qt] 12])
(defalias 'match-and-expander* #[(sub-expressions match-name body) "\204\305 B\207@\306\307!\310 \f\310\311AB\f BBBF*\207" [sub-expressions body name s1 match-name progn gensym "MATCH-AND-EXPANDER*-" match1 and] 7])
(defalias 'match-and-expander #[(match-expression match-value body) "\304\305!\306 DC\307\nA #E)\207" [name match-value match-expression body gensym "MATCH-AND-EXPANDER-" let match-and-expander*] 6])
(defalias 'match-\?-expander #[(match-expression match-value body) "\306\307!\306\310!\nAG\311=\203\312\313!\202i\nAG\314=\203;\315 D\n\211A@)DD\316\317 E\320 B\321BBBE\202i\nAG\322=\203f\315 D\n\211A@)DD\316\317 E\323\n\322\234 BBB\324BBBE\202i\312\325!*\207" [f-name name match-expression match-value x body gensym "MATCH-?-EXPANDER-NAME-" "MATCH-?-EXPANDER-FUNCTION-" 0 error "MATCH1: MATCH-?-EXPANDER: zero arguments to MATCH-?-EXPANDER. Needs 1 or 2." 1 let if funcall progn (*match-fail*) 2 match1 (*match-fail*) "MATCH-?-EXPANDER: MATCH-?-EXPANDER takes only 1 or 2 arguments."] 9])
(defalias 'match-values-expander #[(match-expression match-value body) "\304\305!\306\307 DDC\310\311\nAB BBBE)\207" [name match-value match-expression body gensym "MATCH-VALUES-EXPANDER-" let multiple-value-list match1 list] 6])
(defalias 'match-funcall-expander #[(match-expression match-value body) "<\203\fG\306U\204\307\310<G\306U$\210\311\312!\311\313!\311\314!\315 \fD\n\211A@)D \316\n EDE\317\211AA)@ BBBE+\207" [match-expression result-name fun-name name match-value x 3 error "MATCH-FUNCALL-EXPANDER: FUNCALL match expression must have\ntwo terms, a function and a match against the result. Got\n%s." gensym "MATCH-FUNCALL-EXPANDER-NAME-" "MATCH-FUNCALL-EXPANDER-FUN-NAME-" "MATCH-FUNCALL-EXPANDER-RESULT-NAME-" let* funcall match1 body] 8])
#@31 Holds user declared patterns.
(defvar *extended-patterns* (make-hash-table) (#$ . 6059))
#@61 Return T if PATTERN-HEAD indicates a user provided pattern.
(defalias 'extended-patternp #[(pattern-head) "\304 \"\211@\nA@*\207" [pattern-head *extended-patterns* #1=#:--cl-var-- val gethash] 4 (#$ . 6154)])
(defalias 'match-extended-pattern-expander #[(match-expression match-value body) "A\306@\n\"\307 \"\310\f  +BBB\207" [match-expression pattern-args *extended-patterns* pattern-fun expansion match-value gethash apply match1 body] 4])
#@43 Not documented
(fn NAME ARGS &body BODY)
(defalias 'defpattern '(macro . #[(name args &rest body) "\303\304\305D\306BB\307\310 \nBBDE\207" [name args body setf gethash quote (*extended-patterns*) function lambda] 6 (#$ . 6612)]))
(defalias 'match-literal-string #[(match-expression match-value body) "\303\304 E\305\nB\306BBB\207" [match-expression match-value body if string= progn (*match-fail*)] 4])
(defalias 'match-literal-number #[(match-expression match-value body) "\303\304 E\305\nB\306BBB\207" [match-expression match-value body if = progn (*match-fail*)] 4])
(defalias 'match-literal-keyword #[(match-expression match-value body) "\303\304 E\305\nB\306BBB\207" [match-expression match-value body if eq progn (*match-fail*)] 4])
#@62 Not documented
(defalias 'match1 '(macro . #[(match-expression match-value &rest body) "\303!\203\304 DC\nBB\207;\203\305 \n#\207\247\203%\306 \n#\207\307!\2031\310 \n#\207\311@!\203>\312 \n#\207<\203\253@\313=\203P\314 \n#\207@\315=\203]\316 \n#\207@\317=\203j\320 \n#\207@\321=\203w\322 \n#\207@\323=\203\204\324 \n#\207@\325=\203\221\326 \n#\207@\327=\203\236\330 \n#\207@\331=\205\257\332 \n#\207\333\334\"\207" [match-expression match-value body non-keyword-symbol let match-literal-string match-literal-number keywordp match-literal-keyword extended-patternp match-extended-pattern-expander list match-list-expander cons match-cons-expander quote match-quote-expander and match-and-expander 32 match-\?-expander funcall match-funcall-expander bq match-backquote-expander values match-values-expander error "MATCH1: Unrecognized match expression: %s."] 4 (#$ . 7362)]))
#@40 Not documented
(fn VALUE &body FORMS)
(defalias 'match-helper '(macro . #[(value &rest forms) "9\204 \306\307\211#\210 \204\306\310E\207 <\205Y @\211<\203(\nG\311V\2043\306\312\n<\nG\311V\n$\210\n@\nA\313\314!\315 \316 \fBBBDC\317\320\321\322 ED \323 ABBFE,\207" [value forms first-form result-name match-body-exprs match-expression error "MATCH-HELPER: VALUE must be a symbol! Got %s." "No Match for %s!" 1 "Each MATCH SUB-FORM must be at least two elements long, a matcher\nand an expression to evaluate on match. Got %s instead." gensym "MATCH-HELPER-RESULT-NAME-" let match1 if not eq *match-fail* match-helper] 9 (#$ . 8333)]))
#@277 Attempt to match VALUE against each of the patterns in the CAR of
FORMS. When a match is detected, its subsequent forms are executed as
in a PROGN where the bindings implied by the match are in effect.
An error is thrown when no matches are found.
(fn VALUE &body FORMS)
(defalias 'match '(macro . #[(value &rest forms) "\303\304!\305 DC\306\nBBE)\207" [name value forms gensym "MATCH-VALUE-NAME-" let match-helper] 5 (#$ . 8990)]))
#@59 Like MATCH except the VALUE is curried.
(fn &body FORMS)
(defalias 'match-lambda '(macro . #[(&rest forms) "\302\303!\304\305C\306 BBE)D\207" [name forms gensym "MATCH-LAMBDA-NAME-" function lambda match] 6 (#$ . 9437)]))
#@37 Returns T when LST has one element.
(defalias 'length=1 #[(lst) ":\205A?\207" [lst] 1 (#$ . 9669)])
(puthash 'list-rest #[(&rest patterns) "\303!\203\f\304\305@E\207@A\306\307\310\nE\307\311\312 BEE*\207" [patterns pats pat length=1 32 #'listp and funcall #'car #'cdr list-rest] 6] *extended-patterns*)
(defalias 'cl-struct-prepend #[(s) "\301\302\303\"!\207" [s intern format "cl-struct-%s"] 4])
(byte-code "\301\302\303#\210\304\305!\207" [*extended-patterns* puthash struct #[(struct-name &rest fields) "\306\307\310\311\312\313\314\315\316\317\320!DEEDD \321\211\n:\203>\n@\322\312\313\323\324\325\317 @DEED \211A@)E\fB\nA\211\202\f\237+BBBB\207" [struct-name fields #:--cl-var-- f #:--cl-var-- x and (32 #'vectorp) (32 #'(lambda (x) (> (length x) 0))) 32 function lambda (o) eq (elt o 0) quote cl-struct-prepend nil funcall (o) slot-value o] 13] provide shadchen] 4)
Jump to Line
Something went wrong with that request. Please try again.