--- /dev/null
+Slava Pestov
+James Cash
--- /dev/null
+IN: linked-assocs
+USING: help.markup help.syntax assocs ;
+
+HELP: linked-assoc
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assocs and a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-hash>
+{ $values { "assoc" "A new linked-assoc" } }
+{ $description "Creates a new, empty linked assoc." } ;
+
+ARTICLE: "linked-assocs" "Linked assocs"
+"A " { $emphasis "linked assoc" } " is an assoc which combines a hash table and a dlist to form a structure which has the insertion and retrieval characteristics of a hash table, but with the ability to get the items in insertion order."
+$nl
+"Linked assocs implement the following methods from the assoc protocol:"
+{ $subsection at* }
+{ $subsection assoc-size }
+{ $subsection >alist }
+{ $subsection set-at }
+{ $subsection delete-at }
+{ $subsection clear-assoc }
+{ $subsection >alist } ;
+
+ABOUT: "linked-assocs"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs tools.test linked-assocs math ;
+IN: linked-assocs.test
+
+{ { 1 2 3 } } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ values
+] unit-test
+
+{ 2 t } [
+ <linked-hash> 1 "b" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ "c" swap at*
+] unit-test
+
+{ { 2 3 4 } { "c" "a" "d" } 3 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ [ values ] [ keys ] [ assoc-size ] tri
+] unit-test
+
+{ f 1 } [
+ <linked-hash> 1 "c" pick set-at
+ 2 "b" pick set-at
+ "c" over delete-at
+ "c" over at swap assoc-size
+] unit-test
+
+{ { } 0 } [
+ <linked-hash> 1 "a" pick set-at
+ 2 "c" pick set-at
+ 3 "a" pick set-at
+ 4 "d" pick set-at
+ dup clear-assoc [ keys ] [ assoc-size ] bi
+] unit-test
+
+{ { } { 1 2 3 } } [
+ <linked-hash> dup clone
+ 1 "c" pick set-at
+ 2 "q" pick set-at
+ 3 "a" pick set-at
+ [ values ] bi@
+] unit-test
+
+{ 9 } [
+ <linked-hash>
+ { [ 3 * ] [ 1- ] } "first" pick set-at
+ { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ 4 6 pick values [ first call ] each
+ + swap values <reversed> [ second call ] each
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, James Cash.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays kernel deques dlists sequences hashtables fry ;
+IN: linked-assocs
+
+TUPLE: linked-assoc assoc dlist ;
+
+: <linked-hash> ( -- assoc )
+ 0 <hashtable> <dlist> linked-assoc boa ;
+
+M: linked-assoc assoc-size assoc>> assoc-size ;
+
+M: linked-assoc at* assoc>> at* [ [ obj>> second ] when ] keep ;
+
+M: linked-assoc delete-at
+ [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
+ [ assoc>> delete-at ] 2bi ;
+
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+ [ swap 2array ] dip dlist>> push-back* ;
+PRIVATE>
+
+M: linked-assoc set-at
+ [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
+ assoc>> set-at ;
+
+: dlist>seq ( dlist -- seq )
+ [ ] pusher [ dlist-each ] dip ;
+
+M: linked-assoc >alist
+ dlist>> dlist>seq ;
+
+M: linked-assoc clear-assoc
+ [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ;
+
+M: linked-assoc clone
+ [ assoc>> clone ] [ dlist>> clone ] bi
+ linked-assoc boa ;
+
+INSTANCE: linked-assoc assoc
--- /dev/null
+Assocs that yield items in insertion order
IN: advice
-USING: help.markup help.syntax tools.annotations words ;
+USING: help.markup help.syntax tools.annotations words coroutines ;
HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;
+HELP: ad-do-it
+{ $values { "input" "an object" } { "output" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math tools.test advice parser namespaces ;
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
IN: advice.tests
[
-: foo "foo" ;
-\ foo make-advised
+ [ ad-do-it ] must-fail
+
+ : foo "foo" ;
+ \ foo make-advised
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo ] unit-test
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo ] unit-test
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo ] unit-test
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
-: bar ( a -- b ) 1+ ;
-\ bar make-advised
-
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
-
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
-
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
+ : bar ( a -- b ) 1+ ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
- ] with-scope
\ No newline at end of file
+] with-scope
\ No newline at end of file
! Copyright (C) 2008 James Cash
! 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
-SYMBOLS: before after around advised ;
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
<PRIVATE
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
+PRIVATE>
+
: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
word-prop set-at ;
-PRIVATE>
-: advise-before ( quot name word -- )
- before advise ;
+: advise-before ( quot name word -- ) before advise ;
-: advise-after ( quot name word -- )
- after advise ;
+: advise-after ( quot name word -- ) after advise ;
-: advise-around ( quot name word -- )
- [ \ coterminate suffix ] 2dip
- around advise ;
+: advise-around ( quot name word -- ) around advise ;
: get-advice ( word type -- seq )
word-prop values ;
after get-advice [ call ] each ;
: call-around ( main word -- )
- around get-advice [ cocreate ] map tuck
- [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
: remove-advice ( name word loc -- )
word-prop delete-at ;
: ad-do-it ( input -- result )
- coyield ;
-
-: advised? ( word -- ? )
- advised word-prop ;
+ in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
: make-advised ( word -- )
[ 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 ;
-
\ No newline at end of file
+
+: unadvise ( word -- )
+ [ 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
\ No newline at end of file
Chris Double
Clemens F. Hofreither
+James Cash
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
USING: help.markup help.syntax ;
IN: coroutines
HELP: coterminate
{ $values { "v" "an object" } }
{ $description "Terminate the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. Resuming a terminated coroutine is a no-op." }
-{ $see-also coyield }
+{ $see-also coyield coreset }
+;
+
+HELP: coreset
+{ $values { "v" "an object" } }
+{ $description "Reset the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. When the coroutine is resumed, it will continue at the beginning of the coroutine." }
+{ $see-also coyield coterminate }
;
HELP: current-coro
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
IN: coroutines.tests
USING: coroutines kernel sequences prettyprint tools.test math ;
[ [ coyield* ] each ] cocreate ;
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
+
+{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables namespaces make continuations quotations
accessors ;
SYMBOL: current-coro
-TUPLE: coroutine resumecc exitcc ;
+TUPLE: coroutine resumecc exitcc originalcc ;
: cocreate ( quot -- co )
coroutine new
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
- >>resumecc ;
+ [ >>resumecc ] [ >>originalcc ] bi ;
: coresume ( v co -- result )
[
>>exitcc
resumecc>> call
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
f over
] callcc1 2nip ;
current-coro get
[ ] >>resumecc
exitcc>> continue-with ;
+
+: coreset ( v -- )
+ current-coro get dup
+ originalcc>> >>resumecc
+ exitcc>> continue-with ;
\ No newline at end of file
projects / factor.git / commitdiff