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

basis/bootstrap/image/image.factor

@@ -554,12 +554,19 @@ M: quotation '
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
 
+: build-generics ( -- )
+    [
+        all-words
+        [ generic? ] filter
+        [ make-generic ] each
+    ] with-compilation-unit ;
+
 : build-image ( -- image )
     800000 <vector> image set
     20000 <hashtable> objects set
     emit-image-header t, 0, 1, -1,
     "Building generic words..." print flush
-    remake-generics
+    build-generics
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush

basis/combinators/smart/smart-tests.factor

@@ -53,3 +53,9 @@ IN: combinators.smart.tests
 { 2 0 } [ [ + ] nullary ] must-infer-as
 
 { 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
+
+: smart-if-test ( a b -- b )
+    [ < ] [ swap - ] [ - ] smart-if ;
+
+[ 7 ] [ 10 3 smart-if-test ] unit-test
+[ 16 ] [ 25 41 smart-if-test ] unit-test

basis/combinators/smart/smart.factor

@@ -50,4 +50,4 @@ MACRO: nullary ( quot -- quot' )
     dup outputs '[ @ _ ndrop ] ;
 
 MACRO: smart-if ( pred true false -- )
-    '[ _ preserving _ _ if ] ; inline
+    '[ _ preserving _ _ if ] ;

basis/debugger/debugger.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: slots arrays definitions generic hashtables summary io kernel
 math namespaces make prettyprint prettyprint.config sequences assocs
@@ -252,6 +252,8 @@ M: decode-error summary drop "Character decoding error" ;
 
 M: bad-create summary drop "Bad parameters to create" ;
 
+M: cannot-be-inline summary drop "This type of word cannot be inlined" ;
+
 M: attempt-all-error summary drop "Nothing to attempt" ;
 
 M: already-disposed summary drop "Attempting to operate on disposed object" ;

basis/images/jpeg/jpeg.factor

@@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
 : decode-macroblock ( -- blocks )
     jpeg> components>>
     [
-        [ mb-dim first2 * iota ]
+        [ mb-dim first2 * ]
         [ [ decode-block ] curry replicate ] bi
     ] map concat ;
 

basis/listener/listener.factor

@@ -193,13 +193,12 @@ SYMBOL: interactive-vocabs
 
 : with-interactive-vocabs ( quot -- )
     [
-        <manifest> manifest set
         "scratchpad" set-current-vocab
         interactive-vocabs get only-use-vocabs
         call
-    ] with-scope ; inline
+    ] with-manifest ; inline
 
 : listener ( -- )
-    [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
+    [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
 
 MAIN: listener

basis/macros/macros-tests.factor

@@ -21,3 +21,5 @@ unit-test
 
 [ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
 
+[ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
+    [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail

basis/macros/macros.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel sequences words effects combinators assocs
 definitions quotations namespaces memoize accessors
@@ -23,6 +23,8 @@ SYNTAX: MACRO: (:) define-macro ;
 
 PREDICATE: macro < word "macro" word-prop >boolean ;
 
+M: macro make-inline cannot-be-inline ;
+
 M: macro definer drop \ MACRO: \ ; ;
 
 M: macro definition "macro" word-prop ;

basis/math/ranges/ranges.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel layouts math math.order namespaces sequences
 sequences.private accessors classes.tuple arrays ;
@@ -16,10 +16,8 @@ M: range length ( seq -- n ) length>> ; inline
 
 M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
 
-! For ranges with many elements, the default element-wise methods
+! We want M\ tuple hashcode, not M\ sequence hashcode here!
-! sequences define are unsuitable because they're O(n)
+! sequences hashcode is O(n) in number of elements
-M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
-
 M: range hashcode* tuple-hashcode ;
 
 INSTANCE: range immutable-sequence

basis/random/windows/windows.factor

@@ -1,7 +1,8 @@
 USING: accessors alien.c-types alien.data byte-arrays
 combinators.short-circuit continuations destructors init kernel
 locals namespaces random windows.advapi32 windows.errors
-windows.kernel32 windows.types math.bitwise ;
+windows.kernel32 windows.types math.bitwise sequences fry
+literals ;
 IN: random.windows
 
 TUPLE: windows-rng provider type ;
@@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
         [ CryptGenRandom win32-error=0/f ] keep
     ] with-destructors ;
 
-[
+ERROR: no-windows-crypto-provider error ;
-    MS_DEF_PROV
-    PROV_RSA_FULL <windows-rng> system-random-generator set-global
 
-    [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
+: try-crypto-providers ( seq -- windows-rng )
-    [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
+    [ first2 <windows-rng> ] attempt-all
-    secure-random-generator set-global
+    dup windows-rng? [ no-windows-crypto-provider ] unless ;
+
+[
+    {
+        ${ MS_ENHANCED_PROV PROV_RSA_FULL }
+        ${ MS_DEF_PROV PROV_RSA_FULL }
+    } try-crypto-providers
+    system-random-generator set-global
+
+    {
+        ${ MS_STRONG_PROV PROV_RSA_FULL }
+        ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
+    } try-crypto-providers secure-random-generator set-global
 ] "random.windows" add-startup-hook
 
 [

basis/vocabs/prettyprint/prettyprint.factor

@@ -64,12 +64,15 @@ M: rename pprint-qualified ( rename -- )
         tri
     ] with-pprint ;
 
+: filter-interesting ( seq -- seq' )
+    [ [ vocab? ] [ extra-words? ] bi or not ] filter ;
+
 PRIVATE>
 
 : (pprint-manifest ( manifest -- quots )
     [
         [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
-        [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
+        [ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
         [ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
         tri
     ] { } make ;

core/bootstrap/primitives.factor

@@ -31,32 +31,31 @@ architecture get {
 ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
 
 ! Bring up a bare cross-compiling vocabulary.
-"syntax" vocab vocab-words bootstrap-syntax set {
+"syntax" vocab vocab-words bootstrap-syntax set
-    dictionary
+
-    new-classes
+H{ } clone dictionary set
-    changed-definitions changed-generics changed-effects
+H{ } clone root-cache set
-    outdated-generics forgotten-definitions
+H{ } clone source-files set
-    root-cache source-files update-map implementors-map
+H{ } clone update-map set
-} [ H{ } clone swap set ] each
+H{ } clone implementors-map set
 
 init-caches
 
+bootstrapping? on
+
+call( -- )
+call( -- )
+
 ! Vocabulary for slot accessors
 "accessors" create-vocab drop
 
-dummy-compiler compiler-impl set
-
-call( -- )
-call( -- )
-call( -- )
-
 ! After we execute bootstrap/layouts
 num-types get f <array> builtins set
 
-bootstrapping? on
-
 [
 
+call( -- )
+
 ! Create some empty vocabs where the below primitives and
 ! classes will go
 {

core/classes/tuple/tuple-tests.factor

@@ -6,7 +6,7 @@ io.streams.string kernel kernel.private math math.constants
 math.order namespaces parser parser.notes prettyprint
 quotations random see sequences sequences.private slots
 slots.private splitting strings summary threads tools.test
-vectors vocabs words words.symbol fry literals ;
+vectors vocabs words words.symbol fry literals memory ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -443,14 +443,14 @@ TUPLE: redefinition-problem-2 ;
 
 [ ] [
     [
-        \ vocab tuple { "xxx" } "slots" get append
+        \ vocab identity-tuple { "xxx" } "slots" get append
         define-tuple-class
     ] with-compilation-unit
 
     all-words drop
 
     [
-        \ vocab tuple "slots" get
+        \ vocab identity-tuple "slots" get
         define-tuple-class
     ] with-compilation-unit
 ] unit-test
@@ -765,3 +765,22 @@ USE: classes.struct
     [ "prototype" word-prop ] map
     [ '[ _ hashcode drop f ] [ drop t ] recover ] filter
 ] unit-test
+
+! Make sure that tuple reshaping updates code heap roots
+TUPLE: code-heap-ref ;
+
+: code-heap-ref' ( -- a ) T{ code-heap-ref } ;
+
+! Push foo's literal to tenured space
+[ ] [ gc ] unit-test
+
+! Reshape!
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
+
+! Code heap reference
+[ t ] [ code-heap-ref' code-heap-ref? ] unit-test
+[ 5 ] [ code-heap-ref' x>> ] unit-test
+
+! Data heap reference
+[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
+[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test

core/compiler/units/units.factor

@@ -64,16 +64,6 @@ M: f process-forgotten-words drop ;
 : without-optimizer ( quot -- )
     [ f compiler-impl ] dip with-variable ; inline
 
-! Trivial compiler. We don't want to touch the code heap
-! during stage1 bootstrap, it would just waste time.
-SINGLETON: dummy-compiler
-
-M: dummy-compiler to-recompile f ;
-
-M: dummy-compiler recompile drop { } ;
-
-M: dummy-compiler process-forgotten-words drop ;
-
 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
 
 SYMBOL: definition-observers
@@ -143,13 +133,15 @@ M: object bump-effect-counter* drop f ;
     [ drop ] [ notify-definition-observers notify-error-observers ] if ;
 
 : finish-compilation-unit ( -- )
-    remake-generics
+    [ ] [
-    to-recompile recompile
+        remake-generics
-    update-tuples
+        to-recompile recompile
-    process-forgotten-definitions
+        update-tuples
-    modify-code-heap
+        process-forgotten-definitions
-    bump-effect-counter
+        modify-code-heap
-    notify-observers ;
+        bump-effect-counter
+        notify-observers
+    ] if-bootstrapping ;
 
 PRIVATE>
 

core/continuations/continuations-docs.factor

@@ -1,274 +1,274 @@
-USING: help.markup help.syntax kernel kernel.private
+USING: help.markup help.syntax kernel kernel.private
-continuations.private vectors arrays namespaces
+continuations.private vectors arrays namespaces
-assocs words quotations lexer sequences math ;
+assocs words quotations lexer sequences math ;
-IN: continuations
+IN: continuations
-
+
-ARTICLE: "errors-restartable" "Restartable errors"
+ARTICLE: "errors-restartable" "Restartable errors"
-"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
+"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
-{ $subsections
+{ $subsections
-    throw-restarts
+    throw-restarts
-    rethrow-restarts
+    rethrow-restarts
-}
+}
-"The list of restarts from the most recently-thrown error is stored in a global variable:"
+"The list of restarts from the most recently-thrown error is stored in a global variable:"
-{ $subsections restarts }
+{ $subsections restarts }
-"To invoke restarts, see " { $link "debugger" } "." ;
+"To invoke restarts, see " { $link "debugger" } "." ;
-
+
-ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
+ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
-"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
+"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
-{ $subsections
+{ $subsections
-    error
+    error
-    error-continuation
+    error-continuation
-}
+}
-"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
+"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
-
+
-ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
-"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
-{ $heading "Anti-pattern #1: Ignoring errors" }
+{ $heading "Anti-pattern #1: Ignoring errors" }
-"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
-{ $heading "Anti-pattern #2: Catching errors too early" }
+{ $heading "Anti-pattern #2: Catching errors too early" }
-"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
-$nl
+$nl
-"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
-{ $heading "Anti-pattern #3: Dropping and rethrowing" }
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }
-"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
-{ $heading "Anti-pattern #4: Logging and rethrowing" }
+{ $heading "Anti-pattern #4: Logging and rethrowing" }
-"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
-
+
-ARTICLE: "errors" "Exception handling"
+ARTICLE: "errors" "Exception handling"
-"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
+"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
-$nl
+$nl
-"Two words raise an error in the innermost error handler for the current dynamic extent:"
+"Two words raise an error in the innermost error handler for the current dynamic extent:"
-{ $subsections
+{ $subsections
-    throw
+    throw
-    rethrow
+    rethrow
-}
+}
-"Words for establishing an error handler:"
+"Words for establishing an error handler:"
-{ $subsections
+{ $subsections
-    cleanup
+    cleanup
-    recover
+    recover
-    ignore-errors
+    ignore-errors
-}
+}
-"Syntax sugar for defining errors:"
+"Syntax sugar for defining errors:"
-{ $subsections POSTPONE: ERROR: }
+{ $subsections POSTPONE: ERROR: }
-"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
+"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
-{ $subsections
+{ $subsections
-    "errors-restartable"
+    "errors-restartable"
-    "debugger"
+    "debugger"
-    "errors-post-mortem"
+    "errors-post-mortem"
-    "errors-anti-examples"
+    "errors-anti-examples"
-}
+}
-"When Factor encouters a critical error, it calls the following word:"
+"When Factor encouters a critical error, it calls the following word:"
-{ $subsections die } ;
+{ $subsections die } ;
-
+
-ARTICLE: "continuations.private" "Continuation implementation details"
+ARTICLE: "continuations.private" "Continuation implementation details"
-"A continuation is simply a tuple holding the contents of the five stacks:"
+"A continuation is simply a tuple holding the contents of the five stacks:"
-{ $subsections
+{ $subsections
-    continuation
+    continuation
-    >continuation<
+    >continuation<
-}
+}
-"The five stacks can be read and written:"
+"The five stacks can be read and written:"
-{ $subsections
+{ $subsections
-    datastack
+    datastack
-    set-datastack
+    set-datastack
-    retainstack
+    retainstack
-    set-retainstack
+    set-retainstack
-    callstack
+    callstack
-    set-callstack
+    set-callstack
-    namestack
+    namestack
-    set-namestack
+    set-namestack
-    catchstack
+    catchstack
-    set-catchstack
+    set-catchstack
-} ;
+} ;
-
+
-ARTICLE: "continuations" "Continuations"
+ARTICLE: "continuations" "Continuations"
-"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
+"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
-$nl
+$nl
-"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."
+"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."
-$nl
+$nl
-"Continuations can be reified with the following two words:"
+"Continuations can be reified with the following two words:"
-{ $subsections
+{ $subsections
-    callcc0
+    callcc0
-    callcc1
+    callcc1
-}
+}
-"Another two words resume continuations:"
+"Another two words resume continuations:"
-{ $subsections
+{ $subsections
-    continue
+    continue
-    continue-with
+    continue-with
-}
+}
-"Continuations as control-flow:"
+"Continuations as control-flow:"
-{ $subsections
+{ $subsections
-    attempt-all
+    attempt-all
-    with-return
+    with-return
-}
+}
-"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
-{ $subsections "continuations.private" } ;
+{ $subsections "continuations.private" } ;
-
+
-ABOUT: "continuations"
+ABOUT: "continuations"
-
+
-HELP: catchstack*
+HELP: catchstack*
-{ $values { "catchstack" "a vector of continuations" } }
+{ $values { "catchstack" "a vector of continuations" } }
-{ $description "Outputs the current catchstack." } ;
+{ $description "Outputs the current catchstack." } ;
-
+
-HELP: catchstack
+HELP: catchstack
-{ $values { "catchstack" "a vector of continuations" } }
+{ $values { "catchstack" "a vector of continuations" } }
-{ $description "Outputs a copy of the current catchstack." } ;
+{ $description "Outputs a copy of the current catchstack." } ;
-
+
-HELP: set-catchstack
+HELP: set-catchstack
-{ $values { "catchstack" "a vector of continuations" } }
+{ $values { "catchstack" "a vector of continuations" } }
-{ $description "Replaces the catchstack with a copy of the given vector." } ;
+{ $description "Replaces the catchstack with a copy of the given vector." } ;
-
+
-HELP: continuation
+HELP: continuation
-{ $values { "continuation" continuation } }
+{ $values { "continuation" continuation } }
-{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
+{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
-
+
-HELP: >continuation<
+HELP: >continuation<
-{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
+{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
-{ $description "Takes a continuation apart into its constituents." } ;
+{ $description "Takes a continuation apart into its constituents." } ;
-
+
-HELP: ifcc
+HELP: ifcc
-{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
+{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
-{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
+{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
-
+
-{ callcc0 continue callcc1 continue-with ifcc } related-words
+{ callcc0 continue callcc1 continue-with ifcc } related-words
-
+
-HELP: callcc0
+HELP: callcc0
-{ $values { "quot" { $quotation "( continuation -- )" } } }
+{ $values { "quot" { $quotation "( continuation -- )" } } }
-{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
+{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
-
+
-HELP: callcc1
+HELP: callcc1
-{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
+{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
-{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
+{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
-
+
-HELP: continue
+HELP: continue
-{ $values { "continuation" continuation } }
+{ $values { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
+{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
-
+
-HELP: continue-with
+HELP: continue-with
-{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
+{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;
+{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;
-
+
-HELP: error
+HELP: error
-{ $description "Global variable holding most recently thrown error." }
+{ $description "Global variable holding most recently thrown error." }
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
-
+
-HELP: error-continuation
+HELP: error-continuation
-{ $description "Global variable holding current continuation of most recently thrown error." }
+{ $description "Global variable holding current continuation of most recently thrown error." }
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
-
+
-HELP: restarts
+HELP: restarts
-{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }
+{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
-
+
-HELP: >c
+HELP: >c
-{ $values { "continuation" continuation } }
+{ $values { "continuation" continuation } }
-{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;
+{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;
-
+
-HELP: c>
+HELP: c>
-{ $values { "continuation" continuation } }
+{ $values { "continuation" continuation } }
-{ $description "Pops an exception handler continuation from the catch stack." } ;
+{ $description "Pops an exception handler continuation from the catch stack." } ;
-
+
-HELP: throw
+HELP: throw
-{ $values { "error" object } }
+{ $values { "error" object } }
-{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
+{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
-
+
-{ cleanup recover } related-words
+{ cleanup recover } related-words
-
+
-HELP: cleanup
+HELP: cleanup
-{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
+{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
-{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
+{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
-
+
-HELP: recover
+HELP: recover
-{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
+{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
-{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
+{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
-
+
-HELP: ignore-errors
+HELP: ignore-errors
-{ $values { "quot" quotation } }
+{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
+{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
-
+
-HELP: rethrow
+HELP: rethrow
-{ $values { "error" object } }
+{ $values { "error" object } }
-{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
+{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
-{ $notes
+{ $notes
-    "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
+    "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
-}
+}
-{ $examples
+{ $examples
-    "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
+    "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
-    { $see with-lexer }
+    { $see with-lexer }
-} ;
+} ;
-
+
-HELP: throw-restarts
+HELP: throw-restarts
-{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
+{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
-{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
+{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
-{ $examples
+{ $examples
-    "Try invoking one of the two restarts which are offered after the below code throws an error:"
+    "Try invoking one of the two restarts which are offered after the below code throws an error:"
-    { $code
+    { $code
-        ": restart-test"
+        ": restart-test"
-        "    \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"
+        "    \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"
-        "    \"You restarted: \" write . ;"
+        "    \"You restarted: \" write . ;"
-        "restart-test"
+        "restart-test"
-    }
+    }
-} ;
+} ;
-
+
-HELP: rethrow-restarts
+HELP: rethrow-restarts
-{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
+{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
-{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
+{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
-
+
-{ throw rethrow throw-restarts rethrow-restarts } related-words
+{ throw rethrow throw-restarts rethrow-restarts } related-words
-
+
-HELP: compute-restarts
+HELP: compute-restarts
-{ $values { "error" object } { "seq" "a sequence" } }
+{ $values { "error" object } { "seq" "a sequence" } }
-{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."
+{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."
-$nl
+$nl
-"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;
+"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;
-
+
-HELP: save-error
+HELP: save-error
-{ $values { "error" "an error" } }
+{ $values { "error" "an error" } }
-{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
+{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
-$low-level-note ;
+$low-level-note ;
-
+
-HELP: with-datastack
+HELP: with-datastack
-{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
+{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
-{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
+{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
-{ $examples
+{ $examples
-    { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
+    { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
-} ;
+} ;
-
+
-HELP: attempt-all
+HELP: attempt-all
-{ $values
+{ $values
-     { "seq" sequence } { "quot" quotation }
+     { "seq" sequence } { "quot" quotation }
-     { "obj" object } }
+     { "obj" object } }
-{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
+{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
-{ $examples "The first two numbers throw, the last one doesn't:"
+{ $examples "The first two numbers throw, the last one doesn't:"
-    { $example
+    { $example
-    "USING: prettyprint continuations kernel math ;"
+    "USING: prettyprint continuations kernel math ;"
-    "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
+    "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
-    "6" }
+    "6" }
-    "All quotations throw, the last exception is rethrown:"
+    "All quotations throw, the last exception is rethrown:"
-    { $example
+    { $example
-    "USING: prettyprint continuations kernel math ;"
+    "USING: prettyprint continuations kernel math ;"
-    "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
+    "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
-    "5"
+    "5"
-    }
+    }
-} ;
+} ;
-
+
-HELP: return
+HELP: return
-{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
+{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
-
+
-HELP: with-return
+HELP: with-return
-{ $values
+{ $values
-     { "quot" quotation } }
+     { "quot" quotation } }
-{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
+{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
-{ $examples
+{ $examples
-    "Only \"Hi\" will print:"
+    "Only \"Hi\" will print:"
-    { $example
+    { $example
-    "USING: prettyprint continuations io ;"
+    "USING: prettyprint continuations io ;"
-    "[ \"Hi\" print return \"Bye\" print ] with-return"
+    "[ \"Hi\" print return \"Bye\" print ] with-return"
-    "Hi"
+    "Hi"
-} } ;
+} } ;
-
+
-{ return with-return } related-words
+{ return with-return } related-words
-
+
-HELP: restart
+HELP: restart
-{ $values { "restart" restart } }
+{ $values { "restart" restart } }
-{ $description "Invokes a restart." }
+{ $description "Invokes a restart." }
-{ $class-description "The class of restarts." } ;
+{ $class-description "The class of restarts." } ;

core/continuations/continuations-tests.factor

@@ -1,108 +1,108 @@
-USING: kernel math namespaces io tools.test sequences vectors
+USING: kernel math namespaces io tools.test sequences vectors
-continuations debugger parser memory arrays words
+continuations debugger parser memory arrays words
-kernel.private accessors eval ;
+kernel.private accessors eval ;
-IN: continuations.tests
+IN: continuations.tests
-
+
-: (callcc1-test) ( n obj -- n' obj )
+: (callcc1-test) ( n obj -- n' obj )
-    [ 1 - dup ] dip ?push
+    [ 1 - dup ] dip ?push
-    over 0 = [ "test-cc" get continue-with ] when
+    over 0 = [ "test-cc" get continue-with ] when
-    (callcc1-test) ;
+    (callcc1-test) ;
-
+
-: callcc1-test ( x -- list )
+: callcc1-test ( x -- list )
-    [
+    [
-        "test-cc" set V{ } clone (callcc1-test)
+        "test-cc" set V{ } clone (callcc1-test)
-    ] callcc1 nip ;
+    ] callcc1 nip ;
-
+
-: callcc-namespace-test ( -- ? )
+: callcc-namespace-test ( -- ? )
-    [
+    [
-        "test-cc" set
+        "test-cc" set
-        5 "x" set
+        5 "x" set
-        [
+        [
-            6 "x" set "test-cc" get continue
+            6 "x" set "test-cc" get continue
-        ] with-scope
+        ] with-scope
-    ] callcc0 "x" get 5 = ;
+    ] callcc0 "x" get 5 = ;
-
+
-[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
+[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
-[ t ] [ callcc-namespace-test ] unit-test
+[ t ] [ callcc-namespace-test ] unit-test
-
+
-[ 5 throw ] [ 5 = ] must-fail-with
+[ 5 throw ] [ 5 = ] must-fail-with
-
+
-[ t ] [
+[ t ] [
-    [ "Hello" throw ] ignore-errors
+    [ "Hello" throw ] ignore-errors
-    error get-global
+    error get-global
-    "Hello" =
+    "Hello" =
-] unit-test
+] unit-test
-
+
-"!!! The following error is part of the test" print
+"!!! The following error is part of the test" print
-
+
-[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
+[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
-
+
-"!!! The following error is part of the test" print
+"!!! The following error is part of the test" print
-
+
-[ ] [ [ [ "2 car" ] eval ] try ] unit-test
+[ ] [ [ [ "2 car" ] eval ] try ] unit-test
-
+
-[ f throw ] must-fail
+[ f throw ] must-fail
-
+
-! Weird PowerPC bug.
+! Weird PowerPC bug.
-[ ] [
+[ ] [
-    [ "4" throw ] ignore-errors
+    [ "4" throw ] ignore-errors
-    gc
+    gc
-    gc
+    gc
-] unit-test
+] unit-test
-
+
-! ! See how well callstack overflow is handled
+! ! See how well callstack overflow is handled
-! [ clear drop ] must-fail
+! [ clear drop ] must-fail
-! 
+! 
-! : callstack-overflow callstack-overflow f ;
+! : callstack-overflow callstack-overflow f ;
-! [ callstack-overflow ] must-fail
+! [ callstack-overflow ] must-fail
-
+
-: don't-compile-me ( -- ) ;
+: don't-compile-me ( -- ) ;
-: foo ( -- ) callstack "c" set don't-compile-me ;
+: foo ( -- ) callstack "c" set don't-compile-me ;
-: bar ( -- a b ) 1 foo 2 ;
+: bar ( -- a b ) 1 foo 2 ;
-
+
-<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
+<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
-
+
-[ 1 2 ] [ bar ] unit-test
+[ 1 2 ] [ bar ] unit-test
-
+
-[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
-
+
-[ 1 ] [ "c" get innermost-frame-scan ] unit-test
+[ 1 ] [ "c" get innermost-frame-scan ] unit-test
-
+
-SYMBOL: always-counter
+SYMBOL: always-counter
-SYMBOL: error-counter
+SYMBOL: error-counter
-
+
-[
+[
-    0 always-counter set
+    0 always-counter set
-    0 error-counter set
+    0 error-counter set
-
+
-    [ ] [ always-counter inc ] [ error-counter inc ] cleanup
+    [ ] [ always-counter inc ] [ error-counter inc ] cleanup
-
+
-    [ 1 ] [ always-counter get ] unit-test
+    [ 1 ] [ always-counter get ] unit-test
-    [ 0 ] [ error-counter get ] unit-test
+    [ 0 ] [ error-counter get ] unit-test
-
+
-    [
+    [
-        [ "a" throw ]
+        [ "a" throw ]
-        [ always-counter inc ]
+        [ always-counter inc ]
-        [ error-counter inc ] cleanup
+        [ error-counter inc ] cleanup
-    ] [ "a" = ] must-fail-with
+    ] [ "a" = ] must-fail-with
-
+
-    [ 2 ] [ always-counter get ] unit-test
+    [ 2 ] [ always-counter get ] unit-test
-    [ 1 ] [ error-counter get ] unit-test
+    [ 1 ] [ error-counter get ] unit-test
-
+
-    [
+    [
-        [ ]
+        [ ]
-        [ always-counter inc "a" throw ]
+        [ always-counter inc "a" throw ]
-        [ error-counter inc ] cleanup
+        [ error-counter inc ] cleanup
-    ] [ "a" = ] must-fail-with
+    ] [ "a" = ] must-fail-with
-
+
-    [ 3 ] [ always-counter get ] unit-test
+    [ 3 ] [ always-counter get ] unit-test
-    [ 1 ] [ error-counter get ] unit-test
+    [ 1 ] [ error-counter get ] unit-test
-] with-scope
+] with-scope
-
+
-[ ] [ [ return ] with-return ] unit-test
+[ ] [ [ return ] with-return ] unit-test
-
+
-[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
+[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
-
+
-[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
+[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
-
+
-[ with-datastack ] must-infer
+[ with-datastack ] must-infer

core/generic/single/single-tests.factor

@@ -282,3 +282,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
 [ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
 [ error>> bad-dispatch-position? ]
 must-fail-with
+
+[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
+    [ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail

core/generic/single/single.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.algebra
 combinators definitions generic hashtables kernel
@@ -16,6 +16,8 @@ TUPLE: single-combination ;
 PREDICATE: single-generic < generic
     "combination" word-prop single-combination? ;
 
+M: single-generic make-inline cannot-be-inline ;
+
 GENERIC: dispatch# ( word -- n )
 
 M: generic dispatch# "combination" word-prop dispatch# ;

core/parser/parser.factor

@@ -111,11 +111,10 @@ SYMBOL: bootstrap-syntax
 
 : with-file-vocabs ( quot -- )
     [
-        <manifest> manifest set
         "syntax" use-vocab
         bootstrap-syntax get [ use-words ] when*
         call
-    ] with-scope ; inline
+    ] with-manifest ; inline
 
 SYMBOL: print-use-hook
 

core/source-files/source-files.factor

@@ -16,7 +16,8 @@ checksum
 definitions ;
 
 : record-top-level-form ( quot file -- )
-    (>>top-level-form) H{ } notify-definition-observers ;
+    (>>top-level-form)
+    [ ] [ H{ } notify-definition-observers ] if-bootstrapping ;
 
 : record-checksum ( lines source-file -- )
     [ crc32 checksum-lines ] dip (>>checksum) ;

core/vocabs/parser/parser-tests.factor

@@ -1,5 +1,6 @@
 IN: vocabs.parser.tests
-USING: vocabs.parser tools.test eval kernel accessors ;
+USING: vocabs.parser tools.test eval kernel accessors definitions
+compiler.units words vocabs ;
 
 [ "FROM: kernel => doesnotexist ;" eval( -- ) ]
 [ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
@@ -7,4 +8,44 @@ must-fail-with
 
 [ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
 [ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
-must-fail-with
+must-fail-with
+
+: aaa ( -- ) ;
+
+[
+    [ ] [ "aaa" "vocabs.parser.tests" "uutt" add-renamed-word ] unit-test
+
+    [ ] [ "vocabs.parser.tests" dup add-qualified ] unit-test
+
+    [ aaa ] [ "uutt" search ] unit-test
+    [ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+    [ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test
+
+    [ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
+
+    [ ] [ [ \ aaa forget ] with-compilation-unit ] unit-test
+
+    [ ] [ [ "bbb" "vocabs.parser.tests" lookup forget ] with-compilation-unit ] unit-test
+
+    [ f ] [ "uutt" search ] unit-test
+
+    [ f ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+    [ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
+
+    [ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test
+    
+    [ t ] [ "bbb" search >boolean ] unit-test
+
+    [ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
+    
+    [ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab? ] must-fail-with
+
+    [ begin-private ] [ error>> no-current-vocab? ] must-fail-with
+
+    [ end-private ] [ error>> no-current-vocab? ] must-fail-with
+
+    [ f ] [ "bbb" search >boolean ] unit-test
+    
+] with-manifest

core/vocabs/parser/parser.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel namespaces sequences
 sets strings vocabs sorting accessors arrays compiler.units
-combinators vectors splitting continuations math
+combinators vectors splitting continuations math words
 parser.notes ;
 IN: vocabs.parser
 
@@ -26,7 +26,6 @@ current-vocab
 { search-vocab-names hashtable }
 { search-vocabs vector }
 { qualified-vocabs vector }
-{ extra-words vector }
 { auto-used vector } ;
 
 : <manifest> ( -- manifest )
@@ -34,7 +33,6 @@ current-vocab
         H{ } clone >>search-vocab-names
         V{ } clone >>search-vocabs
         V{ } clone >>qualified-vocabs
-        V{ } clone >>extra-words
         V{ } clone >>auto-used ;
 
 M: manifest clone
@@ -42,7 +40,6 @@ M: manifest clone
         [ clone ] change-search-vocab-names
         [ clone ] change-search-vocabs
         [ clone ] change-qualified-vocabs
-        [ clone ] change-extra-words
         [ clone ] change-auto-used ;
 
 TUPLE: extra-words words ;
@@ -69,10 +66,16 @@ ERROR: no-word-in-vocab word vocab ;
 : (from) ( vocab words -- vocab words words' vocab )
     2dup swap load-vocab ;
 
-: extract-words ( seq vocab -- assoc' )
+: extract-words ( seq vocab -- assoc )
     [ words>> extract-keys dup ] [ name>> ] bi
     [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
 
+: excluding-words ( seq vocab -- assoc )
+    [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
+
+: qualified-words ( prefix vocab -- assoc )
+    words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
+
 : (lookup) ( name assoc -- word/f )
     at dup forward-reference? [ drop f ] when ;
 
@@ -83,8 +86,7 @@ PRIVATE>
 
 : set-current-vocab ( name -- )
     create-vocab
-    [ manifest get (>>current-vocab) ]
+    [ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ;
-    [ words>> <extra-words> (add-qualified) ] bi ;
 
 : with-current-vocab ( name quot -- )
     manifest get clone manifest [
@@ -102,11 +104,11 @@ TUPLE: no-current-vocab ;
     manifest get current-vocab>> [ no-current-vocab ] unless* ;
 
 : begin-private ( -- )
-    manifest get current-vocab>> vocab-name ".private" ?tail
+    current-vocab name>> ".private" ?tail
     [ drop ] [ ".private" append set-current-vocab ] if ;
 
 : end-private ( -- )
-    manifest get current-vocab>> vocab-name ".private" ?tail
+    current-vocab name>> ".private" ?tail
     [ set-current-vocab ] [ drop ] if ;
 
 : using-vocab? ( vocab -- ? )
@@ -137,10 +139,7 @@ TUPLE: no-current-vocab ;
 TUPLE: qualified vocab prefix words ;
 
 : <qualified> ( vocab prefix -- qualified )
-    2dup
+    (from) qualified-words qualified boa ;
-    [ load-vocab words>> ] [ CHAR: : suffix ] bi*
-    [ swap [ prepend ] dip ] curry assoc-map
-    qualified boa ;
 
 : add-qualified ( vocab prefix -- )
     <qualified> (add-qualified) ;
@@ -156,7 +155,7 @@ TUPLE: from vocab names words ;
 TUPLE: exclude vocab names words ;
 
 : <exclude> ( vocab words -- from )
-    (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
+    (from) excluding-words exclude boa ;
 
 : add-words-excluding ( vocab words -- )
     <exclude> (add-qualified) ;
@@ -207,3 +206,45 @@ PRIVATE>
 
 : search ( name -- word/f )
     manifest get search-manifest ;
+
+<PRIVATE
+
+GENERIC: update ( search-path-elt -- valid? )
+
+: trim-forgotten ( qualified-vocab -- valid? )
+    [ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
+    words>> assoc-empty? not ;
+
+M: from update trim-forgotten ;
+M: rename update trim-forgotten ;
+M: extra-words update trim-forgotten ;
+M: exclude update trim-forgotten ;
+
+M: qualified update
+    dup vocab>> vocab [
+        dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
+        >>words
+    ] [ drop f ] if ;
+
+M: vocab update dup name>> vocab eq? ;
+
+: update-manifest ( manifest -- )
+    [ dup [ name>> vocab ] when ] change-current-vocab
+    [ [ drop vocab ] assoc-filter ] change-search-vocab-names
+    dup search-vocab-names>> keys [ vocab ] V{ } map-as >>search-vocabs
+    qualified-vocabs>> [ update ] filter! drop ;
+
+M: manifest definitions-changed ( assoc manifest -- )
+    nip update-manifest ;
+
+PRIVATE>
+
+: with-manifest ( quot -- )
+    <manifest> manifest [
+        [ call ] [
+            [ manifest get add-definition-observer call ]
+            [ manifest get remove-definition-observer ]
+            [ ]
+            cleanup
+        ] if-bootstrapping
+    ] with-variable ; inline

core/words/words.factor

@@ -87,7 +87,11 @@ M: word subwords drop f ;
 : make-deprecated ( word -- )
     t "deprecated" set-word-prop ;
 
-: make-inline ( word -- )
+ERROR: cannot-be-inline word ;
+
+GENERIC: make-inline ( word -- )
+
+M: word make-inline
     dup inline? [ drop ] [
         [ t "inline" set-word-prop ]
         [ changed-effect ]
@@ -155,7 +159,12 @@ ERROR: bad-create name vocab ;
 
 : create ( name vocab -- word )
     check-create 2dup lookup
-    dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
+    dup [ 2nip ] [
+        drop
+        vocab-name <word>
+        dup reveal
+        dup changed-definition
+    ] if ;
 
 : constructor-word ( name vocab -- word )
     [ "<" ">" surround ] dip create ;

vm/objects.cpp

@@ -110,6 +110,31 @@ struct object_become_visitor {
 	}
 };
 
+struct code_block_become_visitor {
+	slot_visitor<slot_become_visitor> *workhorse;
+
+	explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+		workhorse(workhorse_) {}
+
+	void operator()(code_block *compiled, cell size)
+	{
+		workhorse->visit_code_block_objects(compiled);
+		workhorse->visit_embedded_literals(compiled);
+	}
+};
+
+struct code_block_write_barrier_visitor {
+	code_heap *code;
+
+	explicit code_block_write_barrier_visitor(code_heap *code_) :
+		code(code_) {}
+
+	void operator()(code_block *compiled, cell size)
+	{
+		code->write_barrier(compiled);
+	}
+};
+
 /* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
    to coalesce equal but distinct quotations and wrappers. */
 void factor_vm::primitive_become()
@@ -134,17 +159,26 @@ void factor_vm::primitive_become()
 	}
 
 	/* Update all references to old objects to point to new objects */
-	slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+	{
-	workhorse.visit_roots();
+		slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
-	workhorse.visit_contexts();
+		workhorse.visit_roots();
+		workhorse.visit_contexts();
 
-	object_become_visitor object_visitor(&workhorse);
+		object_become_visitor object_visitor(&workhorse);
-	each_object(object_visitor);
+		each_object(object_visitor);
+
+		code_block_become_visitor code_block_visitor(&workhorse);
+		each_code_block(code_block_visitor);
+	}
 
 	/* Since we may have introduced old->new references, need to revisit
-	all objects on a minor GC. */
+	all objects and code blocks on a minor GC. */
 	data->mark_all_cards();
-	primitive_minor_gc();
+
+	{
+		code_block_write_barrier_visitor code_block_visitor(code);
+		each_code_block(code_block_visitor);
+	}
 }
 
 }