Merge branch 'master' of git://factorcode.org/git/jamesnvc

basis/linked-assocs/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+James Cash

basis/linked-assocs/linked-assocs-docs.factor

@@ -0,0 +1,23 @@
+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"

basis/linked-assocs/linked-assocs-tests.factor

@@ -0,0 +1,57 @@
+! 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

basis/linked-assocs/linked-assocs.factor

@@ -0,0 +1,41 @@
+! 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

basis/linked-assocs/summary.txt

@@ -0,0 +1 @@
+Assocs that yield items in insertion order

basis/linked-assocs/tags.txt

@@ -0,0 +1 @@
+assocs

extra/advice/advice-docs.factor

@@ -1,5 +1,5 @@
 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" } }
@@ -16,6 +16,11 @@ HELP: advised?
 { $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." ;
 

extra/advice/advice-tests.factor

@@ -1,26 +1,32 @@
 ! 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
+        foo
+    ] unit-test
  
     { "bar" "foo" "baz" } [
         [ "baz" ] "bazify" \ foo advise-after
-      foo ] unit-test
+        foo
+    ] unit-test
  
     { "foo" "baz" } [
         "barify" \ foo before remove-advice
-     foo ] unit-test
+        foo
+    ] unit-test
  
-: bar ( a -- b ) 1+ ;
-\ bar make-advised
+    : bar ( a -- b ) 1+ ;
+    \ bar make-advised
 
     { 11 } [
         [ 2 * ] "double" \ bar advise-before
@@ -37,4 +43,52 @@ IN: advice.tests
         5 bar
     ] unit-test
 
- ] with-scope
+    : 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

extra/advice/advice.factor

@@ -1,24 +1,31 @@
 ! 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
-: advise ( quot name word loc --  )
-    word-prop set-at ;
+: init-around-co ( quot -- coroutine )
+    \ coreset suffix cocreate ;
 PRIVATE>
 
-: advise-before ( quot name word --  )
-    before advise ;
+: advise ( quot name word loc --  )
+    dup around eq? [ [ init-around-co ] 3dip ] when
+    over advised? [ over make-advised ] unless
+    word-prop set-at ;
     
-: advise-after ( quot name word --  )
-    after advise ;
+: advise-before ( quot name word --  ) before advise ;
     
-: advise-around ( quot name word --  )
-    [ \ coterminate suffix ] 2dip
-    around advise ;
+: advise-after ( quot name word --  ) after advise ;
+
+: advise-around ( quot name word --  ) around advise ;
 
 : get-advice ( word type -- seq )
     word-prop values ;
@@ -30,20 +37,27 @@ PRIVATE>
     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 ;
 
+: 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

extra/coroutines/authors.txt

@@ -1,2 +1,3 @@
 Chris Double
 Clemens F. Hofreither
+James Cash

extra/coroutines/coroutines-docs.factor

@@ -1,4 +1,4 @@
-! 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
 
@@ -46,7 +46,13 @@ HELP: coyield*
 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

extra/coroutines/coroutines-tests.factor

@@ -1,4 +1,4 @@
-! 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 ;
@@ -17,3 +17,5 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
   [ [ 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

extra/coroutines/coroutines.factor

@@ -1,4 +1,4 @@
-! 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 ;
@@ -6,7 +6,7 @@ IN: coroutines
 
 SYMBOL: current-coro
 
-TUPLE: coroutine resumecc exitcc ;
+TUPLE: coroutine resumecc exitcc originalcc ;
 
 : cocreate ( quot -- co )
   coroutine new
@@ -14,14 +14,14 @@ TUPLE: coroutine resumecc exitcc ;
   [ 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 ;
 
@@ -43,3 +43,8 @@ TUPLE: coroutine resumecc exitcc ;
   current-coro get
   [ ] >>resumecc
   exitcc>> continue-with ;
+
+: coreset ( v --  )
+  current-coro get dup
+  originalcc>> >>resumecc
+  exitcc>> continue-with ;