From 00176e7bd19e3bd63a7c279d3624fa19b8165578 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sat, 17 Apr 2010 17:19:37 -0500
Subject: [PATCH] Attempting to make require-when work with multiple vocabs

---
 core/vocabs/loader/loader.factor   | 31 ++++++++++++++++++++-----
 core/vocabs/loader/test/m/m.factor |  3 ++-
 core/vocabs/vocabs.factor          | 37 ++++++++++++++++++++++++++++--
 3 files changed, 62 insertions(+), 9 deletions(-)

diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 59fe06e6fd..4e811d8914 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -3,7 +3,7 @@
 USING: namespaces make sequences io io.files io.pathnames kernel
 assocs words vocabs definitions parser continuations hashtables
 sorting source-files arrays combinators strings system
-math.parser splitting init accessors sets ;
+math.parser splitting init accessors sets fry ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -66,9 +66,17 @@ DEFER: require
 
 <PRIVATE
 
+: transfer-conditionals ( vocab-name record -- )
+    {
+        [ unloaded>> delete ]
+        [ loaded>> adjoin ]
+        [ swap partly-required get adjoin-at ]
+        [ unloaded>> null? swap '[ _ require ] when ]
+    } 2cleave ;
+
 : load-conditional-requires ( vocab-name -- )
     conditional-requires get
-    [ at [ require ] each ] 
+    [ dupd at members [ transfer-conditionals ] with each ] 
     [ delete-at ] 2bi ;
 
 : load-source ( vocab -- )
@@ -96,11 +104,22 @@ PRIVATE>
 : require ( vocab -- )
     load-vocab drop ;
 
+<PRIVATE
+
+: adjoin-each-at ( elt seq assoc -- )
+    [ swap ] dip '[ _ swap _ adjoin-at ] each ;
+
+: record-require-when ( then loaded unloaded -- )
+    [ [ fast-set ] bi@ <require-when-record> ] 2keep
+    [ conditional-requires get adjoin-each-at ]
+    [ partly-required get adjoin-each-at ]
+    bi-curry* bi ;
+
+PRIVATE>
+
 : require-when ( if then -- )
-    over vocab
-    [ nip require ]
-    [ swap conditional-requires get [ swap suffix ] change-at ]
-    if ;
+    swap [ vocab ] partition
+    [ drop require ] [ record-require-when ] if-empty ;
 
 : reload ( name -- )
     dup vocab
diff --git a/core/vocabs/loader/test/m/m.factor b/core/vocabs/loader/test/m/m.factor
index d6d3bd8a7a..cd35d83e4f 100644
--- a/core/vocabs/loader/test/m/m.factor
+++ b/core/vocabs/loader/test/m/m.factor
@@ -1,4 +1,5 @@
 USE: vocabs.loader
 IN: vocabs.loader.test.m
 
-"vocabs.loader.test.o" "vocabs.loader.test.n" require-when
+{ "vocabs.loader.test.o" "vocabs.loader.test.m" }
+"vocabs.loader.test.n" require-when
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index e48d6c3031..db28c9981b 100644
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs strings kernel sorting namespaces
-sequences definitions sets ;
+sequences definitions sets combinators ;
 IN: vocabs
 
 SYMBOL: dictionary
@@ -83,9 +83,25 @@ ERROR: bad-vocab-name name ;
 : check-vocab-name ( name -- name )
     dup string? [ bad-vocab-name ] unless ;
 
+TUPLE: require-when-record
+    vocab loaded unloaded ;
+
+! These are identified by their vocab
+M: require-when-record equal?
+    over require-when-record?
+    [ [ vocab>> ] bi@ = ] [ 2drop f ] if ;
+
+M: require-when-record hashcode*
+    vocab>> hashcode* ;
+
+C: <require-when-record> require-when-record
+
 SYMBOL: conditional-requires
 conditional-requires [ H{ } clone ] initialize
 
+SYMBOL: partly-required
+partly-required [ H{ } clone ] initialize
+
 : create-vocab ( name -- vocab )
     check-vocab-name
     dictionary get [ <vocab> ] cache
@@ -120,9 +136,26 @@ M: vocab-spec >vocab-link ;
 
 M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
 
+<PRIVATE
+
+: untransfer-conditionals ( vocab-name record -- )
+    {
+        [ loaded>> delete ]
+        [ unloaded>> adjoin ]
+        [ swap conditional-requires get adjoin-at ]
+    } 2cleave ;
+
+: unload-conditional-requires ( vocab-name -- )
+    partly-required get
+    [ dupd at members [ untransfer-conditionals ] with each ] 
+    [ delete-at ] 2bi ;
+
+PRIVATE>
+
 : forget-vocab ( vocab -- )
     [ words forget-all ]
-    [ vocab-name dictionary get delete-at ] bi
+    [ vocab-name dictionary get delete-at ]
+    [ unload-conditional-requires ] tri
     notify-vocab-observers ;
 
 M: vocab-spec forget* forget-vocab ;