Merge branch 'master' of factorcode.org:/git/factor
commit
5249016972
|
@ -397,7 +397,7 @@ M: quotation '
|
|||
[
|
||||
{
|
||||
dictionary source-files builtins
|
||||
update-map class<=-cache
|
||||
update-map implementors-map class<=-cache
|
||||
class-not-cache classes-intersect-cache class-and-cache
|
||||
class-or-cache
|
||||
} [ dup get swap bootstrap-word set ] each
|
||||
|
|
|
@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set
|
|||
H{ } clone root-cache set
|
||||
H{ } clone source-files set
|
||||
H{ } clone update-map set
|
||||
H{ } clone implementors-map set
|
||||
init-caches
|
||||
|
||||
! Vocabulary for slot accessors
|
||||
|
@ -492,7 +493,8 @@ tuple
|
|||
"curry" "kernel" lookup
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
|
||||
(( obj quot -- curry )) define-declared
|
||||
|
||||
"compose" "kernel" create
|
||||
tuple
|
||||
|
@ -513,7 +515,8 @@ tuple
|
|||
"compose" "kernel" lookup
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
|
||||
(( quot1 quot2 -- compose )) define-declared
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
|
|
|
@ -49,7 +49,7 @@ millis >r
|
|||
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
"math compiler help random tools ui ui.tools io handbook" "include" set-global
|
||||
"math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
parse-command-line
|
||||
|
|
|
@ -68,7 +68,10 @@ HELP: tuple-class
|
|||
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
|
||||
|
||||
HELP: update-map
|
||||
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
|
||||
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
|
||||
|
||||
! HELP: implementors-map
|
||||
! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ;
|
||||
|
||||
HELP: predicate-word
|
||||
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
|
||||
|
|
|
@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
|
|||
tools.test vectors words quotations classes
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
classes.algebra vectors definitions source-files
|
||||
compiler.units kernel.private ;
|
||||
compiler.units kernel.private sorting vocabs ;
|
||||
IN: classes.tests
|
||||
|
||||
! DEFER: bah
|
||||
|
@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ;
|
|||
[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
|
||||
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
|
||||
[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
all-words [ class? ] filter
|
||||
implementors-map get keys
|
||||
[ natural-sort ] bi@ =
|
||||
] unit-test
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions assocs kernel kernel.private
|
||||
slots.private namespaces sequences strings words vectors math
|
||||
quotations combinators sorting effects graphs vocabs ;
|
||||
quotations combinators sorting effects graphs vocabs sets ;
|
||||
IN: classes
|
||||
|
||||
SYMBOL: class<=-cache
|
||||
|
@ -27,24 +27,24 @@ SYMBOL: class-or-cache
|
|||
|
||||
SYMBOL: update-map
|
||||
|
||||
SYMBOL: implementors-map
|
||||
|
||||
PREDICATE: class < word
|
||||
"class" word-prop ;
|
||||
|
||||
PREDICATE: tuple-class < class
|
||||
"metaclass" word-prop tuple-class eq? ;
|
||||
|
||||
: classes ( -- seq ) all-words [ class? ] filter ;
|
||||
: classes ( -- seq ) implementors-map get keys ;
|
||||
|
||||
: predicate-word ( word -- predicate )
|
||||
[ word-name "?" append ] keep word-vocabulary create ;
|
||||
|
||||
: predicate-effect T{ effect f 1 { "?" } } ;
|
||||
|
||||
PREDICATE: predicate < word "predicating" word-prop >boolean ;
|
||||
|
||||
: define-predicate ( class quot -- )
|
||||
>r "predicate" word-prop first
|
||||
r> predicate-effect define-declared ;
|
||||
r> (( object -- ? )) define-declared ;
|
||||
|
||||
: superclass ( class -- super )
|
||||
#! Output f for non-classes to work with algebra code
|
||||
|
@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- )
|
|||
|
||||
M: word reset-class drop ;
|
||||
|
||||
GENERIC: implementors ( class/classes -- seq )
|
||||
|
||||
! update-map
|
||||
: class-uses ( class -- seq )
|
||||
[
|
||||
|
@ -87,6 +89,16 @@ M: word reset-class drop ;
|
|||
: update-map- ( class -- )
|
||||
dup class-uses update-map get remove-vertex ;
|
||||
|
||||
M: class implementors implementors-map get at keys ;
|
||||
|
||||
M: sequence implementors [ implementors ] gather ;
|
||||
|
||||
: implementors-map+ ( class -- )
|
||||
H{ } clone swap implementors-map get set-at ;
|
||||
|
||||
: implementors-map- ( class -- )
|
||||
implementors-map get delete-at ;
|
||||
|
||||
: make-class-props ( superclass members participants metaclass -- assoc )
|
||||
[
|
||||
{
|
||||
|
@ -99,7 +111,7 @@ M: word reset-class drop ;
|
|||
|
||||
: (define-class) ( word props -- )
|
||||
>r
|
||||
dup class? [ dup new-class ] unless
|
||||
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
|
||||
dup reset-class
|
||||
dup deferred? [ dup define-symbol ] when
|
||||
dup word-props
|
||||
|
@ -139,6 +151,23 @@ GENERIC: update-methods ( class seq -- )
|
|||
[ forget ] [ drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: forget-methods ( class -- )
|
||||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||
|
||||
: forget-class ( class -- )
|
||||
class-usages [
|
||||
{
|
||||
[ forget-predicate ]
|
||||
[ forget-methods ]
|
||||
[ implementors-map- ]
|
||||
[ update-map- ]
|
||||
[ reset-class ]
|
||||
} cleave
|
||||
] each ;
|
||||
|
||||
M: class forget* ( class -- )
|
||||
[ forget-class ] [ call-next-method ] bi ;
|
||||
|
||||
GENERIC: class ( object -- class )
|
||||
|
||||
: instance? ( obj class -- ? )
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words kernel sequences namespaces assocs hashtables
|
||||
definitions kernel.private classes classes.private
|
||||
classes.algebra quotations arrays vocabs effects combinators ;
|
||||
classes.algebra quotations arrays vocabs effects combinators
|
||||
sets ;
|
||||
IN: generic
|
||||
|
||||
! Method combination protocol
|
||||
|
@ -94,8 +95,13 @@ M: method-body crossref?
|
|||
method-word-name f <word>
|
||||
[ set-word-props ] keep ;
|
||||
|
||||
: with-implementors ( class generic quot -- )
|
||||
[ swap implementors-map get at ] dip call ; inline
|
||||
|
||||
: reveal-method ( method class generic -- )
|
||||
[ set-at ] with-methods ;
|
||||
[ [ conjoin ] with-implementors ]
|
||||
[ [ set-at ] with-methods ]
|
||||
2bi ;
|
||||
|
||||
: create-method ( class generic -- method )
|
||||
2dup method dup [
|
||||
|
@ -142,7 +148,11 @@ M: method-body forget*
|
|||
[ "method-generic" word-prop ] bi
|
||||
2dup method
|
||||
] keep eq?
|
||||
[ [ delete-at ] with-methods ] [ 2drop ] if
|
||||
[
|
||||
[ [ delete-at ] with-methods ]
|
||||
[ [ delete-at ] with-implementors ]
|
||||
2bi
|
||||
] [ 2drop ] if
|
||||
] if
|
||||
]
|
||||
[ call-next-method ] bi
|
||||
|
@ -151,33 +161,6 @@ M: method-body forget*
|
|||
M: method-body smart-usage
|
||||
"method-generic" word-prop smart-usage ;
|
||||
|
||||
GENERIC: implementors ( class/classes -- seq )
|
||||
|
||||
M: class implementors
|
||||
all-words [ "methods" word-prop key? ] with filter ;
|
||||
|
||||
M: sequence implementors
|
||||
all-words [
|
||||
"methods" word-prop keys
|
||||
swap [ memq? ] curry contains?
|
||||
] with filter ;
|
||||
|
||||
: forget-methods ( class -- )
|
||||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||
|
||||
: forget-class ( class -- )
|
||||
class-usages [
|
||||
{
|
||||
[ forget-predicate ]
|
||||
[ forget-methods ]
|
||||
[ update-map- ]
|
||||
[ reset-class ]
|
||||
} cleave
|
||||
] each ;
|
||||
|
||||
M: class forget* ( class -- )
|
||||
[ forget-class ] [ call-next-method ] bi ;
|
||||
|
||||
M: sequence update-methods ( class seq -- )
|
||||
implementors [
|
||||
[ update-generic ] [ make-generic drop ] 2bi
|
||||
|
@ -188,6 +171,7 @@ M: sequence update-methods ( class seq -- )
|
|||
2drop
|
||||
] [
|
||||
2dup "combination" set-word-prop
|
||||
over "methods" word-prop values forget-all
|
||||
over H{ } clone "methods" set-word-prop
|
||||
dupd define-default-method
|
||||
make-generic
|
||||
|
|
|
@ -33,7 +33,7 @@ HELP: group
|
|||
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
|
||||
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
|
||||
{ $examples
|
||||
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
|
||||
{ $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
|
||||
} ;
|
||||
|
||||
HELP: <groups>
|
||||
|
@ -41,7 +41,7 @@ HELP: <groups>
|
|||
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||
"USING: arrays kernel prettyprint sequences grouping ;"
|
||||
"9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
|
||||
}
|
||||
} ;
|
||||
|
@ -51,7 +51,7 @@ HELP: <sliced-groups>
|
|||
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||
"USING: arrays kernel prettyprint sequences grouping ;"
|
||||
"9 >array 3 <sliced-groups>"
|
||||
"dup [ reverse-here ] each concat >array ."
|
||||
"{ 2 1 0 5 4 3 8 7 6 }"
|
||||
|
@ -68,7 +68,7 @@ HELP: clump
|
|||
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
|
||||
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
|
||||
{ $examples
|
||||
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
|
||||
{ $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
|
||||
} ;
|
||||
|
||||
HELP: <clumps>
|
||||
|
@ -77,7 +77,7 @@ HELP: <clumps>
|
|||
{ $examples
|
||||
"Running averages:"
|
||||
{ $example
|
||||
"USING: splitting sequences math prettyprint kernel ;"
|
||||
"USING: grouping sequences math prettyprint kernel ;"
|
||||
"IN: scratchpad"
|
||||
": share-price"
|
||||
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
|
||||
|
|
|
@ -95,10 +95,8 @@ SYMBOL: +editable+
|
|||
: describe ( obj -- ) H{ } describe* ;
|
||||
|
||||
: namestack. ( seq -- )
|
||||
[
|
||||
[ global eq? not ] filter
|
||||
[ keys ] map concat prune
|
||||
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
||||
[ [ global eq? not ] filter [ keys ] gather ] keep
|
||||
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
||||
|
||||
: .vars ( -- )
|
||||
namestack namestack. ;
|
||||
|
|
|
@ -14,7 +14,7 @@ GENERIC: encode-char ( char stream encoding -- )
|
|||
|
||||
GENERIC: <decoder> ( stream encoding -- newstream )
|
||||
|
||||
: replacement-char HEX: fffd ;
|
||||
: replacement-char HEX: fffd ; inline
|
||||
|
||||
TUPLE: decoder stream code cr ;
|
||||
|
||||
|
@ -121,14 +121,28 @@ M: encoder stream-flush encoder-stream stream-flush ;
|
|||
INSTANCE: encoder plain-writer
|
||||
PRIVATE>
|
||||
|
||||
: re-encode ( stream encoding -- newstream )
|
||||
over encoder? [ >r encoder-stream r> ] when <encoder> ;
|
||||
GENERIC# re-encode 1 ( stream encoding -- newstream )
|
||||
|
||||
M: object re-encode <encoder> ;
|
||||
|
||||
M: encoder re-encode [ stream>> ] dip re-encode ;
|
||||
|
||||
: encode-output ( encoding -- )
|
||||
output-stream [ swap re-encode ] change ;
|
||||
|
||||
: re-decode ( stream encoding -- newstream )
|
||||
over decoder? [ >r decoder-stream r> ] when <decoder> ;
|
||||
: with-encoded-output ( encoding quot -- )
|
||||
[ [ output-stream get ] dip re-encode ] dip
|
||||
with-output-stream* ; inline
|
||||
|
||||
GENERIC# re-decode 1 ( stream encoding -- newstream )
|
||||
|
||||
M: object re-decode <decoder> ;
|
||||
|
||||
M: decoder re-decode [ stream>> ] dip re-decode ;
|
||||
|
||||
: decode-input ( encoding -- )
|
||||
input-stream [ swap re-decode ] change ;
|
||||
|
||||
: with-decoded-input ( encoding quot -- )
|
||||
[ [ input-stream get ] dip re-decode ] dip
|
||||
with-input-stream* ; inline
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: kernel tools.test io.encodings.utf16 arrays sbufs
|
||||
io.streams.byte-array sequences io.encodings io unicode
|
||||
io.streams.byte-array sequences io.encodings io
|
||||
bootstrap.unicode
|
||||
io.encodings.string alien.c-types alien.strings accessors classes ;
|
||||
IN: io.encodings.utf16.tests
|
||||
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ;
|
||||
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays
|
||||
bootstrap.unicode ;
|
||||
IN: io.encodings.utf8.tests
|
||||
|
||||
: decode-utf8-w/stream ( array -- newarray )
|
||||
|
|
|
@ -401,7 +401,7 @@ HELP: clone
|
|||
{ $values { "obj" object } { "cloned" "a new object" } }
|
||||
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
|
||||
|
||||
HELP: ? ( ? true false -- true/false )
|
||||
HELP: ?
|
||||
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
|
||||
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
|
||||
|
||||
|
@ -409,7 +409,7 @@ HELP: >boolean
|
|||
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
|
||||
{ $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ;
|
||||
|
||||
HELP: not ( obj -- ? )
|
||||
HELP: not
|
||||
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
|
||||
{ $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." }
|
||||
{ $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ;
|
||||
|
@ -692,26 +692,26 @@ HELP: tri@
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: if ( cond true false -- )
|
||||
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
|
||||
HELP: if
|
||||
{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
|
||||
|
||||
HELP: when
|
||||
{ $values { "cond" "a generalized boolean" } { "true" quotation } }
|
||||
{ $values { "?" "a generalized boolean" } { "true" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
|
||||
|
||||
HELP: unless
|
||||
{ $values { "cond" "a generalized boolean" } { "false" quotation } }
|
||||
{ $values { "?" "a generalized boolean" } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
|
||||
|
||||
HELP: if*
|
||||
{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
|
||||
{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
|
||||
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
|
||||
$nl
|
||||
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
|
||||
|
@ -720,14 +720,14 @@ $nl
|
|||
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
|
||||
|
||||
HELP: when*
|
||||
{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
|
||||
{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
|
||||
{ $description "Variant of " { $link if* } " with no false quotation."
|
||||
$nl
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ;
|
||||
|
||||
HELP: unless*
|
||||
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
|
||||
{ $values { "?" "a generalized boolean" } { "false" "a quotation " } }
|
||||
{ $description "Variant of " { $link if* } " with no true quotation." }
|
||||
{ $notes
|
||||
"The following two lines are equivalent:"
|
||||
|
@ -794,7 +794,7 @@ HELP: most
|
|||
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
|
||||
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
|
||||
|
||||
HELP: curry ( obj quot -- curry )
|
||||
HELP: curry
|
||||
{ $values { "obj" object } { "quot" callable } { "curry" curry } }
|
||||
{ $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." }
|
||||
{ $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." }
|
||||
|
@ -832,7 +832,7 @@ HELP: with
|
|||
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
|
||||
} ;
|
||||
|
||||
HELP: compose ( quot1 quot2 -- compose )
|
||||
HELP: compose
|
||||
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
|
||||
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
|
||||
{ $notes
|
||||
|
|
|
@ -28,20 +28,20 @@ DEFER: if
|
|||
: if ( ? true false -- ) ? call ;
|
||||
|
||||
! Single branch
|
||||
: unless ( cond false -- )
|
||||
: unless ( ? false -- )
|
||||
swap [ drop ] [ call ] if ; inline
|
||||
|
||||
: when ( cond true -- )
|
||||
: when ( ? true -- )
|
||||
swap [ call ] [ drop ] if ; inline
|
||||
|
||||
! Anaphoric
|
||||
: if* ( cond true false -- )
|
||||
: if* ( ? true false -- )
|
||||
pick [ drop call ] [ 2nip call ] if ; inline
|
||||
|
||||
: when* ( cond true -- )
|
||||
: when* ( ? true -- )
|
||||
over [ call ] [ 2drop ] if ; inline
|
||||
|
||||
: unless* ( cond false -- )
|
||||
: unless* ( ? false -- )
|
||||
over [ drop ] [ nip call ] if ; inline
|
||||
|
||||
! Default
|
||||
|
|
|
@ -24,7 +24,7 @@ ABOUT: "floats"
|
|||
HELP: float
|
||||
{ $class-description "The class of double-precision floating point numbers." } ;
|
||||
|
||||
HELP: >float ( x -- y )
|
||||
HELP: >float
|
||||
{ $values { "x" real } { "y" float } }
|
||||
{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;
|
||||
|
||||
|
|
|
@ -23,17 +23,21 @@ ABOUT: "integers"
|
|||
HELP: fixnum
|
||||
{ $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ;
|
||||
|
||||
HELP: >fixnum ( x -- n )
|
||||
HELP: >fixnum
|
||||
{ $values { "x" real } { "n" fixnum } }
|
||||
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
|
||||
|
||||
HELP: bignum
|
||||
{ $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
|
||||
|
||||
HELP: >bignum ( x -- n )
|
||||
HELP: >bignum
|
||||
{ $values { "x" real } { "n" bignum } }
|
||||
{ $description "Converts a real number to a bignum, with a possible loss of precision." } ;
|
||||
|
||||
HELP: >integer
|
||||
{ $values { "x" real } { "n" bignum } }
|
||||
{ $description "Converts a real number to an integer, with a possible loss of precision." } ;
|
||||
|
||||
HELP: integer
|
||||
{ $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ;
|
||||
|
||||
|
|
|
@ -3,9 +3,9 @@
|
|||
USING: kernel math.private ;
|
||||
IN: math
|
||||
|
||||
GENERIC: >fixnum ( x -- y ) foldable
|
||||
GENERIC: >bignum ( x -- y ) foldable
|
||||
GENERIC: >integer ( x -- y ) foldable
|
||||
GENERIC: >fixnum ( x -- n ) foldable
|
||||
GENERIC: >bignum ( x -- n ) foldable
|
||||
GENERIC: >integer ( x -- n ) foldable
|
||||
GENERIC: >float ( x -- y ) foldable
|
||||
|
||||
MATH: number= ( x y -- ? ) foldable
|
||||
|
|
|
@ -16,6 +16,9 @@ IN: sets
|
|||
[ ] [ length <hashtable> ] [ length <vector> ] tri
|
||||
[ [ (prune) ] 2curry each ] keep ;
|
||||
|
||||
: gather ( seq quot -- newseq )
|
||||
map concat prune ; inline
|
||||
|
||||
: unique ( seq -- assoc )
|
||||
[ dup ] H{ } map>assoc ;
|
||||
|
||||
|
|
|
@ -148,8 +148,12 @@ M: object redefined drop ;
|
|||
2dup "declared-effect" word-prop = [ 2drop ] [
|
||||
swap
|
||||
[ "declared-effect" set-word-prop ]
|
||||
[ drop [ redefined ] [ +inlined+ changed-definition ] bi ]
|
||||
2bi
|
||||
[
|
||||
drop
|
||||
dup primitive? [ drop ] [
|
||||
[ redefined ] [ +inlined+ changed-definition ] bi
|
||||
] if
|
||||
] 2bi
|
||||
] if ;
|
||||
|
||||
: define-declared ( word def effect -- )
|
||||
|
|
|
@ -7,7 +7,7 @@ kernel io.files bootstrap.image sequences io ;
|
|||
: url "http://factorcode.org/images/latest/" ;
|
||||
|
||||
: download-checksums ( -- alist )
|
||||
url "checksums.txt" append http-get
|
||||
url "checksums.txt" append http-get nip
|
||||
string-lines [ " " split1 ] { } map>assoc ;
|
||||
|
||||
: need-new-image? ( image -- ? )
|
||||
|
|
|
@ -0,0 +1,12 @@
|
|||
USING: parser kernel namespaces ;
|
||||
|
||||
USE: unicode.breaks
|
||||
USE: unicode.case
|
||||
USE: unicode.categories
|
||||
USE: unicode.collation
|
||||
USE: unicode.data
|
||||
USE: unicode.normalize
|
||||
USE: unicode.script
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
name>char-hook set-global
|
|
@ -35,7 +35,7 @@ HOOK: db-close db ( handle -- )
|
|||
handle>> db-close
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
|
||||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
|
||||
|
@ -89,7 +89,7 @@ M: object execute-statement* ( statement type -- )
|
|||
swap >>out-params
|
||||
swap >>in-params
|
||||
swap >>sql ;
|
||||
|
||||
|
||||
: sql-row ( result-set -- seq )
|
||||
dup #columns [ row-column ] with map ;
|
||||
|
||||
|
|
|
@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types
|
|||
db.types tools.walker ascii splitting math.parser combinators
|
||||
libc shuffle calendar.format byte-arrays destructors prettyprint
|
||||
accessors strings serialize io.encodings.binary io.encodings.utf8
|
||||
alien.strings io.streams.byte-array inspector ;
|
||||
alien.strings io.streams.byte-array inspector present urls ;
|
||||
IN: db.postgresql.lib
|
||||
|
||||
: postgresql-result-error-message ( res -- str/f )
|
||||
|
@ -84,6 +84,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
{ TIME [ dup [ timestamp>hms ] when default-param-value ] }
|
||||
{ DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
|
||||
{ TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
|
||||
{ URL [ dup [ present ] when default-param-value ] }
|
||||
[ drop default-param-value ]
|
||||
} case 2array
|
||||
] 2map flip dup empty? [
|
||||
|
@ -164,6 +165,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
|||
{ TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
|
||||
{ DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
|
||||
{ BLOB [ pq-get-blob ] }
|
||||
{ URL [ pq-get-string dup [ >url ] when ] }
|
||||
{ FACTOR-BLOB [
|
||||
pq-get-blob
|
||||
dup [ bytes>object ] when ] }
|
||||
|
|
|
@ -239,6 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable )
|
|||
{ TIMESTAMP { "timestamp" "timestamp" f } }
|
||||
{ BLOB { "bytea" "bytea" f } }
|
||||
{ FACTOR-BLOB { "bytea" "bytea" f } }
|
||||
{ URL { "varchar" "varchar" f } }
|
||||
{ +foreign-id+ { f f "references" } }
|
||||
{ +autoincrement+ { f f "autoincrement" } }
|
||||
{ +unique+ { f f "unique" } }
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math namespaces sequences random
|
||||
strings math.parser math.intervals combinators
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types ;
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types
|
||||
sequences.lib db.sql classes words shuffle arrays ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
@ -99,16 +100,15 @@ M: string where ( spec obj -- ) object-where ;
|
|||
] with filter ;
|
||||
|
||||
: where-clause ( tuple specs -- )
|
||||
dupd filter-slots
|
||||
dup empty? [
|
||||
2drop
|
||||
dupd filter-slots [
|
||||
drop
|
||||
] [
|
||||
" where " 0% [
|
||||
" and " 0%
|
||||
] [
|
||||
2dup slot-name>> swap get-slot-named where
|
||||
] interleave drop
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
M: db <delete-tuples-statement> ( tuple table -- sql )
|
||||
[
|
||||
|
@ -146,15 +146,52 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
number>string " limit " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: make-advanced-statement ( tuple advanced -- tuple' )
|
||||
: make-query ( tuple query -- tuple' )
|
||||
dupd
|
||||
{
|
||||
[ group>> [ do-group ] [ drop ] if* ]
|
||||
[ order>> [ do-order ] [ drop ] if* ]
|
||||
[ group>> [ do-group ] [ drop ] if-seq ]
|
||||
[ order>> [ do-order ] [ drop ] if-seq ]
|
||||
[ limit>> [ do-limit ] [ drop ] if* ]
|
||||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
||||
|
||||
M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
|
||||
advanced-statement boa
|
||||
[ <select-by-slots-statement> ] dip make-advanced-statement ;
|
||||
M: db <query> ( tuple class query -- tuple )
|
||||
[ <select-by-slots-statement> ] dip make-query ;
|
||||
|
||||
! select ID, NAME, SCORE from EXAM limit 1 offset 3
|
||||
|
||||
: select-tuples* ( tuple -- statement )
|
||||
dup
|
||||
[
|
||||
select 0,
|
||||
dup class db-columns [ ", " 0, ]
|
||||
[ dup column-name>> 0, 2, ] interleave
|
||||
from 0,
|
||||
class word-name 0,
|
||||
] { { } { } { } } nmake
|
||||
>r >r parse-sql 4drop r> r>
|
||||
<simple-statement> maybe-make-retryable do-select ;
|
||||
|
||||
M: db <count-statement> ( tuple class groups -- statement )
|
||||
\ query new
|
||||
swap >>group
|
||||
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
|
||||
dip make-query ;
|
||||
|
||||
: where-clause* ( tuple specs -- )
|
||||
dupd filter-slots [
|
||||
drop
|
||||
] [
|
||||
\ where 0,
|
||||
[ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
|
||||
drop
|
||||
] if-empty ;
|
||||
|
||||
: delete-tuple* ( tuple -- sql )
|
||||
dup
|
||||
[
|
||||
delete 0, from 0, dup class db-table 0,
|
||||
dup class db-columns where-clause*
|
||||
] { { } { } { } } nmake
|
||||
>r >r parse-sql 4drop r> r>
|
||||
<simple-statement> maybe-make-retryable do-select ;
|
||||
|
|
|
@ -23,12 +23,27 @@ DEFER: sql%
|
|||
: sql-function, ( seq function -- )
|
||||
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
|
||||
|
||||
: sql-where ( seq -- )
|
||||
B
|
||||
[
|
||||
[ second 0, ]
|
||||
[ first 0, ]
|
||||
[ third 1, \ ? 0, ] tri
|
||||
] each ;
|
||||
|
||||
: sql-array% ( array -- )
|
||||
B
|
||||
unclip
|
||||
{
|
||||
{ \ create [ "create table" sql% ] }
|
||||
{ \ drop [ "drop table" sql% ] }
|
||||
{ \ insert [ "insert into" sql% ] }
|
||||
{ \ update [ "update" sql% ] }
|
||||
{ \ delete [ "delete" sql% ] }
|
||||
{ \ select [ B "select" sql% "," (sql-interleave) ] }
|
||||
{ \ columns [ "," (sql-interleave) ] }
|
||||
{ \ from [ "from" "," sql-interleave ] }
|
||||
{ \ where [ "where" "and" sql-interleave ] }
|
||||
{ \ where [ B "where" 0, sql-where ] }
|
||||
{ \ group-by [ "group by" "," sql-interleave ] }
|
||||
{ \ having [ "having" "," sql-interleave ] }
|
||||
{ \ order-by [ "order by" "," sql-interleave ] }
|
||||
|
@ -49,7 +64,7 @@ DEFER: sql%
|
|||
ERROR: no-sql-match ;
|
||||
: sql% ( obj -- )
|
||||
{
|
||||
{ [ dup string? ] [ " " 0% 0% ] }
|
||||
{ [ dup string? ] [ 0, ] }
|
||||
{ [ dup array? ] [ sql-array% ] }
|
||||
{ [ dup number? ] [ number>string sql% ] }
|
||||
{ [ dup symbol? ] [ unparse sql% ] }
|
||||
|
@ -59,13 +74,4 @@ ERROR: no-sql-match ;
|
|||
} cond ;
|
||||
|
||||
: parse-sql ( obj -- sql in-spec out-spec in out )
|
||||
[
|
||||
unclip {
|
||||
{ \ create [ "create table" sql% ] }
|
||||
{ \ drop [ "drop table" sql% ] }
|
||||
{ \ insert [ "insert into" sql% ] }
|
||||
{ \ update [ "update" sql% ] }
|
||||
{ \ delete [ "delete" sql% ] }
|
||||
{ \ select [ "select" sql% ] }
|
||||
} case [ sql% ] each
|
||||
] { "" { } { } { } { } } nmake ;
|
||||
[ [ sql% ] each ] { { } { } { } } nmake ;
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
|
|||
namespaces sequences db.sqlite.ffi db combinators
|
||||
continuations db.types calendar.format serialize
|
||||
io.streams.byte-array byte-arrays io.encodings.binary
|
||||
io.backend db.errors ;
|
||||
io.backend db.errors present urls ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
ERROR: sqlite-error < db-error n string ;
|
||||
|
@ -107,6 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
|||
object>bytes
|
||||
sqlite-bind-blob-by-name
|
||||
] }
|
||||
{ URL [ present sqlite-bind-text-by-name ] }
|
||||
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
|
||||
{ +random-id+ [ sqlite-bind-int64-by-name ] }
|
||||
{ NULL [ sqlite-bind-null-by-name ] }
|
||||
|
@ -147,6 +148,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
|||
{ TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
|
||||
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
|
||||
{ BLOB [ sqlite-column-blob ] }
|
||||
{ URL [ sqlite3_column_text dup [ >url ] when ] }
|
||||
{ FACTOR-BLOB [
|
||||
sqlite-column-blob
|
||||
dup [ bytes>object ] when
|
||||
|
|
|
@ -182,6 +182,7 @@ M: sqlite-db persistent-table ( -- assoc )
|
|||
{ DOUBLE { "real" "real" } }
|
||||
{ BLOB { "blob" "blob" } }
|
||||
{ FACTOR-BLOB { "blob" "blob" } }
|
||||
{ URL { "text" "text" } }
|
||||
{ +autoincrement+ { f f "autoincrement" } }
|
||||
{ +unique+ { f f "unique" } }
|
||||
{ +default+ { f f "default" } }
|
||||
|
|
|
@ -4,26 +4,27 @@ USING: io.files kernel tools.test db db.tuples classes
|
|||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitfields.lib
|
||||
math.ranges strings sequences.lib ;
|
||||
math.ranges strings sequences.lib urls ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
ts date time blob factor-blob ;
|
||||
ts date time blob factor-blob url ;
|
||||
|
||||
: <person> ( name age real ts date time blob factor-blob -- person )
|
||||
{
|
||||
set-person-the-name
|
||||
set-person-the-number
|
||||
set-person-the-real
|
||||
set-person-ts
|
||||
set-person-date
|
||||
set-person-time
|
||||
set-person-blob
|
||||
set-person-factor-blob
|
||||
} person construct ;
|
||||
: <person> ( name age real ts date time blob factor-blob url -- person )
|
||||
person new
|
||||
swap >>url
|
||||
swap >>factor-blob
|
||||
swap >>blob
|
||||
swap >>time
|
||||
swap >>date
|
||||
swap >>ts
|
||||
swap >>the-real
|
||||
swap >>the-number
|
||||
swap >>the-name ;
|
||||
|
||||
: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
|
||||
<person> [ set-person-the-id ] keep ;
|
||||
: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
|
||||
<person>
|
||||
swap >>the-id ;
|
||||
|
||||
SYMBOL: person1
|
||||
SYMBOL: person2
|
||||
|
@ -103,6 +104,7 @@ SYMBOL: person4
|
|||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f
|
||||
H{ { 1 2 } { 3 4 } { 5 "lol" } }
|
||||
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
|
||||
}
|
||||
] [ T{ person f 4 } select-tuple ] unit-test
|
||||
|
||||
|
@ -120,19 +122,20 @@ SYMBOL: person4
|
|||
{ "time" "T" TIME }
|
||||
{ "blob" "B" BLOB }
|
||||
{ "factor-blob" "FB" FACTOR-BLOB }
|
||||
{ "url" "U" URL }
|
||||
} define-persistent
|
||||
"billy" 10 3.14 f f f f f <person> person1 set
|
||||
"johnny" 10 3.14 f f f f f <person> person2 set
|
||||
"billy" 10 3.14 f f f f f f <person> person1 set
|
||||
"johnny" 10 3.14 f f f f f f <person> person2 set
|
||||
"teddy" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
|
||||
"eddie" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
|
||||
|
||||
: user-assigned-person-schema ( -- )
|
||||
person "PERSON"
|
||||
|
@ -146,20 +149,21 @@ SYMBOL: person4
|
|||
{ "time" "T" TIME }
|
||||
{ "blob" "B" BLOB }
|
||||
{ "factor-blob" "FB" FACTOR-BLOB }
|
||||
{ "url" "U" URL }
|
||||
} define-persistent
|
||||
1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set
|
||||
2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
|
||||
1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
|
||||
2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
|
||||
3 "teddy" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
|
||||
f <user-assigned-person> person3 set
|
||||
f f <user-assigned-person> person3 set
|
||||
4 "eddie" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ;
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
|
||||
|
||||
TUPLE: paste n summary author channel mode contents timestamp annotations ;
|
||||
TUPLE: annotation n paste-id summary author mode contents ;
|
||||
|
@ -227,7 +231,7 @@ TUPLE: exam id name score ;
|
|||
|
||||
: random-exam ( -- exam )
|
||||
f
|
||||
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
|
||||
6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
|
||||
100 random
|
||||
exam boa ;
|
||||
|
||||
|
@ -340,7 +344,9 @@ TUPLE: exam id name score ;
|
|||
}
|
||||
] [
|
||||
T{ exam } select-tuples
|
||||
] unit-test ;
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [ T{ exam } f count-tuples ] unit-test ;
|
||||
|
||||
TUPLE: bignum-test id m n o ;
|
||||
: <bignum-test> ( m n o -- obj )
|
||||
|
|
|
@ -42,8 +42,9 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
|
|||
HOOK: <update-tuple-statement> db ( class -- obj )
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
TUPLE: advanced-statement group order offset limit ;
|
||||
HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
|
||||
TUPLE: query group order offset limit ;
|
||||
HOOK: <query> db ( tuple class query -- statement' )
|
||||
HOOK: <count-statement> db ( tuple class groups -- n )
|
||||
|
||||
HOOK: insert-tuple* db ( tuple statement -- )
|
||||
|
||||
|
@ -55,6 +56,7 @@ SINGLETON: retryable
|
|||
[ make-retryable ] map
|
||||
] [
|
||||
retryable >>type
|
||||
10 >>retries
|
||||
] if ;
|
||||
|
||||
: regenerate-params ( statement -- statement )
|
||||
|
@ -69,12 +71,13 @@ SINGLETON: retryable
|
|||
] 2map >>bind-params ;
|
||||
|
||||
M: retryable execute-statement* ( statement type -- )
|
||||
drop
|
||||
[
|
||||
[ query-results dispose t ]
|
||||
[ ]
|
||||
[ regenerate-params bind-statement* f ] cleanup
|
||||
] curry 10 retry drop ;
|
||||
drop [
|
||||
[
|
||||
[ query-results dispose t ]
|
||||
[ ]
|
||||
[ regenerate-params bind-statement* f ] cleanup
|
||||
] curry
|
||||
] [ retries>> ] bi retry drop ;
|
||||
|
||||
: resulting-tuple ( class row out-params -- tuple )
|
||||
rot class new [
|
||||
|
@ -146,12 +149,21 @@ M: retryable execute-statement* ( statement type -- )
|
|||
: do-select ( exemplar-tuple statement -- tuples )
|
||||
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
|
||||
|
||||
: query ( tuple query -- tuples )
|
||||
>r dup dup class r> <query> do-select ;
|
||||
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> do-select ;
|
||||
|
||||
: count-tuples ( tuple -- n )
|
||||
select-tuples length ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f )
|
||||
dup dup class f f f 1 <advanced-select-statement>
|
||||
do-select ?first ;
|
||||
dup dup class \ query new 1 >>limit <query> do-select ?first ;
|
||||
|
||||
: do-count ( exemplar-tuple statement -- tuples )
|
||||
[
|
||||
[ bind-tuple ] [ nip default-query ] 2bi
|
||||
] with-disposal ;
|
||||
|
||||
: count-tuples ( tuple groups -- n )
|
||||
>r dup dup class r> <count-statement> do-count
|
||||
dup length 1 =
|
||||
[ first first string>number ] [ [ first string>number ] map ] if ;
|
||||
|
|
|
@ -65,7 +65,7 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
|||
|
||||
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
|
||||
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
|
||||
FACTOR-BLOB NULL ;
|
||||
FACTOR-BLOB NULL URL ;
|
||||
|
||||
: spec>tuple ( class spec -- tuple )
|
||||
3 f pad-right
|
||||
|
|
|
@ -6,7 +6,7 @@ IN: html.parser.analyzer
|
|||
TUPLE: link attributes clickable ;
|
||||
|
||||
: scrape-html ( url -- vector )
|
||||
http-get parse-html ;
|
||||
http-get nip parse-html ;
|
||||
|
||||
: (find-relative)
|
||||
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: assocs html.parser html.parser.utils combinators
|
|||
continuations hashtables
|
||||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
state-parser strings ;
|
||||
strings ;
|
||||
IN: html.parser.printer
|
||||
|
||||
SYMBOL: no-section
|
||||
|
@ -16,7 +16,8 @@ TUPLE: state section ;
|
|||
TUPLE: text-printer ;
|
||||
TUPLE: ui-printer ;
|
||||
TUPLE: src-printer ;
|
||||
UNION: printer text-printer ui-printer src-printer ;
|
||||
TUPLE: html-prettyprinter ;
|
||||
UNION: printer text-printer ui-printer src-printer html-prettyprinter ;
|
||||
HOOK: print-tag printer ( tag -- )
|
||||
HOOK: print-text-tag printer ( tag -- )
|
||||
HOOK: print-comment-tag printer ( tag -- )
|
||||
|
@ -47,7 +48,7 @@ M: printer print-comment-tag ( tag -- )
|
|||
tag-text write
|
||||
"-->" write ;
|
||||
|
||||
M: printer print-dtd-tag
|
||||
M: printer print-dtd-tag ( tag -- )
|
||||
"<!" write
|
||||
tag-text write
|
||||
">" write ;
|
||||
|
@ -70,8 +71,8 @@ M: printer print-closing-named-tag ( tag -- )
|
|||
|
||||
M: src-printer print-opening-named-tag ( tag -- )
|
||||
"<" write
|
||||
dup tag-name write
|
||||
tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if
|
||||
[ tag-name write ]
|
||||
[ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
|
||||
">" write ;
|
||||
|
||||
M: src-printer print-closing-named-tag ( tag -- )
|
||||
|
@ -79,9 +80,30 @@ M: src-printer print-closing-named-tag ( tag -- )
|
|||
tag-name write
|
||||
">" write ;
|
||||
|
||||
TUPLE: unknown-tag-error tag ;
|
||||
SYMBOL: tab-width
|
||||
SYMBOL: #indentations
|
||||
|
||||
C: <unknown-tag-error> unknown-tag-error
|
||||
: html-pp ( vector -- )
|
||||
[
|
||||
0 #indentations set
|
||||
2 tab-width set
|
||||
|
||||
] with-scope ;
|
||||
|
||||
: print-tabs ( -- )
|
||||
tab-width get #indentations get * CHAR: \s <repetition> write ;
|
||||
|
||||
M: html-prettyprinter print-opening-named-tag ( tag -- )
|
||||
print-tabs "<" write
|
||||
tag-name write
|
||||
">\n" write ;
|
||||
|
||||
M: html-prettyprinter print-closing-named-tag ( tag -- )
|
||||
"</" write
|
||||
tag-name write
|
||||
">" write ;
|
||||
|
||||
ERROR: unknown-tag-error tag ;
|
||||
|
||||
M: printer print-tag ( tag -- )
|
||||
{
|
||||
|
@ -92,15 +114,12 @@ M: printer print-tag ( tag -- )
|
|||
[ print-closing-named-tag ] }
|
||||
{ [ dup tag-name string? ]
|
||||
[ print-opening-named-tag ] }
|
||||
[ <unknown-tag-error> throw ]
|
||||
[ unknown-tag-error ]
|
||||
} cond ;
|
||||
|
||||
SYMBOL: tablestack
|
||||
|
||||
: with-html-printer
|
||||
[
|
||||
V{ } clone tablestack set
|
||||
] with-scope ;
|
||||
! SYMBOL: tablestack
|
||||
! : with-html-printer ( vector quot -- )
|
||||
! [ V{ } clone tablestack set ] with-scope ;
|
||||
|
||||
! { { 1 2 } { 3 4 } }
|
||||
! H{ { table-gap { 10 10 } } } [
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: assocs circular combinators continuations hashtables
|
||||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
state-parser strings ;
|
||||
state-parser strings sequences.lib ;
|
||||
IN: html.parser.utils
|
||||
|
||||
: string-parse-end?
|
||||
|
@ -13,7 +13,7 @@ IN: html.parser.utils
|
|||
dup length rot length 1- - head next* ;
|
||||
|
||||
: trim1 ( seq ch -- newseq )
|
||||
[ ?head drop ] keep ?tail drop ;
|
||||
[ ?head drop ] [ ?tail drop ] bi ;
|
||||
|
||||
: single-quote ( str -- newstr )
|
||||
>r "'" r> "'" 3append ;
|
||||
|
@ -26,11 +26,7 @@ IN: html.parser.utils
|
|||
[ double-quote ] [ single-quote ] if ;
|
||||
|
||||
: quoted? ( str -- ? )
|
||||
dup length 1 > [
|
||||
[ first ] keep peek [ = ] keep "'\"" member? and
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
|
||||
|
||||
: ?quote ( str -- newstr )
|
||||
dup quoted? [ quote ] unless ;
|
||||
|
@ -39,4 +35,3 @@ IN: html.parser.utils
|
|||
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||
|
||||
: quote? ( ch -- ? ) "'\"" member? ;
|
||||
|
||||
|
|
|
@ -3,8 +3,13 @@
|
|||
USING: assocs http kernel math math.parser namespaces sequences
|
||||
io io.sockets io.streams.string io.files io.timeouts strings
|
||||
splitting calendar continuations accessors vectors math.order
|
||||
io.encodings.8-bit io.encodings.binary io.streams.duplex
|
||||
fry debugger inspector ascii urls ;
|
||||
io.encodings
|
||||
io.encodings.string
|
||||
io.encodings.ascii
|
||||
io.encodings.8-bit
|
||||
io.encodings.binary
|
||||
io.streams.duplex
|
||||
fry debugger inspector ascii urls present ;
|
||||
IN: http.client
|
||||
|
||||
: max-redirects 10 ;
|
||||
|
@ -15,7 +20,7 @@ M: too-many-redirects summary
|
|||
drop
|
||||
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
|
||||
|
||||
DEFER: http-request
|
||||
DEFER: (http-request)
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -31,7 +36,7 @@ SYMBOL: redirects
|
|||
redirects get max-redirects < [
|
||||
request get
|
||||
swap "location" header redirect-url
|
||||
"GET" >>method http-request
|
||||
"GET" >>method (http-request)
|
||||
] [
|
||||
too-many-redirects
|
||||
] if
|
||||
|
@ -45,15 +50,21 @@ PRIVATE>
|
|||
|
||||
: read-chunks ( -- )
|
||||
read-chunk-size dup zero?
|
||||
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
|
||||
[ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
|
||||
|
||||
: read-response-body ( response -- response data )
|
||||
dup "transfer-encoding" header "chunked" =
|
||||
[ [ read-chunks ] "" make ] [ input-stream get contents ] if ;
|
||||
dup "transfer-encoding" header "chunked" = [
|
||||
binary decode-input
|
||||
[ read-chunks ] B{ } make
|
||||
over content-charset>> decode
|
||||
] [
|
||||
dup content-charset>> decode-input
|
||||
input-stream get contents
|
||||
] if ;
|
||||
|
||||
: http-request ( request -- response data )
|
||||
: (http-request) ( request -- response data )
|
||||
dup request [
|
||||
dup url>> url-addr latin1 [
|
||||
dup url>> url-addr ascii [
|
||||
1 minutes timeouts
|
||||
write-request
|
||||
read-response
|
||||
|
@ -62,14 +73,6 @@ PRIVATE>
|
|||
do-redirect
|
||||
] with-variable ;
|
||||
|
||||
: <get-request> ( url -- request )
|
||||
<request>
|
||||
"GET" >>method
|
||||
swap >url ensure-port >>url ;
|
||||
|
||||
: http-get* ( url -- response data )
|
||||
<get-request> http-request ;
|
||||
|
||||
: success? ( code -- ? ) 200 = ;
|
||||
|
||||
ERROR: download-failed response body ;
|
||||
|
@ -84,18 +87,28 @@ M: download-failed error.
|
|||
]
|
||||
[ body>> write ] bi ;
|
||||
|
||||
: check-response ( response string -- string )
|
||||
over code>> success? [ nip ] [ download-failed ] if ;
|
||||
: check-response ( response data -- response data )
|
||||
over code>> success? [ download-failed ] unless ;
|
||||
|
||||
: http-get ( url -- string )
|
||||
http-get* check-response ;
|
||||
: http-request ( request -- response data )
|
||||
(http-request) check-response ;
|
||||
|
||||
: <get-request> ( url -- request )
|
||||
<request>
|
||||
"GET" >>method
|
||||
swap >url ensure-port >>url ;
|
||||
|
||||
: http-get ( url -- response data )
|
||||
<get-request> http-request ;
|
||||
|
||||
: download-name ( url -- name )
|
||||
file-name "?" split1 drop "/" ?tail drop ;
|
||||
present file-name "?" split1 drop "/" ?tail drop ;
|
||||
|
||||
: download-to ( url file -- )
|
||||
#! Downloads the contents of a URL to a file.
|
||||
[ http-get ] dip latin1 [ write ] with-file-writer ;
|
||||
swap http-get
|
||||
[ content-charset>> ] [ '[ , write ] ] bi*
|
||||
with-file-writer ;
|
||||
|
||||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: http tools.test multiline tuple-syntax
|
||||
io.streams.string kernel arrays splitting sequences
|
||||
io.streams.string io.encodings.utf8 io.encodings.string
|
||||
kernel arrays splitting sequences
|
||||
assocs io.sockets db db.sqlite continuations urls hashtables ;
|
||||
IN: http.tests
|
||||
|
||||
|
@ -78,7 +79,7 @@ must-fail-with
|
|||
|
||||
STRING: read-response-test-1
|
||||
HTTP/1.1 404 not found
|
||||
Content-Type: text/html; charset=UTF8
|
||||
Content-Type: text/html; charset=UTF-8
|
||||
|
||||
blah
|
||||
;
|
||||
|
@ -88,10 +89,10 @@ blah
|
|||
version: "1.1"
|
||||
code: 404
|
||||
message: "not found"
|
||||
header: H{ { "content-type" "text/html; charset=UTF8" } }
|
||||
header: H{ { "content-type" "text/html; charset=UTF-8" } }
|
||||
cookies: { }
|
||||
content-type: "text/html"
|
||||
content-charset: "UTF8"
|
||||
content-charset: utf8
|
||||
}
|
||||
] [
|
||||
read-response-test-1 lf>crlf
|
||||
|
@ -101,7 +102,7 @@ blah
|
|||
|
||||
STRING: read-response-test-1'
|
||||
HTTP/1.1 404 not found
|
||||
content-type: text/html; charset=UTF8
|
||||
content-type: text/html; charset=UTF-8
|
||||
|
||||
|
||||
;
|
||||
|
@ -160,14 +161,14 @@ test-db [
|
|||
|
||||
[ t ] [
|
||||
"resource:extra/http/test/foo.html" ascii file-contents
|
||||
"http://localhost:1237/nested/foo.html" http-get =
|
||||
"http://localhost:1237/nested/foo.html" http-get nip ascii decode =
|
||||
] unit-test
|
||||
|
||||
[ "http://localhost:1237/redirect-loop" http-get ]
|
||||
[ "http://localhost:1237/redirect-loop" http-get nip ]
|
||||
[ too-many-redirects? ] must-fail-with
|
||||
|
||||
[ "Goodbye" ] [
|
||||
"http://localhost:1237/quit" http-get
|
||||
"http://localhost:1237/quit" http-get nip
|
||||
] unit-test
|
||||
|
||||
! Dispatcher bugs
|
||||
|
@ -194,12 +195,12 @@ test-db [
|
|||
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
|
||||
|
||||
! This should give a 404 not an infinite redirect loop
|
||||
[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with
|
||||
[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
|
||||
|
||||
! This should give a 404 not an infinite redirect loop
|
||||
[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with
|
||||
[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
|
@ -218,9 +219,9 @@ test-db [
|
|||
|
||||
[ ] [ 100 sleep ] unit-test
|
||||
|
||||
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
|
||||
[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
|
||||
|
||||
USING: html.components html.elements xml xml.utilities validators
|
||||
furnace furnace.flash ;
|
||||
|
@ -253,7 +254,7 @@ SYMBOL: a
|
|||
: test-a string>xml "input" tag-named "value" swap at ;
|
||||
|
||||
[ "3" ] [
|
||||
"http://localhost:1237/" http-get*
|
||||
"http://localhost:1237/" http-get
|
||||
swap dup cookies>> "cookies" set session-id-key get-cookie
|
||||
value>> "session-id" set test-a
|
||||
] unit-test
|
||||
|
@ -273,4 +274,4 @@ SYMBOL: a
|
|||
|
||||
[ 4 ] [ a get-global ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
|
||||
|
|
|
@ -7,6 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
|
|||
math.parser calendar calendar.format present
|
||||
|
||||
io io.server io.sockets.secure
|
||||
io.encodings.iana io.encodings.binary io.encodings.8-bit
|
||||
|
||||
unicode.case unicode.categories qualified
|
||||
|
||||
|
@ -28,7 +29,8 @@ IN: http
|
|||
"header" get
|
||||
add-header
|
||||
] [
|
||||
": " split1 dup [
|
||||
":" split1 dup [
|
||||
[ blank? ] left-trim
|
||||
swap >lower dup "last-header" set
|
||||
"header" get add-header
|
||||
] [
|
||||
|
@ -36,20 +38,20 @@ IN: http
|
|||
] if
|
||||
] if ;
|
||||
|
||||
: read-lf ( -- string )
|
||||
: read-lf ( -- bytes )
|
||||
"\n" read-until CHAR: \n assert= ;
|
||||
|
||||
: read-crlf ( -- string )
|
||||
: read-crlf ( -- bytes )
|
||||
"\r" read-until
|
||||
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
||||
|
||||
: read-header-line ( -- )
|
||||
: (read-header) ( -- )
|
||||
read-crlf dup
|
||||
empty? [ drop ] [ header-line read-header-line ] if ;
|
||||
empty? [ drop ] [ header-line (read-header) ] if ;
|
||||
|
||||
: read-header ( -- assoc )
|
||||
H{ } clone [
|
||||
"header" [ read-header-line ] with-variable
|
||||
"header" [ (read-header) ] with-variable
|
||||
] keep ;
|
||||
|
||||
: header-value>string ( value -- string )
|
||||
|
@ -66,7 +68,8 @@ IN: http
|
|||
|
||||
: write-header ( assoc -- )
|
||||
>alist sort-keys [
|
||||
swap url-encode write ": " write
|
||||
swap
|
||||
check-header-string write ": " write
|
||||
header-value>string check-header-string write crlf
|
||||
] assoc-each crlf ;
|
||||
|
||||
|
@ -299,6 +302,7 @@ body ;
|
|||
H{ } clone >>header
|
||||
"close" "connection" set-header
|
||||
now timestamp>http-string "date" set-header
|
||||
latin1 >>content-charset
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
: read-response-version ( response -- response )
|
||||
|
@ -319,7 +323,9 @@ body ;
|
|||
read-header >>header
|
||||
dup "set-cookie" header parse-cookies >>cookies
|
||||
dup "content-type" header [
|
||||
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
|
||||
parse-content-type
|
||||
[ >>content-type ]
|
||||
[ name>encoding binary or >>content-charset ] bi*
|
||||
] when* ;
|
||||
|
||||
: read-response ( -- response )
|
||||
|
@ -341,7 +347,8 @@ body ;
|
|||
|
||||
: unparse-content-type ( request -- content-type )
|
||||
[ content-type>> "application/octet-stream" or ]
|
||||
[ content-charset>> ] bi
|
||||
[ content-charset>> encoding>name ]
|
||||
bi
|
||||
[ "; charset=" swap 3append ] when* ;
|
||||
|
||||
: write-response-header ( response -- response )
|
||||
|
|
|
@ -1,13 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: html.elements math.parser http accessors kernel
|
||||
io io.streams.string ;
|
||||
io io.streams.string io.encodings.utf8 ;
|
||||
IN: http.server.responses
|
||||
|
||||
: <content> ( body content-type -- response )
|
||||
<response>
|
||||
200 >>code
|
||||
"Document follows" >>message
|
||||
utf8 >>content-charset
|
||||
swap >>content-type
|
||||
swap >>body ;
|
||||
|
||||
|
|
|
@ -1,10 +1,21 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences arrays namespaces splitting
|
||||
vocabs.loader http http.server.responses logging calendar
|
||||
destructors html.elements html.streams io.server
|
||||
io.encodings.8-bit io.timeouts io assocs debugger continuations
|
||||
fry tools.vocabs math ;
|
||||
vocabs.loader destructors assocs debugger continuations
|
||||
tools.vocabs math
|
||||
io
|
||||
io.server
|
||||
io.encodings
|
||||
io.encodings.utf8
|
||||
io.encodings.ascii
|
||||
io.encodings.binary
|
||||
io.streams.limited
|
||||
io.timeouts
|
||||
fry logging calendar
|
||||
http
|
||||
http.server.responses
|
||||
html.elements
|
||||
html.streams ;
|
||||
IN: http.server
|
||||
|
||||
SYMBOL: responder-nesting
|
||||
|
@ -43,19 +54,29 @@ main-responder global [ <404> <trivial-responder> or ] change-at
|
|||
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
|
||||
|
||||
: do-response ( response -- )
|
||||
dup write-response
|
||||
request get method>> "HEAD" = [ drop ] [
|
||||
'[ , write-response-body ]
|
||||
[
|
||||
development-mode get
|
||||
[ http-error. ] [ drop "Response error" ] if
|
||||
] recover
|
||||
] if ;
|
||||
[ write-response ]
|
||||
[
|
||||
request get method>> "HEAD" = [ drop ] [
|
||||
'[
|
||||
,
|
||||
[ content-charset>> encode-output ]
|
||||
[ write-response-body ]
|
||||
bi
|
||||
]
|
||||
[
|
||||
utf8 [
|
||||
development-mode get
|
||||
[ http-error. ] [ drop "Response error" throw ] if
|
||||
] with-encoded-output
|
||||
] recover
|
||||
] if
|
||||
] bi ;
|
||||
|
||||
LOG: httpd-hit NOTICE
|
||||
|
||||
: log-request ( request -- )
|
||||
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
|
||||
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
|
||||
3array httpd-hit ;
|
||||
|
||||
: split-path ( string -- path )
|
||||
"/" split harvest ;
|
||||
|
@ -79,9 +100,15 @@ LOG: httpd-hit NOTICE
|
|||
development-mode get-global
|
||||
[ global [ refresh-all ] bind ] when ;
|
||||
|
||||
: setup-limits ( -- )
|
||||
1 minutes timeouts
|
||||
64 1024 * limit-input ;
|
||||
|
||||
: handle-client ( -- )
|
||||
[
|
||||
1 minutes timeouts
|
||||
setup-limits
|
||||
ascii decode-input
|
||||
ascii encode-output
|
||||
?refresh-all
|
||||
read-request
|
||||
do-request
|
||||
|
@ -90,7 +117,7 @@ LOG: httpd-hit NOTICE
|
|||
|
||||
: httpd ( port -- )
|
||||
dup integer? [ internet-server ] when
|
||||
"http.server" latin1 [ handle-client ] with-server ;
|
||||
"http.server" binary [ handle-client ] with-server ;
|
||||
|
||||
: httpd-main ( -- )
|
||||
8888 httpd ;
|
||||
|
|
|
@ -29,7 +29,10 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
H{ } clone >>special ;
|
||||
|
||||
: (serve-static) ( path mime-type -- response )
|
||||
[ [ binary <file-reader> &dispose ] dip <content> ]
|
||||
[
|
||||
[ binary <file-reader> &dispose ] dip
|
||||
<content> binary >>content-charset
|
||||
]
|
||||
[ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
|
||||
[ "content-length" set-header ]
|
||||
[ "last-modified" set-header ] bi* ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax byte-arrays alien ;
|
||||
USING: help.markup help.syntax byte-arrays alien destructors ;
|
||||
IN: io.buffers
|
||||
|
||||
ARTICLE: "buffers" "Locked I/O buffers"
|
||||
|
@ -7,8 +7,8 @@ $nl
|
|||
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
|
||||
{ $subsection buffer }
|
||||
{ $subsection <buffer> }
|
||||
"Buffers must be manually deallocated:"
|
||||
{ $subsection buffer-free }
|
||||
"Buffers must be manually deallocated by calling " { $link dispose } "."
|
||||
$nl
|
||||
"Buffer operations:"
|
||||
{ $subsection buffer-reset }
|
||||
{ $subsection buffer-length }
|
||||
|
@ -40,11 +40,6 @@ HELP: <buffer>
|
|||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
|
||||
{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
|
||||
|
||||
HELP: buffer-free
|
||||
{ $values { "buffer" buffer } }
|
||||
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
|
||||
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
|
||||
|
||||
HELP: buffer-reset
|
||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
|
||||
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
|
||||
|
@ -61,10 +56,6 @@ HELP: buffer-end
|
|||
{ $values { "buffer" buffer } { "alien" alien } }
|
||||
{ $description "Outputs the memory address of the current fill-pointer." } ;
|
||||
|
||||
HELP: (buffer-read)
|
||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
|
||||
{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
|
||||
|
||||
HELP: buffer-read
|
||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
|
||||
{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
IN: io.buffers.tests
|
||||
USING: alien alien.c-types io.buffers kernel kernel.private libc
|
||||
sequences tools.test namespaces byte-arrays strings accessors ;
|
||||
sequences tools.test namespaces byte-arrays strings accessors
|
||||
destructors ;
|
||||
|
||||
: buffer-set ( string buffer -- )
|
||||
over >byte-array over buffer-ptr byte-array>memory
|
||||
|
@ -18,7 +19,7 @@ sequences tools.test namespaces byte-arrays strings accessors ;
|
|||
65536 <buffer>
|
||||
dup buffer-read-all
|
||||
over buffer-capacity
|
||||
rot buffer-free
|
||||
rot dispose
|
||||
] unit-test
|
||||
|
||||
[ "hello world" "" ] [
|
||||
|
@ -26,34 +27,34 @@ sequences tools.test namespaces byte-arrays strings accessors ;
|
|||
dup buffer-read-all >string
|
||||
0 pick buffer-reset
|
||||
over buffer-read-all >string
|
||||
rot buffer-free
|
||||
rot dispose
|
||||
] unit-test
|
||||
|
||||
[ "hello" ] [
|
||||
"hello world" string>buffer
|
||||
5 over buffer-read >string swap buffer-free
|
||||
5 over buffer-read >string swap dispose
|
||||
] unit-test
|
||||
|
||||
[ 11 ] [
|
||||
"hello world" string>buffer
|
||||
[ buffer-length ] keep buffer-free
|
||||
[ buffer-length ] keep dispose
|
||||
] unit-test
|
||||
|
||||
[ "hello world" ] [
|
||||
"hello" 1024 <buffer> [ buffer-set ] keep
|
||||
" world" >byte-array over >buffer
|
||||
dup buffer-read-all >string swap buffer-free
|
||||
dup buffer-read-all >string swap dispose
|
||||
] unit-test
|
||||
|
||||
[ CHAR: e ] [
|
||||
"hello" string>buffer
|
||||
1 over buffer-consume [ buffer-pop ] keep buffer-free
|
||||
1 over buffer-consume [ buffer-pop ] keep dispose
|
||||
] unit-test
|
||||
|
||||
"hello world" string>buffer "b" set
|
||||
[ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test
|
||||
"b" get buffer-free
|
||||
"b" get dispose
|
||||
|
||||
100 <buffer> "b" set
|
||||
[ 1000 "b" get n>buffer >string ] must-fail
|
||||
"b" get buffer-free
|
||||
"b" get dispose
|
||||
|
|
|
@ -1,77 +1,101 @@
|
|||
! Copyright (C) 2004, 2005 Mackenzie Straight.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.accessors alien.c-types alien.syntax kernel
|
||||
kernel.private libc math sequences byte-arrays strings hints
|
||||
accessors math.order ;
|
||||
USING: accessors alien alien.accessors alien.c-types
|
||||
alien.syntax kernel libc math sequences byte-arrays strings
|
||||
hints accessors math.order destructors combinators ;
|
||||
IN: io.buffers
|
||||
|
||||
TUPLE: buffer size ptr fill pos ;
|
||||
TUPLE: buffer size ptr fill pos disposed ;
|
||||
|
||||
: <buffer> ( n -- buffer )
|
||||
dup malloc 0 0 buffer boa ;
|
||||
dup malloc 0 0 f buffer boa ;
|
||||
|
||||
: buffer-free ( buffer -- )
|
||||
dup buffer-ptr free f swap set-buffer-ptr ;
|
||||
M: buffer dispose* ptr>> free ;
|
||||
|
||||
: buffer-reset ( n buffer -- )
|
||||
0 swap { set-buffer-fill set-buffer-pos } set-slots ;
|
||||
|
||||
: buffer-consume ( n buffer -- )
|
||||
[ buffer-pos + ] keep
|
||||
[ buffer-fill min ] keep
|
||||
[ set-buffer-pos ] keep
|
||||
dup buffer-pos over buffer-fill >= [
|
||||
0 over set-buffer-pos
|
||||
0 over set-buffer-fill
|
||||
] when drop ;
|
||||
|
||||
: buffer@ ( buffer -- alien )
|
||||
dup buffer-pos swap buffer-ptr <displaced-alien> ;
|
||||
|
||||
: buffer-end ( buffer -- alien )
|
||||
dup buffer-fill swap buffer-ptr <displaced-alien> ;
|
||||
|
||||
: buffer-peek ( buffer -- byte )
|
||||
buffer@ 0 alien-unsigned-1 ;
|
||||
|
||||
: buffer-pop ( buffer -- byte )
|
||||
dup buffer-peek 1 rot buffer-consume ;
|
||||
|
||||
: (buffer-read) ( n buffer -- byte-array )
|
||||
[ [ fill>> ] [ pos>> ] bi - min ] keep
|
||||
buffer@ swap memory>byte-array ;
|
||||
|
||||
: buffer-read ( n buffer -- byte-array )
|
||||
[ (buffer-read) ] [ buffer-consume ] 2bi ;
|
||||
|
||||
: buffer-length ( buffer -- n )
|
||||
[ fill>> ] [ pos>> ] bi - ;
|
||||
swap >>fill 0 >>pos drop ;
|
||||
|
||||
: buffer-capacity ( buffer -- n )
|
||||
[ size>> ] [ fill>> ] bi - ;
|
||||
[ size>> ] [ fill>> ] bi - ; inline
|
||||
|
||||
: buffer-empty? ( buffer -- ? )
|
||||
fill>> zero? ;
|
||||
|
||||
: buffer-consume ( n buffer -- )
|
||||
[ + ] change-pos
|
||||
dup [ pos>> ] [ fill>> ] bi <
|
||||
[ 0 >>pos 0 >>fill ] unless drop ; inline
|
||||
|
||||
: buffer-peek ( buffer -- byte )
|
||||
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
|
||||
|
||||
: buffer-pop ( buffer -- byte )
|
||||
[ buffer-peek ] [ 1 swap buffer-consume ] bi ;
|
||||
|
||||
HINTS: buffer-pop buffer ;
|
||||
|
||||
: buffer-length ( buffer -- n )
|
||||
[ fill>> ] [ pos>> ] bi - ; inline
|
||||
|
||||
: buffer@ ( buffer -- alien )
|
||||
[ pos>> ] [ ptr>> ] bi <displaced-alien> ;
|
||||
|
||||
: buffer-read ( n buffer -- byte-array )
|
||||
[ buffer-length min ] keep
|
||||
[ buffer@ ] [ buffer-consume ] 2bi
|
||||
swap memory>byte-array ;
|
||||
|
||||
HINTS: buffer-read fixnum buffer ;
|
||||
|
||||
: extend-buffer ( n buffer -- )
|
||||
2dup buffer-ptr swap realloc
|
||||
over set-buffer-ptr set-buffer-size ;
|
||||
2dup ptr>> swap realloc >>ptr swap >>size drop ;
|
||||
inline
|
||||
|
||||
: check-overflow ( n buffer -- )
|
||||
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
|
||||
inline
|
||||
|
||||
: >buffer ( byte-array buffer -- )
|
||||
over length over check-overflow
|
||||
[ buffer-end byte-array>memory ] 2keep
|
||||
[ buffer-fill swap length + ] keep set-buffer-fill ;
|
||||
|
||||
: byte>buffer ( byte buffer -- )
|
||||
1 over check-overflow
|
||||
[ buffer-end 0 set-alien-unsigned-1 ] keep
|
||||
[ 1+ ] change-fill drop ;
|
||||
: buffer-end ( buffer -- alien )
|
||||
[ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
|
||||
|
||||
: n>buffer ( n buffer -- )
|
||||
[ buffer-fill + ] keep
|
||||
[ buffer-size > [ "Buffer overflow" throw ] when ] 2keep
|
||||
set-buffer-fill ;
|
||||
[ + ] change-fill
|
||||
[ fill>> ] [ size>> ] bi >
|
||||
[ "Buffer overflow" throw ] when ; inline
|
||||
|
||||
: >buffer ( byte-array buffer -- )
|
||||
[ [ length ] dip check-overflow ]
|
||||
[ buffer-end byte-array>memory ]
|
||||
[ [ length ] dip n>buffer ]
|
||||
2tri ;
|
||||
|
||||
HINTS: >buffer byte-array buffer ;
|
||||
|
||||
: byte>buffer ( byte buffer -- )
|
||||
[ 1 swap check-overflow ]
|
||||
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
|
||||
[ 1 swap n>buffer ]
|
||||
tri ;
|
||||
|
||||
HINTS: byte>buffer fixnum buffer ;
|
||||
|
||||
: search-buffer-until ( pos fill ptr separators -- n )
|
||||
[ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
|
||||
|
||||
: finish-buffer-until ( buffer n -- byte-array separator )
|
||||
[
|
||||
over pos>> -
|
||||
over buffer-read
|
||||
swap buffer-pop
|
||||
] [
|
||||
[ buffer-length ] keep
|
||||
buffer-read f
|
||||
] if* ;
|
||||
|
||||
: buffer-until ( separators buffer -- byte-array separator )
|
||||
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
|
||||
search-buffer-until
|
||||
finish-buffer-until ;
|
||||
|
||||
HINTS: buffer-until { string buffer } ;
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: io.encodings.string io.encodings.8-bit tools.test strings arrays ;
|
||||
USING: io.encodings.string io.encodings.8-bit
|
||||
io.encodings.8-bit.private tools.test strings arrays ;
|
||||
IN: io.encodings.8-bit.tests
|
||||
|
||||
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
|
||||
|
@ -8,3 +9,6 @@ IN: io.encodings.8-bit.tests
|
|||
[ "bar" ] [ "bar" latin1 decode ] unit-test
|
||||
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
|
||||
[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
|
||||
|
||||
[ t ] [ \ latin1 8-bit-encoding? ] unit-test
|
||||
[ "bar" ] [ "bar" \ latin1 decode ] unit-test
|
||||
|
|
|
@ -73,6 +73,13 @@ M: 8-bit decode-char
|
|||
: define-8-bit-encoding ( name stream -- )
|
||||
>r in get create r> parse-file make-8-bit ;
|
||||
|
||||
PREDICATE: 8-bit-encoding < word
|
||||
word-def dup length 1 = [ first 8-bit? ] [ drop f ] if ;
|
||||
|
||||
M: 8-bit-encoding <encoder> word-def first <encoder> ;
|
||||
|
||||
M: 8-bit-encoding <decoder> word-def first <decoder> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
[
|
||||
|
|
|
@ -41,6 +41,13 @@ PRIVATE>
|
|||
[ second ] map { "None" } diff
|
||||
] map ;
|
||||
|
||||
: more-aliases ( -- assoc )
|
||||
H{
|
||||
{ "UTF8" utf8 }
|
||||
{ "utf8" utf8 }
|
||||
{ "utf-8" utf8 }
|
||||
} ;
|
||||
|
||||
: make-n>e ( stream -- n>e )
|
||||
parse-iana [ [
|
||||
dup [
|
||||
|
@ -48,7 +55,7 @@ PRIVATE>
|
|||
[ swap [ set ] with each ]
|
||||
[ drop ] if*
|
||||
] with each
|
||||
] each ] H{ } make-assoc ;
|
||||
] each ] H{ } make-assoc more-aliases assoc-union ;
|
||||
PRIVATE>
|
||||
|
||||
"resource:extra/io/encodings/iana/character-sets"
|
||||
|
|
|
@ -71,6 +71,28 @@ M: input-port stream-read
|
|||
] [ 2nip ] if
|
||||
] [ 2nip ] if ;
|
||||
|
||||
: read-until-step ( separators port -- string/f separator/f )
|
||||
dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
|
||||
|
||||
: read-until-loop ( seps port buf -- separator/f )
|
||||
2over read-until-step over [
|
||||
>r over push-all r> dup [
|
||||
>r 3drop r>
|
||||
] [
|
||||
drop read-until-loop
|
||||
] if
|
||||
] [
|
||||
>r 2drop 2drop r>
|
||||
] if ;
|
||||
|
||||
M: input-port stream-read-until ( seps port -- str/f sep/f )
|
||||
2dup read-until-step dup [ >r 2nip r> ] [
|
||||
over [
|
||||
drop
|
||||
BV{ } like [ read-until-loop ] keep B{ } like swap
|
||||
] [ >r 2nip r> ] if
|
||||
] if ;
|
||||
|
||||
TUPLE: output-port < buffered-port ;
|
||||
|
||||
: <output-port> ( handle -- output-port )
|
||||
|
@ -121,7 +143,7 @@ M: output-port dispose*
|
|||
|
||||
M: buffered-port dispose*
|
||||
[ call-next-method ]
|
||||
[ [ [ buffer-free ] when* f ] change-buffer drop ]
|
||||
[ [ [ dispose ] when* f ] change-buffer drop ]
|
||||
bi ;
|
||||
|
||||
M: port cancel-operation handle>> cancel-operation ;
|
||||
|
|
|
@ -0,0 +1,32 @@
|
|||
IN: io.streams.limited.tests
|
||||
USING: io io.streams.limited io.encodings io.encodings.string
|
||||
io.encodings.ascii io.encodings.binary io.streams.byte-array
|
||||
namespaces tools.test strings kernel ;
|
||||
|
||||
[ ] [
|
||||
"hello world\nhow are you today\nthis is a very long line indeed"
|
||||
ascii encode binary <byte-reader> "data" set
|
||||
] unit-test
|
||||
|
||||
[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
|
||||
|
||||
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
|
||||
|
||||
[ ] [ "limited" get ascii <decoder> "decoded" set ] unit-test
|
||||
|
||||
[ "ello world" ] [ "decoded" get stream-readln ] unit-test
|
||||
|
||||
[ "how " ] [ 4 "decoded" get stream-read ] unit-test
|
||||
|
||||
[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"abc\ndef\nghi"
|
||||
ascii encode binary <byte-reader> "data" set
|
||||
] unit-test
|
||||
|
||||
[ ] [ "data" get 7 <limited-stream> "limited" set ] unit-test
|
||||
|
||||
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
|
||||
|
||||
[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math io destructors accessors sequences
|
||||
namespaces ;
|
||||
IN: io.streams.limited
|
||||
|
||||
TUPLE: limited-stream stream count limit ;
|
||||
|
||||
: <limited-stream> ( stream limit -- stream' )
|
||||
limited-stream new
|
||||
swap >>limit
|
||||
swap >>stream
|
||||
0 >>count ;
|
||||
|
||||
: limit-input ( limit -- )
|
||||
input-stream [ swap <limited-stream> ] change ;
|
||||
|
||||
ERROR: limit-exceeded ;
|
||||
|
||||
: check-limit ( n stream -- )
|
||||
[ + ] change-count
|
||||
[ count>> ] [ limit>> ] bi >=
|
||||
[ limit-exceeded ] when ; inline
|
||||
|
||||
M: limited-stream stream-read1
|
||||
1 over check-limit stream>> stream-read1 ;
|
||||
|
||||
M: limited-stream stream-read
|
||||
2dup check-limit stream>> stream-read ;
|
||||
|
||||
M: limited-stream stream-read-partial
|
||||
2dup check-limit stream>> stream-read-partial ;
|
||||
|
||||
: (read-until) ( stream seps buf -- stream seps buf sep/f )
|
||||
3dup [ [ stream-read1 dup ] dip memq? ] dip
|
||||
swap [ drop ] [ push (read-until) ] if ;
|
||||
|
||||
M: limited-stream stream-read-until
|
||||
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
|
||||
|
||||
M: limited-stream dispose
|
||||
stream>> dispose ;
|
|
@ -5,7 +5,7 @@
|
|||
USING: alien alien.c-types continuations kernel libc math macros
|
||||
namespaces math.vectors math.constants math.functions
|
||||
math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||
splitting words byte-arrays assocs combinators.lib ;
|
||||
splitting words byte-arrays assocs ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates ( point1 point2 -- x1 y2 x2 y2 )
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings namespaces math assocs shuffle
|
||||
vectors arrays combinators.lib math.parser
|
||||
vectors arrays math.parser
|
||||
unicode.categories sequences.deep peg peg.private
|
||||
peg.search math.ranges words memoize ;
|
||||
IN: peg.parsers
|
||||
|
|
|
@ -107,7 +107,7 @@ TUPLE: entry title url description date ;
|
|||
|
||||
: download-feed ( url -- feed )
|
||||
#! Retrieve an news syndication file, return as a feed tuple.
|
||||
http-get read-feed ;
|
||||
http-get nip read-feed ;
|
||||
|
||||
! Atom generation
|
||||
: simple-tag, ( content name -- )
|
||||
|
|
|
@ -150,6 +150,7 @@ IN: tools.deploy.shaker
|
|||
classes:class-or-cache
|
||||
classes:class<=-cache
|
||||
classes:classes-intersect-cache
|
||||
classes:implementors-map
|
||||
classes:update-map
|
||||
command-line:main-vocab-hook
|
||||
compiled-crossref
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: kernel combinators vocabs vocabs.loader tools.vocabs io
|
||||
io.files io.styles help.markup help.stylesheet sequences assocs
|
||||
help.topics namespaces prettyprint words sorting definitions
|
||||
arrays inspector ;
|
||||
arrays inspector sets ;
|
||||
IN: tools.vocabs.browser
|
||||
|
||||
: vocab-status-string ( vocab -- string )
|
||||
|
@ -105,7 +105,7 @@ C: <vocab-author> vocab-author
|
|||
|
||||
: vocab-xref ( vocab quot -- vocabs )
|
||||
>r dup vocab-name swap words r> map
|
||||
[ [ word? ] filter [ word-vocabulary ] map ] map>set
|
||||
[ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort
|
||||
remove sift [ vocab ] map ; inline
|
||||
|
||||
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
|
||||
|
|
|
@ -291,14 +291,11 @@ MEMO: all-vocabs-seq ( -- seq )
|
|||
[ vocab-dir? ] with filter
|
||||
] curry map concat ;
|
||||
|
||||
: map>set ( seq quot -- )
|
||||
map concat prune natural-sort ; inline
|
||||
|
||||
MEMO: all-tags ( -- seq )
|
||||
all-vocabs-seq [ vocab-tags ] map>set ;
|
||||
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
|
||||
|
||||
MEMO: all-authors ( -- seq )
|
||||
all-vocabs-seq [ vocab-authors ] map>set ;
|
||||
all-vocabs-seq [ vocab-authors ] gather natural-sort ;
|
||||
|
||||
: reset-cache ( -- )
|
||||
root-cache get-global clear-assoc
|
||||
|
|
|
@ -258,7 +258,7 @@ M: x11-ui-backend ui ( -- )
|
|||
] ui-running ;
|
||||
|
||||
M: x11-ui-backend beep ( -- )
|
||||
dpy 100 XBell drop ;
|
||||
dpy get 100 XBell drop ;
|
||||
|
||||
x11-ui-backend ui-backend set-global
|
||||
|
||||
|
|
|
@ -1,9 +0,0 @@
|
|||
USING: unicode.syntax unicode.data unicode.breaks
|
||||
unicode.normalize unicode.case unicode.categories
|
||||
parser kernel namespaces ;
|
||||
IN: unicode
|
||||
|
||||
! For now: convenience to load all Unicode vocabs
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
name>char-hook set-global
|
|
@ -59,4 +59,4 @@ format similar-ok language country site subscription license ;
|
|||
swap >>query ;
|
||||
|
||||
: search-yahoo ( search -- seq )
|
||||
query http-get string>xml parse-yahoo ;
|
||||
query http-get nip string>xml parse-yahoo ;
|
||||
|
|
|
@ -6,7 +6,7 @@ PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
|
|||
DLL_EXTENSION = .dylib
|
||||
|
||||
ifdef X11
|
||||
LIBS = -lm -framework Foundation $(X11_UI_LIBS)
|
||||
LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
|
||||
else
|
||||
LIBS = -lm -framework Cocoa -framework AppKit
|
||||
endif
|
||||
|
|
13
vm/types.c
13
vm/types.c
|
@ -283,19 +283,6 @@ DEFINE_PRIMITIVE(resize_byte_array)
|
|||
dpush(tag_object(reallot_byte_array(array,capacity)));
|
||||
}
|
||||
|
||||
F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
|
||||
{
|
||||
if(*result_count == byte_array_capacity(result))
|
||||
{
|
||||
result = reallot_byte_array(result,*result_count * 2);
|
||||
}
|
||||
|
||||
bput(BREF(result,*result_count),elt);
|
||||
*result_count++;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
|
||||
{
|
||||
CELL new_size = *result_count + len;
|
||||
|
|
|
@ -212,11 +212,6 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun
|
|||
CELL result##_count = 0; \
|
||||
CELL result = tag_object(allot_byte_array(100))
|
||||
|
||||
F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
|
||||
|
||||
#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
|
||||
result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
|
||||
|
||||
F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
|
||||
|
||||
#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
|
||||
|
|
Loading…
Reference in New Issue