diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 317dac803e..0369d55fb3 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -53,18 +53,11 @@ TUPLE: library path abi dll ; : library ( name -- library ) libraries get at ; -: ( path abi -- library ) f \ library construct-boa ; +: ( path abi -- library ) + over dup [ dlopen ] when \ library construct-boa ; : load-library ( name -- dll ) - library dup [ - dup library-dll [ ] [ - dup library-path dup [ - dlopen dup rot set-library-dll - ] [ - 2drop f - ] if - ] ?if - ] when ; + library library-dll ; : add-library ( name path abi -- ) swap libraries get set-at ; diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index c0c3733afa..876310cc5d 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -315,7 +315,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; data-gc ; [ "Hello world" ] [ - [ callback-4 callback_test_1 ] string-out + [ callback-4 callback_test_1 ] with-string-writer ] unit-test : callback-5 diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index f68bdcf0a2..3a41b80c2a 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -213,30 +213,37 @@ TUPLE: no-such-library name ; M: no-such-library summary drop "Library not found" ; +M: no-such-library compiler-error-type + drop +linkage+ ; + : no-such-library ( name -- ) - \ no-such-library +linkage+ (inference-error) ; + \ no-such-library construct-boa + compiling-word get compiler-error ; -: (alien-invoke-dlsym) ( node -- symbol dll ) - dup alien-invoke-function - swap alien-invoke-library [ - load-library - ] [ - 2drop no-such-library - ] recover ; - -TUPLE: no-such-symbol ; +TUPLE: no-such-symbol name ; M: no-such-symbol summary drop "Symbol not found" ; -: no-such-symbol ( -- ) - \ no-such-symbol +linkage+ (inference-error) ; +M: no-such-symbol compiler-error-type + drop +linkage+ ; -: alien-invoke-dlsym ( node -- symbol dll ) - dup (alien-invoke-dlsym) 2dup dlsym [ - >r over stdcall-mangle r> 2dup dlsym - [ no-such-symbol ] unless - ] unless rot drop ; +: no-such-symbol ( name -- ) + \ no-such-symbol construct-boa + compiling-word get compiler-error ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd [ dlsym ] curry contains? + [ drop ] [ no-such-symbol ] if + ] [ + dll-path no-such-library drop + ] if ; + +: alien-invoke-dlsym ( node -- symbols dll ) + dup alien-invoke-function dup pick stdcall-mangle 2array + swap alien-invoke-library library dup [ library-dll ] when + 2dup check-dlsym ; \ alien-invoke [ ! Four literals @@ -247,8 +254,6 @@ M: no-such-symbol summary pop-literal nip over set-alien-invoke-function pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-return - ! If symbol doesn't resolve, no stack effect, no compile - dup alien-invoke-dlsym 2drop ! Quotation which coerces parameters to required types dup make-prep-quot recursive-state get infer-quot ! Add node to IR diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 2eabe9b0bc..716ac64c9b 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" { $subsection diff } { $subsection remove-all } { $subsection substitute } +{ $subsection substitute-here } { $see-also key? } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" @@ -266,12 +267,16 @@ HELP: remove-all { $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } { $side-effects "assoc" } ; -HELP: substitute -{ $values { "assoc" assoc } { "seq" "a mutable sequence" } } -{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." } +HELP: substitute-here +{ $values { "seq" "a mutable sequence" } { "assoc" assoc } } +{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." } { $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." } { $side-effects "seq" } ; +HELP: substitute +{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } } +{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ; + HELP: cache { $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } { $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index d8cf01e1bd..ff0938e001 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : remove-all ( assoc seq -- subseq ) swap [ key? not ] curry subset ; -: substitute ( assoc seq -- ) - swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ; +: (substitute) + [ dupd at* [ nip ] [ drop ] if ] curry ; inline + +: substitute-here ( seq assoc -- ) + (substitute) change-each ; + +: substitute ( seq assoc -- newseq ) + (substitute) map ; : cache ( key assoc quot -- value ) 2over at [ diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 6d21504f8b..608b5cb581 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -78,7 +78,7 @@ nl [ compiled-usages recompile ] recompile-hook set-global ; : disable-compiler ( -- ) - [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ; + [ default-recompile-hook ] recompile-hook set-global ; enable-compiler diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7c12b3ea60..17b56458ce 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -416,7 +416,7 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - [ (write-image) ] with-stream ; + [ (write-image) ] with-file-writer ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 66ede8b054..97712972f3 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -98,7 +98,7 @@ H{ } clone update-map set [ over "type" word-prop dup \ tag-mask get < \ tag \ type ? , , \ eq? , - ] [ ] make define-predicate ; + ] [ ] make define-predicate* ; : register-builtin ( class -- ) dup "type" word-prop builtins get set-nth ; @@ -646,6 +646,7 @@ builtins get num-tags get tail f union-class define-class { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } + { "dll-valid?" "alien" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index cd99796e7e..3bc82bbe6a 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -59,7 +59,7 @@ SYMBOL: bootstrap-time default-image-name "output-image" set-global - "math help compiler tools ui ui.tools io" "include" set-global + "math help handbook compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 859b6a95d5..56dda6f904 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -119,7 +119,7 @@ HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; -HELP: define-predicate +HELP: define-predicate* { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } } { $description "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" @@ -132,6 +132,13 @@ HELP: define-predicate } $low-level-note ; +HELP: define-predicate +{ $values { "class" class } { "quot" "a quotation" } } +{ $description + "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "." +} +$low-level-note ; + HELP: superclass { $values { "class" class } { "super" class } } { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index c7024a7490..103c4eed09 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -63,7 +63,7 @@ UNION: bah fixnum alien ; ! Test generic see and parsing [ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] -[ [ \ bah see ] string-out ] unit-test +[ [ \ bah see ] with-string-writer ] unit-test ! Test redefinition of classes UNION: union-1 fixnum float ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 345676e106..70088f2b03 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -31,13 +31,16 @@ PREDICATE: class tuple-class PREDICATE: word predicate "predicating" word-prop >boolean ; -: define-predicate ( class predicate quot -- ) +: define-predicate* ( class predicate quot -- ) over [ dupd predicate-effect define-declared 2dup 1quotation "predicate" set-word-prop swap "predicating" set-word-prop - ] [ - 3drop + ] [ 3drop ] if ; + +: define-predicate ( class quot -- ) + over "forgotten" word-prop [ 2drop ] [ + >r dup predicate-word r> define-predicate* ] if ; : superclass ( class -- super ) diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor old mode 100644 new mode 100755 index a7270869c5..6d1c727ee2 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -16,7 +16,7 @@ PREDICATE: class predicate-class : define-predicate-class ( superclass class definition -- ) >r dup f roll predicate-class define-class r> dupd "predicate-definition" set-word-prop - dup predicate-word over predicate-quot define-predicate ; + dup predicate-quot define-predicate ; M: predicate-class reset-class { diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 332903d36b..dcc05e8160 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -31,9 +31,7 @@ PREDICATE: class union-class ] if ; : define-union-predicate ( class -- ) - dup predicate-word - over members union-predicate-quot - define-predicate ; + dup members union-predicate-quot define-predicate ; M: union-class update-predicate define-union-predicate ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f44e6c1387..f0caec7ad1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -24,7 +24,6 @@ IN: compiler : finish-compile ( word effect dependencies -- ) >r dupd save-effect r> - f pick compiler-error over compiled-unxref over crossref? [ compiled-xref ] [ 2drop ] if ; @@ -38,6 +37,7 @@ IN: compiler swap compiler-error ; : (compile) ( word -- ) + f over compiler-error [ dup compile-succeeded finish-compile ] [ dupd compile-failed f save-effect ] recover ; @@ -55,7 +55,9 @@ IN: compiler H{ } clone compiled set [ queue-compile ] each compile-queue get compile-loop - compiled get >alist modify-code-heap + compiled get >alist + dup [ drop crossref? ] assoc-contains? + modify-code-heap ] with-scope ; inline : compile ( words -- ) @@ -70,4 +72,4 @@ IN: compiler [ all-words recompile ] with-compiler-errors ; : decompile ( word -- ) - f 2array 1array modify-code-heap ; + f 2array 1array t modify-code-heap ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 242ed9854a..225e1c17c6 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -77,6 +77,11 @@ GENERIC: definitions-changed ( assoc obj -- ) [ ] cleanup ] with-scope ; inline +: default-recompile-hook + [ f ] { } map>assoc + dup [ drop crossref? ] assoc-contains? + modify-code-heap ; + recompile-hook global -[ [ [ f ] { } map>assoc modify-code-heap ] or ] +[ [ default-recompile-hook ] or ] change-at diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4bb10b23a2..cd6c8b61f7 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -128,7 +128,7 @@ HOOK: %prepare-var-args compiler-backend ( -- ) M: object %prepare-var-args ; -HOOK: %alien-invoke compiler-backend ( library function -- ) +HOOK: %alien-invoke compiler-backend ( function library -- ) HOOK: %cleanup compiler-backend ( alien-node -- ) diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor new file mode 100755 index 0000000000..31c3e8a762 --- /dev/null +++ b/core/debugger/debugger-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: debugger kernel continuations tools.test ; + +[ ] [ [ drop ] [ error. ] recover ] unit-test diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 53f3387d85..776e2976d9 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic hashtables inspector io kernel math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard ; +generic.standard vocabs ; IN: debugger GENERIC: error. ( error -- ) @@ -254,3 +254,6 @@ M: no-compilation-unit error. "Attempting to define " write no-compilation-unit-definition pprint " outside of a compilation unit" print ; + +M: no-vocab summary + drop "Vocabulary does not exist" ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 25e2f8222b..3ee93ba4a5 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -111,7 +111,8 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; : string>symbol ( str -- alien ) - wince? [ string>u16-alien ] [ string>char-alien ] if ; + [ wince? [ string>u16-alien ] [ string>char-alien ] if ] + over string? [ call ] [ map ] if ; : add-dlsym-literals ( symbol dll -- ) >r string>symbol r> 2array literal-table get push-all ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index e6a6226afa..3514947e3d 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -26,7 +26,7 @@ SYMBOL: compiling-word SYMBOL: compiling-label -SYMBOL: compiling-loop? +SYMBOL: compiling-loops ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start @@ -34,7 +34,7 @@ SYMBOL: current-label-start : compiled-stack-traces? ( -- ? ) 36 getenv ; : begin-compiling ( word label -- ) - compiling-loop? off + H{ } clone compiling-loops set compiling-label set compiling-word set compiled-stack-traces? @@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ; : generate-call ( label -- next ) dup maybe-compile end-basic-block - dup compiling-label get eq? compiling-loop? get and [ - drop current-label-start get %jump-label f + dup compiling-loops get at [ + %jump-label f ] [ tail-call? [ %jump f @@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ; %call iterate-next ] if - ] if ; + ] ?if ; ! #label M: #label generate-node @@ -113,17 +113,13 @@ M: #label generate-node r> ; ! #loop +: compiling-loop ( word -- ) +