steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

More work on advice, cleaning it up (TESTS FAIL)

db4
James Cash 2008-11-11 01:31:22 -05:00
parent ec7bc276dc
commit 44bfc0f802
1 changed files with 32 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
extra/advice/advice.factor
View File

@ -1,26 +1,31 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences symbols fry words assocs tools.annotations coroutines ; USING: kernel sequences symbols fry words assocs linked-assocs tools.annotations
coroutines lexer parser quotations arrays namespaces continuations ;
IN: advice IN: advice
! TODO: What should be the order in which the advice is called? SYMBOLS: before after around advised in-advice? ;
SYMBOLS: before after around advised ; : advised? ( word -- ? )
advised word-prop ;
DEFER: make-advised
<PRIVATE <PRIVATE
: advise ( quot name word loc -- ) : init-around-co ( quot -- coroutine )
word-prop set-at ; \ coreset suffix cocreate ;
PRIVATE> PRIVATE>
: advise-before ( quot name word -- ) : advise ( quot name word loc -- )
before advise ; dup around eq? [ [ init-around-co ] 3dip ] when
over advised? [ over make-advised ] unless
word-prop set-at ;
: advise-after ( quot name word -- ) : advise-before ( quot name word -- ) before advise ;
after advise ;
: advise-around ( quot name word -- ) : advise-after ( quot name word -- ) after advise ;
[ \ coreset suffix cocreate ] 2dip
around advise ; : advise-around ( quot name word -- ) around advise ;
: get-advice ( word type -- seq ) : get-advice ( word type -- seq )
word-prop values ; word-prop values ;
@ -32,22 +37,27 @@ PRIVATE>
after get-advice [ call ] each ; after get-advice [ call ] each ;
: call-around ( main word -- ) : call-around ( main word -- )
around get-advice tuck t in-advice? [
[ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ; around get-advice tuck
[ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
] with-variable ;
: remove-advice ( name word loc -- ) : remove-advice ( name word loc -- )
word-prop delete-at ; word-prop delete-at ;
: ad-do-it ( input -- result ) : ad-do-it ( input -- result )
coyield ; in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
: advised? ( word -- ? )
advised word-prop ;
: make-advised ( word -- ) : make-advised ( word -- )
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
[ { before after around } [ H{ } clone swap set-word-prop ] with each ] [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ; [ t advised set-word-prop ] tri ;
: unadvise ( word -- ) : unadvise ( word -- )
[ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ; [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
: ADVISE: ! word adname location => word adname quot loc
scan-word scan scan-word parse-definition swap [ spin ] dip advise ; parsing
: UNADVISE:
scan-word parsed \ unadvise parsed ; parsing