From 93eb74476e776f044283ce61354852037a5c0cb1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 20:04:46 -0600 Subject: [PATCH 01/25] add with-file-in docs, update a couple of usages --- core/io/files/files-docs.factor | 15 +++++++++++++++ extra/tar/tar.factor | 5 ++--- extra/tools/browser/browser.factor | 4 ++-- 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 0b9a748eb8..99f2d42542 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,6 +52,21 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; +HELP: with-file-in +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file is unreadable." } ; + +HELP: with-file-out +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: with-file-appender +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 20e997185d..e15d9511a3 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind (parse-tar) - ] with-stream ; - + ] with-file-out ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..167c238069 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -10,7 +10,7 @@ IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ lines ] [ drop f ] if ; + [ file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; @@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ ?resource-path - [ [ print ] each ] with-stream + [ [ print ] each ] with-file-out ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" From 3eda26ca0b1b330842db444938640a6038876f6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Feb 2008 03:12:44 -0600 Subject: [PATCH 02/25] Fix unit tests --- extra/http/server/server-tests.factor | 7 ++----- extra/io/streams/null/null.factor | 2 +- extra/smtp/smtp-tests.factor | 26 +++++++------------------- 3 files changed, 10 insertions(+), 25 deletions(-) mode change 100644 => 100755 extra/http/server/server-tests.factor diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor old mode 100644 new mode 100755 index f72e12f927..18edd94f12 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,15 +1,12 @@ USING: webapps.file http.server.responders http -http.server namespaces io tools.test strings io.server ; +http.server namespaces io tools.test strings io.server +logging ; IN: temporary [ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test [ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test -[ ] [ - f [ "unit/test" log-responder ] with-logging -] unit-test - [ "index.html" ] [ "http://www.jedit.org/index.html" url>path ] unit-test diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index d747fa0a29..eee66239be 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -6,7 +6,7 @@ USING: kernel io io.timeouts continuations ; TUPLE: null-stream ; M: null-stream dispose drop ; -M: null-stream set-timeout drop ; +M: null-stream set-timeout 2drop ; M: null-stream stream-readln drop f ; M: null-stream stream-read1 drop f ; M: null-stream stream-read-until 2drop f f ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index eda8d7cc1f..aa3641417b 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,5 +1,5 @@ USING: smtp tools.test io.streams.string threads -smtp.server kernel sequences namespaces ; +smtp.server kernel sequences namespaces logging ; IN: temporary { 0 0 } [ [ ] with-smtp-connection ] must-infer-as @@ -15,34 +15,22 @@ IN: temporary { "hello" "world" } [ send-body ] string-out ] unit-test -[ - [ - "500 syntax error" check-response - ] with-log-stdio -] must-fail +[ "500 syntax error" check-response ] must-fail -[ ] [ - [ - "220 success" check-response - ] with-log-stdio -] unit-test +[ ] [ "220 success" check-response ] unit-test [ "220 success" ] [ "220 success" [ receive-response ] string-in ] unit-test [ "220 the end" ] [ - [ - "220-a multiline response\r\n250-another line\r\n220 the end" - [ receive-response ] string-in - ] with-log-stdio + "220-a multiline response\r\n250-another line\r\n220 the end" + [ receive-response ] string-in ] unit-test [ ] [ - [ - "220-a multiline response\r\n250-another line\r\n220 the end" - [ get-ok ] string-in - ] with-log-stdio + "220-a multiline response\r\n250-another line\r\n220 the end" + [ get-ok ] string-in ] unit-test [ From a228072862ef59f2c029544fd4de8ba466012162 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Feb 2008 20:32:10 -0600 Subject: [PATCH 03/25] Logging parser now parses the timestamps --- extra/logging/parser/parser.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index f9bf97a442..b4c7e12772 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -11,8 +11,10 @@ IN: logging.parser SYMBOL: multiline : 'date' - multiline-header token [ drop multiline ] <@ - [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|> + [ "]" member? not ] string-of [ + dup multiline-header = + [ drop multiline ] [ rfc3339>timestamp ] if + ] <@ "[" "]" surrounded-by ; : 'log-level' From a4e5bc11b5166b5259115437b19e71a666d31add Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Feb 2008 20:32:26 -0600 Subject: [PATCH 04/25] Editor gadget fix for CS+LEFT/RIGHT --- extra/ui/gadgets/editors/editors.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index a6674aef5f..507dc932a4 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -448,8 +448,8 @@ editor "selection" f { { T{ key-down f { S+ } "RIGHT" } select-next-character } { T{ key-down f { S+ } "UP" } select-previous-line } { T{ key-down f { S+ } "DOWN" } select-next-line } - { T{ key-down f { S+ C+ } "LEFT" } select-previous-line } - { T{ key-down f { S+ C+ } "RIGHT" } select-next-line } + { T{ key-down f { S+ C+ } "LEFT" } select-previous-word } + { T{ key-down f { S+ C+ } "RIGHT" } select-next-word } { T{ key-down f { S+ } "HOME" } select-start-of-line } { T{ key-down f { S+ } "END" } select-end-of-line } { T{ key-down f { S+ C+ } "HOME" } select-start-of-document } From 637600011ca60df31d1fefe47be9ee01ee452d09 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Feb 2008 20:32:48 -0600 Subject: [PATCH 05/25] FFI compile errors now reported separately; new kill literals phase design --- core/alien/compiler/compiler.factor | 19 ++++- core/compiler/errors/errors-docs.factor | 29 ++++---- core/compiler/errors/errors.factor | 69 +++++++++++------- core/inference/backend/backend.factor | 14 ++-- core/inference/class/class-tests.factor | 10 +++ core/inference/class/class.factor | 33 +++++---- core/inference/dataflow/dataflow.factor | 22 ++++++ core/optimizer/backend/backend.factor | 70 +++++++------------ core/optimizer/def-use/def-use.factor | 63 ++++++++++++++--- core/optimizer/known-words/known-words.factor | 2 +- core/optimizer/optimizer.factor | 5 +- 11 files changed, 213 insertions(+), 123 deletions(-) mode change 100644 => 100755 core/optimizer/def-use/def-use.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 51240a66d9..54348e47f9 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs -kernel.private threads continuations.private libc combinators ; +kernel.private threads continuations.private libc combinators +compiler.errors continuations ; IN: alien.compiler ! Common protocol for alien-invoke/alien-callback/alien-indirect @@ -207,9 +208,21 @@ M: alien-invoke-error summary swap alien-node-parameters parameter-sizes drop number>string 3append ; +TUPLE: no-such-library name ; + +M: no-such-library summary + drop "Library not found" ; + +: no-such-library ( name -- ) + \ no-such-library +linkage+ (inference-error) ; + : (alien-invoke-dlsym) ( node -- symbol dll ) dup alien-invoke-function - swap alien-invoke-library load-library ; + swap alien-invoke-library [ + load-library + ] [ + 2drop no-such-library + ] recover ; TUPLE: no-such-symbol ; @@ -217,7 +230,7 @@ M: no-such-symbol summary drop "Symbol not found" ; : no-such-symbol ( -- ) - \ no-such-symbol inference-error ; + \ no-such-symbol +linkage+ (inference-error) ; : alien-invoke-dlsym ( node -- symbol dll ) dup (alien-invoke-dlsym) 2dup dlsym [ diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 13fc0d3103..678face309 100755 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -1,14 +1,15 @@ IN: compiler.errors USING: help.markup help.syntax vocabs.loader words io -quotations ; +quotations compiler.errors.private ; ARTICLE: "compiler-errors" "Compiler warnings and errors" -"The compiler saves compile warnings and errors in a global variable:" +"The compiler saves various notifications in a global variable:" { $subsection compiler-errors } -"The warnings and errors can be viewed later:" -{ $subsection :warnings } +"These notifications can be viewed later:" { $subsection :errors } -"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:" +{ $subsection :warnings } +{ $subsection :linkage } +"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:" { $link with-compiler-errors } ; HELP: compiler-errors @@ -16,7 +17,7 @@ HELP: compiler-errors HELP: compiler-error { $values { "error" "an error" } { "word" word } } -{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ; +{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; HELP: compiler-error. { $values { "error" "an error" } { "word" word } } @@ -25,24 +26,18 @@ HELP: compiler-error. HELP: compiler-errors. { $values { "errors" "an assoc mapping words to errors" } } { $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ; - -HELP: (:errors) -{ $values { "seq" "an alist" } } -{ $description "Outputs all serious compiler errors from the most recent compile." } ; - HELP: :errors { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; -HELP: (:warnings) -{ $values { "seq" "an alist" } } -{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ; - HELP: :warnings { $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ; -{ :errors (:errors) :warnings (:warnings) } related-words +HELP: :linkage +{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ; + +{ :errors :warnings } related-words HELP: with-compiler-errors { $values { "quot" quotation } } -{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." } +{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } { $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 363c13c478..b7b599e5a9 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences sorting continuations debugger math math.parser ; IN: compiler.errors +SYMBOL: +error+ +SYMBOL: +warning+ +SYMBOL: +linkage+ + +GENERIC: compiler-error-type ( error -- ? ) + +M: object compiler-error-type drop +error+ ; + +alist sort-keys [ swap compiler-error. ] assoc-each ; - -GENERIC: compiler-warning? ( error -- ? ) - -M: object compiler-warning? drop f ; - -: (:errors) ( -- assoc ) +: errors-of-type ( type -- assoc ) compiler-errors get-global - [ nip compiler-warning? not ] assoc-subset ; + swap [ >r nip compiler-error-type r> eq? ] curry + assoc-subset ; -: :errors (:errors) compiler-errors. ; +: compiler-errors. ( type -- ) + errors-of-type >alist sort-keys + [ swap compiler-error. ] assoc-each ; -: (:warnings) ( -- seq ) - compiler-errors get-global - [ nip compiler-warning? ] assoc-subset ; - -: :warnings (:warnings) compiler-errors. ; - -: (compiler-report) ( what assoc -- ) - length dup zero? [ 2drop ] [ +: (compiler-report) ( what type word -- ) + over errors-of-type assoc-empty? [ 3drop ] [ [ - ":" % over % " - print " % # " compiler " % % "." % + ":" % + % + " - print " % + errors-of-type assoc-size # + " " % + % + "." % ] "" make print ] if ; : compiler-report ( -- ) - "errors" (:errors) (compiler-report) - "warnings" (:warnings) (compiler-report) ; + "semantic errors" +error+ "errors" (compiler-report) + "semantic warnings" +warning+ "warnings" (compiler-report) + "linkage errors" +linkage+ "linkage" (compiler-report) ; + +PRIVATE> + +: compiler-error ( error word -- ) + with-compiler-errors? get [ + compiler-errors get pick + [ set-at ] [ delete-at drop ] if + ] [ 2drop ] if ; + +: :errors +error+ compiler-errors. ; + +: :warnings +warning+ compiler-errors. ; + +: :linkage +linkage+ compiler-errors. ; : with-compiler-errors ( quot -- ) with-compiler-errors? get "quiet" get or [ call ] [ diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index ba65d2508c..cadf326692 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -24,24 +24,24 @@ IN: inference.backend : recursive-quotation? ( quot -- ? ) local-recursive-state [ first eq? ] with contains? ; -TUPLE: inference-error rstate major? ; +TUPLE: inference-error rstate type ; -M: inference-error compiler-warning? - inference-error-major? not ; +M: inference-error compiler-error-type + inference-error-type ; -: (inference-error) ( ... class important? -- * ) +: (inference-error) ( ... class type -- * ) >r construct-boa r> recursive-state get { set-delegate - set-inference-error-major? + set-inference-error-type set-inference-error-rstate } \ inference-error construct throw ; inline : inference-error ( ... class -- * ) - t (inference-error) ; inline + +error+ (inference-error) ; inline : inference-warning ( ... class -- * ) - f (inference-error) ; inline + +warning+ (inference-error) ; inline TUPLE: literal-expected ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 17cc3d3cf8..b77661b899 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -269,7 +269,17 @@ cell-bits 32 = [ \ number= inlined? ] unit-test +[ t ] [ + [ B{ 1 0 } *short 0 { number number } declare number= ] + \ number= inlined? +] unit-test + [ t ] [ [ B{ 1 0 } *short 0 = ] \ number= inlined? ] unit-test + +[ t ] [ + [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ] + \ number= inlined? +] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index f6d5a36d3d..3555725c1f 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -73,17 +73,27 @@ SYMBOL: value-intervals ! Current value --> class mapping SYMBOL: value-classes +: value-interval* ( value -- interval/f ) + value-intervals get at ; + : set-value-interval* ( interval value -- ) value-intervals get set-at ; +: intersect-value-interval ( interval value -- ) + [ value-interval* interval-intersect ] keep + set-value-interval* ; + M: interval-constraint apply-constraint dup interval-constraint-interval - swap interval-constraint-value set-value-interval* ; + swap interval-constraint-value intersect-value-interval ; : set-class-interval ( class value -- ) >r "interval" word-prop dup [ r> set-value-interval* ] [ r> 2drop ] if ; +: value-class* ( value -- class ) + value-classes get at object or ; + : set-value-class* ( class value -- ) over [ dup value-intervals get at [ @@ -93,9 +103,12 @@ M: interval-constraint apply-constraint ] when value-classes get set-at ; +: intersect-value-class ( class value -- ) + [ value-class* class-and ] keep set-value-class* ; + M: class-constraint apply-constraint dup class-constraint-class - swap class-constraint-value set-value-class* ; + swap class-constraint-value intersect-value-class ; : set-value-literal* ( literal value -- ) over class over set-value-class* @@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied? dup literal-constraint-value value-literal* [ swap literal-constraint-literal eql? ] [ 2drop f ] if ; -: value-class* ( value -- class ) - value-classes get at object or ; - M: class-constraint constraint-satisfied? dup class-constraint-value value-class* swap class-constraint-class class< ; -: value-interval* ( value -- interval/f ) - value-intervals get at ; - M: pair apply-constraint first2 2dup constraints get set-at constraint-satisfied? [ apply-constraint ] [ drop ] if ; @@ -159,13 +166,10 @@ M: pair constraint-satisfied? 2drop ; : intersect-classes ( classes values -- ) - [ [ value-class* class-and ] keep set-value-class* ] 2each ; + [ intersect-value-class ] 2each ; : intersect-intervals ( intervals values -- ) - [ - [ value-interval* interval-intersect ] keep - set-value-interval* - ] 2each ; + [ intersect-value-interval ] 2each ; : predicate-constraints ( class #call -- ) [ @@ -220,7 +224,8 @@ M: #dispatch child-constraints ] make-constraints ; M: #declare infer-classes-before - dup node-param swap node-in-d [ set-value-class* ] 2each ; + dup node-param swap node-in-d + [ intersect-value-class ] 2each ; DEFER: (infer-classes) diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 6a0be66bb1..71cb0eef65 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -256,6 +256,28 @@ SYMBOL: node-stack ] iterate-nodes drop ] with-node-iterator ; inline +: change-children ( node quot -- ) + over [ + >r dup node-children dup r> + [ map swap set-node-children ] curry + [ 2drop ] if + ] [ + 2drop + ] if ; inline + +: (transform-nodes) ( prev node quot -- ) + dup >r call dup [ + dup rot set-node-successor + dup node-successor r> (transform-nodes) + ] [ + r> drop f swap set-node-successor drop + ] if ; inline + +: transform-nodes ( node quot -- new-node ) + over [ + [ call dup dup node-successor ] keep (transform-nodes) + ] [ drop ] if ; inline + : node-literal? ( node value -- ? ) dup value? >r swap node-literals key? r> or ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 788f862849..c64d1fd010 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? ) DEFER: optimize-nodes : optimize-children ( node -- ) - [ - dup node-children dup [ - [ optimize-nodes ] map swap set-node-children - ] [ - 2drop - ] if - ] when* ; + [ optimize-nodes ] change-children ; : optimize-node ( node -- node ) dup [ @@ -76,39 +70,17 @@ DEFER: optimize-nodes M: f set-node-successor 2drop ; -: (optimize-nodes) ( prev node -- ) - optimize-node [ - dup rot set-node-successor - dup node-successor (optimize-nodes) - ] [ - f swap set-node-successor - ] if* ; - : optimize-nodes ( node -- newnode ) [ class-substitutions [ clone ] change literal-substitutions [ clone ] change - dup [ - optimize-node - dup dup node-successor (optimize-nodes) - ] when optimizer-changed get + [ optimize-node ] transform-nodes + optimizer-changed get ] with-scope optimizer-changed set ; -: prune-if ( node quot -- successor/t ) - over >r call [ r> node-successor t ] [ r> drop t f ] if ; - inline - ! Generic nodes M: node optimize-node* drop t f ; -M: #shuffle optimize-node* - [ - dup node-in-d empty? swap node-out-d empty? and - ] prune-if ; - -M: #push optimize-node* - [ node-out-d empty? ] prune-if ; - : cleanup-inlining ( node -- newnode changed? ) node-successor [ node-successor t ] [ t f ] if* ; @@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ; ! #values M: #values optimize-node* cleanup-inlining ; -! #>r -M: #>r optimize-node* [ node-in-d empty? ] prune-if ; - -! #r> -M: #r> optimize-node* [ node-in-r empty? ] prune-if ; - ! Some utilities for splicing in dataflow IR subtrees : follow ( key assoc -- value ) 2dup at* [ swap follow nip ] [ 2drop ] if ; @@ -194,10 +160,8 @@ M: node remember-method* ! Constant branch folding : fold-branch ( node branch# -- node ) - over drop-inputs >r over node-children nth - swap node-successor over substitute-node - r> [ set-node-successor ] keep ; + swap node-successor over substitute-node ; ! #if : known-boolean-value? ( node value -- value ? ) @@ -213,12 +177,18 @@ M: node remember-method* ] if ; M: #if optimize-node* - dup dup node-in-d first known-boolean-value? - [ 0 1 ? fold-branch t ] [ 2drop t f ] if ; + dup dup node-in-d first known-boolean-value? [ + over drop-inputs >r + 0 1 ? fold-branch + r> [ set-node-successor ] keep + t + ] [ 2drop t f ] if ; M: #dispatch optimize-node* dup dup node-in-d first 2dup node-literal? [ - node-literal fold-branch t + "Optimizing #dispatch" print + node-literal + over drop-inputs >r fold-branch r> [ set-node-successor ] keep t ] [ 3drop t f ] if ; @@ -322,9 +292,19 @@ DEFER: (flat-length) #! Make #shuffle -> #push -> #return -> successor dupd literal-quot splice-quot ; -: optimize-predicate ( #call -- node ) +: evaluate-predicate ( #call -- ? ) dup node-param "predicating" word-prop >r - dup node-class-first r> class< 1array inline-literals ; + node-class-first r> class< ; + +: optimize-predicate ( #call -- node ) + dup evaluate-predicate swap + dup node-successor #if? [ + dup drop-inputs >r + node-successor swap 0 1 ? fold-branch + r> [ set-node-successor ] keep + ] [ + swap 1array inline-literals + ] if ; : optimizer-hooks ( node -- conditions ) node-param "optimizer-hooks" word-prop ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor old mode 100644 new mode 100755 index 091f6524f0..9355b2bb70 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -70,19 +70,66 @@ M: #branch node-def-use #! #values node. dup branch-def-use (node-def-use) ; -: dead-literals ( -- values ) +! : dead-literals ( -- values ) +! def-use get [ >r value? r> empty? and ] assoc-subset ; +! +! : kill-node* ( node values -- ) +! [ swap remove-all ] curry modify-values ; +! +! : kill-node ( node values -- ) +! dup assoc-empty? +! [ 2drop ] [ [ kill-node* ] curry each-node ] if ; +! +! : kill-values ( node -- ) +! #! Remove literals which are not actually used anywhere. +! dead-literals kill-node ; + +: compute-dead-literals ( -- values ) def-use get [ >r value? r> empty? and ] assoc-subset ; -: kill-node* ( node values -- ) - [ swap remove-all ] curry modify-values ; +DEFER: kill-nodes +SYMBOL: dead-literals -: kill-node ( node values -- ) - dup assoc-empty? - [ 2drop ] [ [ kill-node* ] curry each-node ] if ; +GENERIC: kill-node* ( node -- node/t ) -: kill-values ( node -- ) +M: node kill-node* drop t ; + +: prune-if ( node quot -- successor/t ) + over >r call [ r> node-successor ] [ r> drop t ] if ; + inline + +M: #shuffle kill-node* + [ + dup node-in-d empty? swap node-out-d empty? and + ] prune-if ; + +M: #push kill-node* + [ node-out-d empty? ] prune-if ; + +M: #>r kill-node* [ node-in-d empty? ] prune-if ; + +M: #r> kill-node* [ node-in-r empty? ] prune-if ; + +: kill-node ( node -- node ) + dup [ + dup [ dead-literals get swap remove-all ] modify-values + dup kill-node* dup t eq? [ + drop dup [ kill-nodes ] change-children + ] [ + nip kill-node + ] if + ] when ; + +: kill-nodes ( node -- newnode ) + [ kill-node ] transform-nodes ; + +: kill-values ( node -- new-node ) #! Remove literals which are not actually used anywhere. - dead-literals kill-node ; + compute-dead-literals dup assoc-empty? [ drop ] [ + dead-literals [ kill-nodes ] with-variable + ] if ; + +! : sole-consumer ( #call -- node/f ) node-out-d first used-by diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 5820d8f5b2..43c0324611 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -98,7 +98,7 @@ float-arrays combinators.private combinators ; [ num-types get swap [ [ - [ type>class 0 `input class, ] keep + [ type>class object or 0 `input class, ] keep 0 `output literal, ] set-constraints ] curry each diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 219b27197f..1674ecd782 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -4,13 +4,16 @@ USING: kernel namespaces optimizer.backend optimizer.def-use optimizer.known-words optimizer.math inference.class ; IN: optimizer +SYMBOL: optimize-count + : optimize-1 ( node -- newnode ? ) [ + global [ optimize-count inc ] bind H{ } clone class-substitutions set H{ } clone literal-substitutions set H{ } clone value-substitutions set dup compute-def-use - dup kill-values + kill-values dup infer-classes optimizer-changed off optimize-nodes From 262e9d3443ec9a6f00c6d82f2fd24e5e131917ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Feb 2008 23:03:54 -0600 Subject: [PATCH 06/25] Clean up vocabs.loader and add littledan's unit test feature --- core/bootstrap/stage1.factor | 2 +- .../curry-tests.factor => curry.factor} | 0 core/compiler/test/curry/curry.factor | 0 .../float-tests.factor => float.factor} | 0 core/compiler/test/float/float.factor | 0 ...rinsics-tests.factor => intrinsics.factor} | 0 .../test/intrinsics/intrinsics.factor | 0 .../test/redefine/redefine-tests.factor | 287 ------------------ core/compiler/test/redefine/redefine.factor | 0 .../simple-tests.factor => simple.factor} | 0 core/compiler/test/simple/simple.factor | 0 ...-trace-tests.factor => stack-trace.factor} | 0 .../test/stack-trace/stack-trace.factor | 0 ...ly-tests.factor => templates-early.factor} | 0 .../templates-early/templates-early.factor | 0 ...emplates-tests.factor => templates.factor} | 0 core/compiler/test/templates/templates.factor | 0 .../tuples-tests.factor => tuples.factor} | 0 core/compiler/test/tuples/tuples.factor | 0 core/io/files/files.factor | 3 + core/optimizer/optimizer.factor | 3 - core/parser/parser.factor | 2 +- core/source-files/source-files.factor | 2 +- core/vocabs/loader/loader.factor | 116 ++++--- core/vocabs/vocabs.factor | 12 +- extra/furnace/furnace.factor | 2 +- extra/tools/browser/browser.factor | 17 +- extra/tools/test/test-docs.factor | 7 +- extra/tools/test/test.factor | 18 +- 29 files changed, 90 insertions(+), 381 deletions(-) rename core/compiler/test/{curry/curry-tests.factor => curry.factor} (100%) delete mode 100644 core/compiler/test/curry/curry.factor rename core/compiler/test/{float/float-tests.factor => float.factor} (100%) delete mode 100644 core/compiler/test/float/float.factor rename core/compiler/test/{intrinsics/intrinsics-tests.factor => intrinsics.factor} (100%) delete mode 100644 core/compiler/test/intrinsics/intrinsics.factor delete mode 100755 core/compiler/test/redefine/redefine-tests.factor delete mode 100644 core/compiler/test/redefine/redefine.factor rename core/compiler/test/{simple/simple-tests.factor => simple.factor} (100%) delete mode 100644 core/compiler/test/simple/simple.factor rename core/compiler/test/{stack-trace/stack-trace-tests.factor => stack-trace.factor} (100%) delete mode 100644 core/compiler/test/stack-trace/stack-trace.factor rename core/compiler/test/{templates-early/templates-early-tests.factor => templates-early.factor} (100%) delete mode 100644 core/compiler/test/templates-early/templates-early.factor rename core/compiler/test/{templates/templates-tests.factor => templates.factor} (100%) delete mode 100644 core/compiler/test/templates/templates.factor rename core/compiler/test/{tuples/tuples-tests.factor => tuples.factor} (100%) delete mode 100644 core/compiler/test/tuples/tuples.factor mode change 100644 => 100755 extra/furnace/furnace.factor diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index cc328e9760..4f5bf6d69e 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -38,7 +38,7 @@ vocabs.loader system ; [ "resource:core/bootstrap/stage2.factor" - dup ?resource-path exists? [ + dup resource-exists? [ run-file ] [ "Cannot find " write write "." print diff --git a/core/compiler/test/curry/curry-tests.factor b/core/compiler/test/curry.factor similarity index 100% rename from core/compiler/test/curry/curry-tests.factor rename to core/compiler/test/curry.factor diff --git a/core/compiler/test/curry/curry.factor b/core/compiler/test/curry/curry.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/float/float-tests.factor b/core/compiler/test/float.factor similarity index 100% rename from core/compiler/test/float/float-tests.factor rename to core/compiler/test/float.factor diff --git a/core/compiler/test/float/float.factor b/core/compiler/test/float/float.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/intrinsics/intrinsics-tests.factor b/core/compiler/test/intrinsics.factor similarity index 100% rename from core/compiler/test/intrinsics/intrinsics-tests.factor rename to core/compiler/test/intrinsics.factor diff --git a/core/compiler/test/intrinsics/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/redefine/redefine-tests.factor b/core/compiler/test/redefine/redefine-tests.factor deleted file mode 100755 index 9eaf2d1263..0000000000 --- a/core/compiler/test/redefine/redefine-tests.factor +++ /dev/null @@ -1,287 +0,0 @@ -USING: compiler definitions generic assocs inference math -namespaces parser tools.test words kernel sequences arrays io -effects tools.test compiler.units inference.state ; -IN: temporary - -DEFER: x-1 -DEFER: x-2 - -[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [ - "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval - "IN: temporary : x-2 3 x-1 ;" eval - - [ t ] [ - { x-2 } compile - - \ x-2 word-xt - - { x-1 } compile - - \ x-2 word-xt = - ] unit-test -] with-variable - -DEFER: b -DEFER: c - -[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test - -[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test - -{ 0 4 } [ b ] must-infer-as - -[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test - -[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test - -{ 0 6 } [ b ] must-infer-as - -\ b word-xt "b-xt" set - -[ ] [ "IN: temporary : c b ;" eval ] unit-test - -[ t ] [ "b-xt" get \ b word-xt = ] unit-test - -\ c word-xt "c-xt" set - -[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test - -[ t ] [ "c-xt" get \ c word-xt = ] unit-test - -[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test - -[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test - -{ 0 4 } [ c ] must-infer-as - -[ f ] [ "c-xt" get \ c word-xt = ] unit-test - -[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test - -[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test - -[ ] [ "IN: temporary : e d d ;" eval ] unit-test - -[ 3 3 ] [ "USE: temporary e" eval ] unit-test - -[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test - -[ 4 4 ] [ "USE: temporary e" eval ] unit-test - -DEFER: x-3 - -[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test - -DEFER: x-4 - -[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test - -[ t ] [ \ x-4 compiled? ] unit-test - -[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test - -[ f ] [ \ x-3 compiled? ] unit-test - -[ f ] [ \ x-4 compiled? ] unit-test - -[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test - -[ t ] [ \ x-3 compiled? ] unit-test - -[ t ] [ \ x-4 compiled? ] unit-test - -[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test - -DEFER: g-test-1 - -DEFER: g-test-3 - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test - -[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test - -[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test - -[ 25 ] [ 5 g-test-1 ] unit-test - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test - -[ 5 ] [ 5 g-test-1 ] unit-test - -[ t ] [ - \ g-test-3 word-xt - - "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval - - \ g-test-3 word-xt = -] unit-test - -DEFER: g-test-5 - -[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test - -[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test - -[ 6 ] [ g-test-5 ] unit-test - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test - -[ 13 ] [ g-test-5 ] unit-test - -DEFER: g-test-6 - -[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test - -DEFER: g-test-7 - -[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test - -[ 133 ] [ g-test-7 ] unit-test - -[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test - -[ 138 ] [ g-test-7 ] unit-test - -USE: macros - -DEFER: macro-test-3 - -[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test - -[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) >quotation ;" eval ] unit-test - -[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test - -[ 625 ] [ 5 macro-test-3 ] unit-test - -[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test - -[ 8 ] [ 5 macro-test-3 ] unit-test - -USE: hints - -DEFER: hints-test-2 - -[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test - -[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test - -[ 8 ] [ hints-test-2 ] unit-test - -[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test - -[ 10 ] [ hints-test-2 ] unit-test - -DEFER: inline-then-not-inline-test-1 -DEFER: inline-then-not-inline-test-2 - -[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test - -[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test - -[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test - -\ inline-then-not-inline-test-2 word-xt "a" set - -[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test - -[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test - -[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test - -DEFER: generic-then-not-generic-test-1 -DEFER: generic-then-not-generic-test-2 - -[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test - -[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test - -[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test - -[ 9 ] [ generic-then-not-generic-test-2 ] unit-test - -[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test - -[ 4 ] [ generic-then-not-generic-test-2 ] unit-test - -DEFER: foldable-test-1 -DEFER: foldable-test-2 - -[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test - -[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test - -[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test - -[ 3 ] [ foldable-test-2 ] unit-test - -[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test - -[ 4 ] [ foldable-test-2 ] unit-test - -DEFER: flushable-test-2 - -[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test - -[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test - -[ V{ } ] [ flushable-test-2 ] unit-test - -[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test - -[ V{ 3 } ] [ flushable-test-2 ] unit-test - -: ax ; -: bx ax ; -[ \ bx forget ] with-compilation-unit - -[ f ] [ \ bx \ ax compiled-usage key? ] unit-test - -DEFER: defer-redefine-test-2 - -[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test - -[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test - -[ defer-redefine-test-2 ] must-fail - -[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test - -[ 2 1 ] [ defer-redefine-test-2 ] unit-test - -! Cross-referencing issue -: compiled-xref-a ; - -: compiled-xref-c ; inline - -GENERIC: compiled-xref-b ( a -- b ) - -TUPLE: c-1 ; - -M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ; - -TUPLE: c-2 ; - -M: c-2 compiled-xref-b drop 3 ; - -[ t ] [ - \ compiled-xref-a compiled-crossref get key? -] unit-test - -[ ] [ - [ - \ compiled-xref-a forget - ] with-compilation-unit -] unit-test - -[ f ] [ - \ compiled-xref-a compiled-crossref get key? -] unit-test - -[ ] [ - "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval -] unit-test - -[ f ] [ - \ compiled-xref-a compiled-crossref get key? -] unit-test diff --git a/core/compiler/test/redefine/redefine.factor b/core/compiler/test/redefine/redefine.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple.factor similarity index 100% rename from core/compiler/test/simple/simple-tests.factor rename to core/compiler/test/simple.factor diff --git a/core/compiler/test/simple/simple.factor b/core/compiler/test/simple/simple.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/stack-trace/stack-trace-tests.factor b/core/compiler/test/stack-trace.factor similarity index 100% rename from core/compiler/test/stack-trace/stack-trace-tests.factor rename to core/compiler/test/stack-trace.factor diff --git a/core/compiler/test/stack-trace/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/templates-early/templates-early-tests.factor b/core/compiler/test/templates-early.factor similarity index 100% rename from core/compiler/test/templates-early/templates-early-tests.factor rename to core/compiler/test/templates-early.factor diff --git a/core/compiler/test/templates-early/templates-early.factor b/core/compiler/test/templates-early/templates-early.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/templates/templates-tests.factor b/core/compiler/test/templates.factor similarity index 100% rename from core/compiler/test/templates/templates-tests.factor rename to core/compiler/test/templates.factor diff --git a/core/compiler/test/templates/templates.factor b/core/compiler/test/templates/templates.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/compiler/test/tuples/tuples-tests.factor b/core/compiler/test/tuples.factor similarity index 100% rename from core/compiler/test/tuples/tuples-tests.factor rename to core/compiler/test/tuples.factor diff --git a/core/compiler/test/tuples/tuples.factor b/core/compiler/test/tuples/tuples.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 79b59cc364..aa9f8686ce 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -96,6 +96,9 @@ TUPLE: no-parent-directory path ; : ?resource-path ( path -- newpath ) "resource:" ?head [ resource-path ] when ; +: resource-exists? ( path -- ? ) + ?resource-path exists? ; + : make-directories ( path -- ) normalize-pathname right-trim-separators { { [ dup "." = ] [ ] } diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 1674ecd782..1debf6c8cc 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -4,11 +4,8 @@ USING: kernel namespaces optimizer.backend optimizer.def-use optimizer.known-words optimizer.math inference.class ; IN: optimizer -SYMBOL: optimize-count - : optimize-1 ( node -- newnode ? ) [ - global [ optimize-count inc ] bind H{ } clone class-substitutions set H{ } clone literal-substitutions set H{ } clone value-substitutions set diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 486c589134..7dee5e2212 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -479,7 +479,7 @@ SYMBOL: interactive-vocabs [ [ parse-file call ] keep ] assert-depth drop ; : ?run-file ( path -- ) - dup ?resource-path exists? [ run-file ] [ drop ] if ; + dup resource-exists? [ run-file ] [ drop ] if ; : bootstrap-file ( path -- ) [ parse-file % ] [ run-file ] if-bootstrapping ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 7ddf6f02c0..c7539ad3eb 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -26,7 +26,7 @@ uses definitions ; rot source-file-checksum (source-modified?) ] [ - ?resource-path exists? + resource-exists? ] ?if ; : record-modified ( source-file -- ) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index a1276341b3..ea3023a4f8 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger @@ -15,45 +15,59 @@ V{ "resource:work" } clone vocab-roots set-global -! No such thing as current directory on Windows CE -wince? [ "." vocab-roots get push ] unless +: vocab-dir ( vocab -- dir ) + vocab-name "." split "/" join ; : vocab-dir+ ( vocab str/f -- path ) >r vocab-name "." split r> [ >r dup peek r> append add ] when* "/" join ; -: vocab-dir ( vocab -- dir ) - f vocab-dir+ ; +: vocab-path+ ( vocab path -- newpath ) + swap vocab-root dup [ swap path+ ] [ 2drop f ] if ; -: vocab-source ( vocab -- path ) - ".factor" vocab-dir+ ; +: vocab-source-path ( vocab -- path/f ) + dup ".factor" vocab-dir+ vocab-path+ ; -: vocab-docs ( vocab -- path ) - "-docs.factor" vocab-dir+ ; +: vocab-docs-path ( vocab -- path/f ) + dup "-docs.factor" vocab-dir+ vocab-path+ ; -: vocab-tests ( vocab -- path ) - "-tests.factor" vocab-dir+ ; +: vocab-dir? ( root name -- ? ) + over [ + ".factor" vocab-dir+ path+ resource-exists? + ] [ + 2drop f + ] if ; : find-vocab-root ( vocab -- path/f ) - vocab-dir vocab-roots get - swap [ path+ ?resource-path exists? ] curry find nip ; + vocab-roots get swap [ vocab-dir? ] curry find nip ; M: string vocab-root dup vocab [ vocab-root ] [ find-vocab-root ] ?if ; M: vocab-link vocab-root - dup vocab-link-root [ ] [ vocab-link-name vocab-root ] ?if ; + vocab-link-root ; + +: vocab-tests ( vocab -- tests ) + dup vocab-root [ + [ + f >vocab-link dup + + dup "-tests.factor" vocab-dir+ vocab-path+ + dup resource-exists? [ , ] [ drop ] if + + dup vocab-dir "test" path+ vocab-path+ dup + ?resource-path directory keys [ ".factor" tail? ] subset + [ path+ , ] with each + ] { } make + ] [ drop f ] if ; : vocab-files ( vocab -- seq ) - [ - dup vocab-root dup [ - swap - 2dup vocab-source path+ , - 2dup vocab-docs path+ , - 2dup vocab-tests path+ , - ] when 2drop - ] { } make [ ?resource-path exists? ] subset ; + f >vocab-link [ + dup vocab-source-path [ , ] when* + dup vocab-docs-path [ , ] when* + vocab-tests % + ] { } make ; TUPLE: no-vocab name ; @@ -67,42 +81,36 @@ SYMBOL: load-help? : source-wasn't-loaded f swap set-vocab-source-loaded? ; -: load-source ( root name -- ) +: load-source ( vocab-link -- ) [ source-wasn't-loaded ] keep - [ vocab-source path+ bootstrap-file ] keep + [ vocab-source-path bootstrap-file ] keep source-was-loaded ; : docs-were-loaded t swap set-vocab-docs-loaded? ; : docs-weren't-loaded f swap set-vocab-docs-loaded? ; -: load-docs ( root name -- ) +: load-docs ( vocab-link -- ) load-help? get [ [ docs-weren't-loaded ] keep - [ vocab-docs path+ ?run-file ] keep + [ vocab-docs-path ?run-file ] keep docs-were-loaded - ] [ 2drop ] if ; + ] [ drop ] if ; -: amend-vocab-from-root ( root name -- vocab ) - dup vocab-source-loaded? [ 2dup load-source ] unless - dup vocab-docs-loaded? [ 2dup load-docs ] unless - nip vocab ; - -: load-vocab-from-root ( root name -- ) - 2dup vocab-source path+ ?resource-path exists? [ - 2dup create-vocab set-vocab-root - 2dup load-source load-docs - ] [ - nip no-vocab - ] if ; +: create-vocab-with-root ( vocab-link -- vocab ) + dup vocab-name create-vocab + swap vocab-root over set-vocab-root ; : reload ( name -- ) [ - dup find-vocab-root dup [ - swap load-vocab-from-root - ] [ - drop no-vocab - ] if + f >vocab-link + dup vocab-root [ + dup vocab-source-path resource-exists? [ + create-vocab-with-root + dup load-source + load-docs + ] [ no-vocab ] if + ] [ no-vocab ] if ] with-compiler-errors ; : require ( vocab -- ) @@ -122,18 +130,6 @@ SYMBOL: load-help? [ nip ] assoc-subset [ nip source-modified? ] assoc-subset keys ; inline -: vocab-path+ ( vocab path -- newpath ) - swap vocab-root dup [ swap path+ ] [ 2drop f ] if ; - -: vocab-source-path ( vocab -- path/f ) - dup vocab-source vocab-path+ ; - -: vocab-tests-path ( vocab -- path/f ) - dup vocab-tests vocab-path+ ; - -: vocab-docs-path ( vocab -- path/f ) - dup vocab-docs vocab-path+ ; - : modified-sources ( vocabs -- seq ) [ vocab-source-path ] modified ; @@ -151,7 +147,7 @@ SYMBOL: load-help? : vocab-heading. ( vocab -- ) nl "==== " write - dup vocab-name swap f >vocab-link write-object ":" print + dup vocab-name swap vocab write-object ":" print nl ; : load-error. ( triple -- ) @@ -187,8 +183,10 @@ SYMBOL: load-help? GENERIC: (load-vocab) ( name -- vocab ) M: vocab (load-vocab) - dup vocab-root - [ swap vocab-name amend-vocab-from-root ] when* ; + dup vocab-root [ + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless + ] when ; M: string (load-vocab) [ ".private" ?tail drop reload ] keep vocab ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 8db65e2eac..0717a6729c 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -96,8 +96,16 @@ M: vocab-link hashcode* M: vocab-link vocab-name vocab-link-name ; -: >vocab-link ( name root -- vocab ) - over vocab dup [ 2nip ] [ drop ] if ; +GENERIC# >vocab-link 1 ( name root -- vocab ) + +M: vocab >vocab-link drop ; + +M: vocab-link >vocab-link drop ; + +M: string >vocab-link + over vocab dup [ 2nip ] [ + drop [ dup vocab-root ] unless* + ] if ; UNION: vocab-spec vocab vocab-link ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor old mode 100644 new mode 100755 index 80419e9c8d..9b7a8a8aa5 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -189,7 +189,7 @@ SYMBOL: model swap [ render-template ] with-slots ; : browse-webapp-source ( vocab -- ) - vocab-link browser-link-href =href a> + "Browse source" write ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index ae1901ff66..b91a6177b8 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -72,13 +72,6 @@ M: vocab-link summary vocab-summary ; : set-vocab-authors ( authors vocab -- ) dup vocab-authors-path set-vocab-file-contents ; -: vocab-dir? ( root name -- ? ) - over [ - vocab-source path+ ?resource-path exists? - ] [ - 2drop f - ] if ; - : subdirs ( dir -- dirs ) directory [ second ] subset keys natural-sort ; @@ -96,10 +89,8 @@ M: vocab-link summary vocab-summary ; vocabs-in-dir ] with each ; -: sane-vocab-roots "." vocab-roots get remove ; - : all-vocabs ( -- assoc ) - sane-vocab-roots [ + vocab-roots get [ dup [ "" vocabs-in-dir ] { } make ] { } map>assoc ; @@ -153,9 +144,9 @@ MEMO: all-vocabs-seq ( -- seq ) [ vocab ] map ; : all-child-vocabs ( prefix -- assoc ) - sane-vocab-roots [ - dup pick dupd (all-child-vocabs) - [ swap >vocab-link ] with map + vocab-roots get [ + over dupd dupd (all-child-vocabs) + swap [ >vocab-link ] curry map ] { } map>assoc f rot unrooted-child-vocabs 2array add ; diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index b756f9279e..ac561100f8 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -36,7 +36,12 @@ ARTICLE: "tools.test" "Unit testing" $nl "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know." $nl -"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." +"Unit tests for a vocabulary are placed in test files in the same directory as the vocabulary source file (see " { $link "vocabs.loader" } "). Two possibilities are supported:" +{ $list + { "Tests can be placed in a file named " { $snippet { $emphasis "vocab" } "-tests.factor" } "." } + { "Tests can be placed in files in the " { $snippet "test" } " subdirectory." } +} +"The latter is used for vocabularies with more extensive test suites." $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." { $subsection "tools.test.write" } diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 5673e41c62..62a4dab1eb 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -53,18 +53,12 @@ SYMBOL: this-test : (run-test) ( vocab -- ) dup vocab-source-loaded? [ - vocab-tests-path dup [ - dup ?resource-path exists? [ - [ - "temporary" forget-vocab - ] with-compilation-unit - dup run-file - [ - dup forget-source - "temporary" forget-vocab - ] with-compilation-unit - ] when - ] when + [ "temporary" forget-vocab ] with-compilation-unit + vocab-tests dup [ run-file ] each + [ + dup [ forget-source ] each + "temporary" forget-vocab + ] with-compilation-unit ] when drop ; : run-test ( vocab -- failures ) From b6cc47d2b3a64c84dc7afd2e9918ecb1088812a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 Feb 2008 23:07:40 -0600 Subject: [PATCH 07/25] slight speedup in base64 --- extra/base64/base64-tests.factor | 2 +- extra/base64/base64.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index 23ea6e99ab..d867351f8b 100644 --- a/extra/base64/base64-tests.factor +++ b/extra/base64/base64-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test base64 ; +USING: kernel tools.test base64 strings ; [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> ] unit-test diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 2c393c61e2..074640c536 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -35,13 +35,13 @@ PRIVATE> #! pad string with = when not enough bits dup length dup 3 mod - cut swap [ - 3 group [ encode3 % ] each + 3 [ encode3 % ] each dup empty? [ drop ] [ >base64-rem % ] if ] "" make ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 [ - [ 4 group [ decode4 % ] each ] keep [ CHAR: = = not ] count-end + [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end ] SBUF" " make swap [ dup pop* ] times >string ; From 577e18b854c88a9f542fe75132344338f0bcc22d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 Feb 2008 23:09:13 -0600 Subject: [PATCH 08/25] 30% speedup of md5 by moving group -> --- extra/crypto/md5/md5.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index c95b3f4477..fe215e32db 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -153,7 +153,7 @@ SYMBOL: old-d dup S44 64 9 [ I ] BCDA ; : (process-md5-block) ( block -- ) - 4 group [ le> ] map + 4 [ le> ] map (process-md5-block-F) (process-md5-block-G) From afa71627ee8d38f1c6bb8714e7df01b43109ce24 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 Feb 2008 23:11:16 -0600 Subject: [PATCH 09/25] add db.types, db.tuples and some code in progress create-sql works for a limited test case in sqlite --- extra/db/db.factor | 25 +++++- extra/db/mysql/mysql.factor | 1 - extra/db/sqlite/ffi/ffi.factor | 4 + extra/db/sqlite/lib/lib.factor | 3 - extra/db/sqlite/sqlite.factor | 113 +++++++++++++++++++++++++-- extra/db/tuples/tuples-tests.factor | 37 +++++++++ extra/db/tuples/tuples.factor | 116 ++++++++++++++++++++++++++++ extra/db/types/types.factor | 70 +++++++++++++++++ 8 files changed, 356 insertions(+), 13 deletions(-) create mode 100644 extra/db/tuples/tuples-tests.factor create mode 100644 extra/db/tuples/tuples.factor create mode 100644 extra/db/types/types.factor diff --git a/extra/db/db.factor b/extra/db/db.factor index 1c287cd871..effb971e9f 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib tuples words ; IN: db -TUPLE: db handle ; -C: db ( handle -- obj ) +TUPLE: db handle insert-statements update-statements delete-statements select-statements ; +: ( handle -- obj ) + H{ } clone + H{ } clone + H{ } clone + H{ } clone + db construct-boa ; -! HOOK: db-create db ( str -- ) -! HOOK: db-drop db ( str -- ) GENERIC: db-open ( db -- ) +HOOK: db-close db ( handle -- ) + +: dispose-statements [ dispose drop ] assoc-each ; + +: dispose-db ( db -- ) + dup db [ + dup db-insert-statements dispose-statements + dup db-update-statements dispose-statements + dup db-delete-statements dispose-statements + dup db-select-statements dispose-statements + db-handle db-close + ] with-variable ; TUPLE: statement sql params handle bound? ; @@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ? ) +HOOK: last-id db ( -- id ) + : init-result-set ( result-set -- ) dup #rows over set-result-set-max -1 swap set-result-set-n ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index 941c25e1fa..040b87c977 100644 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- ) M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; - M: mysql-db ( str -- statement ) ; diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 609c597b35..47f42b7e0d 100644 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -106,6 +106,8 @@ IN: db.sqlite.ffi TYPEDEF: void sqlite3 TYPEDEF: void sqlite3_stmt +TYPEDEF: longlong sqlite3_int64 +TYPEDEF: ulonglong sqlite3_uint64 LIBRARY: sqlite FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; @@ -116,7 +118,9 @@ FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; +FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; +FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e5f8425d92..944fc14eef 100644 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -21,9 +21,6 @@ TUPLE: sqlite-error n message ; : sqlite-close ( db -- ) sqlite3_close sqlite-check-result ; -: sqlite-last-insert-rowid ( db -- rowid ) - sqlite3_last_insert_rowid ; - : sqlite-prepare ( db sql -- statement ) #! TODO: Support multiple statements in the SQL string. dup length "void*" "void*" diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 73b93d404b..0f4529763a 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -3,7 +3,8 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types -continuations db.sqlite.lib db.sqlite.ffi ; +continuations db.sqlite.lib db.sqlite.ffi db.tuples +words combinators.lib db.types ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -13,10 +14,10 @@ M: sqlite-db db-open ( db -- ) dup sqlite-db-path sqlite-open swap set-delegate ; -M: sqlite-db dispose ( obj -- ) - dup db-handle sqlite-close - f over set-db-handle - f swap set-delegate ; +M: sqlite-db db-close ( handle -- ) + sqlite-close ; + +M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) >r r> with-db ; inline @@ -72,3 +73,105 @@ M: sqlite-db commit-transaction ( -- ) M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; + +M: sqlite-db create-sql ( columns table -- sql ) + [ + "create table " % % + " (" % [ ", " % ] [ + dup second % " " % + dup third >sql-type % " " % + sql-modifiers " " join % + ] interleave ")" % + ] "" make ; + +M: sqlite-db insert-sql* ( columns table -- sql ) + [ + "insert into " % + % + "(" % + dup [ ", " % ] [ second % ] interleave + ") " % + " values (" % + [ ", " % ] [ ":" % second % ] interleave + ")" % + ] "" make ; + +M: sqlite-db update-sql* ( columns table -- sql ) + [ + "update " % + % + " set " % + dup remove-id + [ ", " % ] [ second dup % " = :" % % ] interleave + " where " % + [ primary-key? ] find nip second dup % " = :" % % + ] "" make ; + +M: sqlite-db delete-sql* ( columns table -- sql ) + [ + break + "delete from " % + % + " where " % + first second dup % " = :" % % + ] "" make dup . ; + +M: sqlite-db select-sql* ( columns table -- sql ) + [ + "select ROWID, " % + swap [ ", " % ] [ second % ] interleave + " from " % + % + " where ROWID = :ID" % + ] "" make ; + +M: sqlite-db tuple>params ( columns tuple -- obj ) + [ + >r [ second ":" swap append ] keep first r> get-slot-named + number>string* + ] curry { } map>assoc ; + +M: sqlite-db last-id ( -- id ) + db get db-handle sqlite3_last_insert_rowid ; + + +: sqlite-db-modifiers ( -- hashtable ) + H{ + { +native-id+ "primary key" } + { +assigned-id+ "primary key" } + { +autoincrement+ "autoincrement" } + { +unique+ "unique" } + { +default+ "default" } + { +null+ "null" } + { +not-null+ "not null" } + } ; + +M: sqlite-db sql-modifiers* ( modifiers -- str ) + sqlite-db-modifiers swap [ + dup array? [ + first2 + >r swap at r> number>string* + " " swap 3append + ] [ + swap at + ] if + ] with map [ ] subset ; + +: sqlite-type-hash ( -- assoc ) + H{ + { INTEGER "integer" } + { TEXT "text" } + { VARCHAR "text" } + } ; + +M: sqlite-db >sql-type ( obj -- str ) + dup pair? [ + first >sql-type + ] [ + sqlite-type-hash at* [ T{ no-sql-type } throw ] unless + ] if ; + +! HOOK: get-column-value ( n result-set type -- ) +! M: sqlite get-column-value { { "TEXT" get-text-column } { +! "INTEGER" get-integer-column } ... } case ; + diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor new file mode 100644 index 0000000000..7fc6fd3b97 --- /dev/null +++ b/extra/db/tuples/tuples-tests.factor @@ -0,0 +1,37 @@ +USING: io.files kernel tools.test db db.sqlite db.tuples ; +IN: temporary + +TUPLE: person the-id the-name the-number ; +: ( name age -- person ) + { set-person-the-name set-person-the-number } person construct ; + +person "PERSON" +{ + { "the-id" "ROWID" INTEGER +native-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } +} define-persistent + + +: test-tuples ( -- ) + f "billy" 100 person construct-boa dup insert-tuple + + [ 1 ] [ dup person-id ] unit-test + + 200 over set-person-the-number + + [ ] [ dup update-tuple ] unit-test + + [ ] [ delete-tuple ] unit-test ; + +: test-sqlite ( -- ) + "tuples-test.db" resource-path [ + test-tuples + ] with-db ; + +test-sqlite + +! : test-postgres ( -- ) + ! resource-path [ + ! test-tuples + ! ] with-db ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor new file mode 100644 index 0000000000..c08f359d5e --- /dev/null +++ b/extra/db/tuples/tuples.factor @@ -0,0 +1,116 @@ +USING: arrays assocs classes db kernel namespaces +tuples words sequences slots slots.private math +math.parser io prettyprint db.types ; +USE: continuations +IN: db.tuples + +! only take a tuple if you have to extract things from it +! otherwise take a class +! primary-key vs primary-key-spec +! define-persistent should enforce a primary key +! in sqlite, defining a new primary key makes it an alias for rowid, _rowid_, and oid +! -sql outputs sql code +! table - string +! columns - seq of column specifiers + +: db-columns ( class -- obj ) + "db-columns" word-prop ; + +: db-table ( class -- obj ) + "db-table" word-prop ; + + +: slot-spec-named ( str class -- slot-spec ) + "slots" word-prop [ slot-spec-name = ] with find nip ; + +: offset-of-slot ( str obj -- n ) + class slot-spec-named slot-spec-offset ; + +: get-slot-named ( str obj -- value ) + tuck offset-of-slot slot ; + +: set-slot-named ( value str obj -- ) + tuck offset-of-slot set-slot ; + + +: primary-key-spec ( class -- spec ) + db-columns [ primary-key? ] find nip ; + +: primary-key ( tuple -- obj ) + dup class primary-key-spec get-slot-named ; + +: set-primary-key ( obj tuple -- ) + [ class primary-key-spec first ] keep + set-slot-named ; + + +: cache-statement ( columns class assoc quot -- statement ) + [ db-table dupd ] swap + [ ] 3compose cache nip ; inline + +HOOK: create-sql db ( columns table -- sql ) +HOOK: drop-sql db ( columns table -- sql ) +HOOK: insert-sql* db ( columns table -- sql ) +HOOK: update-sql* db ( columns table -- sql ) +HOOK: delete-sql* db ( columns table -- sql ) +HOOK: select-sql* db ( columns table -- sql ) + +: insert-sql ( columns class -- statement ) + db get db-insert-statements [ insert-sql* ] cache-statement ; + +: update-sql ( columns class -- statement ) + db get db-update-statements [ update-sql* ] cache-statement ; + +: delete-sql ( columns class -- statement ) + db get db-delete-statements [ delete-sql* ] cache-statement ; + +: select-sql ( columns class -- statement ) + db get db-select-statements [ select-sql* ] cache-statement ; + +HOOK: tuple>params db ( columns tuple -- obj ) + +: tuple-statement ( columns tuple quot -- statement ) + >r [ tuple>params ] 2keep class r> call + [ bind-statement ] keep ; + +: do-tuple-statement ( tuple columns-quot statement-quot -- ) + >r [ class db-columns ] swap compose keep + r> tuple-statement dup . execute-statement ; + +: create-table ( class -- ) + dup db-columns swap db-table create-sql sql-command ; + +: insert-tuple ( tuple -- ) + [ + [ maybe-remove-id ] [ insert-sql ] do-tuple-statement + last-id + ] keep set-primary-key ; + +: update-tuple ( tuple -- ) + [ ] [ update-sql ] do-tuple-statement ; + +: delete-tuple ( tuple -- ) + [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ; + +! : select-tuple ( tuple -- ) + ! [ select-sql ] bind-tuple do-query ; + +: persist ( tuple -- ) + dup primary-key [ update-tuple ] [ insert-tuple ] if ; + +! PERSISTENT: + +: define-persistent ( class table columns -- ) + >r dupd "db-table" set-word-prop r> + "db-columns" set-word-prop ; + +: define-relation ( spec -- ) + drop ; + + + + + + + + diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor new file mode 100644 index 0000000000..b4785b7aa1 --- /dev/null +++ b/extra/db/types/types.factor @@ -0,0 +1,70 @@ +USING: arrays assocs db kernel math math.parser +sequences continuations ; +IN: db.types + + +! id serial not null primary key, +! ID is the Primary key +SYMBOL: +native-id+ +SYMBOL: +assigned-id+ + +: primary-key? ( spec -- ? ) + [ { +native-id+ +assigned-id+ } member? ] contains? ; + +! Same concept, SQLite has autoincrement, PostgreSQL has serial +SYMBOL: +autoincrement+ +SYMBOL: +serial+ +SYMBOL: +unique+ + +SYMBOL: +default+ +SYMBOL: +null+ +SYMBOL: +not-null+ +SYMBOL: +has-many+ + +! SQLite Types +! http://www.sqlite.org/datatype3.html +! SYMBOL: NULL +! SYMBOL: INTEGER +! SYMBOL: REAL +! SYMBOL: TEXT +! SYMBOL: BLOB + +SYMBOL: INTEGER +SYMBOL: DOUBLE +SYMBOL: BOOLEAN + +SYMBOL: TEXT +SYMBOL: VARCHAR + +SYMBOL: TIMESTAMP +SYMBOL: DATE + +SYMBOL: BIG_INTEGER + +! SYMBOL: LOCALE +! SYMBOL: TIMEZONE +! SYMBOL: CURRENCY + + +! PostgreSQL Types +! http://developer.postgresql.org/pgdocs/postgres/datatype.html + + +: number>string* ( num/str -- str ) + dup number? [ number>string ] when ; + +TUPLE: no-sql-type ; +HOOK: sql-modifiers* db ( modifiers -- str ) +HOOK: >sql-type db ( obj -- str ) + + + + +: maybe-remove-id ( columns -- obj ) + [ +native-id+ swap member? not ] subset ; + +: remove-id ( columns -- obj ) + [ primary-key? not ] subset ; + +: sql-modifiers ( spec -- seq ) + 3 tail sql-modifiers* ; From a423ca63f44e9f8c17e08b6e1b9250fc343e55d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 00:14:40 -0600 Subject: [PATCH 10/25] Tiny cleanup of combinators.lib and sequences.lib --- extra/combinators/lib/lib.factor | 114 +++++++++---------------------- extra/sequences/lib/lib.factor | 47 +++++++++++-- 2 files changed, 73 insertions(+), 88 deletions(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 9f0f7df1ce..9ccada1ec1 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman, ! Eduardo Cavazos, Daniel Ehrenberg. -! ! See http://factorcode.org/license.txt for BSD license. - -USING: kernel combinators namespaces quotations hashtables sequences assocs - arrays inference effects math math.ranges arrays.lib shuffle macros - bake combinators.cleave ; +USING: kernel combinators namespaces quotations hashtables +sequences assocs arrays inference effects math math.ranges +arrays.lib shuffle macros bake combinators.cleave ; IN: combinators.lib @@ -51,22 +49,6 @@ MACRO: napply ( n -- ) : dipd ( x y quot -- y ) 2 ndip ; inline -! each-with - -: each-withn ( seq quot n -- ) nwith each ; inline - -: each-with ( seq quot -- ) with each ; inline - -: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline - -! map-with - -: map-withn ( seq quot n -- newseq ) nwith map ; inline - -: map-with ( seq quot -- ) with map ; inline - -: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline - : 2with ( param1 param2 obj quot -- obj curry ) with with ; inline @@ -88,39 +70,23 @@ MACRO: napply ( n -- ) : assoc-map-with ( obj assoc quot -- assoc ) with* assoc-map ; inline - -MACRO: nfirst ( n -- ) - [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline - -: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! short circuiting words ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : short-circuit ( quots quot default -- quot ) -! >r { } map>assoc r> -! 1quotation swap alist>quot ; - : short-circuit ( quots quot default -- quot ) 1quotation -rot { } map>assoc alist>quot ; -! : short-circuit ( quots quot default -- quot ) -! 1quotation -rot map>alist alist>quot ; - -MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ; +MACRO: && ( quots -- ? ) + [ [ not ] append [ f ] ] t short-circuit ; MACRO: <-&& ( quots -- ) - [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit - [ nip ] append ; + [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit + [ nip ] append ; MACRO: <--&& ( quots -- ) - [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit - [ 2nip ] append ; + [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit + [ 2nip ] append ; MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; @@ -129,25 +95,25 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MACRO: ifte ( quot quot quot -- ) - pick infer effect-in - dup 1+ swap - [ >r >r , nkeep , nrot r> r> if ] - bake ; + pick infer effect-in + dup 1+ swap + [ >r >r , nkeep , nrot r> r> if ] + bake ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! switch ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : preserving ( predicate -- quot ) - dup infer effect-in - dup 1+ spin - [ , , nkeep , nrot ] - bake ; + dup infer effect-in + dup 1+ spin + [ , , nkeep , nrot ] + bake ; MACRO: switch ( quot -- ) - [ [ preserving ] [ ] bi* ] assoc-map - [ , cond ] - bake ; + [ [ preserving ] [ ] bi* ] assoc-map + [ , cond ] + bake ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,41 +122,34 @@ MACRO: switch ( quot -- ) ! : pcall ( seq quots -- seq ) [ call ] 2map ; MACRO: parallel-call ( quots -- ) - [ [ unclip % r> dup >r push ] bake ] map concat - [ V{ } clone >r % drop r> >array ] bake ; - -! MACRO: parallel-call ( quots -- ) -! [ [ unclip ] swap append ] map -! [ [ r> swap add >r ] append ] map -! concat -! [ { } >r ] swap append ! pre -! [ drop r> ] append ; ! post - + [ [ unclip % r> dup >r push ] bake ] map concat + [ V{ } clone >r % drop r> >array ] bake ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! map-call and friends ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : (make-call-with) ( quots -- quot ) - [ [ keep ] curry ] map concat [ drop ] append ; + [ [ keep ] curry ] map concat [ drop ] append ; MACRO: call-with ( quots -- ) - (make-call-with) ; + (make-call-with) ; MACRO: map-call-with ( quots -- ) - [ (make-call-with) ] keep length [ narray ] curry compose ; + [ (make-call-with) ] keep length [ narray ] curry compose ; : (make-call-with2) ( quots -- quot ) - [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat - [ 2drop ] append ; + [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat + [ 2drop ] append ; MACRO: call-with2 ( quots -- ) - (make-call-with2) ; + (make-call-with2) ; MACRO: map-call-with2 ( quots -- ) - dup >r (make-call-with2) r> length [ narray ] curry append ; + [ (make-call-with2) ] keep length [ narray ] curry append ; -MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ; +MACRO: map-exec-with ( words -- ) + [ 1quotation ] map [ map-call-with ] curry ; MACRO: construct-slots ( assoc tuple-class -- tuple ) [ construct-empty ] curry swap [ @@ -208,14 +167,3 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) : and? ( obj quot1 quot2 -- ? ) >r keep r> rot [ call ] [ 2drop f ] if ; inline - -: prepare-index ( seq quot -- seq n quot ) - >r dup length r> ; inline - -: each-index ( seq quot -- ) - #! quot: ( elt index -- ) - prepare-index 2each ; inline - -: map-index ( seq quot -- ) - #! quot: ( elt index -- obj ) - prepare-index 2map ; inline diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d89c5eec89..f7ac9c340d 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,8 +1,45 @@ +! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman, +! Eduardo Cavazos, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors arrays math.parser sorting strings ascii ; IN: sequences.lib +: each-withn ( seq quot n -- ) nwith each ; inline + +: each-with ( seq quot -- ) with each ; inline + +: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline + +: map-withn ( seq quot n -- newseq ) nwith map ; inline + +: map-with ( seq quot -- ) with map ; inline + +: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline + +MACRO: nfirst ( n -- ) + [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; + +: prepare-index ( seq quot -- seq n quot ) + >r dup length r> ; inline + +: each-index ( seq quot -- ) + #! quot: ( elt index -- ) + prepare-index 2each ; inline + +: map-index ( seq quot -- ) + #! quot: ( elt index -- obj ) + prepare-index 2map ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: sigma ( seq quot -- n ) + [ rot slip + ] curry 0 swap reduce ; inline + +: count ( seq quot -- n ) + [ 1 0 ? ] compose sigma ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : map-reduce ( seq map-quot reduce-quot -- result ) @@ -66,7 +103,7 @@ IN: sequences.lib : split-around ( seq quot -- before elem after ) dupd find over [ "Element not found" throw ] unless - >r cut-slice 1 tail r> swap ; inline + >r cut 1 tail r> swap ; inline : (map-until) ( quot pred -- quot ) [ dup ] swap 3compose @@ -149,7 +186,7 @@ PRIVATE> ! List the positions of obj in seq : indices ( seq obj -- seq ) - >r dup length swap r> - [ = [ ] [ drop f ] if ] curry - 2map - [ ] subset ; + >r dup length swap r> + [ = [ ] [ drop f ] if ] curry + 2map + [ ] subset ; From 19154ce6db0a84800d3ed0dd05f4e1da5080879d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 00:15:47 -0600 Subject: [PATCH 11/25] Don't need this file --- extra/xml/xml-tests.factor | 13 ------------- 1 file changed, 13 deletions(-) delete mode 100644 extra/xml/xml-tests.factor diff --git a/extra/xml/xml-tests.factor b/extra/xml/xml-tests.factor deleted file mode 100644 index 12923839bd..0000000000 --- a/extra/xml/xml-tests.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: io.files tools.test sequences namespaces kernel ; - -{ - "arithmetic" - "errors" - "soap" - "templating" - "test" -} -[ - "resource:extra/xml/test/" swap ".factor" 3append run-test - failures get push-all -] each From bb429425e9edef2cb8fab98299681e4748696669 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 00:16:30 -0600 Subject: [PATCH 12/25] New split-reduce combinator --- core/sequences/sequences.factor | 20 +++++++++++++++++--- core/sorting/sorting.factor | 10 ++-------- 2 files changed, 19 insertions(+), 11 deletions(-) mode change 100644 => 100755 core/sorting/sorting.factor diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 151777b0c7..5bb09d68dc 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -606,7 +606,21 @@ M: sequence <=> ] if ; : cut-slice ( seq n -- before after ) - [ head ] 2keep tail-slice ; + [ head-slice ] 2keep tail-slice ; + +: midpoint@ ( seq -- n ) length 2/ ; inline + +: halves ( seq -- first second ) + dup midpoint@ cut-slice ; + +: binary-reduce ( seq start quot -- value ) + pick length { + { 0 [ drop nip ] } + { 1 [ 2drop first ] } + { 2 [ >r drop first2 r> call ] } + { 3 [ >r drop first3 r> 2apply ] } + [ drop >r >r halves r> r> [ [ split-reduce ] 2curry 2apply ] keep call ] + } case ; inline : cut ( seq n -- before after ) [ head ] 2keep tail ; @@ -657,8 +671,8 @@ PRIVATE> : trim ( seq quot -- newseq ) [ left-trim ] keep right-trim ; inline -: sum ( seq -- n ) 0 [ + ] reduce ; -: product ( seq -- n ) 1 [ * ] reduce ; +: sum ( seq -- n ) 0 [ + ] binary-reduce ; +: product ( seq -- n ) 1 [ * ] binary-reduce ; : infimum ( seq -- n ) dup first [ min ] reduce ; : supremum ( seq -- n ) dup first [ max ] reduce ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor old mode 100644 new mode 100755 index 0269295433..25b8252ea1 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -4,8 +4,6 @@ USING: arrays kernel math sequences vectors sequences sequences.private growable ; IN: sorting -: midpoint@ ( seq -- n ) length 2/ ; inline - DEFER: sort [ (merge) ] keep underlying ; inline -: divide ( seq -- first second ) - dup midpoint@ [ head-slice ] 2keep tail-slice ; - : conquer ( first second quot -- result ) [ tuck >r >r sort r> r> sort ] keep merge ; inline @@ -48,7 +43,7 @@ PRIVATE> : sort ( seq quot -- sortedseq ) over length 1 <= - [ drop ] [ over >r >r divide r> conquer r> like ] if ; + [ drop ] [ over >r >r halves r> conquer r> like ] if ; inline : natural-sort ( seq -- sortedseq ) [ <=> ] sort ; @@ -63,8 +58,7 @@ PRIVATE> [ midpoint@ ] keep nth-unsafe ; inline : partition ( seq n -- slice ) - >r dup midpoint@ r> 1 < [ head-slice ] [ tail-slice ] if ; - inline + 1 < swap halves ? ; inline : (binsearch) ( elt quot seq -- i ) dup length 1 <= [ From 81ac2f77f7f88419efdf3c3afa80fd13015369c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 00:17:51 -0600 Subject: [PATCH 13/25] Fix name clash --- core/compiler/{test => tests}/curry.factor | 0 core/compiler/{test => tests}/float.factor | 0 core/compiler/{test => tests}/intrinsics.factor | 0 core/compiler/{test => tests}/simple.factor | 0 core/compiler/{test => tests}/stack-trace.factor | 0 core/compiler/{test => tests}/templates-early.factor | 0 core/compiler/{test => tests}/templates.factor | 0 core/compiler/{test => tests}/tuples.factor | 0 core/vocabs/loader/loader.factor | 2 +- extra/tools/test/test-docs.factor | 2 +- extra/xml/{test => tests}/arithmetic.factor | 0 extra/xml/{test => tests}/authors.txt | 0 extra/xml/{test => tests}/errors.factor | 0 extra/xml/{test => tests}/soap.factor | 0 extra/xml/{test => tests}/soap.xml | 0 extra/xml/{test => tests}/templating.factor | 0 extra/xml/{test => tests}/test.factor | 0 extra/xml/{test => tests}/test.xml | 0 18 files changed, 2 insertions(+), 2 deletions(-) rename core/compiler/{test => tests}/curry.factor (100%) rename core/compiler/{test => tests}/float.factor (100%) rename core/compiler/{test => tests}/intrinsics.factor (100%) rename core/compiler/{test => tests}/simple.factor (100%) rename core/compiler/{test => tests}/stack-trace.factor (100%) rename core/compiler/{test => tests}/templates-early.factor (100%) rename core/compiler/{test => tests}/templates.factor (100%) rename core/compiler/{test => tests}/tuples.factor (100%) rename extra/xml/{test => tests}/arithmetic.factor (100%) rename extra/xml/{test => tests}/authors.txt (100%) rename extra/xml/{test => tests}/errors.factor (100%) rename extra/xml/{test => tests}/soap.factor (100%) rename extra/xml/{test => tests}/soap.xml (100%) rename extra/xml/{test => tests}/templating.factor (100%) rename extra/xml/{test => tests}/test.factor (100%) rename extra/xml/{test => tests}/test.xml (100%) diff --git a/core/compiler/test/curry.factor b/core/compiler/tests/curry.factor similarity index 100% rename from core/compiler/test/curry.factor rename to core/compiler/tests/curry.factor diff --git a/core/compiler/test/float.factor b/core/compiler/tests/float.factor similarity index 100% rename from core/compiler/test/float.factor rename to core/compiler/tests/float.factor diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/tests/intrinsics.factor similarity index 100% rename from core/compiler/test/intrinsics.factor rename to core/compiler/tests/intrinsics.factor diff --git a/core/compiler/test/simple.factor b/core/compiler/tests/simple.factor similarity index 100% rename from core/compiler/test/simple.factor rename to core/compiler/tests/simple.factor diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/tests/stack-trace.factor similarity index 100% rename from core/compiler/test/stack-trace.factor rename to core/compiler/tests/stack-trace.factor diff --git a/core/compiler/test/templates-early.factor b/core/compiler/tests/templates-early.factor similarity index 100% rename from core/compiler/test/templates-early.factor rename to core/compiler/tests/templates-early.factor diff --git a/core/compiler/test/templates.factor b/core/compiler/tests/templates.factor similarity index 100% rename from core/compiler/test/templates.factor rename to core/compiler/tests/templates.factor diff --git a/core/compiler/test/tuples.factor b/core/compiler/tests/tuples.factor similarity index 100% rename from core/compiler/test/tuples.factor rename to core/compiler/tests/tuples.factor diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index ea3023a4f8..30d7361898 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -56,7 +56,7 @@ M: vocab-link vocab-root dup "-tests.factor" vocab-dir+ vocab-path+ dup resource-exists? [ , ] [ drop ] if - dup vocab-dir "test" path+ vocab-path+ dup + dup vocab-dir "tests" path+ vocab-path+ dup ?resource-path directory keys [ ".factor" tail? ] subset [ path+ , ] with each ] { } make diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index ac561100f8..a8c7239922 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -39,7 +39,7 @@ $nl "Unit tests for a vocabulary are placed in test files in the same directory as the vocabulary source file (see " { $link "vocabs.loader" } "). Two possibilities are supported:" { $list { "Tests can be placed in a file named " { $snippet { $emphasis "vocab" } "-tests.factor" } "." } - { "Tests can be placed in files in the " { $snippet "test" } " subdirectory." } + { "Tests can be placed in files in the " { $snippet "tests" } " subdirectory." } } "The latter is used for vocabularies with more extensive test suites." $nl diff --git a/extra/xml/test/arithmetic.factor b/extra/xml/tests/arithmetic.factor similarity index 100% rename from extra/xml/test/arithmetic.factor rename to extra/xml/tests/arithmetic.factor diff --git a/extra/xml/test/authors.txt b/extra/xml/tests/authors.txt similarity index 100% rename from extra/xml/test/authors.txt rename to extra/xml/tests/authors.txt diff --git a/extra/xml/test/errors.factor b/extra/xml/tests/errors.factor similarity index 100% rename from extra/xml/test/errors.factor rename to extra/xml/tests/errors.factor diff --git a/extra/xml/test/soap.factor b/extra/xml/tests/soap.factor similarity index 100% rename from extra/xml/test/soap.factor rename to extra/xml/tests/soap.factor diff --git a/extra/xml/test/soap.xml b/extra/xml/tests/soap.xml similarity index 100% rename from extra/xml/test/soap.xml rename to extra/xml/tests/soap.xml diff --git a/extra/xml/test/templating.factor b/extra/xml/tests/templating.factor similarity index 100% rename from extra/xml/test/templating.factor rename to extra/xml/tests/templating.factor diff --git a/extra/xml/test/test.factor b/extra/xml/tests/test.factor similarity index 100% rename from extra/xml/test/test.factor rename to extra/xml/tests/test.factor diff --git a/extra/xml/test/test.xml b/extra/xml/tests/test.xml similarity index 100% rename from extra/xml/test/test.xml rename to extra/xml/tests/test.xml From f7b22faf0e3920bd9551255419830e526c83081d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 00:41:41 -0600 Subject: [PATCH 14/25] Patch from Yoshinori Tahara --- extra/x11/xim/xim.factor | 14 ++++++++++---- extra/x11/xlib/xlib.factor | 19 +++++++++++++++++++ 2 files changed, 29 insertions(+), 4 deletions(-) diff --git a/extra/x11/xim/xim.factor b/extra/x11/xim/xim.factor index 6fb6ada3ae..35e1906b2b 100755 --- a/extra/x11/xim/xim.factor +++ b/extra/x11/xim/xim.factor @@ -7,9 +7,15 @@ IN: x11.xim SYMBOL: xim +: (init-xim) ( classname medifier -- im ) + XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless + dpy get f rot dup XOpenIM ; + : init-xim ( classname -- ) - dpy get f rot dup XOpenIM - [ "XOpenIM() failed" throw ] unless* xim set-global ; + dup "" (init-xim) + [ nip ] + [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if* + xim set-global ; : close-xim ( -- ) xim get-global XCloseIM drop f xim set-global ; @@ -32,11 +38,11 @@ SYMBOL: keybuf SYMBOL: keysym : prepare-lookup ( -- ) - buf-size "ulong" keybuf set + buf-size "uint" keybuf set 0 keysym set ; : finish-lookup ( len -- string keysym ) - keybuf get swap c-ulong-array> >string + keybuf get swap c-uint-array> >string keysym get *KeySym ; : lookup-string ( event xic -- string keysym ) diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor index 70006c9f64..752c6c442e 100755 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -1339,10 +1339,28 @@ FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_r FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +! !!! category of setlocale +: LC_ALL 0 ; inline +: LC_COLLATE 1 ; inline +: LC_CTYPE 2 ; inline +: LC_MONETARY 3 ; inline +: LC_NUMERIC 4 ; inline +: LC_TIME 5 ; inline + +FUNCTION: char* setlocale ( int category, char* name ) ; + +FUNCTION: Bool XSupportsLocale ( ) ; + +FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; + SYMBOL: dpy SYMBOL: scr SYMBOL: root +: init-locale ( -- ) + LC_ALL "" setlocale [ "setlocale() failed" throw ] unless + XSupportsLocale [ "XSupportsLocale() failed" throw ] unless ; + : flush-dpy ( -- ) dpy get XFlush drop ; : x-atom ( string -- atom ) dpy get swap 0 XInternAtom ; @@ -1353,6 +1371,7 @@ SYMBOL: root ] unless* ; : initialize-x ( display-string -- ) + init-locale dup [ string>char-alien ] when XOpenDisplay check-display dpy set-global dpy get XDefaultScreen scr set-global From 8672ede540c60243361b6ebeeeeea653e3f1b261 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 00:41:58 -0600 Subject: [PATCH 15/25] Fix compilation of VM on Mac OS X --- vm/debug.c | 84 +++++++++++++++++++++++++++++------------------------- 1 file changed, 45 insertions(+), 39 deletions(-) diff --git a/vm/debug.c b/vm/debug.c index a080a6cab2..f15b387377 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -213,56 +213,62 @@ void dump_objects(F_FIXNUM type) gc_off = false; } -void find_data_references(CELL look_for) -{ - CELL obj; +CELL look_for; +CELL obj; - void find_references_step(CELL *scan) +void find_data_references_step(CELL *scan) +{ + if(look_for == *scan) { - if(look_for == *scan) + printf("%lx ",obj); + print_nested_obj(obj,2); + printf("\n"); + } +} + +void find_data_references(CELL look_for_) +{ + look_for = look_for_; + + begin_scan(); + + while((obj = next_object()) != F) + do_slots(UNTAG(obj),find_data_references_step); + + /* end scan */ + gc_off = false; +} + +CELL look_for; + +void find_code_references_step(F_COMPILED *compiled, CELL code_start, + CELL reloc_start, CELL literals_start) +{ + CELL scan; + CELL literal_end = literals_start + compiled->literals_length; + + for(scan = literals_start; scan < literal_end; scan += CELLS) + { + CELL code_start = (CELL)(compiled + 1); + CELL literal_start = code_start + + compiled->code_length + + compiled->reloc_length; + + CELL obj = get(literal_start); + + if(look_for == get(scan)) { printf("%lx ",obj); print_nested_obj(obj,2); printf("\n"); } } - - begin_scan(); - - while((obj = next_object()) != F) - do_slots(UNTAG(obj),find_references_step); - - /* end scan */ - gc_off = false; } -void find_code_references(CELL look_for) +void find_code_references(CELL look_for_) { - void find_references_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start) - { - CELL scan; - CELL literal_end = literals_start + compiled->literals_length; - - for(scan = literals_start; scan < literal_end; scan += CELLS) - { - CELL code_start = (CELL)(compiled + 1); - CELL literal_start = code_start - + compiled->code_length - + compiled->reloc_length; - - CELL obj = get(literal_start); - - if(look_for == get(scan)) - { - printf("%lx ",obj); - print_nested_obj(obj,2); - printf("\n"); - } - } - } - - iterate_code_heap(find_references_step); + look_for = look_for_; + iterate_code_heap(find_code_references_step); } void factorbug(void) From 6c75da20f1f92713baaf3e02aec0f382331fd318 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 01:18:24 -0600 Subject: [PATCH 16/25] Fix bootstrap.help --- extra/bootstrap/help/help.factor | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor index e88091105b..ade60d4457 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -13,13 +13,7 @@ IN: bootstrap.help vocabs [ vocab-root ] subset [ vocab-source-loaded? ] subset - [ - dup vocab-docs-loaded? [ - drop - ] [ - dup vocab-root swap load-docs - ] if - ] each + [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each ] with-variable "help.handbook" require ; From e66e6d70e40273bea4a2cda492f035d2bdf9ac3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 01:19:53 -0600 Subject: [PATCH 17/25] Moved dispatch to sequences.private --- core/bootstrap/image/image.factor | 2 +- core/combinators/combinators-docs.factor | 2 +- core/combinators/combinators.factor | 6 --- core/compiler/tests/intrinsics.factor | 2 +- core/compiler/tests/simple.factor | 2 +- core/compiler/tests/templates.factor | 2 +- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 2 +- core/inference/backend/backend-docs.factor | 2 +- core/inference/inference-tests.factor | 2 +- core/inference/known-words/known-words.factor | 2 +- core/kernel/kernel.factor | 1 + core/optimizer/known-words/known-words.factor | 2 +- .../specializers/specializers.factor | 2 +- core/sequences/sequences.factor | 26 +++++++++---- core/vocabs/loader/loader-docs.factor | 30 +------------- extra/benchmark/dispatch4/dispatch4.factor | 2 +- extra/combinators/lib/lib-docs.factor | 36 ----------------- extra/cpu/8080/emulator/emulator.factor | 2 +- extra/icfp/2006/2006.factor | 2 +- extra/inverse/inverse.factor | 2 +- extra/optimizer/debugger/debugger.factor | 2 +- extra/sequences/lib/lib-docs.factor | 39 +++++++++++++++++++ extra/sequences/lib/lib.factor | 2 +- extra/space-invaders/space-invaders.factor | 2 +- extra/state-machine/state-machine.factor | 2 +- extra/tools/interpreter/interpreter.factor | 2 +- 27 files changed, 81 insertions(+), 99 deletions(-) mode change 100644 => 100755 core/combinators/combinators-docs.factor mode change 100644 => 100755 extra/benchmark/dispatch4/dispatch4.factor mode change 100644 => 100755 extra/cpu/8080/emulator/emulator.factor mode change 100644 => 100755 extra/icfp/2006/2006.factor mode change 100644 => 100755 extra/inverse/inverse.factor create mode 100755 extra/sequences/lib/lib-docs.factor mode change 100644 => 100755 extra/state-machine/state-machine.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 4468ecf7d1..7c12b3ea60 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts splitting growable classes tuples words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private -combinators.private combinators ; +sequences.private combinators ; IN: bootstrap.image : my-arch ( -- arch ) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor old mode 100644 new mode 100755 index 4cea78bc97..d91c920def --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -1,6 +1,6 @@ USING: arrays help.markup help.syntax strings sbufs vectors kernel quotations generic generic.standard classes -math assocs sequences combinators.private ; +math assocs sequences sequences.private ; IN: combinators ARTICLE: "combinators-quot" "Quotation construction utilities" diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index f532f06293..0ba8b583be 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -4,12 +4,6 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors ; - - TUPLE: no-cond ; : no-cond ( -- * ) \ no-cond construct-empty throw ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 679938b7f3..5dfe447443 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays strings.private system random layouts vectors.private sbufs.private strings.private slots.private alien alien.accessors -alien.c-types alien.syntax namespaces libc combinators.private ; +alien.c-types alien.syntax namespaces libc sequences.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 743fb713d9..1ed43120d3 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,5 +1,5 @@ USING: compiler tools.test kernel kernel.private -combinators.private math.private math combinators strings +sequences.private math.private math combinators strings alien arrays memory ; IN: temporary diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 08e1c98729..74e5ab80a4 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -2,7 +2,7 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private -combinators.private byte-arrays alien alien.accessors layouts +sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units ; IN: temporary diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 21a7857646..2cc28ac0d1 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces sequences words quotations layouts combinators -combinators.private classes definitions ; +sequences.private classes definitions ; IN: generic.math PREDICATE: class math-class ( object -- ? ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 7f4f423d8b..49b003bd62 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel kernel.private slots.private math namespaces sequences vectors words quotations definitions -hashtables layouts combinators combinators.private generic +hashtables layouts combinators sequences.private generic classes classes.private ; IN: generic.standard diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 98e2e6bbcd..1d742e144a 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -1,6 +1,6 @@ USING: help.syntax help.markup words effects inference.dataflow inference.state inference.backend kernel sequences -kernel.private combinators combinators.private ; +kernel.private combinators sequences.private ; HELP: literal-expected { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 7a4176abfb..b841080c94 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate debugger threads.private io.streams.string io.timeouts -combinators.private ; +sequences.private ; IN: temporary { 0 2 } [ 2 "Hello" ] must-infer-as diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 69e331a9bf..a1887e206b 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.accessors arrays bit-arrays byte-arrays -classes combinators.private continuations.private effects +classes sequences.private continuations.private effects float-arrays generic hashtables hashtables.private inference.state inference.backend inference.dataflow io io.backend io.files io.files.private io.streams.c kernel diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 7c4930f5a8..8d639aff78 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -17,6 +17,7 @@ IN: kernel : clear ( -- ) { } set-datastack ; ! Combinators + : call ( callable -- ) uncurry (call) ; DEFER: if diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 43c0324611..3dce9d8f82 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32 io.streams.string layouts splitting math.intervals math.floats.private tuples tuples.private classes optimizer.def-use optimizer.backend optimizer.pattern-match -float-arrays combinators.private combinators ; +float-arrays sequences.private combinators ; ! the output of and has the class which is ! its second-to-last input diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 223ce18117..af8cd5b82e 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces sequences vectors words strings layouts combinators -combinators.private classes generic.standard assocs ; +sequences.private classes generic.standard assocs ; IN: optimizer.specializers : (make-specializer) ( class picker -- quot ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 5bb09d68dc..967fcbbdc8 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. IN: sequences USING: kernel kernel.private slots.private math math.private ; @@ -77,6 +77,8 @@ PREDICATE: fixnum array-capacity : set-array-nth ( elt n array -- ) swap 2 fixnum+fast set-slot ; inline +: dispatch ( n array -- ) array-nth (call) ; + GENERIC: resize ( n seq -- newseq ) flushable ! Unsafe sequence protocol for inner loops @@ -614,13 +616,21 @@ M: sequence <=> dup midpoint@ cut-slice ; : binary-reduce ( seq start quot -- value ) - pick length { - { 0 [ drop nip ] } - { 1 [ 2drop first ] } - { 2 [ >r drop first2 r> call ] } - { 3 [ >r drop first3 r> 2apply ] } - [ drop >r >r halves r> r> [ [ split-reduce ] 2curry 2apply ] keep call ] - } case ; inline + #! We can't use case here since combinators depends on + #! sequences + pick length dup 0 3 between? [ + >fixnum { + [ drop nip ] + [ 2drop first ] + [ >r drop first2 r> call ] + [ >r drop first3 r> 2apply ] + } dispatch + ] [ + drop + >r >r halves r> r> + [ [ binary-reduce ] 2curry 2apply ] keep + call + ] if ; inline : cut ( seq n -- before after ) [ head ] 2keep tail ; diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 379b300eaa..a306efbd68 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -42,23 +42,9 @@ HELP: vocab-main HELP: vocab-roots { $var-description "A sequence of pathname strings to search for vocabularies." } ; -HELP: vocab-source -{ $values { "vocab" "a vocabulary specifier" } { "path" string } } -{ $description "Outputs a pathname relative to a vocabulary root where the source code for " { $snippet "vocab" } " might be found." } ; - -{ vocab-source vocab-source-path } related-words - -HELP: vocab-docs -{ $values { "vocab" "a vocabulary specifier" } { "path" string } } -{ $description "Outputs a pathname relative to a vocabulary root where the documentation for " { $snippet "vocab" } " might be found." } ; - -{ vocab-docs vocab-docs-path } related-words - HELP: vocab-tests -{ $values { "vocab" "a vocabulary specifier" } { "path" string } } -{ $description "Outputs a pathname relative to a vocabulary root where the unit tests for " { $snippet "vocab" } " might be found." } ; - -{ vocab-tests vocab-tests-path } related-words +{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; HELP: find-vocab-root { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } @@ -86,14 +72,6 @@ HELP: load-docs { $values { "root" "a pathname string" } { "name" "a vocabulary name" } } { $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ; -HELP: amend-vocab-from-root -{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } { "vocab" vocab } } -{ $description "Loads a vocabulary's source code and documentation if they have not already been loaded, and outputs the vocabulary." } ; - -HELP: load-vocab-from-root -{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } } -{ $description "Loads a vocabulary's source code and documentation." } ; - HELP: reload { $values { "name" "a vocabulary name" } } { $description "Loads it's source code and documentation." } @@ -116,10 +94,6 @@ HELP: vocab-docs-path { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } } { $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ; -HELP: vocab-tests-path -{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } } -{ $description "Outputs a pathname where the unit tests for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ; - HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; diff --git a/extra/benchmark/dispatch4/dispatch4.factor b/extra/benchmark/dispatch4/dispatch4.factor old mode 100644 new mode 100755 index a5bb983151..a92772a923 --- a/extra/benchmark/dispatch4/dispatch4.factor +++ b/extra/benchmark/dispatch4/dispatch4.factor @@ -1,5 +1,5 @@ USING: kernel.private kernel sequences math combinators -combinators.private ; +sequences.private ; IN: benchmark.dispatch4 : foobar-1 diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor index 02c3556742..d850243bd0 100755 --- a/extra/combinators/lib/lib-docs.factor +++ b/extra/combinators/lib/lib-docs.factor @@ -47,42 +47,6 @@ HELP: nkeep } { $see-also keep nslip } ; -HELP: map-withn -{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } } -{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be " -"passed to the quotation given to map-withn for each element in the sequence." -} -{ $examples - { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" } -} -{ $see-also each-withn } ; - -HELP: each-withn -{ $values { "seq" sequence } { "quot" quotation } { "n" number } } -{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be " -"passed to the quotation given to each-withn for each element in the sequence." -} -{ $see-also map-withn } ; - -HELP: sigma -{ $values { "seq" sequence } { "quot" quotation } { "n" number } } -{ $description "Like map sum, but without creating an intermediate sequence." } -{ $example - "! Find the sum of the squares [0,99]" - "USING: math.ranges combinators.lib ;" - "100 [1,b] [ sq ] sigma ." - "338350" -} ; - -HELP: count -{ $values { "seq" sequence } { "quot" quotation } { "n" integer } } -{ $description "Efficiently returns the number of elements that the predicate quotation matches." } -{ $example - "USING: math.ranges combinators.lib ;" - "100 [1,b] [ even? ] count ." - "50" -} ; - HELP: && { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } } { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor old mode 100644 new mode 100755 index 0eca7bdc47..310e387bd5 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -4,7 +4,7 @@ USING: kernel math sequences words arrays io io.files namespaces math.parser kernel.private assocs quotations parser parser-combinators tools.time - combinators.private compiler.units ; + sequences.private compiler.units ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor old mode 100644 new mode 100755 index 53c7fd5a9b..2a35ed08f8 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Gavin Harrison ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences kernel.private namespaces arrays io io.files - splitting io.binary math.functions vectors quotations combinators.private ; + splitting io.binary math.functions vectors quotations sequences.private ; IN: icfp.2006 SYMBOL: regs diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor old mode 100644 new mode 100755 index b97748514c..99dddb25f0 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,7 +1,7 @@ USING: kernel words inspector slots quotations sequences assocs math arrays inference effects shuffle continuations debugger tuples namespaces vectors bit-arrays byte-arrays strings sbufs -math.functions macros combinators.private combinators ; +math.functions macros sequences.private combinators ; IN: inverse TUPLE: fail ; diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 900f5a3829..499222073b 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -3,7 +3,7 @@ USING: classes inference inference.dataflow io kernel kernel.private math.parser namespaces optimizer prettyprint prettyprint.backend sequences words arrays match macros -assocs combinators.private ; +assocs sequences.private ; IN: optimizer.debugger ! A simple tool for turning dataflow IR into quotations, for diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor new file mode 100755 index 0000000000..eb56e35cd5 --- /dev/null +++ b/extra/sequences/lib/lib-docs.factor @@ -0,0 +1,39 @@ +USING: help.syntax help.markup kernel prettyprint sequences +quotations math ; +IN: sequences.lib + +HELP: map-withn +{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } } +{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be " +"passed to the quotation given to map-withn for each element in the sequence." +} +{ $examples + { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" } +} +{ $see-also each-withn } ; + +HELP: each-withn +{ $values { "seq" sequence } { "quot" quotation } { "n" number } } +{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be " +"passed to the quotation given to each-withn for each element in the sequence." +} +{ $see-also map-withn } ; + +HELP: sigma +{ $values { "seq" sequence } { "quot" quotation } { "n" number } } +{ $description "Like map sum, but without creating an intermediate sequence." } +{ $example + "! Find the sum of the squares [0,99]" + "USING: math.ranges combinators.lib ;" + "100 [1,b] [ sq ] sigma ." + "338350" +} ; + +HELP: count +{ $values { "seq" sequence } { "quot" quotation } { "n" integer } } +{ $description "Efficiently returns the number of elements that the predicate quotation matches." } +{ $example + "USING: math.ranges combinators.lib ;" + "100 [1,b] [ even? ] count ." + "50" +} ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index f7ac9c340d..048d63dc64 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors -arrays math.parser sorting strings ascii ; +arrays math.parser sorting strings ascii macros ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 4d74968c35..f5c518865d 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -5,7 +5,7 @@ USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel shuffle arrays io.files combinators kernel.private ui.gestures ui.gadgets ui.render opengl.gl system threads concurrency match ui byte-arrays combinators.lib - combinators.private ; + sequences.private ; IN: space-invaders TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor old mode 100644 new mode 100755 index ac0bdc81c7..cd3cfc6324 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -1,5 +1,5 @@ USING: kernel parser strings math namespaces sequences words io -arrays quotations debugger kernel.private combinators.private ; +arrays quotations debugger kernel.private sequences.private ; IN: state-machine : STATES: diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index f438bcd8df..f05b3a833f 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes combinators combinators.private +USING: arrays assocs classes combinators sequences.private continuations continuations.private generic hashtables io kernel kernel.private math namespaces namespaces.private prettyprint quotations sequences splitting strings threads vectors words ; From 0f04e9714eb2af6736b3f8a18e5f00bf5a771706 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 01:25:03 -0600 Subject: [PATCH 18/25] Fix stale USE: --- core/bootstrap/compiler/compiler.factor | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 2b278ac458..ff9d5c5e1e 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -77,14 +77,3 @@ nl [ compiled-usages recompile ] recompile-hook set-global " done" print flush - -! Load empty test vocabs -USE: compiler.test.curry -USE: compiler.test.float -USE: compiler.test.intrinsics -USE: compiler.test.redefine -USE: compiler.test.simple -USE: compiler.test.stack-trace -USE: compiler.test.templates -USE: compiler.test.templates-early -USE: compiler.test.tuples From 55f29c69df6a096b63468c933c01ef2f6af13232 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 10 Feb 2008 23:53:20 -0800 Subject: [PATCH 19/25] Changed set-fullscreen? to take a gadget instead of a world, moved it into the ui vocab. Moved fullscreen docs into the ui vocab. --- extra/ui/backend/backend.factor | 4 ++-- extra/ui/cocoa/cocoa.factor | 4 ++-- extra/ui/gadgets/worlds/worlds-docs.factor | 9 --------- extra/ui/ui-docs.factor | 10 ++++++++++ extra/ui/ui.factor | 6 ++++++ 5 files changed, 20 insertions(+), 13 deletions(-) diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index cc1f5f7d05..2334c7602b 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -7,9 +7,9 @@ SYMBOL: ui-backend HOOK: set-title ui-backend ( string world -- ) -HOOK: set-fullscreen? ui-backend ( ? world -- ) +HOOK: set-fullscreen* ui-backend ( ? world -- ) -HOOK: fullscreen? ui-backend ( world -- ? ) +HOOK: fullscreen* ui-backend ( world -- ? ) HOOK: (open-window) ui-backend ( world -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 184e6fd856..06de1d81fb 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -59,10 +59,10 @@ M: cocoa-ui-backend set-title ( string world -- ) : exit-fullscreen ( world -- ) world-handle first f -> exitFullScreenModeWithOptions: ; -M: cocoa-ui-backend set-fullscreen? ( ? world -- ) +M: cocoa-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; -M: cocoa-ui-backend fullscreen? ( world -- ? ) +M: cocoa-ui-backend fullscreen* ( world -- ? ) world-handle first -> isInFullScreenMode zero? not ; : auto-position ( world -- ) diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index 8a64750751..a47717329d 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,15 +13,6 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; -HELP: set-fullscreen? -{ $values { "?" "a boolean" } { "world" world } } -{ $description "Sets and unsets fullscreen mode for the world." } -{ $notes "Find a world using " { $link find-world } "." } ; - -HELP: fullscreen? -{ $values { "world" world } { "?" "a boolean" } } -{ $description "Queries the world to see if it is running in fullscreen mode." } ; - HELP: raise-window { $values { "world" world } } { $description "Makes the native window containing the given world the front-most window." } diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 651a12c737..5d87e40d94 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -14,6 +14,16 @@ HELP: open-window { $values { "gadget" gadget } { "title" string } } { $description "Opens a native window with the specified title." } ; +HELP: set-fullscreen? +{ $values { "?" "a boolean" } { "gadget" gadget } } +{ $description "Sets and unsets fullscreen mode for the gadget's world." } ; + +HELP: fullscreen? +{ $values { "gadget" gadget } { "?" "a boolean" } } +{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ; + +{ fullscreen? set-fullscreen? } related-words + HELP: find-window { $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } } { $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 774d84ff3d..c214eee8d5 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -145,6 +145,12 @@ SYMBOL: ui-hook >r [ 1 track, ] { 0 1 } make-track r> f open-world-window ; +: set-fullscreen? ( ? gadget -- ) + find-world set-fullscreen* ; + +: fullscreen? ( gadget -- ? ) + find-world fullscreen* ; + HOOK: close-window ui-backend ( gadget -- ) M: object close-window From 04dc25f87a9809114ef947ae207ea269729deb05 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 06:11:00 -0600 Subject: [PATCH 20/25] builder.test: Only extract the vocab names from the result of try-everything --- extra/builder/test/test.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index c887c668e6..b77199c7c5 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,8 +7,10 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test +: try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ; + : do-load ( -- ) - [ try-everything ] "../load-everything-time" log-runtime + [ try-everything* ] "../load-everything-time" log-runtime dup empty? [ drop ] [ "../load-everything-log" log-object ] From 3906f1c9f5eaa0bd0a7fc7c6d481c401f80454cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 13:39:43 -0600 Subject: [PATCH 21/25] add drop table fix up unit tests --- extra/db/sqlite/sqlite.factor | 6 +++++- extra/db/tuples/tuples-tests.factor | 20 ++++++++++++++------ extra/db/tuples/tuples.factor | 5 ++++- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 0f4529763a..093dac9d1a 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -84,6 +84,11 @@ M: sqlite-db create-sql ( columns table -- sql ) ] interleave ")" % ] "" make ; +M: sqlite-db drop-sql ( table -- sql ) + [ + "drop table " % % + ] "" make ; + M: sqlite-db insert-sql* ( columns table -- sql ) [ "insert into " % @@ -109,7 +114,6 @@ M: sqlite-db update-sql* ( columns table -- sql ) M: sqlite-db delete-sql* ( columns table -- sql ) [ - break "delete from " % % " where " % diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7fc6fd3b97..dcf27841cf 100644 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,4 +1,5 @@ -USING: io.files kernel tools.test db db.sqlite db.tuples ; +USING: io.files kernel tools.test db db.sqlite db.tuples +db.types continuations namespaces ; IN: temporary TUPLE: person the-id the-name the-number ; @@ -13,16 +14,23 @@ person "PERSON" } define-persistent +SYMBOL: the-person + : test-tuples ( -- ) - f "billy" 100 person construct-boa dup insert-tuple + [ person drop-table ] [ ] recover + person create-table + f "billy" 100 person construct-boa + the-person set + + [ ] [ the-person get insert-tuple ] unit-test - [ 1 ] [ dup person-id ] unit-test + [ 1 ] [ the-person get person-the-id ] unit-test - 200 over set-person-the-number + 200 the-person get set-person-the-number - [ ] [ dup update-tuple ] unit-test + [ ] [ the-person get update-tuple ] unit-test - [ ] [ delete-tuple ] unit-test ; + [ ] [ the-person get delete-tuple ] unit-test ; : test-sqlite ( -- ) "tuples-test.db" resource-path [ diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index c08f359d5e..c9faaf710c 100644 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -49,7 +49,7 @@ IN: db.tuples [ ] 3compose cache nip ; inline HOOK: create-sql db ( columns table -- sql ) -HOOK: drop-sql db ( columns table -- sql ) +HOOK: drop-sql db ( table -- sql ) HOOK: insert-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql ) @@ -80,6 +80,9 @@ HOOK: tuple>params db ( columns tuple -- obj ) : create-table ( class -- ) dup db-columns swap db-table create-sql sql-command ; +: drop-table ( class -- ) + db-table drop-sql sql-command ; + : insert-tuple ( tuple -- ) [ [ maybe-remove-id ] [ insert-sql ] do-tuple-statement From 98d8621ac1997b104809cabb66b4b3effe9ea2d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 13:50:29 -0600 Subject: [PATCH 22/25] First class compose, curry is now a tuple class --- core/bootstrap/layouts/layouts.factor | 7 +- core/bootstrap/primitives.factor | 52 ++- core/continuations/continuations.factor | 2 +- core/inference/known-words/known-words.factor | 345 +++++++++--------- core/inference/transforms/transforms.factor | 2 - core/kernel/kernel-docs.factor | 2 +- core/kernel/kernel.factor | 15 +- core/optimizer/known-words/known-words.factor | 5 + core/prettyprint/backend/backend.factor | 3 + core/quotations/quotations.factor | 30 +- core/threads/threads.factor | 2 +- core/vocabs/loader/loader.factor | 3 +- core/words/words.factor | 2 +- .../interpreter/interpreter-tests.factor | 3 + extra/tools/interpreter/interpreter.factor | 2 +- vm/alien.c | 11 +- vm/data_gc.c | 2 - vm/errors.c | 3 +- vm/layouts.h | 5 +- vm/primitives.c | 2 - vm/quotations.c | 44 --- vm/quotations.h | 3 - 22 files changed, 270 insertions(+), 275 deletions(-) mode change 100644 => 100755 core/threads/threads.factor mode change 100644 => 100755 extra/tools/interpreter/interpreter-tests.factor diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 9c0d6b9838..e15a7b4d7c 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays bit-arrays @@ -8,7 +8,7 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -20 num-types set +19 num-types set H{ { fixnum BIN: 000 } @@ -27,11 +27,10 @@ tag-numbers get H{ { float-array 10 } { callstack 11 } { string 12 } - { curry 13 } + { bit-array 13 } { quotation 14 } { dll 15 } { alien 16 } { word 17 } { byte-array 18 } - { bit-array 19 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 967840a3dc..66ede8b054 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -295,23 +295,6 @@ define-builtin "float-array?" "float-arrays" create { } define-builtin -"curry" "kernel" create -"curry?" "kernel" create -{ - { - { "object" "kernel" } - "obj" - { "curry-obj" "kernel" } - f - } - { - { "object" "kernel" } - "obj" - { "curry-quot" "kernel" } - f - } -} define-builtin - "callstack" "kernel" create "callstack?" "kernel" create { } define-builtin @@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"curry" "kernel" create +{ + { + { "object" "kernel" } + "obj" + { "curry-obj" "kernel" } + f + } { + { "object" "kernel" } + "quot" + { "curry-quot" "kernel" } + f + } +} define-tuple-class + +"compose" "kernel" create +{ + { + { "object" "kernel" } + "first" + { "compose-first" "kernel" } + f + } { + { "object" "kernel" } + "second" + { "compose-second" "kernel" } + f + } +} define-tuple-class + ! Primitive words : make-primitive ( word vocab n -- ) - >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; + >r create dup reset-word r> + [ do-primitive ] curry [ ] like define ; { { "(execute)" "words.private" } { "(call)" "kernel.private" } - { "uncurry" "kernel.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class { "become" "kernel.private" } { "(sleep)" "threads.private" } { "" "float-arrays" } - { "curry" "kernel" } { "" "tuples.private" } { "class-hash" "kernel.private" } { "callstack>array" "kernel" } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index b6ca056691..81f78f491d 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -98,7 +98,7 @@ PRIVATE> : continue-with ( obj continuation -- ) [ walker-hook [ >r 2array r> ] when* (continue-with) - ] 2curry (throw) ; + ] 2 (throw) ; : continue ( continuation -- ) f swap continue-with ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index a1887e206b..f92987f15f 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -126,15 +126,11 @@ M: object infer-call pop-d pop-d swap push-d ] "infer" set-word-prop -\ curry { object object } { curry } "inferred-effect" set-word-prop - \ compose [ 2 ensure-values pop-d pop-d swap push-d ] "infer" set-word-prop -\ compose { object object } { curry } "inferred-effect" set-word-prop - ! Variadic tuple constructor \ [ \ @@ -142,457 +138,460 @@ M: object infer-call make-call-node ] "infer" set-word-prop -! We need this for default-output-classes -\ 2 { tuple } "inferred-effect" set-word-prop - ! Non-standard control flow -\ (throw) { callable } { } -t over set-effect-terminated? -"inferred-effect" set-word-prop +\ (throw) [ + \ (throw) + peek-d value-literal 2 + { } + t over set-effect-terminated? + make-call-node +] "infer" set-word-prop + +: set-primitive-effect ( word effect -- ) + dupd [ make-call-node ] 2curry "infer" set-word-prop ; ! Stack effects for all primitives -\ fixnum< { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum< { fixnum fixnum } { object } set-primitive-effect \ fixnum< make-foldable -\ fixnum<= { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum<= { fixnum fixnum } { object } set-primitive-effect \ fixnum<= make-foldable -\ fixnum> { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum> { fixnum fixnum } { object } set-primitive-effect \ fixnum> make-foldable -\ fixnum>= { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum>= { fixnum fixnum } { object } set-primitive-effect \ fixnum>= make-foldable -\ eq? { object object } { object } "inferred-effect" set-word-prop +\ eq? { object object } { object } set-primitive-effect \ eq? make-foldable -\ rehash-string { string } { } "inferred-effect" set-word-prop +\ rehash-string { string } { } set-primitive-effect -\ bignum>fixnum { bignum } { fixnum } "inferred-effect" set-word-prop +\ bignum>fixnum { bignum } { fixnum } set-primitive-effect \ bignum>fixnum make-foldable -\ float>fixnum { float } { fixnum } "inferred-effect" set-word-prop +\ float>fixnum { float } { fixnum } set-primitive-effect \ bignum>fixnum make-foldable -\ fixnum>bignum { fixnum } { bignum } "inferred-effect" set-word-prop +\ fixnum>bignum { fixnum } { bignum } set-primitive-effect \ fixnum>bignum make-foldable -\ float>bignum { float } { bignum } "inferred-effect" set-word-prop +\ float>bignum { float } { bignum } set-primitive-effect \ float>bignum make-foldable -\ fixnum>float { fixnum } { float } "inferred-effect" set-word-prop +\ fixnum>float { fixnum } { float } set-primitive-effect \ fixnum>float make-foldable -\ bignum>float { bignum } { float } "inferred-effect" set-word-prop +\ bignum>float { bignum } { float } set-primitive-effect \ bignum>float make-foldable -\ { integer integer } { ratio } "inferred-effect" set-word-prop +\ { integer integer } { ratio } set-primitive-effect \ make-foldable -\ string>float { string } { float } "inferred-effect" set-word-prop +\ string>float { string } { float } set-primitive-effect \ string>float make-foldable -\ float>string { float } { string } "inferred-effect" set-word-prop +\ float>string { float } { string } set-primitive-effect \ float>string make-foldable -\ float>bits { real } { integer } "inferred-effect" set-word-prop +\ float>bits { real } { integer } set-primitive-effect \ float>bits make-foldable -\ double>bits { real } { integer } "inferred-effect" set-word-prop +\ double>bits { real } { integer } set-primitive-effect \ double>bits make-foldable -\ bits>float { integer } { float } "inferred-effect" set-word-prop +\ bits>float { integer } { float } set-primitive-effect \ bits>float make-foldable -\ bits>double { integer } { float } "inferred-effect" set-word-prop +\ bits>double { integer } { float } set-primitive-effect \ bits>double make-foldable -\ { real real } { complex } "inferred-effect" set-word-prop +\ { real real } { complex } set-primitive-effect \ make-foldable -\ fixnum+ { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum+ { fixnum fixnum } { integer } set-primitive-effect \ fixnum+ make-foldable -\ fixnum+fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum+fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum+fast make-foldable -\ fixnum- { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum- { fixnum fixnum } { integer } set-primitive-effect \ fixnum- make-foldable -\ fixnum-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-fast make-foldable -\ fixnum* { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum* { fixnum fixnum } { integer } set-primitive-effect \ fixnum* make-foldable -\ fixnum*fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum*fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum*fast make-foldable -\ fixnum/i { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum/i { fixnum fixnum } { integer } set-primitive-effect \ fixnum/i make-foldable -\ fixnum-mod { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-mod { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-mod make-foldable -\ fixnum/mod { fixnum fixnum } { integer fixnum } "inferred-effect" set-word-prop +\ fixnum/mod { fixnum fixnum } { integer fixnum } set-primitive-effect \ fixnum/mod make-foldable -\ fixnum-bitand { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitand { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitand make-foldable -\ fixnum-bitor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitor { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitor make-foldable -\ fixnum-bitxor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitxor { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitxor make-foldable -\ fixnum-bitnot { fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitnot { fixnum } { fixnum } set-primitive-effect \ fixnum-bitnot make-foldable -\ fixnum-shift { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum-shift { fixnum fixnum } { integer } set-primitive-effect \ fixnum-shift make-foldable -\ fixnum-shift-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-shift-fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-shift-fast make-foldable -\ bignum= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum= { bignum bignum } { object } set-primitive-effect \ bignum= make-foldable -\ bignum+ { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum+ { bignum bignum } { bignum } set-primitive-effect \ bignum+ make-foldable -\ bignum- { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum- { bignum bignum } { bignum } set-primitive-effect \ bignum- make-foldable -\ bignum* { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum* { bignum bignum } { bignum } set-primitive-effect \ bignum* make-foldable -\ bignum/i { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum/i { bignum bignum } { bignum } set-primitive-effect \ bignum/i make-foldable -\ bignum-mod { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-mod { bignum bignum } { bignum } set-primitive-effect \ bignum-mod make-foldable -\ bignum/mod { bignum bignum } { bignum bignum } "inferred-effect" set-word-prop +\ bignum/mod { bignum bignum } { bignum bignum } set-primitive-effect \ bignum/mod make-foldable -\ bignum-bitand { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitand { bignum bignum } { bignum } set-primitive-effect \ bignum-bitand make-foldable -\ bignum-bitor { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitor { bignum bignum } { bignum } set-primitive-effect \ bignum-bitor make-foldable -\ bignum-bitxor { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitxor { bignum bignum } { bignum } set-primitive-effect \ bignum-bitxor make-foldable -\ bignum-bitnot { bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitnot { bignum } { bignum } set-primitive-effect \ bignum-bitnot make-foldable -\ bignum-shift { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-shift { bignum bignum } { bignum } set-primitive-effect \ bignum-shift make-foldable -\ bignum< { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum< { bignum bignum } { object } set-primitive-effect \ bignum< make-foldable -\ bignum<= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum<= { bignum bignum } { object } set-primitive-effect \ bignum<= make-foldable -\ bignum> { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum> { bignum bignum } { object } set-primitive-effect \ bignum> make-foldable -\ bignum>= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum>= { bignum bignum } { object } set-primitive-effect \ bignum>= make-foldable -\ bignum-bit? { bignum integer } { object } "inferred-effect" set-word-prop +\ bignum-bit? { bignum integer } { object } set-primitive-effect \ bignum-bit? make-foldable -\ bignum-log2 { bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-log2 { bignum } { bignum } set-primitive-effect \ bignum-log2 make-foldable -\ byte-array>bignum { byte-array } { bignum } "inferred-effect" set-word-prop +\ byte-array>bignum { byte-array } { bignum } set-primitive-effect \ byte-array>bignum make-foldable -\ float= { float float } { object } "inferred-effect" set-word-prop +\ float= { float float } { object } set-primitive-effect \ float= make-foldable -\ float+ { float float } { float } "inferred-effect" set-word-prop +\ float+ { float float } { float } set-primitive-effect \ float+ make-foldable -\ float- { float float } { float } "inferred-effect" set-word-prop +\ float- { float float } { float } set-primitive-effect \ float- make-foldable -\ float* { float float } { float } "inferred-effect" set-word-prop +\ float* { float float } { float } set-primitive-effect \ float* make-foldable -\ float/f { float float } { float } "inferred-effect" set-word-prop +\ float/f { float float } { float } set-primitive-effect \ float/f make-foldable -\ float< { float float } { object } "inferred-effect" set-word-prop +\ float< { float float } { object } set-primitive-effect \ float< make-foldable -\ float-mod { float float } { float } "inferred-effect" set-word-prop +\ float-mod { float float } { float } set-primitive-effect \ float-mod make-foldable -\ float<= { float float } { object } "inferred-effect" set-word-prop +\ float<= { float float } { object } set-primitive-effect \ float<= make-foldable -\ float> { float float } { object } "inferred-effect" set-word-prop +\ float> { float float } { object } set-primitive-effect \ float> make-foldable -\ float>= { float float } { object } "inferred-effect" set-word-prop +\ float>= { float float } { object } set-primitive-effect \ float>= make-foldable -\ { object object } { word } "inferred-effect" set-word-prop +\ { object object } { word } set-primitive-effect \ make-flushable -\ word-xt { word } { integer } "inferred-effect" set-word-prop +\ word-xt { word } { integer } set-primitive-effect \ word-xt make-flushable -\ getenv { fixnum } { object } "inferred-effect" set-word-prop +\ getenv { fixnum } { object } set-primitive-effect \ getenv make-flushable -\ setenv { object fixnum } { } "inferred-effect" set-word-prop +\ setenv { object fixnum } { } set-primitive-effect -\ (stat) { string } { object object object object } "inferred-effect" set-word-prop +\ (stat) { string } { object object object object } set-primitive-effect -\ (directory) { string } { array } "inferred-effect" set-word-prop +\ (directory) { string } { array } set-primitive-effect -\ data-gc { } { } "inferred-effect" set-word-prop +\ data-gc { } { } set-primitive-effect -\ code-gc { } { } "inferred-effect" set-word-prop +\ code-gc { } { } set-primitive-effect -\ gc-time { } { integer } "inferred-effect" set-word-prop +\ gc-time { } { integer } set-primitive-effect -\ save-image { string } { } "inferred-effect" set-word-prop +\ save-image { string } { } set-primitive-effect -\ save-image-and-exit { string } { } "inferred-effect" set-word-prop +\ save-image-and-exit { string } { } set-primitive-effect \ exit { integer } { } t over set-effect-terminated? -"inferred-effect" set-word-prop +set-primitive-effect -\ data-room { } { integer array } "inferred-effect" set-word-prop +\ data-room { } { integer array } set-primitive-effect \ data-room make-flushable -\ code-room { } { integer integer } "inferred-effect" set-word-prop +\ code-room { } { integer integer } set-primitive-effect \ code-room make-flushable -\ os-env { string } { object } "inferred-effect" set-word-prop +\ os-env { string } { object } set-primitive-effect -\ millis { } { integer } "inferred-effect" set-word-prop +\ millis { } { integer } set-primitive-effect \ millis make-flushable -\ type { object } { fixnum } "inferred-effect" set-word-prop +\ type { object } { fixnum } set-primitive-effect \ type make-foldable -\ tag { object } { fixnum } "inferred-effect" set-word-prop +\ tag { object } { fixnum } set-primitive-effect \ tag make-foldable -\ class-hash { object } { fixnum } "inferred-effect" set-word-prop +\ class-hash { object } { fixnum } set-primitive-effect \ class-hash make-foldable -\ cwd { } { string } "inferred-effect" set-word-prop +\ cwd { } { string } set-primitive-effect -\ cd { string } { } "inferred-effect" set-word-prop +\ cd { string } { } set-primitive-effect -\ dlopen { string } { dll } "inferred-effect" set-word-prop +\ dlopen { string } { dll } set-primitive-effect -\ dlsym { string object } { c-ptr } "inferred-effect" set-word-prop +\ dlsym { string object } { c-ptr } set-primitive-effect -\ dlclose { dll } { } "inferred-effect" set-word-prop +\ dlclose { dll } { } set-primitive-effect -\ { integer } { byte-array } "inferred-effect" set-word-prop +\ { integer } { byte-array } set-primitive-effect \ make-flushable -\ { integer } { bit-array } "inferred-effect" set-word-prop +\ { integer } { bit-array } set-primitive-effect \ make-flushable -\ { integer float } { float-array } "inferred-effect" set-word-prop +\ { integer float } { float-array } set-primitive-effect \ make-flushable -\ { integer c-ptr } { c-ptr } "inferred-effect" set-word-prop +\ { integer c-ptr } { c-ptr } set-primitive-effect \ make-flushable -\ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell { c-ptr integer } { integer } set-primitive-effect \ alien-signed-cell make-flushable -\ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-cell { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-cell make-flushable -\ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-cell { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 { c-ptr integer } { integer } set-primitive-effect \ alien-signed-8 make-flushable -\ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-8 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-8 make-flushable -\ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-8 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 { c-ptr integer } { integer } set-primitive-effect \ alien-signed-4 make-flushable -\ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-4 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-4 make-flushable -\ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-4 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 { c-ptr integer } { fixnum } set-primitive-effect \ alien-signed-2 make-flushable -\ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-2 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 { c-ptr integer } { fixnum } set-primitive-effect \ alien-unsigned-2 make-flushable -\ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-2 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 { c-ptr integer } { fixnum } set-primitive-effect \ alien-signed-1 make-flushable -\ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-1 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 { c-ptr integer } { fixnum } set-primitive-effect \ alien-unsigned-1 make-flushable -\ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-1 { integer c-ptr integer } { } set-primitive-effect -\ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float { c-ptr integer } { float } set-primitive-effect \ alien-float make-flushable -\ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-float { float c-ptr integer } { } set-primitive-effect -\ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double { c-ptr integer } { float } set-primitive-effect \ alien-double make-flushable -\ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-double { float c-ptr integer } { } set-primitive-effect -\ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell { c-ptr integer } { simple-c-ptr } set-primitive-effect \ alien-cell make-flushable -\ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-cell { c-ptr c-ptr integer } { } set-primitive-effect -\ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string { c-ptr } { string } set-primitive-effect \ alien>char-string make-flushable -\ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien { string } { byte-array } set-primitive-effect \ string>char-alien make-flushable -\ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string { c-ptr } { string } set-primitive-effect \ alien>u16-string make-flushable -\ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien { string } { byte-array } set-primitive-effect \ string>u16-alien make-flushable -\ alien-address { alien } { integer } "inferred-effect" set-word-prop +\ alien-address { alien } { integer } set-primitive-effect \ alien-address make-flushable -\ slot { object fixnum } { object } "inferred-effect" set-word-prop +\ slot { object fixnum } { object } set-primitive-effect \ slot make-flushable -\ set-slot { object object fixnum } { } "inferred-effect" set-word-prop +\ set-slot { object object fixnum } { } set-primitive-effect -\ string-nth { fixnum string } { fixnum } "inferred-effect" set-word-prop +\ string-nth { fixnum string } { fixnum } set-primitive-effect \ string-nth make-flushable -\ set-string-nth { fixnum fixnum string } { } "inferred-effect" set-word-prop +\ set-string-nth { fixnum fixnum string } { } set-primitive-effect -\ resize-array { integer array } { array } "inferred-effect" set-word-prop +\ resize-array { integer array } { array } set-primitive-effect \ resize-array make-flushable -\ resize-byte-array { integer byte-array } { byte-array } "inferred-effect" set-word-prop +\ resize-byte-array { integer byte-array } { byte-array } set-primitive-effect \ resize-byte-array make-flushable -\ resize-bit-array { integer bit-array } { bit-array } "inferred-effect" set-word-prop +\ resize-bit-array { integer bit-array } { bit-array } set-primitive-effect \ resize-bit-array make-flushable -\ resize-float-array { integer float-array } { float-array } "inferred-effect" set-word-prop +\ resize-float-array { integer float-array } { float-array } set-primitive-effect \ resize-float-array make-flushable -\ resize-string { integer string } { string } "inferred-effect" set-word-prop +\ resize-string { integer string } { string } set-primitive-effect \ resize-string make-flushable -\ { integer object } { array } "inferred-effect" set-word-prop +\ { integer object } { array } set-primitive-effect \ make-flushable -\ begin-scan { } { } "inferred-effect" set-word-prop +\ begin-scan { } { } set-primitive-effect -\ next-object { } { object } "inferred-effect" set-word-prop +\ next-object { } { object } set-primitive-effect -\ end-scan { } { } "inferred-effect" set-word-prop +\ end-scan { } { } set-primitive-effect -\ size { object } { fixnum } "inferred-effect" set-word-prop +\ size { object } { fixnum } set-primitive-effect \ size make-flushable -\ die { } { } "inferred-effect" set-word-prop +\ die { } { } set-primitive-effect -\ fopen { string string } { alien } "inferred-effect" set-word-prop +\ fopen { string string } { alien } set-primitive-effect -\ fgetc { alien } { object } "inferred-effect" set-word-prop +\ fgetc { alien } { object } set-primitive-effect -\ fwrite { string alien } { } "inferred-effect" set-word-prop +\ fwrite { string alien } { } set-primitive-effect -\ fread { integer string } { object } "inferred-effect" set-word-prop +\ fread { integer string } { object } set-primitive-effect -\ fflush { alien } { } "inferred-effect" set-word-prop +\ fflush { alien } { } set-primitive-effect -\ fclose { alien } { } "inferred-effect" set-word-prop +\ fclose { alien } { } set-primitive-effect -\ expired? { object } { object } "inferred-effect" set-word-prop +\ expired? { object } { object } set-primitive-effect \ expired? make-flushable -\ { object } { wrapper } "inferred-effect" set-word-prop +\ { object } { wrapper } set-primitive-effect \ make-foldable -\ (clone) { object } { object } "inferred-effect" set-word-prop +\ (clone) { object } { object } set-primitive-effect \ (clone) make-flushable -\ { integer integer } { string } "inferred-effect" set-word-prop +\ { integer integer } { string } set-primitive-effect \ make-flushable -\ array>quotation { array } { quotation } "inferred-effect" set-word-prop +\ array>quotation { array } { quotation } set-primitive-effect \ array>quotation make-flushable -\ quotation-xt { quotation } { integer } "inferred-effect" set-word-prop +\ quotation-xt { quotation } { integer } set-primitive-effect \ quotation-xt make-flushable -\ { word integer } { quotation } "inferred-effect" set-word-prop +\ { word integer } { quotation } set-primitive-effect \ make-flushable -\ (>tuple) { array } { tuple } "inferred-effect" set-word-prop +\ (>tuple) { array } { tuple } set-primitive-effect \ (>tuple) make-flushable -\ tuple>array { tuple } { array } "inferred-effect" set-word-prop +\ tuple>array { tuple } { array } set-primitive-effect \ tuple>array make-flushable -\ datastack { } { array } "inferred-effect" set-word-prop +\ datastack { } { array } set-primitive-effect \ datastack make-flushable -\ retainstack { } { array } "inferred-effect" set-word-prop +\ retainstack { } { array } set-primitive-effect \ retainstack make-flushable -\ callstack { } { callstack } "inferred-effect" set-word-prop +\ callstack { } { callstack } set-primitive-effect \ callstack make-flushable -\ callstack>array { callstack } { array } "inferred-effect" set-word-prop +\ callstack>array { callstack } { array } set-primitive-effect \ callstack>array make-flushable -\ (sleep) { integer } { } "inferred-effect" set-word-prop +\ (sleep) { integer } { } set-primitive-effect -\ become { array array } { } "inferred-effect" set-word-prop +\ become { array array } { } set-primitive-effect -\ innermost-frame-quot { callstack } { quotation } "inferred-effect" set-word-prop +\ innermost-frame-quot { callstack } { quotation } set-primitive-effect -\ innermost-frame-scan { callstack } { fixnum } "inferred-effect" set-word-prop +\ innermost-frame-scan { callstack } { fixnum } set-primitive-effect -\ set-innermost-frame-quot { quotation callstack } { } "inferred-effect" set-word-prop +\ set-innermost-frame-quot { quotation callstack } { } set-primitive-effect -\ (os-envs) { } { array } "inferred-effect" set-word-prop +\ (os-envs) { } { array } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index b1b56ca1a1..7faeefc3d6 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -93,5 +93,3 @@ M: duplicated-slots-error summary \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop - -\ construct-empty 1 1 "inferred-effect" set-word-prop diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2920122ec2..c828fcb0e9 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -532,7 +532,7 @@ HELP: compose "compose call" "append call" } - "However, " { $link compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations." + "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations." } ; HELP: 3compose diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 8d639aff78..d1f3af4779 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -17,8 +17,7 @@ IN: kernel : clear ( -- ) { } set-datastack ; ! Combinators - -: call ( callable -- ) uncurry (call) ; +GENERIC: call ( callable -- ) DEFER: if @@ -71,6 +70,10 @@ DEFER: if [ 2nip call ] if ; inline ! Quotation building +USE: tuples.private + +: curry ( obj quot -- curry ) + \ curry 4 ; : 2curry ( obj1 obj2 quot -- curry ) curry curry ; inline @@ -82,12 +85,10 @@ DEFER: if swapd [ swapd call ] 2curry ; inline : compose ( quot1 quot2 -- curry ) - ! Not inline because this is treated as a primitive by - ! the compiler - [ slip call ] 2curry ; + \ compose 4 ; : 3compose ( quot1 quot2 quot3 -- curry ) - [ 2slip slip call ] 3curry ; inline + compose compose ; inline ! Object protocol @@ -156,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple ) ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded -: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ; +: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; pprint-sequence ; M: bit-vector >pprint-sequence ; M: byte-vector >pprint-sequence ; M: float-vector >pprint-sequence ; +M: curry >pprint-sequence ; +M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped 1array ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 64bf472704..65c6da2b06 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -1,13 +1,20 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays sequences sequences.private -kernel kernel.private math assocs quotations.private ; +kernel kernel.private math assocs quotations.private +slots.private ; IN: quotations +M: quotation call (call) ; + +M: curry call dup 4 slot swap 5 slot call ; + +M: compose call dup 4 slot swap 5 slot slip call ; + M: wrapper equal? over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; -UNION: callable quotation curry ; +UNION: callable quotation curry compose ; M: callable equal? over callable? [ sequence= ] [ 2drop f ] if ; @@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ; : >quotation ( seq -- quot ) >array array>quotation ; inline -M: quotation like drop dup quotation? [ >quotation ] unless ; +M: callable like drop dup quotation? [ >quotation ] unless ; INSTANCE: quotation immutable-sequence @@ -40,6 +47,17 @@ M: curry nth >r 1- r> curry-quot nth ] if ; -M: curry like drop dup callable? [ >quotation ] unless ; - INSTANCE: curry immutable-sequence + +M: compose length + dup compose-first length + swap compose-second length + ; + +M: compose nth + 2dup compose-first length < [ + compose-first + ] [ + [ compose-first length - ] keep compose-second + ] if nth ; + +INSTANCE: compose immutable-sequence diff --git a/core/threads/threads.factor b/core/threads/threads.factor old mode 100644 new mode 100755 index ee136654df..c4e159742a --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -49,7 +49,7 @@ PRIVATE> V{ } set-catchstack { } set-retainstack [ [ print-error ] recover stop ] call-clear - ] (throw) + ] 1 (throw) ] curry callcc0 ; alien = delegate; + + if(type_of(delegate) == ALIEN_TYPE) + { + F_ALIEN *delegate_alien = untag_object(delegate); + displacement += delegate_alien->displacement; + alien->alien = F; + } + else + alien->alien = delegate; + alien->displacement = displacement; alien->expired = F; return tag_object(alien); diff --git a/vm/data_gc.c b/vm/data_gc.c index 601a677920..342bbb6af4 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -189,8 +189,6 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_ALIEN); case WRAPPER_TYPE: return sizeof(F_WRAPPER); - case CURRY_TYPE: - return sizeof(F_CURRY); case CALLSTACK_TYPE: return callstack_size( untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); diff --git a/vm/errors.c b/vm/errors.c index 966fbe353d..27158cbf44 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -137,12 +137,11 @@ void misc_signal_handler_impl(void) DEFINE_PRIMITIVE(throw) { - uncurry(dpop()); + dpop(); throw_impl(dpop(),stack_chain->callstack_top); } DEFINE_PRIMITIVE(call_clear) { - uncurry(dpop()); throw_impl(dpop(),stack_chain->callstack_bottom); } diff --git a/vm/layouts.h b/vm/layouts.h index ef6fb3d4ac..5ed7c83df2 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -52,15 +52,14 @@ typedef signed long long s64; #define FLOAT_ARRAY_TYPE 10 #define CALLSTACK_TYPE 11 #define STRING_TYPE 12 -#define CURRY_TYPE 13 +#define BIT_ARRAY_TYPE 13 #define QUOTATION_TYPE 14 #define DLL_TYPE 15 #define ALIEN_TYPE 16 #define WORD_TYPE 17 #define BYTE_ARRAY_TYPE 18 -#define BIT_ARRAY_TYPE 19 -#define TYPE_COUNT 20 +#define TYPE_COUNT 19 INLINE bool immediate_p(CELL obj) { diff --git a/vm/primitives.c b/vm/primitives.c index dc7333c667..5699f90fda 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -3,7 +3,6 @@ void *primitives[] = { primitive_execute, primitive_call, - primitive_uncurry, primitive_bignum_to_fixnum, primitive_float_to_fixnum, primitive_fixnum_to_bignum, @@ -178,7 +177,6 @@ void *primitives[] = { primitive_become, primitive_sleep, primitive_float_array, - primitive_curry, primitive_tuple_boa, primitive_class_hash, primitive_callstack_to_array, diff --git a/vm/quotations.c b/vm/quotations.c index 536d5d7d5a..c3b50dbd47 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -350,50 +350,6 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) return quot; } -DEFINE_PRIMITIVE(curry) -{ - F_CURRY *curry; - - switch(type_of(dpeek())) - { - case QUOTATION_TYPE: - case CURRY_TYPE: - curry = allot_object(CURRY_TYPE,sizeof(F_CURRY)); - curry->quot = dpop(); - curry->obj = dpop(); - dpush(tag_object(curry)); - break; - default: - type_error(QUOTATION_TYPE,dpeek()); - break; - } -} - -void uncurry(CELL obj) -{ - F_CURRY *curry; - - switch(type_of(obj)) - { - case QUOTATION_TYPE: - dpush(obj); - break; - case CURRY_TYPE: - curry = untag_object(obj); - dpush(curry->obj); - uncurry(curry->quot); - break; - default: - type_error(QUOTATION_TYPE,obj); - break; - } -} - -DEFINE_PRIMITIVE(uncurry) -{ - uncurry(dpop()); -} - /* push a new quotation on the stack */ DEFINE_PRIMITIVE(array_to_quotation) { diff --git a/vm/quotations.h b/vm/quotations.h index d975d9e0f5..0845957c0b 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -2,8 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); -void uncurry(CELL obj); -DECLARE_PRIMITIVE(curry); DECLARE_PRIMITIVE(array_to_quotation); DECLARE_PRIMITIVE(quotation_xt); -DECLARE_PRIMITIVE(uncurry); From 1598255151dd3ea4bb39ddd677da03750b886eb1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 14:19:36 -0600 Subject: [PATCH 23/25] Add Eduardo-style setters --- extra/new-slots/new-slots.factor | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 0f411f3e88..4edd4239fa 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: effects words kernel sequences slots slots.private -assocs parser mirrors namespaces math vocabs ; +assocs parser mirrors namespaces math vocabs tuples ; IN: new-slots : create-accessor ( name effect -- word ) @@ -19,11 +19,21 @@ IN: new-slots : writer-effect T{ effect f { "value" "object" } { } } ; inline : writer-word ( name -- word ) - ">>" swap append writer-effect create-accessor ; + "(>>" swap ")" 3append writer-effect create-accessor ; : define-writer ( class slot name -- ) writer-word [ set-slot ] define-slot-word ; +: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline + +: setter-word ( name -- word ) + ">>" swap append setter-effect create-accessor ; + +: define-setter ( name -- ) + dup setter-word dup deferred? [ + [ \ over , swap writer-word , ] [ ] make define-inline + ] [ 2drop ] if ; + : changer-effect T{ effect f { "object" "quot" } } ; inline : changer-word ( name -- word ) @@ -40,12 +50,18 @@ IN: new-slots ] [ 2drop ] if ; : define-new-slot ( class slot name -- ) - dup define-changer 3dup define-reader define-writer ; + dup define-changer + dup define-setter + 3dup define-reader + define-writer ; : define-new-slots ( tuple-class -- ) [ "slot-names" word-prop >alist ] keep [ swap first2 >r 4 + r> define-new-slot ] curry each ; -: NEW-SLOTS: scan-word define-new-slots ; parsing +: TUPLE: + CREATE-CLASS + dup ";" parse-tokens define-tuple-class + define-new-slots ; parsing "accessors" create-vocab drop From 4daa1943d89d649ffbcbb7ee8d6d98cc411dadda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 14:19:47 -0600 Subject: [PATCH 24/25] Fixing unit tests --- core/optimizer/def-use/def-use-tests.factor | 2 +- core/optimizer/optimizer-tests.factor | 4 ++-- core/parser/parser.factor | 1 + core/prettyprint/backend/backend.factor | 1 + core/quotations/quotations-tests.factor | 2 +- core/vocabs/vocabs.factor | 7 +++---- extra/combinators/lib/lib-tests.factor | 11 ----------- extra/sequences/lib/lib-tests.factor | 15 ++++++++++++++- extra/tools/browser/browser-tests.factor | 2 -- 9 files changed, 23 insertions(+), 22 deletions(-) mode change 100644 => 100755 core/optimizer/def-use/def-use-tests.factor mode change 100644 => 100755 core/quotations/quotations-tests.factor mode change 100644 => 100755 extra/sequences/lib/lib-tests.factor mode change 100644 => 100755 extra/tools/browser/browser-tests.factor diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor old mode 100644 new mode 100755 index afe0857463..815c564109 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ; ] unit-test : kill-set ( quot -- seq ) - dataflow compute-def-use dead-literals keys + dataflow compute-def-use compute-dead-literals keys [ value-literal ] map ; : subset? [ member? ] curry all? ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 232eb5a83a..8f30abd09f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -288,10 +288,10 @@ TUPLE: silly-tuple a b ; [ t ] [ \ node-successor-f-bug compiled? ] unit-test -: construct-empty-bug construct-empty ; - [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test +[ ] [ [ ] dataflow optimize drop ] unit-test + ! Make sure we have sane heuristics : should-inline? method method-word flat-length 10 <= ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7dee5e2212..1bd7979a0c 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -107,6 +107,7 @@ M: bad-escape summary drop "Bad escape code" ; : escape ( escape -- ch ) H{ + { CHAR: a CHAR: \a } { CHAR: e CHAR: \e } { CHAR: n CHAR: \n } { CHAR: r CHAR: \r } diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 3c8df2c19a..d1364a5986 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ + { CHAR: \a CHAR: a } { CHAR: \e CHAR: e } { CHAR: \n CHAR: n } { CHAR: \r CHAR: r } diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor old mode 100644 new mode 100755 index d357fb70ff..90ba150a41 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -15,4 +15,4 @@ IN: temporary [ [ "hi" ] ] [ "hi" 1quotation ] unit-test -[ 1 \ + curry ] must-fail +! [ 1 \ + curry ] must-fail diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 0717a6729c..1158d60951 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -85,7 +85,8 @@ SYMBOL: load-vocab-hook TUPLE: vocab-link name root ; -C: vocab-link +: ( name root -- vocab-link ) + [ dup vocab-root ] unless* vocab-link construct-boa ; M: vocab-link equal? over vocab-link? @@ -103,9 +104,7 @@ M: vocab >vocab-link drop ; M: vocab-link >vocab-link drop ; M: string >vocab-link - over vocab dup [ 2nip ] [ - drop [ dup vocab-root ] unless* - ] if ; + over vocab dup [ 2nip ] [ drop ] if ; UNION: vocab-spec vocab vocab-link ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 24d70a86c6..5012d9280b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -4,11 +4,7 @@ IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test -[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test -[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test -[ 328350 ] [ 100 [ sq ] sigma ] unit-test -[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test @@ -17,11 +13,6 @@ IN: temporary [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer -{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test -{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer -{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test [ [ sq ] 3apply ] must-infer @@ -55,5 +46,3 @@ IN: temporary [ dup array? ] [ dup vector? ] [ dup float? ] } || nip ] unit-test - -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor old mode 100644 new mode 100755 index d0bc0a9e52..13e2919fd2 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: arrays kernel sequences sequences.lib math -math.functions tools.test strings ; +math.functions tools.test strings math.ranges ; [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test @@ -53,3 +53,16 @@ math.functions tools.test strings ; [ 2 ] [ { 1 2 3 } ?second ] unit-test [ 3 ] [ { 1 2 3 } ?third ] unit-test [ f ] [ { 1 2 3 } ?fourth ] unit-test + +[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test +[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test +[ 328350 ] [ 100 [ sq ] sigma ] unit-test + +[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer +{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test +{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test +[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer +{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test +[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test + +[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor old mode 100644 new mode 100755 index 4b3f1d5a6d..fc7960e475 --- a/extra/tools/browser/browser-tests.factor +++ b/extra/tools/browser/browser-tests.factor @@ -1,6 +1,4 @@ IN: temporary USING: tools.browser tools.test help.markup ; -[ t ] [ "resource:core" "kernel" vocab-dir? ] unit-test - [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test From 1db4c9cc8a9369c0d3ef2fcf9c618cb732d6ec3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 14:51:20 -0600 Subject: [PATCH 25/25] Fix type inference regression --- core/inference/class/class.factor | 16 +++++----------- core/inference/known-words/known-words.factor | 1 + 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 3555725c1f..690571de98 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -185,20 +185,14 @@ M: pair constraint-satisfied? [ swap predicate-constraints ] [ 2drop ] if ] if* ; -: default-output-classes ( word -- classes ) - "inferred-effect" word-prop { - { [ dup not ] [ drop f ] } - { [ dup effect-out [ class? ] all? not ] [ drop f ] } - { [ t ] [ effect-out ] } - } cond ; - : compute-output-classes ( node word -- classes intervals ) - dup node-param "output-classes" word-prop dup - [ call ] [ 2drop f f ] if ; + dup node-param "output-classes" word-prop + dup [ call ] [ 2drop f f ] if ; : output-classes ( node -- classes intervals ) - dup compute-output-classes - >r [ ] [ node-param default-output-classes ] ?if r> ; + dup compute-output-classes >r + [ ] [ node-param "default-output-classes" word-prop ] ?if + r> ; M: #call infer-classes-before dup compute-constraints diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index f92987f15f..e6479d0c6a 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -147,6 +147,7 @@ M: object infer-call ] "infer" set-word-prop : set-primitive-effect ( word effect -- ) + 2dup effect-out "default-output-classes" set-word-prop dupd [ make-call-node ] 2curry "infer" set-word-prop ; ! Stack effects for all primitives