/lib/extend.arc

 1; extend by CatDancer <cat@catdancer.ws> (http://hacks.catdancer.ws)
 2; license: Public domain (http://creativecommons.org/licenses/publicdomain/)
 3
 4; CHANGELOG
 5; 2010-02-15 Mark Huetsch <markhuetsch@gmail.com>
 6;  + moved to simpler extend from http://awwx.ws/extend0.arc simply
 7;    because the old versions don't seem to work with aw's new patches
 8;    and I don't have time to debug them.
 9; 2009-08-20: Michael Arntzenius <daekharel@gmail.com>
10;  + reloading the file will no longer wipe the extensions table.
11;  + refactored 'extend macro into a function 'extend-add, a function 
12;    'extend-fn, a macro 'extend-ensure, and a macro 'extend.
13;  + remove unnecessary let in 'extend-wrap's afn
14;  + add 'extend-pull fn, 'unextend macro
15
16;(unless (and bound!extensions* extensions*)
17;  (= extensions* (table)))
18;
19;(defmemo extend-fn (name)
20;  (fn args
21;    ((afn (((label (test func)) . rest))
22;       (if (or (no test) (apply test args))
23;             (apply func args)
24;           (self rest)))
25;     (or (extensions* name)
26;         (err "no extension defined for" name)))))
27;
28;(mac extend-ensure (name)
29;  `(do
30;     (unless (extensions* ',name)
31;       (= (extensions* ',name) `((original (nil ,,name)))))
32;    (= ,name (extend-fn ',name))))
33;
34;(def extend-add (name label test func)
35;  (aif (assoc label extensions*.name)
36;        (do (prn "*** redefining " name " extension " label)
37;            (= (cadr it) (list test func)))
38;      (push `(,label (,test ,func)) extensions*.name)))
39;
40;(mac extend (name label test func)
41; `(do1 (extend-ensure ,name)
42;       (extend-add ',name ',label ,test ,func)))
43;
44;(def extend-pull (name label)
45;  (prn "*** undefining " name " extension " label)
46;  (pull [is car._ label] extensions*.name))
47;
48;(mac unextend (name label)
49;  `(do (extend-pull ',name ',label) ,name))
50;
51;; original 'extend from extend0.arc
52;(mac extend (name label test func)
53;   `(do (unless (extensions* ',name)
54;          (= (extensions* ',name) `((original (nil ,,name)))))
55;        (aif (assoc ',label (extensions* ',name))
56;              (do (prn "*** redefining " ',name " extension " ',label)
57;                  (= (cadr it) (list ,test ,func)))
58;              (push (list ',label (list ,test ,func)) (extensions* ',name)))
59;        (= ,name (fn args
60;                   ((afn (al)
61;                      (let (label (test func)) (car al)
62;                        (if (or (no test) (apply test args))
63;                             (apply func args)
64;                             (self (cdr al)))))
65;                    (or (extensions* ',name)
66;                        (err "no extension defined for" ',name)))))))
67
68; TODO re-add unextend support
69(mac extend (name arglist test . body)
70  (w/uniq args
71    `(let orig ,name
72       (= ,name
73          (fn ,args
74            (aif (apply (fn ,arglist ,test) ,args)
75                  (apply (fn ,arglist ,@body) ,args)
76                  (apply orig ,args)))))))