Merge branch 'master' of git://factorcode.org/git/factor
commit
9be4bf0030
|
@ -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 [
|
||||
|
|
|
@ -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 )
|
||||
|
@ -136,7 +136,7 @@ SYMBOL: undefined-quot
|
|||
: here-as ( tag -- pointer ) here swap bitor ;
|
||||
|
||||
: align-here ( -- )
|
||||
here 8 mod 4 = [ 0 emit ] when ;
|
||||
here 8 mod 4 = [ heap-size drop 0 emit ] when ;
|
||||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
|
@ -177,6 +177,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
[ dup bignum-bits neg shift swap bignum-radix bitand ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
USE: continuations
|
||||
: emit-bignum ( n -- )
|
||||
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
|
||||
dup length 1+ emit-fixnum
|
||||
|
@ -214,10 +215,6 @@ M: f '
|
|||
: 1, 1 >bignum ' 1-offset fixup ;
|
||||
: -1, -1 >bignum ' -1-offset fixup ;
|
||||
|
||||
! Beginning of the image
|
||||
|
||||
: begin-image ( -- ) emit-header t, 0, 1, -1, ;
|
||||
|
||||
! Words
|
||||
|
||||
: emit-word ( word -- )
|
||||
|
@ -385,7 +382,10 @@ M: curry '
|
|||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
||||
: end-image ( -- )
|
||||
: build-image ( -- image )
|
||||
800000 <vector> image set
|
||||
20000 <hashtable> objects set
|
||||
emit-header t, 0, 1, -1,
|
||||
"Serializing words..." print flush
|
||||
emit-words
|
||||
"Serializing JIT data..." print flush
|
||||
|
@ -400,7 +400,8 @@ M: curry '
|
|||
fixup-header
|
||||
"Image length: " write image get length .
|
||||
"Object cache size: " write objects get assoc-size .
|
||||
\ word global delete-at ;
|
||||
\ word global delete-at
|
||||
image get ;
|
||||
|
||||
! Image output
|
||||
|
||||
|
@ -411,28 +412,23 @@ M: curry '
|
|||
[ >le write ] curry each
|
||||
] if ;
|
||||
|
||||
: write-image ( image filename -- )
|
||||
"Writing image to " write dup write "..." print flush
|
||||
: write-image ( image -- )
|
||||
"Writing image to " write
|
||||
architecture get boot-image-name resource-path
|
||||
dup write "..." print flush
|
||||
<file-writer> [ (write-image) ] with-stream ;
|
||||
|
||||
: prepare-image ( -- )
|
||||
bootstrapping? on
|
||||
load-help? off
|
||||
800000 <vector> image set
|
||||
20000 <hashtable> objects set ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: make-image ( arch -- )
|
||||
architecture [
|
||||
prepare-image
|
||||
begin-image
|
||||
[
|
||||
architecture set
|
||||
bootstrapping? on
|
||||
load-help? off
|
||||
"resource:/core/bootstrap/stage1.factor" run-file
|
||||
end-image
|
||||
image get
|
||||
architecture get boot-image-name resource-path
|
||||
build-image
|
||||
write-image
|
||||
] with-variable ;
|
||||
] with-scope ;
|
||||
|
||||
: make-images ( -- )
|
||||
images [ make-image ] each ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -20,7 +20,9 @@ PREDICATE: class tuple-class
|
|||
|
||||
: classes ( -- seq ) class<map get keys ;
|
||||
|
||||
: type>class ( n -- class ) builtins get nth ;
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||
|
||||
: predicate-word ( word -- predicate )
|
||||
[ word-name "?" append ] keep word-vocabulary create ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -4,12 +4,6 @@ IN: combinators
|
|||
USING: arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: dispatch ( n array -- ) array-nth (call) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: no-cond ;
|
||||
|
||||
: no-cond ( -- * ) \ no-cond construct-empty throw ;
|
||||
|
|
|
@ -1,7 +0,0 @@
|
|||
IN: temporary
|
||||
USING: tools.browser tools.test kernel sequences vocabs ;
|
||||
|
||||
"compiler.test" child-vocabs empty? [
|
||||
"compiler.test" load-children
|
||||
"compiler.test" test
|
||||
] when
|
|
@ -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." } ;
|
||||
|
|
|
@ -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+ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: compiler-errors
|
||||
|
||||
SYMBOL: with-compiler-errors?
|
||||
|
||||
: compiler-error ( error word -- )
|
||||
with-compiler-errors? get [
|
||||
compiler-errors get pick
|
||||
[ set-at ] [ delete-at drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: compiler-error. ( error word -- )
|
||||
nl
|
||||
"While compiling " write pprint ": " print
|
||||
nl
|
||||
print-error ;
|
||||
|
||||
: compiler-errors. ( assoc -- )
|
||||
>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 ] [
|
||||
|
|
|
@ -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 ) <array> >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
|
|
@ -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
|
|
@ -1,6 +1,6 @@
|
|||
USING: compiler tools.test kernel kernel.private
|
||||
combinators.private math.private math combinators strings
|
||||
alien arrays ;
|
||||
sequences.private math.private math combinators strings
|
||||
alien arrays memory ;
|
||||
IN: temporary
|
||||
|
||||
! Test empty word
|
||||
|
@ -48,6 +48,8 @@ IN: temporary
|
|||
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
|
||||
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
|
||||
|
||||
[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
|
||||
|
||||
! Labels
|
||||
|
||||
: recursive ( ? -- ) [ f recursive ] when ; inline
|
|
@ -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
|
||||
|
|
@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
|
|||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-t compiler-backend ( label -- )
|
||||
|
||||
HOOK: %call-dispatch compiler-backend ( -- label )
|
||||
|
||||
HOOK: %jump-dispatch compiler-backend ( -- )
|
||||
HOOK: %dispatch compiler-backend ( -- )
|
||||
|
||||
HOOK: %dispatch-label compiler-backend ( word -- )
|
||||
|
||||
|
|
|
@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
|
|||
M: ppc-backend %jump-t ( label -- )
|
||||
0 "flag" operand f v>operand CMPI BNE ;
|
||||
|
||||
: (%dispatch) ( len -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||
"offset" operand "n" operand 1 SRAWI
|
||||
11 11 "offset" operand ADD
|
||||
11 dup rot cells LWZ ;
|
||||
|
||||
M: ppc-backend %call-dispatch ( word-table# -- )
|
||||
[ 7 (%dispatch) (%call) <label> dup B ] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
} with-template ;
|
||||
|
||||
M: ppc-backend %jump-dispatch ( -- )
|
||||
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
|
||||
M: ppc-backend %dispatch ( -- )
|
||||
[
|
||||
%epilogue-later
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||
"offset" operand "n" operand 1 SRAWI
|
||||
11 11 "offset" operand ADD
|
||||
11 dup 6 cells LWZ
|
||||
(%jump)
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
} with-template ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
|
|||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
cpu.x86.allot cpu.architecture kernel kernel.private math
|
||||
namespaces sequences generator.registers generator.fixup system
|
||||
alien alien.compiler alien.structs slots splitting assocs ;
|
||||
alien alien.accessors alien.compiler alien.structs slots
|
||||
splitting assocs ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
PREDICATE: x86-backend amd64-backend
|
||||
|
|
|
@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
|
|||
M: x86-backend %jump-t ( label -- )
|
||||
"flag" operand f v>operand CMP JNE ;
|
||||
|
||||
: (%dispatch) ( n -- operand )
|
||||
! Load jump table base. We use a temporary register
|
||||
! since on AMD64 we have to load a 64-bit immediate. On
|
||||
! x86, this is redundant.
|
||||
! Untag and multiply to get a jump table offset
|
||||
"n" operand fixnum>slot@
|
||||
! Add jump table base
|
||||
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
"n" operand "offset" operand ADD
|
||||
"n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
|
||||
: code-alignment ( -- n )
|
||||
building get length dup cell align swap - ;
|
||||
|
||||
M: x86-backend %call-dispatch ( word-table# -- )
|
||||
[ 5 (%dispatch) CALL <label> dup JMP ] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
{ +clobber+ { "n" } }
|
||||
} with-template ;
|
||||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86-backend %jump-dispatch ( -- )
|
||||
[ %epilogue-later 0 (%dispatch) JMP ] H{
|
||||
M: x86-backend %dispatch ( -- )
|
||||
[
|
||||
%epilogue-later
|
||||
! Load jump table base. We use a temporary register
|
||||
! since on AMD64 we have to load a 64-bit immediate. On
|
||||
! x86, this is redundant.
|
||||
! Untag and multiply to get a jump table offset
|
||||
"n" operand fixnum>slot@
|
||||
! Add jump table base
|
||||
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
"n" operand "offset" operand ADD
|
||||
"n" operand HEX: 7f [+] JMP
|
||||
! Fix up the displacement above
|
||||
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
||||
building get dup pop* push
|
||||
align-code
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
{ +clobber+ { "n" } }
|
||||
|
|
|
@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
|
|||
: generate-nodes ( node -- )
|
||||
[ node@ generate-node ] iterate-nodes end-basic-block ;
|
||||
|
||||
: init-generate-nodes ( -- )
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label ;
|
||||
|
||||
: generate ( word label node -- )
|
||||
[
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label
|
||||
init-generate-nodes
|
||||
[ generate-nodes ] with-node-iterator
|
||||
] generate-1 ;
|
||||
|
||||
|
@ -168,17 +171,23 @@ M: #if generate-node
|
|||
] if %dispatch-label
|
||||
] each ;
|
||||
|
||||
: generate-dispatch ( node -- )
|
||||
%dispatch dispatch-branches init-templates ;
|
||||
|
||||
M: #dispatch generate-node
|
||||
#! The order here is important, dispatch-branches must
|
||||
#! run after %dispatch, so that each branch gets the
|
||||
#! correct register state
|
||||
tail-call? [
|
||||
%jump-dispatch dispatch-branches
|
||||
generate-dispatch iterate-next
|
||||
] [
|
||||
0 frame-required
|
||||
%call-dispatch >r dispatch-branches r> resolve-label
|
||||
] if
|
||||
init-templates iterate-next ;
|
||||
compiling-word get gensym [
|
||||
rot [
|
||||
init-generate-nodes
|
||||
generate-dispatch
|
||||
] generate-1
|
||||
] keep generate-call
|
||||
] if ;
|
||||
|
||||
! #call
|
||||
: define-intrinsics ( word intrinsics -- )
|
||||
|
|
|
@ -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 -- ? )
|
||||
|
@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
|
|||
: math-vtable* ( picker max quot -- quot )
|
||||
[
|
||||
rot , \ tag ,
|
||||
[ >r [ type>class ] map r> map % ] { } make ,
|
||||
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
|
||||
\ dispatch ,
|
||||
] [ ] make ; inline
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
|
|||
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||
|
||||
: vtable-class ( n -- class )
|
||||
type>class [ hi-tag bootstrap-word ] unless* ;
|
||||
bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
|
||||
|
||||
: group-methods ( assoc -- vtable )
|
||||
#! Input is a predicate -> method association.
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
|
|||
init-inference
|
||||
dependencies off
|
||||
dup word-def over dup infer-quot-recursive
|
||||
end-infer
|
||||
finish-word
|
||||
current-effect
|
||||
] with-scope
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
|
|||
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 combinators.private ;
|
||||
debugger threads.private io.streams.string io.timeouts
|
||||
sequences.private ;
|
||||
IN: temporary
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
|
@ -536,3 +537,8 @@ TUPLE: custom-error ;
|
|||
! This was a false trigger of the undecidable quotation
|
||||
! recursion bug
|
||||
{ 2 1 } [ find-last-sep ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: missing->r-check >r ;
|
||||
|
||||
[ [ missing->r-check ] infer ] must-fail
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -52,6 +52,21 @@ HELP: <file-appender>
|
|||
{ $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." }
|
||||
|
|
|
@ -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 "." = ] [ ] }
|
||||
|
|
|
@ -22,8 +22,7 @@ $nl
|
|||
{ $subsection make-block-stream }
|
||||
{ $subsection make-cell-stream }
|
||||
{ $subsection stream-write-table }
|
||||
"Optional word for network streams:"
|
||||
{ $subsection set-timeout } ;
|
||||
{ $see-also "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "stdio" "The default stream"
|
||||
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
|
||||
|
@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
|
|||
|
||||
ABOUT: "streams"
|
||||
|
||||
HELP: set-timeout
|
||||
{ $values { "n" "an integer" } { "stream" "a stream" } }
|
||||
{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
|
||||
{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
|
||||
|
||||
HELP: stream-readln
|
||||
{ $values { "stream" "an input stream" } { "str" string } }
|
||||
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
|
|
|
@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
|
|||
continuations assocs io.styles sbufs ;
|
||||
IN: io
|
||||
|
||||
GENERIC: set-timeout ( n stream -- )
|
||||
GENERIC: stream-readln ( stream -- str )
|
||||
GENERIC: stream-read1 ( stream -- ch/f )
|
||||
GENERIC: stream-read ( n stream -- str/f )
|
||||
|
|
|
@ -74,8 +74,3 @@ M: duplex-stream dispose
|
|||
[ dup duplex-stream-out dispose ]
|
||||
[ dup duplex-stream-in dispose ] [ ] cleanup
|
||||
] unless drop ;
|
||||
|
||||
M: duplex-stream set-timeout
|
||||
2dup
|
||||
duplex-stream-in set-timeout
|
||||
duplex-stream-out set-timeout ;
|
||||
|
|
|
@ -17,6 +17,7 @@ IN: kernel
|
|||
: clear ( -- ) { } set-datastack ;
|
||||
|
||||
! Combinators
|
||||
|
||||
: call ( callable -- ) uncurry (call) ;
|
||||
|
||||
DEFER: if
|
||||
|
|
|
@ -41,6 +41,9 @@ DEFER: base>
|
|||
<PRIVATE
|
||||
|
||||
SYMBOL: radix
|
||||
SYMBOL: negative?
|
||||
|
||||
: sign negative? get "-" "+" ? ;
|
||||
|
||||
: with-radix ( radix quot -- )
|
||||
radix swap with-variable ; inline
|
||||
|
@ -48,7 +51,7 @@ SYMBOL: radix
|
|||
: (base>) ( str -- n ) radix get base> ;
|
||||
|
||||
: whole-part ( str -- m n )
|
||||
"+" split1 >r (base>) r>
|
||||
sign split1 >r (base>) r>
|
||||
dup [ (base>) ] [ drop 0 swap ] if ;
|
||||
|
||||
: string>ratio ( str -- a/b )
|
||||
|
@ -70,7 +73,7 @@ PRIVATE>
|
|||
|
||||
: base> ( str radix -- n/f )
|
||||
[
|
||||
"-" ?head >r
|
||||
"-" ?head dup negative? set >r
|
||||
{
|
||||
{ [ CHAR: / over member? ] [ string>ratio ] }
|
||||
{ [ CHAR: . over member? ] [ string>float ] }
|
||||
|
@ -114,9 +117,9 @@ M: integer >base
|
|||
M: ratio >base
|
||||
[
|
||||
[
|
||||
dup 0 < [ "-" % neg ] when
|
||||
dup 0 < dup negative? set [ "-" % neg ] when
|
||||
1 /mod
|
||||
>r dup zero? [ drop ] [ (>base) % "+" % ] if r>
|
||||
>r dup zero? [ drop ] [ (>base) % sign % ] if r>
|
||||
dup numerator (>base) %
|
||||
"/" %
|
||||
denominator (>base) %
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 <tuple> and <tuple-boa> has the class which is
|
||||
! its second-to-last input
|
||||
|
@ -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
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: optimizer
|
|||
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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
@ -606,7 +608,29 @@ 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 )
|
||||
#! 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 ;
|
||||
|
@ -657,8 +681,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 ;
|
||||
|
|
|
@ -4,8 +4,6 @@ USING: arrays kernel math sequences vectors
|
|||
sequences sequences.private growable ;
|
||||
IN: sorting
|
||||
|
||||
: midpoint@ ( seq -- n ) length 2/ ; inline
|
||||
|
||||
DEFER: sort
|
||||
|
||||
<PRIVATE
|
||||
|
@ -38,9 +36,6 @@ DEFER: sort
|
|||
rot length rot length + <vector>
|
||||
[ (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 <= [
|
||||
|
|
|
@ -26,7 +26,7 @@ uses definitions ;
|
|||
rot source-file-checksum
|
||||
(source-modified?)
|
||||
] [
|
||||
?resource-path exists?
|
||||
resource-exists?
|
||||
] ?if ;
|
||||
|
||||
: record-modified ( source-file -- )
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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 "tests" 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 ;
|
||||
|
|
|
@ -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 <vocab-link> ] 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* <vocab-link>
|
||||
] if ;
|
||||
|
||||
UNION: vocab-spec vocab vocab-link ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test base64 ;
|
||||
USING: kernel tools.test base64 strings ;
|
||||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
|
||||
] unit-test
|
||||
|
|
|
@ -35,13 +35,13 @@ PRIVATE>
|
|||
#! pad string with = when not enough bits
|
||||
dup length dup 3 mod - cut swap
|
||||
[
|
||||
3 group [ encode3 % ] each
|
||||
3 <groups> [ 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 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
|
||||
] SBUF" " make swap [ dup pop* ] times >string ;
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel.private kernel sequences math combinators
|
||||
combinators.private ;
|
||||
sequences.private ;
|
||||
IN: benchmark.dispatch4
|
||||
|
||||
: foobar-1
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
|
||||
USING: kernel io io.files io.launcher hashtables
|
||||
USING: kernel io io.files io.launcher io.sockets hashtables
|
||||
system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators bootstrap.image bootstrap.image.download ;
|
||||
combinators bootstrap.image bootstrap.image.download
|
||||
combinators.cleave ;
|
||||
|
||||
IN: builder
|
||||
|
||||
|
@ -29,16 +30,34 @@ IN: builder
|
|||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: host-name* ( -- name ) host-name "." split first ;
|
||||
|
||||
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
|
||||
: email-file ( subject file -- )
|
||||
`{
|
||||
{ +stdin+ , }
|
||||
{ +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } }
|
||||
{ +arguments+
|
||||
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
|
||||
}
|
||||
>hashtable run-process drop ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" , %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run-or-notify ( desc message -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ email-string throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
: run-or-send-file ( desc message file -- )
|
||||
>r >r [ try-process ] curry
|
||||
r> r> [ email-file throw ] 2curry
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -59,71 +78,44 @@ VAR: stamp
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: build-status
|
||||
|
||||
: build ( -- )
|
||||
|
||||
"running" build-status set-global
|
||||
|
||||
datestamp >stamp
|
||||
|
||||
"/builds/factor" cd
|
||||
|
||||
: git-pull ( -- desc )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
"master"
|
||||
}
|
||||
run-process process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: git pull" email-string
|
||||
"builder: git pull" throw
|
||||
]
|
||||
if
|
||||
} ;
|
||||
|
||||
{
|
||||
"git" "pull" "--no-summary"
|
||||
"http://dharmatech.onigirihouse.com/factor.git" "master"
|
||||
} run-process drop
|
||||
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
|
||||
|
||||
"/builds/" stamp> append make-directory
|
||||
"/builds/" stamp> append cd
|
||||
|
||||
{ "git" "clone" "../factor" } run-process drop
|
||||
|
||||
"factor" cd
|
||||
: enter-build-dir ( -- )
|
||||
datestamp >stamp
|
||||
"/builds" cd
|
||||
stamp> make-directory
|
||||
stamp> cd ;
|
||||
|
||||
: record-git-id ( -- )
|
||||
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second
|
||||
"../git-id" log-object
|
||||
"../git-id" log-object ;
|
||||
|
||||
{ "make" "clean" } run-process drop
|
||||
|
||||
! "vm" build-status set-global
|
||||
: make-clean ( -- desc ) { "make" "clean" } ;
|
||||
|
||||
: make-vm ( -- )
|
||||
`{
|
||||
{ +arguments+ { "make" ,[ target ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable run-process process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: vm compile" "../compile-log" email-file
|
||||
"builder: vm compile" throw
|
||||
] if
|
||||
>hashtable ;
|
||||
|
||||
: retrieve-boot-image ( -- )
|
||||
[ my-arch download-image ]
|
||||
[ ]
|
||||
[ "builder: image download" email-string ]
|
||||
cleanup
|
||||
|
||||
! "bootstrap" build-status set-global
|
||||
cleanup ;
|
||||
|
||||
: bootstrap ( -- desc )
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
|
@ -133,29 +125,49 @@ SYMBOL: build-status
|
|||
{ +stdout+ "../boot-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable [ run-process ] "../boot-time" log-runtime process-status
|
||||
0 =
|
||||
[ ]
|
||||
[
|
||||
"builder: bootstrap" "../boot-log" email-file
|
||||
"builder: bootstrap" throw
|
||||
] if
|
||||
>hashtable ;
|
||||
|
||||
! "test" build-status set-global
|
||||
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
`{ ,[ factor-binary ] "-run=builder.test" } run-process drop
|
||||
SYMBOL: build-status
|
||||
|
||||
: build ( -- )
|
||||
|
||||
"running" build-status set-global
|
||||
|
||||
"/builds/factor" cd
|
||||
|
||||
git-pull "git pull error" run-or-notify
|
||||
|
||||
enter-build-dir
|
||||
|
||||
git-clone "git clone error" run-or-notify
|
||||
|
||||
"factor" cd
|
||||
|
||||
record-git-id
|
||||
|
||||
make-clean "make clean error" run-or-notify
|
||||
|
||||
make-vm "vm compile error" "../compile-log" run-or-send-file
|
||||
|
||||
retrieve-boot-image
|
||||
|
||||
bootstrap "bootstrap error" "../boot-log" run-or-send-file
|
||||
|
||||
builder-test "builder.test fatal error" run-or-notify
|
||||
|
||||
"../load-everything-log" exists?
|
||||
[ "builder: load-everything" "../load-everything-log" email-file ]
|
||||
[ "load-everything" "../load-everything-log" email-file ]
|
||||
when
|
||||
|
||||
"../failing-tests" exists?
|
||||
[ "builder: failing tests" "../failing-tests" email-file ]
|
||||
[ "failing tests" "../failing-tests" email-file ]
|
||||
when
|
||||
|
||||
! "ready" build-status set-global
|
||||
|
||||
;
|
||||
"ready" build-status set-global ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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 <reversed> r>
|
||||
! 1quotation swap alist>quot ;
|
||||
|
||||
: short-circuit ( quots quot default -- quot )
|
||||
1quotation -rot { } map>assoc <reversed> alist>quot ;
|
||||
|
||||
! : short-circuit ( quots quot default -- quot )
|
||||
! 1quotation -rot map>alist <reversed> 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
|
||||
|
|
|
@ -133,4 +133,9 @@ SYMBOL: value
|
|||
[ 3 3 ] [
|
||||
[ 3 ] future
|
||||
dup ?future swap ?future
|
||||
] unit-test
|
||||
|
||||
! Another race
|
||||
[ 3 ] [
|
||||
[ 3 yield ] future ?future
|
||||
] unit-test
|
|
@ -273,14 +273,14 @@ TUPLE: future value processes ;
|
|||
|
||||
: future ( quot -- future )
|
||||
#! Spawn a process to call the quotation and immediately return.
|
||||
\ future construct-empty [
|
||||
f V{ } clone \ future construct-boa [
|
||||
[
|
||||
>r [ t 2array ] compose [ f 2array ] recover r>
|
||||
notify-future
|
||||
] 2curry spawn drop
|
||||
] keep ;
|
||||
|
||||
: ?future ( future -- result )
|
||||
|
||||
: ?future ( future -- result )
|
||||
#! Block the process until the future has completed and then
|
||||
#! place the result on the stack. Return the result
|
||||
#! immediately if the future has completed.
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -153,7 +153,7 @@ SYMBOL: old-d
|
|||
dup S44 64 9 [ I ] BCDA ;
|
||||
|
||||
: (process-md5-block) ( block -- )
|
||||
4 group [ le> ] map
|
||||
4 <groups> [ le> ] map
|
||||
|
||||
(process-md5-block-F)
|
||||
(process-md5-block-G)
|
||||
|
|
|
@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
|
|||
namespaces sequences sequences.lib tuples words ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle ;
|
||||
C: <db> db ( handle -- obj )
|
||||
TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
|
||||
: <db> ( 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 ;
|
||||
|
|
|
@ -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 <simple-statement> ( str -- statement )
|
||||
;
|
||||
|
||||
|
|
|
@ -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 ) ;
|
||||
|
|
|
@ -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*" <c-object> "void*" <c-object>
|
||||
|
|
|
@ -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 <db>
|
||||
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 <sqlite-db> 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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
: <person> ( 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 <sqlite-db> [
|
||||
test-tuples
|
||||
] with-db ;
|
||||
|
||||
test-sqlite
|
||||
|
||||
! : test-postgres ( -- )
|
||||
! resource-path <postgresql-db> [
|
||||
! test-tuples
|
||||
! ] with-db ;
|
|
@ -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
|
||||
[ <prepared-statement> ] 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 ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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* ;
|
|
@ -18,7 +18,7 @@ PROTOCOL: stream-protocol
|
|||
stream-read1 stream-read stream-read-until
|
||||
stream-flush stream-write1 stream-write stream-format
|
||||
stream-nl make-span-stream make-block-stream stream-readln
|
||||
make-cell-stream stream-write-table set-timeout ;
|
||||
make-cell-stream stream-write-table ;
|
||||
|
||||
PROTOCOL: definition-protocol
|
||||
where set-where forget uses redefined*
|
||||
|
|
|
@ -189,7 +189,7 @@ SYMBOL: model
|
|||
swap [ render-template ] with-slots ;
|
||||
|
||||
: browse-webapp-source ( vocab -- )
|
||||
<a f >vocab-link browser-link-href =href a>
|
||||
<a vocab browser-link-href =href a>
|
||||
"Browse source" write
|
||||
</a> ;
|
||||
|
||||
|
|
|
@ -157,7 +157,8 @@ ARTICLE: "io" "Input and output"
|
|||
"Advanced features:"
|
||||
{ $subsection "io.launcher" }
|
||||
{ $subsection "io.mmap" }
|
||||
{ $subsection "io.monitors" } ;
|
||||
{ $subsection "io.monitors" }
|
||||
{ $subsection "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "tools" "Developer tools"
|
||||
{ $subsection "tools.annotations" }
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs http kernel math math.parser namespaces sequences
|
||||
io io.sockets io.streams.string io.files strings splitting
|
||||
continuations assocs.lib ;
|
||||
io io.sockets io.streams.string io.files io.timeouts strings
|
||||
splitting continuations assocs.lib ;
|
||||
IN: http.client
|
||||
|
||||
: parse-host ( url -- host port )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel namespaces io strings splitting
|
||||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||
threads http http.server.responders sequences prettyprint
|
||||
io.server logging ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -76,6 +76,9 @@ HELP: +append-environment+
|
|||
$nl
|
||||
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
|
||||
|
||||
HELP: +timeout+
|
||||
{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
|
||||
|
||||
HELP: default-descriptor
|
||||
{ $description "Association storing default values for launch descriptor keys." } ;
|
||||
|
||||
|
@ -94,22 +97,16 @@ HELP: run-process*
|
|||
|
||||
HELP: >descriptor
|
||||
{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
|
||||
{ $description "Creates a launch descriptor from an object, which must be one of the following:"
|
||||
{ $list
|
||||
{ "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
|
||||
{ "a sequence of strings -- this is wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
|
||||
{ "an association, used to set launch parameters for additional control" }
|
||||
}
|
||||
} ;
|
||||
{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
|
||||
|
||||
HELP: run-process
|
||||
{ $values { "desc" "a launch descriptor" } { "process" process } }
|
||||
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
|
||||
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
|
||||
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
|
||||
|
||||
HELP: run-detached
|
||||
{ $values { "desc" "a launch descriptor" } { "process" process } }
|
||||
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
|
||||
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
|
||||
{ $notes
|
||||
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
|
||||
$nl
|
||||
|
@ -162,25 +159,27 @@ HELP: wait-for-process
|
|||
{ $values { "process" process } { "status" integer } }
|
||||
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
|
||||
|
||||
ARTICLE: "io.launcher" "Launching OS processes"
|
||||
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
|
||||
$nl
|
||||
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a launch descriptor:"
|
||||
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
|
||||
"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
|
||||
{ $list
|
||||
{ "strings are wrapped in a launch descriptor with a single " { $link +command+ } " key" }
|
||||
{ "sequences of strings are wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
|
||||
{ "launch descriptors are associations, which can set extra launch parameters for finer control" }
|
||||
{ "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
|
||||
{ "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
|
||||
{ "associations can be passed in, which allows finer control over launch parameters" }
|
||||
}
|
||||
"A launch descriptor is an association containing keys from the below set:"
|
||||
"The associations can contain the following keys:"
|
||||
{ $subsection +command+ }
|
||||
{ $subsection +arguments+ }
|
||||
{ $subsection +detached+ }
|
||||
{ $subsection +environment+ }
|
||||
{ $subsection +environment-mode+ }
|
||||
"Redirecting standard input and output to files:"
|
||||
{ $subsection +timeout+ }
|
||||
{ $subsection +stdin+ }
|
||||
{ $subsection +stdout+ }
|
||||
{ $subsection +stderr+ }
|
||||
{ $subsection +stderr+ } ;
|
||||
|
||||
ARTICLE: "io.launcher" "Launching OS processes"
|
||||
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
|
||||
{ $subsection "io.launcher.descriptors" }
|
||||
"The following words are used to launch processes:"
|
||||
{ $subsection run-process }
|
||||
{ $subsection run-detached }
|
||||
|
@ -193,6 +192,7 @@ $nl
|
|||
"A class representing an active or finished process:"
|
||||
{ $subsection process }
|
||||
"Waiting for a process to end, or getting the exit code of a finished process:"
|
||||
{ $subsection wait-for-process } ;
|
||||
{ $subsection wait-for-process }
|
||||
"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
|
||||
|
||||
ABOUT: "io.launcher"
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.backend system kernel namespaces strings hashtables
|
||||
sequences assocs combinators vocabs.loader init threads
|
||||
continuations math ;
|
||||
USING: io io.backend io.timeouts system kernel namespaces
|
||||
strings hashtables sequences assocs combinators vocabs.loader
|
||||
init threads continuations math ;
|
||||
IN: io.launcher
|
||||
|
||||
! Non-blocking process exit notification facility
|
||||
|
@ -10,14 +10,14 @@ SYMBOL: processes
|
|||
|
||||
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
|
||||
|
||||
TUPLE: process handle status ;
|
||||
TUPLE: process handle status killed? lapse ;
|
||||
|
||||
HOOK: register-process io-backend ( process -- )
|
||||
|
||||
M: object register-process drop ;
|
||||
|
||||
: <process> ( handle -- process )
|
||||
f process construct-boa
|
||||
f f <lapse> process construct-boa
|
||||
V{ } clone over processes get set-at
|
||||
dup register-process ;
|
||||
|
||||
|
@ -25,6 +25,8 @@ M: process equal? 2drop f ;
|
|||
|
||||
M: process hashcode* process-handle hashcode* ;
|
||||
|
||||
: process-running? ( process -- ? ) process-status not ;
|
||||
|
||||
SYMBOL: +command+
|
||||
SYMBOL: +arguments+
|
||||
SYMBOL: +detached+
|
||||
|
@ -34,6 +36,7 @@ SYMBOL: +stdin+
|
|||
SYMBOL: +stdout+
|
||||
SYMBOL: +stderr+
|
||||
SYMBOL: +closed+
|
||||
SYMBOL: +timeout+
|
||||
|
||||
SYMBOL: +prepend-environment+
|
||||
SYMBOL: +replace-environment+
|
||||
|
@ -63,22 +66,30 @@ SYMBOL: +append-environment+
|
|||
{ +replace-environment+ [ ] }
|
||||
} case ;
|
||||
|
||||
GENERIC: >descriptor ( desc -- desc )
|
||||
: string-array? ( obj -- ? )
|
||||
dup sequence? [ [ string? ] all? ] [ drop f ] if ;
|
||||
|
||||
M: string >descriptor +command+ associate ;
|
||||
M: sequence >descriptor +arguments+ associate ;
|
||||
M: assoc >descriptor >hashtable ;
|
||||
: >descriptor ( desc -- desc )
|
||||
{
|
||||
{ [ dup string? ] [ +command+ associate ] }
|
||||
{ [ dup string-array? ] [ +arguments+ associate ] }
|
||||
{ [ dup assoc? ] [ >hashtable ] }
|
||||
} cond ;
|
||||
|
||||
HOOK: run-process* io-backend ( desc -- handle )
|
||||
|
||||
: wait-for-process ( process -- status )
|
||||
dup process-handle [
|
||||
dup [ processes get at push stop ] curry callcc0
|
||||
] when process-status ;
|
||||
[
|
||||
dup process-handle
|
||||
[ dup [ processes get at push stop ] curry callcc0 ] when
|
||||
dup process-killed?
|
||||
[ "Process was killed" throw ] [ process-status ] if
|
||||
] with-timeout ;
|
||||
|
||||
: run-process ( desc -- process )
|
||||
>descriptor
|
||||
dup run-process*
|
||||
+timeout+ pick at [ over set-timeout ] when*
|
||||
+detached+ rot at [ dup wait-for-process drop ] unless ;
|
||||
|
||||
: run-detached ( desc -- process )
|
||||
|
@ -87,7 +98,7 @@ HOOK: run-process* io-backend ( desc -- handle )
|
|||
TUPLE: process-failed code ;
|
||||
|
||||
: process-failed ( code -- * )
|
||||
process-failed construct-boa throw ;
|
||||
\ process-failed construct-boa throw ;
|
||||
|
||||
: try-process ( desc -- )
|
||||
run-process wait-for-process dup zero?
|
||||
|
@ -96,8 +107,13 @@ TUPLE: process-failed code ;
|
|||
HOOK: kill-process* io-backend ( handle -- )
|
||||
|
||||
: kill-process ( process -- )
|
||||
t over set-process-killed?
|
||||
process-handle [ kill-process* ] when* ;
|
||||
|
||||
M: process get-lapse process-lapse ;
|
||||
|
||||
M: process timed-out kill-process ;
|
||||
|
||||
HOOK: process-stream* io-backend ( desc -- stream process )
|
||||
|
||||
TUPLE: process-stream process ;
|
||||
|
|
|
@ -38,8 +38,6 @@ $nl
|
|||
{ $list
|
||||
{ { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
|
||||
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
|
||||
{ { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
|
||||
{ { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
|
||||
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
|
||||
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
|
||||
} } ;
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.nonblocking
|
||||
USING: math kernel io sequences io.buffers generic sbufs system
|
||||
io.streams.lines io.streams.plain io.streams.duplex io.backend
|
||||
continuations debugger classes byte-arrays namespaces splitting
|
||||
dlists assocs ;
|
||||
USING: math kernel io sequences io.buffers io.timeouts generic
|
||||
sbufs system io.streams.lines io.streams.plain io.streams.duplex
|
||||
io.backend continuations debugger classes byte-arrays namespaces
|
||||
splitting dlists assocs ;
|
||||
|
||||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
@ -13,9 +13,12 @@ SYMBOL: default-buffer-size
|
|||
TUPLE: port
|
||||
handle
|
||||
error
|
||||
timeout-entry timeout cutoff
|
||||
lapse
|
||||
type eof? ;
|
||||
|
||||
! Ports support the lapse protocol
|
||||
M: port get-lapse port-lapse ;
|
||||
|
||||
SYMBOL: closed
|
||||
|
||||
PREDICATE: port input-port port-type input-port eq? ;
|
||||
|
@ -26,12 +29,11 @@ GENERIC: close-handle ( handle -- )
|
|||
|
||||
: <port> ( handle buffer type -- port )
|
||||
pick init-handle
|
||||
0 0 {
|
||||
<lapse> {
|
||||
set-port-handle
|
||||
set-delegate
|
||||
set-port-type
|
||||
set-port-timeout
|
||||
set-port-cutoff
|
||||
set-port-lapse
|
||||
} port construct ;
|
||||
|
||||
: <buffered-port> ( handle type -- port )
|
||||
|
@ -48,50 +50,14 @@ GENERIC: close-handle ( handle -- )
|
|||
[ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
|
||||
cleanup ;
|
||||
|
||||
: timeout? ( port -- ? )
|
||||
port-cutoff dup zero? not swap millis < and ;
|
||||
|
||||
: pending-error ( port -- )
|
||||
dup port-error f rot set-port-error [ throw ] when* ;
|
||||
|
||||
SYMBOL: timeout-queue
|
||||
|
||||
timeout-queue global [ [ <dlist> ] unless* ] change-at
|
||||
|
||||
: unqueue-timeout ( port -- )
|
||||
port-timeout-entry [
|
||||
timeout-queue get-global swap delete-node
|
||||
] when* ;
|
||||
|
||||
: queue-timeout ( port -- )
|
||||
dup timeout-queue get-global push-front*
|
||||
swap set-port-timeout-entry ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
|
||||
M: object cancel-io drop ;
|
||||
|
||||
: expire-timeouts ( -- )
|
||||
timeout-queue get-global dup dlist-empty? [ drop ] [
|
||||
dup peek-back timeout?
|
||||
[ pop-back cancel-io expire-timeouts ] [ drop ] if
|
||||
] if ;
|
||||
|
||||
: begin-timeout ( port -- )
|
||||
dup port-timeout dup zero? [
|
||||
2drop
|
||||
] [
|
||||
millis + over set-port-cutoff
|
||||
dup unqueue-timeout queue-timeout
|
||||
] if ;
|
||||
|
||||
: end-timeout ( port -- )
|
||||
unqueue-timeout ;
|
||||
|
||||
: with-port-timeout ( port quot -- )
|
||||
over begin-timeout keep end-timeout ; inline
|
||||
|
||||
M: port set-timeout set-port-timeout ;
|
||||
M: port timed-out cancel-io ;
|
||||
|
||||
GENERIC: (wait-to-read) ( port -- )
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.streams.null
|
||||
USING: kernel io continuations ;
|
||||
USING: kernel io io.timeouts continuations ;
|
||||
|
||||
TUPLE: null-stream ;
|
||||
|
||||
|
|
|
@ -0,0 +1,32 @@
|
|||
IN: io.timeouts
|
||||
USING: help.markup help.syntax math kernel ;
|
||||
|
||||
HELP: get-lapse
|
||||
{ $values { "obj" object } { "lapse" lapse } }
|
||||
{ $contract "Outputs an object's timeout lapse descriptor." } ;
|
||||
|
||||
HELP: set-timeout
|
||||
{ $values { "ms" integer } { "obj" object } }
|
||||
{ $contract "Sets an object's timeout, in milliseconds." }
|
||||
{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
|
||||
|
||||
HELP: timed-out
|
||||
{ $values { "obj" object } }
|
||||
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
|
||||
|
||||
HELP: with-timeout
|
||||
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
|
||||
|
||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
||||
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||
{ $subsection set-timeout }
|
||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||
{ $subsection get-lapse }
|
||||
{ $subsection timed-out }
|
||||
"A combinator to be used in operations which can time out:"
|
||||
{ $subsection with-timeout }
|
||||
{ $see-also "stream-protocol" "io.launcher" }
|
||||
;
|
||||
|
||||
ABOUT: "io.timeouts"
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math system dlists namespaces assocs init threads
|
||||
io.streams.duplex ;
|
||||
IN: io.timeouts
|
||||
|
||||
TUPLE: lapse entry timeout cutoff ;
|
||||
|
||||
: <lapse> f 0 0 \ lapse construct-boa ;
|
||||
|
||||
! Won't need this with new slot accessors
|
||||
GENERIC: get-lapse ( obj -- lapse )
|
||||
|
||||
GENERIC: set-timeout ( ms obj -- )
|
||||
|
||||
M: object set-timeout get-lapse set-timeout ;
|
||||
|
||||
M: lapse set-timeout set-lapse-timeout ;
|
||||
|
||||
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
|
||||
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
|
||||
: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
|
||||
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
|
||||
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
|
||||
|
||||
! Won't need this with inheritance
|
||||
TUPLE: duplex-stream-lapse stream ;
|
||||
|
||||
M: duplex-stream-lapse set-timeout
|
||||
duplex-stream-lapse-stream 2dup
|
||||
duplex-stream-in set-timeout
|
||||
duplex-stream-out set-timeout ;
|
||||
|
||||
M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
|
||||
|
||||
SYMBOL: timeout-queue
|
||||
|
||||
: timeout? ( lapse -- ? )
|
||||
cutoff dup zero? not swap millis < and ;
|
||||
|
||||
timeout-queue global [ [ <dlist> ] unless* ] change-at
|
||||
|
||||
: unqueue-timeout ( obj -- )
|
||||
entry [
|
||||
timeout-queue get-global swap delete-node
|
||||
] when* ;
|
||||
|
||||
: queue-timeout ( obj -- )
|
||||
dup timeout-queue get-global push-front*
|
||||
swap set-entry ;
|
||||
|
||||
GENERIC: timed-out ( obj -- )
|
||||
|
||||
M: object timed-out drop ;
|
||||
|
||||
: expire-timeouts ( -- )
|
||||
timeout-queue get-global dup dlist-empty? [ drop ] [
|
||||
dup peek-back timeout?
|
||||
[ pop-back timed-out expire-timeouts ] [ drop ] if
|
||||
] if ;
|
||||
|
||||
: begin-timeout ( obj -- )
|
||||
dup timeout dup zero? [
|
||||
2drop
|
||||
] [
|
||||
millis + over set-cutoff
|
||||
dup unqueue-timeout queue-timeout
|
||||
] if ;
|
||||
|
||||
: with-timeout ( obj quot -- )
|
||||
over begin-timeout keep unqueue-timeout ; inline
|
||||
|
||||
: expiry-thread ( -- )
|
||||
expire-timeouts 5000 sleep expiry-thread ;
|
||||
|
||||
[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien generic assocs kernel kernel.private math
|
||||
io.nonblocking sequences strings structs sbufs threads unix
|
||||
vectors io.buffers io.backend io.streams.duplex math.parser
|
||||
continuations system libc qualified namespaces ;
|
||||
continuations system libc qualified namespaces io.timeouts ;
|
||||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
|
@ -61,7 +61,7 @@ M: mx register-io-task ( task mx -- )
|
|||
mx get-global register-io-task stop ;
|
||||
|
||||
: with-port-continuation ( port quot -- port )
|
||||
[ callcc0 ] curry with-port-timeout ; inline
|
||||
[ callcc0 ] curry with-timeout ; inline
|
||||
|
||||
M: mx unregister-io-task ( task mx -- )
|
||||
fd/container delete-at drop ;
|
||||
|
@ -178,7 +178,7 @@ M: port port-flush ( port -- )
|
|||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: unix-io io-multiplex ( ms -- )
|
||||
expire-timeouts mx get-global wait-for-events ;
|
||||
mx get-global wait-for-events ;
|
||||
|
||||
M: unix-io init-stdio ( -- )
|
||||
0 1 handle>duplex-stream io:stdio set-global
|
||||
|
|
|
@ -49,7 +49,7 @@ MEMO: 'arguments' ( -- parser )
|
|||
|
||||
: redirect ( obj mode fd -- )
|
||||
{
|
||||
{ [ pick not ] [ 3drop ] }
|
||||
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
|
||||
{ [ pick +closed+ eq? ] [ close 2drop ] }
|
||||
{ [ pick string? ] [ (redirect) ] }
|
||||
} cond ;
|
||||
|
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.private io.files
|
||||
io.buffers io.nonblocking io.unix.backend io.unix.select
|
||||
io.unix.launcher unix.linux.inotify assocs namespaces threads
|
||||
continuations init math alien.c-types alien vocabs.loader ;
|
||||
USING: kernel io.backend io.monitors io.monitors.private
|
||||
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
|
||||
io.unix.select io.unix.launcher unix.linux.inotify assocs
|
||||
namespaces threads continuations init math alien.c-types alien
|
||||
vocabs.loader ;
|
||||
IN: io.unix.linux
|
||||
|
||||
TUPLE: linux-io ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: io.unix.backend io.unix.files io.unix.sockets
|
||||
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
|
||||
io.unix.launcher io.unix.mmap io.backend combinators namespaces
|
||||
system vocabs.loader ;
|
||||
|
||||
|
|
|
@ -55,7 +55,7 @@ M: windows-ce-io accept ( server -- client )
|
|||
] keep
|
||||
] keep server-port-addr parse-sockaddr swap
|
||||
<win32-socket> dup handle>duplex-stream <client-stream>
|
||||
] with-port-timeout ;
|
||||
] with-timeout ;
|
||||
|
||||
M: windows-ce-io <datagram> ( addrspec -- datagram )
|
||||
[
|
||||
|
|
|
@ -91,7 +91,7 @@ M: windows-nt-io cancel-io
|
|||
port-handle win32-file-handle CancelIo drop ;
|
||||
|
||||
M: windows-nt-io io-multiplex ( ms -- )
|
||||
expire-timeouts drain-overlapped ;
|
||||
drain-overlapped ;
|
||||
|
||||
M: windows-nt-io init-io ( -- )
|
||||
<master-completion-port> master-completion-port set-global
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue