namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators ;
+accessors combinators effects ;
IN: alien.c-types
DEFER: <int>
>r ">c-" swap "-array" 3append r> create ;
: define-to-array ( type vocab -- )
- [ to-array-word ] 2keep >c-array-quot define ;
+ [ to-array-word ] 2keep >c-array-quot
+ (( array -- byte-array )) define-declared ;
: c-array>quot ( type vocab -- quot )
[
>r "c-" swap "-array>" 3append r> create ;
: define-from-array ( type vocab -- )
- [ from-array-word ] 2keep c-array>quot define ;
+ [ from-array-word ] 2keep c-array>quot
+ (( c-ptr n -- array )) define-declared ;
: define-primitive-type ( type name -- )
"alien.c-types"
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-: indirect-test-1
+: indirect-test-1 ( ptr -- result )
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ -1 indirect-test-1 ] must-fail
-: indirect-test-2
+: indirect-test-2 ( x y ptr -- result )
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
-: indirect-test-3
+: indirect-test-3 ( a b c d ptr -- result )
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
! Make sure XT doesn't get clobbered in stack frame
-: ffi_test_31
+: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
"void"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
! Test callbacks
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
] with-scope
] unit-test
-: callback-4
+: callback-4 ( -- callback )
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
-: callback-5
+: callback-5 ( -- callback )
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
-: callback-5a
+: callback-5a ( -- callback )
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! ] unit-test
! ] unless
-: callback-6
+: callback-6 ( -- callback )
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-: callback-7
+: callback-7 ( -- callback )
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
-: callback-8
+: callback-8 ( -- callback )
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
-: callback-9
+: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
-init ;
+init sets ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
-: pop-parameters pop-literal nip [ expand-constants ] map ;
+: pop-parameters ( -- seq )
+ pop-literal nip [ expand-constants ] map ;
: stdcall-mangle ( symbol node -- symbol )
"@"
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
-: register-callback ( word -- ) dup callbacks get set-at ;
+: register-callback ( word -- ) callbacks get conjoin ;
M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
-: eval-callback
+: eval-callback ( -- callback )
"void*" { "char*" } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
-: yield-callback
+: yield-callback ( -- callback )
"void" { } "cdecl" [ yield ] alien-callback ;
-: sleep-callback
+: sleep-callback ( -- callback )
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
alien.strings kernel math namespaces parser sequences words
-quotations math.parser splitting effects prettyprint
+quotations math.parser splitting grouping effects prettyprint
prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax
"All associative mappings must implement methods on the following generic words:"
{ $subsection at* }
{ $subsection assoc-size }
-"At least one of the following two generic words must have a method; the " { $link assoc } " mixin has default definitions which are mutually recursive:"
{ $subsection >alist }
-{ $subsection assoc-find }
"Mutable assocs should implement the following additional words:"
{ $subsection set-at }
{ $subsection delete-at }
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection delete-at* }
-{ $subsection delete-any }
{ $subsection rename-at }
{ $subsection change-at }
{ $subsection at+ }
$nl
"The standard functional programming idioms:"
{ $subsection assoc-each }
+{ $subsection assoc-find }
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-filter }
HELP: assoc-find
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
-{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
-{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
+{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
HELP: clear-assoc
{ $values { "assoc" assoc } }
{ $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." }
{ $side-effects "assoc" } ;
-HELP: delete-any
-{ $values { "assoc" assoc } { "key" "a key" } { "value" "a value" } }
-{ $description "Removes an undetermined entry from the assoc and outputs it." }
-{ $errors "Throws an error if the assoc is empty." }
-{ $notes "This word is useful when using an assoc as an unordered queue which requires constant-time membership tests. Entries are enqueued with " { $link set-at } " and dequeued with " { $link delete-any } "." } ;
-
HELP: rename-at
{ $values { "newkey" object } { "key" object } { "assoc" assoc } }
{ $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." }
GENERIC: >alist ( assoc -- newassoc )
-GENERIC# assoc-find 1 ( assoc quot -- key value ? ) inline
+: (assoc-each) ( assoc quot -- seq quot' )
+ >r >alist r> [ first2 ] prepose ; inline
-M: assoc assoc-find
- >r >alist [ first2 ] r> compose find swap
- [ first2 t ] [ drop f f f ] if ;
+: assoc-find ( assoc quot -- key value ? )
+ (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
: assoc-each ( assoc quot -- )
- [ f ] compose assoc-find 3drop ; inline
-
-: (assoc>map) ( quot accum -- quot' )
- [ push ] curry compose ; inline
+ (assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
- >r over assoc-size
- <vector> [ (assoc>map) assoc-each ] keep
- r> like ; inline
+ >r accumulator >r assoc-each r> r> like ; inline
+
+: assoc-map-as ( assoc quot exemplar -- newassoc )
+ >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
: assoc-map ( assoc quot -- newassoc )
- over >r [ 2array ] compose V{ } assoc>map r> assoc-like ;
- inline
+ over assoc-map-as ; inline
: assoc-push-if ( key value quot accum -- )
>r 2keep r> roll
: rename-at ( newkey key assoc -- )
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
-: delete-any ( assoc -- key value )
- [
- [ 2drop t ] assoc-find
- [ "Assoc is empty" throw ] unless over
- ] keep delete-at ;
-
: assoc-empty? ( assoc -- ? )
assoc-size zero? ;
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
-M: assoc >alist [ 2array ] { } assoc>map ;
+! M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
+: push-at ( value key assoc -- )
+ [ ?push ] change-at ;
+
: zip ( keys values -- alist )
2array flip ; inline
USING: arrays help.markup help.syntax kernel
-kernel.private prettyprint strings vectors sbufs ;
+kernel.private math prettyprint strings vectors sbufs ;
IN: bit-arrays
ARTICLE: "bit-arrays" "Bit arrays"
{ $subsection <bit-array> }
"Efficiently setting and clearing all bits in a bit array:"
{ $subsection set-bits }
-{ $subsection clear-bits } ;
+{ $subsection clear-bits }
+"Converting between unsigned integers and their binary representation:"
+{ $subsection integer>bit-array }
+{ $subsection bit-array>integer } ;
ABOUT: "bit-arrays"
{ $code "[ drop t ] change-each" }
}
{ $side-effects "bit-array" } ;
+
+HELP: integer>bit-array
+{ $values { "integer" integer } { "bit-array" bit-array } }
+{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
+{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
+
+HELP: bit-array>integer
+{ $values { "bit-array" bit-array } { "integer" integer } }
+{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
+{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
[ t ] [
100 [
- drop 100 [ drop 2 random zero? ] map
+ drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] unit-test
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
[ -10 ?{ } resize-bit-array ] must-fail
+
+[ -1 integer>bit-array ] must-fail
+[ ?{ f t } ] [ 2 integer>bit-array ] unit-test
+[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test
+[ ?{
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+} ] [
+ HEX: ffffffffffffffffffffffffffffffff integer>bit-array
+] unit-test
+
+[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test
+[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
+} bit-array>integer ] unit-test
M: bit-array resize
resize-bit-array ;
+: integer>bit-array ( int -- bit-array )
+ [ log2 1+ <bit-array> 0 ] keep
+ [ dup zero? not ] [
+ [ -8 shift ] [ 255 bitand ] bi
+ -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
+ ] [ ] while
+ 2drop ;
+
+: bit-array>integer ( bit-array -- int )
+ dup >r length 7 + n>byte 0 r> [
+ swap alien-unsigned-1 swap 8 shift bitor
+ ] curry reduce ;
+
INSTANCE: bit-array sequence
enable-compiler
-: compile-uncompiled [ compiled? not ] filter compile ;
+: compile-uncompiled ( words -- )
+ [ compiled? not ] filter compile ;
nl
"Compiling..." write flush
underlying
- find-pair-next namestack*
+ namestack*
bitand bitor bitxor bitnot
} compile-uncompiled
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
-splitting growable classes classes.builtin classes.tuple
+splitting grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
: 1-offset 8 ; inline
: -1-offset 9 ; inline
-: array-start 2 bootstrap-cells object tag-number - ;
-: scan@ array-start bootstrap-cell - ;
-: wrapper@ bootstrap-cell object tag-number - ;
-: word-xt@ 8 bootstrap-cells object tag-number - ;
-: quot-array@ bootstrap-cell object tag-number - ;
-: quot-xt@ 3 bootstrap-cells object tag-number - ;
-
: jit-define ( quot rc rt offset name -- )
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! Bignums
-: bignum-bits bootstrap-cell-bits 2 - ;
+: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
-: bignum-radix bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
! Padded with fixnums for 8-byte alignment
-: t, t t-offset fixup ;
+: t, ( -- ) t t-offset fixup ;
M: f '
#! f is #define F RETAG(0,F_TYPE)
drop \ f tag-number ;
-: 0, 0 >bignum ' 0-offset fixup ;
-: 1, 1 >bignum ' 1-offset fixup ;
-: -1, -1 >bignum ' -1-offset fixup ;
+: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
+: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
+: -1, ( -- ) -1 >bignum ' -1-offset fixup ;
! Words
[
{
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
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
+H{ } clone new-classes set
H{ } clone changed-definitions set
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
"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
"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 -- )
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
"\""
"#!"
"("
+ "(("
":"
";"
"<PRIVATE"
\ flatten-class must-infer\r
\ flatten-builtin-class must-infer\r
\r
-: class= [ class<= ] [ swap class<= ] 2bi and ;\r
+: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;\r
\r
-: class-and* >r class-and r> class= ;\r
+: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;\r
\r
-: class-or* >r class-or r> class= ;\r
+: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;\r
\r
[ t ] [ object object object class-and* ] unit-test\r
[ t ] [ fixnum object fixnum class-and* ] unit-test\r
[ f ] [ null { number fixnum null } min-class ] unit-test\r
\r
! Test for hangs?\r
-: random-class classes random ;\r
+: random-class ( -- class ) classes random ;\r
\r
-: random-op\r
+: random-op ( -- word )\r
{\r
class-and\r
class-or\r
\r
10 [\r
[ ] [\r
- 20 [ drop random-op ] map >quotation\r
+ 20 [ random-op ] [ ] replicate-as\r
[ infer effect-in [ random-class ] times ] keep\r
call\r
drop\r
] unit-test\r
] times\r
\r
-: random-boolean\r
+: random-boolean ( -- ? )\r
{ t f } random ;\r
\r
-: boolean>class\r
+: boolean>class ( ? -- class )\r
object null ? ;\r
\r
-: random-boolean-op\r
+: random-boolean-op ( -- word )\r
{\r
and\r
or\r
xor\r
} random ;\r
\r
-: class-xor [ class-or ] 2keep class-and class-not class-and ;\r
+: class-xor ( cls1 cls2 -- cls3 )\r
+ [ class-or ] 2keep class-and class-not class-and ;\r
\r
-: boolean-op>class-op\r
+: boolean-op>class-op ( word -- word' )\r
{\r
{ and class-and }\r
{ or class-or }\r
\r
20 [\r
[ t ] [\r
- 20 [ drop random-boolean-op ] [ ] map-as dup .\r
- [ infer effect-in [ drop random-boolean ] map dup . ] keep\r
+ 20 [ random-boolean-op ] [ ] replicate-as dup .\r
+ [ infer effect-in [ random-boolean ] replicate dup . ] keep\r
\r
[ >r [ ] each r> call ] 2keep\r
\r
{ $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" } }
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
[ \ mx1 forget ] with-compilation-unit
! Empty unions were causing problems
-GENERIC: empty-union-test
+GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
-GENERIC: method-forget-test
+GENERIC: method-forget-test ( obj -- obj )
TUPLE: method-forget-class ;
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
! 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
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 1 { "?" } <effect> ;
-
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
M: word reset-class drop ;
-<PRIVATE
+GENERIC: implementors ( class/classes -- seq )
! update-map
: class-uses ( class -- seq )
tri
] { } make ;
-: class-usages ( class -- assoc )
- [ update-map get at ] closure ;
+: class-usages ( class -- seq )
+ [ update-map get at ] closure keys ;
+
+<PRIVATE
: update-map+ ( class -- )
dup class-uses update-map get add-vertex ;
: 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 )
[
{
: (define-class) ( word props -- )
>r
+ dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
M: class update-class drop ;
-GENERIC: update-methods ( assoc -- )
+GENERIC: update-methods ( class seq -- )
: update-classes ( class -- )
- class-usages
- [ [ drop update-class ] assoc-each ]
- [ update-methods ]
- bi ;
+ dup class-usages
+ [ nip [ update-class ] each ] [ update-methods ] 2bi ;
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
[ drop update-map+ ]
2tri ;
+: forget-predicate ( class -- )
+ dup "predicate" word-prop
+ dup length 1 = [
+ first
+ tuck "predicating" word-prop =
+ [ 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 -- ? )
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.union words kernel sequences
-definitions combinators arrays accessors ;
+definitions combinators arrays assocs generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class rank-class drop 3 ;
: redefine-mixin-class ( class members -- )
- dupd define-union-class
- t "mixin" set-word-prop ;
+ [ (define-union-class) ]
+ [ drop t "mixin" set-word-prop ]
+ 2bi ;
: define-mixin-class ( class -- )
dup mixin-class? [
] unless ;
: if-mixin-member? ( class mixin true false -- )
- >r >r check-mixin-class 2dup members memq? r> r> if ; inline
+ [ check-mixin-class 2dup members memq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
- [ members swap bootstrap-word ] prepose keep
+ [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
+: update-classes/new ( mixin -- )
+ class-usages
+ [ [ update-class ] each ]
+ [ implementors [ make-generic ] each ] bi ;
+
: add-mixin-instance ( class mixin -- )
- [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
+ #! Note: we call update-classes on the new member, not the
+ #! mixin. This ensures that we only have to update the
+ #! methods whose specializer intersects the new member, not
+ #! the entire mixin (since the other mixin members are not
+ #! affected at all). Also, all usages of the mixin will get
+ #! updated by transitivity; the mixins usages appear in
+ #! class-usages of the member, now that it's been added.
+ [ 2drop ] [
+ [ [ suffix ] change-mixin-class ] 2keep
+ tuck [ new-class? ] either? [
+ update-classes/new
+ ] [
+ update-classes
+ ] if
+ ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
- [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
+ [
+ [ [ swap remove ] change-mixin-class ] keep
+ update-classes
+ ] [ 2drop ] if-mixin-member? ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
IN: classes.tuple.tests
TUPLE: rect x y w h ;
-: <rect> rect boa ;
+: <rect> ( x y w h -- rect ) rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
PREDICATE: silly-pred < tuple
class \ rect = ;
-GENERIC: area
+GENERIC: area ( obj -- n )
M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ;
[
[ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test
+ [ ] [ \ <yo-momma> forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test
[ 1 ] [ <t4> 1 m2 ] unit-test
! another combination issue
-GENERIC: silly
+GENERIC: silly ( obj -- obj obj )
UNION: my-union slice repetition column array vector reversed ;
! We want to make sure constructors are recompiled when
! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem new ;
-: cons-test-2 \ erg's-reshape-problem boa ;
+: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
+: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
-: test-laptop-slot-values
+: test-laptop-slot-values ( -- )
[ laptop ] [ "laptop" get class ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
-: test-server-slot-values
+: test-server-slot-values ( -- )
[ server ] [ "server" get class ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
"a" "b" <test2> "test" set
-: test-a/b
+: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
[ "b" ] [ "test" get b>> ] unit-test ;
T{ move-up-2 f "a" "b" "c" } "move-up" set
-: test-move-up
+: test-move-up ( -- )
[ "a" ] [ "move-up" get a>> ] unit-test
[ "b" ] [ "move-up" get b>> ] unit-test
[ "c" ] [ "move-up" get c>> ] unit-test ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
-[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
+[ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ]
unit-test
-[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
+[ { subclass-forget-test-3 } ]
[ subclass-forget-test-3 class-usages ]
unit-test
[ subclass-forget-test-3 new ] must-fail
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
+
+! More
+DEFER: subclass-reset-test
+DEFER: subclass-reset-test-1
+DEFER: subclass-reset-test-2
+DEFER: subclass-reset-test-3
+
+GENERIC: break-me ( obj -- )
+
+[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
+
+[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
+
+[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
+
+[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
+[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
+[ subclass-forget-test-3 new ] must-fail
+
+[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
+
+[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
3tri ;
: subclasses ( class -- classes )
- class-usages keys [ tuple-class? ] filter ;
+ class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
2drop
[
[ update-tuples-after ]
- [ changed-definition ]
+ [ +inlined+ changed-definition ]
[ redefined ]
tri
] each-subclass
M: union-class update-class define-union-predicate ;
+: (define-union-class) ( class members -- )
+ f swap f union-class define-class ;
+
: define-union-class ( class members -- )
- [ f swap f union-class define-class ]
- [ drop update-classes ]
- 2bi ;
+ [ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;
main-vocab-hook get [ call ] [ "listener" ] if*
] if ;
-: default-cli-args
+: default-cli-args ( -- )
global [
"quiet" off
"script" off
inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
-inference combinators ;
+inference combinators dequeues search-dequeues ;
IN: compiler
-: ripple-up ( word -- )
- compiled-usage [ drop queue-compile ] assoc-each ;
+SYMBOL: +failed+
+
+: ripple-up ( words -- )
+ dup "compiled-effect" word-prop +failed+ eq?
+ [ usage [ word? ] filter ] [ compiled-usage keys ] if
+ [ queue-compile ] each ;
+
+: ripple-up? ( word effect -- ? )
+ #! If the word has previously been compiled and had a
+ #! different stack effect, we have to recompile any callers.
+ swap "compiled-effect" word-prop [ = not ] keep and ;
: save-effect ( word effect -- )
- [
- over "compiled-effect" word-prop = [
- dup "compiled-uses" word-prop
- [ dup ripple-up ] when
- ] unless drop
- ]
- [ "compiled-effect" set-word-prop ] 2bi ;
+ [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
+ [ "compiled-effect" set-word-prop ]
+ 2bi ;
: compile-begins ( word -- )
f swap compiler-error ;
[ swap compiler-error ]
[
drop
+ [ compiled-unxref ]
[ f swap compiled get set-at ]
- [ f save-effect ]
- bi
+ [ +failed+ save-effect ]
+ tri
] 2bi ;
: compile-succeeded ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
- dup compiled-crossref?
+ dup crossref?
[ dependencies get compiled-xref ] [ drop ] if
] tri ;
: (compile) ( word -- )
+ dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[
H{ } clone dependencies set
} cleave
] curry with-return ;
-: compile-loop ( assoc -- )
- dup assoc-empty? [ drop ] [
- dup delete-any drop (compile)
- yield
- compile-loop
- ] if ;
+: compile-loop ( dequeue -- )
+ [ (compile) yield ] slurp-dequeue ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
- H{ } clone compile-queue set
+ <hashed-dlist> compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
-: card-mark HEX: 40 HEX: 80 bitor ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
-: header-offset object tag-number neg ;
-: float-offset 8 float tag-number - ;
-: string-offset 4 bootstrap-cells object tag-number - ;
-: profile-count-offset 7 bootstrap-cells object tag-number - ;
-: byte-array-offset 2 bootstrap-cells object tag-number - ;
-: alien-offset 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset bootstrap-cell object tag-number - ;
-: tuple-class-offset bootstrap-cell tuple tag-number - ;
-: class-hash-offset bootstrap-cell object tag-number - ;
-: word-xt-offset 8 bootstrap-cells object tag-number - ;
-: word-code-offset 9 bootstrap-cells object tag-number - ;
-: compiled-header-size 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ;
+: float-offset ( -- n ) 8 float tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: compiled-header-size ( -- n ) 4 bootstrap-cells ;
[ set-at ] [ delete-at drop ] if
] [ 2drop ] if ;
-: :errors +error+ compiler-errors. ;
+: :errors ( -- ) +error+ compiler-errors. ;
-: :warnings +warning+ compiler-errors. ;
+: :warnings ( -- ) +warning+ compiler-errors. ;
-: :linkage +linkage+ compiler-errors. ;
+: :linkage ( -- ) +linkage+ compiler-errors. ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [
--- /dev/null
+IN: compiler.tests
+USING: words kernel inference alien.strings tools.test ;
+
+[ ] [ \ if redefined [ string>alien ] infer. ] unit-test
! Some randomized tests
: compiled-fixnum* fixnum* ;
-: test-fixnum*
+: test-fixnum* ( -- )
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
: compiled-fixnum>bignum fixnum>bignum ;
-: test-fixnum>bignum
+: test-fixnum>bignum ( -- )
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
: compiled-bignum>fixnum bignum>fixnum ;
-: test-bignum>fixnum
+: test-bignum>fixnum ( -- )
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def word-def [ { fixnum } declare ] prepend ;
+: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
--- /dev/null
+IN: compiler.tests
+USING: compiler compiler.units tools.test math parser kernel
+sequences sequences.private classes.mixin generic definitions
+arrays words assocs ;
+
+GENERIC: method-redefine-test ( a -- b )
+
+M: integer method-redefine-test 3 + ;
+
+: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
+
+[ 6 ] [ method-redefine-test-1 ] unit-test
+
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
+
+[ 7 ] [ method-redefine-test-1 ] unit-test
+
+[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
+
+[ 6 ] [ method-redefine-test-1 ] unit-test
+
+! Test ripple-up behavior
+: hey ( -- ) ;
+: there ( -- ) hey ;
+
+[ t ] [ \ hey compiled? ] unit-test
+[ t ] [ \ there compiled? ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
+[ f ] [ \ hey compiled? ] unit-test
+[ f ] [ \ there compiled? ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
+[ t ] [ \ there compiled? ] unit-test
+
+! Just changing the stack effect didn't mark a word for recompilation
+DEFER: change-effect
+
+[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
+{ 1 1 } [ change-effect ] must-infer-as
+
+[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
+{ 1 0 } [ change-effect ] must-infer-as
+
+: good ( -- ) ;
+: bad ( -- ) good ;
+: ugly ( -- ) bad ;
+
+[ t ] [ \ good compiled? ] unit-test
+[ t ] [ \ bad compiled? ] unit-test
+[ t ] [ \ ugly compiled? ] unit-test
+
+[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
+
+[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
+
+[ f ] [ \ good compiled? ] unit-test
+[ f ] [ \ bad compiled? ] unit-test
+[ f ] [ \ ugly compiled? ] unit-test
+
+[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
+
+[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
+
+[ t ] [ \ good compiled? ] unit-test
+[ t ] [ \ bad compiled? ] unit-test
+[ t ] [ \ ugly compiled? ] unit-test
+
+[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
--- /dev/null
+IN: compiler.tests
+USING: compiler compiler.units tools.test math parser kernel
+sequences sequences.private classes.mixin generic definitions
+arrays words assocs ;
+
+DEFER: blah
+
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
+
+[ t ] [ blah new sequence? ] unit-test
+
+[ 3 ] [ 0 blah new nth-unsafe ] unit-test
+
+[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ f ] [ blah new sequence? ] unit-test
+
+[ 0 blah new nth-unsafe ] must-fail
--- /dev/null
+IN: compiler.tests
+USING: compiler compiler.units tools.test math parser kernel
+sequences sequences.private classes.mixin generic definitions
+arrays words assocs ;
+
+GENERIC: sheeple ( obj -- x )
+
+M: object sheeple drop "sheeple" ;
+
+MIXIN: empty-mixin
+
+M: empty-mixin sheeple drop "wake up" ;
+
+: sheeple-test ( -- string ) { } sheeple ;
+
+[ "sheeple" ] [ sheeple-test ] unit-test
+[ t ] [ \ sheeple-test compiled? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+
+[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
+
+[ "wake up" ] [ sheeple-test ] unit-test
+[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+
+[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ "sheeple" ] [ sheeple-test ] unit-test
+[ t ] [ \ sheeple-test compiled? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
--- /dev/null
+IN: compiler.tests
+USE: vocabs.loader
+
+"parser" reload
+"sequences" reload
+"kernel" reload
! Regression
-: empty ;
+: empty ( -- ) ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
-: dummy-if-1 t [ ] [ ] if ;
+: dummy-if-1 ( -- ) t [ ] [ ] if ;
[ ] [ dummy-if-1 ] unit-test
-: dummy-if-2 f [ ] [ ] if ;
+: dummy-if-2 ( -- ) f [ ] [ ] if ;
[ ] [ dummy-if-2 ] unit-test
-: dummy-if-3 t [ 1 ] [ 2 ] if ;
+: dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
[ 1 ] [ dummy-if-3 ] unit-test
-: dummy-if-4 f [ 1 ] [ 2 ] if ;
+: dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
[ 2 ] [ dummy-if-4 ] unit-test
-: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
+: dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
[ 1 ] [ dummy-if-5 ] unit-test
-: dummy-if-6
+: dummy-if-6 ( n -- n )
dup 1 fixnum<= [
drop 1
] [
[ 17 ] [ 10 dummy-if-6 ] unit-test
-: dead-code-rec
+: dead-code-rec ( -- obj )
t [
3.2
] [
[ 3.2 ] [ dead-code-rec ] unit-test
-: one-rec [ f one-rec ] [ "hi" ] if ;
+: one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
[ "hi" ] [ t one-rec ] unit-test
-: after-if-test
+: after-if-test ( -- n )
t [ ] [ ] if 5 ;
[ 5 ] [ after-if-test ] unit-test
[ ] [ 10 countdown-b ] unit-test
-: dummy-when-1 t [ ] when ;
+: dummy-when-1 ( -- ) t [ ] when ;
[ ] [ dummy-when-1 ] unit-test
-: dummy-when-2 f [ ] when ;
+: dummy-when-2 ( -- ) f [ ] when ;
[ ] [ dummy-when-2 ] unit-test
-: dummy-when-3 dup [ dup fixnum* ] when ;
+: dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
[ 16 ] [ 4 dummy-when-3 ] unit-test
[ f ] [ f dummy-when-3 ] unit-test
-: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
+: dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
[ f t ] [ t f dummy-when-4 ] unit-test
-: dummy-when-5 f [ dup fixnum* ] when ;
+: dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
[ f ] [ f dummy-when-5 ] unit-test
-: dummy-unless-1 t [ ] unless ;
+: dummy-unless-1 ( -- ) t [ ] unless ;
[ ] [ dummy-unless-1 ] unit-test
-: dummy-unless-2 f [ ] unless ;
+: dummy-unless-2 ( -- ) f [ ] unless ;
[ ] [ dummy-unless-2 ] unit-test
-: dummy-unless-3 dup [ drop 3 ] unless ;
+: dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
[ 3 ] [ f dummy-unless-3 ] unit-test
[ 4 ] [ 4 dummy-unless-3 ] unit-test
] compile-call
] unit-test
-GENERIC: single-combination-test
+GENERIC: single-combination-test ( obj1 obj2 -- obj )
M: object single-combination-test drop ;
M: f single-combination-test nip ;
DEFER: single-combination-test-2
-: single-combination-test-4
+: single-combination-test-4 ( obj -- obj )
dup [ single-combination-test-2 ] when ;
-: single-combination-test-3
+: single-combination-test-3 ( obj -- obj )
drop 3 ;
-GENERIC: single-combination-test-2
+GENERIC: single-combination-test-2 ( obj -- obj )
M: object single-combination-test-2 single-combination-test-3 ;
M: f single-combination-test-2 single-combination-test-4 ;
IN: compiler.tests
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
-words splitting sorting ;
+words splitting grouping sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
2 group flip first ;
-: foo 3 throw 7 ;
-: bar foo 4 ;
-: baz bar 5 ;
+: foo ( -- * ) 3 throw 7 ;
+: bar ( -- * ) foo 4 ;
+: baz ( -- * ) bar 5 ;
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
{ baz bar foo throw } tail?
] unit-test
-: bleh [ 3 + ] map [ 0 > ] filter ;
+: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
-: stack-trace-contains? symbolic-stack-trace memq? ;
+: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test
-: quux { 1 2 3 } [ "hi" throw ] sort ;
+: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
[ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
-: foo ;
+: foo ( -- ) ;
[ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch
+: try-breaking-dispatch ( n a b -- a b str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
-: try-breaking-dispatch-2
+: try-breaking-dispatch-2 ( -- ? )
1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
[ t ] [
] unit-test
! Regression
-: foox
+: foox ( obj -- obj )
dup not
[ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
] unit-test
! Regression
-: a-dummy drop "hi" print ;
+: a-dummy ( -- ) drop "hi" print ;
[ ] [
1 [
] compile-call
] unit-test
-: float-spill-bug
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
: compile ( words -- )
recompile-hook get call
- dup [ drop compiled-crossref? ] assoc-contains?
+ dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
- changed-definitions get keys [ word? ] filter
+ changed-definitions get [ drop word? ] assoc-filter
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )
update-tuples-hook get call ;
+: unxref-forgotten-definitions ( -- )
+ forgotten-definitions get
+ keys [ word? ] filter
+ [ delete-compiled-xref ] each ;
+
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
- dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
- ;
+ unxref-forgotten-definitions
+ dup [ drop crossref? ] assoc-contains? modify-code-heap ;
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[
#! with a declaration.
f { object } declare ;
-: init-catchstack V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 setenv ;
PRIVATE>
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
-: %prologue-later \ %prologue-later , ;
+: %prologue-later ( -- ) \ %prologue-later , ;
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
-: %epilogue-later \ %epilogue-later , ;
+: %epilogue-later ( -- ) \ %epilogue-later , ;
! Store word XT in stack frame
HOOK: %save-word-xt cpu ( -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
-HOOK: %gc cpu
+HOOK: %gc cpu ( -- )
: operand ( var -- op ) get v>operand ; inline
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
\r
: jit-call-quot ( -- )\r
- temp-reg quot-reg quot-xt@ LWZ ! load quotation-xt\r
+ temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt\r
temp-reg MTCTR ! jump to quotation-xt\r
BCTR ;\r
\r
temp-reg ds-reg 0 LWZ ! load index\r
temp-reg dup 1 SRAWI ! turn it into an array offset\r
quot-reg dup temp-reg ADD ! compute quotation location\r
- quot-reg dup array-start LWZ ! load quotation\r
+ quot-reg dup array-start-offset LWZ ! load quotation\r
ds-reg dup 4 SUBI ! pop index\r
jit-call-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return return-reg stack-reg rot [+] ;
+: load/store-int-return ( n reg-class -- src dst )
+ return-reg stack-reg rot [+] ;
M: int-regs load-return-reg load/store-int-return MOV ;
M: int-regs store-return-reg load/store-int-return swap MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-: FSTP 4 = [ FSTPS ] [ FSTPL ] if ;
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
-: FLD 4 = [ FLDS ] [ FLDL ] if ;
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return reg-size >r stack@ r> ;
+: load/store-float-return ( n reg-class -- op size )
+ [ stack@ ] [ reg-size ] bi* ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
-: (%box-long-long)
+: (%box-long-long) ( n -- )
#! If n is f, push the return registers onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
M: x86.32 %box-long-long ( n func -- )
8 [
- >r (%box-long-long) r> f %alien-invoke
+ [ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
M: x86.32 %box-large-struct ( n size -- )
4 "double" c-type set-c-type-align
] unless
-: sse2? "Intrinsic" throw ;
+: sse2? ( -- ? ) "Intrinsic" throw ;
\ sse2? [
{ EAX EBX ECX EDX } [ PUSH ] each
4 \ cell set
-: arg0 EAX ;
-: arg1 EDX ;
-: temp-reg EBX ;
-: stack-reg ESP ;
-: ds-reg ESI ;
-: fixnum>slot@ arg0 1 SAR ;
-: rex-length 0 ;
+: arg0 ( -- reg ) EAX ;
+: arg1 ( -- reg ) EDX ;
+: temp-reg ( -- reg ) EBX ;
+: stack-reg ( -- reg ) ESP ;
+: ds-reg ( -- reg ) ESI ;
+: fixnum>slot@ ( -- ) arg0 1 SAR ;
+: rex-length ( -- n ) 0 ;
<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
call
8 \ cell set
-: arg0 RDI ;
-: arg1 RSI ;
-: temp-reg RBX ;
-: stack-reg RSP ;
-: ds-reg R14 ;
-: fixnum>slot@ ;
-: rex-length 1 ;
+: arg0 ( -- reg ) RDI ;
+: arg1 ( -- reg ) RSI ;
+: temp-reg ( -- reg ) RBX ;
+: stack-reg ( -- reg ) RSP ;
+: ds-reg ( -- reg ) R14 ;
+: fixnum>slot@ ( -- ) ;
+: rex-length ( -- n ) 1 ;
<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
call
generator.registers system layouts alien ;
IN: cpu.x86.allot
-: allot-reg
+: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
combinators compiler.constants math.order ;
IN: cpu.x86.architecture
-HOOK: ds-reg cpu
-HOOK: rs-reg cpu
-HOOK: stack-reg cpu
-HOOK: stack-save-reg cpu
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+HOOK: stack-save-reg cpu ( -- reg )
-: stack@ stack-reg swap [+] ;
+: stack@ ( n -- op ) stack-reg swap [+] ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
-HOOK: temp-reg-1 cpu
-HOOK: temp-reg-2 cpu
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
HOOK: address-operand cpu ( address -- operand )
-HOOK: fixnum>slot@ cpu
+HOOK: fixnum>slot@ cpu ( op -- )
-HOOK: prepare-division cpu
+HOOK: prepare-division cpu ( -- )
M: immediate load-literal v>operand swap v>operand MOV ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-: factor-area-size 4 cells ;
+: factor-area-size ( -- n ) 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
M: x86 %replace swap %peek ;
-: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-: temp@ stack-reg \ stack-frame get rot - [+] ;
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
-: REGISTERS:
+: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
>>
M: indirect extended? base>> extended? ;
-: canonicalize-EBP
+: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
- ] when drop ;
+ ] when ;
-: canonicalize-ESP
+: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
- dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
+ dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-: canonicalize ( indirect -- )
+: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- [ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
+ canonicalize-EBP canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
- indirect boa dup canonicalize ;
+ indirect boa canonicalize ;
-: reg-code "register" word-prop 7 bitand ;
+: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
-: indirect-base* base>> EBP or reg-code ;
+: indirect-base* ( op -- n ) base>> EBP or reg-code ;
-: indirect-index* index>> ESP or reg-code ;
+: indirect-index* ( op -- n ) index>> ESP or reg-code ;
-: indirect-scale* scale>> 0 or ;
+: indirect-scale* ( op -- n ) scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
-: 1, 1 n, ; inline
-: 4, 4 n, ; inline
-: 2, 2 n, ; inline
-: cell, bootstrap-cell n, ; inline
+: 1, ( n -- ) 1 n, ; inline
+: 4, ( n -- ) 4 n, ; inline
+: 2, ( n -- ) 2 n, ; inline
+: cell, ( n -- ) bootstrap-cell n, ; inline
: mod-r/m, ( reg# indirect -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
[ nip operand-64? ]
} cond and ;
-: rex.r
+: rex.r ( m op -- n )
extended? [ BIN: 00000100 bitor ] when ;
-: rex.b
+: rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [
index>> extended? [ BIN: 00000010 bitor ] when
#! the opcode.
>r dupd prefix-1 reg-code r> + , ;
-: opcode, dup array? [ % ] [ , ] if ;
+: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
#! 'reg' field of the mod-r/m byte.
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
-: immediate-operand-size-bit
+: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1 ( imm dst reg,rex.w,opcode -- )
: immediate-4 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 4, ;
-: immediate-fits-in-size-bit
+: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
! Control flow
GENERIC: JMP ( op -- )
-: (JMP) HEX: e9 , 0 4, rc-relative ;
+: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
-: (CALL) HEX: e8 , 0 4, rc-relative ;
+: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) extended-opcode, 0 4, rc-relative ;
+: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
-: JO HEX: 80 JUMPcc ;
-: JNO HEX: 81 JUMPcc ;
-: JB HEX: 82 JUMPcc ;
-: JAE HEX: 83 JUMPcc ;
-: JE HEX: 84 JUMPcc ; ! aka JZ
-: JNE HEX: 85 JUMPcc ;
-: JBE HEX: 86 JUMPcc ;
-: JA HEX: 87 JUMPcc ;
-: JS HEX: 88 JUMPcc ;
-: JNS HEX: 89 JUMPcc ;
-: JP HEX: 8a JUMPcc ;
-: JNP HEX: 8b JUMPcc ;
-: JL HEX: 8c JUMPcc ;
-: JGE HEX: 8d JUMPcc ;
-: JLE HEX: 8e JUMPcc ;
-: JG HEX: 8f JUMPcc ;
+: JO ( dst -- ) HEX: 80 JUMPcc ;
+: JNO ( dst -- ) HEX: 81 JUMPcc ;
+: JB ( dst -- ) HEX: 82 JUMPcc ;
+: JAE ( dst -- ) HEX: 83 JUMPcc ;
+: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
+: JNE ( dst -- ) HEX: 85 JUMPcc ;
+: JBE ( dst -- ) HEX: 86 JUMPcc ;
+: JA ( dst -- ) HEX: 87 JUMPcc ;
+: JS ( dst -- ) HEX: 88 JUMPcc ;
+: JNS ( dst -- ) HEX: 89 JUMPcc ;
+: JP ( dst -- ) HEX: 8a JUMPcc ;
+: JNP ( dst -- ) HEX: 8b JUMPcc ;
+: JL ( dst -- ) HEX: 8c JUMPcc ;
+: JGE ( dst -- ) HEX: 8d JUMPcc ;
+: JLE ( dst -- ) HEX: 8e JUMPcc ;
+: JG ( dst -- ) HEX: 8f JUMPcc ;
: LEAVE ( -- ) HEX: c9 , ;
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
-: CDQ HEX: 99 , ;
-: CQO HEX: 48 , CDQ ;
+: CDQ ( -- ) HEX: 99 , ;
+: CQO ( -- ) HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
-: CMOVO HEX: 40 MOVcc ;
-: CMOVNO HEX: 41 MOVcc ;
-: CMOVB HEX: 42 MOVcc ;
-: CMOVAE HEX: 43 MOVcc ;
-: CMOVE HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE HEX: 45 MOVcc ;
-: CMOVBE HEX: 46 MOVcc ;
-: CMOVA HEX: 47 MOVcc ;
-: CMOVS HEX: 48 MOVcc ;
-: CMOVNS HEX: 49 MOVcc ;
-: CMOVP HEX: 4a MOVcc ;
-: CMOVNP HEX: 4b MOVcc ;
-: CMOVL HEX: 4c MOVcc ;
-: CMOVGE HEX: 4d MOVcc ;
-: CMOVLE HEX: 4e MOVcc ;
-: CMOVG HEX: 4f MOVcc ;
+: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
+: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
+: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
+: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
+: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
+: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
+: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
+: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
+: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
+: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
+: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
+: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
+: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
+: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
+: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
+: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
! CPU Identification
-: CPUID HEX: a2 extended-opcode, ;
+: CPUID ( -- ) HEX: a2 extended-opcode, ;
! x87 Floating Point Unit
1 jit-code-format set
-: stack-frame-size 4 bootstrap-cells ;
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
[
! Load word
arg0 \ f tag-number CMP ! compare it with f
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
- arg0 quot-xt@ [+] JMP ! jump to quotation-xt
+ arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
[
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
- arg0 arg0 array-start [+] MOV ! load quotation
- arg0 quot-xt@ [+] JMP ! execute branch
+ arg0 arg0 array-start-offset [+] MOV ! load quotation
+ arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
} define-intrinsic
! Slots
-: %slot-literal-known-tag
+: %slot-literal-known-tag ( -- op )
"obj" operand
"n" get cells
"obj" get operand-tag - [+] ;
-: %slot-literal-any-tag
+: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" get cells [+] ;
-: %slot-any
+: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
{ +clobber+ { "offset" } }
} ;
-: define-getter
+: define-getter ( word quot reg -- )
[ %alien-integer-get ] 2curry
alien-integer-get-template
define-intrinsic ;
-: define-unsigned-getter
+: define-unsigned-getter ( word reg -- )
[ small-reg dup XOR MOV ] swap define-getter ;
-: define-signed-getter
+: define-signed-getter ( word reg -- )
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
: %alien-integer-set ( quot reg -- )
{ +clobber+ { "value" "offset" } }
} ;
-: define-setter
+: define-setter ( word reg -- )
[ swap MOV ] swap
[ %alien-integer-set ] 2curry
alien-integer-set-template
: :vars ( -- )
error-continuation get continuation-name namestack. ;
-: :res ( n -- )
+: :res ( n -- * )
1- restarts get-global nth f restarts set-global restart ;
-: :1 1 :res ;
-: :2 2 :res ;
-: :3 3 :res ;
+: :1 ( -- * ) 1 :res ;
+: :2 ( -- * ) 2 :res ;
+: :3 ( -- * ) 3 :res ;
: restart. ( restart n -- )
[
: stack-overflow. ( obj name -- )
write " stack overflow" print drop ;
-: datastack-underflow. "Data" stack-underflow. ;
-: datastack-overflow. "Data" stack-overflow. ;
-: retainstack-underflow. "Retain" stack-underflow. ;
-: retainstack-overflow. "Retain" stack-overflow. ;
+: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
+: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
+: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
+: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
-: memory-error.
+: memory-error. ( error -- )
"Memory protection fault at address " write third .h ;
-: primitive-error.
+: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
PREDICATE: kernel-error < array
[ second 0 15 between? ]
} cond ;
-: kernel-errors
+: kernel-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
SYMBOL: changed-definitions
-: changed-definition ( defspec -- )
- dup changed-definitions get
- [ no-compilation-unit ] unless*
- set-at ;
+SYMBOL: +inlined+
+SYMBOL: +called+
+
+: changed-definition ( defspec how -- )
+ swap changed-definitions get
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+SYMBOL: new-classes
+
+: new-class ( word -- )
+ dup new-classes get
+ [ set-at ] [ no-compilation-unit ] if* ;
+
+: new-class? ( word -- ? )
+ new-classes get key? ;
GENERIC: where ( defspec -- loc )
: xref ( defspec -- ) dup uses crossref get add-vertex ;
-: usage ( defspec -- seq ) \ f or crossref get at keys ;
+: usage ( defspec -- seq ) crossref get at keys ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: f smart-usage drop \ f smart-usage ;
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
: unxref ( defspec -- )
dup uses crossref get remove-vertex ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: dequeues
+USING: help.markup help.syntax kernel ;
+
+ARTICLE: "dequeues" "Dequeues"
+"A dequeue is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "dequeues" } " vocabulary."
+$nl
+"Dequeues must be instances of a mixin class:"
+{ $subsection dequeue }
+"Dequeues must implement a protocol."
+$nl
+"Querying the dequeue:"
+{ $subsection peek-front }
+{ $subsection peek-back }
+{ $subsection dequeue-length }
+{ $subsection dequeue-member? }
+"Adding and removing elements:"
+{ $subsection push-front* }
+{ $subsection push-back* }
+{ $subsection pop-front* }
+{ $subsection pop-back* }
+{ $subsection clear-dequeue }
+"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
+{ $subsection delete-node }
+{ $subsection node-value }
+"Utility operations built in terms of the above:"
+{ $subsection dequeue-empty? }
+{ $subsection push-front }
+{ $subsection push-all-front }
+{ $subsection push-back }
+{ $subsection push-all-back }
+{ $subsection pop-front }
+{ $subsection pop-back }
+{ $subsection slurp-dequeue }
+"When using a dequeue as a queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." ;
+
+ABOUT: "dequeues"
+
+HELP: dequeue-empty?
+{ $values { "dequeue" { $link dequeue } } { "?" "a boolean" } }
+{ $description "Returns true if a dequeue is empty." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-front
+{ $values { "obj" object } { "dequeue" dequeue } }
+{ $description "Push the object onto the front of the dequeue." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-front*
+{ $values { "obj" object } { "dequeue" dequeue } { "node" "a node" } }
+{ $description "Push the object onto the front of the dequeue and return the newly created node." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-back
+{ $values { "obj" object } { "dequeue" dequeue } }
+{ $description "Push the object onto the back of the dequeue." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-back*
+{ $values { "obj" object } { "dequeue" dequeue } { "node" "a node" } }
+{ $description "Push the object onto the back of the dequeue and return the newly created node." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: peek-front
+{ $values { "dequeue" dequeue } { "obj" object } }
+{ $description "Returns the object at the front of the dequeue." } ;
+
+HELP: pop-front
+{ $values { "dequeue" dequeue } { "obj" object } }
+{ $description "Pop the object off the front of the dequeue and return the object." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: pop-front*
+{ $values { "dequeue" dequeue } }
+{ $description "Pop the object off the front of the dequeue." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: peek-back
+{ $values { "dequeue" dequeue } { "obj" object } }
+{ $description "Returns the object at the back of the dequeue." } ;
+
+HELP: pop-back
+{ $values { "dequeue" dequeue } { "obj" object } }
+{ $description "Pop the object off the back of the dequeue and return the object." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: pop-back*
+{ $values { "dequeue" dequeue } }
+{ $description "Pop the object off the back of the dequeue." }
+{ $notes "This operation is O(1)." } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math ;
+IN: dequeues
+
+GENERIC: push-front* ( obj dequeue -- node )
+GENERIC: push-back* ( obj dequeue -- node )
+GENERIC: peek-front ( dequeue -- obj )
+GENERIC: peek-back ( dequeue -- obj )
+GENERIC: pop-front* ( dequeue -- )
+GENERIC: pop-back* ( dequeue -- )
+GENERIC: delete-node ( node dequeue -- )
+GENERIC: dequeue-length ( dequeue -- n )
+GENERIC: dequeue-member? ( value dequeue -- ? )
+GENERIC: clear-dequeue ( dequeue -- )
+GENERIC: node-value ( node -- value )
+
+: dequeue-empty? ( dequeue -- ? )
+ dequeue-length zero? ;
+
+: push-front ( obj dequeue -- )
+ push-front* drop ;
+
+: push-all-front ( seq dequeue -- )
+ [ push-front ] curry each ;
+
+: push-back ( obj dequeue -- )
+ push-back* drop ;
+
+: push-all-back ( seq dequeue -- )
+ [ push-back ] curry each ;
+
+: pop-front ( dequeue -- obj )
+ [ peek-front ] [ pop-front* ] bi ;
+
+: pop-back ( dequeue -- obj )
+ [ peek-back ] [ pop-back* ] bi ;
+
+: slurp-dequeue ( dequeue quot -- )
+ over dequeue-empty? [ 2drop ] [
+ [ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
+ ] if ; inline
+
+MIXIN: dequeue
--- /dev/null
+Double-ended queue protocol and common operations
--- /dev/null
+collections
-USING: help.markup help.syntax kernel quotations dlists.private ;
+USING: help.markup help.syntax kernel quotations
+dequeues ;
IN: dlists
-ARTICLE: "dlists" "Doubly-linked lists"
-"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object."
+ARTICLE: "dlists" "Double-linked lists"
+"A double-linked list is the canonical implementation of a " { $link dequeue } "."
$nl
-"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time."
-$nl
-"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "."
-$nl
-"Dlists form a class:"
+"Double-linked lists form a class:"
{ $subsection dlist }
{ $subsection dlist? }
-"Constructing a dlist:"
+"Constructing a double-linked list:"
{ $subsection <dlist> }
-"Working with the front of the list:"
-{ $subsection push-front }
-{ $subsection push-front* }
-{ $subsection peek-front }
-{ $subsection pop-front }
-{ $subsection pop-front* }
-"Working with the back of the list:"
-{ $subsection push-back }
-{ $subsection push-back* }
-{ $subsection peek-back }
-{ $subsection pop-back }
-{ $subsection pop-back* }
-"Finding out the length:"
-{ $subsection dlist-empty? }
-{ $subsection dlist-length }
+"Double-linked lists support all the operations of the dequeue protocol (" { $link "dequeues" } ") as well as the following."
+$nl
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
{ $subsection dlist-contains? }
-"Deleting a node:"
-{ $subsection delete-node }
-{ $subsection dlist-delete }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
-{ $subsection delete-node-if }
-"Consuming all nodes:"
-{ $subsection dlist-slurp } ;
+{ $subsection delete-node-if } ;
ABOUT: "dlists"
-HELP: dlist-empty?
-{ $values { "dlist" { $link dlist } } { "?" "a boolean" } }
-{ $description "Returns true if a " { $link dlist } " is empty." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: push-front
-{ $values { "obj" "an object" } { "dlist" dlist } }
-{ $description "Push the object onto the front of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: push-front*
-{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
-{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: push-back
-{ $values { "obj" "an object" } { "dlist" dlist } }
-{ $description "Push the object onto the back of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: push-back*
-{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
-{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: peek-front
-{ $values { "dlist" dlist } { "obj" "an object" } }
-{ $description "Returns the object at the front of the " { $link dlist } "." } ;
-
-HELP: pop-front
-{ $values { "dlist" dlist } { "obj" "an object" } }
-{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: pop-front*
-{ $values { "dlist" dlist } }
-{ $description "Pop the object off the front of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: peek-back
-{ $values { "dlist" dlist } { "obj" "an object" } }
-{ $description "Returns the object at the back of the " { $link dlist } "." } ;
-
-HELP: pop-back
-{ $values { "dlist" dlist } { "obj" "an object" } }
-{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." } ;
-
-HELP: pop-back*
-{ $values { "dlist" dlist } }
-{ $description "Pop the object off the back of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." } ;
-
-{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
-
HELP: dlist-find
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
-USING: dlists dlists.private kernel tools.test random assocs
-sets sequences namespaces sorting debugger io prettyprint
+USING: dequeues dlists dlists.private kernel tools.test random
+assocs sets sequences namespaces sorting debugger io prettyprint
math accessors classes ;
IN: dlists.tests
-[ t ] [ <dlist> dlist-empty? ] unit-test
+[ t ] [ <dlist> dequeue-empty? ] unit-test
[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
[ <dlist> 1 over push-front ] unit-test
! Make sure empty lists are empty
-[ t ] [ <dlist> dlist-empty? ] unit-test
-[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test
-[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test
+[ t ] [ <dlist> dequeue-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-front dequeue-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-back dequeue-empty? ] unit-test
[ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test
[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
! Test the prev,next links for two nodes
[ f ] [
<dlist> 1 over push-back 2 over push-back
- dlist-front dlist-node-prev
+ front>> prev>>
] unit-test
[ 2 ] [
<dlist> 1 over push-back 2 over push-back
- dlist-front dlist-node-next dlist-node-obj
+ front>> next>> obj>>
] unit-test
[ 1 ] [
<dlist> 1 over push-back 2 over push-back
- dlist-front dlist-node-next dlist-node-prev dlist-node-obj
+ front>> next>> prev>> obj>>
] unit-test
[ f ] [
<dlist> 1 over push-back 2 over push-back
- dlist-front dlist-node-next dlist-node-next
+ front>> next>> next>>
] unit-test
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
-[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
-
-[ 0 ] [ <dlist> dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
-[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
-
-: assert-same-elements
- [ prune natural-sort ] bi@ assert= ;
-
-: dlist-delete-all [ dlist-delete drop ] curry each ;
-
-: dlist>array [ [ , ] dlist-slurp ] { } make ;
-
-[ ] [
- 5 [ drop 30 random >fixnum ] map prune
- 6 [ drop 30 random >fixnum ] map prune [
- <dlist>
- [ push-all-front ]
- [ dlist-delete-all ]
- [ dlist>array ] tri
- ] 2keep swap diff assert-same-elements
-] unit-test
-
-[ ] [
- <dlist> "d" set
- 1 "d" get push-front
- 2 "d" get push-front
- 3 "d" get push-front
- 4 "d" get push-front
- 2 "d" get dlist-delete drop
- 3 "d" get dlist-delete drop
- 4 "d" get dlist-delete drop
-] unit-test
-
-[ 1 ] [ "d" get dlist-length ] unit-test
-[ 1 ] [ "d" get dlist>array length ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-empty? ] unit-test
+[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dequeue-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dequeue-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dequeue-length ] unit-test
+
+[ 0 ] [ <dlist> dequeue-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-front dequeue-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-front dup pop-front* dequeue-length ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
-[ <dlist> peek-front ] must-fail
-[ <dlist> peek-back ] must-fail
+[ <dlist> peek-front ] [ empty-dlist? ] must-fail-with
+[ <dlist> peek-back ] [ empty-dlist? ] must-fail-with
[ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
[ <dlist> pop-back ] [ empty-dlist? ] must-fail-with
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences accessors inspector ;
+USING: combinators kernel math sequences accessors inspector
+dequeues ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist new
- 0 >>length ;
+ 0 >>length ;
-: dlist-empty? ( dlist -- ? ) front>> not ;
+M: dlist dequeue-length length>> ;
<PRIVATE
C: <dlist-node> dlist-node
+M: dlist-node node-value obj>> ;
+
: inc-length ( dlist -- )
[ 1+ ] change-length drop ; inline
: dlist-each-node ( dlist quot -- )
[ f ] compose dlist-find-node 2drop ; inline
+: unlink-node ( dlist-node -- )
+ dup prev>> over next>> set-prev-when
+ dup next>> swap prev>> set-next-when ;
+
PRIVATE>
-: push-front* ( obj dlist -- dlist-node )
+M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
-: push-front ( obj dlist -- )
- push-front* drop ;
-
-: push-all-front ( seq dlist -- )
- [ push-front ] curry each ;
-
-: push-back* ( obj dlist -- dlist-node )
+M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
-: push-back ( obj dlist -- )
- push-back* drop ;
-
-: push-all-back ( seq dlist -- )
- [ push-back ] curry each ;
-
ERROR: empty-dlist ;
M: empty-dlist summary ( dlist -- )
- drop "Emtpy dlist" ;
+ drop "Empty dlist" ;
-: peek-front ( dlist -- obj )
- front>> [ empty-dlist ] unless* obj>> ;
+M: dlist peek-front ( dlist -- obj )
+ front>> [ obj>> ] [ empty-dlist ] if* ;
-: pop-front ( dlist -- obj )
- dup front>> [ empty-dlist ] unless*
+M: dlist pop-front* ( dlist -- )
+ dup front>> [ empty-dlist ] unless
[
+ dup front>>
dup next>>
f rot (>>next)
f over set-prev-when
swap (>>front)
- ] 2keep obj>>
- swap [ normalize-back ] keep dec-length ;
+ ] keep
+ [ normalize-back ] keep
+ dec-length ;
-: pop-front* ( dlist -- )
- pop-front drop ;
+M: dlist peek-back ( dlist -- obj )
+ back>> [ obj>> ] [ empty-dlist ] if* ;
-: peek-back ( dlist -- obj )
- back>> [ empty-dlist ] unless* obj>> ;
-
-: pop-back ( dlist -- obj )
- dup back>> [ empty-dlist ] unless*
+M: dlist pop-back* ( dlist -- )
+ dup back>> [ empty-dlist ] unless
[
+ dup back>>
dup prev>>
f rot (>>prev)
f over set-next-when
swap (>>back)
- ] 2keep obj>>
- swap [ normalize-front ] keep dec-length ;
-
-: pop-back* ( dlist -- )
- pop-back drop ;
+ ] keep
+ [ normalize-front ] keep
+ dec-length ;
: dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
-: unlink-node ( dlist-node -- )
- dup prev>> over next>> set-prev-when
- dup next>> swap prev>> set-next-when ;
+M: dlist dequeue-member? ( value dlist -- ? )
+ [ = ] curry dlist-contains? ;
-: delete-node ( dlist dlist-node -- )
+M: dlist delete-node ( dlist-node dlist -- )
{
- { [ over front>> over eq? ] [ drop pop-front* ] }
- { [ over back>> over eq? ] [ drop pop-back* ] }
- [ unlink-node dec-length ]
+ { [ 2dup front>> eq? ] [ nip pop-front* ] }
+ { [ 2dup back>> eq? ] [ nip pop-back* ] }
+ [ dec-length unlink-node ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
dupd dlist-find-node [
dup [
- [ delete-node ] keep obj>> t
+ [ swap delete-node ] keep obj>> t
] [
2drop f f
] if
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
- [ obj>> ] prepose
- delete-node-if* drop ; inline
-
-: dlist-delete ( obj dlist -- obj/f )
- swap [ eq? ] curry delete-node-if ;
+ [ obj>> ] prepose delete-node-if* drop ; inline
-: dlist-delete-all ( dlist -- )
+M: dlist clear-dequeue ( dlist -- )
f >>front
f >>back
0 >>length
: dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline
-: dlist-slurp ( dlist quot -- )
- over dlist-empty?
- [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
- inline
-
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
+
+INSTANCE: dlist dequeue
IN: effects
ARTICLE: "effect-declaration" "Stack effect declaration"
-"It is good practice to declare the stack effects of words using the following syntax:"
+"Stack effects of words must be declared, with the exception of words which only push literals on the stack."
+$nl
+"Stack effects are declared with the following syntax:"
{ $code ": sq ( x -- y ) dup * ;" }
"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Stack effect declarations are read in using a parsing word:"
{ $subsection POSTPONE: ( }
"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:"
{ $table
{ { { $snippet "?" } } "a boolean" }
+ { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } }
{ { { $snippet "elt" } } "an object which is an element of a sequence" }
{ { { $snippet "m" } ", " { $snippet "n" } } "an integer" }
{ { { $snippet "obj" } } "an object" }
ARTICLE: "effects" "Stack effects"
"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
$nl
+"Stack effects of words can be declared."
+{ $subsection "effect-declaration" }
"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
{ $subsection effect }
{ $subsection effect? }
-"Stack effects of words can be declared."
-{ $subsection "effect-declaration" }
+"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
+{ $subsection POSTPONE: (( }
"Getting a word's declared stack effect:"
{ $subsection stack-effect }
"Converting a stack effect to a string form:"
{ $subsection effect>string }
"Comparing effects:"
{ $subsection effect-height }
-{ $subsection effect<= } ;
+{ $subsection effect<= }
+{ $see-also "inference" } ;
ABOUT: "effects"
IN: effects.tests
-USING: effects tools.test ;
+USING: effects tools.test prettyprint accessors sequences ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
-[ t ] [ 2 3 <effect> f effect<= ] unit-test
+[ 2 ] [ (( a b -- c )) in>> length ] unit-test
+[ 1 ] [ (( a b -- c )) out>> length ] unit-test
+
+
+[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
+[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
+[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
+[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
+[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
-combinators ;
+combinators accessors ;
IN: effects
TUPLE: effect in out terminated? ;
effect boa ;
: effect-height ( effect -- n )
- dup effect-out length swap effect-in length - ;
+ [ out>> length ] [ in>> length ] bi - ;
: effect<= ( eff1 eff2 -- ? )
{
- { [ dup not ] [ t ] }
- { [ over effect-terminated? ] [ t ] }
- { [ dup effect-terminated? ] [ f ] }
- { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
+ { [ over terminated?>> ] [ t ] }
+ { [ dup terminated?>> ] [ f ] }
+ { [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ;
: effect>string ( effect -- string )
[
"( " %
- dup effect-in stack-picture %
- "-- " %
- dup effect-out stack-picture %
- effect-terminated? [ "* " % ] when
+ [ in>> stack-picture % "-- " % ]
+ [ out>> stack-picture % ]
+ [ terminated?>> [ "* " % ] when ]
+ tri
")" %
] "" make ;
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
- [ effect-in clone ] keep effect-out clone <effect> ;
+ [ in>> clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- effect-in length cut* ;
+ in>> length cut* ;
: load-shuffle ( stack shuffle -- )
- effect-in [ set ] 2each ;
+ in>> [ set ] 2each ;
: shuffled-values ( shuffle -- values )
- effect-out [ get ] map ;
+ out>> [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+ ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer
optimizer.specializers prettyprint quotations sequences system
-threads words vectors ;
+threads words vectors sets dequeues ;
IN: generator
SYMBOL: compile-queue
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
- [ dup compile-queue get set-at ]
+ [ compile-queue get push-front ]
} cond ;
: maybe-compile ( word -- )
: word-dataflow ( word -- effect dataflow )
[
- dup "no-effect" word-prop [ no-effect ] when
- dup "no-compile" word-prop [ no-effect ] when
- dup specialized-def over dup 2array 1array infer-quot
- finish-word
+ [
+ dup "cannot-infer" word-prop [ cannot-infer-effect ] when
+ dup "no-compile" word-prop [ cannot-infer-effect ] when
+ dup specialized-def over dup 2array 1array infer-quot
+ finish-word
+ ] maybe-cannot-infer
] with-infer ;
: intrinsics ( #call -- quot )
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> f ds-loc boa ;
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> f rs-loc boa ;
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
<PRIVATE
! Moving values between locations and registers
-: %move-bug "Bug in generator.registers" throw ;
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
-: (loc)
+: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
-GENERIC: generic-forget-test-2
+GENERIC: generic-forget-test-2 ( a b -- c )
M: sequence generic-forget-test-2 = ;
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
-GENERIC: generic-forget-test-3
+GENERIC: generic-forget-test-3 ( a -- b )
M: f generic-forget-test-3 ;
! 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
\ check-method boa throw
] unless ; inline
-: with-methods ( generic quot -- )
- swap [ "methods" word-prop swap call ] keep make-generic ;
- inline
+: affected-methods ( class generic -- seq )
+ "methods" word-prop swap
+ [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
+ values ;
+
+: update-generic ( class generic -- )
+ affected-methods [ +called+ changed-definition ] each ;
+
+: with-methods ( class generic quot -- )
+ [ drop update-generic ]
+ [ [ "methods" word-prop ] dip call ]
+ [ drop make-generic drop ]
+ 3tri ; inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
"method-generic" word-prop stack-effect ;
M: method-body crossref?
- drop t ;
+ "forgotten" word-prop not ;
: method-word-props ( class generic -- assoc )
[
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 [
] if ;
: <default-method> ( generic combination -- method )
- object bootstrap-word pick <method>
- [ -rot make-default-method define ] keep ;
+ [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
+ [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
: define-default-method ( generic combination -- )
dupd <default-method> "default-method" set-word-prop ;
M: method-spec forget*
first2 method forget* ;
+M: method-spec smart-usage
+ second smart-usage ;
+
M: method-body definer
drop \ M: \ ; ;
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
- [ ]
- [ "method-class" word-prop ]
- [ "method-generic" word-prop ] tri
- 3dup method eq? [
- [ delete-at ] with-methods
- call-next-method
- ] [ 3drop ] if
+ dup "default" word-prop [ drop ] [
+ [
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ 2dup method
+ ] keep eq?
+ [
+ [ [ delete-at ] with-methods ]
+ [ [ delete-at ] with-implementors ]
+ 2bi
+ ] [ 2drop ] if
+ ] if
]
- [ t "forgotten" set-word-prop ] bi
+ [ call-next-method ] bi
] if ;
-: implementors* ( classes -- words )
- all-words [
- "methods" word-prop keys
- swap [ key? ] curry contains?
- ] with filter ;
+M: method-body smart-usage
+ "method-generic" word-prop smart-usage ;
-: implementors ( class -- seq )
- dup associate implementors* ;
-
-: forget-methods ( class -- )
- [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
-
-M: class forget* ( class -- )
- [
- class-usages [
- drop
- [ forget-methods ]
- [ update-map- ]
- [ reset-class ]
- tri
- ] assoc-each
- ]
- [ call-next-method ] bi ;
-
-M: assoc update-methods ( assoc -- )
- implementors* [ make-generic ] each ;
+M: sequence update-methods ( class seq -- )
+ implementors [
+ [ update-generic ] [ make-generic drop ] 2bi
+ ] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [
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
\ hi-tag bootstrap-word
\ <hi-tag-dispatch-engine> convert-methods ;
-: num-hi-tags num-types get num-tags get - ;
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n )
"type" word-prop num-tags get - ;
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
classes.algebra math math.private kernel.private
-quotations arrays ;
+quotations arrays definitions ;
IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ;
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
-: word-hashcode% [ 1 slot ] % ;
+: word-hashcode% ( -- ) [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
[
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: engine-word compiled-crossref?
- drop t ;
+M: engine-word crossref? "forgotten" word-prop not ;
+
+M: engine-word irrelevant? drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
: define-engine-word ( quot -- word )
>r <engine-word> dup r> define ;
-: array-nth% 2 + , [ slot { word } declare ] % ;
+: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
-prettyprint byte-vectors bit-vectors float-vectors ;
+prettyprint byte-vectors bit-vectors float-vectors definitions
+generic sets graphs assocs ;
-GENERIC: lo-tag-test
+GENERIC: lo-tag-test ( obj -- obj' )
M: integer lo-tag-test 3 + ;
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-GENERIC: hi-tag-test
+GENERIC: hi-tag-test ( obj -- obj' )
M: string hi-tag-test ", in bed" append ;
C: <circle> circle
-GENERIC: area
+GENERIC: area ( shape -- n )
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-GENERIC: perimiter
+GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter + 2 * ;
+: rectangle-perimiter ( n -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
-: hypotenuse [ sq ] bi@ + sqrt ;
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
-GENERIC: big-mix-test
+GENERIC: big-mix-test ( obj -- obj' )
M: object big-mix-test drop "object" ;
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
-GENERIC: small-lo-tag
+GENERIC: small-lo-tag ( obj -- obj )
M: fixnum small-lo-tag drop "fixnum" ;
M: c funky* "c" , call-next-method ;
-: funky [ funky* ] { } make ;
+: funky ( obj -- seq ) [ funky* ] { } make ;
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test
+
+! Cross-referencing with generic words
+TUPLE: xref-tuple-1 ;
+TUPLE: xref-tuple-2 < xref-tuple-1 ;
+
+: (xref-test) ( obj -- ) drop ;
+
+GENERIC: xref-test ( obj -- )
+
+M: xref-tuple-1 xref-test (xref-test) ;
+M: xref-tuple-2 xref-test (xref-test) ;
+
+[ t ] [
+ \ xref-test
+ \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
+] unit-test
+
+[ t ] [
+ \ xref-test
+ \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
+] unit-test
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
- [
- generic get "inline" word-prop [
- <predicate-dispatch-engine>
- ] [
- <big-dispatch-engine>
- ] if
- ] bi
- engine>quot
+ [ <big-dispatch-engine> ]
+ bi engine>quot
]
} cleave
] with-scope ;
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces sequences ;
+USING: assocs kernel namespaces sequences sets ;
IN: graphs
SYMBOL: graph
over previous get key? [
2drop
] [
- over dup previous get set-at
+ over previous get conjoin
dup slip
[ nip (closure) ] curry assoc-each
] if ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax sequences strings ;
+IN: grouping
+
+ARTICLE: "grouping" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
+ABOUT: "grouping"
+
+HELP: groups
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
+{ $see-also group } ;
+
+HELP: group
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $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: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
+
+HELP: <groups>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" 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 grouping ;"
+ "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+ }
+} ;
+
+HELP: <sliced-groups>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" 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 grouping ;"
+ "9 >array 3 <sliced-groups>"
+ "dup [ reverse-here ] each concat >array ."
+ "{ 2 1 0 5 4 3 8 7 6 }"
+ }
+} ;
+
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $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: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "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 } ;"
+ ""
+ "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
--- /dev/null
+USING: grouping tools.test kernel sequences arrays ;
+IN: grouping.tests
+
+[ { 1 2 3 } 0 group ] must-fail
+
+[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+ V{ "a" "b" } clone 2 <groups>
+ 2 over set-length
+ >array
+] unit-test
+
+[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order strings arrays vectors sequences
+accessors ;
+IN: grouping
+
+TUPLE: abstract-groups seq n ;
+
+: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: new-groups ( seq n class -- groups )
+ >r check-groups r> boa ; inline
+
+GENERIC: group@ ( n groups -- from to seq )
+
+M: abstract-groups nth group@ subseq ;
+
+M: abstract-groups set-nth group@ <slice> 0 swap copy ;
+
+M: abstract-groups like drop { } like ;
+
+INSTANCE: abstract-groups sequence
+
+TUPLE: groups < abstract-groups ;
+
+: <groups> ( seq n -- groups )
+ groups new-groups ; inline
+
+M: groups length
+ [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+
+M: groups set-length
+ [ n>> * ] [ seq>> ] bi set-length ;
+
+M: groups group@
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+
+TUPLE: sliced-groups < groups ;
+
+: <sliced-groups> ( seq n -- groups )
+ sliced-groups new-groups ; inline
+
+M: sliced-groups nth group@ <slice> ;
+
+TUPLE: clumps < abstract-groups ;
+
+: <clumps> ( seq n -- clumps )
+ clumps new-groups ; inline
+
+M: clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+TUPLE: sliced-clumps < clumps ;
+
+: <sliced-clumps> ( seq n -- clumps )
+ sliced-clumps new-groups ; inline
+
+M: sliced-clumps nth group@ <slice> ;
+
+: group ( seq n -- array ) <groups> { } like ;
+
+: clump ( seq n -- array ) <clumps> { } like ;
--- /dev/null
+Grouping sequence elements into subsequences
--- /dev/null
+collections
$nl
"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries."
{ $subsection <hash-array> }
-{ $subsection nth-pair }
{ $subsection set-nth-pair }
-{ $subsection find-pair }
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
{ $subsection rehash } ;
{ $values { "key" "a key" } { "hash" hashtable } { "array" "the underlying array of the hashtable" } { "n" "the index where the key would be stored" } { "empty?" "a boolean indicating whether the location is currently empty" } }
{ $description "Searches the hashtable for the key using a linear probing strategy. If the key is not present in the hashtable, outputs the index where it should be stored." } ;
-HELP: nth-pair
-{ $values { "n" "an index in the sequence" } { "seq" "a sequence" } { "key" "the first element of the pair" } { "value" "the second element of the pair" } }
-{ $description "Fetches the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
-{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." } ;
-
-{ nth-pair set-nth-pair } related-words
-
HELP: set-nth-pair
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "seq" "a sequence" } { "n" "an index in the sequence" } }
{ $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." }
{ $side-effects "seq" } ;
-HELP: find-pair
-{ $values { "array" "an array of pairs" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key" } { "value" "the successful value" } { "?" "a boolean of whether there was success" } }
-{ $description "Applies a quotation to successive pairs in the array, yielding the first successful pair." }
-{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because passing an array of odd length can lead to memory corruption." } ;
-
HELP: reset-hash
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" hashtable } }
{ $description "Resets the underlying array of the hashtable to a new array with the given capacity. Removes all entries from the hashtable." }
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
- math.private sequences sequences.private vectors ;
+math.private sequences sequences.private vectors grouping ;
IN: hashtables
<PRIVATE
: new-key@ ( key hash -- array n empty? )
hash-array 2dup hash@ (new-key@) ; inline
-: nth-pair ( n seq -- key value )
- swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ;
- inline
-
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
[ rot hash-count+ set-nth-pair t ]
[ rot drop set-nth-pair f ] if ; inline
-: find-pair-next >r 2 fixnum+fast r> ; inline
-
-: (find-pair) ( quot i array -- key value ? )
- 2dup array-capacity eq? [
- 3drop f f f
- ] [
- 2dup array-nth tombstone? [
- find-pair-next (find-pair)
- ] [
- [ nth-pair rot call ] 3keep roll [
- nth-pair >r nip r> t
- ] [
- find-pair-next (find-pair)
- ] if
- ] if
- ] if ; inline
-
-: find-pair ( array quot -- key value ? )
- 0 rot (find-pair) ; inline
-
-: (rehash) ( hash array -- )
- [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
+: (rehash) ( hash alist -- )
+ swap [ swapd (set-hash) drop ] curry assoc-each ;
: hash-large? ( hash -- ? )
[ hash-count 3 fixnum*fast ]
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
: grow-hash ( hash -- )
- [ dup hash-array swap assoc-size 1+ ] keep
+ [ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep
swap (rehash) ;
dup hash-count swap hash-deleted - ;
: rehash ( hash -- )
- dup hash-array
-
dup length ((empty)) <array> pick set-hash-array
+ dup >alist
+
over hash-array length ((empty)) <array> pick set-hash-array
0 pick set-hash-count
0 pick set-hash-deleted
(rehash) ;
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
-M: hashtable assoc-find ( hash quot -- key value ? )
- >r hash-array r> find-pair ;
+M: hashtable >alist
+ hash-array 2 <groups> [ first tombstone? not ] filter ;
M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
{ $values { "node" "a dataflow node" } { "effect" "an instance of " { $link effect } } }
{ $description "Adds a node to the dataflow graph that calls " { $snippet "word" } " with a stack effect of " { $snippet "effect" } "." } ;
-HELP: no-effect
+HELP: cannot-infer-effect
{ $values { "word" word } }
-{ $description "Throws a " { $link no-effect } " error." }
+{ $description "Throws a " { $link cannot-infer-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: inline-word
{ $description "Throws an " { $link effect-error } "." }
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
-HELP: recursive-declare-error
-{ $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
+HELP: missing-effect
+{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
HELP: recursive-quotation-error
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple accessors math.order ;
+generic.standard.engines.tuple accessors math.order definitions
+sets ;
IN: inference.backend
: recursive-label ( word -- label/f )
M: word inline?
"inline" word-prop ;
+SYMBOL: visited
+
+: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ visited get conjoin ]
+ [
+ crossref get at keys
+ [ word? ] filter
+ [
+ [ reset-on-redefine [ word-prop ] with contains? ]
+ [ inline? ]
+ bi or
+ ] filter
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
+
: local-recursive-state ( -- assoc )
recursive-state get dup keys
[ dup word? [ inline? ] when not ] find drop
1 #drop node,
pop-d dup value-literal >r value-recursion r> ;
-: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
+: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
: add-inputs ( seq stack -- n stack )
tuck [ length ] bi@ - dup 0 >
meta-d [ add-inputs ] change d-in [ + ] change ;
: current-effect ( -- effect )
- d-in get meta-d get length <effect>
- terminated? get over set-effect-terminated? ;
+ d-in get
+ meta-d get length <effect>
+ terminated? get >>terminated? ;
: init-inference ( -- )
terminated? off
terminated? on #terminate node, ;
: infer-quot ( quot rstate -- )
- recursive-state get >r
- recursive-state set
- [ apply-object terminated? get not ] all? drop
- r> recursive-state set ;
+ recursive-state get [
+ recursive-state set
+ [ apply-object terminated? get not ] all? drop
+ ] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- )
- recursive-state get -rot 2array prefix infer-quot ;
+ 2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
value-literal recursive-quotation-error inference-error
] [
dup value-literal callable? [
- dup value-literal
- over value-recursion
- rot f 2array prefix infer-quot
+ [ value-literal ]
+ [ [ value-recursion ] keep f 2array prefix ]
+ bi infer-quot
] [
drop bad-call
] if
dup ensure-values
#>r
over 0 pick node-inputs
- over [ drop pop-d ] map reverse [ push-r ] each
+ over [ pop-d ] replicate reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
dup check-r>
#r>
0 pick pick node-inputs
- over [ drop pop-r ] map reverse [ push-d ] each
+ over [ pop-r ] replicate reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;
meta-d get push-all ;
: if-inline ( word true false -- )
- >r >r dup inline? r> r> if ; inline
+ [ dup inline? ] 2dip if ; inline
: consume/produce ( effect node -- )
- over effect-in over consume-values
- over effect-out over produce-values
- node,
- effect-terminated? [ terminate ] when ;
+ [ [ in>> ] dip consume-values ]
+ [ [ out>> ] dip produce-values ]
+ [ node, terminated?>> [ terminate ] when ]
+ 2tri ;
GENERIC: constructor ( value -- word/f )
GENERIC: infer-uncurry ( value -- )
M: curried infer-uncurry
- drop pop-d dup curried-obj push-d curried-quot push-d ;
+ drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
M: curried constructor
drop \ curry ;
M: composed infer-uncurry
- drop pop-d dup composed-quot1 push-d composed-quot2 push-d ;
+ drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
M: composed constructor
drop \ compose ;
DEFER: unify-values
: unify-curries ( seq -- value )
- dup [ curried-obj ] map unify-values
- swap [ curried-quot ] map unify-values
+ [ [ obj>> ] map unify-values ]
+ [ [ quot>> ] map unify-values ] bi
<curried> ;
: unify-composed ( seq -- value )
- dup [ composed-quot1 ] map unify-values
- swap [ composed-quot2 ] map unify-values
+ [ [ quot1>> ] map unify-values ]
+ [ [ quot2>> ] map unify-values ] bi
<composed> ;
TUPLE: cannot-unify-specials ;
: unify-inputs ( max-d-in d-in meta-d -- meta-d )
dup [
- [ >r - r> length + ] keep add-inputs nip
+ [ [ - ] dip length + ] keep add-inputs nip
] [
2nip
] if ;
[ swap at ] curry map ;
: datastack-effect ( seq -- )
- dup quotation branch-variable
- over d-in branch-variable
- rot meta-d active-variable
- unify-effect meta-d set d-in set ;
+ [ quotation branch-variable ]
+ [ d-in branch-variable ]
+ [ meta-d active-variable ] tri
+ unify-effect
+ [ d-in set ] [ meta-d set ] bi* ;
: retainstack-effect ( seq -- )
- dup quotation branch-variable
- over length 0 <repetition>
- rot meta-r active-variable
- unify-effect meta-r set drop ;
+ [ quotation branch-variable ]
+ [ length 0 <repetition> ]
+ [ meta-r active-variable ] tri
+ unify-effect
+ [ drop ] [ meta-r set ] bi* ;
: unify-effects ( seq -- )
- dup datastack-effect
- dup retainstack-effect
- [ terminated? swap at ] all? terminated? set ;
+ [ datastack-effect ]
+ [ retainstack-effect ]
+ [ [ terminated? swap at ] all? terminated? set ]
+ tri ;
: unify-dataflow ( effects -- nodes )
dataflow-graph branch-variable ;
: infer-branch ( last value -- namespace )
[
copy-inference
- dup value-literal quotation set
- infer-quot-value
+
+ [ value-literal quotation set ]
+ [ infer-quot-value ]
+ bi
+
terminated? get [ drop ] [ call node, ] if
] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list )
[ infer-branch ] with map
- dup unify-effects unify-dataflow ; inline
+ [ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- )
#! last is a quotation which provides a #return or a #values
#call consume/produce
] if ;
-TUPLE: no-effect word ;
+TUPLE: cannot-infer-effect word ;
-: no-effect ( word -- * ) \ no-effect inference-warning ;
+: cannot-infer-effect ( word -- * )
+ \ cannot-infer-effect inference-warning ;
-TUPLE: effect-error word effect ;
+TUPLE: effect-error word inferred declared ;
-: effect-error ( word effect -- * )
+: effect-error ( word inferred declared -- * )
\ effect-error inference-error ;
+TUPLE: missing-effect word ;
+
+: effect-required? ( word -- ? )
+ {
+ { [ dup inline? ] [ drop f ] }
+ { [ dup deferred? ] [ drop f ] }
+ { [ dup crossref? not ] [ drop f ] }
+ [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ } cond ;
+
+: ?missing-effect ( word -- )
+ dup effect-required?
+ [ missing-effect inference-error ] [ drop ] if ;
+
: check-effect ( word effect -- )
- dup pick stack-effect effect<=
- [ 2drop ] [ effect-error ] if ;
+ over stack-effect {
+ { [ dup not ] [ 2drop ?missing-effect ] }
+ { [ 2dup effect<= ] [ 3drop ] }
+ [ effect-error ]
+ } cond ;
: finish-word ( word -- )
current-effect
- 2dup check-effect
- over recorded get push
- "inferred-effect" set-word-prop ;
+ [ check-effect ]
+ [ drop recorded get push ]
+ [ "inferred-effect" set-word-prop ]
+ 2tri ;
+
+: maybe-cannot-infer ( word quot -- )
+ [ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
: infer-word ( word -- effect )
[
finish-word
current-effect
] with-scope
- ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
+ ] maybe-cannot-infer ;
: custom-infer ( word -- )
#! Customized inference behavior
- dup +inlined+ depends-on
- "infer" word-prop call ;
+ [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
: cached-infer ( word -- )
dup "inferred-effect" word-prop make-call-node ;
: apply-word ( word -- )
{
{ [ dup "infer" word-prop ] [ custom-infer ] }
- { [ dup "no-effect" word-prop ] [ no-effect ] }
+ { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
[ dup infer-word make-call-node ]
} cond ;
-TUPLE: recursive-declare-error word ;
-
-: declared-infer ( word -- )
+: declared-infer ( word -- )
dup stack-effect [
make-call-node
] [
- \ recursive-declare-error inference-error
+ \ missing-effect inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
-: inlined-block? "inlined-block" word-prop ;
+: inlined-block? ( word -- ? )
+ "inlined-block" word-prop ;
-: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
+: <inlined-block> ( -- word )
+ gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- #label data )
[
copy-inference nest-node
- dup word-def swap <inlined-block>
+ [ word-def ] [ <inlined-block> ] bi
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
] H{ } make-assoc ;
: join-values ( #label -- )
- calls>> [ node-in-d ] map meta-d get suffix
+ calls>> [ in-d>> ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
: splice-node ( node -- )
- dup node-successor [
- dup node, penultimate-node f over set-node-successor
- dup current-node set
- ] when drop ;
-
-: apply-infer ( hash -- )
- { meta-d meta-r d-in terminated? }
- [ swap [ at ] curry map ] keep
- [ set ] 2each ;
+ dup successor>> [
+ [ node, ] [ penultimate-node ] bi
+ f >>successor
+ current-node set
+ ] [ drop ] if ;
+
+: apply-infer ( data -- )
+ { meta-d meta-r d-in terminated? } swap extract-keys
+ namespace swap update ;
+
+: current-stack-height ( -- n )
+ d-in get meta-d get length - ;
+
+: word-stack-height ( word -- n )
+ stack-effect effect-height ;
+
+: bad-recursive-declaration ( word inferred -- )
+ dup 0 < [ 0 swap ] [ 0 ] if <effect>
+ over stack-effect
+ effect-error ;
+
+: check-stack-height ( word height -- )
+ over word-stack-height over =
+ [ 2drop ] [ bad-recursive-declaration ] if ;
+
+: inline-recursive-word ( word #label -- )
+ current-stack-height [
+ flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
+ [ node, ]
+ [ calls>> [ [ flatten-curries ] modify-values ] each ]
+ [ word>> ]
+ tri
+ ] dip
+ current-stack-height -
+ check-stack-height ;
: inline-word ( word -- )
- dup inline-block over recursive-label? [
- flatten-meta-d >r
- drop join-values inline-block apply-infer
- r> over set-node-in-d
- dup node,
- calls>> [
- [ flatten-curries ] modify-values
- ] each
- ] [
- apply-infer node-child node-successor splice-node drop
- ] if ;
+ dup inline-block over recursive-label?
+ [ drop inline-recursive-word ]
+ [ apply-infer node-child successor>> splice-node drop ] if ;
M: word apply-object
[
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
! We don't want to use = to compare literals
-: foo reverse ;
+: foo ( seq -- seq' ) reverse ;
\ foo [
[
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
-: `input node get in-d>> nth ;
-: `output node get out-d>> nth ;
-: class, <class-constraint> , ;
-: literal, <literal-constraint> , ;
-: interval, <interval-constraint> , ;
+: `input ( n -- value ) node get in-d>> nth ;
+: `output ( n -- value ) node get out-d>> nth ;
+: class, ( class value -- ) <class-constraint> , ;
+: literal, ( literal value -- ) <literal-constraint> , ;
+: interval, ( interval value -- ) <interval-constraint> , ;
M: f apply-constraint drop ;
IN: inference.dataflow
! Computed value
-: <computed> \ <computed> counter ;
+: <computed> ( -- value ) \ <computed> counter ;
! Literal value
TUPLE: value < identity-tuple literal uid recursion ;
: r-tail ( n -- seq )
dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
-: node-child node-children first ;
+: node-child ( node -- child ) node-children first ;
TUPLE: #label < node word loop? returns calls ;
SYMBOL: node-stack
-: >node node-stack get push ;
-: node> node-stack get pop ;
-: node@ node-stack get peek ;
+: >node ( node -- ) node-stack get push ;
+: node> ( -- node ) node-stack get pop ;
+: node@ ( -- node ) node-stack get peek ;
: iterate-next ( -- node ) node@ successor>> ;
sequences prettyprint io words arrays inspector effects debugger
assocs accessors ;
+M: inference-error error-help error>> error-help ;
+
M: inference-error error.
dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
swap error>> error. "Nesting: " write . ;
-M: inference-error error-help drop f ;
-
M: unbalanced-branches-error error.
"Unbalanced branches:" print
- dup unbalanced-branches-error-quots
- over unbalanced-branches-error-in
- rot unbalanced-branches-error-out [ length ] map
- 3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
+ [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
+ [ [ bl ] [ pprint ] interleave nl ] each ;
M: literal-expected summary
drop "Literal value expected" ;
drop
"Quotation pops retain stack elements which it did not push" ;
-M: no-effect error.
- "Unable to infer stack effect of " write no-effect-word . ;
+M: cannot-infer-effect error.
+ "Unable to infer stack effect of " write word>> . ;
-M: recursive-declare-error error.
- "The recursive word " write
- recursive-declare-error-word pprint
+M: missing-effect error.
+ "The word " write
+ word>> pprint
" must declare a stack effect" print ;
M: effect-error error.
"Stack effects of the word " write
- dup effect-error-word pprint
- " do not match." print
- "Declared: " write
- dup effect-error-word stack-effect effect>string .
- "Inferred: " write effect-error-effect effect>string . ;
+ [ word>> pprint " do not match." print ]
+ [ "Inferred: " write inferred>> effect>string . ]
+ [ "Declared: " write declared>> effect>string . ] tri ;
M: recursive-quotation-error error.
"The quotation " write
- recursive-quotation-error-quot pprint
+ quot>> pprint
" calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
"Main wrapper for all inference errors:"
{ $subsection inference-error }
"Specific inference errors:"
-{ $subsection no-effect }
+{ $subsection cannot-infer-effect }
{ $subsection literal-expected }
{ $subsection too-many->r }
{ $subsection too-many-r> }
{ $subsection unbalanced-branches-error }
{ $subsection effect-error }
-{ $subsection recursive-declare-error } ;
+{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
-"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
+"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
{ $subsection infer. }
{ $subsection "inference-limitations" }
{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
-{ $subsection "compiler-transforms" } ;
+{ $subsection "compiler-transforms" }
+{ $see-also "effects" } ;
ABOUT: "inference"
] must-fail
! Test inference of termination of control flow
-: termination-test-1
- "foo" throw ;
+: termination-test-1 ( -- * ) "foo" throw ;
-: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
+: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
{ 1 1 } [ termination-test-2 ] must-infer-as
-: infinite-loop infinite-loop ;
-
-[ [ infinite-loop ] infer ] must-fail
-
-: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer ] must-fail
-
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
{ 0 1 } [ sym-test ] must-infer-as
-: terminator-branch
+: terminator-branch ( a -- b )
dup [
length
] [
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
-: bad-input#
+{ 2 2 } [
dup string? [ 2array throw ] unless
- over string? [ 2array throw ] unless ;
-
-{ 2 2 } [ bad-input# ] must-infer-as
+ over string? [ 2array throw ] unless
+] must-infer-as
! Regression
{ 2 1 } [ too-deep ] must-infer-as
! Error reporting is wrong
-MATH: xyz
+MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
! Incorrect stack declarations on inline recursive words should
! be caught
: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx fooxxx ;
+: barxxx ( a b -- c ) fooxxx ;
[ [ barxxx ] infer ] must-fail
DEFER: deferred-word
-: calls-deferred-word [ deferred-word ] [ 3 ] if ;
-
-{ 1 1 } [ calls-deferred-word ] must-infer-as
+{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
USE: inference.dataflow
{ 1 0 } [ [ ] map-children ] must-infer-as
! Corner case
-! [ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+
+[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+
+: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+
+[ [ erg's-inference-bug ] infer ] must-fail
+
+: inference-invalidation-a ( -- ) ;
+: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
+: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
+
+[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+
+{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+
+[ ] [ "IN: inference.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
+
+[ 3 ] [ inference-invalidation-c ] unit-test
+
+{ 0 1 } [ inference-invalidation-c ] must-infer-as
+
+GENERIC: inference-invalidation-d ( obj -- )
+
+M: object inference-invalidation-d inference-invalidation-c 2drop ;
-! [ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+\ inference-invalidation-d must-infer
-! : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+[ ] [ "IN: inference.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
-! [ [ erg's-inference-bug ] infer ] must-fail
+[ [ inference-invalidation-d ] infer ] must-fail
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
- [ f infer-quot ] with-infer drop ;
+ [ recursive-state get infer-quot ] with-infer drop ;
: infer. ( quot -- )
+ #! Safe to call from inference transforms.
infer effect>string print ;
GENERIC: dataflow ( quot -- dataflow )
M: callable dataflow
+ #! Not safe to call from inference transforms.
[ f infer-quot ] with-infer nip ;
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
M: callable dataflow-with
+ #! Not safe to call from inference transforms.
[
V{ } like meta-d set
f infer-quot
: forget-errors ( -- )
all-words [
- dup subwords [ f "no-effect" set-word-prop ] each
- f "no-effect" set-word-prop
+ dup subwords [ f "cannot-infer" set-word-prop ] each
+ f "cannot-infer" set-word-prop
] each ;
\ (set-os-envs) { array } { } <effect> set-primitive-effect
-\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
+\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
IN: inference.state.tests
-USING: tools.test inference.state words kernel namespaces ;
+USING: tools.test inference.state words kernel namespaces
+definitions ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel words ;
+USING: assocs namespaces sequences kernel definitions ;
IN: inference.state
! Nesting state to solve recursion
! Compile-time data stack
SYMBOL: meta-d
-: push-d meta-d get push ;
-: pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
+: push-d ( obj -- ) meta-d get push ;
+: pop-d ( -- obj ) meta-d get pop ;
+: peek-d ( -- obj ) meta-d get peek ;
! Compile-time retain stack
SYMBOL: meta-r
-: push-r meta-r get push ;
-: pop-r meta-r get pop ;
-: peek-r meta-r get peek ;
+: push-r ( obj -- ) meta-r get push ;
+: pop-r ( -- obj ) meta-r get pop ;
+: peek-r ( -- obj ) meta-r get peek ;
! Head of dataflow IR
SYMBOL: dataflow-graph
quotations inference accessors combinators words arrays
classes ;
-: compose-n-quot <repetition> >quotation ;
-: compose-n compose-n-quot call ;
+: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
+: compose-n ( quot -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
-: compose-n-test 2 \ + compose-n ;
+: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ new must-infer
-
-TUPLE: a-tuple x y z ;
-
-: set-slots-test ( x y z -- )
- { set-a-tuple-x set-a-tuple-y } set-slots ;
-
-\ set-slots-test must-infer
-
-: set-slots-test-2
- { set-a-tuple-x set-a-tuple-x } set-slots ;
-
-[ [ set-slots-test-2 ] infer ] must-fail
-
TUPLE: color r g b ;
C: <color> color
-: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+: cleave-test ( color -- r g b )
+ { [ r>> ] [ g>> ] [ b>> ] } cleave ;
{ 1 3 } [ cleave-test ] must-infer-as
[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
-: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
+: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
-: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
+: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic sets ;
+inspector hashtables classes generic sets definitions ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
: 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. ;
GENERIC: <decoder> ( stream encoding -- newstream )
-: replacement-char HEX: fffd ;
+: replacement-char HEX: fffd ; inline
TUPLE: decoder stream code cr ;
! Decoding
-<PRIVATE
-
M: object <decoder> f decoder boa ;
-: >decoder< ( decoder -- stream encoding )
- [ stream>> ] [ code>> ] bi ;
-
-: cr+ t swap set-decoder-cr ; inline
+<PRIVATE
-: cr- f swap set-decoder-cr ; inline
+: cr+ t >>cr drop ; inline
-: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
+: cr- f >>cr drop ; inline
-: line-ends\r ( stream str -- str ) swap cr+ ; inline
+: >decoder< ( decoder -- stream encoding )
+ [ stream>> ] [ code>> ] bi ; inline
-: line-ends\n ( stream str -- str )
- over decoder-cr over empty? and
- [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
+: fix-read1 ( stream char -- char )
+ over cr>> [
+ over cr-
+ dup CHAR: \n = [
+ drop dup stream-read1
+ ] when
+ ] when nip ; inline
-: handle-readln ( stream str ch -- str )
- {
- { f [ line-ends/eof ] }
- { CHAR: \r [ line-ends\r ] }
- { CHAR: \n [ line-ends\n ] }
- } case ;
+M: decoder stream-read1
+ dup >decoder< decode-char fix-read1 ;
: fix-read ( stream string -- string )
- over decoder-cr [
+ over cr>> [
over cr-
"\n" ?head [
over stream-read1 [ suffix ] when*
] when
- ] when nip ;
+ ] when nip ; inline
-: read-loop ( n stream -- string )
- SBUF" " clone [
+: (read) ( n quot -- n string )
+ over 0 <string> [
[
- >r nip stream-read1 dup
- [ r> push f ] [ r> 2drop t ] if
- ] 2curry find-integer drop
- ] keep "" like f like ;
+ >r call dup
+ [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
+ ] 2curry find-integer
+ ] keep ; inline
+
+: finish-read ( n string -- string/f )
+ {
+ { [ over 0 = ] [ 2drop f ] }
+ { [ over not ] [ nip ] }
+ [ swap head ]
+ } cond ; inline
M: decoder stream-read
- tuck read-loop fix-read ;
+ tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
M: decoder stream-read-partial stream-read ;
-: (read-until) ( buf quot -- string/f sep/f )
+: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
+
+: line-ends\r ( stream str -- str ) swap cr+ ; inline
+
+: line-ends\n ( stream str -- str )
+ over cr>> over empty? and
+ [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
+
+: handle-readln ( stream str ch -- str )
+ {
+ { f [ line-ends/eof ] }
+ { CHAR: \r [ line-ends\r ] }
+ { CHAR: \n [ line-ends\n ] }
+ } case ; inline
+
+: ((read-until)) ( buf quot -- string/f sep/f )
! quot: -- char stop?
dup call
[ >r drop "" like r> ]
- [ pick push (read-until) ] if ; inline
+ [ pick push ((read-until)) ] if ; inline
-M: decoder stream-read-until
+: (read-until) ( seps stream -- string/f sep/f )
SBUF" " clone -rot >decoder<
- [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
- (read-until) ;
+ [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
+ ((read-until)) ; inline
-: fix-read1 ( stream char -- char )
- over decoder-cr [
- over cr-
- dup CHAR: \n = [
- drop dup stream-read1
- ] when
- ] when nip ;
-
-M: decoder stream-read1
- dup >decoder< decode-char fix-read1 ;
+M: decoder stream-read-until (read-until) ;
-M: decoder stream-readln ( stream -- str )
- "\r\n" over stream-read-until handle-readln ;
+M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
-M: decoder dispose decoder-stream dispose ;
+M: decoder dispose stream>> dispose ;
! Encoding
M: object <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
- [ stream>> ] [ code>> ] bi ;
+ [ stream>> ] [ code>> ] bi ; inline
M: encoder stream-write1
>encoder< encode-char ;
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
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
-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 )
\ exists? must-infer
\ (exists?) must-infer
+\ file-info must-infer
+\ link-info must-infer
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
delete-file
] if ;
-: to-directory over file-name append-path ;
+: to-directory ( from to -- from to' )
+ over file-name append-path ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
: growable-read-until ( growable n -- str )
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
-: find-last-sep swap [ memq? ] curry find-last drop ;
+: find-last-sep ( seq seps -- n )
+ swap [ memq? ] curry find-last drop ;
M: growable stream-read-until
[ find-last-sep ] keep over [
{ $example "t \\ t eq? ." "t" }
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
+ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
+"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
+$nl
+"The following two lines are equivalent:"
+{ $code "[ drop f ] unless" "swap and" }
+"The following two lines are equivalent:"
+{ $code "[ ] [ ] ?if" "swap or" }
+"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
+{ $code "[ L ] unless*" "L or" } ;
+
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection if }
{ $subsection and }
{ $subsection or }
{ $subsection xor }
+{ $subsection "conditionals-boolean-equivalence" }
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
{ $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" } "." } ;
{ $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." } ;
}
} ;
-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."
{ $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:"
-{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
-"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
-{ $code "[ L ] unless*" "L or" } } ;
+{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
{ $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." }
{ $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
: 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
>r keep r> call ; inline
: tri ( x p q r -- )
- >r pick >r bi r> r> call ; inline
+ >r >r keep r> keep r> call ; inline
! Double cleavers
: 2bi ( x y p q -- )
>r dip r> call ; inline
: tri* ( x y z p q r -- )
- >r rot >r bi* r> r> call ; inline
+ >r >r 2dip r> dip r> call ; inline
! Double spreaders
: 2bi* ( w x y z p q -- )
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations destructors init kernel
-namespaces accessors ;
+namespaces accessors sets ;
IN: libc
<PRIVATE
[ H{ } clone mallocs set-global ] "libc" add-init-hook
: add-malloc ( alien -- )
- dup mallocs get-global set-at ;
+ mallocs get-global conjoin ;
: delete-malloc ( alien -- )
[
: a 1 ; inline
: b 2 ; inline
-: foo { a b } flags ;
+: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
USING: arrays kernel math sequences words ;
IN: math.bitfields
-GENERIC: (bitfield) inline
+GENERIC: (bitfield) ( value accum shift -- newaccum )
M: integer (bitfield) ( value accum shift -- newaccum )
swapd shift bitor ;
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." } ;
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." } ;
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
-: ratio>float [ >bignum ] bi@ /f ;
+: ratio>float ( a b -- f ) [ >bignum ] bi@ /f ;
[ 5. ] [ 5 1 ratio>float ] unit-test
[ 4. ] [ 4 1 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
-: random-integer
+: random-integer ( -- n )
32 random-bits
1 random zero? [ neg ] when
1 random zero? [ >bignum ] when ;
{ 3 [ (a,b] ] }
} case ;
-: random-op
+: random-op ( -- pair )
{
{ + interval+ }
{ - interval- }
] when
random ;
-: interval-test
+: interval-test ( -- ? )
random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
-: random-comparison
+: random-comparison ( -- pair )
{
{ < interval< }
{ <= interval<= }
{ >= interval>= }
} random ;
-: comparison-test
+: comparison-test ( -- ? )
random-interval random-interval random-comparison
[ >r [ random-element ] bi@ r> first execute ] 3keep
second execute dup incomparable eq? [
C: <interval> interval
-: open-point f 2array ;
+: open-point ( n -- endpoint ) f 2array ;
-: closed-point t 2array ;
+: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ;
[ interval-to ] bi@ =
and and ;
-: (interval<) over interval-from over interval-from endpoint< ;
+: (interval<) ( i1 i2 -- i1 i2 ? )
+ over interval-from over interval-from endpoint< ;
: interval< ( i1 i2 -- ? )
{
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
IN: math.order
HELP: <=>
-{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
+{ $values { "obj1" object } { "obj2" object } { "<=>" "an ordering specifier" } }
{ $contract
- "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
+ "Compares two objects using an intrinsic linear order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
} ;
HELP: +lt+
-{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ;
+{ $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
HELP: +eq+
-{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ;
+{ $description "Output by " { $link <=> } " when the first object is equal to the second object." } ;
HELP: +gt+
-{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
+{ $description "Output by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: invert-comparison
-{ $values { "symbol" symbol }
- { "new-symbol" symbol } }
-{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
+{ $values { "<=>" symbol }
+ { "<=>'" symbol } }
+{ $description "Invert the comparison symbol returned by " { $link <=> } "." }
{ $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
HELP: compare
-{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "<=>" "an ordering specifier" } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
} ;
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
-ARTICLE: "math.order" "Ordered objects"
+ARTICLE: "order-specifiers" "Ordering specifiers"
+"Ordering words such as " { $link <=> } " output one of the following values, indicating that of two objects being compared, the first is less than the second, the two are equal, or that the first is greater than the second:"
+{ $subsection +lt+ }
+{ $subsection +eq+ }
+{ $subsection +gt+ } ;
+
+ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:"
{ $subsection <=> }
{ $subsection compare }
{ $subsection invert-comparison }
-"The above words return one of the following symbols:"
-{ $subsection +lt+ }
-{ $subsection +eq+ }
-{ $subsection +gt+ }
+"The above words output order specifiers."
+{ $subsection "order-specifiers" }
"Utilities for comparing objects:"
{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
-{ $subsection before=? } ;
+{ $subsection before=? }
+{ $see-also "sequences-sorting" } ;
ABOUT: "math.order"
SYMBOL: +eq+
SYMBOL: +gt+
-: invert-comparison ( symbol -- new-symbol )
+: invert-comparison ( <=> -- <=>' )
#! Can't use case, index or nth here
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
-GENERIC: <=> ( obj1 obj2 -- symbol )
+GENERIC: <=> ( obj1 obj2 -- <=> )
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
: [-] ( x y -- z ) - 0 max ; inline
-: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline
+: compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline
SYMBOL: radix
SYMBOL: negative?
-: sign negative? get "-" "+" ? ;
+: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
} cond
] if ;
-: fold-if-branch? dup node-in-d first known-boolean-value? ;
+: fold-if-branch? ( node -- value ? )
+ dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
-: lift-branch
+: lift-branch ( node tail -- )
over
last-node clone-node
dup node-in-d \ #merge out-node
used-by empty? ;
: uses-values ( node seq -- )
- [ def-use get [ ?push ] change-at ] with each ;
+ [ def-use get push-at ] with each ;
: defs-values ( seq -- )
#! If there is no value, set it to a new empty vector,
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
- nest-def-use keys
- def-use get [ [ t swap ?push ] change-at ] curry each ;
+ nest-def-use keys def-use get [ t -rot push-at ] curry each ;
optimizer.math.partial continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control kernel.private ;
+optimizer.control kernel.private definitions ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
[ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node )
- 2dup dispatching-class dup [
- over +inlined+ depends-on
- swap method 1quotation f splice-quot
- ] [
- 3drop t
- ] if ;
+ 2dup dispatching-class dup
+ [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
-inference.class kernel assocs math math.private kernel.private
-sequences words parser vectors strings sbufs io namespaces
-assocs quotations sequences.private io.binary
+inference.class kernel assocs math math.order math.private
+kernel.private sequences words parser vectors strings sbufs io
+namespaces assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
-sequences.private combinators ;
+sequences.private combinators byte-arrays byte-vectors ;
{ <tuple> <tuple-boa> } [
[
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
-: member-quot ( seq -- newquot )
- [ literalize [ t ] ] { } map>assoc
- [ drop f ] suffix [ nip case ] curry ;
+: expand-member ( #call quot -- )
+ >r dup node-in-d peek value-literal r> call f splice-quot ;
+
+: bit-member-n 256 ; inline
+
+: bit-member? ( seq -- ? )
+ #! Can we use a fast byte array test here?
+ {
+ { [ dup length 8 < ] [ f ] }
+ { [ dup [ integer? not ] contains? ] [ f ] }
+ { [ dup [ 0 < ] contains? ] [ f ] }
+ { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+ bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+ dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+ [
+ [ drop ] % ! drop the sequence itself; we don't use it at run time
+ bit-member-seq ,
+ [
+ {
+ { [ over fixnum? ] [ ?nth 1 eq? ] }
+ { [ over bignum? ] [ ?nth 1 eq? ] }
+ { [ over exact-float? ] [ ?nth 1 eq? ] }
+ [ 2drop f ]
+ } cond
+ ] %
+ ] [ ] make ;
-: expand-member ( #call -- )
- dup node-in-d peek value-literal member-quot f splice-quot ;
+: member-quot ( seq -- newquot )
+ dup bit-member? [
+ bit-member-quot
+ ] [
+ [ literalize [ t ] ] { } map>assoc
+ [ drop f ] suffix [ nip case ] curry
+ ] if ;
\ member? {
- { [ dup literal-member? ] [ expand-member ] }
+ { [ dup literal-member? ] [ [ member-quot ] expand-member ] }
+} define-optimizers
+
+: memq-quot ( seq -- newquot )
+ [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+ [ drop f ] suffix [ nip cond ] curry ;
+
+\ memq? {
+ { [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal,
] each
\ push-all
-{ { string sbuf } { array vector } }
+{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
\ append
! regression
GENERIC: void-generic ( obj -- * )
-: breakage "hi" void-generic ;
+: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail
! another regression
: constant-branch-fold-0 "hey" ; foldable
-: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
+: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
-: bar foo 4 4 = and ;
+: bar ( -- ? ) foo 4 4 = and ;
[ f ] [ bar ] unit-test
! ensure identities are working in some form
] unit-test
! compiling <tuple> with a non-literal class failed
-: <tuple>-regression <tuple> ;
+: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
-: should-inline? method flat-length 10 <= ;
+: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression
-: lift-throw-tail-regression
+: lift-throw-tail-regression ( obj -- obj str )
dup integer? [ "an integer" ] [
dup string? [ "a string" ] [
"error" throw
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
-: generic-inline-test-1
+: generic-inline-test-1 ( -- x )
1
generic-inline-test
generic-inline-test
HINTS: recursive-inline-hang array ;
-: recursive-inline-hang-1
+: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
-: member-test { + - * / /i } member? ;
+: member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
{ $subsection parse-tokens } ;
ARTICLE: "parsing-words" "Parsing words"
-"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
+"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
$nl
"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
{ $code ": hello \"Hello world\" print ; parsing" }
-"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
+"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser."
+$nl
+"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
+$nl
+"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
$nl
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
-{ $link staging-violation }
+{ $subsection staging-violation }
"Tools for implementing parsing words:"
{ $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" }
ABOUT: "parser"
-: $parsing-note
+: $parsing-note ( children -- )
drop
"This word should only be called from parsing words."
$notes ;
{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ;
HELP: parse-effect
-{ $values { "effect" "an instance of " { $link effect } } }
+{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
{ $description "Parses a stack effect from the current input line." }
-{ $examples "This word is used by " { $link POSTPONE: ( } " to parse stack effect declarations." }
+{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
$parsing-note ;
HELP: parse-base
] unit-test
] times
-[ ] [ "parser" reload ] unit-test
-
[ ] [
[ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test
PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
+M: parsing-word stack-effect drop (( parsed -- parsed )) ;
+
: unexpected-eof ( word -- * ) f unexpected ;
: (parse-tokens) ( accum end -- accum )
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
- [ changed-definitions get key? [ staging-violation ] when ]
- [ execute ]
- bi ;
+ dup changed-definitions get key? [ staging-violation ] when
+ execute ;
: parse-step ( accum end -- accum ? )
scan-word {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
- { [ dup parsing? ] [ nip execute-parsing t ] }
+ { [ dup parsing-word? ] [ nip execute-parsing t ] }
[ pick push drop t ]
} cond ;
lexer-factory get call (parse-lines) ;
! Parsing word utilities
-: parse-effect ( -- effect )
- ")" parse-tokens "(" over member? [
- "Stack effect declaration must not contain (" throw
- ] [
+: parse-effect ( end -- effect )
+ parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
] if
+ ] [
+ "Stack effect declaration must not contain ( or ((" throw
] if ;
ERROR: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) CREATE-WORD parse-definition ;
+: (:) ( -- word def ) CREATE-WORD parse-definition ;
SYMBOL: current-class
SYMBOL: current-generic
r> call
] with-scope ; inline
-: (M:)
+: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
- scan-word dup parsing?
+ scan-word dup parsing-word?
[ V{ } clone swap execute first ] when ;
GENERIC: expected>string ( obj -- str )
: reset-removed-classes ( -- )
removed-classes
- filter-moved [ class? ] filter [ reset-class ] each ;
+ filter-moved [ class? ] filter [ forget-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
-float-arrays ;
+float-arrays combinators ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
+M: effect pprint* effect>string "(" swap ")" 3append text ;
+
: ?effect-height ( word -- n )
stack-effect [ effect-height ] [ 0 ] if* ;
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
[
- dup presented set
- dup parsing? over delimiter? rot t eq? or or
- [ bold font-style set ] when
+ [ presented set ]
+ [
+ [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
+ [ bold font-style set ] when
+ ] bi
] bind
] keep ;
<block swap pprint-word call block> ; inline
M: word pprint*
- dup parsing? [
+ dup parsing-word? [
\ POSTPONE: [ pprint-word ] pprint-prefix
] [
- dup "break-before" word-prop line-break
- dup pprint-word
- dup ?start-group dup ?end-group
- "break-after" word-prop line-break
+ {
+ [ "break-before" word-prop line-break ]
+ [ pprint-word ]
+ [ ?start-group ]
+ [ ?end-group ]
+ [ "break-after" word-prop line-break ]
+ } cleave
] if ;
M: real pprint* number>string text ;
[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
-
-[ "( a b -- c d )" ] [
- { "a" "b" } { "c" "d" } <effect> effect>string
-] unit-test
-
-[ "( -- c d )" ] [
- { } { "c" "d" } <effect> effect>string
-] unit-test
-
-[ "( a b -- )" ] [
- { "a" "b" } { } <effect> effect>string
-] unit-test
-
-[ "( -- )" ] [
- { } { } <effect> effect>string
-] unit-test
-
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
[ ] [ \ fixnum see ] unit-test
USING: arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
-prettyprint.config sorting splitting math.parser vocabs
+prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
-combinators quotations sets ;
+combinators quotations sets accessors ;
: make-pprint ( obj quot -- block in use )
[
definer drop pprint-word ;
: stack-effect. ( word -- )
- dup parsing? over symbol? or not swap stack-effect and
+ [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
: word-synopsis ( word -- )
- dup seeing-word
- dup definer.
- dup pprint-word
- stack-effect. ;
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ pprint-word ]
+ [ stack-effect. ]
+ } cleave ;
M: word synopsis* word-synopsis ;
M: simple-generic synopsis* word-synopsis ;
M: standard-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup dispatch# pprint*
- stack-effect. ;
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ dispatch# pprint* ]
+ [ stack-effect. ]
+ } cleave ;
M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "combination" word-prop hook-combination-var pprint*
- stack-effect. ;
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ "combination" word-prop hook-combination-var pprint* ]
+ [ stack-effect. ]
+ } cleave ;
M: method-spec synopsis*
first2 method synopsis* ;
M: method-body synopsis*
- dup dup
- definer.
- "method-class" word-prop pprint-word
- "method-generic" word-prop pprint-word ;
+ [ definer. ]
+ [ "method-class" word-prop pprint-word ]
+ [ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
- dup definer.
- dup mixin-instance-class pprint-word
- mixin-instance-mixin pprint-word ;
+ [ definer. ]
+ [ class>> pprint-word ]
+ [ mixin>> pprint-word ] tri ;
M: pathname synopsis* pprint* ;
POSTPONE: flushable
} [ declaration. ] with each ;
-: pprint-; \ ; pprint-word ;
+: pprint-; ( -- ) \ ; pprint-word ;
: (see) ( spec -- )
<colon dup synopsis*
USING: arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested accessors ;
+io.streams.nested accessors sets ;
IN: prettyprint.sections
! State
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
- word-vocabulary [ dup pprinter-use get set-at ] when* ;
+ word-vocabulary [ pprinter-use get conjoin ] when* ;
! Utility words
: line-limit? ( -- ? )
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
-: (<block) pprinter-stack get push ;
+: (<block) ( block -- ) pprinter-stack get push ;
-: <block f <block> (<block) ;
+: <block ( -- ) f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
SYMBOL: prev
SYMBOL: next
-: split-groups [ t , ] when ;
+: split-groups ( ? -- ) [ t , ] when ;
M: f section-start-group? drop t ;
[ compose-first length ]
[ compose-second length ] bi + ;
-M: compose nth
+M: compose virtual-seq compose-first ;
+
+M: compose virtual@
2dup compose-first length < [
compose-first
] [
[ compose-first length - ] [ compose-second ] bi
- ] if nth ;
+ ] if ;
-INSTANCE: compose immutable-sequence
+INSTANCE: compose virtual-sequence
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: search-dequeues
+USING: help.markup help.syntax kernel dlists hashtables
+dequeues assocs ;
+
+ARTICLE: "search-dequeues" "Search dequeues"
+"A search dequeue is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search dequeues implement all dequeue operations in terms of an underlying dequeue, and membership testing with " { $link dequeue-member? } " is implemented with an underlying assoc. Search dequeues are defined in the " { $vocab-link "search-dequeues" } " vocabulary."
+$nl
+"Creating a search dequeue:"
+{ $subsection <search-dequeue> }
+"Default implementation:"
+{ $subsection <hashed-dlist> } ;
+
+ABOUT: "search-dequeues"
+
+HELP: <search-dequeue> ( assoc dequeue -- search-dequeue )
+{ $values { "assoc" assoc } { "dequeue" dequeue } { "search-dequeue" search-dequeue } }
+{ $description "Creates a new " { $link search-dequeue } "." } ;
+
+HELP: <hashed-dlist> ( -- search-dequeue )
+{ $values { "search-dequeue" search-dequeue } }
+{ $description "Creates a new " { $link search-dequeue } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
--- /dev/null
+IN: search-dequeues.tests
+USING: search-dequeues tools.test namespaces
+kernel sequences words dequeues vocabs ;
+
+<hashed-dlist> "h" set
+
+[ t ] [ "h" get dequeue-empty? ] unit-test
+
+[ ] [ 3 "h" get push-front* "1" set ] unit-test
+[ ] [ 1 "h" get push-front ] unit-test
+[ ] [ 3 "h" get push-front* "2" set ] unit-test
+[ ] [ 3 "h" get push-front* "3" set ] unit-test
+[ ] [ 7 "h" get push-front ] unit-test
+
+[ t ] [ "1" get "2" get eq? ] unit-test
+[ t ] [ "2" get "3" get eq? ] unit-test
+
+[ 3 ] [ "h" get dequeue-length ] unit-test
+[ t ] [ 7 "h" get dequeue-member? ] unit-test
+
+[ 3 ] [ "1" get node-value ] unit-test
+[ ] [ "1" get "h" get delete-node ] unit-test
+
+[ 2 ] [ "h" get dequeue-length ] unit-test
+[ 1 ] [ "h" get pop-back ] unit-test
+[ 7 ] [ "h" get pop-back ] unit-test
+
+[ f ] [ 7 "h" get dequeue-member? ] unit-test
+
+[ ] [
+ <hashed-dlist>
+ [ all-words swap [ push-front ] curry each ]
+ [ [ drop ] slurp-dequeue ]
+ bi
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel assocs dequeues dlists hashtables ;
+IN: search-dequeues
+
+TUPLE: search-dequeue assoc dequeue ;
+
+C: <search-dequeue> search-dequeue
+
+: <hashed-dlist> ( -- search-dequeue )
+ 0 <hashtable> <dlist> <search-dequeue> ;
+
+M: search-dequeue dequeue-length dequeue>> dequeue-length ;
+
+M: search-dequeue peek-front dequeue>> peek-front ;
+
+M: search-dequeue peek-back dequeue>> peek-back ;
+
+M: search-dequeue push-front*
+ 2dup assoc>> at* [ 2nip ] [
+ drop
+ [ dequeue>> push-front* ] [ assoc>> ] 2bi
+ [ 2drop ] [ set-at ] 3bi
+ ] if ;
+
+M: search-dequeue push-back*
+ 2dup assoc>> at* [ 2nip ] [
+ drop
+ [ dequeue>> push-back* ] [ assoc>> ] 2bi
+ [ 2drop ] [ set-at ] 3bi
+ ] if ;
+
+M: search-dequeue pop-front*
+ [ [ dequeue>> peek-front ] [ assoc>> ] bi delete-at ]
+ [ dequeue>> pop-front* ]
+ bi ;
+
+M: search-dequeue pop-back*
+ [ [ dequeue>> peek-back ] [ assoc>> ] bi delete-at ]
+ [ dequeue>> pop-back* ]
+ bi ;
+
+M: search-dequeue delete-node
+ [ dequeue>> delete-node ]
+ [ [ node-value ] [ assoc>> ] bi* delete-at ] 2bi ;
+
+M: search-dequeue clear-dequeue
+ [ dequeue>> clear-dequeue ] [ assoc>> clear-assoc ] bi ;
+
+M: search-dequeue dequeue-member?
+ assoc>> key? ;
+
+INSTANCE: search-dequeue dequeue
--- /dev/null
+Double-ended queues with sub-linear membership testing
--- /dev/null
+collections
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
+{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
-
-! Hardcore
-[ ] [ "sequences" reload ] unit-test
: map ( seq quot -- newseq )
over map-as ; inline
+: replicate ( seq quot -- newseq )
+ [ drop ] prepose map ; inline
+
+: replicate-as ( seq quot exemplar -- newseq )
+ >r [ drop ] prepose r> map-as ; inline
+
: change-each ( seq quot -- )
over map-into ; inline
: interleave ( seq between quot -- )
[ (interleave) ] 2curry >r dup length swap r> 2each ; inline
+: accumulator ( quot -- quot' vec )
+ V{ } clone [ [ push ] curry compose ] keep ; inline
+
: unfold ( pred quot tail -- seq )
- V{ } clone [
- swap >r [ push ] curry compose r> while
- ] keep { } like ; inline
+ swap accumulator >r swap while r> { } like ; inline
: follow ( obj quot -- seq )
>r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ;
+: gather ( seq quot -- newseq )
+ map concat prune ; inline
+
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;
{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." }
$low-level-note ;
-HELP: reader-effect
-{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
-
HELP: define-reader
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
-HELP: writer-effect
-{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
-
HELP: define-writer
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
-: reader-effect T{ effect f { "object" } { "value" } } ; inline
-
: reader-word ( name -- word )
- ">>" append reader-effect create-accessor ;
+ ">>" append (( object -- value )) create-accessor ;
: define-reader ( class slot name -- )
reader-word object reader-quot define-slot-word ;
-: writer-effect T{ effect f { "value" "object" } { } } ; inline
-
: writer-word ( name -- word )
- "(>>" swap ")" 3append writer-effect create-accessor ;
+ "(>>" swap ")" 3append (( value object -- )) create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
-: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
-
: setter-word ( name -- word )
- ">>" prepend setter-effect create-accessor ;
+ ">>" prepend (( object value -- object )) create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
-: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
-
: changer-word ( name -- word )
- "change-" prepend changer-effect create-accessor ;
+ "change-" prepend (( object quot -- object )) create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
IN: sorting
ARTICLE: "sequences-sorting" "Sorting and binary search"
-"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- n )" } " that order the two given elements and output a value whose sign denotes the result:"
-{ $list
- { "positive - indicates that " { $snippet "elt1" } " follows " { $snippet "elt2" } }
- { "zero - indicates that " { $snippet "elt1" } " is ordered equivalently to " { $snippet "elt2" } }
- { "negative - indicates that " { $snippet "elt1" } " precedes " { $snippet "elt2" } }
-}
+"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
+$nl
"Sorting a sequence with a custom comparator:"
{ $subsection sort }
"Sorting a sequence with common comparators:"
{ $subsection binsearch }
{ $subsection binsearch* } ;
+ABOUT: "sequences-sorting"
+
HELP: sort
-{ $values { "seq" "a sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } }
+{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ;
HELP: sort-keys
{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ;
HELP: binsearch
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "i" "the index of the search result" } }
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } }
{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
$nl
"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
HELP: binsearch*
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "result" "the search result" } }
+{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } }
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
$nl
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
[ t ] [
100 [
drop
- 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
+ 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
] all?
] unit-test
--- /dev/null
+IN: source-files.tests
+USING: source-files tools.test assocs sequences strings
+namespaces kernel ;
+
+[ { } ] [ source-files get keys [ string? not ] filter ] unit-test
\ source-file construct ;
: source-file ( path -- source-file )
+ dup string? [ "Invalid source file path" throw ] unless
source-files get [ <source-file> ] cache ;
: reset-checksums ( -- )
USING: help.markup help.syntax sequences strings ;
IN: splitting
-ARTICLE: "groups-clumps" "Groups and clumps"
-"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
-"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
-{ $subsection clumps }
-{ $subsection <clumps> }
-{ $subsection <sliced-clumps> }
-"The difference can be summarized as the following:"
-{ $list
- { "With groups, the subsequences form the original sequence when concatenated:"
- { $unchecked-example "dup n groups concat sequence= ." "t" }
- }
- { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
- { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
- }
-} ;
-
ARTICLE: "sequences-split" "Splitting sequences"
"Splitting sequences at occurrences of subsequences:"
{ $subsection ?head }
{ $subsection split1 }
{ $subsection split }
"Splitting a string into lines:"
-{ $subsection string-lines }
-{ $subsection "groups-clumps" } ;
+{ $subsection string-lines } ;
ABOUT: "sequences-split"
{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
-HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
-$nl
-"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
-{ $see-also group } ;
-
-HELP: group
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $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 } }" }
-} ;
-
-HELP: <groups>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" 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 ;"
- "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
- }
-} ;
-
-HELP: <sliced-groups>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" 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 ;"
- "9 >array 3 <sliced-groups>"
- "dup [ reverse-here ] each concat >array ."
- "{ 2 1 0 5 4 3 8 7 6 }"
- }
-} ;
-
-HELP: clumps
-{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
-$nl
-"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
-
-HELP: clump
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $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 } }" }
-} ;
-
-HELP: <clumps>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
-{ $examples
- "Running averages:"
- { $example
- "USING: splitting 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 } ;"
- ""
- "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
- "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
- }
-} ;
-
-HELP: <sliced-clumps>
-{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
-
-{ clumps groups } related-words
-
-{ clump group } related-words
-
-{ <clumps> <groups> } related-words
-
-{ <sliced-clumps> <sliced-groups> } related-words
-
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " starts with " { $snippet "begin" } ". If there is a match, outputs the subrange of " { $snippet "seq" } " excluding " { $snippet "begin" } ", and " { $link t } ". If there is no match, outputs " { $snippet "seq" } " and " { $link f } "." } ;
USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
-[ { 1 2 3 } 0 group ] must-fail
-
-[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
-
[ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test
[ "hello" "world-+." ] [ "hello-+world-+." "-+" split1 ] unit-test
[ "goodbye" f ] [ "goodbye" " " split1 ] unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
-
-[ { V{ "a" "b" } V{ f f } } ] [
- V{ "a" "b" } clone 2 <groups>
- 2 over set-length
- >array
-] unit-test
sets math.order accessors ;
IN: splitting
-TUPLE: abstract-groups seq n ;
-
-: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
-
-: construct-groups ( seq n class -- groups )
- >r check-groups r> boa ; inline
-
-GENERIC: group@ ( n groups -- from to seq )
-
-M: abstract-groups nth group@ subseq ;
-
-M: abstract-groups set-nth group@ <slice> 0 swap copy ;
-
-M: abstract-groups like drop { } like ;
-
-INSTANCE: abstract-groups sequence
-
-TUPLE: groups < abstract-groups ;
-
-: <groups> ( seq n -- groups )
- groups construct-groups ; inline
-
-M: groups length
- [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
-
-M: groups set-length
- [ n>> * ] [ seq>> ] bi set-length ;
-
-M: groups group@
- [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-
-TUPLE: sliced-groups < groups ;
-
-: <sliced-groups> ( seq n -- groups )
- sliced-groups construct-groups ; inline
-
-M: sliced-groups nth group@ <slice> ;
-
-TUPLE: clumps < abstract-groups ;
-
-: <clumps> ( seq n -- clumps )
- clumps construct-groups ; inline
-
-M: clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
-
-M: clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
-
-M: clumps group@
- [ n>> over + ] [ seq>> ] bi ;
-
-TUPLE: sliced-clumps < groups ;
-
-: <sliced-clumps> ( seq n -- clumps )
- sliced-clumps construct-groups ; inline
-
-M: sliced-clumps nth group@ <slice> ;
-
-: group ( seq n -- array ) <groups> { } like ;
-
-: clump ( seq n -- array ) <clumps> { } like ;
-
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;
[ ] [
[
4 [
- 100 [ drop "obdurak" clone ] map
+ 100 [ "obdurak" clone ] replicate
gc
dup [
1234 0 rot set-string-nth
{ $notes "This word is used inside parsing words to delegate further action to another parsing word, and to refer to parsing words literally from literal arrays and such." } ;
HELP: :
-{ $syntax ": word definition... ;" }
+{ $syntax ": word ( stack -- effect ) definition... ;" }
{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
-{ $description "Defines a word in the current vocabulary." }
+{ $description "Defines a word with the given stack effect in the current vocabulary. The stack effect is optional for words which only push literals on the stack." }
{ $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- )\n \"Greetings, \" write print ;\n: friend ( -- )\n ask-name greet ;" } } ;
{ POSTPONE: : POSTPONE: ; define } related-words
{ $syntax "\\ word" }
{ $values { "word" "a word" } }
{ $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." }
-{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } } ;
+{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ;
HELP: DEFER:
{ $syntax "DEFER: word" }
{ $syntax "( inputs -- outputs )" }
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
-{ $notes "Recursive words must have a declared stack effect to compile. See " { $link "effect-declaration" } " for details." } ;
+{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
+
+HELP: ((
+{ $syntax "(( inputs -- outputs ))" }
+{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
+{ $description "Literal stack effect syntax." }
+{ $notes "Useful for meta-programming with " { $link define-declared } "." }
+{ $examples
+ { $code
+ "SYMBOL: my-dynamic-word"
+ "USING: math random words ;"
+ "3 { [ + ] [ - ] [ * ] [ / ] } random curry"
+ "(( x -- y )) define-declared"
+ }
+} ;
HELP: !
{ $syntax "! comment..." }
"it satisfies the predicate"
}
"Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch."
+}
+{ $examples
+ { $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" }
} ;
HELP: TUPLE:
] define-syntax
"(" [
- parse-effect word
- [ swap "declared-effect" set-word-prop ] [ drop ] if*
+ ")" parse-effect
+ word dup [ set-stack-effect ] [ 2drop ] if
+ ] define-syntax
+
+ "((" [
+ "))" parse-effect parsed
] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings
-assocs heaps boxes namespaces ;
+assocs heaps boxes namespaces dequeues ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors
-math.order ;
+math.order dequeues ;
IN: threads
SYMBOL: initial-thread
: thread-registered? ( thread -- ? )
id>> threads key? ;
-: check-unregistered
+: check-unregistered ( thread -- thread )
dup thread-registered?
[ "Thread already stopped" throw ] when ;
-: check-registered
+: check-registered ( thread -- thread )
dup thread-registered?
[ "Thread is not running" throw ] unless ;
: sleep-time ( -- ms/f )
{
- { [ run-queue dlist-empty? not ] [ 0 ] }
+ { [ run-queue dequeue-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
: next ( -- * )
expire-sleep-loop
- run-queue dup dlist-empty? [
+ run-queue dup dequeue-empty? [
drop no-runnable-threads
] [
pop-back dup array? [ first2 ] [ f swap ] if (next)
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
- 100 [ drop 100 random ] map >vector
+ 100 [ 100 random ] V{ } replicate-as
dup >array >vector =
] unit-test
SYMBOL: load-help?
-: source-was-loaded t swap set-vocab-source-loaded? ;
+: source-was-loaded ( vocab -- ) t swap set-vocab-source-loaded? ;
-: source-wasn't-loaded f swap set-vocab-source-loaded? ;
+: source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ;
: load-source ( vocab -- )
[ source-wasn't-loaded ] keep
[ vocab-source-path [ bootstrap-file ] when* ] keep
source-was-loaded ;
-: docs-were-loaded t swap set-vocab-docs-loaded? ;
+: docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ;
-: docs-weren't-loaded f swap set-vocab-docs-loaded? ;
+: docs-weren't-loaded ( vocab -- ) f swap set-vocab-docs-loaded? ;
: load-docs ( vocab -- )
load-help? get [
{ $values { "word" word } { "target" word } }
{ $description "Looks up a word with the same name and vocabulary as the given word, performing a transformation to handle parsing words in the target dictionary. Used during bootstrap to transfer host words to the target dictionary." } ;
-HELP: parsing?
+HELP: parsing-word?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a parsing word declared by " { $link POSTPONE: parsing } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
+
+[ { } ]
+[
+ all-words [
+ "compiled-uses" word-prop
+ keys [ "forgotten" word-prop ] contains?
+ ] filter
+] unit-test
+
+[ { } ] [
+ crossref get keys
+ [ word? ] filter [ "forgotten" word-prop ] filter
+] unit-test
M: object (quot-uses) 2drop ;
-M: word (quot-uses)
- >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ;
+M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
- [ drop compiled-crossref? ] assoc-filter
- 2dup "compiled-uses" set-word-prop
- compiled-crossref get add-vertex* ;
+ [ drop crossref? ] assoc-filter
+ [ "compiled-uses" set-word-prop ]
+ [ compiled-crossref get add-vertex* ]
+ 2bi ;
: compiled-unxref ( word -- )
- dup "compiled-uses" word-prop
- compiled-crossref get remove-vertex* ;
+ [
+ dup "compiled-uses" word-prop
+ compiled-crossref get remove-vertex*
+ ]
+ [ f "compiled-uses" set-word-prop ] bi ;
: delete-compiled-xref ( word -- )
dup compiled-unxref
compiled-crossref get delete-at ;
-SYMBOL: +inlined+
-SYMBOL: +called+
-
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
-: compiled-usages ( words -- seq )
- [ unique dup ] keep [
- compiled-usage [ nip +inlined+ eq? ] assoc-filter update
- ] with each keys ;
-
-<PRIVATE
-
-SYMBOL: visited
-
-: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
-
-: (redefined) ( word -- )
- dup visited get key? [ drop ] [
- [ reset-on-redefine reset-props ]
- [ dup visited get set-at ]
- [
- crossref get at keys
- [ word? ] filter
- [ reset-on-redefine [ word-prop ] with contains? ] filter
- [ (redefined) ] each
- ] tri
- ] if ;
+: compiled-usages ( assoc -- seq )
+ clone [
+ dup [
+ [
+ [ compiled-usage ] dip
+ +inlined+ eq? [
+ [ nip +inlined+ eq? ] assoc-filter
+ ] when
+ ] dip swap update
+ ] curry assoc-each
+ ] keep keys ;
-PRIVATE>
+GENERIC: redefined ( word -- )
-: redefined ( word -- )
- H{ } clone visited [ (redefined) ] with-variable ;
+M: object redefined drop ;
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
- dup changed-definition
+ dup +inlined+ changed-definition
dup crossref? [ dup xref ] when drop ;
+: set-stack-effect ( effect word -- )
+ 2dup "declared-effect" word-prop = [ 2drop ] [
+ swap
+ [ "declared-effect" set-word-prop ]
+ [
+ drop
+ dup primitive? [ drop ] [
+ [ redefined ] [ +inlined+ changed-definition ] bi
+ ] if
+ ] 2bi
+ ] if ;
+
: define-declared ( word def effect -- )
pick swap "declared-effect" set-word-prop
define ;
M: word subwords drop f ;
: reset-generic ( word -- )
- dup subwords forget-all
- dup reset-word
- { "methods" "combination" "default-method" } reset-props ;
+ [ subwords forget-all ]
+ [ reset-word ]
+ [ { "methods" "combination" "default-method" } reset-props ]
+ tri ;
: gensym ( -- word )
"( gensym )" f <word> ;
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
-: parsing? ( obj -- ? )
- dup word? [ "parsing" word-prop ] [ drop f ] if ;
+PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
M: word set-where swap "loc" set-word-prop ;
M: word forget*
- dup "forgotten" word-prop [
- dup delete-xref
- dup delete-compiled-xref
- dup word-name over word-vocabulary vocab-words delete-at
- dup t "forgotten" set-word-prop
- ] unless drop ;
+ dup "forgotten" word-prop [ drop ] [
+ [ delete-xref ]
+ [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ]
+ [ t "forgotten" set-word-prop ]
+ tri
+ ] if ;
M: word hashcode*
nip 1 slot { fixnum } declare ;
M: word literalize <wrapper> ;
-: ?word-name dup word? [ word-name ] when ;
+: ?word-name ( word -- name ) dup word? [ word-name ] when ;
: xref-words ( -- ) all-words [ xref ] each ;
--- /dev/null
+USING: words quotations kernel effects sequences parser ;\r
+IN: alias\r
+\r
+PREDICATE: alias < word "alias" word-prop ;\r
+\r
+M: alias reset-word\r
+ [ call-next-method ] [ f "alias" set-word-prop ] bi ;\r
+\r
+M: alias stack-effect\r
+ word-def first stack-effect ;\r
+\r
+: define-alias ( new old -- )\r
+ [ 1quotation define-inline ]\r
+ [ drop t "alias" set-word-prop ] 2bi ;\r
+\r
+: ALIAS: CREATE-WORD scan-word define-alias ; parsing\r
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element new ;
+: <element> ( -- element ) element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
: replace-at ( assoc value key -- assoc )
>r >r dup r> 1vector r> rot set-at ;
-: insert-at ( value key assoc -- )
- [ ?push ] change-at ;
-
: peek-at* ( assoc key -- obj ? )
swap at* dup [ >r peek r> ] when ;
: multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline
-: insert ( value variable -- ) namespace insert-at ;
+: insert ( value variable -- ) namespace push-at ;
: generate-key ( assoc -- str )
>r 32 random-bits >hex r>
USING: kernel tools.test base64 strings ;
-[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
+[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
] unit-test
-[ "" ] [ "" >base64 base64> ] unit-test
-[ "a" ] [ "a" >base64 base64> ] unit-test
-[ "ab" ] [ "ab" >base64 base64> ] unit-test
-[ "abc" ] [ "abc" >base64 base64> ] unit-test
+[ "" ] [ "" >base64 base64> >string ] unit-test
+[ "a" ] [ "a" >base64 base64> >string ] unit-test
+[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
+[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+
+! From http://en.wikipedia.org/wiki/Base64
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+ "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+ >base64 >string
+] unit-test
+
+\ >base64 must-infer
+\ base64> must-infer
-USING: kernel math sequences namespaces io.binary splitting
- strings hashtables ;
+USING: kernel math sequences io.binary splitting grouping ;
IN: base64
<PRIVATE
: count-end ( seq quot -- count )
- >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ;
+ >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
} nth ;
: encode3 ( seq -- seq )
- be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ;
+ be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
: decode4 ( str -- str )
- [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
+ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str )
- [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
+ [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
PRIVATE>
: >base64 ( seq -- base64 )
#! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits
- dup length dup 3 mod - cut swap
- [
- 3 <groups> [ encode3 % ] each
- dup empty? [ drop ] [ >base64-rem % ] if
- ] "" make ;
+ dup length dup 3 mod - cut
+ [ 3 <groups> [ encode3 ] map concat ]
+ [ dup empty? [ drop "" ] [ >base64-rem ] if ]
+ bi* append ;
: base64> ( base64 -- str )
#! input length must be a multiple of 4
- [
- [ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
- ] SBUF" " make swap [ dup pop* ] times >string ;
-
+ [ 4 <groups> [ decode4 ] map concat ]
+ [ [ CHAR: = = not ] count-end ]
+ bi head* ;
USING: math kernel continuations ;
IN: benchmark.continuations
-: continuations-main
+: continuations-main ( -- )
100000 [ drop [ continue ] callcc0 ] each-integer ;
MAIN: continuations-main
-USING: namespaces math sequences splitting kernel columns ;
+USING: namespaces math sequences splitting grouping
+kernel columns ;
IN: benchmark.dispatch2
-: sequences
+: sequences ( -- seq )
[
1 ,
10 >bignum ,
1 [ + ] curry ,
] { } make ;
-: don't-flush-me drop ;
+: don't-flush-me ( obj -- ) drop ;
-: dispatch-test
+: dispatch-test ( -- )
1000000 sequences
[ [ 0 swap nth don't-flush-me ] each ] curry times ;
-USING: sequences math mirrors splitting kernel namespaces
-assocs alien.syntax columns ;
+USING: sequences math mirrors splitting grouping
+kernel namespaces assocs alien.syntax columns ;
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
M: object g drop "object" ;
-: objects
+: objects ( -- seq )
[
H{ } ,
\ + <mirror> ,
ALIEN: 1234 ,
] { } make ;
-: dispatch-test
+: dispatch-test ( -- )
2000000 objects [ [ g drop ] each ] curry times ;
MAIN: dispatch-test
sequences.private ;
IN: benchmark.dispatch4
-: foobar-1
+: foobar-1 ( n -- val )
dup {
[ 0 eq? [ 0 ] [ "x" ] if ]
[ 1 eq? [ 1 ] [ "x" ] if ]
[ 19 eq? [ 19 ] [ "x" ] if ]
} dispatch ;
-: foobar-2
+: foobar-2 ( n -- val )
{
{ [ dup 0 eq? ] [ drop 0 ] }
{ [ dup 1 eq? ] [ drop 1 ] }
{ [ dup 19 eq? ] [ drop 19 ] }
} cond ;
-: foobar-test-1
+: foobar-test-1 ( -- )
20000000 [
20 [
foobar-1 drop
] each
] times ;
-: foobar-test-2
+: foobar-test-2 ( -- )
20000000 [
20 [
foobar-2 drop
] ;
-: run-fasta 2500000 reverse-complement-in fasta ;
+: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
MAIN: run-fasta
swap 1 fixnum-fast fast-fixnum-fib fixnum+fast
] if ;
-: fib-main 34 fast-fixnum-fib 9227465 assert= ;
+: fib-main ( -- ) 34 fast-fixnum-fib 9227465 assert= ;
MAIN: fib-main
1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+
] if ;
-: fib-main 34 fixnum-fib 9227465 assert= ;
+: fib-main ( -- ) 34 fixnum-fib 9227465 assert= ;
MAIN: fib-main
: fib ( m -- n )
dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
-: fib-main 34 fib 9227465 assert= ;
+: fib-main ( -- ) 34 fib 9227465 assert= ;
MAIN: fib-main
swap box-i swap box-i + <box>
] if ;
-: fib-main T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
+: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
MAIN: fib-main
] if
] with-scope ;
-: fib-main 30 namespace-fib 1346269 assert= ;
+: fib-main ( -- ) 30 namespace-fib 1346269 assert= ;
MAIN: fib-main
IN: benchmark.fib6\r
USING: math kernel alien ;\r
\r
-: fib\r
+: fib ( x -- y )\r
"int" { "int" } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
1- dup fib swap 1- fib +\r
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
\r
-: fib-main 25 fib drop ;\r
+: fib-main ( -- ) 25 fib drop ;\r
\r
MAIN: fib-main\r
: <range> ( from to -- seq ) dup <slice> ; inline
-: vector-iter 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
-: array-iter 100 [ 0 100000 <range> >array [ ] map drop ] times ;
-: string-iter 100 [ 0 100000 <range> >string [ ] map drop ] times ;
-: sbuf-iter 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
-: reverse-iter 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
-: dot-iter 100 [ 0 100000 <range> dup v. drop ] times ;
+: vector-iter ( -- ) 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
+: array-iter ( -- ) 100 [ 0 100000 <range> >array [ ] map drop ] times ;
+: string-iter ( -- ) 100 [ 0 100000 <range> >string [ ] map drop ] times ;
+: sbuf-iter ( -- ) 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
+: reverse-iter ( -- ) 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
+: dot-iter ( -- ) 100 [ 0 100000 <range> dup v. drop ] times ;
-: iter-main
+: iter-main ( -- )
vector-iter
array-iter
string-iter
: ppm-header ( w h -- )
"P6\n" % swap # " " % # "\n255\n" % ;
-: buf-size width height * 3 * 100 + ;
+: buf-size ( -- n ) width height * 3 * 100 + ;
: mandel ( -- data )
[
dup 1- 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
-: nsieve-bits-main* 11 nsieve-bits-main ;
+: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
MAIN: nsieve-bits-main*
dup 1 - 2^ 10000 * nsieve.
2 - 2^ 10000 * nsieve. ;
-: nsieve-main* 9 nsieve-main ;
+: nsieve-main* ( -- ) 9 nsieve-main ;
MAIN: nsieve-main*
] with each
] tabular-output ;
-: partial-sums-main 2500000 partial-sums ;
+: partial-sums-main ( -- ) 2500000 partial-sums ;
MAIN: partial-sums-main
USING: io.files io.encodings.ascii random math.parser io math ;
IN: benchmark.random
-: random-numbers-path "random-numbers.txt" temp-file ;
+: random-numbers-path ( -- path )
+ "random-numbers.txt" temp-file ;
: write-random-numbers ( n -- )
random-numbers-path ascii [
[ [ oversampling sq / pgm-pixel ] each ] each
] B{ } make ;
-: raytracer-main
+: raytracer-main ( -- )
run "raytracer.pnm" temp-file binary set-file-contents ;
MAIN: raytracer-main
HINTS: recursive fixnum ;
-: recursive-main 11 recursive ;
+: recursive-main ( -- ) 11 recursive ;
MAIN: recursive-main
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
-hints unicode.case continuations io.encodings.ascii ;
+grouping hints unicode.case continuations io.encodings.ascii ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
] with-file-reader
] with-file-writer ;
-: reverse-complement-in
+: reverse-complement-in ( -- path )
"reverse-complement-in.txt" temp-file ;
-: reverse-complement-out
+: reverse-complement-out ( -- path )
"reverse-complement-out.txt" temp-file ;
: reverse-complement-main ( -- )
: number-of-requests 1 ;
-: server-addr "127.0.0.1" 7777 <inet4> ;
+: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- )
dup accept drop [
io.files io.encodings.ascii ;
IN: benchmark.sort
-: sort-benchmark
+: sort-benchmark ( -- )
random-numbers-path
ascii file-lines [ string>number ] map
natural-sort drop ;
TUPLE: hello n ;
-: foo 0 100000000 [ over hello-n + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- value ) dup tuple? [ 3 slot ] [ 3 throw ] if ;
-: foo 0 100000000 [ over hello-n* + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- val ) dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
-: foo 0 100000000 [ over hello-n* + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* 3 slot ;
+: hello-n* ( obj -- val ) 3 slot ;
-: foo 0 100000000 [ over hello-n* + ] times ;
+: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello boa foo 2drop ;
+: typecheck-main ( -- ) 0 hello boa foo 2drop ;
MAIN: typecheck-main
>ranges filter-pad [ define-setters ] 2keep define-accessors
] with-compilation-unit ;
-: parse-bitfield
+: parse-bitfield ( -- )
scan ";" parse-tokens parse-slots define-bitfield ;
: BITFIELD:
{ [ cohesion-radius> in-range? ]
[ cohesion-view-angle> in-view? ]
[ eq? not ] }
- <--&& ;
+ 2&& ;
: cohesion-neighborhood ( self -- boids )
boids> [ within-cohesion-neighborhood? ] with filter ;
{ [ separation-radius> in-range? ]
[ separation-view-angle> in-view? ]
[ eq? not ] }
- <--&& ;
+ 2&& ;
: separation-neighborhood ( self -- boids )
boids> [ within-separation-neighborhood? ] with filter ;
{ [ alignment-radius> in-range? ]
[ alignment-view-angle> in-view? ]
[ eq? not ] }
- <--&& ;
+ 2&& ;
: alignment-neighborhood ( self -- boids )
boids> [ within-alignment-neighborhood? ] with filter ;
parser vocabs.loader ;
IN: bootstrap.help
-: load-help
+: load-help ( -- )
"alien.syntax" require
"compiler" require
: 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 -- ? )
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
-: checksums "checksums.txt" temp-file ;
+: checksums ( -- temp ) "checksums.txt" temp-file ;
-: boot-image-names images [ boot-image-name ] map ;
+: boot-image-names ( -- seq ) images [ boot-image-name ] map ;
: compute-checksums ( -- )
checksums ascii [
--- /dev/null
+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
ascii [ parse-model ] with-file-reader
[ normals ] 2keep 3array ;
-: model-path "bun_zipper.ply" temp-file ;
+: model-path ( -- path ) "bun_zipper.ply" temp-file ;
-: model-url "http://factorcode.org/bun_zipper.ply" ;
+: model-url ( -- url ) "http://factorcode.org/bun_zipper.ply" ;
: maybe-download ( -- path )
model-path dup exists? [
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math opengl.gadgets kernel
byte-arrays cairo.ffi cairo io.backend
-opengl.gl arrays ;
+ui.gadgets accessors opengl.gl
+arrays ;
IN: cairo.gadgets
>r first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
- r> with-cairo-from-surface ;
+ r> with-cairo-from-surface ; inline
-: <cairo-gadget> ( dim quot -- )
- over 2^-bounds swap copy-cairo
- GL_BGRA rot <texture-gadget> ;
+TUPLE: cairo-gadget < texture-gadget dim quot ;
+
+: <cairo-gadget> ( dim quot -- gadget )
+ cairo-gadget construct-gadget
+ swap >>quot
+ swap >>dim ;
+
+M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
+
+: render-cairo ( dim quot -- bytes format )
+ >r 2^-bounds r> copy-cairo GL_BGRA ; inline
+
+! M: cairo-gadget render*
+! [ dim>> dup ] [ quot>> ] bi
+! render-cairo render-bytes* ;
! maybe also texture>png
! : cairo>png ( gadget path -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
-: <png-gadget> ( path -- gadget )
- normalize-path cairo_image_surface_create_from_png
+TUPLE: png-gadget < texture-gadget path ;
+: <png> ( path -- gadget )
+ png-gadget construct-gadget
+ swap >>path ;
+
+M: png-gadget render*
+ path>> normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height 2array dup 2^-bounds ]
[ [ copy-surface ] curry copy-cairo ] tri
- GL_BGRA rot <texture-gadget> ;
-
+ GL_BGRA render-bytes* ;
+M: png-gadget cache-key* path>> ;
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader calendar.backend threads
-accessors combinators locals classes.tuple math.order ;
+accessors combinators locals classes.tuple math.order
+memoize ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
-: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
-: years ( n -- dt ) instant swap >>year ;
-: months ( n -- dt ) instant swap >>month ;
-: days ( n -- dt ) instant swap >>day ;
+MEMO: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
+: years ( n -- dt ) instant clone swap >>year ;
+: months ( n -- dt ) instant clone swap >>month ;
+: days ( n -- dt ) instant clone swap >>day ;
: weeks ( n -- dt ) 7 * days ;
-: hours ( n -- dt ) instant swap >>hour ;
-: minutes ( n -- dt ) instant swap >>minute ;
-: seconds ( n -- dt ) instant swap >>second ;
+: hours ( n -- dt ) instant clone swap >>hour ;
+: minutes ( n -- dt ) instant clone swap >>minute ;
+: seconds ( n -- dt ) instant clone swap >>second ;
: milliseconds ( n -- dt ) 1000 / seconds ;
GENERIC: leap-year? ( obj -- ? )
M: duration time-
before time+ ;
-: <zero> 0 0 0 0 0 0 instant <timestamp> ;
+MEMO: <zero> ( -- timestamp )
+0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
-: unix-1970 ( -- timestamp )
- 1970 1 1 0 0 0 instant <timestamp> ; foldable
+MEMO: unix-1970 ( -- timestamp )
+ 1970 1 1 0 0 0 instant <timestamp> ;
: millis>timestamp ( n -- timestamp )
>r unix-1970 r> milliseconds time+ ;
calendar calendar.format.macros ;\r
IN: calendar.format\r
\r
-: pad-00 number>string 2 CHAR: 0 pad-left ;\r
+: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
\r
-: pad-0000 number>string 4 CHAR: 0 pad-left ;\r
+: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;\r
\r
-: pad-00000 number>string 5 CHAR: 0 pad-left ;\r
+: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;\r
\r
-: write-00 pad-00 write ;\r
+: write-00 ( n -- ) pad-00 write ;\r
\r
-: write-0000 pad-0000 write ;\r
+: write-0000 ( n -- ) pad-0000 write ;\r
\r
-: write-00000 pad-00000 write ;\r
+: write-00000 ( n -- ) pad-00000 write ;\r
\r
-: hh hour>> write-00 ;\r
+: hh ( time -- ) hour>> write-00 ;\r
\r
-: mm minute>> write-00 ;\r
+: mm ( time -- ) minute>> write-00 ;\r
\r
-: ss second>> >integer write-00 ;\r
+: ss ( time -- ) second>> >integer write-00 ;\r
\r
-: D day>> number>string write ;\r
+: D ( time -- ) day>> number>string write ;\r
\r
-: DD day>> write-00 ;\r
+: DD ( time -- ) day>> write-00 ;\r
\r
-: DAY day-of-week day-abbreviations3 nth write ;\r
+: DAY ( time -- ) day-of-week day-abbreviations3 nth write ;\r
\r
-: MM month>> write-00 ;\r
+: MM ( time -- ) month>> write-00 ;\r
\r
-: MONTH month>> month-abbreviations nth write ;\r
+: MONTH ( time -- ) month>> month-abbreviations nth write ;\r
\r
-: YYYY year>> write-0000 ;\r
+: YYYY ( time -- ) year>> write-0000 ;\r
\r
-: YYYYY year>> write-00000 ;\r
+: YYYYY ( time -- ) year>> write-00000 ;\r
\r
: expect ( str -- )\r
read1 swap member? [ "Parse error" throw ] unless ;\r
\r
-: read-00 2 read string>number ;\r
+: read-00 ( -- n ) 2 read string>number ;\r
\r
-: read-000 3 read string>number ;\r
+: read-000 ( -- n ) 3 read string>number ;\r
\r
-: read-0000 4 read string>number ;\r
+: read-0000 ( -- n ) 4 read string>number ;\r
\r
GENERIC: day. ( obj -- )\r
\r
: timestamp>ymd ( timestamp -- str )\r
[ (timestamp>ymd) ] with-string-writer ;\r
\r
-: (timestamp>hms)\r
+: (timestamp>hms) ( timestamp -- )\r
{ hh ":" mm ":" ss } formatted ;\r
\r
: timestamp>hms ( timestamp -- str )\r
[ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with
-: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ;
+: compiled-test-1 ( -- n )
+ { [ 1 throw ] [ 2 ] } attempt-all-quots ;
\ compiled-test-1 must-infer
1000 sleep (time-thread) ;\r
\r
: time-thread ( -- )\r
- [ (time-thread) ] "Time model update" spawn drop ;\r
+ [\r
+ init-namespaces\r
+ (time-thread)\r
+ ] "Time model update" spawn drop ;\r
\r
f <model> time set-global\r
[ time-thread ] "calendar.model" add-init-hook\r
! See http://www.faqs.org/rfcs/rfc1321.html
USING: kernel io io.binary io.files io.streams.byte-array math
-math.functions math.parser namespaces splitting strings
+math.functions math.parser namespaces splitting grouping strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols math.bitfields.lib checksums ;
IN: checksums.md5
: S43 15 ; inline
: S44 21 ; inline
-: (process-md5-block-F)
+: (process-md5-block-F) ( block -- block )
dup S11 1 0 [ F ] ABCD
dup S12 2 1 [ F ] DABC
dup S13 3 2 [ F ] CDAB
dup S13 15 14 [ F ] CDAB
dup S14 16 15 [ F ] BCDA ;
-: (process-md5-block-G)
+: (process-md5-block-G) ( block -- block )
dup S21 17 1 [ G ] ABCD
dup S22 18 6 [ G ] DABC
dup S23 19 11 [ G ] CDAB
dup S23 31 7 [ G ] CDAB
dup S24 32 12 [ G ] BCDA ;
-: (process-md5-block-H)
+: (process-md5-block-H) ( block -- block )
dup S31 33 5 [ H ] ABCD
dup S32 34 8 [ H ] DABC
dup S33 35 11 [ H ] CDAB
dup S33 47 15 [ H ] CDAB
dup S34 48 2 [ H ] BCDA ;
-: (process-md5-block-I)
+: (process-md5-block-I) ( block -- block )
dup S41 49 0 [ I ] ABCD
dup S42 50 7 [ I ] DABC
dup S43 51 14 [ I ] CDAB
-USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols math.bitfields.lib checksums ;
+USING: crypto.common kernel splitting grouping
+math sequences namespaces io.binary symbols
+math.bitfields.lib checksums ;
IN: checksums.sha2
<PRIVATE
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien io kernel namespaces core-foundation
+USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads debugger init inspector
kernel.private ;
: NSApp ( -- app ) NSApplication -> sharedApplication ;
+FUNCTION: void NSBeep ( ) ;
+
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ;
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii ;
+memoize debugger io.encodings.ascii effects ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: define-objc-class-word ( name quot -- )
[
over , , \ unless-defined , dup , \ objc-class ,
- ] [ ] make >r "cocoa.classes" create r> define ;
+ ] [ ] make >r "cocoa.classes" create r>
+ (( -- class )) define-declared ;
: import-objc-class ( name quot -- )
2dup unless-defined
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
- 3 [ drop 0 0 0 255 <range> ] map
+ 3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose>
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
}
{ $see-also keep nslip } ;
-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." } ;
+! 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." } ;
-HELP: ||
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
-{ $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ;
+! HELP: ||
+! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
+! { $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ;
[ t ] [
3 {
[ dup number? ] [ dup odd? ] [ dup 0 > ]
- } && nip
+ } 0&& nip
] unit-test
[ f ] [
3 {
[ dup number? ] [ dup even? ] [ dup 0 > ]
- } && nip
+ } 0&& nip
] unit-test
! ||
[ t ] [
4 {
[ dup array? ] [ dup number? ] [ 3 throw ]
- } || nip
+ } 0|| nip
] unit-test
[ f ] [
4 {
[ dup array? ] [ dup vector? ] [ dup float? ]
- } || nip
+ } 0|| nip
] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: short-circuit ( quots quot default -- quot )
- 1quotation -rot { } map>assoc <reversed> alist>quot ;
+ 1quotation -rot { } map>assoc <reversed> alist>quot ;
-MACRO: && ( quots -- ? )
- [ [ not ] append [ f ] ] t short-circuit ;
-
-MACRO: <-&& ( quots -- )
- [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
- [ nip ] append ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: <--&& ( quots -- )
- [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
- [ 2nip ] append ;
+MACRO: 0&& ( quots -- quot )
+ [ '[ drop @ dup not ] [ drop f ] 2array ] map
+ { [ t ] [ ] } suffix
+ '[ f , cond ] ;
-! or
+MACRO: 1&& ( quots -- quot )
+ [ '[ drop dup @ dup not ] [ drop drop f ] 2array ] map
+ { [ t ] [ nip ] } suffix
+ '[ f , cond ] ;
-MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
+MACRO: 2&& ( quots -- quot )
+ [ '[ drop 2dup @ dup not ] [ drop 2drop f ] 2array ] map
+ { [ t ] [ 2nip ] } suffix
+ '[ f , cond ] ;
-MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MACRO: 1|| ( quots -- ? )
- [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
+MACRO: 0|| ( quots -- quot )
+ [ '[ drop @ dup ] [ ] 2array ] map
+ { [ drop t ] [ f ] } suffix
+ '[ f , cond ] ;
-MACRO: 2|| ( quots -- ? )
- [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+MACRO: 1|| ( quots -- quot )
+ [ '[ drop dup @ dup ] [ nip ] 2array ] map
+ { [ drop drop t ] [ f ] } suffix
+ '[ f , cond ] ;
-MACRO: 3|| ( quots -- ? )
- [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
+MACRO: 2|| ( quots -- quot )
+ [ '[ drop 2dup @ dup ] [ 2nip ] 2array ] map
+ { [ drop 2drop t ] [ f ] } suffix
+ '[ f , cond ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists dlists.private threads kernel arrays sequences\r
-alarms ;\r
+USING: dequeues threads kernel arrays sequences alarms ;\r
IN: concurrency.conditions\r
\r
-: notify-1 ( dlist -- )\r
- dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;\r
+: notify-1 ( dequeue -- )\r
+ dup dequeue-empty? [ drop ] [ pop-back resume-now ] if ;\r
\r
-: notify-all ( dlist -- )\r
- [ resume-now ] dlist-slurp ;\r
+: notify-all ( dequeue -- )\r
+ [ resume-now ] slurp-dequeue ;\r
\r
: queue-timeout ( queue timeout -- alarm )\r
#! Add an alarm which removes the current thread from the\r
#! queue, and resumes it, passing it a value of t.\r
- >r self over push-front* [\r
- tuck delete-node\r
- dlist-node-obj t swap resume-with\r
+ >r [ self swap push-front* ] keep [\r
+ [ delete-node ] [ drop node-value ] 2bi\r
+ t swap resume-with\r
] 2curry r> later ;\r
\r
: wait ( queue timeout status -- )\r
IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations ;
+concurrency.messaging continuations accessors prettyprint ;
-: test-node
+: test-node ( -- addrspec )
{
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
{ [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
-[ ] [ test-node dup 1array swap (start-node) ] unit-test
+[ ] [ test-node dup (start-node) ] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ 1000 sleep ] unit-test
[ ] [
[
receive
] unit-test
+[ ] [ 1000 sleep ] unit-test
+
[ ] [ test-node stop-node ] unit-test
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
-io.server qualified arrays namespaces kernel io.encodings.binary
-accessors ;
+io.servers.connection io.encodings.binary
+qualified arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
: handle-node-client ( -- )
deserialize
- [ first2 get-process send ]
- [ stop-server ] if* ;
+ [ first2 get-process send ] [ stop-server ] if* ;
-: (start-node) ( addrspecs addrspec -- )
+: (start-node) ( addrspec addrspec -- )
local-node set-global
[
- "concurrency.distributed"
- binary
- [ handle-node-client ] with-server
+ <threaded-server>
+ swap >>insecure
+ binary >>encoding
+ "concurrency.distributed" >>name
+ [ handle-node-client ] >>handler
+ start-server
] curry "Distributed concurrency server" spawn drop ;
: start-node ( port -- )
- [ internet-server ]
- [ host-name swap <inet> ] bi
- (start-node) ;
+ host-name over <inet> (start-node) ;
TUPLE: remote-process id node ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists kernel threads continuations math\r
+USING: dequeues dlists kernel threads continuations math\r
concurrency.conditions ;\r
IN: concurrency.locks\r
\r
\r
: release-write-lock ( lock -- )\r
f over set-rw-lock-writer\r
- dup rw-lock-readers dlist-empty?\r
+ dup rw-lock-readers dequeue-empty?\r
[ notify-writer ] [ rw-lock-readers notify-all ] if ;\r
\r
: reentrant-read-lock-ok? ( lock -- ? )\r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
IN: concurrency.mailboxes\r
-USING: dlists threads sequences continuations destructors\r
-namespaces random math quotations words kernel arrays assocs\r
-init system concurrency.conditions accessors debugger ;\r
+USING: dlists dequeues threads sequences continuations\r
+destructors namespaces random math quotations words kernel\r
+arrays assocs init system concurrency.conditions accessors\r
+debugger ;\r
\r
TUPLE: mailbox threads data disposed ;\r
\r
<dlist> <dlist> f mailbox boa ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
- data>> dlist-empty? ;\r
+ data>> dequeue-empty? ;\r
\r
: mailbox-put ( obj mailbox -- )\r
[ data>> push-front ]\r
\r
C: <linked-error> linked-error\r
\r
-: ?linked dup linked-error? [ rethrow ] when ;\r
+: ?linked ( message -- message )\r
+ dup linked-error? [ rethrow ] when ;\r
\r
TUPLE: linked-thread < thread supervisor ;\r
\r
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel threads vectors arrays sequences
-namespaces tools.test continuations dlists strings math words
+namespaces tools.test continuations dequeues strings math words
match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
-[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
+[ ] [ my-mailbox mailbox-data clear-dequeue ] unit-test
[ "received" ] [
[
M: thread send ( message thread -- )\r
check-registered mailbox-of mailbox-put ;\r
\r
-: my-mailbox self mailbox-of ;\r
+: my-mailbox ( -- mailbox ) self mailbox-of ;\r
\r
: receive ( -- message )\r
my-mailbox mailbox-get ?linked ;\r
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: cords.tests
+USING: cords strings tools.test kernel sequences ;
+
+[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test
+[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences sorting math math.order
+arrays combinators kernel ;
+IN: cords
+
+<PRIVATE
+
+TUPLE: simple-cord first second ;
+
+M: simple-cord length
+ [ first>> length ] [ second>> length ] bi + ;
+
+M: simple-cord virtual-seq first>> ;
+
+M: simple-cord virtual@
+ 2dup first>> length <
+ [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ;
+
+TUPLE: multi-cord count seqs ;
+
+M: multi-cord length count>> ;
+
+M: multi-cord virtual@
+ dupd
+ seqs>> [ first <=> ] binsearch*
+ [ first - ] [ second ] bi ;
+
+M: multi-cord virtual-seq
+ seqs>> dup empty? [ drop f ] [ first second ] if ;
+
+: <cord> ( seqs -- cord )
+ dup length 2 = [
+ first2 simple-cord boa
+ ] [
+ [ 0 [ length + ] accumulate ] keep zip multi-cord boa
+ ] if ;
+
+PRIVATE>
+
+UNION: cord simple-cord multi-cord ;
+
+INSTANCE: cord virtual-sequence
+
+INSTANCE: multi-cord virtual-sequence
+
+: cord-append ( seq1 seq2 -- cord )
+ {
+ { [ over empty? ] [ nip ] }
+ { [ dup empty? ] [ drop ] }
+ { [ 2dup [ cord? ] both? ] [ [ seqs>> values ] bi@ append <cord> ] }
+ { [ over cord? ] [ [ seqs>> values ] dip suffix <cord> ] }
+ { [ dup cord? ] [ seqs>> values swap prefix <cord> ] }
+ [ 2array <cord> ]
+ } cond ;
+
+: cord-concat ( seqs -- cord )
+ {
+ { [ dup empty? ] [ drop f ] }
+ { [ dup length 1 = ] [ first ] }
+ [
+ [
+ {
+ { [ dup cord? ] [ seqs>> values ] }
+ { [ dup empty? ] [ drop { } ] }
+ [ 1array ]
+ } cond
+ ] map concat <cord>
+ ]
+ } cond ;
--- /dev/null
+Virtual sequence concatenation
--- /dev/null
+collections
SYMBOL: event-stream-callbacks
-: event-stream-counter \ event-stream-counter counter ;
+: event-stream-counter ( -- n )
+ \ event-stream-counter counter ;
[
event-stream-callbacks global
!
USING: kernel math sequences words arrays io io.files namespaces
math.parser assocs quotations parser parser-combinators
-tools.time io.encodings.binary ;
+tools.time io.encodings.binary sequences.deep symbols combinators ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
{ "M" { flag-m? } }
} at ;
-SYMBOL: $1
-SYMBOL: $2
-SYMBOL: $3
-SYMBOL: $4
+SYMBOLS: $1 $2 $3 $4 ;
: replace-patterns ( vector tree -- tree )
- #! Copy the tree, replacing each occurence of
- #! $1, $2, etc with the relevant item from the
- #! given index.
- dup quotation? over [ ] = not and [ ! vector tree
- dup first swap rest ! vector car cdr
- >r dupd replace-patterns ! vector v R: cdr
- swap r> replace-patterns >r 1quotation r> append
- ] [ ! vector value
- dup $1 = [ drop 0 over nth ] when
- dup $2 = [ drop 1 over nth ] when
- dup $3 = [ drop 2 over nth ] when
- dup $4 = [ drop 3 over nth ] when
- nip
- ] if ;
-
-: test-rp
- { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
+ [
+ {
+ { $1 [ first ] }
+ { $2 [ second ] }
+ { $3 [ third ] }
+ { $4 [ fourth ] }
+ [ nip ]
+ } case
+ ] with deep-map ;
: (emulate-RST) ( n cpu -- )
#! RST nn
"H" token <|>
"L" token <|> [ register-lookup ] <@ ;
-: all-flags
+: all-flags ( -- parser )
#! A parser for 16-bit flags.
"NZ" token
"NC" token <|>
"P" token <|>
"M" token <|> [ flag-lookup ] <@ ;
-: 16-bit-registers
+: 16-bit-registers ( -- parser )
#! A parser for 16-bit registers. On a successfull parse the
#! parse tree contains a vector. The first item in the vector
#! is the getter word for that register with stack effect
16-bit-registers indirect <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-RR,NN-instruction
+: LD-RR,NN-instruction ( -- parser )
#! LD BC,nn
"LD-RR,NN" "LD" complex-instruction
16-bit-registers sp <&>
",nn" token <&
just [ first2 swap curry ] <@ ;
-: LD-R,N-instruction
+: LD-R,N-instruction ( -- parser )
#! LD B,n
"LD-R,N" "LD" complex-instruction
8-bit-registers sp <&>
",n" token <&
just [ first2 swap curry ] <@ ;
-: LD-(RR),N-instruction
+: LD-(RR),N-instruction ( -- parser )
"LD-(RR),N" "LD" complex-instruction
16-bit-registers indirect sp <&>
",n" token <&
just [ first2 swap curry ] <@ ;
-: LD-(RR),R-instruction
+: LD-(RR),R-instruction ( -- parser )
#! LD (BC),A
"LD-(RR),R" "LD" complex-instruction
16-bit-registers indirect sp <&>
8-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-R,R-instruction
+: LD-R,R-instruction ( -- parser )
"LD-R,R" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-RR,RR-instruction
+: LD-RR,RR-instruction ( -- parser )
"LD-RR,RR" "LD" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-R,(RR)-instruction
+: LD-R,(RR)-instruction ( -- parser )
"LD-R,(RR)" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: LD-(NN),RR-instruction
+: LD-(NN),RR-instruction ( -- parser )
"LD-(NN),RR" "LD" complex-instruction
"nn" token indirect sp <&
"," token <&
16-bit-registers <&>
just [ first2 swap curry ] <@ ;
-: LD-(NN),R-instruction
+: LD-(NN),R-instruction ( -- parser )
"LD-(NN),R" "LD" complex-instruction
"nn" token indirect sp <&
"," token <&
8-bit-registers <&>
just [ first2 swap curry ] <@ ;
-: LD-RR,(NN)-instruction
+: LD-RR,(NN)-instruction ( -- parser )
"LD-RR,(NN)" "LD" complex-instruction
16-bit-registers sp <&>
"," token <&
"nn" token indirect <&
just [ first2 swap curry ] <@ ;
-: LD-R,(NN)-instruction
+: LD-R,(NN)-instruction ( -- parser )
"LD-R,(NN)" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
"nn" token indirect <&
just [ first2 swap curry ] <@ ;
-: OUT-(N),R-instruction
+: OUT-(N),R-instruction ( -- parser )
"OUT-(N),R" "OUT" complex-instruction
"n" token indirect sp <&
"," token <&
8-bit-registers <&>
just [ first2 swap curry ] <@ ;
-: IN-R,(N)-instruction
+: IN-R,(N)-instruction ( -- parser )
"IN-R,(N)" "IN" complex-instruction
8-bit-registers sp <&>
"," token <&
"n" token indirect <&
just [ first2 swap curry ] <@ ;
-: EX-(RR),RR-instruction
+: EX-(RR),RR-instruction ( -- parser )
"EX-(RR),RR" "EX" complex-instruction
16-bit-registers indirect sp <&>
"," token <&
16-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: EX-RR,RR-instruction
+: EX-RR,RR-instruction ( -- parser )
"EX-RR,RR" "EX" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
-: 8080-generator-parser
+: 8080-generator-parser ( -- parser )
NOP-instruction
RST-0-instruction <|>
RST-8-instruction <|>
#! that would implement that instruction.
dup " " join instruction-quotations
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
- r> define ;
+ r> (( cpu -- )) define-declared ;
: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
-USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints math.bitfields.lib
-assocs ;
+USING: arrays kernel io io.binary sbufs splitting grouping
+strings sequences namespaces math math.parser parser
+hints math.bitfields.lib assocs ;
IN: crypto.common
: w+ ( int int -- int ) + 32 bits ; inline
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 ;
swap >>out-params
swap >>in-params
swap >>sql ;
-
+
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
FUNCTION: void PQfreemem ( void* ptr ) ;
! Exists for backward compatibility.
-: PQfreeNotify PQfreemem ;
+: PQfreeNotify ( ptr -- ) PQfreemem ;
!
! Make an empty PGresult with given status (some apps find this
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 )
: param-types ( statement -- seq )
in-params>> [ type>> type>oid ] map >c-uint-array ;
-: malloc-byte-array/length
+: malloc-byte-array/length ( byte-array -- alien length )
[ malloc-byte-array &free ] [ length ] bi ;
-: default-param-value
+: default-param-value ( obj -- alien n )
number>string* dup [ utf8 malloc-string &free ] when 0 ;
: param-values ( statement -- seq seq2 )
{ 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? [
{ 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 ] }
{ 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" } }
! 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 -- )
] 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 )
[
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 ;
+
+: create-index ( index-name table-name columns -- )
+ [
+ >r >r "create index " % % r> " on " % % r> "(" %
+ "," join % ")" %
+ ] "" make sql-command ;
+
+: drop-index ( index-name -- )
+ [ "drop index " % % ] "" make sql-command ;
where group-by having order-by limit offset is-null desc all
any count avg table values ;
-: input-spec, 1, ;
-: output-spec, 2, ;
-: input, 3, ;
-: output, 4, ;
+: input-spec, ( obj -- ) 1, ;
+: output-spec, ( obj -- ) 2, ;
+: input, ( obj -- ) 3, ;
+: output, ( obj -- ) 4, ;
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 ] }
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% ] }
} 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 ;
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 ;
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 ] }
{ 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
M: sqlite-statement low-level-bind ( statement -- )
[ statement-bind-params ] [ statement-handle ] bi
- swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
+ [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
{ 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" } }
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 ;
-
-: <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 ;
-
-: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
- <person> [ set-person-the-id ] keep ;
+ts date time blob factor-blob url ;
+
+: <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 url -- person )
+ <person>
+ swap >>the-id ;
SYMBOL: person1
SYMBOL: person2
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
{ "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"
{ "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 ;
: 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 ;
}
] [
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 )
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 -- )
[ make-retryable ] map
] [
retryable >>type
+ 10 >>retries
] if ;
: regenerate-params ( statement -- statement )
] 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 [
: ensure-table ( class -- )
[ create-table ] curry ignore-errors ;
+: ensure-tables ( classes -- )
+ [ ensure-table ] each ;
+
: insert-db-assigned-statement ( tuple -- )
dup class
db get db-insert-statements [ <insert-db-assigned-statement> ] cache
: 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 ;
: 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 ;
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
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs
-sequences arrays vectors definitions prettyprint combinators.lib
-math hashtables sets ;
+sequences arrays vectors definitions prettyprint
+math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
: consult-method ( word class quot -- )
[ drop swap first create-method ]
- [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
+ [
+ nip
+ [
+ over second saver %
+ %
+ dup second restorer %
+ first ,
+ ] [ ] make
+ ] 3bi
define ;
: change-word-prop ( word prop quot -- )
PROTOCOL: assoc-protocol
at* assoc-size >alist set-at assoc-clone-like
- { assoc-find 1 } delete-at clear-assoc new-assoc
- assoc-like ;
+ delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-partial stream-readln
-USING: kernel byte-arrays combinators strings arrays sequences splitting
+USING: kernel byte-arrays combinators strings arrays sequences splitting
+ grouping
math math.functions math.parser random
destructors
io io.binary io.sockets io.encodings.binary
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: >> neg shift ;
+: >> ( x n -- y ) neg shift ;
: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
get-double
}
2cleave message boa ;
+: ba->message ( ba -- message ) parse-message ;
+
+: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-receive-udp ( ba server -- ba )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 1&& <-&& ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
: query->answer/cache ( query -- rrs/NX/f )
-USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
+USING: kernel combinators sequences splitting math
+ io.files io.encodings.utf8 random newfx dns.util ;
IN: dns.misc
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: resolv-conf-servers ( -- seq )
"/etc/resolv.conf" utf8 file-lines
[ " " split ] map
[ 1st "nameserver" = ] filter
[ 2nd ] map ;
-: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
\ No newline at end of file
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: domain-has-name? ( domain name -- ? )
+ {
+ { [ 2dup = ] [ 2drop t ] }
+ { [ 2dup longer? ] [ 2drop f ] }
+ { [ t ] [ cdr-name domain-has-name? ] }
+ }
+ cond ;
+
+: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel combinators sequences sets math threads namespaces continuations
+ debugger io io.sockets unicode.case accessors destructors
+ combinators.cleave combinators.lib
+ newfx fry
+ dns dns.util dns.misc ;
+
+IN: dns.server
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: records-var
+
+: records ( -- records ) records-var get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- array )
+ { [ name>> >lower ] [ type>> ] [ class>> ] } <arr> ;
+
+: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
+: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
+
+: delegated-zones ( -- names ) zones my-zones diff ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->zone
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->zone ( name -- zone/f )
+ zones sort-largest-first [ name-in-domain? ] with find nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! extract-names
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->rdata-names ( rr -- names/f )
+ {
+ { [ dup type>> NS = ] [ rdata>> {1} ] }
+ { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
+ { [ dup type>> CNAME = ] [ rdata>> {1} ] }
+ { [ t ] [ drop f ] }
+ }
+ cond ;
+
+: extract-rdata-names ( message -- names )
+ [ answer-section>> ] [ authority-section>> ] bi append
+ [ rr->rdata-names ] map concat ;
+
+: extract-names ( message -- names )
+ [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-authority ( message -- message )
+ dup
+ extract-names [ name->authority ] map concat prune
+ over answer-section>> diff
+ >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-additional
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
+
+: fill-additional ( message -- message )
+ dup
+ extract-rdata-names [ name->rrs-a ] map concat prune
+ over answer-section>> diff
+ >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! query->rrs
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: query->rrs
+
+: matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
+
+: matching-cname? ( query -- rrs/f )
+ [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
+ [ empty? not ]
+ [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
+ [ 2drop f ]
+ 1if ;
+
+: query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! have-answers
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: have-answers ( message -- message/f )
+ dup message-query query->rrs
+ [ empty? ]
+ [ 2drop f ]
+ [ >>answer-section fill-authority fill-additional ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! have-delegates?
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
+
+: have-ns? ( name -- rrs/f )
+ NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
+
+: name->delegates ( name -- rrs-ns )
+ {
+ [ "" = { } and ]
+ [ is-soa? { } and ]
+ [ have-ns? ]
+ [ cdr-name name->delegates ]
+ }
+ 1|| ;
+
+: have-delegates ( message -- message/f )
+ dup message-query name>> name->delegates ! message rrs-ns
+ [ empty? ]
+ [ 2drop f ]
+ [
+ dup [ rdata>> A IN query boa matching-rrs ] map concat
+ ! message rrs-ns rrs-a
+ [ >>authority-section ]
+ [ >>additional-section ]
+ bi*
+ ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! outsize-zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: outside-zones ( message -- message/f )
+ dup message-query name>> name->zone f =
+ [ ]
+ [ drop f ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! is-nx
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: is-nx ( message -- message/f )
+ [ message-query name>> records [ name>> = ] with filter empty? ]
+ [
+ NAME-ERROR >>rcode
+ dup
+ message-query name>> name->zone SOA IN query boa matching-rrs
+ >>authority-section
+ ]
+ [ drop f ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: none-of-type ( message -- message )
+ dup
+ message-query name>> name->zone SOA IN query boa matching-rrs
+ >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+ {
+ [ have-answers ]
+ [ have-delegates ]
+ [ outside-zones ]
+ [ is-nx ]
+ [ none-of-type ]
+ }
+ 1|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (handle-request) ( packet -- )
+ [ [ find-answer ] with-message-bytes ] change-data respond ;
+
+: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
+
+: receive-loop ( socket -- )
+ [ receive-packet handle-request ] [ receive-loop ] bi ;
+
+: loop ( addr-spec -- )
+ [ <datagram> '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
+
--- /dev/null
+
+USING: kernel sequences sorting math math.order macros fry ;
+
+IN: dns.util
+
+: tri-chain ( obj p q r -- x y z )
+ >r >r call dup r> call dup r> call ; inline
+
+MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
+
+! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: io.sockets accessors ;
+
+TUPLE: packet data addr socket ;
+
+: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
+
+: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
+
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel math models namespaces sequences strings
-splitting combinators unicode.categories math.order ;
+USING: accessors arrays io kernel math models namespaces
+sequences strings splitting combinators unicode.categories
+math.order ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;
V{ "" } clone <model> V{ } clone
{ set-delegate set-document-locs } document construct ;
-: add-loc document-locs push ;
+: add-loc ( loc document -- ) locs>> push ;
-: remove-loc document-locs delete ;
+: remove-loc ( loc document -- ) locs>> delete ;
: update-locs ( loc document -- )
document-locs [ set-model ] with each ;
>r >r first2 swap r> doc-line r> call
r> =col ; inline
-: ((word-elt)) [ ?nth blank? ] 2keep ;
+: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
[ >r blank? r> xor ] curry ; inline
[ file>> path>> ] [ line>> ] bi edit-location
] when* ;
-: fix ( word -- )
- [ "Fixing " write pprint " and all usages..." print nl ]
- [ [ usage ] keep prefix ] bi
+: edit-each ( seq -- )
[
[ "Editing " write . ]
[
readln
] bi
] all? drop ;
+
+: fix ( word -- )
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ smart-usage ] keep prefix ] bi
+ edit-each ;
editors.vim editors.gvim.backend vocabs.loader ;
IN: editors.gvim
-TUPLE: gvim ;
+SINGLETON: gvim
M: gvim vim-command ( file line -- string )
- [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
+ [ gvim-path , swap , "+" swap number>string append , ] { } make ;
-t vim-detach set-global ! don't block the ui
-
-T{ gvim } vim-editor set-global
+gvim vim-editor set-global
{
{ [ os unix? ] [ "editors.gvim.unix" ] }
"USE: vim"
"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
}
-"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
-$nl
-"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ;
+"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;
IN: editors.vim
SYMBOL: vim-path
-SYMBOL: vim-detach
SYMBOL: vim-editor
-HOOK: vim-command vim-editor
+HOOK: vim-command vim-editor ( file line -- array )
-TUPLE: vim ;
+SINGLETON: vim
-M: vim vim-command ( file line -- array )
+M: vim vim-command
[
vim-path get , swap , "+" swap number>string append ,
] { } make ;
: vim-location ( file line -- )
- vim-command
- <process> swap >>command
- vim-detach get-global [ t >>detached ] when
- try-process ;
+ vim-command try-process ;
"vim" vim-path set-global
[ vim-location ] edit-hook set-global
-T{ vim } vim-editor set-global
+vim vim-editor set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: listener io.server strings parser byte-arrays ;
-IN: eval-server
-
-: eval-server ( -- )
- 9998 local-server "eval-server" [
- >string eval>string >byte-array
- ] with-datagrams ;
-
-MAIN: eval-server
+++ /dev/null
-Listens for UDP packets on localhost:9998, evaluates them and sends back result
+++ /dev/null
-demos
-network
-tools
-applications
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg
-sequences strings html.elements xml.entities xmode.code2html
-splitting io.streams.string peg.parsers
+USING: arrays io io.styles kernel memoize namespaces peg math
+combinators sequences strings html.elements xml.entities
+xmode.code2html splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
SYMBOL: relative-link-prefix
+SYMBOL: disable-images?
SYMBOL: link-no-follow?
<PRIVATE
</pre>
] with-string-writer ;
+: invalid-url "javascript:alert('Invalid URL in farkup');" ;
+
: check-url ( href -- href' )
- CHAR: : over member? [
- dup { "http://" "https://" "ftp://" } [ head? ] with contains?
- [ drop "/" ] unless
- ] [
- relative-link-prefix get prepend
- ] if ;
+ {
+ { [ dup empty? ] [ drop invalid-url ] }
+ { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
+ { [ dup first "/\\" member? ] [ drop invalid-url ] }
+ { [ CHAR: : over member? ] [
+ dup { "http://" "https://" "ftp://" } [ head? ] with contains?
+ [ drop invalid-url ] unless
+ ] }
+ [ relative-link-prefix get prepend ]
+ } cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
escape-link
[
"<a" ,
- " href=\"" , >r , r>
+ " href=\"" , >r , r> "\"" ,
link-no-follow? get [ " nofollow=\"true\"" , ] when
- "\">" , , "</a>" ,
+ ">" , , "</a>" ,
] { } make ;
: make-image-link ( href alt -- seq )
- escape-link
- [
- "<img src=\"" , swap , "\"" ,
- dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
- "/>" , ]
- { } make ;
+ disable-images? get [
+ 2drop "<strong>Images are not allowed</strong>"
+ ] [
+ escape-link
+ [
+ "<img src=\"" , swap , "\"" ,
+ dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+ "/>" ,
+ ] { } make
+ ] if ;
MEMO: image-link ( -- parser )
[
{ "face-size*" "size" }
{ "void*" "charmap" } ;
+C-STRUCT: FT_Bitmap
+ { "int" "rows" }
+ { "int" "width" }
+ { "int" "pitch" }
+ { "void*" "buffer" }
+ { "short" "num_grays" }
+ { "char" "pixel_mode" }
+ { "char" "palette_mode" }
+ { "void*" "palette" } ;
+
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;
FT_RENDER_MODE_LCD
FT_RENDER_MODE_LCD_V ;
+C-ENUM:
+ FT_PIXEL_MODE_NONE
+ FT_PIXEL_MODE_MONO
+ FT_PIXEL_MODE_GRAY
+ FT_PIXEL_MODE_GRAY2
+ FT_PIXEL_MODE_GRAY4
+ FT_PIXEL_MODE_LCD
+ FT_PIXEL_MODE_LCD_V ;
+
FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
FUNCTION: void FT_Done_Face ( face* face ) ;
FUNCTION: void FT_Done_FreeType ( void* library ) ;
FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;
+
QUALIFIED: namespaces
IN: fry
-: , "Only valid inside a fry" throw ;
-: @ "Only valid inside a fry" throw ;
-: _ "Only valid inside a fry" throw ;
+: , ( -- * ) "Only valid inside a fry" throw ;
+: @ ( -- * ) "Only valid inside a fry" throw ;
+: _ ( -- * ) "Only valid inside a fry" throw ;
DEFER: (shallow-fry)
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.encodings io.encodings.binary io.encodings.utf8 io.files
-io.server io.sockets kernel math.parser namespaces sequences
+io.sockets kernel math.parser namespaces sequences
ftp io.unix.launcher.parser unicode.case splitting assocs
-classes io.server destructors calendar io.timeouts
+classes io.servers.connection destructors calendar io.timeouts
io.streams.duplex threads continuations math
concurrency.promises byte-arrays ;
IN: ftp.server
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
-: handle-client ( -- )
+TUPLE: ftp-server < threaded-server ;
+
+M: ftp-server handle-client* ( server -- )
+ drop
[
"" [
host-name <ftp-client> client set
] with-directory
] with-destructors ;
+: <ftp-server> ( port -- server )
+ ftp-server new-threaded-server
+ swap >>insecure
+ "ftp.server" >>name
+ latin1 >>encoding ;
+
: ftpd ( port -- )
- internet-server "ftp.server"
- latin1 [ handle-client ] with-server ;
+ <ftp-server> start-server ;
: ftpd-main ( -- ) 2100 ftpd ;
init-request
{ } "action-1" get call-responder
] unit-test
+
+<action>
+ "a" >>rest
+ [ "a" param string>number sq ] >>display
+"action-2" set
+
+STRING: action-request-test-2
+GET http://foo/bar/123 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-2 lf>crlf
+ [ read-request ] with-string-reader
+ init-request
+ { "5" } "action-2" get call-responder
+] unit-test
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
validators http hashtables namespaces fry continuations locals\r
-io arrays math boxes\r
+io arrays math boxes splitting urls\r
xml.entities\r
http.server\r
http.server.responses\r
furnace\r
+furnace.flash\r
+html.forms\r
html.elements\r
html.components\r
+html.components\r
html.templates.chloe\r
html.templates.chloe.syntax ;\r
IN: furnace.actions\r
\r
SYMBOL: params\r
\r
-SYMBOL: rest-param\r
+SYMBOL: rest\r
\r
: render-validation-messages ( -- )\r
- validation-messages get\r
+ form get errors>>\r
dup empty? [ drop ] [\r
<ul "errors" =class ul>\r
- [ <li> message>> escape-string write </li> ] each\r
+ [ <li> escape-string write </li> ] each\r
</ul>\r
] if ;\r
\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
-TUPLE: action rest-param init display validate submit ;\r
+TUPLE: action rest authorize init display validate submit ;\r
\r
: new-action ( class -- action )\r
- new\r
- [ ] >>init\r
- [ <400> ] >>display\r
- [ ] >>validate\r
- [ <400> ] >>submit ;\r
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
\r
: <action> ( -- action )\r
action new-action ;\r
\r
+: set-nested-form ( form name -- )\r
+ dup empty? [\r
+ drop form set\r
+ ] [\r
+ dup length 1 = [\r
+ first set-value\r
+ ] [\r
+ unclip [ set-nested-form ] nest-form\r
+ ] if\r
+ ] if ;\r
+\r
+: restore-validation-errors ( -- )\r
+ form fget [\r
+ nested-forms fget set-nested-form\r
+ ] when* ;\r
+\r
: handle-get ( action -- response )\r
- blank-values\r
- [ init>> call ]\r
- [ display>> call ]\r
- bi ;\r
+ '[\r
+ , dup display>> [\r
+ {\r
+ [ init>> call ]\r
+ [ authorize>> call ]\r
+ [ drop restore-validation-errors ]\r
+ [ display>> call ]\r
+ } cleave\r
+ ] [ drop <400> ] if\r
+ ] with-exit-continuation ;\r
+\r
+: param ( name -- value )\r
+ params get at ;\r
+\r
+: revalidate-url-key "__u" ;\r
+\r
+: revalidate-url ( -- url/f )\r
+ revalidate-url-key param\r
+ dup [ >url [ same-host? ] keep and ] when ;\r
\r
: validation-failed ( -- * )\r
- request get method>> "POST" =\r
- [ action get display>> call ] [ <400> ] if exit-with ;\r
+ post-request? revalidate-url and\r
+ [\r
+ nested-forms-key param " " split harvest nested-forms set\r
+ { form nested-forms } <flash-redirect>\r
+ ] [ <400> ] if*\r
+ exit-with ;\r
\r
: handle-post ( action -- response )\r
- init-validation\r
- blank-values\r
- [ validate>> call ]\r
- [ submit>> call ] bi ;\r
-\r
-: handle-rest-param ( arg -- )\r
- dup length 1 > action get rest-param>> not or\r
- [ <404> exit-with ] [\r
- action get rest-param>> associate rest-param set\r
- ] if ;\r
-\r
-M: action call-responder* ( path action -- response )\r
- dup action set\r
'[\r
- , dup empty? [ drop ] [ handle-rest-param ] if\r
-\r
- init-validation\r
- ,\r
- request get\r
- [ request-params rest-param get assoc-union params set ]\r
- [ method>> ] bi\r
- {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
+ , dup submit>> [\r
+ [ validate>> call ]\r
+ [ authorize>> call ]\r
+ [ submit>> call ]\r
+ tri\r
+ ] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: param ( name -- value )\r
- params get at ;\r
+: handle-rest ( path action -- assoc )\r
+ rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
+\r
+: init-action ( path action -- )\r
+ begin-form\r
+ handle-rest\r
+ request get request-params assoc-union params set ;\r
+\r
+M: action call-responder* ( path action -- response )\r
+ [ init-action ] keep\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case ;\r
+\r
+M: action modify-form\r
+ drop request get url>> revalidate-url-key hidden-form-field ;\r
\r
: check-validation ( -- )\r
validation-failed? [ validation-failed ] when ;\r
\r
: validate-params ( validators -- )\r
- params get swap validate-values from-object\r
- check-validation ;\r
+ params get swap validate-values check-validation ;\r
\r
: validate-integer-id ( -- )\r
{ { "id" [ v-number ] } } validate-params ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences db.tuples alarms calendar db fry
+furnace.cache
+furnace.asides
+furnace.flash
+furnace.sessions
+furnace.referrer
+furnace.db
+furnace.auth.providers
+furnace.auth.login.permits ;
+IN: furnace.alloy
+
+: <alloy> ( responder db params -- responder' )
+ '[
+ <asides>
+ <flash-scopes>
+ <sessions>
+ , , <db-persistence>
+ <check-form-submissions>
+ ] call ;
+
+: state-classes { session flash-scope aside permit } ; inline
+
+: init-furnace-tables ( -- )
+ state-classes ensure-tables
+ user ensure-table ;
+
+: start-expiring ( db params -- )
+ '[
+ , , [ state-classes [ expire-state ] each ] with-db
+ ] 5 minutes every drop ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces sequences arrays kernel
+assocs assocs.lib hashtables math.parser urls combinators
+html.elements html.templates.chloe.syntax db.types db.tuples
+http http.server http.server.filters
+furnace furnace.cache furnace.sessions furnace.redirection ;
+IN: furnace.asides
+
+TUPLE: aside < server-state session method url post-data ;
+
+: <aside> ( id -- aside )
+ aside new-server-state ;
+
+aside "ASIDES"
+{
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "method" "METHOD" { VARCHAR 10 } +not-null+ }
+ { "url" "URL" URL +not-null+ }
+ { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+ asides new-server-state-manager ;
+
+: begin-aside* ( -- id )
+ f <aside>
+ session get id>> >>session
+ request get
+ [ method>> >>method ]
+ [ url>> >>url ]
+ [ post-data>> >>post-data ]
+ tri
+ [ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
+
+: end-aside-post ( aside -- response )
+ request [
+ clone
+ over post-data>> >>post-data
+ over url>> >>url
+ ] change
+ url>> path>> split-path
+ asides get responder>> call-responder ;
+
+ERROR: end-aside-in-get-error ;
+
+: get-aside ( id -- aside )
+ dup [ aside get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
+: end-aside* ( url id -- response )
+ post-request? [ end-aside-in-get-error ] unless
+ aside get-state [
+ dup method>> {
+ { "GET" [ url>> <redirect> ] }
+ { "HEAD" [ url>> <redirect> ] }
+ { "POST" [ end-aside-post ] }
+ } case
+ ] [ <redirect> ] ?if ;
+
+SYMBOL: aside-id
+
+: aside-id-key "__a" ;
+
+: begin-aside ( -- )
+ begin-aside* aside-id set ;
+
+: end-aside ( default -- response )
+ aside-id [ f ] change end-aside* ;
+
+: request-aside-id ( request -- aside-id )
+ aside-id-key swap request-params at string>number ;
+
+M: asides call-responder*
+ dup asides set
+ request get request-aside-id aside-id set
+ call-next-method ;
+
+M: asides link-attr ( tag -- )
+ drop
+ "aside" optional-attr {
+ { "none" [ aside-id off ] }
+ { "begin" [ begin-aside ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+M: asides modify-query ( query responder -- query' )
+ drop
+ aside-id get [ aside-id-key associate assoc-union ] when* ;
+
+M: asides modify-form ( responder -- )
+ drop aside-id get aside-id-key hidden-form-field ;
--- /dev/null
+USING: furnace.auth tools.test ;
+IN: furnace.auth.tests
+
+\ logged-in-username must-infer
+\ <protected> must-infer
+\ new-realm must-infer
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs namespaces kernel sequences sets\r
+destructors combinators fry\r
+io.encodings.utf8 io.encodings.string io.binary random\r
+checksums checksums.sha2\r
+html.forms\r
http.server\r
http.server.filters\r
http.server.dispatchers\r
-furnace.sessions\r
-furnace.auth.providers ;\r
+furnace\r
+furnace.actions\r
+furnace.redirection\r
+furnace.boilerplate\r
+furnace.auth.providers\r
+furnace.auth.providers.db ;\r
IN: furnace.auth\r
\r
SYMBOL: logged-in-user\r
\r
+: logged-in? ( -- ? ) logged-in-user get >boolean ;\r
+\r
GENERIC: init-user-profile ( responder -- )\r
\r
M: object init-user-profile drop ;\r
M: filter-responder init-user-profile\r
responder>> init-user-profile ;\r
\r
+: have-capability? ( capability -- ? )\r
+ logged-in-user get capabilities>> member? ;\r
+\r
: profile ( -- assoc ) logged-in-user get profile>> ;\r
\r
: user-changed ( -- )\r
V{ } clone capabilities set-global\r
\r
: define-capability ( word -- ) capabilities get adjoin ;\r
+\r
+TUPLE: realm < dispatcher name users checksum secure ;\r
+\r
+GENERIC: login-required* ( realm -- response )\r
+\r
+GENERIC: logged-in-username ( realm -- username )\r
+\r
+: login-required ( -- * ) realm get login-required* exit-with ;\r
+\r
+: new-realm ( responder name class -- realm )\r
+ new-dispatcher\r
+ swap >>name\r
+ swap >>default\r
+ users-in-db >>users\r
+ sha-256 >>checksum\r
+ t >>secure ; inline\r
+\r
+: users ( -- provider )\r
+ realm get users>> ;\r
+\r
+TUPLE: user-saver user ;\r
+\r
+C: <user-saver> user-saver\r
+\r
+M: user-saver dispose\r
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
+\r
+: save-user-after ( user -- )\r
+ <user-saver> &dispose drop ;\r
+\r
+: init-user ( user -- )\r
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;\r
+\r
+M: realm call-responder* ( path responder -- response )\r
+ dup realm set\r
+ dup logged-in-username dup [ users get-user ] when init-user\r
+ call-next-method ;\r
+\r
+: encode-password ( string salt -- bytes )\r
+ [ utf8 encode ] [ 4 >be ] bi* append\r
+ realm get checksum>> checksum-bytes ;\r
+\r
+: >>encoded-password ( user string -- user )\r
+ 32 random-bits [ encode-password ] keep\r
+ [ >>password ] [ >>salt ] bi* ; inline\r
+\r
+: valid-login? ( password user -- ? )\r
+ [ salt>> encode-password ] [ password>> ] bi = ;\r
+\r
+: check-login ( password username -- user/f )\r
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
+\r
+: if-secure-realm ( quot -- )\r
+ realm get secure>> [ if-secure ] [ call ] if ; inline\r
+\r
+TUPLE: secure-realm-only < filter-responder ;\r
+\r
+C: <secure-realm-only> secure-realm-only\r
+\r
+M: secure-realm-only call-responder*\r
+ '[ , , call-next-method ] if-secure-realm ;\r
+\r
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
+\r
+: check-capabilities ( responder user/f -- ? )\r
+ {\r
+ { [ dup not ] [ 2drop f ] }\r
+ { [ dup deleted>> 1 = ] [ 2drop f ] }\r
+ [ [ capabilities>> ] bi@ subset? ]\r
+ } cond ;\r
+\r
+M: protected call-responder* ( path responder -- response )\r
+ '[\r
+ , ,\r
+ dup protected set\r
+ dup logged-in-user get check-capabilities\r
+ [ call-next-method ] [ 2drop realm get login-required* ] if\r
+ ] if-secure-realm ;\r
+\r
+: <auth-boilerplate> ( responder -- responder' )\r
+ <boilerplate> { realm "boilerplate" } >>template ;\r
+\r
+: password-mismatch ( -- * )\r
+ "passwords do not match" validation-error\r
+ validation-failed ;\r
+\r
+: same-password-twice ( -- )\r
+ "new-password" value "verify-password" value =\r
+ [ password-mismatch ] unless ;\r
+\r
+: user-exists ( -- * )\r
+ "username taken" validation-error\r
+ validation-failed ;\r
! Copyright (c) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-base64 html.elements io combinators sequences\r
-http http.server.filters http.server.responses http.server\r
-furnace.auth.providers furnace.auth.login ;\r
+USING: accessors kernel splitting base64 namespaces strings\r
+http http.server.responses furnace.auth ;\r
IN: furnace.auth.basic\r
\r
-TUPLE: basic-auth < filter-responder realm provider ;\r
+TUPLE: basic-auth-realm < realm ;\r
\r
-C: <basic-auth> basic-auth\r
+: <basic-auth-realm> ( responder name -- realm )\r
+ basic-auth-realm new-realm ;\r
\r
-: authorization-ok? ( provider header -- ? )\r
- #! Given the realm and the 'Authorization' header,\r
- #! authenticate the user.\r
+: parse-basic-auth ( header -- username/f password/f )\r
dup [\r
" " split1 swap "Basic" = [\r
- base64> ":" split1 spin check-login\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- 2drop f\r
- ] if ;\r
+ base64> >string ":" split1\r
+ ] [ drop f f ] if\r
+ ] [ drop f f ] if ;\r
\r
: <401> ( realm -- response )\r
- 401 "Unauthorized" <trivial-response>\r
- "Basic realm=\"" rot "\"" 3append\r
- "WWW-Authenticate" set-header\r
- [\r
- <html> <body>\r
- "Username or Password is invalid" write\r
- </body> </html>\r
- ] >>body ;\r
+ 401 "Invalid username or password" <trivial-response>\r
+ [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;\r
\r
-: logged-in? ( request responder -- ? )\r
- provider>> swap "authorization" header authorization-ok? ;\r
+M: basic-auth-realm login-required* ( realm -- response )\r
+ name>> <401> ;\r
\r
-M: basic-auth call-responder* ( request path responder -- response )\r
- pick over logged-in?\r
- [ call-next-method ] [ 2nip realm>> <401> ] if ;\r
+M: basic-auth-realm logged-in-username ( realm -- uid )\r
+ drop\r
+ request get "authorization" header parse-basic-auth\r
+ dup [ over check-login swap and ] [ 2drop f ] if ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs namespaces accessors db db.tuples urls
+http.server.dispatchers
+furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
+IN: furnace.auth.features.deactivate-user
+
+: <deactivate-user-action> ( -- action )
+ <action>
+ [
+ logged-in-user get
+ 1 >>deleted
+ t >>changed?
+ drop
+ URL" $realm" end-aside
+ ] >>submit ;
+
+: allow-deactivation ( realm -- realm )
+ <deactivate-user-action> <protected>
+ "delete your profile" >>description
+ "deactivate-user" add-responder ;
+
+: allow-deactivation? ( -- ? )
+ realm get responders>> "deactivate-user" swap key? ;
--- /dev/null
+IN: furnace.auth.features.edit-profile.tests
+USING: tools.test furnace.auth.features.edit-profile ;
+
+\ allow-edit-profile must-infer
--- /dev/null
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences assocs
+validators urls
+html.forms
+http.server.dispatchers
+furnace.auth
+furnace.asides
+furnace.actions ;
+IN: furnace.auth.features.edit-profile
+
+: <edit-profile-action> ( -- action )
+ <page-action>
+ [
+ logged-in-user get
+ [ username>> "username" set-value ]
+ [ realname>> "realname" set-value ]
+ [ email>> "email" set-value ]
+ tri
+ ] >>init
+
+ { realm "features/edit-profile/edit-profile" } >>template
+
+ [
+ logged-in-user get username>> "username" set-value
+
+ {
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "password" [ ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params
+
+ { "password" "new-password" "verify-password" }
+ [ value empty? not ] contains? [
+ "password" value logged-in-user get username>> check-login
+ [ "incorrect password" validation-error ] unless
+
+ same-password-twice
+ ] when
+ ] >>validate
+
+ [
+ logged-in-user get
+
+ "new-password" value dup empty?
+ [ drop ] [ >>encoded-password ] if
+
+ "realname" value >>realname
+ "email" value >>email
+
+ t >>changed?
+
+ drop
+
+ URL" $login" end-aside
+ ] >>submit
+
+ <protected>
+ "edit your profile" >>description ;
+
+: allow-edit-profile ( login -- login )
+ <edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
+
+: allow-edit-profile? ( -- ? )
+ realm get responders>> "edit-profile" swap key? ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form t:action="$realm/edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:label t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:password t:name="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+ <t:if t:code="furnace.auth.features.deactivate-user:allow-deactivation?">
+ <t:button t:action="$realm/deactivate-user">Delete User</t:button>
+ </t:if>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
+
+ <t:form t:action="$realm/recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form t:action="$realm/recover-3">
+
+ <table>
+
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a t:href="$realm">proceed</t:a>.</p>\r
+\r
+</t:chloe>\r
--- /dev/null
+IN: furnace.auth.features.recover-password
+USING: tools.test furnace.auth.features.recover-password ;
+
+\ allow-password-recovery must-infer
--- /dev/null
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors kernel assocs arrays io.sockets threads
+fry urls smtp validators html.forms present
+http http.server.responses http.server.redirection
+http.server.dispatchers
+furnace furnace.actions furnace.auth furnace.auth.providers
+furnace.redirection ;
+IN: furnace.auth.features.recover-password
+
+SYMBOL: lost-password-from
+
+: current-host ( -- string )
+ request get url>> host>> host-name or ;
+
+: new-password-url ( user -- url )
+ URL" recover-3" clone
+ swap
+ [ username>> "username" set-query-param ]
+ [ ticket>> "ticket" set-query-param ]
+ bi
+ adjust-url relative-to-request ;
+
+: password-email ( user -- email )
+ <email>
+ [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
+ lost-password-from get >>from
+ over email>> 1array >>to
+ [
+ "This e-mail was sent by the application server on " % current-host % "\n" %
+ "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
+ "login form, and requested a new password for the user named ``" %
+ over username>> % "''.\n" %
+ "\n" %
+ "If you believe that this request was legitimate, you may click the below link in\n" %
+ "your browser to set a new password for your account:\n" %
+ "\n" %
+ swap new-password-url present %
+ "\n\n" %
+ "Love,\n" %
+ "\n" %
+ " FactorBot\n" %
+ ] "" make >>body ;
+
+: send-password-email ( user -- )
+ '[ , password-email send-email ]
+ "E-mail send thread" spawn drop ;
+
+: <recover-action-1> ( -- action )
+ <page-action>
+ { realm "features/recover-password/recover-1" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "email" [ v-email ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+ ] >>validate
+
+ [
+ "email" value "username" value
+ users issue-ticket [
+ send-password-email
+ ] when*
+
+ URL" $realm/recover-2" <redirect>
+ ] >>submit ;
+
+: <recover-action-2> ( -- action )
+ <page-action>
+ { realm "features/recover-password/recover-2" } >>template ;
+
+: <recover-action-3> ( -- action )
+ <page-action>
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ } validate-params
+ ] >>init
+
+ { realm "features/recover-password/recover-3" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ } validate-params
+
+ same-password-twice
+ ] >>validate
+
+ [
+ "ticket" value
+ "username" value
+ users claim-ticket [
+ "new-password" value >>encoded-password
+ users update-user
+
+ URL" $realm/recover-4" <redirect>
+ ] [
+ <403>
+ ] if*
+ ] >>submit ;
+
+: <recover-action-4> ( -- action )
+ <page-action>
+ { realm "features/recover-password/recover-4" } >>template ;
+
+: allow-password-recovery ( login -- login )
+ <recover-action-1> <auth-boilerplate>
+ "recover-password" add-responder
+ <recover-action-2> <auth-boilerplate>
+ "recover-2" add-responder
+ <recover-action-3> <auth-boilerplate>
+ "recover-3" add-responder
+ <recover-action-4> <auth-boilerplate>
+ "recover-4" add-responder ;
+
+: allow-password-recovery? ( -- ? )
+ realm get responders>> "recover-password" swap key? ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form t:action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+ <t:validation-messages />
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+IN: furnace.auth.features.registration.tests
+USING: tools.test furnace.auth.features.registration ;
+
+\ allow-registration must-infer
--- /dev/null
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces validators html.forms urls
+http.server.dispatchers
+furnace furnace.auth furnace.auth.providers furnace.actions
+furnace.redirection ;
+IN: furnace.auth.features.registration
+
+: <register-action> ( -- action )
+ <page-action>
+ { realm "features/registration/register" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+
+ same-password-twice
+ ] >>validate
+
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "new-password" value >>encoded-password
+ "email" value >>email
+ H{ } clone >>profile
+
+ users new-user [ user-exists ] unless*
+
+ realm get init-user-profile
+
+ URL" $realm" <redirect>
+ ] >>submit
+ <auth-boilerplate> ;
+
+: allow-registration ( login -- login )
+ <register-action> "register" add-responder ;
+
+: allow-registration? ( -- ? )
+ realm get responders>> "register" swap key? ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Edit Profile</t:title>
-
- <t:form t:action="$login/edit-profile">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:label t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Current password:</th>
- <td><t:password t:name="password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you don't want to change your current password, leave this field blank.</td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you are changing your password, enter it twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Update" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
IN: furnace.auth.login.tests\r
USING: tools.test furnace.auth.login ;\r
\r
-\ <login> must-infer\r
-\ allow-registration must-infer\r
-\ allow-password-recovery must-infer\r
+\ <login-realm> must-infer\r
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-combinators sequences namespaces hashtables sets\r
-fry arrays threads qualified random validators\r
-io\r
-io.sockets\r
-io.encodings.utf8\r
-io.encodings.string\r
-io.binary\r
-continuations\r
-destructors\r
-checksums\r
-checksums.sha2\r
-validators\r
-html.components\r
-html.elements\r
-urls\r
-http\r
-http.server\r
-http.server.dispatchers\r
-http.server.filters\r
-http.server.responses\r
+USING: kernel accessors namespaces sequences math.parser\r
+calendar validators urls html.forms\r
+http http.server http.server.dispatchers\r
furnace\r
furnace.auth\r
-furnace.auth.providers\r
-furnace.auth.providers.db\r
+furnace.flash\r
+furnace.asides\r
furnace.actions\r
-furnace.flows\r
furnace.sessions\r
-furnace.boilerplate ;\r
-QUALIFIED: smtp\r
+furnace.utilities\r
+furnace.redirection\r
+furnace.auth.login.permits ;\r
IN: furnace.auth.login\r
\r
-TUPLE: login < dispatcher users checksum ;\r
+SYMBOL: permit-id\r
\r
-: users ( -- provider )\r
- login get users>> ;\r
+: permit-id-key ( realm -- string )\r
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat\r
+ "__p_" prepend ;\r
\r
-: encode-password ( string salt -- bytes )\r
- [ utf8 encode ] [ 4 >be ] bi* append\r
- login get checksum>> checksum-bytes ;\r
+: client-permit-id ( realm -- id/f )\r
+ permit-id-key client-state dup [ string>number ] when ;\r
\r
-: >>encoded-password ( user string -- user )\r
- 32 random-bits [ encode-password ] keep\r
- [ >>password ] [ >>salt ] bi* ; inline\r
+TUPLE: login-realm < realm timeout domain ;\r
\r
-: valid-login? ( password user -- ? )\r
- [ salt>> encode-password ] [ password>> ] bi = ;\r
+M: login-realm call-responder*\r
+ [ name>> client-permit-id permit-id set ]\r
+ [ call-next-method ]\r
+ bi ;\r
\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
+M: login-realm logged-in-username\r
+ drop permit-id get dup [ get-permit-uid ] when ;\r
\r
-! Destructor\r
-TUPLE: user-saver user ;\r
+M: login-realm modify-form ( responder -- )\r
+ drop permit-id get realm get name>> permit-id-key hidden-form-field ;\r
\r
-C: <user-saver> user-saver\r
+: <permit-cookie> ( -- cookie )\r
+ permit-id get realm get name>> permit-id-key <cookie>\r
+ "$login-realm" resolve-base-path >>path\r
+ realm get\r
+ [ timeout>> from-now >>expires ]\r
+ [ domain>> >>domain ]\r
+ [ secure>> >>secure ]\r
+ tri ;\r
\r
-M: user-saver dispose\r
- user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
+: put-permit-cookie ( response -- response' )\r
+ <permit-cookie> put-cookie ;\r
\r
-: save-user-after ( user -- )\r
- <user-saver> &dispose drop ;\r
-\r
-! ! ! Login\r
: successful-login ( user -- response )\r
- username>> set-uid URL" $login" end-flow ;\r
+ [ username>> make-permit permit-id set ] [ init-user ] bi\r
+ URL" $realm" end-aside\r
+ put-permit-cookie ;\r
+\r
+: logout ( -- )\r
+ permit-id get [ delete-permit ] when*\r
+ URL" $realm" end-aside ;\r
+\r
+SYMBOL: description\r
+SYMBOL: capabilities\r
+\r
+: flashed-variables { description capabilities } ;\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
\r
: <login-action> ( -- action )\r
<page-action>\r
- { login "login" } >>template\r
+ [\r
+ flashed-variables restore-flash\r
+ description get "description" set-value\r
+ capabilities get words>strings "capabilities" set-value\r
+ ] >>init\r
+\r
+ { login-realm "login" } >>template\r
\r
[\r
{\r
"password" value\r
"username" value check-login\r
[ successful-login ] [ login-failed ] if*\r
- ] >>submit ;\r
-\r
-! ! ! New user registration\r
-\r
-: user-exists ( -- * )\r
- "username taken" validation-error\r
- validation-failed ;\r
-\r
-: password-mismatch ( -- * )\r
- "passwords do not match" validation-error\r
- validation-failed ;\r
-\r
-: same-password-twice ( -- )\r
- "new-password" value "verify-password" value =\r
- [ password-mismatch ] unless ;\r
-\r
-: <register-action> ( -- action )\r
- <page-action>\r
- { login "register" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- { "email" [ [ v-email ] v-optional ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "username" value <user>\r
- "realname" value >>realname\r
- "new-password" value >>encoded-password\r
- "email" value >>email\r
- H{ } clone >>profile\r
-\r
- users new-user [ user-exists ] unless*\r
-\r
- login get init-user-profile\r
-\r
- successful-login\r
- ] >>submit ;\r
-\r
-! ! ! Editing user profile\r
-\r
-: <edit-profile-action> ( -- action )\r
- <page-action>\r
- [\r
- logged-in-user get\r
- [ username>> "username" set-value ]\r
- [ realname>> "realname" set-value ]\r
- [ email>> "email" set-value ]\r
- tri\r
- ] >>init\r
-\r
- { login "edit-profile" } >>template\r
-\r
- [\r
- uid "username" set-value\r
-\r
- {\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "password" [ ] }\r
- { "new-password" [ [ v-password ] v-optional ] }\r
- { "verify-password" [ [ v-password ] v-optional ] } \r
- { "email" [ [ v-email ] v-optional ] }\r
- } validate-params\r
-\r
- { "password" "new-password" "verify-password" }\r
- [ value empty? not ] contains? [\r
- "password" value uid check-login\r
- [ "incorrect password" validation-error ] unless\r
-\r
- same-password-twice\r
- ] when\r
- ] >>validate\r
-\r
- [\r
- logged-in-user get\r
-\r
- "new-password" value dup empty?\r
- [ drop ] [ >>encoded-password ] if\r
-\r
- "realname" value >>realname\r
- "email" value >>email\r
-\r
- t >>changed?\r
-\r
- drop\r
-\r
- URL" $login" end-flow\r
- ] >>submit ;\r
-\r
-! ! ! Password recovery\r
-\r
-SYMBOL: lost-password-from\r
-\r
-: current-host ( -- string )\r
- request get url>> host>> host-name or ;\r
-\r
-: new-password-url ( user -- url )\r
- "recover-3"\r
- swap [\r
- [ username>> "username" set ]\r
- [ ticket>> "ticket" set ]\r
- bi\r
- ] H{ } make-assoc\r
- derive-url ;\r
+ ] >>submit\r
+ <auth-boilerplate>\r
+ <secure-realm-only> ;\r
\r
-: password-email ( user -- email )\r
- smtp:<email>\r
- [ "[ " % current-host % " ] password recovery" % ] "" make >>subject\r
- lost-password-from get >>from\r
- over email>> 1array >>to\r
- [\r
- "This e-mail was sent by the application server on " % current-host % "\n" %\r
- "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %\r
- "login form, and requested a new password for the user named ``" %\r
- over username>> % "''.\n" %\r
- "\n" %\r
- "If you believe that this request was legitimate, you may click the below link in\n" %\r
- "your browser to set a new password for your account:\n" %\r
- "\n" %\r
- swap new-password-url %\r
- "\n\n" %\r
- "Love,\n" %\r
- "\n" %\r
- " FactorBot\n" %\r
- ] "" make >>body ;\r
-\r
-: send-password-email ( user -- )\r
- '[ , password-email smtp:send-email ]\r
- "E-mail send thread" spawn drop ;\r
-\r
-: <recover-action-1> ( -- action )\r
- <page-action>\r
- { login "recover-1" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "email" [ v-email ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
- ] >>validate\r
-\r
- [\r
- "email" value "username" value\r
- users issue-ticket [\r
- send-password-email\r
- ] when*\r
-\r
- URL" $login/recover-2" <redirect>\r
- ] >>submit ;\r
-\r
-: <recover-action-2> ( -- action )\r
- <page-action>\r
- { login "recover-2" } >>template ;\r
-\r
-: <recover-action-3> ( -- action )\r
- <page-action>\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- } validate-params\r
- ] >>init\r
-\r
- { login "recover-3" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "ticket" value\r
- "username" value\r
- users claim-ticket [\r
- "new-password" value >>encoded-password\r
- users update-user\r
-\r
- URL" $login/recover-4" <redirect>\r
- ] [\r
- <403>\r
- ] if*\r
- ] >>submit ;\r
-\r
-: <recover-action-4> ( -- action )\r
- <page-action>\r
- { login "recover-4" } >>template ;\r
-\r
-! ! ! Logout\r
: <logout-action> ( -- action )\r
<action>\r
- [\r
- f set-uid\r
- URL" $login" end-flow\r
- ] >>submit ;\r
-\r
-! ! ! Authentication logic\r
-\r
-TUPLE: protected < filter-responder capabilities ;\r
-\r
-C: <protected> protected\r
-\r
-: show-login-page ( -- response )\r
- begin-flow\r
- URL" $login/login" <redirect> ;\r
-\r
-: check-capabilities ( responder user -- ? )\r
- [ capabilities>> ] bi@ subset? ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- uid dup [\r
- users get-user 2dup check-capabilities [\r
- [ logged-in-user set ] [ save-user-after ] bi\r
- call-next-method\r
- ] [\r
- 3drop show-login-page\r
- ] if\r
- ] [\r
- 3drop show-login-page\r
- ] if ;\r
-\r
-M: login call-responder* ( path responder -- response )\r
- dup login set\r
- call-next-method ;\r
-\r
-: <login-boilerplate> ( responder -- responder' )\r
- <boilerplate>\r
- { login "boilerplate" } >>template ;\r
-\r
-: <login> ( responder -- auth )\r
- login new-dispatcher\r
- swap >>default\r
- <login-action> <login-boilerplate> "login" add-responder\r
- <logout-action> <login-boilerplate> "logout" add-responder\r
- users-in-db >>users\r
- sha-256 >>checksum ;\r
-\r
-! ! ! Configuration\r
-\r
-: allow-edit-profile ( login -- login )\r
- <edit-profile-action> f <protected> <login-boilerplate>\r
- "edit-profile" add-responder ;\r
-\r
-: allow-registration ( login -- login )\r
- <register-action> <login-boilerplate>\r
- "register" add-responder ;\r
-\r
-: allow-password-recovery ( login -- login )\r
- <recover-action-1> <login-boilerplate>\r
- "recover-password" add-responder\r
- <recover-action-2> <login-boilerplate>\r
- "recover-2" add-responder\r
- <recover-action-3> <login-boilerplate>\r
- "recover-3" add-responder\r
- <recover-action-4> <login-boilerplate>\r
- "recover-4" add-responder ;\r
-\r
-: allow-edit-profile? ( -- ? )\r
- login get responders>> "edit-profile" swap key? ;\r
-\r
-: allow-registration? ( -- ? )\r
- login get responders>> "register" swap key? ;\r
-\r
-: allow-password-recovery? ( -- ? )\r
- login get responders>> "recover-password" swap key? ;\r
+ [ logout ] >>submit\r
+ <protected>\r
+ "logout" >>description ;\r
+\r
+M: login-realm login-required*\r
+ drop\r
+ begin-aside\r
+ protected get description>> description set\r
+ protected get capabilities>> capabilities set\r
+ URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;\r
+\r
+: <login-realm> ( responder name -- auth )\r
+ login-realm new-realm\r
+ <login-action> "login" add-responder\r
+ <logout-action> "logout" add-responder\r
+ 20 minutes >>timeout ;\r
<t:title>Login</t:title>
+ <t:if t:value="description">
+ <p>You must log in to <t:label t:name="description" />.</p>
+ </t:if>
+
+ <t:if t:value="capabilities">
+ <p>Your user must have the following capabilities:</p>
+ <ul>
+ <t:each t:name="capabilities">
+ <li><t:label t:name="value" /></li>
+ </t:each>
+ </ul>
+ </t:if>
+
<t:form t:action="login">
<table>
</t:form>
<p>
- <t:if t:code="furnace.auth.login:allow-registration?">
+ <t:if t:code="furnace.auth.features.registration:allow-registration?">
<t:a t:href="register">Register</t:a>
</t:if>
|
- <t:if t:code="furnace.auth.login:allow-password-recovery?">
+ <t:if t:code="furnace.auth.features.recover-password:allow-password-recovery?">
<t:a t:href="recover-password">Recover Password</t:a>
</t:if>
</p>
--- /dev/null
+USING: accessors namespaces combinators.lib kernel
+db.tuples db.types
+furnace.auth furnace.sessions furnace.cache ;
+IN: furnace.auth.login.permits
+
+TUPLE: permit < server-state session uid ;
+
+permit "PERMITS" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "uid" "UID" { VARCHAR 255 } +not-null+ }
+} define-persistent
+
+: touch-permit ( permit -- )
+ realm get touch-state ;
+
+: get-permit-uid ( id -- uid )
+ permit get-state {
+ [ ]
+ [ session>> session get id>> = ]
+ [ [ touch-permit ] [ uid>> ] bi ]
+ } 1&& ;
+
+: make-permit ( uid -- id )
+ permit new
+ swap >>uid
+ session get id>> >>session
+ [ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
+
+: delete-permit ( id -- )
+ permit new-server-state delete-tuples ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 1 of 4</t:title>
-
- <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
-
- <t:form t:action="recover-password">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
- </tr>
-
- </table>
-
- <input type="submit" value="Recover password" />
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 2 of 4</t:title>
-
- <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 3 of 4</t:title>
-
- <p>Choose a new password for your account.</p>
-
- <t:form t:action="new-password">
-
- <table>
-
- <t:hidden t:name="username" />
- <t:hidden t:name="ticket" />
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify password:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Set password" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>\r
-\r
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
-\r
- <t:title>Recover lost password: step 4 of 4</t:title>\r
-\r
- <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>\r
-\r
-</t:chloe>\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New User Registration</t:title>
-
- <t:form t:action="register">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
-
- </table>
-
- <p>
-
- <input type="submit" value="Register" />
- <t:validation-messages />
-
- </p>
-
- </t:form>
-
-</t:chloe>
IN: furnace.auth.providers.assoc.tests\r
-USING: furnace.actions furnace.auth.providers \r
+USING: furnace.actions furnace.auth furnace.auth.providers \r
furnace.auth.providers.assoc furnace.auth.login\r
tools.test namespaces accessors kernel ;\r
\r
-<action> <login>\r
+<action> "Test" <login-realm>\r
<users-in-memory> >>users\r
-login set\r
+realm set\r
\r
[ t ] [\r
"slava" <user>\r
IN: furnace.auth.providers.db.tests\r
USING: furnace.actions\r
+furnace.auth\r
furnace.auth.login\r
furnace.auth.providers\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
io.files accessors kernel ;\r
\r
-<action> <login>\r
- users-in-db >>users\r
-login set\r
+<action> "test" <login-realm> realm set\r
\r
[ "auth-test.db" temp-file delete-file ] ignore-errors\r
\r
"auth-test.db" temp-file sqlite-db [\r
\r
- init-users-table\r
+ user ensure-table\r
\r
[ t ] [\r
"slava" <user>\r
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
-: init-users-table user ensure-table ;
-
SINGLETON: users-in-db
M: users-in-db get-user
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces
-html.templates html.templates.chloe
+USING: accessors kernel math.order namespaces combinators.lib
+html.forms
+html.templates
+html.templates.chloe
locals
http.server
http.server.filters
furnace ;
IN: furnace.boilerplate
-TUPLE: boilerplate < filter-responder template ;
+TUPLE: boilerplate < filter-responder template init ;
-: <boilerplate> f boilerplate boa ;
+: <boilerplate> ( responder -- boilerplate )
+ boilerplate new
+ swap >>responder
+ [ ] >>init ;
+
+: wrap-boilerplate? ( response -- ? )
+ {
+ [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
+ [ content-type>> "text/html" = ]
+ } 1&& ;
M:: boilerplate call-responder* ( path responder -- )
+ begin-form
path responder call-next-method
+ responder init>> call
dup content-type>> "text/html" = [
clone [| body |
[
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math.intervals
+calendar alarms fry
+random db db.tuples db.types
+http.server.filters ;
+IN: furnace.cache
+
+TUPLE: server-state id expires ;
+
+: new-server-state ( id class -- server-state )
+ new swap >>id ; inline
+
+server-state f
+{
+ { "id" "ID" +random-id+ system-random-generator }
+ { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+} define-persistent
+
+: get-state ( id class -- state )
+ new-server-state select-tuple ;
+
+: expire-state ( class -- )
+ new
+ -1.0/0.0 now [a,b] >>expires
+ delete-tuples ;
+
+TUPLE: server-state-manager < filter-responder timeout ;
+
+: new-server-state-manager ( responder class -- responder' )
+ new
+ swap >>responder
+ 20 minutes >>timeout ; inline
+
+: touch-state ( state manager -- )
+ timeout>> from-now >>expires drop ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors continuations namespaces destructors\r
-db db.pools io.pools http.server http.server.filters\r
-furnace.sessions ;\r
+db db.pools io.pools http.server http.server.filters ;\r
IN: furnace.db\r
\r
TUPLE: db-persistence < filter-responder pool ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs assocs.lib kernel sequences accessors
+urls db.types db.tuples math.parser fry
+http http.server http.server.filters http.server.redirection
+furnace furnace.cache furnace.sessions furnace.redirection ;
+IN: furnace.flash
+
+TUPLE: flash-scope < server-state session namespace ;
+
+: <flash-scope> ( id -- aside )
+ flash-scope new-server-state ;
+
+flash-scope "FLASH_SCOPES" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+} define-persistent
+
+: flash-id-key "__f" ;
+
+TUPLE: flash-scopes < server-state-manager ;
+
+: <flash-scopes> ( responder -- responder' )
+ flash-scopes new-server-state-manager ;
+
+SYMBOL: flash-scope
+
+: fget ( key -- value )
+ flash-scope get dup
+ [ namespace>> at ] [ 2drop f ] if ;
+
+: get-flash-scope ( id -- flash-scope )
+ dup [ flash-scope get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
+: request-flash-scope ( request -- flash-scope )
+ flash-id-key swap request-params at string>number get-flash-scope ;
+
+M: flash-scopes call-responder*
+ dup flash-scopes set
+ request get request-flash-scope flash-scope set
+ call-next-method ;
+
+: make-flash-scope ( seq -- id )
+ f <flash-scope>
+ session get id>> >>session
+ swap [ dup get ] H{ } map>assoc >>namespace
+ [ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
+
+: <flash-redirect> ( url seq -- response )
+ [ clone ] dip
+ make-flash-scope flash-id-key set-query-param
+ <redirect> ;
+
+: restore-flash ( seq -- )
+ flash-scope get dup [
+ namespace>>
+ [ '[ , key? ] filter ]
+ [ '[ [ , at ] keep set ] each ]
+ bi
+ ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences arrays kernel
-assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
-html.elements html.templates.chloe.syntax ;
-IN: furnace.flows
-
-TUPLE: flows < filter-responder ;
-
-C: <flows> flows
-
-: begin-flow* ( -- id )
- request get
- [ url>> ] [ post-data>> ] [ method>> ] tri 3array
- flows sget set-at-unique
- session-changed ;
-
-: end-flow-post ( url post-data -- response )
- request [
- clone
- "POST" >>method
- swap >>post-data
- swap >>url
- ] change
- request get url>> path>> split-path
- flows get responder>> call-responder ;
-
-: end-flow* ( url id -- response )
- flows sget at [
- first3 {
- { "GET" [ drop <redirect> ] }
- { "HEAD" [ drop <redirect> ] }
- { "POST" [ end-flow-post ] }
- } case
- ] [ <redirect> ] ?if ;
-
-SYMBOL: flow-id
-
-: flow-id-key "factorflowid" ;
-
-: begin-flow ( -- )
- begin-flow* flow-id set ;
-
-: end-flow ( default -- response )
- flow-id get end-flow* ;
-
-M: flows call-responder*
- dup flows set
- flow-id-key request get request-params at flow-id set
- call-next-method ;
-
-M: flows init-session*
- H{ } clone flows sset
- call-next-method ;
-
-M: flows link-attr ( tag -- )
- drop
- "flow" optional-attr {
- { "none" [ flow-id off ] }
- { "begin" [ begin-flow ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-M: flows modify-query ( query responder -- query' )
- drop
- flow-id get [ flow-id-key associate assoc-union ] when* ;
-
-M: flows hidden-form-field ( responder -- )
- drop
- flow-id get [
- <input
- "hidden" =type
- flow-id-key =name
- =value
- input/>
- ] when* ;
IN: furnace.tests
USING: http.server.dispatchers http.server.responses
-http.server furnace tools.test kernel namespaces accessors ;
+http.server furnace tools.test kernel namespaces accessors
+io.streams.string ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
V{ } responder-nesting set
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
+
+[ "<input type='hidden' name='foo' value='&&&'/>" ]
+[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
continuations namespaces sequences splitting words
-vocabs.loader classes
-fry urls multiline
+vocabs.loader classes strings
+fry urls multiline present
xml
xml.data
+xml.entities
xml.writer
-xml.utilities
html.components
html.elements
+html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
+EXCLUDE: xml.utilities => children>string ;
IN: furnace
: nested-responders ( -- seq )
: base-path ( string -- pair )
dup responder-nesting get
- [ second class word-name = ] with find nip
+ [ second class superclasses [ word-name = ] with contains? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
M: object modify-query drop ;
-: adjust-url ( url -- url' )
+GENERIC: adjust-url ( url -- url' )
+
+M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
-: <redirect> ( url -- response )
- adjust-url request get method>> {
- { "GET" [ <temporary-redirect> ] }
- { "HEAD" [ <temporary-redirect> ] }
- { "POST" [ <permanent-redirect> ] }
- } case ;
+M: string adjust-url ;
-GENERIC: hidden-form-field ( responder -- )
+GENERIC: modify-form ( responder -- )
-M: object hidden-form-field drop ;
+M: object modify-form drop ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
- { "POST" [ post-data>> ] }
+ { "POST" [
+ post-data>>
+ dup content-type>> "application/x-www-form-urlencoded" =
+ [ content>> ] [ drop f ] if
+ ] }
+ } case ;
+
+: referrer ( -- referrer )
+ #! Typo is intentional, its in the HTTP spec!
+ "referer" request get header>> at >url ;
+
+: user-agent ( -- user-agent )
+ "user-agent" request get header>> at "" or ;
+
+: same-host? ( url -- ? )
+ request get url>>
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+
+: cookie-client-state ( key request -- value/f )
+ swap get-cookie dup [ value>> ] when ;
+
+: post-client-state ( key request -- value/f )
+ request-params at ;
+
+: client-state ( key -- value/f )
+ request get dup method>> {
+ { "GET" [ cookie-client-state ] }
+ { "HEAD" [ cookie-client-state ] }
+ { "POST" [ post-client-state ] }
} case ;
SYMBOL: exit-continuation
-: exit-with exit-continuation get continue-with ;
+: exit-with ( value -- )
+ exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
-CHLOE: atom
- [ "title" required-attr ]
+: a-url-path ( tag -- string )
[ "href" required-attr ]
- [ "query" optional-attr parse-query-attr ] tri
- <url>
- swap >>query
- swap >>path
- adjust-url relative-to-request
- add-atom-feed ;
+ [ "rest" optional-attr dup [ value ] when ] bi
+ [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
+
+: a-url ( tag -- url )
+ dup "value" optional-attr
+ [ value ] [
+ <url>
+ swap
+ [ a-url-path >>path ]
+ [ "query" optional-attr parse-query-attr >>query ]
+ bi
+ adjust-url relative-to-request
+ ] ?if ;
+
+CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
M: object link-attr 2drop ;
: link-attrs ( tag -- )
+ #! Side-effects current namespace.
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
- [
- <a
- dup link-attrs
- dup "value" optional-attr [ value f ] [
- [ "href" required-attr ]
- [ "query" optional-attr parse-query-attr ]
- bi
- ] ?if
- <url>
- swap >>query
- swap >>path
- adjust-url relative-to-request =href
- a>
- ] with-scope ;
+ [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
CHLOE: a
[ a-start-tag ]
[ drop </a> ]
tri ;
+: hidden-form-field ( value name -- )
+ over [
+ <input
+ "hidden" =type
+ =name
+ present =value
+ input/>
+ ] [ 2drop ] if ;
+
+: nested-forms-key "__n" ;
+
+: form-magic ( tag -- )
+ [ modify-form ] each-responder
+ nested-forms get " " join f like nested-forms-key hidden-form-field
+ "for" optional-attr [ "," split [ hidden render ] each ] when* ;
+
: form-start-tag ( tag -- )
[
[
<form
- "POST" =method
- [ link-attrs ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs non-chloe-attrs-only print-attrs ]
- tri
+ {
+ [ link-attrs ]
+ [ "method" optional-attr "post" or =method ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ } cleave
form>
- ] [
- [ hidden-form-field ] each-responder
- "for" optional-attr [ hidden render ] when*
- ] bi
+ ]
+ [ form-magic ] bi
] with-scope ;
CHLOE: form
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;
-
-: attr>word ( value -- word/f )
- dup ":" split1 swap lookup
- [ ] [ "No such word: " swap append throw ] ?if ;
-
-: attr>var ( value -- word/f )
- attr>word dup symbol? [
- "Must be a symbol: " swap append throw
- ] unless ;
-
-: if-satisfied? ( tag -- ? )
- "code" required-attr attr>word execute ;
-
-CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators namespaces fry
+io.servers.connection
+http http.server http.server.redirection http.server.filters
+furnace ;
+IN: furnace.redirection
+
+: <redirect> ( url -- response )
+ adjust-url request get method>> {
+ { "GET" [ <temporary-redirect> ] }
+ { "HEAD" [ <temporary-redirect> ] }
+ { "POST" [ <permanent-redirect> ] }
+ } case ;
+
+: >secure-url ( url -- url' )
+ clone
+ "https" >>protocol
+ secure-port >>port ;
+
+: <secure-redirect> ( url -- response )
+ >secure-url <redirect> ;
+
+TUPLE: redirect-responder to ;
+
+: <redirect-responder> ( url -- responder )
+ redirect-responder boa ;
+
+M: redirect-responder call-responder* nip to>> <redirect> ;
+
+TUPLE: secure-only < filter-responder ;
+
+C: <secure-only> secure-only
+
+: if-secure ( quot -- )
+ >r request get url>> protocol>> "http" =
+ [ request get url>> <secure-redirect> ]
+ r> if ; inline
+
+M: secure-only call-responder*
+ '[ , , call-next-method ] if-secure ;
--- /dev/null
+USING: accessors kernel
+http.server http.server.filters http.server.responses
+furnace ;
+IN: furnace.referrer
+
+TUPLE: referrer-check < filter-responder quot ;
+
+C: <referrer-check> referrer-check
+
+M: referrer-check call-responder*
+ referrer over quot>> call
+ [ call-next-method ]
+ [ 2drop 403 "Bad referrer" <trivial-response> ] if ;
+
+: <check-form-submissions> ( responder -- responder' )
+ [ same-host? post-request? not or ] <referrer-check> ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel fry
-rss http.server.responses furnace.actions ;
-IN: furnace.rss
-
-: <feed-content> ( body -- response )
- feed>xml "application/atom+xml" <content> ;
-
-TUPLE: feed-action < action feed ;
-
-: <feed-action> ( -- feed )
- feed-action new-action
- dup '[ , feed>> call <feed-content> ] >>display ;
IN: furnace.sessions.tests\r
USING: tools.test http furnace.sessions\r
furnace.actions http.server http.server.responses\r
-math namespaces kernel accessors\r
+math namespaces kernel accessors io.sockets io.servers.connection\r
prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.sqlite continuations urls math.parser\r
+sequences db db.tuples db.sqlite continuations urls math.parser\r
furnace ;\r
\r
: with-session\r
"auth-test.db" temp-file sqlite-db [\r
\r
<request> init-request\r
- init-sessions-table\r
+ session ensure-table\r
+\r
+ "127.0.0.1" 1234 <inet4> remote-address set\r
\r
[ ] [\r
<foo> <sessions>\r
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
-random accessors quotations hashtables sequences continuations
-fry calendar combinators destructors alarms
+strings random accessors quotations hashtables sequences continuations
+fry calendar combinators combinators.lib destructors alarms
+io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
-html.elements furnace ;
+html.elements
+furnace furnace.cache ;
IN: furnace.sessions
-TUPLE: session id expires uid namespace changed? ;
+TUPLE: session < server-state namespace user-agent client changed? ;
: <session> ( id -- session )
- session new
- swap >>id ;
+ session new-server-state ;
session "SESSIONS"
{
- { "id" "ID" +random-id+ system-random-generator }
- { "expires" "EXPIRES" TIMESTAMP +not-null+ }
- { "uid" "UID" { VARCHAR 255 } }
- { "namespace" "NAMESPACE" FACTOR-BLOB }
+ { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+ { "user-agent" "USER_AGENT" TEXT +not-null+ }
+ { "client" "CLIENT" TEXT +not-null+ }
} define-persistent
: get-session ( id -- session )
- dup [ <session> select-tuple ] when ;
-
-: init-sessions-table session ensure-table ;
-
-: start-expiring-sessions ( db seq -- )
- '[
- , , [
- session new
- -1.0/0.0 now [a,b] >>expires
- delete-tuples
- ] with-db
- ] 5 minutes every drop ;
+ dup [ session get-state ] when ;
GENERIC: init-session* ( responder -- )
M: filter-responder init-session* responder>> init-session* ;
-TUPLE: sessions < filter-responder timeout domain ;
+TUPLE: sessions < server-state-manager domain verify? ;
: <sessions> ( responder -- responder' )
- sessions new
- swap >>responder
- 20 minutes >>timeout ;
+ sessions new-server-state-manager
+ t >>verify? ;
: (session-changed) ( session -- )
t >>changed? drop ;
[ namespace>> swap change-at ] keep
(session-changed) ; inline
-: uid ( -- uid )
- session get uid>> ;
-
-: set-uid ( uid -- )
- session get [ (>>uid) ] [ (session-changed) ] bi ;
-
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
-: cutoff-time ( -- time )
- sessions get timeout>> from-now ;
-
: touch-session ( session -- )
- cutoff-time >>expires drop ;
+ sessions get touch-state ;
+
+: remote-host ( -- string )
+ {
+ [ request get "x-forwarded-for" header ]
+ [ remote-address get host>> ]
+ } 0|| ;
: empty-session ( -- session )
f <session>
H{ } clone >>namespace
+ remote-host >>client
+ user-agent >>user-agent
dup touch-session ;
: begin-session ( -- session )
[ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ;
-: session-id-key "factorsessid" ;
-
-: cookie-session-id ( request -- id/f )
- session-id-key get-cookie
- dup [ value>> string>number ] when ;
+: session-id-key "__s" ;
-: post-session-id ( request -- id/f )
- session-id-key swap post-data>> at string>number ;
-
-: request-session-id ( -- id/f )
- request get dup method>> {
- { "GET" [ cookie-session-id ] }
- { "HEAD" [ cookie-session-id ] }
- { "POST" [ post-session-id ] }
- } case ;
+: verify-session ( session -- session )
+ sessions get verify?>> [
+ dup [
+ dup
+ [ client>> remote-host = ]
+ [ user-agent>> user-agent = ]
+ bi and [ drop f ] unless
+ ] when
+ ] when ;
: request-session ( -- session/f )
- request-session-id get-session ;
+ session-id-key
+ client-state dup string? [ string>number ] when
+ get-session verify-session ;
-: <session-cookie> ( id -- cookie )
- session-id-key <cookie>
+: <session-cookie> ( -- cookie )
+ session get id>> session-id-key <cookie>
"$sessions" resolve-base-path >>path
sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )
- session get id>> number>string <session-cookie> put-cookie ;
+ <session-cookie> put-cookie ;
-M: sessions hidden-form-field ( responder -- )
- drop
- <input
- "hidden" =type
- session-id-key =name
- session get id>> number>string =value
- input/> ;
+M: sessions modify-form ( responder -- )
+ drop session get id>> session-id-key hidden-form-field ;
M: sessions call-responder* ( path responder -- response )
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
- session new swap >>uid delete-tuples ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences fry sequences.lib
+combinators syndication
+http.server.responses http.server.redirection
+furnace furnace.actions ;
+IN: furnace.syndication
+
+GENERIC: feed-entry-title ( object -- string )
+
+GENERIC: feed-entry-date ( object -- timestamp )
+
+GENERIC: feed-entry-url ( object -- url )
+
+GENERIC: feed-entry-description ( object -- description )
+
+M: object feed-entry-description drop f ;
+
+GENERIC: >entry ( object -- entry )
+
+M: entry >entry ;
+
+M: object >entry
+ <entry>
+ swap {
+ [ feed-entry-title >>title ]
+ [ feed-entry-date >>date ]
+ [ feed-entry-url >>url ]
+ [ feed-entry-description >>description ]
+ } cleave ;
+
+: process-entries ( seq -- seq' )
+ 20 short head-slice [
+ >entry clone
+ [ adjust-url relative-to-request ] change-url
+ ] map ;
+
+: <feed-content> ( body -- response )
+ feed>xml "application/atom+xml" <content> ;
+
+TUPLE: feed-action < action title url entries ;
+
+: <feed-action> ( -- action )
+ feed-action new-action
+ dup '[
+ feed new
+ ,
+ [ title>> call >>title ]
+ [ url>> call adjust-url relative-to-request >>url ]
+ [ entries>> call process-entries >>entries ]
+ tri
+ <feed-content>
+ ] >>display ;
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences splitting ;
+IN: furnace.utilities
+
+: word>string ( word -- string )
+ [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
+
+: words>strings ( seq -- seq' )
+ [ word>string ] map ;
+
+ERROR: no-such-word name vocab ;
+
+: string>word ( string -- word )
+ ":" split1 swap 2dup lookup dup
+ [ 2nip ] [ drop no-such-word ] if ;
+
+: strings>words ( seq -- seq' )
+ [ string>word ] map ;
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
+USING: assocs kernel gap-buffer generic trees trees.avl math
sequences quotations ;
IN: gap-buffer.cursortree
: cursor-index ( cursor -- i ) cursor-i ;
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
+: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
: remove-cursor ( cursortree cursor -- )
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
USING: kernel sequences io.files io.launcher io.encodings.ascii
io.streams.string http.client sequences.lib combinators
math.parser math.vectors math.intervals interval-maps memoize
-csv accessors assocs strings math splitting ;
+csv accessors assocs strings math splitting grouping arrays ;
IN: geo-ip
-: db-path "IpToCountry.csv" temp-file ;
+: db-path ( -- path ) "IpToCountry.csv" temp-file ;
-: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
+: db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
: download-db ( -- path )
db-path dup exists? [
[ "#" head? not ] filter "\n" join <string-reader> csv
[ parse-ip-entry ] map ;
+: filter-overlaps ( alist -- alist' )
+ 2 clump
+ [ first2 [ first second ] [ first first ] bi* < ] filter
+ [ first ] map ;
+
MEMO: ip-intervals ( -- interval-map )
- ip-db [ [ [ from>> ] [ to>> ] bi [a,b] ] keep ] { } map>assoc
- <interval-map> ;
+ ip-db [ [ [ from>> ] [ to>> ] bi 2array ] keep ] { } map>assoc
+ filter-overlaps <interval-map> ;
GENERIC: lookup-ip ( ip -- ip-entry )
M: string lookup-ip
"." split [ string>number ] map
- { HEX: 1000000 HEX: 10000 HEX: 100 1 } v.
+ { HEX: 1000000 HEX: 10000 HEX: 100 HEX: 1 } v.
lookup-ip ;
M: integer lookup-ip ip-intervals interval-at ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators regexp lazy-lists sequences kernel
+USING: parser-combinators regexp lists sequences kernel
promises strings unicode.case ;
IN: globs
<PRIVATE
-: 'char' [ ",*?" member? not ] satisfy ;
+: 'char' ( -- parser )
+ [ ",*?" member? not ] satisfy ;
-: 'string' 'char' <+> [ >lower token ] <@ ;
+: 'string' ( -- parser )
+ 'char' <+> [ >lower token ] <@ ;
-: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ;
+: 'escaped-char' ( -- parser )
+ "\\" token any-char-parser &> [ 1token ] <@ ;
-: 'escaped-string' 'string' 'escaped-char' <|> ;
+: 'escaped-string' ( -- parser )
+ 'string' 'escaped-char' <|> ;
DEFER: 'term'
'glob' "," token nonempty-list-of "{" "}" surrounded-by
[ <or-parser> ] <@ ;
-LAZY: 'term'
+LAZY: 'term' ( -- parser )
'union'
'character-class' <|>
"?" token [ drop any-char-parser ] <@ <|>
PRIVATE>
-: <glob> 'glob' just parse-1 just ;
+: <glob> ( string -- glob ) 'glob' just parse-1 just ;
: glob-matches? ( input glob -- ? )
[ >lower ] [ <glob> ] bi* parse nil? not ;
M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
-: pull-win32-string [ utf16n alien>string ] keep free ;
+: pull-win32-string ( alien -- string )
+ [ utf16n alien>string ] keep free ;
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
USE: io
IN: hello-world
-: hello "Hello world" print ;
+: hello ( -- ) "Hello world" print ;
MAIN: hello
$nl
"Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece."
$nl
-"Most words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } ". See " { $link "effect-declaration" } "."
+"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "."
$nl
"Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:"
{ $table
"The " { $link dup } " word makes a copy of the value at the top of the stack:"
{ $example "5 dup * ." "25" }
"The " { $link sq } " word is actually defined as follows:"
-{ $code ": sq dup * ;" }
+{ $code ": sq ( x -- y ) dup * ;" }
"(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)"
$nl
"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
"This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":"
{ $code
": a 1 ;"
- ": b a 1 + ;"
+ ": b ( -- x ) a 1 + ;"
": a 2 ;"
"b ."
}
"In Factor, this example will print 3 since word redefinition is explicitly supported."
+ $nl
+ "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "."
}
{ $references
{ "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." }
"Common terminology and abbreviations used throughout Factor and its documentation:"
{ $table
{ "Term" "Definition" }
- { "alist" { "an association list. See " { $link "alists" } } }
- { "assoc" "an associative mapping" }
+ { "alist" { "an association list; see " { $link "alists" } } }
+ { "assoc" { "an associative mapping; see " { $link "assocs" } } }
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "boolean" { { $link t } " or " { $link f } } }
{ "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
{ "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
{ "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
{ "object" { "any datum which can be identified" } }
+ { "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "pathname string" { "an OS-specific pathname which identifies a file" } }
- { "sequence" { "an object whose class implements the " { $link "sequence-protocol" } } }
+ { "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
{ "slot" { "a component of an object which can store a value" } }
{ "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
{ "true value" { "any object not equal to " { $link f } } }
{ $subsection "hashtables" }
{ $subsection "alists" }
{ $subsection "enums" }
+{ $heading "Double-ended queues" }
+{ $subsection "dequeues" }
+"Implementations:"
+{ $subsection "dlists" }
+{ $subsection "search-dequeues" }
{ $heading "Other collections" }
{ $subsection "boxes" }
-{ $subsection "dlists" }
{ $subsection "heaps" }
{ $subsection "graphs" }
-{ $subsection "buffers" } ;
+{ $subsection "buffers" }
+"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
USING: io.sockets io.launcher io.mmap io.monitors
io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
M: word article-name word-name ;
M: word article-title
- dup parsing? over symbol? or [
+ dup [ parsing-word? ] [ symbol? ] bi or [
word-name
] [
- dup word-name
- swap stack-effect
- [ effect>string " " swap 3append ] when*
+ [ word-name ]
+ [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
+ append
] if ;
M: word article-content
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;
-: (:help-multi)
- "This error has multiple delegates:" print
- ($index) nl
- "Use \\ ... help to get help about a specific delegate." print ;
-
-: (:help-none)
- drop "No help for this error. " print ;
-
-: (:help-debugger)
+: :help-debugger ( -- )
nl
"Debugger commands:" print
nl
":vars - list all variables at error time" print ;
: :help ( -- )
- error get delegates [ error-help ] map sift
- {
- { [ dup empty? ] [ (:help-none) ] }
- { [ dup length 1 = ] [ first help ] }
- [ (:help-multi) ]
- } cond (:help-debugger) ;
+ error get error-help [ help ] [ "No help for this error. " print ] if*
+ :help-debugger ;
: remove-article ( name -- )
dup articles get key? [
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: help.html
+
+
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
-macros combinators.lib sequences.lib math sets ;
+macros math sets ;
IN: help.lint
: check-example ( element -- )
: check-values ( word element -- )
{
- [ over "declared-effect" word-prop ]
- [ dup contains-funky-elements? not ]
- [ over macro? not ]
+ { [ over "declared-effect" word-prop ] [ 2drop ] }
+ { [ dup contains-funky-elements? not ] [ 2drop ] }
+ { [ over macro? not ] [ 2drop ] }
[
- 2dup extract-values >array
- >r effect-values >array
- r> assert=
- t
+ [ effect-values >array ]
+ [ extract-values >array ]
+ bi* assert=
]
- } && 3drop ;
+ } cond ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
H{ } clone [
[
- >r >r dup >link where ?first r> at r> [ ?push ] change-at
+ >r >r dup >link where dup
+ [ first r> at r> push-at ]
+ [ r> r> 2drop 2drop ]
+ if
] 2curry each
] keep ;
SYMBOL: block
SYMBOL: table
-: last-span? last-element get span eq? ;
-: last-block? last-element get block eq? ;
+: last-span? ( -- ? ) last-element get span eq? ;
+: last-block? ( -- ? ) last-element get block eq? ;
: ($span) ( quot -- )
last-block? [ nl ] when
! Some spans
-: $snippet [ snippet-style get print-element* ] ($span) ;
+: $snippet ( children -- )
+ [ snippet-style get print-element* ] ($span) ;
-: $emphasis [ emphasis-style get print-element* ] ($span) ;
+: $emphasis ( children -- )
+ [ emphasis-style get print-element* ] ($span) ;
-: $strong [ strong-style get print-element* ] ($span) ;
+: $strong ( children -- )
+ [ strong-style get print-element* ] ($span) ;
-: $url [ url-style get print-element* ] ($span) ;
+: $url ( children -- )
+ [ url-style get print-element* ] ($span) ;
-: $nl nl nl drop ;
+: $nl ( children -- )
+ nl nl drop ;
! Some blocks
-: ($heading)
+: ($heading) ( children quot -- )
last-element get [ nl ] when ($block) ; inline
: $heading ( element -- )
M: string ($instance)
dup a/an write bl $snippet ;
-: $instance first ($instance) ;
+: $instance ( children -- ) first ($instance) ;
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
drop
"Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
-: $low-level-note
+: $low-level-note ( children -- )
drop
"Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
-: $values-x/y
+: $values-x/y ( children -- )
drop { { "x" number } { "y" number } } $values ;
-: $io-error
+: $io-error ( children -- )
drop
"Throws an error if the I/O operation fails." $errors ;
-: $prettyprinting-note
+: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "
{ $link with-pprint } " combinator."
: ABOUT:
scan-object
in get vocab
- dup changed-definition
+ dup +inlined+ changed-definition
set-vocab-help ; parsing
USING: arrays io io.streams.string kernel math math.parser namespaces
- prettyprint sequences sequences.lib splitting strings ascii ;
+prettyprint sequences sequences.lib splitting grouping strings ascii ;
IN: hexdump
<PRIVATE
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
-html.elements html.components namespaces ;
+html.elements html.components html.forms namespaces ;
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
[ ] [ "jimmy" "red" set-value ] unit-test
-[ "123.5" ] [ 123.5 object>string ] unit-test
-
[ "jimmy" ] [
[
"red" label render
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ t "delivery" set-value ] unit-test
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
- [ "farkup" farkup render ] with-string-writer
+ [ "farkup" T{ farkup } render ] with-string-writer
] unit-test
[ ] [ { 1 2 3 } "object" set-value ] unit-test
=
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [
"factor" [
"concatenative" "model" set-value
- ] nest-values
+ ] nest-form
] unit-test
-[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
+[
+ H{
+ {
+ "factor"
+ T{ form f V{ } H{ { "model" "concatenative" } } }
+ }
+ }
+] [ values ] unit-test
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
-classes.tuple words arrays sequences sequences.lib splitting
-mirrors hashtables combinators continuations math strings
-fry locals calendar calendar.format xml.entities validators
-html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html urls ;
+classes.tuple words arrays sequences splitting mirrors
+hashtables combinators continuations math strings inspector
+fry locals calendar calendar.format xml.entities
+validators urls present
+xmode.code2html lcs.diff2html farkup
+html.elements html.streams html.forms ;
IN: html.components
-SYMBOL: values
-
-: value values get at ;
-
-: set-value values get set-at ;
-
-: blank-values H{ } clone values set ;
-
-: prepare-value ( name object -- value name object )
- [ [ value ] keep ] dip ; inline
-
-: from-object ( object -- )
- dup assoc? [ <mirror> ] unless
- values get swap update ;
-
-: deposit-values ( destination names -- )
- [ dup value ] H{ } map>assoc update ;
-
-: deposit-slots ( destination names -- )
- [ <mirror> ] dip deposit-values ;
-
-: with-each-index ( seq quot -- )
- '[
- [
- values [ clone ] change
- 1+ "index" set-value @
- ] with-scope
- ] each-index ; inline
-
-: with-each-value ( seq quot -- )
- '[ "value" set-value @ ] with-each-index ; inline
-
-: with-each-object ( seq quot -- )
- '[ from-object @ ] with-each-index ; inline
-
-: with-values ( object quot -- )
- '[ blank-values , from-object @ ] with-scope ; inline
-
-: nest-values ( name quot -- )
- swap [
- [
- H{ } clone [ values set call ] keep
- ] with-scope
- ] dip set-value ; inline
-
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
- over named-validation-messages get at [
- [ value>> ] [ message>> ] bi
- [ -rot render* ] dip
- render-error
- ] [
- prepare-value render*
- ] if* ;
+ prepare-value
+ [
+ dup validation-error?
+ [ [ message>> ] [ value>> ] bi ]
+ [ f swap ]
+ if
+ ] 2dip
+ render*
+ [ render-error ] when* ;
<PRIVATE
: render-input ( value name type -- )
- <input =type =name object>string =value input/> ;
+ <input =type =name present =value input/> ;
PRIVATE>
SINGLETON: label
-M: label render* 2drop object>string escape-string write ;
+M: label render* 2drop present escape-string write ;
SINGLETON: hidden
: render-field ( value name size type -- )
<input
=type
- [ object>string =size ] when*
+ [ present =size ] when*
=name
- object>string =value
+ present =value
input/> ;
TUPLE: field size ;
M: textarea render*
<textarea
- [ rows>> [ object>string =rows ] when* ]
- [ cols>> [ object>string =cols ] when* ] bi
+ [ rows>> [ present =rows ] when* ]
+ [ cols>> [ present =cols ] when* ] bi
=name
textarea>
- object>string escape-string write
+ present escape-string write
</textarea> ;
! Choice
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
- object>string escape-string write
+ present escape-string write
</option> ;
: render-options ( options selected -- )
M: choice render*
<select
swap =name
- dup size>> [ object>string =size ] when*
+ dup size>> [ present =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
+M: string link-title ;
+M: string link-href ;
+
+M: url link-title ;
+M: url link-href ;
+
SINGLETON: link
M: link render*
2drop
<a dup link-href =href a>
- link-title object>string escape-string write
+ link-title present escape-string write
</a> ;
! XMode code component
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
! Farkup component
-SINGLETON: farkup
+TUPLE: farkup no-follow disable-images ;
+
+: string>boolean ( string -- boolean )
+ {
+ { "true" [ t ] }
+ { "false" [ f ] }
+ } case ;
M: farkup render*
- 2drop string-lines "\n" join convert-farkup write ;
+ [
+ [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
+ [ disable-images>> [ string>boolean disable-images? set ] when* ] bi
+ drop string-lines "\n" join convert-farkup write
+ ] with-scope ;
! Inspector component
SINGLETON: inspector
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators calendar calendar.format ;
+urls math math.parser combinators present fry ;
IN: html.elements
#! dynamically creating words.
>r >r elements-vocab create r> r> define-declared ;
-: <foo> "<" swap ">" 3append ;
-
-: empty-effect T{ effect f 0 0 } ;
+: <foo> ( str -- <str> ) "<" swap ">" 3append ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
- dup <foo> swap [ <foo> write-html ] curry
- empty-effect html-word ;
+ dup <foo> swap '[ , <foo> write-html ]
+ (( -- )) html-word ;
-: <foo "<" prepend ;
+: <foo ( str -- <str ) "<" prepend ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
- <foo dup [ write-html ] curry
- empty-effect html-word ;
+ <foo dup '[ , write-html ]
+ (( -- )) html-word ;
-: foo> ">" append ;
+: foo> ( str -- foo> ) ">" append ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
#! word.
- foo> [ ">" write-html ] empty-effect html-word ;
+ foo> [ ">" write-html ] (( -- )) html-word ;
-: </foo> "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- </foo> dup [ write-html ] curry empty-effect html-word ;
+ </foo> dup '[ , write-html ] (( -- )) html-word ;
-: <foo/> "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
- dup <foo/> swap [ <foo/> write-html ] curry
- empty-effect html-word ;
+ dup <foo/> swap '[ , <foo/> write-html ]
+ (( -- )) html-word ;
-: foo/> "/>" append ;
+: foo/> ( str -- str/> ) "/>" append ;
: def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned
#! word.
- foo/> [ "/>" write-html ] empty-effect html-word ;
+ foo/> [ "/>" write-html ] (( -- )) html-word ;
: define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for
dup def-for-html-word-<foo
def-for-html-word-foo/> ;
-: object>string ( object -- string )
- #! Should this be generic and in the core?
- {
- { [ dup real? ] [ number>string ] }
- { [ dup timestamp? ] [ timestamp>string ] }
- { [ dup url? ] [ url>string ] }
- { [ dup string? ] [ ] }
- { [ dup word? ] [ word-name ] }
- { [ dup not ] [ drop "" ] }
- } cond ;
-
: write-attr ( value name -- )
" " write-html
write-html
"='" write-html
- object>string escape-quoted-string write-html
+ present escape-quoted-string write-html
"'" write-html ;
-: attribute-effect T{ effect f { "string" } 0 } ;
-
: define-attribute-word ( name -- )
dup "=" prepend swap
- [ write-attr ] curry attribute-effect html-word ;
+ '[ , write-attr ] (( string -- )) html-word ;
! Define some closed HTML tags
[
--- /dev/null
+IN: html.forms.tests
+USING: kernel sequences tools.test assocs html.forms validators accessors
+namespaces ;
+
+: with-validation ( quot -- messages )
+ [
+ begin-form
+ call
+ ] with-scope ; inline
+
+[ 14 ] [
+ [
+ "14" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation
+] unit-test
+
+[ t ] [
+ [
+ "140" [ v-number 13 v-min-value 100 v-max-value ] validate
+ [ validation-error? ]
+ [ value>> "140" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ t t ] [
+ [
+ { { "age" "" } }
+ { { "age" [ v-required ] } }
+ validate-values
+ validation-failed?
+ "age" value
+ [ validation-error? ]
+ [ message>> "required" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+[ H{ { "a" 123 } } f ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ form get errors>> first
+ ] with-validation
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors strings namespaces assocs hashtables
+mirrors math fry sequences sequences.lib words continuations ;
+IN: html.forms
+
+TUPLE: form errors values validation-failed ;
+
+: <form> ( -- form )
+ form new
+ V{ } clone >>errors
+ H{ } clone >>values ;
+
+M: form clone
+ call-next-method
+ [ clone ] change-errors
+ [ clone ] change-values ;
+
+: check-value-name ( name -- name )
+ dup string? [ "Value name not a string" throw ] unless ;
+
+: values ( -- assoc )
+ form get values>> ;
+
+: value ( name -- value )
+ check-value-name values at ;
+
+: set-value ( value name -- )
+ check-value-name values set-at ;
+
+: begin-form ( -- ) <form> form set ;
+
+: prepare-value ( name object -- value name object )
+ [ [ value ] keep ] dip ; inline
+
+: from-object ( object -- )
+ [ values ] [ make-mirror ] bi* update ;
+
+: to-object ( destination names -- )
+ [ make-mirror ] [ values extract-keys ] bi* update ;
+
+: with-each-value ( name quot -- )
+ [ value ] dip '[
+ [
+ form [ clone ] change
+ 1+ "index" set-value
+ "value" set-value
+ @
+ ] with-scope
+ ] each-index ; inline
+
+: with-each-object ( name quot -- )
+ [ value ] dip '[
+ [
+ begin-form
+ 1+ "index" set-value
+ from-object
+ @
+ ] with-scope
+ ] each-index ; inline
+
+SYMBOL: nested-forms
+
+: with-form ( name quot -- )
+ '[
+ ,
+ [ nested-forms [ swap prefix ] change ]
+ [ value form set ]
+ bi
+ @
+ ] with-scope ; inline
+
+: nest-form ( name quot -- )
+ swap [
+ [
+ <form> form set
+ call
+ form get
+ ] with-scope
+ ] dip set-value ; inline
+
+TUPLE: validation-error value message ;
+
+C: <validation-error> validation-error
+
+: validation-error ( message -- )
+ form get
+ t >>validation-failed
+ errors>> push ;
+
+: validation-failed? ( -- ? )
+ form get validation-failed>> ;
+
+: define-validators ( class validators -- )
+ >hashtable "validators" set-word-prop ;
+
+: validate ( value quot -- result )
+ [ <validation-error> ] recover ; inline
+
+: validate-value ( name value quot -- )
+ validate
+ dup validation-error? [ form get t >>validation-failed drop ] when
+ swap set-value ;
+
+: validate-values ( assoc validators -- assoc' )
+ swap '[ dup , at _ validate-value ] assoc-each ;
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
continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
-state-parser strings ;
+strings ;
IN: html.parser.printer
SYMBOL: no-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 -- )
tag-text write
"-->" write ;
-M: printer print-dtd-tag
+M: printer print-dtd-tag ( tag -- )
"<!" write
tag-text write
">" write ;
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 -- )
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 -- )
{
[ 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 } } } [
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?
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 ;
[ 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 ;
dup quoted? [ but-last-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ;
-
M: html-block-stream dispose ( quot style stream -- )
end-sub-stream a-div format-html-div ;
-: border-spacing-css,
+: border-spacing-css, ( pair -- )
"padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str )
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
-namespaces xml html.components
-splitting unicode.categories furnace ;
+namespaces xml html.components html.forms
+splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
- blank-values
+ begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
- blank-values
+ begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] run-template
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
"test9" test-template call-template
] run-template
] unit-test
+
+[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
+
+[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
+ [
+ "test10" test-template call-template
+ ] run-template
+] unit-test
+
+[ ] [ begin-form ] unit-test
+
+[ ] [
+ <form> H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
+ [
+ "test11" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+ begin-form
+ { "a" "b" } "choices" set-value
+ "true" "b" set-value
+] unit-test
+
+[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
+ [
+ "test12" test-template call-template
+ ] run-template
+] unit-test
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry math urls
+unicode.case tuple-syntax mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
+html.forms
html.elements
html.components
html.templates
: (bind-tag) ( tag quot -- )
[
- [ "name" required-attr value ] keep
+ [ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
CHLOE: bind-each [ with-each-object ] (bind-tag) ;
-CHLOE: bind [ with-values ] (bind-tag) ;
+CHLOE: bind [ with-form ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
CHLOE: call-next-template drop call-next-template ;
+: attr>word ( value -- word/f )
+ ":" split1 swap lookup ;
+
+: if-satisfied? ( tag -- ? )
+ [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
+ [ "value" optional-attr [ value ] [ t ] if* ]
+ bi and ;
+
+CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
-CHLOE-SINGLETON: farkup
CHLOE-SINGLETON: inspector
CHLOE-SINGLETON: comparison
CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
+CHLOE-TUPLE: farkup
CHLOE-TUPLE: field
CHLOE-TUPLE: textarea
CHLOE-TUPLE: password
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
clone [
- [ "@" ?head [ value object>string ] when ] assoc-map
+ [ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:bind t:name="person">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:bind>
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>
method: "GET"
version: "1.1"
cookies: V{ }
- header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
+ header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
}
] [
"http://www.apple.com/index.html"
method: "GET"
version: "1.1"
cookies: V{ }
- header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
+ header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
}
] [
"https://www.amazon.com/index.html"
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 ;
drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
-DEFER: http-request
+DEFER: (http-request)
<PRIVATE
SYMBOL: redirects
: redirect-url ( request url -- request )
- '[ , >url derive-url ensure-port ] change-url ;
+ '[ , >url ensure-port derive-url ensure-port ] change-url ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
redirects get max-redirects < [
request get
swap "location" header redirect-url
- "GET" >>method http-request
+ "GET" >>method (http-request)
] [
too-many-redirects
] if
: 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 ;
-
-: http-request ( request -- response data )
+ 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 )
dup request [
- dup url>> url-addr latin1 [
+ dup url>> url-addr ascii [
1 minutes timeouts
write-request
read-response
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 ;
M: download-failed error.
"HTTP download failed:" print nl
- [
- response>>
- write-response-code
- write-response-message nl
- drop
- ]
- [ body>> write ] bi ;
+ [ response>> write-response-line nl drop ]
+ [ body>> write ]
+ bi ;
+
+: check-response ( response data -- response data )
+ over code>> success? [ download-failed ] unless ;
-: check-response ( response string -- string )
- over code>> success? [ nip ] [ download-failed ] if ;
+: http-request ( request -- response data )
+ (http-request) check-response ;
-: http-get ( url -- string )
- http-get* 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 ;
-: <post-request> ( content-type content url -- request )
+: <post-request> ( post-data url -- request )
<request>
"POST" >>method
swap >url ensure-port >>url
- swap >>post-data
- swap >>post-data-type ;
+ swap >>post-data ;
-: http-post ( content-type content url -- response data )
+: http-post ( post-data url -- response data )
<post-request> http-request ;
USING: http tools.test multiline tuple-syntax
-io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls ;
+io.streams.string io.encodings.utf8 io.encodings.string
+kernel arrays splitting sequences
+assocs io.sockets db db.sqlite continuations urls hashtables
+accessors ;
IN: http.tests
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
-GET http://foo/bar HTTP/1.1
+POST /bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
+Content-type: application/octet-stream
blah
;
[
TUPLE{ request
- url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
- method: "GET"
+ url: TUPLE{ url path: "/bar" }
+ method: "POST"
version: "1.1"
- header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
- post-data: "blah"
+ header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
+ post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
cookies: V{ }
}
] [
] unit-test
STRING: read-request-test-1'
-GET /bar HTTP/1.1
+POST /bar HTTP/1.1
content-length: 4
+content-type: application/octet-stream
some-header: 1; 2
blah
] unit-test
STRING: read-request-test-2
-HEAD http://foo/bar HTTP/1.1
+HEAD /bar HTTP/1.1
Host: www.sex.com
;
[
TUPLE{ request
- url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
+ url: TUPLE{ url host: "www.sex.com" path: "/bar" }
method: "HEAD"
version: "1.1"
header: H{ { "host" "www.sex.com" } }
;
-[ read-request-test-3 [ read-request ] with-string-reader ]
+[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ]
[ "Bad request: URL" = ]
must-fail-with
+STRING: read-request-test-4
+GET /blah HTTP/1.0
+Host: "www.amazon.com"
+;
+
+[ "www.amazon.com" ]
+[
+ read-request-test-4 lf>crlf [ read-request ] with-string-reader
+ "host" header
+] unit-test
+
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
;
version: "1.1"
code: 404
message: "not found"
- header: H{ { "content-type" "text/html; charset=UTF8" } }
- cookies: V{ }
+ 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
STRING: read-response-test-1'
HTTP/1.1 404 not found
-content-type: text/html; charset=UTF8
+content-type: text/html; charset=UTF-8
;
[ t ] [
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
- dup parse-cookies unparse-cookies =
+ dup parse-set-cookie first unparse-set-cookie =
+] unit-test
+
+[ t ] [
+ "a="
+ dup parse-set-cookie first unparse-set-cookie =
+] unit-test
+
+STRING: read-response-test-2
+HTTP/1.1 200 Content follows
+Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
+
+
+;
+
+[ 2 ] [
+ read-response-test-2 lf>crlf
+ [ read-response ] with-string-reader
+ cookies>> length
+] unit-test
+
+STRING: read-response-test-3
+HTTP/1.1 200 Content follows
+Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
+
+
+;
+
+[ 1 ] [
+ read-response-test-3 lf>crlf
+ [ read-response ] with-string-reader
+ cookies>> length
] unit-test
! Live-fire exercise
-USING: http.server http.server.static furnace.sessions
-furnace.actions furnace.auth.login furnace.db http.client
-io.server io.files io io.encodings.ascii
+USING: http.server http.server.static furnace.sessions furnace.alloy
+furnace.actions furnace.auth furnace.auth.login furnace.db http.client
+io.servers.connection io.files io io.encodings.ascii
accessors namespaces threads
-http.server.responses http.server.redirection
-http.server.dispatchers ;
+http.server.responses http.server.redirection furnace.redirection
+http.server.dispatchers db.tuples ;
: add-quit-action
<action>
[ test-db drop delete-file ] ignore-errors
test-db [
- init-sessions-table
+ init-furnace-tables
] with-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
[ ] [
[
<dispatcher>
- <login>
+ <action> <protected>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
: 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
[ ] [
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
[ ] [ 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 nip ] unit-test
+
+USING: html.components html.elements html.forms
+xml xml.utilities validators
+furnace furnace.flash ;
+
+SYMBOL: a
+
+[ ] [
+ [
+ <dispatcher>
+ <action>
+ [ a get-global "a" set-value ] >>init
+ [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+ [ { { "a" [ v-integer ] } } validate-params ] >>validate
+ [ "a" value a set-global URL" " <redirect> ] >>submit
+ <flash-scopes>
+ <sessions>
+ >>default
+ add-quit-action
+ test-db <db-persistence>
+ main-responder set
+
+ [ 1237 httpd ] "HTTPD test" spawn drop
+ ] with-scope
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+3 a set-global
+
+: test-a string>xml "input" tag-named "value" swap at ;
+
+[ "3" ] [
+ "http://localhost:1237/" http-get
+ swap dup cookies>> "cookies" set session-id-key get-cookie
+ value>> "session-id" set test-a
+] unit-test
+
+[ "4" ] [
+ H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+ "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+! Test flash scope
+[ "xyz" ] [
+ H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+ "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
+! Test cloning
+[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
+[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces
-
-assocs sequences splitting sorting sets debugger
+assocs assocs.lib sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format
+math.parser calendar calendar.format present
-io io.server io.sockets.secure
+io io.encodings io.encodings.iana io.encodings.binary
+io.encodings.8-bit
unicode.case unicode.categories qualified
-urls html.templates ;
+urls html.templates xml xml.data xml.writer
+
+http.parsers ;
EXCLUDE: fry => , ;
IN: http
-: crlf "\r\n" write ;
-
-: add-header ( value key assoc -- )
- [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
-
-: header-line ( line -- )
- dup first blank? [
- [ blank? ] left-trim
- "last-header" get
- "header" get
- add-header
- ] [
- ": " split1 dup [
- swap >lower dup "last-header" set
- "header" get add-header
- ] [
- 2drop
- ] if
- ] if ;
-
-: read-lf ( -- string )
- "\n" read-until CHAR: \n assert= ;
-
-: read-crlf ( -- string )
+: crlf ( -- ) "\r\n" write ;
+
+: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
-: read-header-line ( -- )
- read-crlf dup
- empty? [ drop ] [ header-line read-header-line ] if ;
+: (read-header) ( -- alist )
+ [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
+
+: process-header ( alist -- assoc )
+ f swap [ [ swap or dup ] dip swap ] assoc-map nip
+ [ ?push ] histogram [ "; " join ] assoc-map
+ >hashtable ;
: read-header ( -- assoc )
- H{ } clone [
- "header" [ read-header-line ] with-variable
- ] keep ;
+ (read-header) process-header ;
: header-value>string ( value -- string )
{
- { [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] }
- { [ dup url? ] [ url>string ] }
- { [ dup string? ] [ ] }
- { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
+ { [ dup array? ] [ [ header-value>string ] map "; " join ] }
+ [ present ]
} cond ;
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n" intersect empty?
+ dup "\r\n\"" intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
>alist sort-keys [
- swap url-encode write ": " write
- header-value>string check-header-string write crlf
+ [ check-header-string write ": " write ]
+ [ header-value>string check-header-string write crlf ] bi*
] assoc-each crlf ;
-TUPLE: cookie name value path domain expires max-age http-only ;
+TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
: <cookie> ( value name -- cookie )
cookie new
swap >>name
swap >>value ;
-: parse-cookies ( string -- seq )
+: parse-set-cookie ( string -- seq )
[
f swap
-
- ";" split [
- [ blank? ] trim "=" split1 swap >lower {
+ (parse-set-cookie)
+ [
+ swap {
+ { "version" [ >>version ] }
+ { "comment" [ >>comment ] }
{ "expires" [ cookie-string>timestamp >>expires ] }
{ "max-age" [ string>number seconds >>max-age ] }
{ "domain" [ >>domain ] }
{ "path" [ >>path ] }
{ "httponly" [ drop t >>http-only ] }
- { "" [ drop ] }
+ { "secure" [ drop t >>secure ] }
[ <cookie> dup , nip ]
} case
- ] each
+ ] assoc-each
+ drop
+ ] { } make ;
+: parse-cookie ( string -- seq )
+ [
+ f swap
+ (parse-cookie)
+ [
+ swap {
+ { "$version" [ >>version ] }
+ { "$domain" [ >>domain ] }
+ { "$path" [ >>path ] }
+ [ <cookie> dup , nip ]
+ } case
+ ] assoc-each
drop
] { } make ;
-: (unparse-cookie) ( key value -- )
+: check-cookie-string ( string -- string' )
+ dup "=;'\"\r\n" intersect empty?
+ [ "Bad cookie name or value" throw ] unless ;
+
+: unparse-cookie-value ( key value -- )
{
{ f [ drop ] }
- { t [ , ] }
+ { t [ check-cookie-string , ] }
[
{
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
{ [ dup duration? ] [ dt>seconds number>string ] }
+ { [ dup real? ] [ number>string ] }
[ ]
} cond
- "=" swap 3append ,
+ check-cookie-string "=" swap check-cookie-string 3append ,
]
} case ;
-: unparse-cookie ( cookie -- strings )
+: (unparse-cookie) ( cookie -- strings )
[
- dup name>> >lower over value>> (unparse-cookie)
- "path" over path>> (unparse-cookie)
- "domain" over domain>> (unparse-cookie)
- "expires" over expires>> (unparse-cookie)
- "max-age" over max-age>> (unparse-cookie)
- "httponly" over http-only>> (unparse-cookie)
+ dup name>> check-cookie-string >lower
+ over value>> unparse-cookie-value
+ "$path" over path>> unparse-cookie-value
+ "$domain" over domain>> unparse-cookie-value
drop
] { } make ;
-: unparse-cookies ( cookies -- string )
- [ unparse-cookie ] map concat "; " join ;
+: unparse-cookie ( cookies -- string )
+ [ (unparse-cookie) ] map concat "; " join ;
+
+: unparse-set-cookie ( cookie -- string )
+ [
+ dup name>> check-cookie-string >lower
+ over value>> unparse-cookie-value
+ "path" over path>> unparse-cookie-value
+ "domain" over domain>> unparse-cookie-value
+ "expires" over expires>> unparse-cookie-value
+ "max-age" over max-age>> unparse-cookie-value
+ "httponly" over http-only>> unparse-cookie-value
+ "secure" over secure>> unparse-cookie-value
+ drop
+ ] { } make "; " join ;
TUPLE: request
method
version
header
post-data
-post-data-type
cookies ;
+: check-url ( string -- url )
+ >url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
+
+: read-request-line ( request -- request )
+ read-crlf parse-request-line first3
+ [ >>method ] [ check-url >>url ] [ >>version ] tri* ;
+
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
-: <request>
+: <request> ( -- request )
request new
"1.1" >>version
<url>
- "http" >>protocol
H{ } clone >>query
>>url
H{ } clone >>header
V{ } clone >>cookies
"close" "connection" set-header
- "Factor http.client vocabulary" "user-agent" set-header ;
-
-: read-method ( request -- request )
- " " read-until [ "Bad request: method" throw ] unless
- >>method ;
+ "Factor http.client" "user-agent" set-header ;
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
-: read-url ( request -- request )
- " " read-until [
- dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
- ] [ "Bad request: URL" throw ] if ;
-
-: parse-version ( string -- version )
- "HTTP/" ?head [ "Bad request: version" throw ] unless
- dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
-
-: read-request-version ( request -- request )
- read-crlf [ CHAR: \s = ] left-trim
- parse-version
- >>version ;
-
: read-request-header ( request -- request )
read-header >>header ;
: header ( request/response key -- value )
swap header>> at ;
-SYMBOL: max-post-request
+TUPLE: post-data raw content content-type ;
-1024 256 * max-post-request set-global
+: <post-data> ( raw content-type -- post-data )
+ post-data new
+ swap >>content-type
+ swap >>raw ;
-: content-length ( header -- n )
- "content-length" swap at string>number dup [
- dup max-post-request get > [
- "content-length > max-post-request" throw
- ] when
- ] when ;
+: parse-post-data ( post-data -- post-data )
+ [ ] [ raw>> ] [ content-type>> ] tri {
+ { "application/x-www-form-urlencoded" [ query>assoc ] }
+ { "text/xml" [ string>xml ] }
+ [ drop ]
+ } case >>content ;
: read-post-data ( request -- request )
- dup header>> content-length [ read >>post-data ] when* ;
+ dup method>> "POST" = [
+ [ ]
+ [ "content-length" header string>number read ]
+ [ "content-type" header ] tri
+ <post-data> parse-post-data >>post-data
+ ] when ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
- ensure-port
drop ;
-: extract-post-data-type ( request -- request )
- dup "content-type" header >>post-data-type ;
-
-: parse-post-data ( request -- request )
- dup post-data-type>> "application/x-www-form-urlencoded" =
- [ dup post-data>> query>assoc >>post-data ] when ;
-
: extract-cookies ( request -- request )
- dup "cookie" header [ parse-cookies >>cookies ] when* ;
+ dup "cookie" header [ parse-cookie >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
-: detect-protocol ( request -- request )
- dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
-
: read-request ( -- request )
<request>
- read-method
- read-url
- read-request-version
+ read-request-line
read-request-header
read-post-data
- detect-protocol
extract-host
- extract-post-data-type
- parse-post-data
extract-cookies ;
-: write-method ( request -- request )
- dup method>> write bl ;
-
-: write-request-url ( request -- request )
- dup url>> relative-url url>string write bl ;
-
-: write-version ( request -- request )
- "HTTP/" write dup request-version write crlf ;
-
-: unparse-post-data ( request -- request )
- dup post-data>> dup sequence? [ drop ] [
- assoc>query >>post-data
- "application/x-www-form-urlencoded" >>post-data-type
- ] if ;
+: write-request-line ( request -- request )
+ dup
+ [ method>> write bl ]
+ [ url>> relative-url present write bl ]
+ [ "HTTP/" write version>> write crlf ]
+ tri ;
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
: write-request-header ( request -- request )
dup header>> >hashtable
over url>> host>> [ over url>> url-host "host" pick set-at ] when
- over post-data>> [ length "content-length" pick set-at ] when*
- over post-data-type>> [ "content-type" pick set-at ] when*
- over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
+ over post-data>> [
+ [ raw>> length "content-length" pick set-at ]
+ [ content-type>> "content-type" pick set-at ]
+ bi
+ ] when*
+ over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
write-header ;
+GENERIC: >post-data ( object -- post-data )
+
+M: post-data >post-data ;
+
+M: string >post-data "application/octet-stream" <post-data> ;
+
+M: byte-array >post-data "application/octet-stream" <post-data> ;
+
+M: xml >post-data xml>string "text/xml" <post-data> ;
+
+M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
+
+M: f >post-data ;
+
+: unparse-post-data ( request -- request )
+ [ >post-data ] change-post-data ;
+
: write-post-data ( request -- request )
- dup post-data>> [ write ] when* ;
+ dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
- write-method
- write-request-url
- write-version
+ write-request-line
write-request-header
write-post-data
flush
content-charset
body ;
-: <response>
+: <response> ( -- response )
response new
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
+ "Factor http.server" "server" set-header
+ latin1 >>content-charset
V{ } clone >>cookies ;
-: read-response-version
- " \t" read-until
- [ "Bad response: version" throw ] unless
- parse-version
- >>version ;
+M: response clone
+ call-next-method
+ [ clone ] change-header
+ [ clone ] change-cookies ;
-: read-response-code
- " \t" read-until [ "Bad response: code" throw ] unless
- string>number [ "Bad response: code" throw ] unless*
- >>code ;
+: read-response-line ( response -- response )
+ read-crlf parse-response-line first3
+ [ >>version ] [ >>code ] [ >>message ] tri* ;
-: read-response-message
- read-crlf >>message ;
-
-: read-response-header
+: read-response-header ( response -- response )
read-header >>header
- extract-cookies
+ dup "set-cookie" header parse-set-cookie >>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 )
<response>
- read-response-version
- read-response-code
- read-response-message
+ read-response-line
read-response-header ;
-: write-response-version ( response -- response )
- "HTTP/" write
- dup version>> write bl ;
-
-: write-response-code ( response -- response )
- dup code>> number>string write bl ;
-
-: write-response-message ( response -- response )
- dup message>> write crlf ;
+: write-response-line ( response -- response )
+ dup
+ [ "HTTP/" write version>> write bl ]
+ [ code>> present write bl ]
+ [ message>> write crlf ]
+ tri ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
- [ content-charset>> ] bi
+ [ content-charset>> encoding>name ]
+ bi
[ "; charset=" swap 3append ] when* ;
+: ensure-domain ( cookie -- cookie )
+ [
+ request get url>>
+ host>> dup "localhost" =
+ [ drop ] [ or ] if
+ ] change-domain ;
+
: write-response-header ( response -- response )
- dup header>> clone
- over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
+ #! We send one set-cookie header per cookie, because that's
+ #! what Firefox expects.
+ dup header>> >alist >vector
over unparse-content-type "content-type" pick set-at
+ over cookies>> [
+ ensure-domain unparse-set-cookie
+ "set-cookie" swap 2array over push
+ ] each
write-header ;
: write-response-body ( response -- response )
dup body>> call-template ;
M: response write-response ( respose -- )
- write-response-version
- write-response-code
- write-response-message
+ write-response-line
write-response-header
flush
drop ;
M: response write-full-response ( request response -- )
dup write-response
- swap method>> "HEAD" = [ write-response-body ] unless ;
+ swap method>> "HEAD" = [
+ [ content-charset>> encode-output ]
+ [ write-response-body ]
+ bi
+ ] unless ;
: get-cookie ( request/response name -- cookie/f )
[ cookies>> ] dip '[ , _ name>> = ] find nip ;
"1.1" >>version ;
M: raw-response write-response ( respose -- )
- write-response-version
- write-response-code
- write-response-message
+ write-response-line
write-response-body
drop ;
--- /dev/null
+USING: math math.order math.parser kernel combinators.lib
+sequences sequences.deep peg peg.parsers assocs arrays
+hashtables strings unicode.case namespaces ascii ;
+IN: http.parsers
+
+: except ( quot -- parser )
+ [ not ] compose satisfy ; inline
+
+: except-these ( quots -- parser )
+ [ 1|| ] curry except ; inline
+
+: ctl? ( ch -- ? )
+ { [ 0 31 between? ] [ 127 = ] } 1|| ;
+
+: tspecial? ( ch -- ? )
+ "()<>@,;:\\\"/[]?={} \t" member? ;
+
+: 'token' ( -- parser )
+ { [ ctl? ] [ tspecial? ] } except-these repeat1 ;
+
+: case-insensitive ( parser -- parser' )
+ [ flatten >string >lower ] action ;
+
+: case-sensitive ( parser -- parser' )
+ [ flatten >string ] action ;
+
+: 'space' ( -- parser )
+ [ " \t" member? ] satisfy repeat0 hide ;
+
+: one-of ( strings -- parser )
+ [ token ] map choice ;
+
+: 'http-method' ( -- parser )
+ { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
+
+: 'url' ( -- parser )
+ [ " \t\r\n" member? ] except repeat1 case-sensitive ;
+
+: 'http-version' ( -- parser )
+ [
+ "HTTP" token hide ,
+ 'space' ,
+ "/" token hide ,
+ 'space' ,
+ "1" token ,
+ "." token ,
+ { "0" "1" } one-of ,
+ ] seq* [ concat >string ] action ;
+
+PEG: parse-request-line ( string -- triple )
+ #! Triple is { method url version }
+ [
+ 'space' ,
+ 'http-method' ,
+ 'space' ,
+ 'url' ,
+ 'space' ,
+ 'http-version' ,
+ 'space' ,
+ ] seq* just ;
+
+: 'text' ( -- parser )
+ [ ctl? ] except ;
+
+: 'response-code' ( -- parser )
+ [ digit? ] satisfy 3 exactly-n [ string>number ] action ;
+
+: 'response-message' ( -- parser )
+ 'text' repeat0 case-sensitive ;
+
+PEG: parse-response-line ( string -- triple )
+ #! Triple is { version code message }
+ [
+ 'space' ,
+ 'http-version' ,
+ 'space' ,
+ 'response-code' ,
+ 'space' ,
+ 'response-message' ,
+ ] seq* just ;
+
+: 'crlf' ( -- parser )
+ "\r\n" token ;
+
+: 'lws' ( -- parser )
+ [ " \t" member? ] satisfy repeat1 ;
+
+: 'qdtext' ( -- parser )
+ { [ CHAR: " = ] [ ctl? ] } except-these ;
+
+: 'quoted-char' ( -- parser )
+ "\\" token hide any-char 2seq ;
+
+: 'quoted-string' ( -- parser )
+ 'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
+
+: 'ctext' ( -- parser )
+ { [ ctl? ] [ "()" member? ] } except-these ;
+
+: 'comment' ( -- parser )
+ 'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
+
+: 'field-name' ( -- parser )
+ 'token' case-insensitive ;
+
+: 'field-content' ( -- parser )
+ 'quoted-string' case-sensitive
+ 'text' repeat0 case-sensitive
+ 2choice ;
+
+PEG: parse-header-line ( string -- pair )
+ #! Pair is either { name value } or { f value }. If f, its a
+ #! continuation of the previous header line.
+ [
+ 'field-name' ,
+ 'space' ,
+ ":" token hide ,
+ 'space' ,
+ 'field-content' ,
+ ] seq*
+ [
+ 'lws' [ drop f ] action ,
+ 'field-content' ,
+ ] seq*
+ 2choice ;
+
+: 'word' ( -- parser )
+ 'token' 'quoted-string' 2choice ;
+
+: 'value' ( -- parser )
+ 'quoted-string'
+ [ ";" member? ] except repeat0
+ 2choice case-sensitive ;
+
+: 'attr' ( -- parser )
+ 'token' case-insensitive ;
+
+: 'av-pair' ( -- parser )
+ [
+ 'space' ,
+ 'attr' ,
+ 'space' ,
+ [ "=" token , 'space' , 'value' , ] seq* [ peek ] action
+ epsilon [ drop f ] action
+ 2choice ,
+ 'space' ,
+ ] seq* ;
+
+: 'av-pairs' ( -- parser )
+ 'av-pair' ";" token list-of optional ;
+
+PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
+
+: 'cookie-value' ( -- parser )
+ [
+ 'space' ,
+ 'attr' ,
+ 'space' ,
+ "=" token hide ,
+ 'space' ,
+ 'value' ,
+ 'space' ,
+ ] seq* ;
+
+PEG: (parse-cookie) ( string -- alist )
+ 'cookie-value' [ ";," member? ] satisfy list-of optional just ;
http accessors sequences strings math.parser fry urls ;\r
IN: http.server.cgi\r
\r
-: post? request get method>> "POST" = ;\r
-\r
: cgi-variables ( script-path -- assoc )\r
#! This needs some work.\r
[\r
request get "user-agent" header "HTTP_USER_AGENT" set\r
request get "accept" header "HTTP_ACCEPT" set\r
\r
- post? [\r
- request get post-data-type>> "CONTENT_TYPE" set\r
- request get post-data>> length number>string "CONTENT_LENGTH" set\r
+ post-request? [\r
+ request get post-data>> raw>>\r
+ [ "CONTENT_TYPE" set ]\r
+ [ length number>string "CONTENT_LENGTH" set ]\r
+ bi\r
] when\r
] H{ } make-assoc ;\r
\r
"CGI output follows" >>message\r
swap '[\r
, output-stream get swap <cgi-process> <process-stream> [\r
- post? [ request get post-data>> write flush ] when\r
+ post-request? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
] >>body ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences assocs accessors
-http http.server http.server.responses ;
+USING: kernel namespaces sequences assocs accessors splitting
+unicode.case http http.server http.server.responses ;
IN: http.server.dispatchers
TUPLE: dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
vhost-dispatcher new-dispatcher ;
+: canonical-host ( host -- host' )
+ >lower "www." ?head drop "." ?tail drop ;
+
: find-vhost ( dispatcher -- responder )
- request get url>> host>> over responders>> at*
+ request get url>> host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
-namespaces tools.test ;
+namespaces tools.test present ;
\ relative-to-request must-infer
request set
[ "http://www.apple.com:80/xxx/bar" ] [
- <url> relative-to-request url>string
+ <url> relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz" ] [
- <url> "baz" >>path relative-to-request url>string
+ <url> "baz" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
- <url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
+ <url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
- <url> { { "c" "d" } } >>query relative-to-request url>string
+ <url> { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip" ] [
- <url> "/flip" >>path relative-to-request url>string
+ <url> "/flip" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [
- <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
+ <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.jedit.org:80/" ] [
- "http://www.jedit.org" >url relative-to-request url>string
+ "http://www.jedit.org" >url relative-to-request present
] unit-test
[ "http://www.jedit.org:80/?a=b" ] [
- "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
+ "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
] unit-test
] with-scope
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces
+USING: kernel accessors combinators namespaces strings
logging urls http http.server http.server.responses ;
IN: http.server.redirection
-: relative-to-request ( url -- url' )
+GENERIC: relative-to-request ( url -- url' )
+
+M: string relative-to-request ;
+
+M: url relative-to-request
request get url>>
clone
f >>query
! 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 ;
--- /dev/null
+USING: http http.server math sequences continuations tools.test ;
+IN: http.server.tests
+
+[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
! 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
+combinators tools.vocabs tools.time math
+io
+io.sockets
+io.sockets.secure
+io.encodings
+io.encodings.utf8
+io.encodings.ascii
+io.encodings.binary
+io.streams.limited
+io.servers.connection
+io.timeouts
+fry logging logging.insomniac calendar urls
+http
+http.server.responses
+html.elements
+html.streams ;
IN: http.server
+: post-request? ( -- ? ) request get method>> "POST" = ;
+
SYMBOL: responder-nesting
SYMBOL: main-responder
-SYMBOL: development-mode
+SYMBOL: development?
+
+SYMBOL: benchmark?
! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response )
M: trivial-responder call-responder* nip response>> clone ;
-main-responder global [ <404> <trivial-responder> get-global or ] change-at
+main-responder global [ <404> <trivial-responder> or ] change-at
: invert-slice ( slice -- slice' )
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
+ swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
- dup write-response
- request get method>> "HEAD" =
- [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
+ [ request get swap write-full-response ]
+ [
+ [ \ do-response log-error ]
+ [
+ utf8 [
+ development? get
+ [ http-error. ] [ drop "Response error" write ] if
+ ] with-encoded-output
+ ] bi
+ ] recover ;
LOG: httpd-hit NOTICE
+LOG: httpd-header NOTICE
+
+: log-header ( headers name -- )
+ tuck header 2array httpd-header ;
+
: log-request ( request -- )
- [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
+ [ [ method>> ] [ url>> ] bi 2array httpd-hit ]
+ [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
+ bi ;
: split-path ( string -- path )
"/" split harvest ;
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
+: prepare-request ( request -- )
+ [
+ local-address get
+ [ secure? "https" "http" ? >>protocol ]
+ [ port>> '[ , or ] change-port ]
+ bi
+ ] change-url drop ;
+
+: valid-request? ( request -- ? )
+ url>> port>> local-address get port>> = ;
+
: do-request ( request -- response )
'[
,
- [ init-request ]
- [ log-request ]
- [ dispatch-request ] tri
+ {
+ [ init-request ]
+ [ prepare-request ]
+ [ log-request ]
+ [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
+ } cleave
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
- development-mode get-global
- [ global [ refresh-all ] bind ] when ;
+ development? get-global [ global [ refresh-all ] bind ] when ;
+
+LOG: httpd-benchmark DEBUG
+
+: ?benchmark ( quot -- )
+ benchmark? get [
+ [ benchmark ] [ first ] bi request get url>> rot 3array
+ httpd-benchmark
+ ] [ call ] if ; inline
-: handle-client ( -- )
+TUPLE: http-server < threaded-server ;
+
+M: http-server handle-client*
+ drop
[
- 1 minutes timeouts
+ 64 1024 * limit-input
?refresh-all
read-request
- do-request
- do-response
+ [ do-request ] ?benchmark
+ [ do-response ] ?benchmark
] with-destructors ;
-: httpd ( port -- )
- dup integer? [ internet-server ] when
- "http.server" latin1 [ handle-client ] with-server ;
+: <http-server> ( -- server )
+ http-server new-threaded-server
+ "http.server" >>name
+ "http" protocol-port >>insecure
+ "https" protocol-port >>secure ;
-: httpd-main ( -- )
- 8888 httpd ;
+: httpd ( port -- )
+ <http-server>
+ swap >>insecure
+ f >>secure
+ start-server ;
-MAIN: httpd-main
+: http-insomniac ( -- )
+ "http.server" { "httpd-hit" } schedule-insomniac ;
H{ } clone >>special ;\r
\r
: (serve-static) ( path mime-type -- response )\r
- [ [ binary <file-reader> &dispose ] dip <content> ]\r
+ [\r
+ [ binary <file-reader> &dispose ] dip\r
+ <content> binary >>content-charset\r
+ ]\r
[ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
[ "content-length" set-header ]\r
[ "last-modified" set-header ] bi* ;\r
"index.html" append-path dup exists? [ drop f ] unless ;\r
\r
: serve-directory ( filename -- response )\r
- request get path>> "/" tail? [\r
+ request get url>> path>> "/" tail? [\r
dup\r
find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
! 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 io.encodings.binary ;
+io.files splitting grouping io.binary math.functions vectors
+quotations combinators io.encodings.binary ;
IN: icfp.2006
SYMBOL: regs
{ [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not
- ] } <-&& ;
+ ] } 1&& ;
: (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
-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"
"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 }
{ $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" } "." } ;
{ $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." } ;
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
65536 <buffer>
dup buffer-read-all
over buffer-capacity
- rot buffer-free
+ rot dispose
] unit-test
[ "hello world" "" ] [
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
! 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 ;
+ swap >>fill 0 >>pos drop ;
-: 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-capacity ( buffer -- n )
+ [ size>> ] [ fill>> ] bi - ; inline
-: buffer@ ( buffer -- alien )
- dup buffer-pos swap buffer-ptr <displaced-alien> ;
+: buffer-empty? ( buffer -- ? )
+ fill>> zero? ;
-: buffer-end ( buffer -- alien )
- dup buffer-fill swap buffer-ptr <displaced-alien> ;
+: buffer-consume ( n buffer -- )
+ [ + ] change-pos
+ dup [ pos>> ] [ fill>> ] bi <
+ [ 0 >>pos 0 >>fill ] unless drop ; inline
: buffer-peek ( buffer -- byte )
- buffer@ 0 alien-unsigned-1 ;
+ [ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: 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-peek ] [ 1 swap buffer-consume ] bi ;
-: buffer-read ( n buffer -- byte-array )
- [ (buffer-read) ] [ buffer-consume ] 2bi ;
+HINTS: buffer-pop buffer ;
: buffer-length ( buffer -- n )
- [ fill>> ] [ pos>> ] bi - ;
+ [ fill>> ] [ pos>> ] bi - ; inline
-: buffer-capacity ( buffer -- n )
- [ size>> ] [ fill>> ] bi - ;
+: buffer@ ( buffer -- alien )
+ [ pos>> ] [ ptr>> ] bi <displaced-alien> ;
-: buffer-empty? ( buffer -- ? )
- fill>> zero? ;
+: 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-end ( buffer -- alien )
+ [ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
+
+: n>buffer ( n buffer -- )
+ [ + ] change-fill
+ [ fill>> ] [ size>> ] bi >
+ [ "Buffer overflow" throw ] when ; inline
: >buffer ( byte-array buffer -- )
- over length over check-overflow
- [ buffer-end byte-array>memory ] 2keep
- [ buffer-fill swap length + ] keep set-buffer-fill ;
+ [ [ length ] dip check-overflow ]
+ [ buffer-end byte-array>memory ]
+ [ [ length ] dip n>buffer ]
+ 2tri ;
-: byte>buffer ( byte buffer -- )
- 1 over check-overflow
- [ buffer-end 0 set-alien-unsigned-1 ] keep
- [ 1+ ] change-fill drop ;
+HINTS: >buffer byte-array buffer ;
-: n>buffer ( n buffer -- )
- [ buffer-fill + ] keep
- [ buffer-size > [ "Buffer overflow" throw ] when ] 2keep
- set-buffer-fill ;
+: 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 } ;
-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
[ "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
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
- [ 8-bit boa ] 2curry dupd curry define ;
+ [ 2drop ] [ 8-bit boa ] 3bi [ ] curry define ;
: 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>
[
<PRIVATE
: encode-if< ( char stream encoding max -- )
- nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
+ nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
: decode-if< ( stream encoding max -- character )
- nip swap stream-read1
- [ tuck > [ drop replacement-char ] unless ]
- [ drop f ] if* ;
+ nip swap stream-read1 dup
+ [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii
[ 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 [
[ 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"
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
- [ drop random-ch ] "" map-as ;
+ [ random-ch ] "" replicate-as ;
: unique-length ( -- n ) 10 ; inline
: unique-retries ( -- n ) 10 ; inline
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.streams.duplex io.ports ;
+io.streams.duplex io.ports debugger prettyprint inspector ;
IN: io.launcher
TUPLE: process < identity-tuple
run-detached
dup detached>> [ dup wait-for-process drop ] unless ;
-ERROR: process-failed code ;
+ERROR: process-failed process code ;
+
+M: process-failed error.
+ dup "Process exited with error code " write code>> . nl
+ "Launch descriptor:" print nl
+ process>> describe ;
: try-process ( desc -- )
- run-process wait-for-process dup zero?
- [ drop ] [ process-failed ] if ;
+ run-process dup wait-for-process dup zero?
+ [ 2drop ] [ process-failed ] if ;
HOOK: kill-process* io-backend ( handle -- )
USING: io.files kernel sequences accessors
-dlists arrays sequences.lib ;
+dlists dequeues arrays sequences.lib ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
dup path>> over push-directory ;
: next-file ( iter -- file/f )
- dup queue>> dlist-empty? [ drop f ] [
+ dup queue>> dequeue-empty? [ drop f ] [
dup queue>> pop-back first2
[ over push-directory next-file ] [ nip ] if
] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
-io splitting sequences sequences.lib namespaces kernel
+io splitting grouping sequences namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
IN: io.pipes
<PRIVATE
-: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
-: ?writer [ <output-port> &dispose ] [ output-stream get ] if* ;
+: ?reader ( handle/f -- stream )
+ [ <input-port> &dispose ] [ input-stream get ] if* ;
+
+: ?writer ( handle/f -- stream )
+ [ <output-port> &dispose ] [ output-stream get ] if* ;
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
- connections>> [ delete-all ] [ dispose-each ] bi
+ connections>> delete-all
] [ drop ] if ;
: <pool> ( class -- pool )
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
+ dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;
HELP: wait-to-read
{ $values { "port" input-port } { "eof?" "a boolean" } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
-
-HELP: can-write?
-{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
-{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
-dlists assocs io.encodings.binary inspector accessors
+grouping dlists assocs io.encodings.binary inspector accessors
destructors ;
IN: io.ports
] [ 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 )
output-port <buffered-port> ;
-: can-write? ( len buffer -- ? )
- [ buffer-fill + ] keep buffer-capacity <= ;
-
: wait-to-write ( len port -- )
- tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
+ tuck buffer>> buffer-capacity <=
+ [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
dup check-disposed
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 ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help help.syntax help.markup io ;
-IN: io.server
-
-HELP: with-server
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
-{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
-
-HELP: with-datagrams
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
-{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;
+++ /dev/null
-IN: io.server.tests
-USING: tools.test io.server io.server.private kernel ;
-
-{ 2 0 } [ [ ] server-loop ] must-infer-as
-{ 2 0 } [ [ ] with-connection ] must-infer-as
-{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
-{ 2 0 } [ [ ] with-datagrams ] must-infer-as
+++ /dev/null
-! Copyright (C) 2003, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.sockets io.sockets.secure io.files
-io.streams.duplex logging continuations destructors kernel math
-math.parser namespaces parser sequences strings prettyprint
-debugger quotations calendar threads concurrency.combinators
-assocs fry ;
-IN: io.server
-
-SYMBOL: servers
-
-SYMBOL: remote-address
-
-<PRIVATE
-
-LOG: accepted-connection NOTICE
-
-: with-connection ( client remote quot -- )
- '[
- , [ remote-address set ] [ accepted-connection ] bi
- @
- ] with-stream ; inline
-
-\ with-connection DEBUG add-error-logging
-
-: accept-loop ( server quot -- )
- [
- >r accept r> '[ , , , with-connection ] "Client" spawn drop
- ] 2keep accept-loop ; inline
-
-: server-loop ( addrspec encoding quot -- )
- >r <server> dup servers get push r>
- '[ , accept-loop ] with-disposal ; inline
-
-\ server-loop NOTICE add-error-logging
-
-PRIVATE>
-
-: local-server ( port -- seq )
- "localhost" swap t resolve-host ;
-
-: internet-server ( port -- seq )
- f swap t resolve-host ;
-
-: secure-server ( port -- seq )
- internet-server [ <secure> ] map ;
-
-: with-server ( seq service encoding quot -- )
- V{ } clone servers [
- '[ , [ , , server-loop ] with-logging ] parallel-each
- ] with-variable ; inline
-
-: stop-server ( -- )
- servers get dispose-each ;
-
-<PRIVATE
-
-LOG: received-datagram NOTICE
-
-: datagram-loop ( quot datagram -- )
- [
- [ receive dup received-datagram >r swap call r> ] keep
- pick [ send ] [ 3drop ] if
- ] 2keep datagram-loop ; inline
-
-: spawn-datagrams ( quot addrspec -- )
- <datagram> [ datagram-loop ] with-disposal ; inline
-
-\ spawn-datagrams NOTICE add-input-logging
-
-PRIVATE>
-
-: with-datagrams ( seq service quot -- )
- '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
+++ /dev/null
-TCP/IP and UDP/IP servers
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help help.syntax help.markup io ;
+IN: io.servers.connection
--- /dev/null
+IN: io.servers.connection
+USING: tools.test io.servers.connection io.sockets namespaces
+io.servers.connection.private kernel accessors sequences
+concurrency.promises io.encodings.ascii io threads calendar ;
+
+[ t ] [ <threaded-server> listen-on empty? ] unit-test
+
+[ f ] [
+ <threaded-server>
+ 25 internet-server >>insecure
+ listen-on
+ empty?
+] unit-test
+
+[ t ] [
+ T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
+ [ log-connection ] 2keep
+ [ remote-address get = ] [ local-address get = ] bi*
+ and
+] unit-test
+
+[ ] [ <threaded-server> init-server drop ] unit-test
+
+[ 10 ] [
+ <threaded-server>
+ 10 >>max-connections
+ init-server semaphore>> count>>
+] unit-test
+
+[ ] [ <promise> "p" set ] unit-test
+
+[ ] [
+ [
+ <threaded-server>
+ 5 >>max-connections
+ 1237 >>insecure
+ [ "Hello world." write stop-server ] >>handler
+ start-server
+ t "p" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
+
+[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
--- /dev/null
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations destructors kernel math math.parser
+namespaces parser sequences strings prettyprint debugger
+quotations combinators combinators.lib logging calendar assocs
+fry accessors arrays io io.sockets io.encodings.ascii
+io.sockets.secure io.files io.streams.duplex io.timeouts
+io.encodings threads concurrency.combinators
+concurrency.semaphores ;
+IN: io.servers.connection
+
+TUPLE: threaded-server
+name
+secure insecure
+secure-config
+sockets
+max-connections
+semaphore
+timeout
+encoding
+handler ;
+
+: local-server ( port -- addrspec ) "localhost" swap <inet> ;
+
+: internet-server ( port -- addrspec ) f swap <inet> ;
+
+: new-threaded-server ( class -- threaded-server )
+ new
+ "server" >>name
+ ascii >>encoding
+ 1 minutes >>timeout
+ V{ } clone >>sockets
+ <secure-config> >>secure-config
+ [ "No handler quotation" throw ] >>handler ; inline
+
+: <threaded-server> ( -- threaded-server )
+ threaded-server new-threaded-server ;
+
+SYMBOL: remote-address
+
+GENERIC: handle-client* ( server -- )
+
+<PRIVATE
+
+: >insecure ( addrspec -- addrspec' )
+ dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
+
+: >secure ( addrspec -- addrspec' )
+ >insecure
+ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
+
+: listen-on ( threaded-server -- addrspecs )
+ [ secure>> >secure ] [ insecure>> >insecure ] bi
+ [ resolve-host ] bi@ append ;
+
+LOG: accepted-connection NOTICE
+
+: log-connection ( remote local -- )
+ [ [ remote-address set ] [ local-address set ] bi* ]
+ [ 2array accepted-connection ]
+ 2bi ;
+
+M: threaded-server handle-client* handler>> call ;
+
+: handle-client ( client remote local -- )
+ '[
+ , , log-connection
+ threaded-server get
+ [ timeout>> timeouts ] [ handle-client* ] bi
+ ] with-stream ;
+
+: thread-name ( server-name addrspec -- string )
+ unparse " connection from " swap 3append ;
+
+: accept-connection ( server -- )
+ [ accept ] [ addr>> ] bi
+ [ '[ , , , handle-client ] ]
+ [ drop threaded-server get name>> swap thread-name ] 2bi
+ spawn drop ;
+
+: accept-loop ( server -- )
+ [
+ threaded-server get semaphore>>
+ [ [ accept-connection ] with-semaphore ]
+ [ accept-connection ]
+ if*
+ ] [ accept-loop ] bi ; inline
+
+: start-accept-loop ( server -- )
+ threaded-server get encoding>> <server>
+ [ threaded-server get sockets>> push ]
+ [ [ accept-loop ] with-disposal ]
+ bi ;
+
+\ start-accept-loop ERROR add-error-logging
+
+: init-server ( threaded-server -- threaded-server )
+ dup semaphore>> [
+ dup max-connections>> [
+ <semaphore> >>semaphore
+ ] when*
+ ] unless ;
+
+PRIVATE>
+
+: start-server ( threaded-server -- )
+ init-server
+ dup secure-config>> [
+ dup threaded-server [
+ dup name>> [
+ listen-on [
+ start-accept-loop
+ ] parallel-each
+ ] with-logging
+ ] with-variable
+ ] with-secure-context ;
+
+: stop-server ( -- )
+ threaded-server get [ f ] change-sockets drop dispose-each ;
+
+GENERIC: port ( addrspec -- n )
+
+M: integer port ;
+
+M: object port port>> ;
+
+: secure-port ( -- n )
+ threaded-server get dup [ secure>> port ] when ;
+
+: insecure-port ( -- n )
+ threaded-server get dup [ insecure>> port ] when ;
--- /dev/null
+Multi-threaded TCP/IP servers
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: io.servers.datagram
+
+<PRIVATE
+
+LOG: received-datagram NOTICE
+
+: datagram-loop ( quot datagram -- )
+ [
+ [ receive dup received-datagram [ swap call ] dip ] keep
+ pick [ send ] [ 3drop ] if
+ ] 2keep datagram-loop ; inline
+
+: spawn-datagrams ( quot addrspec -- )
+ <datagram> [ datagram-loop ] with-disposal ; inline
+
+\ spawn-datagrams NOTICE add-input-logging
+
+PRIVATE>
+
+: with-datagrams ( seq service quot -- )
+ '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
--- /dev/null
+Multi-threaded UDP/IP servers
-! No unit tests here, until Windows SSL is implemented
+IN: io.sockets.secure.tests
+USING: accessors kernel io.sockets io.sockets.secure tools.test ;
+
+[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
-destructors io.sockets sequences inspector calendar ;
+destructors io.sockets sequences inspector calendar delegate ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
C: <secure> secure
-: resolve-secure-host ( host port passive? -- seq )
- resolve-host [ <secure> ] map ;
+CONSULT: inet secure addrspec>> ;
+
+M: secure resolve-host ( secure -- seq )
+ addrspec>> resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
M: secure-inet (client)
[
- addrspec>>
- [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
- host>> pick handle>> check-certificate
+ [ resolve-host (client) [ |dispose ] dip ] keep
+ addrspec>> host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE>
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
}
-"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
+"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
{ $see-also "io.sockets.secure" } ;
ARTICLE: "network-packet" "Packet-oriented networking"
HELP: inet4
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
+"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
}
{ $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" }
HELP: inet6
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
+"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
{ $examples
{ $code "\"::1\" 8080 <inet6>" }
} ;
}
{ $notes
"To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 t resolve-host" }
+ { $code "f 1234 <inet> resolve-host" }
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 t resolve-host" }
- "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
+ { $code "\"localhost\" 1234 <inet> resolve-host" }
+ "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
$nl
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
{ $unchecked-example
}
{ $notes
"To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 t resolve-host" }
+ { $code "f 1234 <inet> resolve-host" }
"To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 t resolve-host" }
+ { $code "\"localhost\" 1234 <inet> resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
"Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
}
{ $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } }
{ $description "Sends a packet to the given address." }
{ $errors "Throws an error if the packet could not be sent." } ;
+
+HELP: resolve-host
+{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
+{ $description "Resolves host names to IP addresses." } ;
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
-[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
+[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser
-alien.c-types math.parser splitting math assocs inspector ;
+alien.c-types math.parser splitting grouping
+math assocs inspector ;
IN: io.sockets
<< {
SYMBOL: port-override
-: (port) port-override get swap or ;
+: (port) ( port -- port' ) port-override get swap or ;
PRIVATE>
[ addrinfo>addrspec ] map
sift ;
-: prepare-resolve-host ( host serv passive? -- host' serv' flags )
+: prepare-resolve-host ( addrspec -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
- >r
- dup integer? [ port-override set "http" ] when
- r> AI_PASSIVE 0 ? ;
+ [ host>> ]
+ [ port>> dup integer? [ port-override set "http" ] when ] bi
+ over 0 AI_PASSIVE ? ;
HOOK: addrinfo-error io-backend ( n -- )
-: resolve-host ( host serv passive? -- seq )
+GENERIC: resolve-host ( addrspec -- seq )
+
+TUPLE: inet host port ;
+
+C: <inet> inet
+
+M: inet resolve-host
[
prepare-resolve-host
"addrinfo" <c-object>
freeaddrinfo
] with-scope ;
+M: f resolve-host drop { } ;
+
+M: object resolve-host 1array ;
+
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;
-TUPLE: inet host port ;
-
-C: <inet> inet
-
-M: inet (client)
- [ host>> ] [ port>> ] bi f resolve-host (client) ;
+M: inet (client) resolve-host (client) ;
ERROR: invalid-inet-server addrspec ;
accessors delegate delegate.protocols ;
IN: io.streams.duplex
-! We ensure that the stream can only be closed once, to preserve
-! integrity of duplex I/O ports.
-
TUPLE: duplex-stream in out ;
C: <duplex-stream> duplex-stream
--- /dev/null
+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
+
+[ "he" CHAR: l ] [
+ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
+ ascii <byte-reader> [
+ 5 limit-input
+ "l" read-until
+ ] with-input-stream
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math io io.encodings 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 ;
+
+GENERIC# limit 1 ( stream limit -- stream' )
+
+M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
+
+M: object limit <limited-stream> ;
+
+: limit-input ( limit -- ) input-stream [ swap limit ] 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 ;
GENERIC: add-input-callback ( thread fd mx -- )
-: add-callback ( thread fd assoc -- )
- [ ?push ] change-at ;
-
-M: mx add-input-callback reads>> add-callback ;
+M: mx add-input-callback reads>> push-at ;
GENERIC: add-output-callback ( thread fd mx -- )
-M: mx add-output-callback writes>> add-callback ;
+M: mx add-output-callback writes>> push-at ;
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
] when* ;
: redirect-fd ( oldfd fd -- )
- 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
+ 2dup = [ 2drop ] [ dup2 io-error ] if ;
: reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of
[ >r >r underlying-handle r> r> redirect ]
} cond ;
-: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
+: ?closed ( obj -- obj' )
+ dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( process -- process )
dup stdin>> ?closed read-flags 0 redirect
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: peg peg.parsers kernel sequences strings words
-memoize ;
+USING: peg peg.parsers kernel sequences strings words ;
IN: io.unix.launcher.parser
! Our command line parser. Supported syntax:
! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation
-MEMO: 'escaped-char' ( -- parser )
- "\\" token [ drop t ] satisfy 2seq [ second ] action ;
+: 'escaped-char' ( -- parser )
+ "\\" token any-char 2seq [ second ] action ;
-MEMO: 'quoted-char' ( delimiter -- parser' )
+: 'quoted-char' ( delimiter -- parser' )
'escaped-char'
swap [ member? not ] curry satisfy
2choice ; inline
-MEMO: 'quoted' ( delimiter -- parser )
+: 'quoted' ( delimiter -- parser )
dup 'quoted-char' repeat0 swap dup surrounded-by ;
-MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
+: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
-MEMO: 'argument' ( -- parser )
+: 'argument' ( -- parser )
"\"" 'quoted'
"'" 'quoted'
'unquoted' 3choice
: <inotify> ( -- port/f )
inotify_init dup 0 < [ drop f ] [ <fd> <input-port> ] if ;
-: inotify-fd inotify get handle>> handle-fd ;
+: inotify-fd ( -- fd ) inotify get handle>> handle-fd ;
: check-existing ( wd -- )
watches get key? [
[ (add-watch) ] [ drop ] 2bi r>
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
-: check-inotify
+: check-inotify ( -- )
inotify get [
"Calling <monitor> outside with-monitors" throw
] unless ;
: init-fdset ( fds fdset -- )
[ >r t swap munge r> set-nth ] curry each ;
-: read-fdset/tasks
+: read-fdset/tasks ( mx -- seq fdset )
[ reads>> keys ] [ read-fdset>> ] bi ;
-: write-fdset/tasks
+: write-fdset/tasks ( mx -- seq fdset )
[ writes>> keys ] [ write-fdset>> ] bi ;
: max-fd ( assoc -- n )
[ ] [ <promise> "port" set ] unit-test
-: with-test-context
+: with-test-context ( quot -- )
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
- swap with-secure-context ;
+ swap with-secure-context ; inline
:: server-test ( quot -- )
[
] with-test-context
] "SSL server test" spawn drop ;
-: client-test
+: client-test ( -- string )
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context ;
dup dup handle>> SSL_connect check-connect-response dup
[ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
+: resume-session ( ssl-handle ssl-session -- )
+ [ [ handle>> ] dip SSL_set_session ssl-error ]
+ [ drop do-ssl-connect ]
+ 2bi ;
+
+: begin-session ( ssl-handle addrspec -- )
+ [ drop do-ssl-connect ]
+ [ [ handle>> SSL_get1_session ] dip save-session ]
+ 2bi ;
+
+: secure-connection ( ssl-handle addrspec -- )
+ dup get-session [ resume-session ] [ begin-session ] ?if ;
+
M: secure establish-connection ( client-out remote -- )
- [ addrspec>> establish-connection ]
+ addrspec>>
+ [ establish-connection ]
[
- drop handle>>
- [ [ do-ssl-connect ] with-timeout ]
- [ t >>connected drop ]
- bi
+ [ handle>> ] dip
+ [ [ secure-connection ] curry with-timeout ]
+ [ drop t >>connected drop ]
+ 2bi
] 2bi ;
M: secure (server) addrspec>> (server) ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
-: WIN32_FIND_DATA>file-info
+: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
[
FindClose win32-error=0/f
] keep ;
-: BY_HANDLE_FILE_INFORMATION>file-info
+: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
[
accessors locals ;
IN: io.windows.mmap
-: create-file-mapping
+: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
-: map-view-of-file
+: map-view-of-file ( hFileMappingObject dwDesiredAccess dwFileOffsetHigh dwFileOffsetLow dwNumberOfBytesToMap -- HANDLE )
MapViewOfFile [ win32-error=0/f ] keep ;
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
{ [ dup right-trim-separators
- { [ dup length 2 = ] [ dup second CHAR: : = ] } && nip ] [
+ { [ dup length 2 = ] [ dup second CHAR: : = ] } 0&& nip ] [
t
] }
[ f ]
[ dup length 2 >= ]
[ dup second CHAR: : = ]
[ dup first Letter? ]
- } && [ 2 head ] [ not-absolute-path ] if ;
+ } 0&& [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [
--- /dev/null
+USING: help.markup help.syntax quotations kernel ;
+IN: irc.client
+
+HELP: irc-client "IRC Client object"
+"blah" ;
+
+HELP: irc-server-listener "Listener for server messages unmanaged by other listeners"
+"blah" ;
+
+HELP: irc-channel-listener "Listener for irc channels"
+"blah" ;
+
+HELP: irc-nick-listener "Listener for irc users"
+"blah" ;
+
+HELP: irc-profile "IRC Client profile object"
+"blah" ;
+
+HELP: connect-irc "Connecting to an irc server"
+{ $values { "irc-client" "an irc client object" } }
+{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
+
+HELP: add-listener "Listening to irc channels/users/etc"
+{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } }
+{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
+
+HELP: terminate-irc "Terminates an irc client"
+{ $values { "irc-client" "an irc client object" } }
+{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
+
+ARTICLE: "irc.client" "IRC Client"
+"An IRC Client library"
+{ $heading "IRC objects:" }
+{ $subsection irc-client }
+{ $heading "Listener objects:" }
+{ $subsection irc-server-listener }
+{ $subsection irc-channel-listener }
+{ $subsection irc-nick-listener }
+{ $heading "Setup objects:" }
+{ $subsection irc-profile }
+{ $heading "Words:" }
+{ $subsection connect-irc }
+{ $subsection terminate-irc }
+{ $subsection add-listener }
+{ $heading "IRC messages" }
+"Some of the RFC defined irc messages as objects:"
+{ $table
+ { { $link irc-message } "base of all irc messages" }
+ { { $link logged-in } "logged in to server" }
+ { { $link ping } "ping message" }
+ { { $link join } "channel join" }
+ { { $link part } "channel part" }
+ { { $link quit } "quit from irc" }
+ { { $link privmsg } "private message (to client or channel)" }
+ { { $link kick } "kick from channel" }
+ { { $link roomlist } "list of participants in channel" }
+ { { $link nick-in-use } "chosen nick is in use by another client" }
+ { { $link notice } "notice message" }
+ { { $link mode } "mode change" }
+ { { $link unhandled } "uninmplemented/unhandled message" }
+ }
+{ $heading "Special messages" }
+"Some special messages that are created by the library and not by the irc server."
+{ $table
+ { { $link irc-end } " sent when the client isn't running anymore, listeners should stop after this." }
+ { { $link irc-disconnected } " sent to notify listeners that connection was lost." }
+ { { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } }
+
+{ $heading "Example:" }
+{ $code
+ "USING: irc.client concurrency.mailboxes ;"
+ "SYMBOL: bot"
+ "SYMBOL: mychannel"
+ "! Create the profile and client objects"
+ "\"irc.freenode.org\" irc-port \"mybot123\" f <irc-profile> <irc-client> bot set"
+ "! Connect to the server"
+ "bot get connect-irc"
+ "! Create a channel listener"
+ "\"#mychannel123\" <irc-channel-listener> mychannel set"
+ "! Register and start listener (this joins the channel)"
+ "bot get mychannel get add-listener"
+ "! Send a message to the channel"
+ "\"what's up?\" mychannel get out-messages>> mailbox-put"
+ "! Read a message from the channel"
+ "mychannel get in-messages>> mailbox-get"
+}
+ ;
+
+ABOUT: "irc.client"
\ No newline at end of file
--- /dev/null
+USING: kernel tools.test accessors arrays sequences qualified
+ io.streams.string io.streams.duplex namespaces threads
+ calendar irc.client.private ;
+EXCLUDE: irc.client => join ;
+IN: irc.client.tests
+
+! Utilities
+: <test-stream> ( lines -- stream )
+ "\n" join <string-reader> <string-writer> <duplex-stream> ;
+
+: make-client ( lines -- irc-client )
+ "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+ swap [ 2nip <test-stream> f ] curry >>connect ;
+
+: set-nick ( irc-client nickname -- )
+ [ nick>> ] dip >>name drop ;
+
+: with-dummy-client ( quot -- )
+ rot with-variable ; inline
+
+! Parsing tests
+irc-message new
+ ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+ "someuser!n=user@some.where" >>prefix
+ "PRIVMSG" >>command
+ { "#factortest" } >>parameters
+ "hi" >>trailing
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ string>irc-message f >>timestamp ] unit-test
+
+privmsg new
+ ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+ "someuser!n=user@some.where" >>prefix
+ "PRIVMSG" >>command
+ { "#factortest" } >>parameters
+ "hi" >>trailing
+ "#factortest" >>name
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ parse-irc-line f >>timestamp ] unit-test
+
+{ "" } make-client dup "factorbot" set-nick current-irc-client [
+ { t } [ irc> nick>> name>> me? ] unit-test
+
+ { "factorbot" } [ irc> nick>> name>> ] unit-test
+
+ { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
+ { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ parse-irc-line irc-message-origin ] unit-test
+
+ { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+ parse-irc-line irc-message-origin ] unit-test
+] with-variable
+
+! Test login and nickname set
+{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..."
+ "NOTICE AUTH :*** Checking ident"
+ "NOTICE AUTH :*** Found your hostname"
+ "NOTICE AUTH :*** No identd (auth) response"
+ ":some.where 001 factorbot :Welcome factorbot"
+ } make-client
+ [ connect-irc ] keep 1 seconds sleep
+ nick>> name>> ] unit-test
+
+! TODO: Channel join messages
+! { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+! ":ircserver.net MODE #factortest +ns"
+! ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+! ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+! ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+! } make-client dup "factorbot" set-nick
+! TODO: user join
+! ":somedude!n=user@isp.net JOIN :#factortest"
+! TODO: channel message
+! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
+! TODO: direct private message
+! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
\ No newline at end of file
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators concurrency.mailboxes concurrency.futures io
+USING: arrays combinators concurrency.mailboxes fry io strings
io.encodings.8-bit io.sockets kernel namespaces sequences
sequences.lib splitting threads calendar classes.tuple
- ascii assocs accessors destructors ;
+ classes ascii assocs accessors destructors continuations ;
IN: irc.client
! ======================================
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
-TUPLE: irc-channel-profile name password ;
-: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
-
! "live" objects
TUPLE: nick name channels log ;
C: <nick> nick
TUPLE: irc-client profile nick stream in-messages out-messages join-messages
- listeners is-running ;
+ listeners is-running connect reconnect-time ;
: <irc-client> ( profile -- irc-client )
f V{ } clone V{ } clone <nick>
- f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+ f <mailbox> <mailbox> <mailbox> H{ } clone f
+ [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
TUPLE: irc-listener in-messages out-messages ;
-: <irc-listener> ( -- irc-listener )
- <mailbox> <mailbox> irc-listener boa ;
+TUPLE: irc-server-listener < irc-listener ;
+TUPLE: irc-channel-listener < irc-listener name password timeout ;
+TUPLE: irc-nick-listener < irc-listener name ;
+UNION: irc-named-listener irc-nick-listener irc-channel-listener ;
+
+: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
+
+: <irc-server-listener> ( -- irc-server-listener )
+ <mailbox> <mailbox> irc-server-listener boa ;
+
+: <irc-channel-listener> ( name -- irc-channel-listener )
+ <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+
+: <irc-nick-listener> ( name -- irc-nick-listener )
+ <mailbox> <mailbox> rot irc-nick-listener boa ;
! ======================================
! Message objects
! ======================================
-SINGLETON: irc-end ! Message used when the client isn't running anymore
+SINGLETON: irc-end ! sent when the client isn't running anymore
+SINGLETON: irc-disconnected ! sent when connection is lost
+SINGLETON: irc-connected ! sent when connection is established
+UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
TUPLE: mode < irc-message name channel mode ;
TUPLE: unhandled < irc-message ;
+: terminate-irc ( irc-client -- )
+ [ in-messages>> irc-end swap mailbox-put ]
+ [ f >>is-running drop ]
+ [ stream>> dispose ]
+ tri ;
+
<PRIVATE
! ======================================
! Shortcuts
! ======================================
-: irc-client> ( -- irc-client ) current-irc-client get ;
-: irc-stream> ( -- stream ) irc-client> stream>> ;
+: irc> ( -- irc-client ) current-irc-client get ;
+: irc-stream> ( -- stream ) irc> stream>> ;
: irc-write ( s -- ) irc-stream> stream-write ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
- <inet> latin1 <client> drop ;
+ irc> connect>> call drop ;
: /JOIN ( channel password -- )
"JOIN " irc-write
: /PONG ( text -- )
"PONG " irc-write irc-print ;
-! ======================================
-! Server message handling
-! ======================================
-
-USE: prettyprint
-
-GENERIC: handle-incoming-irc ( irc-message -- )
-
-M: irc-message handle-incoming-irc ( irc-message -- )
- . ;
-
-M: logged-in handle-incoming-irc ( logged-in -- )
- name>> irc-client> nick>> (>>name) ;
-
-M: ping handle-incoming-irc ( ping -- )
- trailing>> /PONG ;
-
-M: nick-in-use handle-incoming-irc ( nick-in-use -- )
- name>> "_" append /NICK ;
-
-M: privmsg handle-incoming-irc ( privmsg -- )
- dup name>> irc-client> listeners>> at
- [ in-messages>> mailbox-put ] [ drop ] if* ;
-
-M: join handle-incoming-irc ( join -- )
- irc-client> join-messages>> mailbox-put ;
-
-! ======================================
-! Client message handling
-! ======================================
-
-GENERIC: handle-outgoing-irc ( obj -- )
-
-M: privmsg handle-outgoing-irc ( privmsg -- )
- [ name>> ] [ trailing>> ] bi /PRIVMSG ;
-
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
- dupd [ member? ] curry find
+ dupd '[ , member? ] find
[ cut 1 tail ]
[ swap ]
if ;
} case
[ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+! ======================================
+! Server message handling
+! ======================================
+
+: me? ( string -- ? )
+ irc> nick>> name>> = ;
+
+: irc-message-origin ( irc-message -- name )
+ dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
+
+: broadcast-message-to-listeners ( message -- )
+ irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
+
+GENERIC: handle-incoming-irc ( irc-message -- )
+
+M: irc-message handle-incoming-irc ( irc-message -- )
+ f irc> listeners>> at
+ [ in-messages>> mailbox-put ] [ drop ] if* ;
+
+M: logged-in handle-incoming-irc ( logged-in -- )
+ name>> irc> nick>> (>>name) ;
+
+M: ping handle-incoming-irc ( ping -- )
+ trailing>> /PONG ;
+
+M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+ name>> "_" append /NICK ;
+
+M: privmsg handle-incoming-irc ( privmsg -- )
+ dup irc-message-origin irc> listeners>> [ at ] keep
+ '[ f , at ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ;
+
+M: join handle-incoming-irc ( join -- )
+ irc> join-messages>> mailbox-put ;
+
+M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
+ broadcast-message-to-listeners ;
+
+! ======================================
+! Client message handling
+! ======================================
+
+GENERIC: handle-outgoing-irc ( obj -- )
+
+M: privmsg handle-outgoing-irc ( privmsg -- )
+ [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
! ======================================
! Reader/Writer
! ======================================
-: stream-readln-or-close ( stream -- str/f )
- dup stream-readln [ nip ] [ dispose f ] if* ;
+: irc-mailbox-get ( mailbox quot -- )
+ swap 5 seconds
+ '[ , , , mailbox-get-timeout swap call ]
+ [ drop ] recover ; inline
: handle-reader-message ( irc-message -- )
- irc-client> in-messages>> mailbox-put ;
+ irc> in-messages>> mailbox-put ;
+
+DEFER: (connect-irc)
-: handle-stream-close ( -- )
- irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
+: (handle-disconnect) ( -- )
+ irc>
+ [ in-messages>> irc-disconnected swap mailbox-put ]
+ [ dup reconnect-time>> sleep (connect-irc) ]
+ [ profile>> nickname>> /LOGIN ]
+ tri ;
+
+: handle-disconnect ( error -- )
+ drop irc> is-running>> [ (handle-disconnect) ] when ;
+
+: (reader-loop) ( -- )
+ irc> stream>> [
+ |dispose stream-readln [
+ parse-irc-line handle-reader-message
+ ] [
+ irc> terminate-irc
+ ] if*
+ ] with-destructors ;
: reader-loop ( -- )
- irc-client> stream>> stream-readln-or-close [
- parse-irc-line handle-reader-message
- ] [
- handle-stream-close
- ] if* ;
+ [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- )
- irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
+ irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- )
- irc-client> in-messages>> mailbox-get handle-incoming-irc ;
-
-! FIXME: Hack, this should be handled better
-GENERIC: add-name ( name obj -- obj )
-M: object add-name nip ;
-M: privmsg add-name swap >>name ;
-
-: listener-loop ( name -- ) ! FIXME: take different values from the stack?
- dup irc-client> listeners>> at [
- out-messages>> mailbox-get add-name
- irc-client> out-messages>>
- mailbox-put
- ] [ drop ] if* ;
+ irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
+
+: strings>privmsg ( name string -- privmsg )
+ privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
+
+: maybe-annotate-with-name ( name obj -- obj )
+ {
+ { [ dup string? ] [ strings>privmsg ] }
+ { [ dup privmsg instance? ] [ swap >>name ] }
+ } cond ;
+
+: listener-loop ( name listener -- )
+ out-messages>> swap
+ '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ]
+ irc-mailbox-get ;
: spawn-irc-loop ( quot name -- )
- [ [ irc-client> is-running>> ] compose ] dip
+ [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
spawn-server drop ;
: spawn-irc ( -- )
! Listener join request handling
! ======================================
-: make-registered-listener ( join -- listener )
- <irc-listener> swap trailing>>
- dup [ listener-loop ] curry "listener" spawn-irc-loop
- [ irc-client> listeners>> set-at ] curry keep ;
+: set+run-listener ( name irc-listener -- )
+ [ '[ , , listener-loop ] "listener" spawn-irc-loop ]
+ [ swap irc> listeners>> set-at ]
+ 2bi ;
-: make-join-future ( name -- future )
- [ [ swap trailing>> = ] curry ! compare name with channel name
- irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
- make-registered-listener ]
- curry future ;
+GENERIC: (add-listener) ( irc-listener -- )
+M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
+ [ [ name>> ] [ password>> ] bi /JOIN ]
+ [ [ [ drop irc> join-messages>> ]
+ [ timeout>> ]
+ [ name>> '[ trailing>> , = ] ]
+ tri mailbox-get-timeout? trailing>> ] keep set+run-listener
+ ] bi ;
-PRIVATE>
+M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
+ [ name>> ] keep set+run-listener ;
+
+M: irc-server-listener (add-listener) ( irc-server-listener -- )
+ f swap set+run-listener ;
: (connect-irc) ( irc-client -- )
- [ profile>> [ server>> ] keep port>> /CONNECT ] keep
- swap >>stream
- t >>is-running drop ;
+ [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
+ swap >>stream
+ t >>is-running
+ in-messages>> irc-connected swap mailbox-put ;
+
+PRIVATE>
: connect-irc ( irc-client -- )
dup current-irc-client [
spawn-irc
] with-variable ;
-: listen-to ( irc-client name -- future )
- swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
-
-! shorcut for privmsgs, etc
-: sender>> ( obj -- string )
- prefix>> parse-name ;
+GENERIC: add-listener ( irc-client irc-listener -- )
+M: irc-listener add-listener ( irc-client irc-listener -- )
+ current-irc-client swap '[ , (add-listener) ] with-variable ;
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types colors jamshred.game jamshred.oint
-jamshred.player jamshred.tunnel kernel math math.vectors opengl
-opengl.gl opengl.glu sequences ;
+USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ;
IN: jamshred.gl
: min-vertices 6 ; inline
: n-segments-ahead ( -- n ) 60 ; inline
: n-segments-behind ( -- n ) 40 ; inline
+: wall-drawing-offset ( -- n )
+ #! so that we can't see through the wall, we draw it a bit further away
+ 0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ dup [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
over segment-color gl-color segment-vertex-and-normal
gl-normal gl-vertex ;
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures
-: jamshred-window ( -- )
- [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
+: jamshred-window ( -- jamshred )
+ [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
MAIN: jamshred-window
: random-turn ( oint theta -- )
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
+ [ forward>> n*v ] [ location+ ] bi ;
: distance-vector ( oint oint -- vector )
[ location>> ] bi@ swap v- ;
:: reflect ( v n -- v' )
#! bounce v on a surface with normal n
v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
+USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ;
+USE: tools.walker
IN: jamshred.player
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
[ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
[ (>>nearest-segment) ] tri ;
+: update-time ( player -- seconds-passed )
+ millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
: moved ( player -- ) millis swap (>>last-move) ;
: speed-range ( -- range )
: multiply-player-speed ( n player -- )
[ * speed-range clamp-to-range ] change-speed drop ;
-: distance-to-move ( player -- distance )
- [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
- [ (>>last-move) ] tri ;
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
-DEFER: (move-player)
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
-: ?bounce ( distance-remaining player -- )
- over 0 > [
- {
- [ dup nearest-segment>> bounce ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ (move-player) ]
- } cleave
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
] [
2drop
] if ;
-: move-player-distance ( distance-remaining player distance -- distance-remaining player )
- pick min tuck over go-forward [ - ] dip ;
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
-: (move-player) ( distance-remaining player -- )
- over 0 <= [
- 2drop
- ] [
- dup dup nearest-segment>> distance-to-collision
- move-player-distance ?bounce
- ] if ;
+: move-toward-wall ( d-left player d-to-wall -- d-left' player )
+ over [ forward>> ] keep distance-to-heading-segment-area min
+ over forward>> move-player-on-heading ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
+ move-toward-wall ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
: move-player ( player -- )
- [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
: update-player ( player -- )
- dup move-player nearest-segment>>
- white swap set-segment-color ;
+ [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
[ { 0 1 0 } ]
-[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USE: tools.walker
IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline
TUPLE: segment < oint number color radius ;
C: <segment> segment
-: segment-vertex ( theta segment -- vertex )
- tuck 2dup up>> swap sin v*n
- >r left>> swap cos v*n r> v+
- swap location>> v+ ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-
: segment-number++ ( segment -- )
[ number>> 1+ ] keep (>>number) ;
: (random-segments) ( segments n -- segments )
dup 0 > [
>r dup peek random-segment over push r> 1- (random-segments)
- ] [
- drop
- ] if ;
+ ] [ drop ] if ;
: default-segment-radius ( -- r ) 1 ;
: <straight-tunnel> ( -- segments )
n-segments simple-segments ;
-: sub-tunnel ( from to sements -- segments )
+: sub-tunnel ( from to segments -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
[ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
[ nearest-segment-forward ] 3keep
nearest-segment-backward r> nearer-segment ;
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
: vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
: wall-normal ( seg oint -- n )
location>> vector-to-centre normalize ;
-: from ( seg loc -- radius d-f-c )
- dupd location>> distance-from-centre [ radius>> ] dip ;
+: distant ( -- n ) 1000 ;
-: distance-from-wall ( seg loc -- distance ) from - ;
-: fraction-from-centre ( seg loc -- fraction ) from / ;
-: fraction-from-wall ( seg loc -- fraction )
- fraction-from-centre 1 swap - ;
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
:: collision-coefficient ( v w r -- c )
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max ] ;
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
: sideways-heading ( oint segment -- v )
[ forward>> ] bi@ proj-perp ;
: sideways-relative-location ( oint segment -- loc )
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-: bounce-offset 0.1 ; inline
-
-: bounce-radius ( segment -- r )
- radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?)
-
-: collision-vector ( oint segment -- v )
+: (distance-to-collision) ( oint segment -- distance )
[ sideways-heading ] [ sideways-relative-location ]
- [ bounce-radius ] 2tri
- swap [ collision-coefficient ] dip forward>> n*v ;
+ [ nip radius>> ] 2tri collision-coefficient ;
-: distance-to-collision ( oint segment -- distance )
- collision-vector norm ;
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
#! must be done after forward and left!
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-: bounce ( oint segment -- )
+: bounce-off-wall ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order
- lazy-lists hashtables ascii ;
+ lists hashtables ascii ;
IN: json.reader
! Grammar for JSON from RFC 4627
IN: koszul
! Utilities
-: -1^ odd? -1 1 ? ;
+: -1^ ( m -- n ) odd? -1 1 ? ;
: >alt ( obj -- vec )
{
[ 1array >alt ]
} cond ;
-: canonicalize
+: canonicalize ( assoc -- assoc' )
[ nip zero? not ] assoc-filter ;
SYMBOL: terms
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
+ dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
[ v- ] 2map ;
! Laplacian
-: m.m' dup flip m. ;
-: m'.m dup flip swap m. ;
+: m.m' ( matrix -- matrix' ) dup flip m. ;
+: m'.m ( matrix -- matrix' ) dup flip swap m. ;
: empty-matrix? ( matrix -- ? )
dup empty? [ drop t ] [ first empty? ] if ;
+++ /dev/null
-Chris Double
-Samuel Tardieu
-Matthew Willis
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: lazy-lists.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
-
-[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
-[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
+++ /dev/null
-! Rewritten by Matthew Willis, July 2006
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: lazy-lists math kernel sequences quotations ;
-IN: lazy-lists.examples
-
-: naturals 0 lfrom ;
-: positives 1 lfrom ;
-: evens 0 [ 2 + ] lfrom-by ;
-: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
-: powers-of-2 1 [ 2 * ] lfrom-by ;
-: ones 1 [ ] lfrom-by ;
-: squares naturals [ dup * ] lmap ;
-: first-five-squares 5 squares ltake list>array ;
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: help.markup help.syntax sequences strings ;
-IN: lazy-lists
-
-{ car cons cdr nil nil? list? uncons } related-words
-
-HELP: cons
-{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
-{ $description "Constructs a cons cell." } ;
-
-HELP: car
-{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
-{ $description "Returns the first item in the list." } ;
-
-HELP: cdr
-{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
-{ $description "Returns the tail of the list." } ;
-
-HELP: nil
-{ $values { "cons" "An empty cons" } }
-{ $description "Returns a representation of an empty list" } ;
-
-HELP: nil?
-{ $values { "cons" "a cons object" } { "?" "a boolean" } }
-{ $description "Return true if the cons object is the nil cons." } ;
-
-HELP: list? ( object -- ? )
-{ $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } ;
-
-{ 1list 2list 3list } related-words
-
-HELP: 1list
-{ $values { "obj" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 1 element." } ;
-
-HELP: 2list
-{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 2 elements." } ;
-
-HELP: 3list
-{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 3 elements." } ;
-
-HELP: lazy-cons
-{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
-{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
-{ $see-also cons car cdr nil nil? } ;
-
-{ 1lazy-list 2lazy-list 3lazy-list } related-words
-
-HELP: 1lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
-
-HELP: 2lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: 3lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: <memoized-cons>
-{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
-{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
-{ $see-also cons car cdr nil nil? } ;
-
-HELP: lnth
-{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
-{ $description "Outputs the nth element of the list." }
-{ $see-also llength cons car cdr } ;
-
-HELP: llength
-{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
-{ $description "Outputs the length of the list. This should not be called on an infinite list." }
-{ $see-also lnth cons car cdr } ;
-
-HELP: uncons
-{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
-{ $description "Put the head and tail of the list on the stack." } ;
-
-{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
-
-HELP: leach
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
-{ $description "Call the quotation for each item in the list." } ;
-
-HELP: lreduce
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
-{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
-
-HELP: lmap
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lmap-with
-{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
-{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
-
-HELP: ltake
-{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lfilter
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: lwhile
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: luntil
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: list>vector
-{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
-{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>array } ;
-
-HELP: list>array
-{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
-{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>vector } ;
-
-HELP: lappend
-{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
-
-HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
-
-HELP: lfrom
-{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
-
-HELP: seq>list
-{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
-{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
-{ $see-also >list } ;
-
-HELP: >list
-{ $values { "object" "an object" } { "list" "a list" } }
-{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
-{ $see-also seq>list } ;
-
-HELP: lconcat
-{ $values { "list" "a list of lists" } { "result" "a list" } }
-{ $description "Concatenates a list of lists together into one list." } ;
-
-HELP: lcartesian-product
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
-{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcartesian-product*
-{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
-{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
-
-HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
-{ $examples
- { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
-} ;
-
-HELP: lmerge
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
-{ $description "Return the result of merging the two lists in a lazy manner." }
-{ $examples
- { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
-} ;
-
-HELP: lcontents
-{ $values { "stream" "a stream" } { "result" string } }
-{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also llines } ;
-
-HELP: llines
-{ $values { "stream" "a stream" } { "result" "a list" } }
-{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also lcontents } ;
-
+++ /dev/null
-! Copyright (C) 2006 Matthew Willis and Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: lazy-lists tools.test kernel math io sequences ;
-IN: lazy-lists.tests
-
-[ { 1 2 3 4 } ] [
- { 1 2 3 4 } >list list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
-] unit-test
-
-[ { 5 6 6 7 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
-] unit-test
-
-[ { 5 6 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
-] unit-test
-
-[ { 4 5 6 } ] [
- 3 { 1 2 3 } >list [ + ] lmap-with list>array
-] unit-test
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-!
-USING: kernel sequences math vectors arrays namespaces
-quotations promises combinators io ;
-IN: lazy-lists
-
-! Lazy List Protocol
-MIXIN: list
-GENERIC: car ( cons -- car )
-GENERIC: cdr ( cons -- cdr )
-GENERIC: nil? ( cons -- ? )
-
-M: promise car ( promise -- car )
- force car ;
-
-M: promise cdr ( promise -- cdr )
- force cdr ;
-
-M: promise nil? ( cons -- bool )
- force nil? ;
-
-TUPLE: cons car cdr ;
-
-C: cons cons
-
-M: cons car ( cons -- car )
- cons-car ;
-
-M: cons cdr ( cons -- cdr )
- cons-cdr ;
-
-: nil ( -- cons )
- T{ cons f f f } ;
-
-M: cons nil? ( cons -- bool )
- nil eq? ;
-
-: 1list ( obj -- cons )
- nil cons ;
-
-: 2list ( a b -- cons )
- nil cons cons ;
-
-: 3list ( a b c -- cons )
- nil cons cons cons ;
-
-! Both 'car' and 'cdr' are promises
-TUPLE: lazy-cons car cdr ;
-
-: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons boa
- T{ promise f f t f } clone
- [ set-promise-value ] keep ;
-
-M: lazy-cons car ( lazy-cons -- car )
- lazy-cons-car force ;
-
-M: lazy-cons cdr ( lazy-cons -- cdr )
- lazy-cons-cdr force ;
-
-M: lazy-cons nil? ( lazy-cons -- bool )
- nil eq? ;
-
-: 1lazy-list ( a -- lazy-cons )
- [ nil ] lazy-cons ;
-
-: 2lazy-list ( a b -- lazy-cons )
- 1lazy-list 1quotation lazy-cons ;
-
-: 3lazy-list ( a b c -- lazy-cons )
- 2lazy-list 1quotation lazy-cons ;
-
-: lnth ( n list -- elt )
- swap [ cdr ] times car ;
-
-: (llength) ( list acc -- n )
- over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
-
-: llength ( list -- n )
- 0 (llength) ;
-
-: uncons ( cons -- car cdr )
- #! Return the car and cdr of the lazy list
- dup car swap cdr ;
-
-: leach ( list quot -- )
- swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
-
-: lreduce ( list identity quot -- result )
- swapd leach ; inline
-
-TUPLE: memoized-cons original car cdr nil? ;
-
-: not-memoized ( -- obj )
- { } ;
-
-: not-memoized? ( obj -- bool )
- not-memoized eq? ;
-
-: <memoized-cons> ( cons -- memoized-cons )
- not-memoized not-memoized not-memoized
- memoized-cons boa ;
-
-M: memoized-cons car ( memoized-cons -- car )
- dup memoized-cons-car not-memoized? [
- dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
- ] [
- memoized-cons-car
- ] if ;
-
-M: memoized-cons cdr ( memoized-cons -- cdr )
- dup memoized-cons-cdr not-memoized? [
- dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
- ] [
- memoized-cons-cdr
- ] if ;
-
-M: memoized-cons nil? ( memoized-cons -- bool )
- dup memoized-cons-nil? not-memoized? [
- dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
- ] [
- memoized-cons-nil?
- ] if ;
-
-TUPLE: lazy-map cons quot ;
-
-C: <lazy-map> lazy-map
-
-: lmap ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
-
-M: lazy-map car ( lazy-map -- car )
- [ lazy-map-cons car ] keep
- lazy-map-quot call ;
-
-M: lazy-map cdr ( lazy-map -- cdr )
- [ lazy-map-cons cdr ] keep
- lazy-map-quot lmap ;
-
-M: lazy-map nil? ( lazy-map -- bool )
- lazy-map-cons nil? ;
-
-: lmap-with ( value list quot -- result )
- with lmap ;
-
-TUPLE: lazy-take n cons ;
-
-C: <lazy-take> lazy-take
-
-: ltake ( n list -- result )
- over zero? [ 2drop nil ] [ <lazy-take> ] if ;
-
-M: lazy-take car ( lazy-take -- car )
- lazy-take-cons car ;
-
-M: lazy-take cdr ( lazy-take -- cdr )
- [ lazy-take-n 1- ] keep
- lazy-take-cons cdr ltake ;
-
-M: lazy-take nil? ( lazy-take -- bool )
- dup lazy-take-n zero? [
- drop t
- ] [
- lazy-take-cons nil?
- ] if ;
-
-TUPLE: lazy-until cons quot ;
-
-C: <lazy-until> lazy-until
-
-: luntil ( list quot -- result )
- over nil? [ drop ] [ <lazy-until> ] if ;
-
-M: lazy-until car ( lazy-until -- car )
- lazy-until-cons car ;
-
-M: lazy-until cdr ( lazy-until -- cdr )
- [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
- [ 2drop nil ] [ luntil ] if ;
-
-M: lazy-until nil? ( lazy-until -- bool )
- drop f ;
-
-TUPLE: lazy-while cons quot ;
-
-C: <lazy-while> lazy-while
-
-: lwhile ( list quot -- result )
- over nil? [ drop ] [ <lazy-while> ] if ;
-
-M: lazy-while car ( lazy-while -- car )
- lazy-while-cons car ;
-
-M: lazy-while cdr ( lazy-while -- cdr )
- [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
-
-M: lazy-while nil? ( lazy-while -- bool )
- [ car ] keep lazy-while-quot call not ;
-
-TUPLE: lazy-filter cons quot ;
-
-C: <lazy-filter> lazy-filter
-
-: lfilter ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
-
-: car-filter? ( lazy-filter -- ? )
- [ lazy-filter-cons car ] keep
- lazy-filter-quot call ;
-
-: skip ( lazy-filter -- )
- [ lazy-filter-cons cdr ] keep
- set-lazy-filter-cons ;
-
-M: lazy-filter car ( lazy-filter -- car )
- dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
-
-M: lazy-filter cdr ( lazy-filter -- cdr )
- dup car-filter? [
- [ lazy-filter-cons cdr ] keep
- lazy-filter-quot lfilter
- ] [
- dup skip cdr
- ] if ;
-
-M: lazy-filter nil? ( lazy-filter -- bool )
- dup lazy-filter-cons nil? [
- drop t
- ] [
- dup car-filter? [
- drop f
- ] [
- dup skip nil?
- ] if
- ] if ;
-
-: list>vector ( list -- vector )
- [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
- [ [ , ] leach ] { } make ;
-
-TUPLE: lazy-append list1 list2 ;
-
-C: <lazy-append> lazy-append
-
-: lappend ( list1 list2 -- result )
- over nil? [ nip ] [ <lazy-append> ] if ;
-
-M: lazy-append car ( lazy-append -- car )
- lazy-append-list1 car ;
-
-M: lazy-append cdr ( lazy-append -- cdr )
- [ lazy-append-list1 cdr ] keep
- lazy-append-list2 lappend ;
-
-M: lazy-append nil? ( lazy-append -- bool )
- drop f ;
-
-TUPLE: lazy-from-by n quot ;
-
-C: lfrom-by lazy-from-by ( n quot -- list )
-
-: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
-
-M: lazy-from-by car ( lazy-from-by -- car )
- lazy-from-by-n ;
-
-M: lazy-from-by cdr ( lazy-from-by -- cdr )
- [ lazy-from-by-n ] keep
- lazy-from-by-quot dup slip lfrom-by ;
-
-M: lazy-from-by nil? ( lazy-from-by -- bool )
- drop f ;
-
-TUPLE: lazy-zip list1 list2 ;
-
-C: <lazy-zip> lazy-zip
-
-: lzip ( list1 list2 -- lazy-zip )
- over nil? over nil? or
- [ 2drop nil ] [ <lazy-zip> ] if ;
-
-M: lazy-zip car ( lazy-zip -- car )
- [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
-
-M: lazy-zip cdr ( lazy-zip -- cdr )
- [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
-
-M: lazy-zip nil? ( lazy-zip -- bool )
- drop f ;
-
-TUPLE: sequence-cons index seq ;
-
-C: <sequence-cons> sequence-cons
-
-: seq>list ( index seq -- list )
- 2dup length >= [
- 2drop nil
- ] [
- <sequence-cons>
- ] if ;
-
-M: sequence-cons car ( sequence-cons -- car )
- [ sequence-cons-index ] keep
- sequence-cons-seq nth ;
-
-M: sequence-cons cdr ( sequence-cons -- cdr )
- [ sequence-cons-index 1+ ] keep
- sequence-cons-seq seq>list ;
-
-M: sequence-cons nil? ( sequence-cons -- bool )
- drop f ;
-
-: >list ( object -- list )
- {
- { [ dup sequence? ] [ 0 swap seq>list ] }
- { [ dup list? ] [ ] }
- [ "Could not convert object to a list" throw ]
- } cond ;
-
-TUPLE: lazy-concat car cdr ;
-
-C: <lazy-concat> lazy-concat
-
-DEFER: lconcat
-
-: (lconcat) ( car cdr -- list )
- over nil? [
- nip lconcat
- ] [
- <lazy-concat>
- ] if ;
-
-: lconcat ( list -- result )
- dup nil? [
- drop nil
- ] [
- uncons (lconcat)
- ] if ;
-
-M: lazy-concat car ( lazy-concat -- car )
- lazy-concat-car car ;
-
-M: lazy-concat cdr ( lazy-concat -- cdr )
- [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
-
-M: lazy-concat nil? ( lazy-concat -- bool )
- dup lazy-concat-car nil? [
- lazy-concat-cdr nil?
- ] [
- drop f
- ] if ;
-
-: lcartesian-product ( list1 list2 -- result )
- swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
-
-: lcartesian-product* ( lists -- result )
- dup nil? [
- drop nil
- ] [
- [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
- swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
- ] reduce
- ] if ;
-
-: lcomp ( list quot -- result )
- [ lcartesian-product* ] dip lmap ;
-
-: lcomp* ( list guards quot -- result )
- [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
-
-DEFER: lmerge
-
-: (lmerge) ( list1 list2 -- result )
- over [ car ] curry -rot
- [
- dup [ car ] curry -rot
- [
- [ cdr ] bi@ lmerge
- ] 2curry lazy-cons
- ] 2curry lazy-cons ;
-
-: lmerge ( list1 list2 -- result )
- {
- { [ over nil? ] [ nip ] }
- { [ dup nil? ] [ drop ] }
- { [ t ] [ (lmerge) ] }
- } cond ;
-
-TUPLE: lazy-io stream car cdr quot ;
-
-C: <lazy-io> lazy-io
-
-: lcontents ( stream -- result )
- f f [ stream-read1 ] <lazy-io> ;
-
-: llines ( stream -- result )
- f f [ stream-readln ] <lazy-io> ;
-
-M: lazy-io car ( lazy-io -- car )
- dup lazy-io-car dup [
- nip
- ] [
- drop dup lazy-io-stream over lazy-io-quot call
- swap dupd set-lazy-io-car
- ] if ;
-
-M: lazy-io cdr ( lazy-io -- cdr )
- dup lazy-io-cdr dup [
- nip
- ] [
- drop dup
- [ lazy-io-stream ] keep
- [ lazy-io-quot ] keep
- car [
- [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
- ] [
- 3drop nil
- ] if
- ] if ;
-
-M: lazy-io nil? ( lazy-io -- bool )
- car not ;
-
-INSTANCE: cons list
-INSTANCE: sequence-cons list
-INSTANCE: memoized-cons list
-INSTANCE: promise list
-INSTANCE: lazy-io list
-INSTANCE: lazy-concat list
-INSTANCE: lazy-cons list
-INSTANCE: lazy-map list
-INSTANCE: lazy-take list
-INSTANCE: lazy-append list
-INSTANCE: lazy-from-by list
-INSTANCE: lazy-zip list
-INSTANCE: lazy-while list
-INSTANCE: lazy-until list
-INSTANCE: lazy-filter list
+++ /dev/null
-<html>
- <head>
- <title>Lazy Evaluation</title>
- <link rel="stylesheet" type="text/css" href="style.css">
- </head>
- <body>
- <h1>Lazy Evaluation</h1>
-<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
- ability to describe infinite structures, and to delay execution of
- expressions until they are actually used.</p>
-<p>Lazy lists, like normal lists, are composed of a head and tail. In
- a lazy list the head and tail are something called a 'promise'.
- To convert a
- 'promise' into its actual value a word called 'force' is used. To
- convert a value into a 'promise' the word to use is 'delay'.</p>
-<table border="1">
-<tr><td><a href="#delay">delay</a></td></tr>
-<tr><td><a href="#force">force</a></td></tr>
-</table>
-
-<p>Many of the lazy list words are named similar to the standard list
- words but with an 'l' suffixed to it. Here are the commonly used
- words and their equivalent list operation:</p>
-<table border="1">
-<tr><th>Lazy List</th><th>Normal List</th></tr>
-<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
-<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
-<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
-<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
-<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
-<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
-<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
-<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
-<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
-<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
-<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
-<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
-</table>
-<p>A few additional words specific to lazy lists are:</p>
-<table border="1">
-<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
-number of items from the lazy list.</td></tr>
-<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
-concatenate them together in a lazy manner, returning a single lazy
-list.</td></tr>
-<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
-that contains the same elements as the normal list.</td></tr>
-</table>
-<h2>Reference</h2>
-<!-- delay description -->
-<a name="delay">
-<h3>delay ( quot -- <promise> )</h3>
-<p>'delay' is used to convert a value or expression into a promise.
- The word 'force' is used to convert that promise back to its
- value, or to force evaluation of the expression to return a value.
-</p>
-<p>The value on the stack that 'delay' expects must be quoted. This is
- a requirement to prevent it from being evaluated.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- force description -->
-<a name="force">
-<h3>force ( <promise> -- value )</h3>
-<p>'force' will evaluate a promises original expression
- and leave the value of that expression on the stack.
-</p>
-<p>A promise can be forced multiple times but the expression
- is only evaluated once. Future calls of 'force' on the promise
- will returned the cached value of the original force. If the
- expression contains side effects, such as i/o, then that i/o
- will only occur on the first 'force'. See below for an example
- (steps 3-5).
-</p>
-<p>If a promise is itself delayed, a force will evaluate all promises
- until a value is returned. Due to this behaviour it is generally not
- possible to delay a promise. The example below shows what happens
- in this case.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-
- #! Multiple forces on a promise returns cached value
- ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
- ( 4 ) dup <a href="#force">force</a> .
- => hello
- 42
- ( 5 ) <a href="#force">force</a> .
- => 42
-
- #! Forcing a delayed promise cascades up to return
- #! original value, rather than the promise.
- ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
- ( 7 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- lnil description -->
-<a name="lnil">
-<h3>lnil ( -- lcons )</h3>
-<p>Returns a value representing the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> .
- => << promise [ ] [ [ ] ] t [ ] >>
-</pre>
-
-<!-- lnil description -->
-<a name="lnilp">
-<h3>lnil? ( lcons -- bool )</h3>
-<p>Returns true if the given lazy cons is the value representing
- the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
- => [ ]
- ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
-</pre>
-
-<!-- lcons description -->
-<a name="lcons">
-<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
-<p>Provides the same effect as 'cons' does for normal lists.
- Both values provided must be promises (ie. expressions that have
- had <a href="#delay">delay</a> called on them).
-</p>
-<p>As the car and cdr passed on the stack are promises, they are not
- evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
- are called on the lazy cons.</p>
-<pre class="code">
- ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => "car"
- ( 3 ) dup <a href="#lcdr">lcdr</a> .
- => "cdr"
-</pre>
-
-<!-- lunit description -->
-<a name="lunit">
-<h3>lunit ( value-promise -- llist )</h3>
-<p>Provides the same effect as 'unit' does for normal lists. It
-creates a lazy list where the first element is the value given.</p>
-<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
- a promise and is not evaluated until the <a href="#lcar">lcar</a>
- of the list is requested.</a>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => 42
- ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 4 ) [ . ] <a href="#leach">leach</a>
- => 42
-</pre>
-
-<!-- lcar description -->
-<a name="lcar">
-<h3>lcar ( lcons -- value )</h3>
-<p>Provides the same effect as 'car' does for normal lists. It
-returns the first element in a lazy cons cell. This will force
-the evaluation of that element.</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcar">lcar</a> .
- => 42
-</pre>
-
-<!-- lcdr description -->
-<a name="lcdr">
-<h3>lcdr ( lcons -- value )</h3>
-<p>Provides the same effect as 'cdr' does for normal lists. It
-returns the second element in a lazy cons cell and forces it. This
-causes that element to be evaluated immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> .
- => 11
-</pre>
-
-<pre class="code">
- ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 6
- ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 7
- ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 8
-</pre>
-
-<!-- lnth description -->
-<a name="lnth">
-<h3>lnth ( n llist -- value )</h3>
-<p>Provides the same effect as 'nth' does for normal lists. It
-returns the nth value in the lazy list. It causes all the values up to
-'n' to be evaluated.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) 5 swap <a href="#lnth">lnth</a> .
- => 6
-</pre>
-
-<!-- luncons description -->
-<a name="luncons">
-<h3>luncons ( lcons -- car cdr )</h3>
-<p>Provides the same effect as 'uncons' does for normal lists. It
-returns the car and cdr of the lazy list.</p>
-<pre class="code">
- ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#luncons">luncons</a> . .
- => 6
- 5
-</pre>
-
-<!-- lmap description -->
-<a name="lmap">
-<h3>lmap ( llist quot -- llist )</h3>
-<p>Lazily maps over a lazy list applying the quotation to each element.
-A new lazy list is returned which contains the results of the
-quotation.</p>
-<p>When intially called nothing in the original lazy list is
-evaluated. Only when <a href="#lcar">lcar</a> is called will the item
-in the list be evaluated and applied to the quotation. Ditto with <a
-href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
- => < infinite list of numbers incrementing by 2 >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 4 6 8 10 ]
-</pre>
-
-<!-- lsubset description -->
-<a name="lsubset">
-<h3>lsubset ( llist pred -- llist )</h3>
-<p>Provides the same effect as 'subset' does for normal lists. It
-lazily iterates over a lazy list applying the predicate quotation to each
-element. If that quotation returns true, the element will be included
-in the resulting lazy list. If it is false, the element will be skipped.
-A new lazy list is returned which contains all elements where the
-predicate returned true.</p>
-<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
-will occur. A lazy list is returned that when values are retrieved
-from in then items are evaluated and checked against the predicate.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
- => < infinite list of prime numbers >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 3 5 7 11 ]
-</pre>
-
-<!-- leach description -->
-<a name="leach">
-<h3>leach ( llist quot -- )</h3>
-<p>Provides the same effect as 'each' does for normal lists. It
-lazily iterates over a lazy list applying the quotation to each
-element. If this operation is applied to an infinite list it will
-never return unless the quotation escapes out by calling a continuation.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
- => < infinite list of odd numbers >
- ( 3 ) [ . ] <a href="#leach">leach</a>
- => 1
- 3
- 5
- 7
- ... for ever ...
-</pre>
-
-<!-- ltake description -->
-<a name="ltake">
-<h3>ltake ( n llist -- llist )</h3>
-<p>Iterates over the lazy list 'n' times, appending each element to a
-lazy list. This provides a convenient way of getting elements out of
-an infinite lazy list.</p>
-<pre class="code">
- ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
- ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 1 1 1 1 1 ]
-</pre>
-
-<!-- lappend description -->
-<a name="lappend">
-<h3>lappend ( llist1 llist2 -- llist )</h3>
-<p>Lazily appends two lists together. The actual appending is done
-lazily on iteration rather than immediately so it works very fast no
-matter how large the list.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
-</pre>
-
-<!-- lappend* description -->
-<a name="lappendstar">
-<h3>lappend* ( llists -- llist )</h3>
-<p>Given a lazy list of lazy lists, concatenate them together in a
-lazy fashion. The actual appending is done lazily on iteration rather
-than immediately so it works very fast no matter how large the lists.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
- ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
- ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
- ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
- ( 5 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
-</pre>
-
-<!-- list>llist description -->
-<a name="list2llist">
-<h3>list>llist ( list -- llist )</h3>
-<p>Converts a normal list into a lazy list. This is done lazily so the
-initial list is not iterated through immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
-</pre>
-
-<p class="footer">
-News and updates to this software can be obtained from the authors
-weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
-<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
-</body> </html>
+++ /dev/null
-Lazy lists
+++ /dev/null
-extensions
-collections
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
+\ lcs must-infer
+\ diff must-infer
+\ levenshtein must-infer
+
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
{\r
[ i>> 0 > ] [ j>> 0 > ]\r
[ [ old-nth ] [ new-nth ] bi = ]\r
- } <-&& ;\r
+ } 1&& ;\r
\r
: do-retain ( state -- state )\r
dup old-nth retain boa ,\r
[ 1- ] change-i [ 1- ] change-j ;\r
\r
: inserted? ( state -- ? )\r
- [ j>> 0 > ]\r
- [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;\r
+ {\r
+ [ j>> 0 > ]\r
+ [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]\r
+ } 1&& ;\r
\r
: do-insert ( state -- state )\r
dup new-nth insert boa , [ 1- ] change-j ;\r
\r
: deleted? ( state -- ? )\r
- [ i>> 0 > ]\r
- [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;\r
+ {\r
+ [ i>> 0 > ]\r
+ [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]\r
+ } 1&& ;\r
\r
: do-delete ( state -- state )\r
dup old-nth delete boa , [ 1- ] change-i ;\r
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp lisp.parser tools.test sequences math kernel parser ;
+USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists
+quotations ;
IN: lisp.test
[
init-env
- "#f" [ f ] lisp-define
- "#t" [ t ] lisp-define
+ [ f ] "#f" lisp-define
+ [ t ] "#t" lisp-define
- "+" "math" "+" define-primitve
- "-" "math" "-" define-primitve
+ "+" "math" "+" define-primitive
+ "-" "math" "-" define-primitive
+ "cons" "lists" "cons" define-primitive
+ "car" "lists" "car" define-primitive
+ "cdr" "lists" "cdr" define-primitive
+ "append" "lists" "lappend" define-primitive
+ "nil" "lists" "nil" define-primitive
+ "nil?" "lists" "nil?" define-primitive
+
+ [ seq>list ] "##list" lisp-define
+
+ "define" "lisp" "defun" define-primitive
+
+ "(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
+
{ 5 } [
- [ 2 3 ] "+" <lisp-symbol> funcall
+ ! [ 2 3 ] "+" <lisp-symbol> funcall
+ "(+ 2 3)" lisp-eval
] unit-test
{ 8.3 } [
- [ 10.4 2.1 ] "-" <lisp-symbol> funcall
+ ! [ 10.4 2.1 ] "-" <lisp-symbol> funcall
+ "(- 10.4 2.1)" lisp-eval
] unit-test
{ 3 } [
- "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
+ "((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test
- { 42 } [
- "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
+! { 42 } [
+! "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
+! ] unit-test
+
+ { "b" } [
+ "(cond (#f \"a\") (#t \"b\"))" lisp-eval
] unit-test
- { 1 } [
- "(if #t 1 2)" lisp-string>factor call
+ { 5 } [
+ "(begin (+ 1 4))" lisp-eval
] unit-test
- { "b" } [
- "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
+ { { 1 2 3 4 5 } } [
+ "(list 1 2 3 4 5)" lisp-eval list>seq
] unit-test
- { 5 } [
- "(begin (+ 1 4))" lisp-string>factor call
+ { { 1 2 { 3 { 4 } 5 } } } [
+ "(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq
] unit-test
- { 3 } [
- "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
+ { T{ lisp-symbol f "if" } } [
+ "(defmacro if (pred tr fl) (list (quote cond) (list (list pred tr) (list t fl))))" lisp-eval
+ ] unit-test
+
+ { t } [
+ T{ lisp-symbol f "if" } lisp-macro?
] unit-test
-] with-interactive-vocabs
\ No newline at end of file
+
+! { 1 } [
+! "(if #t 1 2)" lisp-eval
+! ] unit-test
+
+! { 3 } [
+! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
+! ] unit-test
+
+] with-interactive-vocabs
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
-namespaces combinators math bake locals locals.private accessors
-vectors syntax lisp.parser assocs parser sequences.lib words quotations
-fry ;
+namespaces combinators math locals locals.private locals.backend accessors
+vectors syntax lisp.parser assocs parser sequences.lib words
+quotations fry lists inspector ;
IN: lisp
DEFER: convert-form
DEFER: funcall
DEFER: lookup-var
-
+DEFER: lookup-macro
+DEFER: lisp-macro?
+DEFER: lisp-var?
+DEFER: macro-expand
+DEFER: define-lisp-macro
+
+ERROR: no-such-var variable-name ;
+M: no-such-var summary drop "No such variable" ;
+
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( s-exp -- quot )
- [ ] [ convert-form compose ] reduce ; inline
-
-: convert-if ( s-exp -- quot )
- rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
+: convert-body ( cons -- quot )
+ [ ] [ convert-form compose ] foldl ; inline
-: convert-begin ( s-exp -- quot )
- rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
+: convert-begin ( cons -- quot )
+ cdr [ convert-form ] [ ] lmap-as '[ , [ call ] each ] ;
-: convert-cond ( s-exp -- quot )
- rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
- { } map-as '[ , cond ] ;
+: convert-cond ( cons -- quot )
+ cdr [ 2car [ convert-form ] bi@ [ '[ @ call ] ] dip 2array ]
+ { } lmap-as '[ , cond ] ;
-: convert-general-form ( s-exp -- quot )
- unclip convert-form swap convert-body swap '[ , @ funcall ] ;
+: convert-general-form ( cons -- quot )
+ uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
- [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
- [ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
- ] map ;
-
-: localize-lambda ( body vars -- newbody newvars )
+ {
+ { [ dup list? ] [ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ] }
+ { [ dup lisp-symbol? ] [ name>> over at ] }
+ [ ]
+ } cond ;
+
+: localize-lambda ( body vars -- newvars newbody )
make-locals dup push-locals swap
- [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
+ [ swap localize-body convert-form swap pop-locals ] dip swap ;
-: split-lambda ( s-exp -- body vars )
- first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
+: split-lambda ( cons -- body-cons vars-seq )
+ cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline
-: rest-lambda ( body vars -- quot )
+: rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi
- localize-lambda <lambda>
- '[ , cut '[ @ , ] , compose ] ;
+ swapd localize-lambda <lambda>
+ '[ , cut '[ @ , seq>list ] call , call ] ;
: normal-lambda ( body vars -- quot )
- localize-lambda <lambda> '[ , compose ] ;
+ localize-lambda <lambda> lambda-rewrite [ compose call ] compose 1quotation ;
PRIVATE>
-: convert-lambda ( s-exp -- quot )
+: convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
-: convert-quoted ( s-exp -- quot )
- second 1quotation ;
-
-: convert-list-form ( s-exp -- quot )
- dup first dup lisp-symbol?
- [ name>>
- { { "lambda" [ convert-lambda ] }
- { "quote" [ convert-quoted ] }
- { "if" [ convert-if ] }
- { "begin" [ convert-begin ] }
- { "cond" [ convert-cond ] }
- [ drop convert-general-form ]
- } case ]
- [ drop convert-general-form ] if ;
+: convert-quoted ( cons -- quot )
+ cadr 1quotation ;
+
+: convert-defmacro ( cons -- quot )
+ cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
+
+: form-dispatch ( cons lisp-symbol -- quot )
+ name>>
+ { { "lambda" [ convert-lambda ] }
+ { "defmacro" [ convert-defmacro ] }
+ { "quote" [ convert-quoted ] }
+ { "begin" [ convert-begin ] }
+ { "cond" [ convert-cond ] }
+ [ drop convert-general-form ]
+ } case ;
+
+: convert-list-form ( cons -- quot )
+ dup car
+ { { [ dup lisp-macro? ] [ drop macro-expand ] }
+ { [ dup lisp-symbol? ] [ form-dispatch ] }
+ [ drop convert-general-form ]
+ } cond ;
: convert-form ( lisp-form -- quot )
- { { [ dup s-exp? ] [ body>> convert-list-form ] }
- { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
- [ 1quotation ]
+ {
+ { [ dup cons? ] [ convert-list-form ] }
+ { [ dup lisp-var? ] [ lookup-var 1quotation ] }
+ { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
+ [ 1quotation ]
} cond ;
+: compile-form ( lisp-ast -- quot )
+ convert-form lambda-rewrite call ; inline
+
+: macro-expand ( cons -- quot )
+ uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
+
: lisp-string>factor ( str -- quot )
- lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+ lisp-expr parse-result-ast compile-form ;
+
+: lisp-eval ( str -- * )
+ lisp-string>factor call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
-ERROR: no-such-var var ;
+SYMBOL: macro-env
: init-env ( -- )
- H{ } clone lisp-env set ;
+ H{ } clone lisp-env set
+ H{ } clone macro-env set ;
-: lisp-define ( name quot -- )
- swap lisp-env get set-at ;
+: lisp-define ( quot name -- )
+ lisp-env get set-at ;
+
+: defun ( name quot -- name )
+ over name>> lisp-define ;
: lisp-get ( name -- word )
- dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
+ dup lisp-env get at [ ] [ no-such-var ] ?if ;
: lookup-var ( lisp-symbol -- quot )
name>> lisp-get ;
+: lisp-var? ( lisp-symbol -- ? )
+ dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
+
+: funcall-arg-list ( args -- newargs )
+ [ ] [ dup \ funcall = [ drop 2 cut* [ funcall ] compose call ] when suffix ] reduce ;
+
: funcall ( quot sym -- * )
- dup lisp-symbol? [ lookup-var ] when call ; inline
+ [ funcall-arg-list ] dip
+ dup lisp-symbol? [ lookup-var ] when curry call ; inline
+
+: define-primitive ( name vocab word -- )
+ swap lookup 1quotation '[ , compose call ] swap lisp-define ; ! '[ , compose call ] swap lisp-define ;
+
+: lookup-macro ( lisp-symbol -- lambda )
+ name>> macro-env get at ;
+
+: define-lisp-macro ( quot name -- )
+ macro-env get set-at ;
-: define-primitve ( name vocab word -- )
- swap lookup 1quotation '[ , compose call ] lisp-define ;
\ No newline at end of file
+: lisp-macro? ( car -- ? )
+ dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: lisp.parser tools.test peg peg.ebnf ;
+USING: lisp.parser tools.test peg peg.ebnf lists ;
IN: lisp.parser.tests
] unit-test
{ -42 } [
- "-42" "atom" \ lisp-expr rule parse parse-result-ast
+ "-42" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 37/52 } [
- "37/52" "atom" \ lisp-expr rule parse parse-result-ast
+ "37/52" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 123.98 } [
- "123.98" "atom" \ lisp-expr rule parse parse-result-ast
+ "123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "" } [
- "\"\"" "atom" \ lisp-expr rule parse parse-result-ast
+ "\"\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "aoeu" } [
- "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
+ "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "aoeu\"de" } [
- "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
+ "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ lisp-symbol f "foobar" } } [
- "foobar" "atom" \ lisp-expr rule parse parse-result-ast
+ "foobar" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ lisp-symbol f "+" } } [
- "+" "atom" \ lisp-expr rule parse parse-result-ast
+ "+" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
-{ T{ s-exp f
- V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
- "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
+{ +nil+ } [
+ "()" lisp-expr parse-result-ast
+] unit-test
+
+{ T{
+ cons
+ f
+ T{ lisp-symbol f "foo" }
+ T{
+ cons
+ f
+ 1
+ T{ cons f 2 T{ cons f "aoeu" +nil+ } }
+ } } } [
+ "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
+] unit-test
+
+{ T{ cons f
+ 1
+ T{ cons f
+ T{ cons f 3 T{ cons f 4 +nil+ } }
+ T{ cons f 2 +nil+ } }
+ }
+} [
+ "(1 (3 4) 2)" lisp-expr parse-result-ast
] unit-test
\ No newline at end of file
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
-combinators.lib math ;
+USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
+combinators.lib math fry accessors lists ;
IN: lisp.parser
TUPLE: lisp-symbol name ;
C: <lisp-symbol> lisp-symbol
-TUPLE: s-exp body ;
-C: <s-exp> s-exp
-
EBNF: lisp-expr
_ = (" " | "\t" | "\n")*
LPAREN = "("
number = float
| rational
| integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
- | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
+ | "<" | "#" | " =" | ">" | "?" | "^" | "_"
+ | "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials
numbers = [0-9] => [[ 1array >string ]]
atom = number
| identifier
| string
-list-item = _ (atom|s-expression) _ => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
+list-item = _ ( atom | s-expression ) _ => [[ second ]]
;EBNF
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Chris Double
+Samuel Tardieu
+Matthew Willis
--- /dev/null
+Chris Double
--- /dev/null
+USING: lists.lazy.examples lists.lazy tools.test ;
+IN: lists.lazy.examples.tests
+
+[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
+[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
--- /dev/null
+! Rewritten by Matthew Willis, July 2006
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: lists.lazy math kernel sequences quotations ;
+IN: lists.lazy.examples
+
+: naturals ( -- list ) 0 lfrom ;
+: positives ( -- list ) 1 lfrom ;
+: evens ( -- list ) 0 [ 2 + ] lfrom-by ;
+: odds ( -- list ) 1 lfrom [ 2 mod 1 = ] lfilter ;
+: powers-of-2 ( -- list ) 1 [ 2 * ] lfrom-by ;
+: ones ( -- list ) 1 [ ] lfrom-by ;
+: squares ( -- list ) naturals [ dup * ] lazy-map ;
+: first-five-squares ( -- list ) 5 squares ltake list>array ;
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: help.markup help.syntax sequences strings lists ;
+IN: lists.lazy
+
+HELP: lazy-cons
+{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
+{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
+{ $see-also cons car cdr nil nil? } ;
+
+{ 1lazy-list 2lazy-list 3lazy-list } related-words
+
+HELP: 1lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
+
+HELP: 2lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: 3lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: <memoized-cons>
+{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
+{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
+{ $see-also cons car cdr nil nil? } ;
+
+{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+
+HELP: lazy-map
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: lazy-map-with
+{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
+{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
+
+HELP: ltake
+{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: lfilter
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: lwhile
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: luntil
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: list>vector
+{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
+{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>array } ;
+
+HELP: list>array
+{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
+{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>vector } ;
+
+HELP: lappend
+{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
+
+HELP: lfrom-by
+{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
+
+HELP: lfrom
+{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
+
+HELP: seq>list
+{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
+{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
+{ $see-also >list } ;
+
+HELP: >list
+{ $values { "object" "an object" } { "list" "a list" } }
+{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
+{ $see-also seq>list } ;
+
+{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+
+HELP: lconcat
+{ $values { "list" "a list of lists" } { "result" "a list" } }
+{ $description "Concatenates a list of lists together into one list." } ;
+
+HELP: lcartesian-product
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcartesian-product*
+{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcomp
+{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
+
+HELP: lcomp*
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
+{ $examples
+ { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
+} ;
+
+HELP: lmerge
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
+{ $description "Return the result of merging the two lists in a lazy manner." }
+{ $examples
+ { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+} ;
+
+HELP: lcontents
+{ $values { "stream" "a stream" } { "result" string } }
+{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also llines } ;
+
+HELP: llines
+{ $values { "stream" "a stream" } { "result" "a list" } }
+{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also lcontents } ;
--- /dev/null
+! Copyright (C) 2006 Matthew Willis and Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: lists lists.lazy tools.test kernel math io sequences ;
+IN: lists.lazy.tests
+
+[ { 1 2 3 4 } ] [
+ { 1 2 3 4 } >list list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
+] unit-test
+
+[ { 5 6 6 7 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
+] unit-test
+
+[ { 5 6 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
+] unit-test
+
+[ { 4 5 6 } ] [
+ 3 { 1 2 3 } >list [ + ] lazy-map-with list>array
+] unit-test
--- /dev/null
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Updated by Matthew Willis, July 2006
+! Updated by Chris Double, September 2006
+! Updated by James Cash, June 2008
+!
+USING: kernel sequences math vectors arrays namespaces
+quotations promises combinators io lists accessors ;
+IN: lists.lazy
+
+M: promise car ( promise -- car )
+ force car ;
+
+M: promise cdr ( promise -- cdr )
+ force cdr ;
+
+M: promise nil? ( cons -- bool )
+ force nil? ;
+
+! Both 'car' and 'cdr' are promises
+TUPLE: lazy-cons car cdr ;
+
+: lazy-cons ( car cdr -- promise )
+ [ promise ] bi@ \ lazy-cons boa
+ T{ promise f f t f } clone
+ [ set-promise-value ] keep ;
+
+M: lazy-cons car ( lazy-cons -- car )
+ car>> force ;
+
+M: lazy-cons cdr ( lazy-cons -- cdr )
+ cdr>> force ;
+
+M: lazy-cons nil? ( lazy-cons -- bool )
+ nil eq? ;
+
+: 1lazy-list ( a -- lazy-cons )
+ [ nil ] lazy-cons ;
+
+: 2lazy-list ( a b -- lazy-cons )
+ 1lazy-list 1quotation lazy-cons ;
+
+: 3lazy-list ( a b c -- lazy-cons )
+ 2lazy-list 1quotation lazy-cons ;
+
+TUPLE: memoized-cons original car cdr nil? ;
+
+: not-memoized ( -- obj )
+ { } ;
+
+: not-memoized? ( obj -- bool )
+ not-memoized eq? ;
+
+: <memoized-cons> ( cons -- memoized-cons )
+ not-memoized not-memoized not-memoized
+ memoized-cons boa ;
+
+M: memoized-cons car ( memoized-cons -- car )
+ dup car>> not-memoized? [
+ dup original>> car [ >>car drop ] keep
+ ] [
+ car>>
+ ] if ;
+
+M: memoized-cons cdr ( memoized-cons -- cdr )
+ dup cdr>> not-memoized? [
+ dup original>> cdr [ >>cdr drop ] keep
+ ] [
+ cdr>>
+ ] if ;
+
+M: memoized-cons nil? ( memoized-cons -- bool )
+ dup nil?>> not-memoized? [
+ dup original>> nil? [ >>nil? drop ] keep
+ ] [
+ nil?>>
+ ] if ;
+
+TUPLE: lazy-map cons quot ;
+
+C: <lazy-map> lazy-map
+
+: lazy-map ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
+
+M: lazy-map car ( lazy-map -- car )
+ [ cons>> car ] keep
+ quot>> call ;
+
+M: lazy-map cdr ( lazy-map -- cdr )
+ [ cons>> cdr ] keep
+ quot>> lazy-map ;
+
+M: lazy-map nil? ( lazy-map -- bool )
+ cons>> nil? ;
+
+: lazy-map-with ( value list quot -- result )
+ with lazy-map ;
+
+TUPLE: lazy-take n cons ;
+
+C: <lazy-take> lazy-take
+
+: ltake ( n list -- result )
+ over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+
+M: lazy-take car ( lazy-take -- car )
+ cons>> car ;
+
+M: lazy-take cdr ( lazy-take -- cdr )
+ [ n>> 1- ] keep
+ cons>> cdr ltake ;
+
+M: lazy-take nil? ( lazy-take -- bool )
+ dup n>> zero? [
+ drop t
+ ] [
+ cons>> nil?
+ ] if ;
+
+TUPLE: lazy-until cons quot ;
+
+C: <lazy-until> lazy-until
+
+: luntil ( list quot -- result )
+ over nil? [ drop ] [ <lazy-until> ] if ;
+
+M: lazy-until car ( lazy-until -- car )
+ cons>> car ;
+
+M: lazy-until cdr ( lazy-until -- cdr )
+ [ cons>> uncons ] keep quot>> tuck call
+ [ 2drop nil ] [ luntil ] if ;
+
+M: lazy-until nil? ( lazy-until -- bool )
+ drop f ;
+
+TUPLE: lazy-while cons quot ;
+
+C: <lazy-while> lazy-while
+
+: lwhile ( list quot -- result )
+ over nil? [ drop ] [ <lazy-while> ] if ;
+
+M: lazy-while car ( lazy-while -- car )
+ cons>> car ;
+
+M: lazy-while cdr ( lazy-while -- cdr )
+ [ cons>> cdr ] keep quot>> lwhile ;
+
+M: lazy-while nil? ( lazy-while -- bool )
+ [ car ] keep quot>> call not ;
+
+TUPLE: lazy-filter cons quot ;
+
+C: <lazy-filter> lazy-filter
+
+: lfilter ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
+
+: car-filter? ( lazy-filter -- ? )
+ [ cons>> car ] [ quot>> ] bi call ;
+
+: skip ( lazy-filter -- )
+ dup cons>> cdr >>cons drop ;
+
+M: lazy-filter car ( lazy-filter -- car )
+ dup car-filter? [ cons>> ] [ dup skip ] if car ;
+
+M: lazy-filter cdr ( lazy-filter -- cdr )
+ dup car-filter? [
+ [ cons>> cdr ] [ quot>> ] bi lfilter
+ ] [
+ dup skip cdr
+ ] if ;
+
+M: lazy-filter nil? ( lazy-filter -- bool )
+ dup cons>> nil? [
+ drop t
+ ] [
+ dup car-filter? [
+ drop f
+ ] [
+ dup skip nil?
+ ] if
+ ] if ;
+
+: list>vector ( list -- vector )
+ [ [ , ] leach ] V{ } make ;
+
+: list>array ( list -- array )
+ [ [ , ] leach ] { } make ;
+
+TUPLE: lazy-append list1 list2 ;
+
+C: <lazy-append> lazy-append
+
+: lappend ( list1 list2 -- result )
+ over nil? [ nip ] [ <lazy-append> ] if ;
+
+M: lazy-append car ( lazy-append -- car )
+ list1>> car ;
+
+M: lazy-append cdr ( lazy-append -- cdr )
+ [ list1>> cdr ] keep
+ list2>> lappend ;
+
+M: lazy-append nil? ( lazy-append -- bool )
+ drop f ;
+
+TUPLE: lazy-from-by n quot ;
+
+C: lfrom-by lazy-from-by ( n quot -- list )
+
+: lfrom ( n -- list )
+ [ 1+ ] lfrom-by ;
+
+M: lazy-from-by car ( lazy-from-by -- car )
+ n>> ;
+
+M: lazy-from-by cdr ( lazy-from-by -- cdr )
+ [ n>> ] keep
+ quot>> dup slip lfrom-by ;
+
+M: lazy-from-by nil? ( lazy-from-by -- bool )
+ drop f ;
+
+TUPLE: lazy-zip list1 list2 ;
+
+C: <lazy-zip> lazy-zip
+
+: lzip ( list1 list2 -- lazy-zip )
+ over nil? over nil? or
+ [ 2drop nil ] [ <lazy-zip> ] if ;
+
+M: lazy-zip car ( lazy-zip -- car )
+ [ list1>> car ] keep list2>> car 2array ;
+
+M: lazy-zip cdr ( lazy-zip -- cdr )
+ [ list1>> cdr ] keep list2>> cdr lzip ;
+
+M: lazy-zip nil? ( lazy-zip -- bool )
+ drop f ;
+
+TUPLE: sequence-cons index seq ;
+
+C: <sequence-cons> sequence-cons
+
+: seq>list ( index seq -- list )
+ 2dup length >= [
+ 2drop nil
+ ] [
+ <sequence-cons>
+ ] if ;
+
+M: sequence-cons car ( sequence-cons -- car )
+ [ index>> ] keep
+ seq>> nth ;
+
+M: sequence-cons cdr ( sequence-cons -- cdr )
+ [ index>> 1+ ] keep
+ seq>> seq>list ;
+
+M: sequence-cons nil? ( sequence-cons -- bool )
+ drop f ;
+
+: >list ( object -- list )
+ {
+ { [ dup sequence? ] [ 0 swap seq>list ] }
+ { [ dup list? ] [ ] }
+ [ "Could not convert object to a list" throw ]
+ } cond ;
+
+TUPLE: lazy-concat car cdr ;
+
+C: <lazy-concat> lazy-concat
+
+DEFER: lconcat
+
+: (lconcat) ( car cdr -- list )
+ over nil? [
+ nip lconcat
+ ] [
+ <lazy-concat>
+ ] if ;
+
+: lconcat ( list -- result )
+ dup nil? [
+ drop nil
+ ] [
+ uncons swap (lconcat)
+ ] if ;
+
+M: lazy-concat car ( lazy-concat -- car )
+ car>> car ;
+
+M: lazy-concat cdr ( lazy-concat -- cdr )
+ [ car>> cdr ] keep cdr>> (lconcat) ;
+
+M: lazy-concat nil? ( lazy-concat -- bool )
+ dup car>> nil? [
+ cdr>> nil?
+ ] [
+ drop f
+ ] if ;
+
+: lcartesian-product ( list1 list2 -- result )
+ swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ;
+
+: lcartesian-product* ( lists -- result )
+ dup nil? [
+ drop nil
+ ] [
+ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
+ swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat
+ ] reduce
+ ] if ;
+
+: lcomp ( list quot -- result )
+ [ lcartesian-product* ] dip lazy-map ;
+
+: lcomp* ( list guards quot -- result )
+ [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
+
+DEFER: lmerge
+
+: (lmerge) ( list1 list2 -- result )
+ over [ car ] curry -rot
+ [
+ dup [ car ] curry -rot
+ [
+ [ cdr ] bi@ lmerge
+ ] 2curry lazy-cons
+ ] 2curry lazy-cons ;
+
+: lmerge ( list1 list2 -- result )
+ {
+ { [ over nil? ] [ nip ] }
+ { [ dup nil? ] [ drop ] }
+ { [ t ] [ (lmerge) ] }
+ } cond ;
+
+TUPLE: lazy-io stream car cdr quot ;
+
+C: <lazy-io> lazy-io
+
+: lcontents ( stream -- result )
+ f f [ stream-read1 ] <lazy-io> ;
+
+: llines ( stream -- result )
+ f f [ stream-readln ] <lazy-io> ;
+
+M: lazy-io car ( lazy-io -- car )
+ dup car>> dup [
+ nip
+ ] [
+ drop dup stream>> over quot>> call
+ swap dupd set-lazy-io-car
+ ] if ;
+
+M: lazy-io cdr ( lazy-io -- cdr )
+ dup cdr>> dup [
+ nip
+ ] [
+ drop dup
+ [ stream>> ] keep
+ [ quot>> ] keep
+ car [
+ [ f f ] dip <lazy-io> [ >>cdr drop ] keep
+ ] [
+ 3drop nil
+ ] if
+ ] if ;
+
+M: lazy-io nil? ( lazy-io -- bool )
+ car not ;
+
+INSTANCE: sequence-cons list
+INSTANCE: memoized-cons list
+INSTANCE: promise list
+INSTANCE: lazy-io list
+INSTANCE: lazy-concat list
+INSTANCE: lazy-cons list
+INSTANCE: lazy-map list
+INSTANCE: lazy-take list
+INSTANCE: lazy-append list
+INSTANCE: lazy-from-by list
+INSTANCE: lazy-zip list
+INSTANCE: lazy-while list
+INSTANCE: lazy-until list
+INSTANCE: lazy-filter list
--- /dev/null
+<html>
+ <head>
+ <title>Lazy Evaluation</title>
+ <link rel="stylesheet" type="text/css" href="style.css">
+ </head>
+ <body>
+ <h1>Lazy Evaluation</h1>
+<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
+ ability to describe infinite structures, and to delay execution of
+ expressions until they are actually used.</p>
+<p>Lazy lists, like normal lists, are composed of a head and tail. In
+ a lazy list the head and tail are something called a 'promise'.
+ To convert a
+ 'promise' into its actual value a word called 'force' is used. To
+ convert a value into a 'promise' the word to use is 'delay'.</p>
+<table border="1">
+<tr><td><a href="#delay">delay</a></td></tr>
+<tr><td><a href="#force">force</a></td></tr>
+</table>
+
+<p>Many of the lazy list words are named similar to the standard list
+ words but with an 'l' suffixed to it. Here are the commonly used
+ words and their equivalent list operation:</p>
+<table border="1">
+<tr><th>Lazy List</th><th>Normal List</th></tr>
+<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
+<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
+<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
+<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
+<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
+<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
+<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
+<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
+<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
+<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
+<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
+<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
+</table>
+<p>A few additional words specific to lazy lists are:</p>
+<table border="1">
+<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
+number of items from the lazy list.</td></tr>
+<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
+concatenate them together in a lazy manner, returning a single lazy
+list.</td></tr>
+<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
+that contains the same elements as the normal list.</td></tr>
+</table>
+<h2>Reference</h2>
+<!-- delay description -->
+<a name="delay">
+<h3>delay ( quot -- <promise> )</h3>
+<p>'delay' is used to convert a value or expression into a promise.
+ The word 'force' is used to convert that promise back to its
+ value, or to force evaluation of the expression to return a value.
+</p>
+<p>The value on the stack that 'delay' expects must be quoted. This is
+ a requirement to prevent it from being evaluated.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- force description -->
+<a name="force">
+<h3>force ( <promise> -- value )</h3>
+<p>'force' will evaluate a promises original expression
+ and leave the value of that expression on the stack.
+</p>
+<p>A promise can be forced multiple times but the expression
+ is only evaluated once. Future calls of 'force' on the promise
+ will returned the cached value of the original force. If the
+ expression contains side effects, such as i/o, then that i/o
+ will only occur on the first 'force'. See below for an example
+ (steps 3-5).
+</p>
+<p>If a promise is itself delayed, a force will evaluate all promises
+ until a value is returned. Due to this behaviour it is generally not
+ possible to delay a promise. The example below shows what happens
+ in this case.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+
+ #! Multiple forces on a promise returns cached value
+ ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
+ ( 4 ) dup <a href="#force">force</a> .
+ => hello
+ 42
+ ( 5 ) <a href="#force">force</a> .
+ => 42
+
+ #! Forcing a delayed promise cascades up to return
+ #! original value, rather than the promise.
+ ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
+ ( 7 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- lnil description -->
+<a name="lnil">
+<h3>lnil ( -- lcons )</h3>
+<p>Returns a value representing the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> .
+ => << promise [ ] [ [ ] ] t [ ] >>
+</pre>
+
+<!-- lnil description -->
+<a name="lnilp">
+<h3>lnil? ( lcons -- bool )</h3>
+<p>Returns true if the given lazy cons is the value representing
+ the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
+ => [ ]
+ ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+</pre>
+
+<!-- lcons description -->
+<a name="lcons">
+<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
+<p>Provides the same effect as 'cons' does for normal lists.
+ Both values provided must be promises (ie. expressions that have
+ had <a href="#delay">delay</a> called on them).
+</p>
+<p>As the car and cdr passed on the stack are promises, they are not
+ evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
+ are called on the lazy cons.</p>
+<pre class="code">
+ ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => "car"
+ ( 3 ) dup <a href="#lcdr">lcdr</a> .
+ => "cdr"
+</pre>
+
+<!-- lunit description -->
+<a name="lunit">
+<h3>lunit ( value-promise -- llist )</h3>
+<p>Provides the same effect as 'unit' does for normal lists. It
+creates a lazy list where the first element is the value given.</p>
+<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
+ a promise and is not evaluated until the <a href="#lcar">lcar</a>
+ of the list is requested.</a>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => 42
+ ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 4 ) [ . ] <a href="#leach">leach</a>
+ => 42
+</pre>
+
+<!-- lcar description -->
+<a name="lcar">
+<h3>lcar ( lcons -- value )</h3>
+<p>Provides the same effect as 'car' does for normal lists. It
+returns the first element in a lazy cons cell. This will force
+the evaluation of that element.</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcar">lcar</a> .
+ => 42
+</pre>
+
+<!-- lcdr description -->
+<a name="lcdr">
+<h3>lcdr ( lcons -- value )</h3>
+<p>Provides the same effect as 'cdr' does for normal lists. It
+returns the second element in a lazy cons cell and forces it. This
+causes that element to be evaluated immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> .
+ => 11
+</pre>
+
+<pre class="code">
+ ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 6
+ ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 7
+ ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 8
+</pre>
+
+<!-- lnth description -->
+<a name="lnth">
+<h3>lnth ( n llist -- value )</h3>
+<p>Provides the same effect as 'nth' does for normal lists. It
+returns the nth value in the lazy list. It causes all the values up to
+'n' to be evaluated.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) 5 swap <a href="#lnth">lnth</a> .
+ => 6
+</pre>
+
+<!-- luncons description -->
+<a name="luncons">
+<h3>luncons ( lcons -- car cdr )</h3>
+<p>Provides the same effect as 'uncons' does for normal lists. It
+returns the car and cdr of the lazy list.</p>
+<pre class="code">
+ ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#luncons">luncons</a> . .
+ => 6
+ 5
+</pre>
+
+<!-- lmap description -->
+<a name="lmap">
+<h3>lmap ( llist quot -- llist )</h3>
+<p>Lazily maps over a lazy list applying the quotation to each element.
+A new lazy list is returned which contains the results of the
+quotation.</p>
+<p>When intially called nothing in the original lazy list is
+evaluated. Only when <a href="#lcar">lcar</a> is called will the item
+in the list be evaluated and applied to the quotation. Ditto with <a
+href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
+ => < infinite list of numbers incrementing by 2 >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 4 6 8 10 ]
+</pre>
+
+<!-- lsubset description -->
+<a name="lsubset">
+<h3>lsubset ( llist pred -- llist )</h3>
+<p>Provides the same effect as 'subset' does for normal lists. It
+lazily iterates over a lazy list applying the predicate quotation to each
+element. If that quotation returns true, the element will be included
+in the resulting lazy list. If it is false, the element will be skipped.
+A new lazy list is returned which contains all elements where the
+predicate returned true.</p>
+<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
+will occur. A lazy list is returned that when values are retrieved
+from in then items are evaluated and checked against the predicate.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
+ => < infinite list of prime numbers >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 3 5 7 11 ]
+</pre>
+
+<!-- leach description -->
+<a name="leach">
+<h3>leach ( llist quot -- )</h3>
+<p>Provides the same effect as 'each' does for normal lists. It
+lazily iterates over a lazy list applying the quotation to each
+element. If this operation is applied to an infinite list it will
+never return unless the quotation escapes out by calling a continuation.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
+ => < infinite list of odd numbers >
+ ( 3 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 3
+ 5
+ 7
+ ... for ever ...
+</pre>
+
+<!-- ltake description -->
+<a name="ltake">
+<h3>ltake ( n llist -- llist )</h3>
+<p>Iterates over the lazy list 'n' times, appending each element to a
+lazy list. This provides a convenient way of getting elements out of
+an infinite lazy list.</p>
+<pre class="code">
+ ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
+ ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 1 1 1 1 1 ]
+</pre>
+
+<!-- lappend description -->
+<a name="lappend">
+<h3>lappend ( llist1 llist2 -- llist )</h3>
+<p>Lazily appends two lists together. The actual appending is done
+lazily on iteration rather than immediately so it works very fast no
+matter how large the list.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+</pre>
+
+<!-- lappend* description -->
+<a name="lappendstar">
+<h3>lappend* ( llists -- llist )</h3>
+<p>Given a lazy list of lazy lists, concatenate them together in a
+lazy fashion. The actual appending is done lazily on iteration rather
+than immediately so it works very fast no matter how large the lists.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
+ ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
+ ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
+ ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
+ ( 5 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+</pre>
+
+<!-- list>llist description -->
+<a name="list2llist">
+<h3>list>llist ( list -- llist )</h3>
+<p>Converts a normal list into a lazy list. This is done lazily so the
+initial list is not iterated through immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+</pre>
+
+<p class="footer">
+News and updates to this software can be obtained from the authors
+weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
+<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
+</body> </html>
--- /dev/null
+Lazy lists
--- /dev/null
+extensions
+collections
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+
+IN: lists
+
+{ car cons cdr nil nil? list? uncons } related-words
+
+HELP: cons
+{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
+{ $description "Constructs a cons cell." } ;
+
+HELP: car
+{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
+{ $description "Returns the first item in the list." } ;
+
+HELP: cdr
+{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
+{ $description "Returns the tail of the list." } ;
+
+HELP: nil
+{ $values { "symbol" "The empty cons (+nil+)" } }
+{ $description "Returns a symbol representing the empty list" } ;
+
+HELP: nil?
+{ $values { "cons" "a cons object" } { "?" "a boolean" } }
+{ $description "Return true if the cons object is the nil cons." } ;
+
+HELP: list? ( object -- ? )
+{ $values { "object" "an object" } { "?" "a boolean" } }
+{ $description "Returns true if the object conforms to the list protocol." } ;
+
+{ 1list 2list 3list } related-words
+
+HELP: 1list
+{ $values { "obj" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 1 element." } ;
+
+HELP: 2list
+{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 2 elements." } ;
+
+HELP: 3list
+{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 3 elements." } ;
+
+HELP: lnth
+{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
+{ $description "Outputs the nth element of the list." }
+{ $see-also llength cons car cdr } ;
+
+HELP: llength
+{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
+{ $description "Outputs the length of the list. This should not be called on an infinite list." }
+{ $see-also lnth cons car cdr } ;
+
+HELP: uncons
+{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
+{ $description "Put the head and tail of the list on the stack." } ;
+
+{ leach foldl lmap>array } related-words
+
+HELP: leach
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
+{ $description "Call the quotation for each item in the list." } ;
+
+HELP: foldl
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
+
+HELP: foldr
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
+
+HELP: lmap
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } }
+{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
+
+HELP: lreverse
+{ $values { "list" "a cons object" } { "newlist" "a new cons object" } }
+{ $description "Reverses the input list, outputing a new, reversed list" } ;
+
+HELP: list>seq
+{ $values { "list" "a cons object" } { "array" "an array object" } }
+{ $description "Turns the given cons object into an array, maintaing order." } ;
+
+HELP: seq>list
+{ $values { "seq" "a sequence" } { "list" "a cons object" } }
+{ $description "Turns the given array into a cons object, maintaing order." } ;
+
+HELP: cons>seq
+{ $values { "cons" "a cons object" } { "array" "an array object" } }
+{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
+
+HELP: seq>cons
+{ $values { "seq" "a sequence object" } { "cons" "a cons object" } }
+{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
+
+HELP: traverse
+{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" }
+ { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } }
+{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
+ " returns true for with the result of applying quot to." } ;
+
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test lists math ;
+
+IN: lists.tests
+
+{ { 3 4 5 6 7 } } [
+ { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq
+] unit-test
+
+{ { 3 4 5 6 } } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ +nil+ } } } } [ 2 + ] lmap>array
+] unit-test
+
+{ 10 } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ +nil+ } } } } 0 [ + ] foldl
+] unit-test
+
+{ T{ cons f
+ 1
+ T{ cons f
+ 2
+ T{ cons f
+ T{ cons f
+ 3
+ T{ cons f
+ 4
+ T{ cons f
+ T{ cons f 5 +nil+ }
+ +nil+ } } }
+ +nil+ } } }
+} [
+ { 1 2 { 3 4 { 5 } } } seq>cons
+] unit-test
+
+{ { 1 2 { 3 4 { 5 } } } } [
+ { 1 2 { 3 4 { 5 } } } seq>cons cons>seq
+] unit-test
+
+{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
+ { 1 2 3 4 } seq>cons [ 1+ ] lmap
+] unit-test
+
+{ 15 } [
+ { 1 2 3 4 5 } seq>list 0 [ + ] foldr
+] unit-test
+
+{ { 5 4 3 2 1 } } [
+ { 1 2 3 4 5 } seq>list lreverse list>seq
+] unit-test
+
+{ 5 } [
+ { 1 2 3 4 5 } seq>list llength
+] unit-test
+
+{ { 3 4 { 5 6 { 7 } } } } [
+ { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
+] unit-test
+
+{ { 1 2 3 4 5 6 } } [
+ { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors math arrays vectors classes words locals ;
+
+IN: lists
+
+! List Protocol
+MIXIN: list
+GENERIC: car ( cons -- car )
+GENERIC: cdr ( cons -- cdr )
+GENERIC: nil? ( object -- ? )
+
+TUPLE: cons car cdr ;
+
+C: cons cons
+
+M: cons car ( cons -- car )
+ car>> ;
+
+M: cons cdr ( cons -- cdr )
+ cdr>> ;
+
+SYMBOL: +nil+
+M: word nil? +nil+ eq? ;
+M: object nil? drop f ;
+
+: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
+
+: nil ( -- symbol ) +nil+ ;
+
+: uncons ( cons -- cdr car )
+ [ cdr ] [ car ] bi ;
+
+: 1list ( obj -- cons )
+ nil cons ;
+
+: 2list ( a b -- cons )
+ nil cons cons ;
+
+: 3list ( a b c -- cons )
+ nil cons cons cons ;
+
+: cadr ( cons -- elt )
+ cdr car ;
+
+: 2car ( cons -- car caar )
+ [ car ] [ cdr car ] bi ;
+
+: 3car ( cons -- car caar caaar )
+ [ car ] [ cdr car ] [ cdr cdr car ] tri ;
+
+: lnth ( n list -- elt )
+ swap [ cdr ] times car ;
+
+: (leach) ( list quot -- cdr quot )
+ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
+
+: leach ( list quot -- )
+ over nil? [ 2drop ] [ (leach) leach ] if ; inline
+
+: lmap ( list quot -- result )
+ over nil? [ drop ] [ (leach) lmap cons ] if ; inline
+
+: foldl ( list identity quot -- result ) swapd leach ; inline
+
+: foldr ( list identity quot -- result )
+ pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
+ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
+ call
+ ] if ; inline
+
+: llength ( list -- n )
+ 0 [ drop 1+ ] foldl ;
+
+: lreverse ( list -- newlist )
+ nil [ swap cons ] foldl ;
+
+: lappend ( list1 list2 -- newlist )
+ [ lreverse ] dip [ swap cons ] foldl ;
+
+: seq>list ( seq -- list )
+ <reversed> nil [ swap cons ] reduce ;
+
+: same? ( obj1 obj2 -- ? )
+ [ class ] bi@ = ;
+
+: seq>cons ( seq -- cons )
+ [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
+
+: (lmap>array) ( acc cons quot -- newcons )
+ over nil? [ 2drop ]
+ [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
+
+: lmap>array ( cons quot -- newcons )
+ { } -rot (lmap>array) ; inline
+
+: lmap-as ( cons quot exemplar -- seq )
+ [ lmap>array ] dip like ;
+
+: cons>seq ( cons -- array )
+ [ dup cons? [ cons>seq ] when ] lmap>array ;
+
+: list>seq ( list -- array )
+ [ ] lmap>array ;
+
+: traverse ( list pred quot -- result )
+ [ 2over call [ tuck [ call ] 2dip ] when
+ pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ;
+
+INSTANCE: cons list
\ No newline at end of file
--- /dev/null
+Implementation of lisp-style linked lists
--- /dev/null
+cons
+lists
+sequences
[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
-: get-local-test-1 3 >r 1 get-local r> drop ;
+: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ;
-{ 0 1 } [ get-local-test-1 ] must-infer-as
+\ get-local-test-1 must-infer
[ 3 ] [ get-local-test-1 ] unit-test
-: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ;
-{ 0 1 } [ get-local-test-2 ] must-infer-as
+\ get-local-test-2 must-infer
[ 4 ] [ get-local-test-2 ] unit-test
-: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ;
-{ 0 2 } [ get-local-test-3 ] must-infer-as
+\ get-local-test-3 must-infer
[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
-: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
+: get-local-test-4 ( -- a b )
+ 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
-{ 0 2 } [ get-local-test-4 ] must-infer-as
+\ get-local-test-4 must-infer
[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
-: load-locals-test-1 1 2 2 load-locals r> r> ;
+: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ;
-{ 0 2 } [ load-locals-test-1 ] must-infer-as
+\ load-locals-test-1 must-infer
[ 1 2 ] [ load-locals-test-1 ] unit-test
GENERIC: local-rewrite* ( obj -- )
-: lambda-rewrite
+: lambda-rewrite ( quot -- quot' )
[ local-rewrite* ] [ ] make
[ [ lambda-rewrite* ] each ] [ ] make ;
let-rewrite ;
: parse-locals ( -- vars assoc )
- parse-effect
+ ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals dup push-locals ;
2dup "lambda" set-word-prop
lambda-rewrite first ;
-: (::) CREATE-WORD parse-locals-definition ;
+: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
-: (M::)
+: (M::) ( -- word def )
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences namespaces words assocs logging sorting\r
-prettyprint io io.styles strings logging.parser calendar.format ;\r
+prettyprint io io.styles strings logging.parser calendar.format\r
+combinators ;\r
IN: logging.analysis\r
\r
SYMBOL: word-names\r
] curry assoc-each\r
] tabular-output ;\r
\r
-: log-entry.\r
+: log-entry. ( entry -- )\r
"====== " write\r
- dup first (timestamp>string) bl\r
- dup second pprint bl\r
- dup third write nl\r
- fourth "\n" join print ;\r
+ {\r
+ [ first (timestamp>string) bl ]\r
+ [ second pprint bl ]\r
+ [ third write nl ]\r
+ [ fourth "\n" join print ]\r
+ } cleave ;\r
\r
: errors. ( errors -- )\r
[ log-entry. ] each ;\r
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
splitting continuations effects arrays.lib parser strings\r
-combinators.lib quotations fry symbols accessors ;\r
+quotations fry symbols accessors ;\r
IN: logging\r
\r
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
\r
<PRIVATE\r
\r
-: one-string?\r
- {\r
- [ dup array? ]\r
- [ dup length 1 = ]\r
- [ dup first string? ]\r
- } && nip ;\r
-\r
: stack>message ( obj -- inputs>message )\r
- dup one-string? [ first ] [\r
- H{\r
- { string-limit f }\r
- { line-limit 1 }\r
- { nesting-limit 3 }\r
- { margin 0 }\r
- } clone [ unparse ] bind\r
- ] if ;\r
+ dup array? [ dup length 1 = [ first ] when ] when\r
+ dup string? [\r
+ [\r
+ string-limit off\r
+ 1 line-limit set\r
+ 3 nesting-limit set\r
+ 0 margin set\r
+ unparse\r
+ ] with-scope\r
+ ] unless ;\r
\r
PRIVATE>\r
\r
3drop\r
] if ; inline\r
\r
-: input# stack-effect in>> length ;\r
+: input# ( word -- n ) stack-effect in>> length ;\r
\r
: input-logging-quot ( quot word level -- quot' )\r
rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;\r
: add-input-logging ( word level -- )\r
[ input-logging-quot ] (define-logging) ;\r
\r
-: output# stack-effect out>> length ;\r
+: output# ( word -- n ) stack-effect out>> length ;\r
\r
: output-logging-quot ( quot word level -- quot' )\r
[ [ output# ] keep ] dip '[ @ , , , log-stack ] ;\r
#! Syntax: name level\r
CREATE-WORD dup scan-word\r
'[ 1array stack>message , , log-message ]\r
- define ; parsing\r
+ (( message -- )) define-declared ; parsing\r
calendar calendar.format ;\r
IN: logging.parser\r
\r
-: string-of satisfy <!*> [ >string ] <@ ;\r
+: string-of ( quot -- parser ) satisfy <!*> [ >string ] <@ ;\r
\r
SYMBOL: multiline\r
\r
-: 'date'\r
+: 'date' ( -- parser )\r
[ "]" member? not ] string-of [\r
dup multiline-header =\r
[ drop multiline ] [ rfc3339>timestamp ] if\r
] <@\r
"[" "]" surrounded-by ;\r
\r
-: 'log-level'\r
+: 'log-level' ( -- parser )\r
log-levels [\r
[ word-name token ] keep [ nip ] curry <@\r
] map <or-parser> ;\r
\r
-: 'word-name'\r
+: 'word-name' ( -- parser )\r
[ " :" member? not ] string-of ;\r
\r
SYMBOL: malformed\r
\r
-: 'malformed-line'\r
+: 'malformed-line' ( -- parser )\r
[ drop t ] string-of [ malformed swap 2array ] <@ ;\r
\r
-: 'log-message'\r
+: 'log-message' ( -- parser )\r
[ drop t ] string-of [ 1vector ] <@ ;\r
\r
MEMO: 'log-line' ( -- parser )\r
: multiline? ( line -- ? )\r
first multiline eq? ;\r
\r
-: malformed-line\r
+: malformed-line ( line -- )\r
"Warning: malformed log line:" print\r
second print ;\r
\r
: ?delete-file ( path -- )\r
dup exists? [ delete-file ] [ drop ] if ;\r
\r
-: delete-oldest keep-logs log# ?delete-file ;\r
+: delete-oldest ( service -- ) keep-logs log# ?delete-file ;\r
\r
: ?move-file ( old new -- )\r
over exists? [ move-file ] [ 2drop ] if ;\r
} case log-server-loop ;\r
\r
: log-server ( -- )\r
- [ [ log-server-loop ] [ error. (close-logs) ] recover t ]\r
+ [\r
+ init-namespaces\r
+ [ log-server-loop ]\r
+ [ error. (close-logs) ]\r
+ recover t\r
+ ]\r
"Log server" spawn-server\r
"log-server" set-global ;\r
\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: has-param? ( slice -- ? ) { [ length 1 > ] [ second CHAR: ( = ] } <-&& ;
+: has-param? ( slice -- ? ) { [ length 1 > ] [ second CHAR: ( = ] } 1&& ;
: next+rest ( slice -- next rest ) [ 1 head ] [ 1 tail-slice ] bi ;
{ $values { "..." "inputs to a macro" } { "word" macro } { "quot" quotation } }
{ $description "Expands a macro. Useful for debugging." }
{ $examples
- { $code "{ [ dup integer? ] [ dup 0 > ] [ dup 13 mod zero? ] } \ && macro-expand ." }
+ { $code "USING: math macros combinators.lib ;" "{ [ integer? ] [ 0 > ] [ 13 mod zero? ] } \ 1&& macro-expand ." }
} ;
ARTICLE: "macros" "Macros"
{ $subsection POSTPONE: MACRO: }
"Expanding macros for debugging purposes:"
{ $subsection macro-expand }
-! "Two sample macros which implement short-circuiting boolean operators (as found in C, Java and similar languages):"
-! { $subsection && }
-! { $subsection || }
"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ;
ABOUT: "macros"
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
[ \ see-test see ] with-string-writer =
] unit-test
+
+[ ] [ "USING: macros inference kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test
+
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
-: saver \ >r <repetition> >quotation ;
+: saver ( n -- quot ) \ >r <repetition> >quotation ;
-: restorer \ r> <repetition> >quotation ;
+: restorer ( n -- quot ) \ r> <repetition> >quotation ;
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences classes.tuple
-combinators macros assocs math ;
+combinators macros assocs math effects ;
IN: match
SYMBOL: _
: define-match-var ( name -- )
create-in
dup t "match-var" set-word-prop
- dup [ get ] curry define ;
+ dup [ get ] curry (( -- value )) define-declared ;
: define-match-vars ( seq -- )
[ define-match-var ] each ;
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math.erato tools.test ;
+USING: lists.lazy math.erato tools.test ;
IN: math.erato.tests
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
+USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
math.ranges sequences ;
IN: math.erato
! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
! http://dressguardmeister.blogspot.com/2007/01/fft.html
USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting columns ;
+math.functions kernel splitting grouping columns ;
IN: math.fft
: n^v ( n v -- w ) [ ^ ] with map ;
[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+[ t ] [ -100 atan tan -100 1.e-10 ~ ] unit-test
[ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
+[ t ] [ 10 atanh tanh 10 1.e-10 ~ ] unit-test
+[ t ] [ 0.5 atanh tanh 0.5 1.e-10 ~ ] unit-test
[ 100 ] [ 100 100 gcd nip ] unit-test
[ 100 ] [ 1000 100 gcd nip ] unit-test
gcd nip
] unit-test
-: verify-gcd
+: verify-gcd ( a b -- ? )
2dup gcd
>r rot * swap rem r> = ;
: coth ( x -- y ) tanh recip ; inline
: acosh ( x -- y )
- dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline
+ dup sq 1- sqrt + log ; inline
: asech ( x -- y ) recip acosh ; inline
: asinh ( x -- y )
- dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline
+ dup sq 1+ sqrt + log ; inline
: acosech ( x -- y ) recip asinh ; inline
: atanh ( x -- y )
- dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline
+ dup 1+ swap 1- neg / log 2 / ; inline
: acoth ( x -- y ) recip atanh ; inline
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting columns ;
+USING: sequences math kernel splitting grouping columns ;
IN: math.haar
: averages ( seq -- seq )
"double" "libm" "atan" { "double" } alien-invoke ;
foldable
-: facosh ( x -- y )
- "double" "libm" "acosh" { "double" } alien-invoke ;
- foldable
-
-: fasinh ( x -- y )
- "double" "libm" "asinh" { "double" } alien-invoke ;
- foldable
-
-: fatanh ( x -- y )
- "double" "libm" "atanh" { "double" } alien-invoke ;
- foldable
-
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
foldable
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
foldable
+
+! Windows doesn't have these...
+: facosh ( x -- y )
+ "double" "libm" "acosh" { "double" } alien-invoke ;
+ foldable
+
+: fasinh ( x -- y )
+ "double" "libm" "asinh" { "double" } alien-invoke ;
+ foldable
+
+: fatanh ( x -- y )
+ "double" "libm" "atanh" { "double" } alien-invoke ;
+ foldable
: echelon ( matrix -- matrix' )
[ 0 0 (echelon) ] with-matrix ;
-: nonzero-rows [ [ zero? ] all? not ] filter ;
+: nonzero-rows ( matrix -- matrix' )
+ [ [ zero? ] all? not ] filter ;
: null/rank ( matrix -- null rank )
echelon dup length swap nonzero-rows length [ - ] keep ;
<PRIVATE
-: x first ; inline
-: y second ; inline
-: z third ; inline
+: x ( seq -- elt ) first ; inline
+: y ( seq -- elt ) second ; inline
+: z ( seq -- elt ) third ; inline
-: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
-: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
-: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
+: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
+: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
+: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
PRIVATE>
#! divide the last two numbers in the sequences
[ peek ] bi@ / ;
-: (p/mod)
+: (p/mod) ( p p -- p p )
2dup /-last
2dup , n*p swapd
p- >vector
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
+USING: arrays kernel lists math math.primes namespaces sequences ;
IN: math.primes.factors
<PRIVATE
dup empty? [ drop ] [ first , ] if ;
: (factors) ( quot list n -- )
- dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
+ dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
-USING: arrays math.primes tools.test lazy-lists ;
+USING: arrays math.primes tools.test lists.lazy ;
{ 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lazy-lists math math.functions math.miller-rabin
+USING: combinators kernel lists.lazy math math.functions math.miller-rabin
math.order math.primes.list math.ranges sequences sorting ;
IN: math.primes
USING: kernel math math.functions ;
IN: math.quadratic
-: monic ( c b a -- c' b' ) tuck / >r / r> ;
+: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ;
: discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ;
-: critical ( b d -- -b/2 d ) >r -2 / r> ;
+: critical ( b d -- -b/2 d ) [ -2 / ] dip ;
-: +- ( x y -- x+y x-y ) [ + ] 2keep - ;
+: +- ( x y -- x+y x-y ) [ + ] [ - ] 2bi ;
: quadratic ( c b a -- alpha beta )
#! Solve a quadratic equation ax^2 + bx + c = 0
: qeval ( x c b a -- y )
#! Evaluate ax^2 + bx + c
- >r pick * r> roll sq * + + ;
+ [ pick * ] dip roll sq * + + ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting sequences.lib ;
+ sequences splitting grouping sequences.lib ;
IN: math.text.english
<PRIVATE
SYMBOL: and-needed?
: set-conjunction ( seq -- )
- first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ;
+ first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;
: reset-memoized ( word -- )
"memoize" word-prop clear-assoc ;
-: invalidate-memoized ! ( inputs... word )
+: invalidate-memoized ( inputs... word -- )
[ #in packer call ] [ "memoize" word-prop delete-at ] bi ;
{ $slide "Questions?" }
} ;
-: minneapolis-talk minneapolis-slides slides-window ;
+: minneapolis-talk ( -- ) minneapolis-slides slides-window ;
MAIN: minneapolis-talk
: <history> ( value -- history )
history construct-model dup reset-history ;
-: (add-history)
+: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
-USING: tools.test monads math kernel sequences lazy-lists promises ;
+USING: tools.test monads math kernel sequences lists promises ;
IN: monads.tests
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences sequences.deep splitting
-accessors fry locals combinators namespaces lazy-lists
+accessors fry locals combinators namespaces lists lists.lazy
shuffle ;
IN: monads
MIXIN: monad
GENERIC: monad-of ( mvalue -- singleton )
-GENERIC: return ( string singleton -- mvalue )
+GENERIC: return ( value singleton -- mvalue )
GENERIC: fail ( value singleton -- mvalue )
GENERIC: >>= ( mvalue -- quot )
SINGLETON: nothing
TUPLE: just value ;
-: just \ just boa ;
+: just ( value -- just ) \ just boa ;
UNION: maybe just nothing ;
INSTANCE: maybe monad
INSTANCE: either-monad monad
TUPLE: left value ;
-: left \ left boa ;
+: left ( value -- left ) \ left boa ;
TUPLE: right value ;
-: right \ right boa ;
+: right ( value -- right ) \ right boa ;
UNION: either left right ;
INSTANCE: either monad
M: list monad-of drop list-monad ;
-M: list >>= '[ , _ lmap lconcat ] ;
+M: list >>= '[ , _ lazy-map lconcat ] ;
! State
SINGLETON: state-monad
INSTANCE: state-monad monad
TUPLE: state quot ;
-: state \ state boa ;
+: state ( quot -- state ) \ state boa ;
INSTANCE: state monad
M: state-monad return drop '[ , 2array ] state ;
M: state-monad fail "Fail" throw ;
-: mcall quot>> call ;
+: mcall ( state -- ) quot>> call ;
M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
: run-st ( state initial -- ) swap mcall second ;
-: return-st state-monad return ;
+: return-st ( value -- mvalue ) state-monad return ;
! Reader
SINGLETON: reader-monad
INSTANCE: reader-monad monad
TUPLE: reader quot ;
-: reader \ reader boa ;
+: reader ( quot -- reader ) \ reader boa ;
INSTANCE: reader monad
M: reader monad-of drop reader-monad ;
INSTANCE: writer-monad monad
TUPLE: writer value log ;
-: writer \ writer boa ;
+: writer ( value log -- writer ) \ writer boa ;
M: writer monad-of drop writer-monad ;
USING: io kernel math math.functions math.parser parser
-namespaces sequences splitting combinators continuations
-sequences.lib ;
+namespaces sequences splitting grouping combinators
+continuations sequences.lib ;
IN: money
: dollars/cents ( dollars -- dollars cents )
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
IN: morse
<PRIVATE
USING: kernel io parser words namespaces quotations arrays assocs sequences
- splitting math shuffle ;
+ splitting grouping math shuffle ;
IN: mortar
"multi-method-generic" word-prop stack-effect ;
M: method-body crossref?
- drop t ;
+ "forgotten" word-prop not ;
: method-word-name ( specializer generic -- string )
[ word-name % "-" % unparse % ] "" make ;
drop [ <method> dup ] 2keep reveal-method
] if ;
-: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
: create-method-in ( specializer generic -- method )
create-method dup save-location f set-word ;
-: CREATE-METHOD
+: CREATE-METHOD ( -- method )
scan-word scan-object swap create-method-in ;
-: (METHOD:) CREATE-METHOD parse-definition ;
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
: METHOD: (METHOD:) define ; parsing
: get-building-seq ( n -- seq )
building-seq get nth ;
-: n, get-building-seq push ;
-: n% get-building-seq push-all ;
-: n# >r number>string r> n% ;
-
-: 0, 0 n, ;
-: 0% 0 n% ;
-: 0# 0 n# ;
-: 1, 1 n, ;
-: 1% 1 n% ;
-: 1# 1 n# ;
-: 2, 2 n, ;
-: 2% 2 n% ;
-: 2# 2 n# ;
-: 3, 3 n, ;
-: 3% 3 n% ;
-: 3# 3 n# ;
-: 4, 4 n, ;
-: 4% 4 n% ;
-: 4# 4 n# ;
+: n, ( obj n -- ) get-building-seq push ;
+: n% ( seq n -- ) get-building-seq push-all ;
+: n# ( num n -- ) >r number>string r> n% ;
+
+: 0, ( obj -- ) 0 n, ;
+: 0% ( seq -- ) 0 n% ;
+: 0# ( num -- ) 0 n# ;
+: 1, ( obj -- ) 1 n, ;
+: 1% ( seq -- ) 1 n% ;
+: 1# ( num -- ) 1 n# ;
+: 2, ( obj -- ) 2 n, ;
+: 2% ( seq -- ) 2 n% ;
+: 2# ( num -- ) 2 n# ;
+: 3, ( obj -- ) 3 n, ;
+: 3% ( seq -- ) 3 n% ;
+: 3# ( num -- ) 3 n# ;
+: 4, ( obj -- ) 4 n, ;
+: 4% ( seq -- ) 4 n% ;
+: 4# ( num -- ) 4 n# ;
MACRO:: nmake ( quot exemplars -- )
[let | n [ exemplars length ] |
nehe.2 nehe.3 nehe.4 nehe.5 kernel ;
IN: nehe
-: nehe-window
+: nehe-window ( -- )
[
[
"Nehe 2" [ drop run2 ] <bevel-button> gadget,
-USING: kernel sequences assocs qualified circular ;
+USING: kernel sequences assocs qualified circular sets ;
USING: math multi-methods ;
QUALIFIED: sequences
QUALIFIED: assocs
QUALIFIED: circular
+QUALIFIED: sets
IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 1st 0 at ;
-: 2nd 1 at ;
-: 3rd 2 at ;
-: 4th 3 at ;
-: 5th 4 at ;
-: 6th 5 at ;
-: 7th 6 at ;
-: 8th 7 at ;
-: 9th 8 at ;
+: 1st ( seq -- obj ) 0 at ;
+: 2nd ( seq -- obj ) 1 at ;
+: 3rd ( seq -- obj ) 2 at ;
+: 4th ( seq -- obj ) 3 at ;
+: 5th ( seq -- obj ) 4 at ;
+: 6th ( seq -- obj ) 5 at ;
+: 7th ( seq -- obj ) 6 at ;
+: 8th ( seq -- obj ) 7 at ;
+: 9th ( seq -- obj ) 8 at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
-! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
+! indicate that this is the main objective of the word, as a side effect.
+
+: adjoin ( seq elt -- seq ) over sets:adjoin ;
+: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
+: adjoined ( set elt -- ) swap sets:adjoin ;
+: adjoined-on ( elt set -- ) sets:adjoin ;
\ No newline at end of file
: read-number ( -- n ) readln string>number ;
-: guess-banner
+: guess-banner ( -- )
"I'm thinking of a number between 0 and 100." print ;
-: guess-prompt "Enter your guess: " write ;
-: too-high "Too high" print ;
-: too-low "Too low" print ;
-: correct "Correct - you win!" print ;
+: guess-prompt ( -- ) "Enter your guess: " write ;
+: too-high ( -- ) "Too high" print ;
+: too-low ( -- ) "Too low" print ;
+: correct ( -- ) "Correct - you win!" print ;
: inexact-guess ( actual guess -- )
< [ too-high ] [ too-low ] if ;
dup guess-prompt read-number judge-guess
[ numbers-game-loop ] [ drop ] if ;
-: numbers-game number-to-guess numbers-game-loop ;
+: numbers-game ( -- ) number-to-guess numbers-game-loop ;
MAIN: numbers-game
f init set-global
] unless ;
-: <uint-array> "ALuint" <c-array> ;
+: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
: gen-sources ( size -- seq )
dup <uint-array> 2dup alGenSources swap c-uint-array> ;
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
-IN: opengl.framebuffers
-
-HELP: gen-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
-
-HELP: gen-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
-
-HELP: delete-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
-
-HELP: delete-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
-
-{ gen-framebuffer delete-framebuffer } related-words
-{ gen-renderbuffer delete-renderbuffer } related-words
-
-HELP: framebuffer-incomplete?
-{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
-
-HELP: check-framebuffer
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
-
-HELP: with-framebuffer
-{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
-{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
-
-ABOUT: "gl-utilities"
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.framebuffers
+
+HELP: gen-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
+
+HELP: gen-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
+
+HELP: delete-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
+
+HELP: delete-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
+
+{ gen-framebuffer delete-framebuffer } related-words
+{ gen-renderbuffer delete-renderbuffer } related-words
+
+HELP: framebuffer-incomplete?
+{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
+
+HELP: check-framebuffer
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
+
+HELP: with-framebuffer
+{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
+{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
+
+ABOUT: "gl-utilities"
\ No newline at end of file
--- /dev/null
+IN: opengl.gadgets.tests
+USING: tools.test opengl.gadgets ;
+
+\ render* must-infer
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
opengl.gl accessors kernel opengl ui.gadgets
+fry assocs
destructors sequences ui.render colors ;
IN: opengl.gadgets
-TUPLE: texture-gadget bytes format dim tex ;
+TUPLE: texture-gadget ;
+
+GENERIC: render* ( gadget -- texture dims )
+GENERIC: cache-key* ( gadget -- key )
+
+M: texture-gadget cache-key* ;
+
+SYMBOL: textures
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+ dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+refcounts init-cache
+
+: refcount-change ( gadget quot -- )
+ >r cache-key* refcounts get
+ [ [ 0 ] unless* ] r> compose change-at ;
+
+TUPLE: cache-entry tex dims ;
+C: <entry> cache-entry
+
+: make-entry ( gadget -- entry )
+ dup render* <entry>
+ [ swap cache-key* textures get set-at ] keep ;
+
+: get-entry ( gadget -- {texture,dims} )
+ dup cache-key* textures get at
+ [ nip ] [ make-entry ] if* ;
+
+: get-dims ( gadget -- dims )
+ get-entry dims>> ;
+
+: get-texture ( gadget -- texture )
+ get-entry tex>> ;
+
+: release-texture ( gadget -- )
+ cache-key* textures get delete-at*
+ [ tex>> delete-texture ] [ drop ] if ;
+
+M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+
+M: texture-gadget ungraft* ( gadget -- )
+ dup [ 1- ] refcount-change
+ dup cache-key* refcounts get at
+ zero? [ release-texture ] [ drop ] if ;
: 2^-ceil ( x -- y )
dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
: 2^-bounds ( dim -- dim' )
[ 2^-ceil ] map ; foldable flushable
-: <texture-gadget> ( bytes format dim -- gadget )
- texture-gadget construct-gadget
- swap >>dim
- swap >>format
- swap >>bytes ;
-
-:: render ( gadget -- )
+:: (render-bytes) ( dims bytes format texture -- )
GL_ENABLE_BIT [
GL_TEXTURE_2D glEnable
- GL_TEXTURE_2D gadget tex>> glBindTexture
+ GL_TEXTURE_2D texture glBindTexture
GL_TEXTURE_2D
0
GL_RGBA
- gadget dim>> 2^-bounds first2
+ dims 2^-bounds first2
0
- gadget format>>
+ format
GL_UNSIGNED_BYTE
- gadget bytes>>
+ bytes
glTexImage2D
init-texture
GL_TEXTURE_2D 0 glBindTexture
] do-attribs ;
+: render-bytes ( dims bytes format -- texture )
+ gen-texture [ (render-bytes) ] keep ;
+
+: render-bytes* ( dims bytes format -- texture dims )
+ pick >r render-bytes r> ;
+
:: four-corners ( dim -- )
[let* | w [ dim first ]
h [ dim second ]
white gl-color
1.0 -1.0 glPixelZoom
GL_TEXTURE_2D glEnable
- GL_TEXTURE_2D over tex>> glBindTexture
+ GL_TEXTURE_2D over get-texture glBindTexture
GL_QUADS [
- dim>> four-corners
+ get-dims four-corners
] do-state
GL_TEXTURE_2D 0 glBindTexture
] do-attribs
] with-translation ;
-M: texture-gadget graft* ( gadget -- )
- gen-texture >>tex [ render ]
- [ f >>bytes f >>format drop ] bi ;
-
-M: texture-gadget ungraft* ( gadget -- )
- tex>> delete-texture ;
-
-M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;
+M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
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 [ first2 ] bi@ ;
+: coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 ] bi@ ;
-: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ;
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 [ >fixnum ] bi@ ] bi@ ;
: gl-color ( color -- ) first4 glColor4d ; inline
>r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
-: (gl-poly) [ [ gl-vertex ] each ] do-state ;
+: (gl-poly) ( points state -- )
+ [ [ gl-vertex ] each ] do-state ;
: gl-fill-poly ( points -- )
dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
: gl-poly ( points -- )
GL_LINE_LOOP (gl-poly) ;
-: circle-steps dup length v/n 2 pi * v*n ;
+: circle-steps ( steps -- angles )
+ dup length v/n 2 pi * v*n ;
-: unit-circle dup [ sin ] map swap [ cos ] map ;
+: unit-circle ( angles -- points1 points2 )
+ [ [ sin ] map ] [ [ cos ] map ] bi ;
-: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ;
+: adjust-points ( points1 points2 -- points1' points2' )
+ [ [ 1 + 0.5 * ] map ] bi@ ;
-: scale-points zip [ v* ] with map [ v+ ] with map ;
+: scale-points ( loc dim points1 points2 -- points )
+ zip [ v* ] with map [ v+ ] with map ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
: <sprite> ( loc dim dim2 -- sprite )
f f sprite boa ;
-: sprite-size2 sprite-dim2 first2 ;
+: sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ;
-: sprite-width sprite-dim first ;
+: sprite-width ( sprite -- w ) sprite-dim first ;
: gray-texture ( sprite pixmap -- id )
gen-texture [
! Copyright (C) 2007 Elie CHAFTARI
+! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
USING: alien alien.syntax combinators kernel system namespaces
-assocs parser sequences words quotations ;
+assocs parser sequences words quotations math.bitfields ;
IN: openssl.libssl
: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
-: SSL_CTRL_NEED_TMP_RSA 1 ; inline
-: SSL_CTRL_SET_TMP_RSA 2 ; inline
-: SSL_CTRL_SET_TMP_DH 3 ; inline
-: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
-: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+: SSL_CTRL_NEED_TMP_RSA 1 ; inline
+: SSL_CTRL_SET_TMP_RSA 2 ; inline
+: SSL_CTRL_SET_TMP_DH 3 ; inline
+: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
+: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+
+: SSL_CTRL_GET_SESSION_REUSED 6 ; inline
+: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline
+: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline
+: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline
+: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline
+: SSL_CTRL_GET_FLAGS 11 ; inline
+: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline
+
+: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline
+: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline
+
+: SSL_CTRL_SESS_NUMBER 20 ; inline
+: SSL_CTRL_SESS_CONNECT 21 ; inline
+: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline
+: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline
+: SSL_CTRL_SESS_ACCEPT 24 ; inline
+: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline
+: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline
+: SSL_CTRL_SESS_HIT 27 ; inline
+: SSL_CTRL_SESS_CB_HIT 28 ; inline
+: SSL_CTRL_SESS_MISSES 29 ; inline
+: SSL_CTRL_SESS_TIMEOUTS 30 ; inline
+: SSL_CTRL_SESS_CACHE_FULL 31 ; inline
+: SSL_CTRL_OPTIONS 32 ; inline
+: SSL_CTRL_MODE 33 ; inline
+
+: SSL_CTRL_GET_READ_AHEAD 40 ; inline
+: SSL_CTRL_SET_READ_AHEAD 41 ; inline
+: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline
+: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline
+: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline
+: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline
+
+: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline
+: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline
: SSL_ERROR_NONE 0 ; inline
: SSL_ERROR_SSL 1 ; inline
} ;
TYPEDEF: void* ssl-method
-TYPEDEF: void* ssl-ctx
-TYPEDEF: void* ssl-pointer
+TYPEDEF: void* SSL_CTX*
+TYPEDEF: void* SSL_SESSION*
+TYPEDEF: void* SSL*
LIBRARY: libssl
! ssl.h
! ===============================================
-FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ;
+FUNCTION: char* SSL_get_version ( SSL* ssl ) ;
! Maps OpenSSL errors to strings
FUNCTION: void SSL_load_error_strings ( ) ;
FUNCTION: ssl-method TLSv1_method ( ) ;
! Creates the context
-FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
+FUNCTION: SSL_CTX* SSL_CTX_new ( ssl-method method ) ;
! Load the certificates and private keys into the SSL_CTX
-FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
+FUNCTION: int SSL_CTX_use_certificate_chain_file ( SSL_CTX* ctx,
char* file ) ; ! PEM type
-FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
+FUNCTION: SSL* SSL_new ( SSL_CTX* ctx ) ;
+
+FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ;
-FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
+FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ;
-FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ;
+FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ;
-FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ;
+FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ;
-FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ;
-FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ;
-FUNCTION: int SSL_connect ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_connect ( SSL* ssl ) ;
-FUNCTION: int SSL_accept ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_accept ( SSL* ssl ) ;
-FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
+FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ;
-FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
+FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ;
-FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_shutdown ( SSL* ssl ) ;
: SSL_SENT_SHUTDOWN 1 ;
: SSL_RECEIVED_SHUTDOWN 2 ;
-FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ;
+
+FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ;
+
+FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ;
+
+FUNCTION: void SSL_free ( SSL* ssl ) ;
-FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ;
-FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_want ( SSL* ssl ) ;
: SSL_NOTHING 1 ; inline
: SSL_WRITING 2 ; inline
FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ;
-FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
+FUNCTION: void SSL_CTX_free ( SSL_CTX* ctx ) ;
FUNCTION: void RAND_seed ( void* buf, int num ) ;
-FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ;
+FUNCTION: int SSL_set_cipher_list ( SSL* ssl, char* str ) ;
-FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ;
+FUNCTION: int SSL_use_RSAPrivateKey_file ( SSL* ssl, char* str ) ;
-FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ;
+FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( SSL_CTX* ctx, int type ) ;
-FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
+FUNCTION: int SSL_use_certificate_file ( SSL* ssl,
char* str, int type ) ;
-FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
+FUNCTION: int SSL_CTX_load_verify_locations ( SSL_CTX* ctx, char* CAfile,
char* CApath ) ;
-FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
+FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ;
: SSL_VERIFY_NONE 0 ; inline
: SSL_VERIFY_PEER 1 ; inline
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
-FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
+FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ;
-FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
+FUNCTION: void SSL_CTX_set_client_CA_list ( SSL_CTX* ctx, SSL* list ) ;
-FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
+FUNCTION: SSL* SSL_load_client_CA_file ( char* file ) ;
! Used to manipulate settings of the SSL_CTX and SSL objects.
! This function should never be called directly
-FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ;
+FUNCTION: long SSL_CTX_ctrl ( SSL_CTX* ctx, int cmd, long larg, void* parg ) ;
-FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ;
+FUNCTION: void SSL_CTX_set_default_passwd_cb ( SSL_CTX* ctx, void* cb ) ;
-FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx,
+FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( SSL_CTX* ctx,
void* u ) ;
-FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file,
+FUNCTION: int SSL_CTX_use_PrivateKey_file ( SSL_CTX* ctx, char* file,
int type ) ;
-! Sets the maximum depth for the allowed ctx certificate chain verification
-FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ;
+! Sets the maximum depth for the allowed ctx certificate chain verification
+FUNCTION: void SSL_CTX_set_verify_depth ( SSL_CTX* ctx, int depth ) ;
! Sets DH parameters to be used to be dh.
! The key is inherited by all ssl objects created from ctx
-FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ;
+FUNCTION: void SSL_CTX_set_tmp_dh_callback ( SSL_CTX* ctx, void* dh ) ;
-FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
+FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
+: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
+ >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
+
+: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
+: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline
+: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline
+
+: SSL_SESS_CACHE_BOTH ( -- n )
+ { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
+
+: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline
+: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline
+: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline
+
+: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
+ { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+
! ===============================================
! x509.h
! ===============================================
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors debugger inspector
-locals unicode.case
+continuations destructors debugger inspector splitting assocs
+random math.parser locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
io.timeouts ;
[ f ssl-initialized? set-global ] "openssl" add-init-hook
-TUPLE: openssl-context < secure-context aliens ;
+TUPLE: openssl-context < secure-context aliens sessions ;
+
+: set-session-cache ( ctx -- )
+ handle>>
+ [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
+ [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
+ bi ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
TUPLE: bio handle disposed ;
-: <bio> f bio boa ;
+: <bio> ( handle -- bio ) f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
TUPLE: rsa handle disposed ;
-: <rsa> f rsa boa ;
+: <rsa> ( handle -- rsa ) f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
+: <openssl-context> ( config ctx -- context )
+ openssl-context new
+ swap >>handle
+ swap >>config
+ V{ } clone >>aliens
+ H{ } clone >>sessions ;
+
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
- dup ssl-error f V{ } clone openssl-context boa |dispose
+ dup ssl-error <openssl-context> |dispose
{
+ [ set-session-cache ]
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
M: openssl-context dispose*
[ aliens>> [ free ] each ]
+ [ sessions>> values [ SSL_SESSION_free ] each ]
[ handle>> SSL_CTX_free ]
- bi ;
+ tri ;
TUPLE: ssl-handle file handle connected disposed ;
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
+: common-names-match? ( expected actual -- ? )
+ [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
+
: check-common-name ( host ssl-handle -- )
- SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
+ SSL_get_peer_certificate common-name
+ 2dup common-names-match?
[ 2drop ] [ common-name-verify-error ] if ;
M: openssl check-certificate ( host ssl -- )
2bi
] [ 2drop ] if ;
+: get-session ( addrspec -- session/f )
+ current-secure-context sessions>> at
+ dup expired? [ drop f ] when ;
+
+: save-session ( session addrspec -- )
+ current-secure-context sessions>> set-at ;
+
openssl secure-socket-backend set-global
kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros
assocs sequences.private optimizer.specializers generic
-combinators sorting math quotations ;
+combinators sorting math quotations accessors ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
: effect-str ( node -- str )
[
- " " over node-in-d values%
- " r: " over node-in-r values%
+ " " over in-d>> values%
+ " r: " over in-r>> values%
" --" %
- " " over node-out-d values%
- " r: " swap node-out-r values%
+ " " over out-d>> values%
+ " r: " swap out-r>> values%
] "" make rest ;
MACRO: match-choose ( alist -- )
} match-choose ;
M: #shuffle node>quot
- dup node-in-d over node-out-d pretty-shuffle
+ dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
[ , ] [ >r drop t r> ] if*
dup effect-str "#shuffle: " prepend comment, ;
-: pushed-literals node-out-d [ value-literal literalize ] map ;
+: pushed-literals ( node -- seq )
+ out-d>> [ value-literal literalize ] map ;
M: #push node>quot nip pushed-literals % ;
DEFER: dataflow>quot
: #call>quot ( ? node -- )
- dup node-param dup ,
+ dup param>> dup ,
[ dup effect-str ] [ "empty call" ] if comment, ;
M: #call node>quot #call>quot ;
M: #label node>quot
[
- dup node-param literalize ,
+ dup param>> literalize ,
dup #label-loop? "#loop: " "#label: " ?
- over node-param word-name append comment,
+ over param>> word-name append comment,
] 2keep
node-child swap dataflow>quot , \ call , ;
M: #if node>quot
[ "#if" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map %
+ children>> swap [ dataflow>quot ] curry map %
\ if , ;
M: #dispatch node>quot
[ "#dispatch" comment, ] 2keep
- node-children swap [ dataflow>quot ] curry map ,
+ children>> swap [ dataflow>quot ] curry map ,
\ dispatch , ;
-M: #>r node>quot nip
node-in-d length \ >r <array> % ;
+M: #>r node>quot nip
in-d>> length \ >r <array> % ;
-M: #r> node>quot nip
node-out-d length \ r> <array> % ;
+M: #r> node>quot nip
out-d>> length \ r> <array> % ;
M: object node>quot
[
dup class word-name %
" " %
- dup node-param unparse %
+ dup param>> unparse %
" " %
dup effect-str %
] "" make comment, ;
: (dataflow>quot) ( ? node -- )
dup [
- 2dup node>quot node-successor (dataflow>quot)
+ 2dup node>quot successor>> (dataflow>quot)
] [
2drop
] if ;
0 swap [
>r 1+ r>
dup #call? [
- node-param {
+ param>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
>r optimize-1\r
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
\r
-: results\r
+: results ( seq -- )\r
[ [ second ] prepose compare ] curry sort 20 tail*\r
print\r
standard-table-style\r
[ [ [ pprint-cell ] each ] with-row ] each\r
] tabular-output ;\r
\r
-: optimizer-report\r
+: optimizer-report ( -- )\r
all-words [ compiled? ] filter\r
[\r
dup [\r
USING: kernel namespaces
math math.constants math.functions math.matrices math.vectors
- sequences splitting self math.trig ;
+ sequences splitting grouping self math.trig ;
IN: ori
! pangocairo bindings, from pango/pangocairo.h
USING: cairo.ffi alien.c-types math
alien.syntax system combinators alien
+memoize
arrays pango pango.fonts ;
IN: pango.cairo
<< "pangocairo" {
-! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
-! { [ os macosx? ] [ "libpangocairo.dylib" ] }
+ { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] }
+ { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] }
{ [ os unix? ] [ "libpangocairo-1.0.so" ] }
} cond "cdecl" add-library >>
! Higher level words and combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: destructors accessors namespaces kernel cairo ;
-
-TUPLE: pango-layout alien ;
-C: <pango-layout> pango-layout
-M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
-
-: layout ( -- pango-layout ) pango-layout get ;
+USING: pango.layouts
+destructors accessors namespaces kernel cairo ;
: (with-pango) ( layout quot -- )
>r alien>> pango-layout r> with-variable ; inline
-: with-pango ( quot -- )
- cr pango_cairo_create_layout <pango-layout> swap
- [ (with-pango) ] curry with-disposal ; inline
+: with-pango-cairo ( quot -- )
+ cr pango_cairo_create_layout swap with-layout ; inline
-: pango-layout-get-pixel-size ( layout -- width height )
- 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
- [ *int ] bi@ ;
+MEMO: dummy-cairo ( -- cr )
+ CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ;
: dummy-pango ( quot -- )
- >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
- r> [ with-pango ] curry with-cairo-from-surface ; inline
+ >r dummy-cairo cairo r> [ with-pango-cairo ] curry with-variable ; inline
: layout-size ( quot -- dim )
[ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
-: layout-font ( str -- )
- pango_font_description_from_string
- dup zero? [ "pango: not a valid font." throw ] when
- layout over pango_layout_set_font_description
- pango_font_description_free ;
-
-: layout-text ( str -- )
- layout swap -1 pango_layout_set_text ;
+: show-layout ( -- )
+ cr layout pango_cairo_show_layout ;
: families ( -- families )
pango_cairo_font_map_get_default list-families ;
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: pango.cairo cairo cairo.ffi cairo.gadgets
-alien.c-types kernel math ;
+USING: pango.cairo pango.gadgets
+cairo.gadgets arrays namespaces
+fry accessors ui.gadgets
+sequences opengl.gadgets
+kernel pango.layouts ;
+
IN: pango.cairo.gadgets
-: (pango-gadget) ( setup show -- gadget )
- [ drop layout-size ]
- [ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
+TUPLE: pango-cairo-gadget < pango-gadget ;
-: <pango-gadget> ( quot -- gadget )
- [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
+SINGLETON: pango-cairo-backend
+pango-cairo-backend pango-backend set-global
-USING: prettyprint sequences ui.gadgets.panes
-threads io.backend io.encodings.utf8 io.files ;
-: hello-pango ( -- )
- 50 [ 6 + ] map [
- "Sans " swap unparse append
- [
- cr 0 1 0.2 0.6 cairo_set_source_rgba
- layout-font "今日は、 Pango!" layout-text
- ] curry
- <pango-gadget> gadget. yield
- ] each
- [
- "resource:extra/pango/cairo/gadgets/gadgets.factor"
- normalize-path utf8 file-contents layout-text
- ] <pango-gadget> gadget. ;
+M: pango-cairo-backend construct-pango
+ pango-cairo-gadget construct-gadget ;
-MAIN: hello-pango
+: setup-layout ( gadget -- quot )
+ [ font>> ] [ text>> ] bi
+ '[ , layout-font , layout-text ] ; inline
+
+M: pango-cairo-gadget render* ( gadget -- )
+ setup-layout [ layout-size dup ]
+ [
+ '[ [ @ show-layout ] with-pango-cairo ]
+ ] bi render-cairo render-bytes* ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: prettyprint sequences ui.gadgets.panes
+pango.cairo.gadgets math kernel cairo cairo.ffi
+pango.cairo pango.gadgets tools.time namespaces assocs
+threads io.backend io.encodings.utf8 io.files ;
+
+IN: pango.cairo.samples
+
+: hello-pango ( -- )
+ "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor"
+ normalize-path utf8 file-contents
+ <pango> gadget. ;
+
+: time-pango ( -- )
+ [ hello-pango ] time ;
+
+MAIN: time-pango
--- /dev/null
+USING: alien alien.c-types
+math kernel byte-arrays freetype
+opengl.gadgets accessors pango
+ui.gadgets memoize
+arrays sequences libc opengl.gl
+system combinators alien.syntax
+pango.layouts ;
+IN: pango.ft2
+
+<< "pangoft2" {
+ { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] }
+ { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] }
+ { [ os unix? ] [ "libpangoft2-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pangoft2
+
+FUNCTION: PangoFontMap*
+pango_ft2_font_map_new ( ) ;
+
+FUNCTION: PangoContext*
+pango_ft2_font_map_create_context ( PangoFT2FontMap* fontmap ) ;
+
+FUNCTION: void
+pango_ft2_render_layout ( FT_Bitmap* bitmap, PangoLayout* layout, int x, int y ) ;
+
+: 4*-ceil ( n -- k*4 )
+ 3 + 4 /i 4 * ;
+
+: <ft-bitmap> ( width height -- ft-bitmap )
+ swap dup
+ 2dup * 4*-ceil
+ "uchar" malloc-array
+ 256
+ FT_PIXEL_MODE_GRAY
+ "FT_Bitmap" <c-object> dup >r
+ {
+ set-FT_Bitmap-rows
+ set-FT_Bitmap-width
+ set-FT_Bitmap-pitch
+ set-FT_Bitmap-buffer
+ set-FT_Bitmap-num_grays
+ set-FT_Bitmap-pixel_mode
+ } set-slots r> ;
+
+: render-layout ( layout -- dims alien )
+ [
+ pango-layout-get-pixel-size
+ 2array dup 2^-bounds first2 <ft-bitmap> dup
+ ] [ 0 0 pango_ft2_render_layout ] bi FT_Bitmap-buffer ;
+
+MEMO: ft2-context ( -- PangoContext* )
+ pango_ft2_font_map_new pango_ft2_font_map_create_context ;
+
+: with-ft2-layout ( quot -- )
+ ft2-context pango_layout_new swap with-layout ; inline
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: pango.ft2 pango.gadgets opengl.gadgets
+accessors kernel opengl.gl libc
+sequences namespaces ui.gadgets pango.layouts ;
+IN: pango.ft2.gadgets
+
+TUPLE: pango-ft2-gadget < pango-gadget ;
+
+SINGLETON: pango-ft2-backend
+pango-ft2-backend pango-backend set-global
+
+M: pango-ft2-backend construct-pango
+ pango-ft2-gadget construct-gadget ;
+
+M: pango-ft2-gadget render*
+ [
+ [ text>> layout-text ] [ font>> layout-font ] bi
+ layout render-layout
+ ] with-ft2-layout [ GL_ALPHA render-bytes* ] keep free ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: opengl.gadgets kernel
+arrays
+accessors ;
+
+IN: pango.gadgets
+
+TUPLE: pango-gadget < texture-gadget text font ;
+
+M: pango-gadget cache-key* [ font>> ] [ text>> ] bi 2array ;
+
+SYMBOL: pango-backend
+HOOK: construct-pango pango-backend ( -- gadget )
+
+: <pango> ( font text -- gadget )
+ construct-pango
+ swap >>text
+ swap >>font ;
--- /dev/null
+USING: alien alien.c-types
+math
+destructors accessors namespaces
+pango kernel ;
+IN: pango.layouts
+
+: pango-layout-get-pixel-size ( layout -- width height )
+ 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
+ [ *int ] bi@ ;
+
+TUPLE: pango-layout alien ;
+C: <pango-layout> pango-layout
+M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
+
+: layout ( -- pango-layout ) pango-layout get ;
+
+: (with-layout) ( pango-layout quot -- )
+ >r alien>> pango-layout r> with-variable ; inline
+
+: with-layout ( layout quot -- )
+ >r <pango-layout> r> [ (with-layout) ] curry with-disposal ; inline
+
+: layout-font ( str -- )
+ pango_font_description_from_string
+ dup zero? [ "pango: not a valid font." throw ] when
+ layout over pango_layout_set_font_description
+ pango_font_description_free ;
+
+: layout-text ( str -- )
+ layout swap -1 pango_layout_set_text ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<< "pango" {
-! { [ os winnt? ] [ "libpango-1.dll" ] }
-! { [ os macosx? ] [ "libpango.dylib" ] }
+ { [ os winnt? ] [ "libpango-1.0-0.dll" ] }
+ { [ os macosx? ] [ "libpango-1.0.0.dylib" ] }
{ [ os unix? ] [ "libpango-1.0.so" ] }
} cond "cdecl" add-library >>
: PANGO_SCALE 1024 ;
+FUNCTION: PangoLayout*
+pango_layout_new ( PangoContext* context ) ;
+
FUNCTION: void
pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
"from the input string. The value consumed is the "
"result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
+{ $example "USING: lists.lazy parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel lazy-lists tools.test strings math
+USING: kernel lists.lazy tools.test strings math
sequences parser-combinators arrays math.parser unicode.categories ;
IN: parser-combinators.tests
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists promises kernel sequences strings math
+USING: lists lists.lazy promises kernel sequences strings math
arrays splitting quotations combinators namespaces
unicode.case unicode.categories sequences.deep ;
IN: parser-combinators
>r parse-result-parsed r>
[ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result>
- ] lmap-with
- ] lmap-with lconcat ;
+ ] lazy-map-with
+ ] lazy-map-with lconcat ;
M: and-parser parse ( input parser -- list )
#! Parse 'input' by sequentially combining the
#! of parser1 and parser2 being applied to the same
#! input. This implements the choice parsing operator.
or-parser-parsers 0 swap seq>list
- [ parse ] lmap-with lconcat ;
+ [ parse ] lazy-map-with lconcat ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
-rot parse [
[ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result>
- ] lmap-with ;
+ ] lazy-map-with ;
TUPLE: some-parser p1 ;
"the input string. The numeric value of the digit "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
HELP: 'integer'
{ $values
"the input string. The numeric value of the integer "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
HELP: 'string'
{ $values
{ "parser" "a parser object" } }
"quotations from the input string. The string value "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
HELP: 'bold'
{ $values
"'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings math sequences lazy-lists words
+USING: kernel strings math sequences lists.lazy words
math.parser promises parser-combinators unicode.categories ;
IN: parser-combinators.simple
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words math math.parser
- sequences accessors ;
+ sequences accessors peg.parsers parser namespaces arrays
+ strings ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
] unit-test
{ 6 } [
- "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call ast>>
+ "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] call ast>>
] unit-test
{ 6 } [
- "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call ast>>
+ "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] call ast>>
] unit-test
{ 10 } [
- { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
+ { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>>
] unit-test
{ f } [
- { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call
+ { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call
] unit-test
{ 3 } [
- { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
+ { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>>
] unit-test
{ f } [
] unit-test
{ t } [
- "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty?
+ "abcd='9' | ('8'):x => [[ x ]]" 'ebnf' parse parse-result-remaining empty?
] unit-test
EBNF: primary
"ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
] unit-test
+{ V{ "a" "a" "a" } } [
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>>
+] unit-test
+
+{ t } [
+ "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] call ast>> =
+] unit-test
+
+{ V{ "a" "a" "a" } } [
+ "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>>
+] unit-test
+
+{ t } [
+ "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>>
+ "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] call ast>> =
+] unit-test
+
+{ t } [
+ "number=(digit)+:n 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "number=(digit)+ 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "number=digit+ 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "number=digit+:n 'a'" 'ebnf' parse remaining>> length zero?
+] unit-test
+
+{ t } [
+ "foo=(name):n !(keyword) => [[ n ]]" 'rule' parse ast>>
+ "foo=name:n !(keyword) => [[ n ]]" 'rule' parse ast>> =
+] unit-test
+
+{ t } [
+ "foo=!(keyword) (name):n => [[ n ]]" 'rule' parse ast>>
+ "foo=!(keyword) name:n => [[ n ]]" 'rule' parse ast>> =
+] unit-test
+
+<<
+EBNF: parser1
+foo='a'
+;EBNF
+>>
+
+EBNF: parser2
+foo=<foreign parser1 foo> 'b'
+;EBNF
+
+EBNF: parser3
+foo=<foreign parser1> 'c'
+;EBNF
+
+EBNF: parser4
+foo=<foreign any-char> 'd'
+;EBNF
+
+{ "a" } [
+ "a" parser1 ast>>
+] unit-test
+
+{ V{ "a" "b" } } [
+ "ab" parser2 ast>>
+] unit-test
+
+{ V{ "a" "c" } } [
+ "ac" parser3 ast>>
+] unit-test
+
+{ V{ CHAR: a "d" } } [
+ "ad" parser4 ast>>
+] unit-test
+
+{ t } [
+ "USING: kernel peg.ebnf ; [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t
+] unit-test
+
+[
+ "USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval drop
+] must-fail
+
+{ t } [
+ #! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule
+ #! if a var in a namespace is set. This unit test is to remind me to fix this.
+ [ "fail" "foo" set "foo='a'" 'ebnf' parse ast>> transform drop t ] with-scope
+] unit-test
+
+#! Tokenizer tests
+{ V{ "a" CHAR: b } } [
+ "ab" [EBNF tokenizer=default foo="a" . EBNF] call ast>>
+] unit-test
+
+TUPLE: ast-number value ;
+
+EBNF: a-tokenizer
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = Digit+
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
+Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
+Spaces = Space* => [[ ignore ]]
+Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
+ | Digits => [[ >string string>number ast-number boa ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "~=" | "===" | "==" | "=" | ">="
+ | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
+ | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
+ | "&&" | "||=" | "||" | "." | "!"
+Tok = Spaces (Number | Special )
+;EBNF
+
+{ V{ CHAR: 1 T{ ast-number f 23 } ";" CHAR: x } } [
+ "123;x" [EBNF bar = .
+ tokenizer = <foreign a-tokenizer Tok> foo=.
+ tokenizer=default baz=.
+ main = bar foo foo baz
+ EBNF] call ast>>
+] unit-test
+
+{ V{ CHAR: 5 "+" CHAR: 2 } } [
+ "5+2" [EBNF
+ space=(" " | "\n")
+ number=[0-9]
+ operator=("*" | "+")
+ spaces=space* => [[ ignore ]]
+ tokenizer=spaces (number | operator)
+ main= . . .
+ EBNF] call ast>>
+] unit-test
+
+{ V{ CHAR: 5 "+" CHAR: 2 } } [
+ "5 + 2" [EBNF
+ space=(" " | "\n")
+ number=[0-9]
+ operator=("*" | "+")
+ spaces=space* => [[ ignore ]]
+ tokenizer=spaces (number | operator)
+ main= . . .
+ EBNF] call ast>>
+] unit-test
+
+{ "++" } [
+ "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] call ast>>
+] unit-test
\ No newline at end of file
! Copyright (C) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel compiler.units parser words arrays strings math.parser sequences \r
+USING: kernel compiler.units words arrays strings math.parser sequences \r
quotations vectors namespaces math assocs continuations peg\r
- peg.parsers unicode.categories multiline combinators.lib \r
- splitting accessors effects sequences.deep peg.search ;\r
+ peg.parsers unicode.categories multiline combinators combinators.lib \r
+ splitting accessors effects sequences.deep peg.search inference \r
+ io.streams.string io prettyprint parser ;\r
IN: peg.ebnf\r
\r
+: rule ( name word -- parser )\r
+ #! Given an EBNF word produced from EBNF: return the EBNF rule\r
+ "ebnf-parser" word-prop at ;\r
+\r
+TUPLE: tokenizer any one many ;\r
+\r
+: default-tokenizer ( -- tokenizer )\r
+ T{ tokenizer f \r
+ [ any-char ]\r
+ [ token ]\r
+ [ [ = ] curry any-char swap semantic ]\r
+ } ;\r
+\r
+: parser-tokenizer ( parser -- tokenizer )\r
+ [ 1quotation ] keep\r
+ [ swap [ = ] curry semantic ] curry dup tokenizer boa ;\r
+\r
+: rule-tokenizer ( name word -- tokenizer )\r
+ rule parser-tokenizer ;\r
+\r
+: tokenizer ( -- word )\r
+ \ tokenizer get-global [ default-tokenizer ] unless* ;\r
+\r
+: reset-tokenizer ( -- )\r
+ default-tokenizer \ tokenizer set-global ;\r
+\r
+: TOKENIZER: \r
+ scan search [ "Tokenizer not found" throw ] unless*\r
+ execute \ tokenizer set-global ; parsing\r
+\r
TUPLE: ebnf-non-terminal symbol ;\r
TUPLE: ebnf-terminal symbol ;\r
+TUPLE: ebnf-foreign word rule ;\r
TUPLE: ebnf-any-character ;\r
TUPLE: ebnf-range pattern ;\r
TUPLE: ebnf-ensure group ;\r
TUPLE: ebnf-repeat1 group ;\r
TUPLE: ebnf-optional group ;\r
TUPLE: ebnf-whitespace group ;\r
+TUPLE: ebnf-tokenizer elements ;\r
TUPLE: ebnf-rule symbol elements ;\r
TUPLE: ebnf-action parser code ;\r
TUPLE: ebnf-var parser name ;\r
\r
C: <ebnf-non-terminal> ebnf-non-terminal\r
C: <ebnf-terminal> ebnf-terminal\r
+C: <ebnf-foreign> ebnf-foreign\r
C: <ebnf-any-character> ebnf-any-character\r
C: <ebnf-range> ebnf-range\r
C: <ebnf-ensure> ebnf-ensure\r
C: <ebnf-repeat1> ebnf-repeat1\r
C: <ebnf-optional> ebnf-optional\r
C: <ebnf-whitespace> ebnf-whitespace\r
+C: <ebnf-tokenizer> ebnf-tokenizer\r
C: <ebnf-rule> ebnf-rule\r
C: <ebnf-action> ebnf-action\r
C: <ebnf-var> ebnf-var\r
C: <ebnf-semantic> ebnf-semantic\r
C: <ebnf> ebnf\r
\r
+: filter-hidden ( seq -- seq )\r
+ #! Remove elements that produce no AST from sequence\r
+ [ ebnf-ensure-not? not ] filter [ ebnf-ensure? not ] filter ;\r
+\r
: syntax ( string -- parser )\r
#! Parses the string, ignoring white space, and\r
#! does not put the result in the AST.\r
#! begin and end.\r
[ syntax ] 2dip syntax pack ;\r
\r
+#! Don't want to use 'replace' in an action since replace doesn't infer.\r
+#! Do the compilation of the peg at parse time and call (replace).\r
+PEG: escaper ( string -- ast )\r
+ [\r
+ "\\t" token [ drop "\t" ] action ,\r
+ "\\n" token [ drop "\n" ] action ,\r
+ "\\r" token [ drop "\r" ] action ,\r
+ ] choice* any-char-parser 2array choice repeat0 ;\r
+\r
+: replace-escapes ( string -- string )\r
+ escaper sift [ [ tree-write ] each ] with-string-writer ;\r
+\r
+: insert-escapes ( string -- string )\r
+ [\r
+ "\t" token [ drop "\\t" ] action ,\r
+ "\n" token [ drop "\\n" ] action ,\r
+ "\r" token [ drop "\\r" ] action ,\r
+ ] choice* replace ;\r
+\r
: 'identifier' ( -- parser )\r
#! Return a parser that parses an identifer delimited by\r
#! a quotation character. The quotation can be single\r
[\r
[ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,\r
[ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,\r
- ] choice* [ >string ] action ;\r
+ ] choice* [ >string replace-escapes ] action ;\r
\r
: 'non-terminal' ( -- parser )\r
#! A non-terminal is the name of another rule. It can\r
[ dup CHAR: ? = ]\r
[ dup CHAR: : = ]\r
[ dup CHAR: ~ = ]\r
- } || not nip \r
+ [ dup CHAR: < = ]\r
+ [ dup CHAR: > = ]\r
+ } 0|| not nip \r
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;\r
\r
: 'terminal' ( -- parser )\r
#! and it represents the literal value of the identifier.\r
'identifier' [ <ebnf-terminal> ] action ;\r
\r
+: 'foreign-name' ( -- parser )\r
+ #! Parse a valid foreign parser name\r
+ [\r
+ {\r
+ [ dup blank? ]\r
+ [ dup CHAR: > = ]\r
+ } 0|| not nip \r
+ ] satisfy repeat1 [ >string ] action ;\r
+\r
+: 'foreign' ( -- parser )\r
+ #! A foreign call is a call to a rule in another ebnf grammar\r
+ [\r
+ "<foreign" syntax ,\r
+ 'foreign-name' sp ,\r
+ 'foreign-name' sp optional ,\r
+ ">" syntax ,\r
+ ] seq* [ first2 <ebnf-foreign> ] action ;\r
+\r
: 'any-character' ( -- parser )\r
#! A parser to match the symbol for any character match.\r
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;\r
#! The latter indicates that it is the beginning of a\r
#! new rule.\r
[\r
- [ \r
- 'non-terminal' ,\r
- 'terminal' ,\r
- 'range-parser' ,\r
- 'any-character' ,\r
+ [\r
+ [ \r
+ 'non-terminal' ,\r
+ 'terminal' ,\r
+ 'foreign' ,\r
+ 'range-parser' ,\r
+ 'any-character' ,\r
+ ] choice* \r
+ [ dup , "*" token hide , ] seq* [ first <ebnf-repeat0> ] action ,\r
+ [ dup , "+" token hide , ] seq* [ first <ebnf-repeat1> ] action ,\r
+ [ dup , "?[" token ensure-not , "?" token hide , ] seq* [ first <ebnf-optional> ] action ,\r
+ ,\r
] choice* ,\r
[\r
"=" syntax ensure-not ,\r
] choice* ,\r
] seq* [ first ] action ;\r
\r
+DEFER: 'action'\r
+\r
: 'element' ( -- parser )\r
[\r
[ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
: ('sequence') ( -- parser )\r
#! A sequence of terminals and non-terminals, including\r
#! groupings of those. \r
- [ \r
- 'ensure-not' sp ,\r
- 'ensure' sp ,\r
- 'element' sp ,\r
- 'group' sp , \r
- 'repeat0' sp ,\r
- 'repeat1' sp ,\r
- 'optional' sp , \r
+ [\r
+ [ \r
+ 'ensure-not' sp ,\r
+ 'ensure' sp ,\r
+ 'element' sp ,\r
+ 'group' sp , \r
+ 'repeat0' sp ,\r
+ 'repeat1' sp ,\r
+ 'optional' sp , \r
+ ] choice* \r
+ [ dup , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
+ ,\r
] choice* ;\r
\r
: 'action' ( -- parser )\r
: 'actioned-sequence' ( -- parser )\r
[\r
[ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,\r
- [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r <ebnf-var> r> <ebnf-action> ] action ,\r
- [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
'sequence' ,\r
] choice* ;\r
\r
: 'choice' ( -- parser )\r
- 'actioned-sequence' sp "|" token sp list-of [ \r
+ 'actioned-sequence' sp repeat1 [ dup length 1 = [ first ] [ <ebnf-sequence> ] if ] action "|" token sp list-of [ \r
dup length 1 = [ first ] [ <ebnf-choice> ] if\r
] action ;\r
\r
+: 'tokenizer' ( -- parser )\r
+ [\r
+ "tokenizer" syntax ,\r
+ "=" syntax ,\r
+ ">" token ensure-not ,\r
+ [ "default" token sp , 'choice' , ] choice* ,\r
+ ] seq* [ first <ebnf-tokenizer> ] action ;\r
+\r
: 'rule' ( -- parser )\r
[\r
+ "tokenizer" token ensure-not , \r
'non-terminal' [ symbol>> ] action ,\r
"=" syntax ,\r
">" token ensure-not ,\r
] seq* [ first2 <ebnf-rule> ] action ;\r
\r
: 'ebnf' ( -- parser )\r
- 'rule' sp repeat1 [ <ebnf> ] action ;\r
+ [ 'tokenizer' sp , 'rule' sp , ] choice* repeat1 [ <ebnf> ] action ;\r
\r
GENERIC: (transform) ( ast -- parser )\r
\r
\r
M: ebnf (transform) ( ast -- parser )\r
rules>> [ (transform) ] map peek ;\r
+\r
+M: ebnf-tokenizer (transform) ( ast -- parser )\r
+ elements>> dup "default" = [\r
+ drop default-tokenizer \ tokenizer set-global any-char\r
+ ] [\r
+ (transform) \r
+ dup parser-tokenizer \ tokenizer set-global\r
+ ] if ;\r
\r
M: ebnf-rule (transform) ( ast -- parser )\r
dup elements>> \r
(transform) [\r
- swap symbol>> set\r
+ swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ \r
+ "Rule '" over append "' defined more than once" append throw \r
+ ] [ \r
+ set \r
+ ] if\r
] keep ;\r
\r
M: ebnf-sequence (transform) ( ast -- parser )\r
options>> [ (transform) ] map choice ;\r
\r
M: ebnf-any-character (transform) ( ast -- parser )\r
- drop any-char ;\r
+ drop tokenizer any>> call ;\r
\r
M: ebnf-range (transform) ( ast -- parser )\r
pattern>> range-pattern ;\r
GENERIC: build-locals ( code ast -- code )\r
\r
M: ebnf-sequence build-locals ( code ast -- code )\r
- elements>> dup [ ebnf-var? ] filter empty? [\r
- drop \r
- ] [ \r
- [\r
- "USING: locals sequences ; [let* | " %\r
- dup length swap [\r
- dup ebnf-var? [\r
- name>> % \r
- " [ " % # " over nth ] " %\r
- ] [\r
- 2drop\r
- ] if\r
- ] 2each\r
- " | " %\r
- % \r
- " ]" % \r
- ] "" make \r
+ #! Note the need to filter out this ebnf items that\r
+ #! leave nothing in the AST\r
+ elements>> filter-hidden dup length 1 = [ \r
+ first build-locals \r
+ ] [\r
+ dup [ ebnf-var? ] filter empty? [\r
+ drop \r
+ ] [ \r
+ [\r
+ "USING: locals sequences ; [let* | " %\r
+ dup length swap [\r
+ dup ebnf-var? [\r
+ name>> % \r
+ " [ " % # " over nth ] " %\r
+ ] [\r
+ 2drop\r
+ ] if\r
+ ] 2each\r
+ " | " %\r
+ % \r
+ " nip ]" % \r
+ ] "" make \r
+ ] if\r
] if ;\r
\r
M: ebnf-var build-locals ( code ast -- )\r
name>> % " [ dup ] " %\r
" | " %\r
% \r
- " ]" % \r
+ " nip ]" % \r
] "" make ;\r
\r
M: object build-locals ( code ast -- )\r
drop ;\r
\r
+: check-action-effect ( quot -- quot )\r
+ dup infer {\r
+ { [ dup (( a -- b )) effect<= ] [ drop ] }\r
+ { [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }\r
+ [\r
+ [ \r
+ "Bad effect: " write effect>string write \r
+ " for quotation " write pprint\r
+ ] with-string-writer throw\r
+ ]\r
+ } cond ;\r
+ \r
M: ebnf-action (transform) ( ast -- parser )\r
- [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
- string-lines parse-lines action ;\r
+ [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
+ string-lines parse-lines check-action-effect action ;\r
\r
M: ebnf-semantic (transform) ( ast -- parser )\r
- [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
+ [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
string-lines parse-lines semantic ;\r
\r
M: ebnf-var (transform) ( ast -- parser )\r
parser>> (transform) ;\r
\r
M: ebnf-terminal (transform) ( ast -- parser )\r
- symbol>> token ;\r
+ symbol>> tokenizer one>> call ;\r
+\r
+M: ebnf-foreign (transform) ( ast -- parser )\r
+ dup word>> search\r
+ [ "Foreign word '" swap word>> append "' not found" append throw ] unless*\r
+ swap rule>> [ main ] unless* dupd swap rule [\r
+ nip\r
+ ] [\r
+ execute\r
+ ] if* ;\r
\r
: parser-not-found ( name -- * )\r
[\r
- "Parser " % % " not found." %\r
+ "Parser '" % % "' not found." %\r
] "" make throw ;\r
\r
M: ebnf-non-terminal (transform) ( ast -- parser )\r
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable\r
[ compiled-parse ] curry [ with-scope ] curry ;\r
\r
-: replace-escapes ( string -- string )\r
- [\r
- "\\t" token [ drop "\t" ] action ,\r
- "\\n" token [ drop "\n" ] action ,\r
- "\\r" token [ drop "\r" ] action ,\r
- ] choice* replace ;\r
-\r
-: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing\r
+: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip parsed reset-tokenizer ; parsing\r
\r
: EBNF: \r
- CREATE-WORD dup \r
- ";EBNF" parse-multiline-string replace-escapes\r
- ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing\r
+ reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
+ ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop \r
+ reset-tokenizer ; parsing\r
+\r
+\r
\r
-: rule ( name word -- parser )\r
- #! Given an EBNF word produced from EBNF: return the EBNF rule\r
- "ebnf-parser" word-prop at ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: peg.javascript.ast
+
+TUPLE: ast-keyword value ;
+TUPLE: ast-name value ;
+TUPLE: ast-number value ;
+TUPLE: ast-string value ;
+TUPLE: ast-regexp value ;
+TUPLE: ast-cond-expr condition then else ;
+TUPLE: ast-set lhs rhs ;
+TUPLE: ast-get value ;
+TUPLE: ast-mset lhs rhs operator ;
+TUPLE: ast-binop lhs rhs operator ;
+TUPLE: ast-unop expr operator ;
+TUPLE: ast-postop expr operator ;
+TUPLE: ast-preop expr operator ;
+TUPLE: ast-getp index expr ;
+TUPLE: ast-send method expr args ;
+TUPLE: ast-call expr args ;
+TUPLE: ast-this ;
+TUPLE: ast-new name args ;
+TUPLE: ast-array values ;
+TUPLE: ast-json bindings ;
+TUPLE: ast-binding name value ;
+TUPLE: ast-func fs body ;
+TUPLE: ast-var name value ;
+TUPLE: ast-begin statements ;
+TUPLE: ast-if condition true false ;
+TUPLE: ast-while condition statements ;
+TUPLE: ast-do-while statements condition ;
+TUPLE: ast-for i c u statements ;
+TUPLE: ast-for-in v e statements ;
+TUPLE: ast-switch expr statements ;
+TUPLE: ast-break ;
+TUPLE: ast-continue ;
+TUPLE: ast-throw e ;
+TUPLE: ast-try t e c f ;
+TUPLE: ast-return e ;
+TUPLE: ast-case c cs ;
+TUPLE: ast-default cs ;
--- /dev/null
+Chris Double
--- /dev/null
+Abstract Syntax Tree for JavaScript parser
--- /dev/null
+text
+javascript
+parsing
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.markup help.syntax ;\r
+IN: peg.javascript\r
+\r
+HELP: parse-javascript\r
+{ $values \r
+ { "string" "a string" } \r
+ { "ast" "a JavaScript abstract syntax tree" } \r
+}\r
+{ $description \r
+ "Parse the input string using the JavaScript parser. Throws an error if "\r
+ "the string does not contain valid JavaScript. Returns the abstract syntax tree "\r
+ "if successful." } ;\r
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg.javascript peg.javascript.ast accessors ;
+IN: peg.javascript.tests
+
+\ parse-javascript must-infer
+
+{ T{ ast-begin f V{ T{ ast-number f 123 } } } } [
+ "123;" parse-javascript
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors peg.javascript.tokenizer peg.javascript.parser ;
+IN: peg.javascript
+
+: parse-javascript ( string -- ast )
+ javascript [
+ ast>>
+ ] [
+ "Unable to parse JavaScript" throw
+ ] if* ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
+ accessors multiline sequences math ;
+IN: peg.javascript.parser.tests
+
+\ javascript must-infer
+
+{
+ T{
+ ast-begin
+ f
+ V{
+ T{ ast-number f 123 }
+ T{ ast-string f "hello" }
+ T{
+ ast-call
+ f
+ T{ ast-get f "foo" }
+ V{ T{ ast-get f "x" } }
+ }
+ }
+ }
+} [
+ "123; 'hello'; foo(x);" javascript ast>>
+] unit-test
+
+{ t } [
+<"
+var x=5
+var y=10
+"> javascript remaining>> length zero?
+] unit-test
+
+
+{ t } [
+<"
+function foldl(f, initial, seq) {
+ for(var i=0; i< seq.length; ++i)
+ initial = f(initial, seq[i]);
+ return initial;
+}
+"> javascript remaining>> length zero?
+] unit-test
+
+{ t } [
+<"
+ParseState.prototype.from = function(index) {
+ var r = new ParseState(this.input, this.index + index);
+ r.cache = this.cache;
+ r.length = this.length - index;
+ return r;
+}
+"> javascript remaining>> length zero?
+] unit-test
+
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors peg peg.ebnf peg.javascript.ast peg.javascript.tokenizer ;
+IN: peg.javascript.parser
+
+#! Grammar for JavaScript. Based on OMeta-JS example from:
+#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+
+#! The interesting thing about this parser is the mixing of
+#! a default and non-default tokenizer. The JavaScript tokenizer
+#! removes all newlines. So when operating on tokens there is no
+#! need for newline and space skipping in the grammar. But JavaScript
+#! uses the newline in the 'automatic semicolon insertion' rule.
+#!
+#! If a statement ends in a newline, sometimes the semicolon can be
+#! skipped. So we define an 'nl' rule using the default tokenizer.
+#! This operates a character at a time. Using this 'nl' in the parser
+#! allows us to detect newlines when we need to for the semicolon
+#! insertion rule, but ignore it in all other places.
+EBNF: javascript
+tokenizer = default
+nl = "\r" "\n" | "\n"
+
+tokenizer = <foreign tokenize-javascript Tok>
+End = !(.)
+Space = " " | "\t" | "\n"
+Spaces = Space* => [[ ignore ]]
+Name = . ?[ ast-name? ]? => [[ value>> ]]
+Number = . ?[ ast-number? ]? => [[ value>> ]]
+String = . ?[ ast-string? ]? => [[ value>> ]]
+RegExp = . ?[ ast-regexp? ]? => [[ value>> ]]
+SpacesNoNl = (!(nl) Space)* => [[ ignore ]]
+
+Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]]
+ | OrExpr:e "=" Expr:rhs => [[ e rhs ast-set boa ]]
+ | OrExpr:e "+=" Expr:rhs => [[ e rhs "+" ast-mset boa ]]
+ | OrExpr:e "-=" Expr:rhs => [[ e rhs "-" ast-mset boa ]]
+ | OrExpr:e "*=" Expr:rhs => [[ e rhs "*" ast-mset boa ]]
+ | OrExpr:e "/=" Expr:rhs => [[ e rhs "/" ast-mset boa ]]
+ | OrExpr:e "%=" Expr:rhs => [[ e rhs "%" ast-mset boa ]]
+ | OrExpr:e "&&=" Expr:rhs => [[ e rhs "&&" ast-mset boa ]]
+ | OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]]
+ | OrExpr:e => [[ e ]]
+
+OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]]
+ | AndExpr
+AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]]
+ | EqExpr
+EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]]
+ | EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]]
+ | EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]]
+ | EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]]
+ | RelExpr
+RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop boa ]]
+ | RelExpr:x ">=" AddExpr:y => [[ x y ">=" ast-binop boa ]]
+ | RelExpr:x "<" AddExpr:y => [[ x y "<" ast-binop boa ]]
+ | RelExpr:x "<=" AddExpr:y => [[ x y "<=" ast-binop boa ]]
+ | RelExpr:x "instanceof" AddExpr:y => [[ x y "instanceof" ast-binop boa ]]
+ | AddExpr
+AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]]
+ | AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]]
+ | MulExpr
+MulExpr = MulExpr:x "*" MulExpr:y => [[ x y "*" ast-binop boa ]]
+ | MulExpr:x "/" MulExpr:y => [[ x y "/" ast-binop boa ]]
+ | MulExpr:x "%" MulExpr:y => [[ x y "%" ast-binop boa ]]
+ | Unary
+Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]]
+ | "+" Postfix:p => [[ p ]]
+ | "++" Postfix:p => [[ p "++" ast-preop boa ]]
+ | "--" Postfix:p => [[ p "--" ast-preop boa ]]
+ | "!" Postfix:p => [[ p "!" ast-unop boa ]]
+ | "typeof" Postfix:p => [[ p "typeof" ast-unop boa ]]
+ | "void" Postfix:p => [[ p "void" ast-unop boa ]]
+ | "delete" Postfix:p => [[ p "delete" ast-unop boa ]]
+ | Postfix
+Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]]
+ | PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]]
+ | PrimExpr
+Args = (Expr ("," Expr => [[ second ]])* => [[ first2 swap prefix ]])?
+PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp boa ]]
+ | PrimExpr:p "." Name:m "(" Args:as ")" => [[ m p as ast-send boa ]]
+ | PrimExpr:p "." Name:f => [[ f p ast-getp boa ]]
+ | PrimExpr:p "(" Args:as ")" => [[ p as ast-call boa ]]
+ | PrimExprHd
+PrimExprHd = "(" Expr:e ")" => [[ e ]]
+ | "this" => [[ ast-this boa ]]
+ | Name => [[ ast-get boa ]]
+ | Number => [[ ast-number boa ]]
+ | String => [[ ast-string boa ]]
+ | RegExp => [[ ast-regexp boa ]]
+ | "function" FuncRest:fr => [[ fr ]]
+ | "new" Name:n "(" Args:as ")" => [[ n as ast-new boa ]]
+ | "[" Args:es "]" => [[ es ast-array boa ]]
+ | Json
+JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])?
+Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]]
+JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]]
+JsonPropName = Name | Number | String | RegExp
+Formal = Spaces Name
+Formals = (Formal ("," Formal => [[ second ]])* => [[ first2 swap prefix ]])?
+FuncRest = "(" Formals:fs ")" "{" SrcElems:body "}" => [[ fs body ast-func boa ]]
+Sc = SpacesNoNl (nl | &("}") | End)| ";"
+Binding = Name:n "=" Expr:v => [[ n v ast-var boa ]]
+ | Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
+Block = "{" SrcElems:ss "}" => [[ ss ]]
+Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])?
+For1 = "var" Binding => [[ second ]]
+ | Expr
+ | Spaces => [[ "undefined" ast-get boa ]]
+For2 = Expr
+ | Spaces => [[ "true" ast-get boa ]]
+For3 = Expr
+ | Spaces => [[ "undefined" ast-get boa ]]
+ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa ]]
+ | Expr
+Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]]
+ | "default" ":" SrcElems:cs => [[ cs ast-default boa ]]
+SwitchBody = Switch1*
+Finally = "finally" Block:b => [[ b ]]
+ | Spaces => [[ "undefined" ast-get boa ]]
+Stmt = Block
+ | "var" Bindings:bs Sc => [[ bs ast-begin boa ]]
+ | "if" "(" Expr:c ")" Stmt:t "else" Stmt:f => [[ c t f ast-if boa ]]
+ | "if" "(" Expr:c ")" Stmt:t => [[ c t "undefined" ast-get boa ast-if boa ]]
+ | "while" "(" Expr:c ")" Stmt:s => [[ c s ast-while boa ]]
+ | "do" Stmt:s "while" "(" Expr:c ")" Sc => [[ s c ast-do-while boa ]]
+ | "for" "(" For1:i ";" For2:c ";" For3:u ")" Stmt:s => [[ i c u s ast-for boa ]]
+ | "for" "(" ForIn1:v "in" Expr:e ")" Stmt:s => [[ v e s ast-for-in boa ]]
+ | "switch" "(" Expr:e ")" "{" SwitchBody:cs "}" => [[ e cs ast-switch boa ]]
+ | "break" Sc => [[ ast-break boa ]]
+ | "continue" Sc => [[ ast-continue boa ]]
+ | "throw" SpacesNoNl Expr:e Sc => [[ e ast-throw boa ]]
+ | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ t e c f ast-try boa ]]
+ | "return" Expr:e Sc => [[ e ast-return boa ]]
+ | "return" Sc => [[ "undefined" ast-get boa ast-return boa ]]
+ | Expr:e Sc => [[ e ]]
+ | ";" => [[ "undefined" ast-get boa ]]
+SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]]
+ | Stmt
+SrcElems = SrcElem* => [[ ast-begin boa ]]
+TopLevel = SrcElems Spaces
+;EBNF
\ No newline at end of file
--- /dev/null
+JavaScript Parser
--- /dev/null
+text
+javascript
+parsing
--- /dev/null
+JavaScript parser
--- /dev/null
+text
+javascript
+parsing
--- /dev/null
+Chris Double
--- /dev/null
+Tokenizer for JavaScript language
--- /dev/null
+text
+javascript
+parsing
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ;
+IN: peg.javascript.tokenizer.tests
+
+\ tokenize-javascript must-infer
+
+{
+ V{
+ T{ ast-number f 123 }
+ ";"
+ T{ ast-string f "hello" }
+ ";"
+ T{ ast-name f "foo" }
+ "("
+ T{ ast-name f "x" }
+ ")"
+ ";"
+ }
+} [
+ "123; 'hello'; foo(x);" tokenize-javascript ast>>
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings arrays math.parser peg peg.ebnf peg.javascript.ast ;
+IN: peg.javascript.tokenizer
+
+#! Grammar for JavaScript. Based on OMeta-JS example from:
+#! http://jarrett.cs.ucla.edu/ometa-js/#JavaScript_Compiler
+
+USE: prettyprint
+
+EBNF: tokenize-javascript
+Letter = [a-zA-Z]
+Digit = [0-9]
+Digits = Digit+
+SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
+MultiLineComment = "/*" (!("*/") .)* "*/" => [[ ignore ]]
+Space = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
+Spaces = Space* => [[ ignore ]]
+NameFirst = Letter | "$" => [[ CHAR: $ ]] | "_" => [[ CHAR: _ ]]
+NameRest = NameFirst | Digit
+iName = NameFirst NameRest* => [[ first2 swap prefix >string ]]
+Keyword = ("break"
+ | "case"
+ | "catch"
+ | "continue"
+ | "default"
+ | "delete"
+ | "do"
+ | "else"
+ | "finally"
+ | "for"
+ | "function"
+ | "if"
+ | "in"
+ | "instanceof"
+ | "new"
+ | "return"
+ | "switch"
+ | "this"
+ | "throw"
+ | "try"
+ | "typeof"
+ | "var"
+ | "void"
+ | "while"
+ | "with") !(NameRest)
+Name = !(Keyword) iName => [[ ast-name boa ]]
+Number = Digits:ws '.' Digits:fs => [[ ws "." fs 3array concat >string string>number ast-number boa ]]
+ | Digits => [[ >string string>number ast-number boa ]]
+
+EscapeChar = "\\n" => [[ 10 ]]
+ | "\\r" => [[ 13 ]]
+ | "\\t" => [[ 9 ]]
+StringChars1 = (EscapeChar | !('"""') .)* => [[ >string ]]
+StringChars2 = (EscapeChar | !('"') .)* => [[ >string ]]
+StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]]
+Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]]
+ | '"' StringChars2:cs '"' => [[ cs ast-string boa ]]
+ | "'" StringChars3:cs "'" => [[ cs ast-string boa ]]
+RegExpBody = (!("/" | "\n" | "\r") .)* => [[ >string ]]
+RegExp = "/" RegExpBody:r "/" => [[ r ast-regexp boa ]]
+Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";"
+ | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">="
+ | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-="
+ | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&="
+ | "&&" | "||=" | "||" | "." | "!"
+Tok = Spaces (Name | Keyword | Number | Str | RegExp | Special )
+Toks = Tok* Spaces
+;EBNF
+
! 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
: 1token ( ch -- parser ) 1string token ;
-<PRIVATE
: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
-PRIVATE>
: list-of ( items separator -- parser )
hide f (list-of) ;
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings fry namespaces math assocs shuffle
+USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order
unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
#! to fix boxes so this isn't needed...
box-parser boa next-id f <parser> over set-delegate [ ] action ;
+ERROR: parse-failed input word ;
+
+M: parse-failed error.
+ "The " write dup word>> pprint " word could not parse the following input:" print nl
+ input>> . ;
+
: PEG:
- (:) [
+ (:)
+ [let | def [ ] word [ ] |
[
- call compile [ compiled-parse ] curry
- [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
- append define
- ] with-compilation-unit
- ] 2curry over push-all ; parsing
+ [
+ [let | compiled-def [ def call compile ] |
+ [
+ dup compiled-def compiled-parse
+ [ ast>> ] [ word parse-failed ] ?if
+ ]
+ word swap define
+ ]
+ ] with-compilation-unit
+ ] over push-all
+ ] ; parsing
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax kernel math sequences ;
+IN: persistent-vectors
+
+HELP: new-nth
+{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
+{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppush
+{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppop
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: PV{
+{ $syntax "elements... }" }
+{ $description "Parses a literal " { $link persistent-vector } "." } ;
+
+HELP: >persistent-vector
+{ $values { "seq" sequence } { "pvec" persistent-vector } }
+{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ;
+
+HELP: persistent-vector
+{ $class-description "The class of persistent vectors." } ;
+
+HELP: pempty
+{ $values { "pvec" persistent-vector } }
+{ $description "Outputs an empty " { $link persistent-vector } "." } ;
+
+ARTICLE: "persistent-vectors" "Persistent vectors"
+"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
+$nl
+"The class of persistent vectors:"
+{ $subsection persistent-vector }
+"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
+$nl
+"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"The empty persistent vector, used for building up all other persistent vectors:"
+{ $subsection pempty }
+"Converting a sequence into a persistent vector:"
+{ $subsection >persistent-vector }
+"Persistent vectors have a literal syntax:"
+{ $subsection POSTPONE: PV{ }
+"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
+
+ABOUT: "persistent-vectors"
--- /dev/null
+IN: persistent-vectors.tests
+USING: tools.test persistent-vectors sequences kernel arrays
+random namespaces vectors math math.order ;
+
+\ new-nth must-infer
+\ ppush must-infer
+\ ppop must-infer
+
+[ 0 ] [ pempty length ] unit-test
+
+[ 1 ] [ 3 pempty ppush length ] unit-test
+
+[ 3 ] [ 3 pempty ppush first ] unit-test
+
+[ PV{ 3 1 3 3 7 } ] [
+ pempty { 3 1 3 3 7 } [ swap ppush ] each
+] unit-test
+
+[ { 3 1 3 3 7 } ] [
+ pempty { 3 1 3 3 7 } [ swap ppush ] each >array
+] unit-test
+
+{ 100 1060 2000 10000 100000 1000000 } [
+ [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
+] each
+
+[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
+[ ] [ "1" get >vector "2" set ] unit-test
+
+[ t ] [
+ 3000 [
+ drop
+ 16 random-bits 10000 random
+ [ "1" [ new-nth ] change ]
+ [ "2" [ new-nth ] change ] 2bi
+ "1" get "2" get sequence=
+ ] all?
+] unit-test
+
+[ PV{ } ppop ] [ empty-error? ] must-fail-with
+
+[ t ] [ PV{ 3 } ppop empty? ] unit-test
+
+[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test
+
+[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test
+
+[ ] [ PV{ } "1" set ] unit-test
+[ ] [ V{ } clone "2" set ] unit-test
+
+[ t ] [
+ 100 [
+ drop
+ 100 random [
+ 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
+ ] times
+ 100 random "1" get length min [
+ "1" [ ppop ] change
+ "2" get pop*
+ ] times
+ "1" get "2" get sequence=
+ ] all?
+] unit-test
--- /dev/null
+! Based on Clojure's PersistentVector by Rich Hickey.
+
+USING: math accessors kernel sequences.private sequences arrays
+combinators parser prettyprint.backend ;
+IN: persistent-vectors
+
+ERROR: empty-error pvec ;
+
+GENERIC: ppush ( val seq -- seq' )
+
+M: sequence ppush swap suffix ;
+
+GENERIC: ppop ( seq -- seq' )
+
+M: sequence ppop 1 head* ;
+
+GENERIC: new-nth ( val i seq -- seq' )
+
+M: sequence new-nth clone [ set-nth ] keep ;
+
+TUPLE: persistent-vector count root tail ;
+
+M: persistent-vector length count>> ;
+
+<PRIVATE
+
+TUPLE: node children level ;
+
+: node-size 32 ; inline
+
+: node-mask node-size mod ; inline
+
+: node-shift -5 * shift ; inline
+
+: node-nth ( i node -- obj )
+ [ node-mask ] [ children>> ] bi* nth ; inline
+
+: body-nth ( i node -- i node' )
+ dup level>> [
+ dupd [ level>> node-shift ] keep node-nth
+ ] times ; inline
+
+: tail-offset ( pvec -- n )
+ [ count>> ] [ tail>> children>> length ] bi - ;
+
+M: persistent-vector nth-unsafe
+ 2dup tail-offset >=
+ [ tail>> ] [ root>> body-nth ] if
+ node-nth ;
+
+: node-add ( val node -- node' )
+ clone [ ppush ] change-children ;
+
+: ppush-tail ( val pvec -- pvec' )
+ [ node-add ] change-tail ;
+
+: full? ( node -- ? )
+ children>> length node-size = ;
+
+: 1node ( val level -- node )
+ node new
+ swap >>level
+ swap 1array >>children ;
+
+: 2node ( first second -- node )
+ [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+
+: new-child ( new-child node -- node' expansion/f )
+ dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+
+: new-last ( val seq -- seq' )
+ [ length 1- ] keep new-nth ;
+
+: node-set-last ( child node -- node' )
+ clone [ new-last ] change-children ;
+
+: (ppush-new-tail) ( tail node -- node' expansion/f )
+ dup level>> 1 = [
+ new-child
+ ] [
+ tuck children>> peek (ppush-new-tail)
+ [ swap new-child ] [ swap node-set-last f ] ?if
+ ] if ;
+
+: do-expansion ( pvec root expansion/f -- pvec )
+ [ 2node ] when* >>root ;
+
+: ppush-new-tail ( val pvec -- pvec' )
+ [ ] [ tail>> ] [ root>> ] tri
+ (ppush-new-tail) do-expansion
+ swap 0 1node >>tail ;
+
+M: persistent-vector ppush ( val pvec -- pvec' )
+ clone
+ dup tail>> full?
+ [ ppush-new-tail ] [ ppush-tail ] if
+ [ 1+ ] change-count ;
+
+: node-set-nth ( val i node -- node' )
+ clone [ new-nth ] change-children ;
+
+: node-change-nth ( i node quot -- node' )
+ [ clone ] dip [
+ [ clone ] dip [ change-nth ] 2keep drop
+ ] curry change-children ; inline
+
+: (new-nth) ( val i node -- node' )
+ dup level>> 0 = [
+ [ node-mask ] dip node-set-nth
+ ] [
+ [ dupd level>> node-shift node-mask ] keep
+ [ (new-nth) ] node-change-nth
+ ] if ;
+
+M: persistent-vector new-nth ( obj i pvec -- pvec' )
+ 2dup count>> = [ nip ppush ] [
+ clone
+ 2dup tail-offset >= [
+ [ node-mask ] dip
+ [ node-set-nth ] change-tail
+ ] [
+ [ (new-nth) ] change-root
+ ] if
+ ] if ;
+
+: (ppop-contraction) ( node -- node' tail' )
+ clone [ unclip-last swap ] change-children swap ;
+
+: ppop-contraction ( node -- node' tail' )
+ [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ;
+
+: (ppop-new-tail) ( root -- root' tail' )
+ dup level>> 1 > [
+ dup children>> peek (ppop-new-tail) over children>> empty?
+ [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if
+ ] [
+ ppop-contraction
+ ] if ;
+
+: ppop-tail ( pvec -- pvec' )
+ [ clone [ ppop ] change-children ] change-tail ;
+
+: ppop-new-tail ( pvec -- pvec' )
+ dup root>> (ppop-new-tail)
+ [
+ dup [ level>> 1 > ] [ children>> length 1 = ] bi and
+ [ children>> first ] when
+ ] dip
+ [ >>root ] [ >>tail ] bi* ;
+
+PRIVATE>
+
+: pempty ( -- pvec )
+ T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline
+
+M: persistent-vector ppop ( pvec -- pvec' )
+ dup count>> {
+ { 0 [ empty-error ] }
+ { 1 [ drop pempty ] }
+ [
+ [
+ clone
+ dup tail>> children>> length 1 >
+ [ ppop-tail ] [ ppop-new-tail ] if
+ ] dip 1- >>count
+ ]
+ } case ;
+
+M: persistent-vector like
+ drop pempty [ swap ppush ] reduce ;
+
+M: persistent-vector equal?
+ over persistent-vector? [ sequence= ] [ 2drop f ] if ;
+
+: >persistent-vector ( seq -- pvec ) pempty like ; inline
+
+: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
+
+M: persistent-vector pprint-delims drop \ PV{ \ } ;
+
+M: persistent-vector >pprint-sequence ;
+
+INSTANCE: persistent-vector immutable-sequence
--- /dev/null
+Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop
--- /dev/null
+collections
--- /dev/null
+USING: math math.parser calendar calendar.format strings words
+kernel effects ;
+IN: present
+
+GENERIC: present ( object -- string )
+
+M: real present number>string ;
+
+M: timestamp present timestamp>string ;
+
+M: string present ;
+
+M: word present word-name ;
+
+M: effect present effect>string ;
+
+M: f present drop "" ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math math.primes ;
+USING: lists math math.primes ;
IN: project-euler.007
! http://projecteuler.net/index.php?section=problems&id=7
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces project-euler.common sequences splitting ;
+USING: kernel namespaces project-euler.common sequences
+splitting grouping ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
<PRIVATE
: worth-calculating? ( n -- ? )
- { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
+ { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
PRIVATE>
: amicable? ( n -- ? )
dup sum-proper-divisors
- { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ;
+ { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ;
: euler021 ( -- answer )
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
: both-bases? ( n -- ? )
{ [ dup palindrome? ]
- [ dup >bin dup reverse = ] } && nip ;
+ [ dup >bin dup reverse = ] } 0&& nip ;
PRIVATE>
[ 5 4 pick subseq-divisible? ]
[ 3 3 pick subseq-divisible? ]
[ 2 2 pick subseq-divisible? ]
- } && nip ;
+ } 0&& nip ;
PRIVATE>
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ dup odd? ] [ dup 3 mod zero? ] } && nip ;
+ { [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ;
: next-all-same ( x n -- n )
dup candidate? [
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces sequences sequences.lib sequences.private sorting
- splitting strings sets ;
+ splitting grouping strings sets ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math.algebra math math.functions
+USING: arrays kernel lists lists.lazy math.algebra math math.functions
math.order math.primes math.ranges project-euler.common sequences ;
IN: project-euler.134
PRIVATE>
: euler134 ( -- answer )
- 0 5 lprimes-from uncons [ 1000000 > ] luntil
+ 0 5 lprimes-from uncons swap [ 1000000 > ] luntil
[ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
: partial-sum-infimum ( seq -- seq )
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
-: generate ( n quot -- seq )
- [ drop ] prepose map ; inline
-
: map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+ 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
PRIVATE>
#! Syntax: QUALIFIED-WITH: vocab prefix
scan scan define-qualified ; parsing
-: expect=> scan "=>" assert= ;
+: expect=> ( -- ) scan "=>" assert= ;
: partial-vocab ( words name -- assoc )
dupd [
USING: kernel math tools.test namespaces random
-random.blum-blum-shub alien.c-types sequences splitting ;
+random.blum-blum-shub alien.c-types sequences splitting
+grouping ;
IN: blum-blum-shub.tests
[ 887708070 ] [
-USING: arrays combinators kernel lazy-lists math math.parser
+USING: arrays combinators kernel lists math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories ;
: or-predicates ( quots -- quot )
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
-: <@literal [ nip ] curry <@ ;
+: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
-: <@delay [ curry ] curry <@ ;
+: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
PRIVATE>
'posix-character-class' <|>
'simple-escape' <|> &> ;
-: 'any-char'
+: 'any-char' ( -- parser )
"." token [ drop t ] <@literal ;
-: 'char'
+: 'char' ( -- parser )
'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
DEFER: 'regexp'
+++ /dev/null
-USING: kernel peg regexp2 sequences tools.test ;
-IN: regexp2.tests
-
-[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ]
- [ "056" 'octal' parse ] unit-test
+++ /dev/null
-USING: assocs combinators.lib kernel math math.parser
-namespaces peg unicode.case sequences unicode.categories
-memoize peg.parsers math.order ;
-USE: io
-USE: tools.walker
-IN: regexp2
-
-<PRIVATE
-
-SYMBOL: ignore-case?
-
-: char=-quot ( ch -- quot )
- ignore-case? get
- [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
- curry ;
-
-: char-between?-quot ( ch1 ch2 -- quot )
- ignore-case? get
- [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
- [ [ between? ] ]
- if 2curry ;
-
-: or-predicates ( quots -- quot )
- [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
-
-: literal-action [ nip ] curry action ;
-
-: delay-action [ curry ] curry action ;
-
-PRIVATE>
-
-: ascii? ( n -- ? )
- 0 HEX: 7f between? ;
-
-: octal-digit? ( n -- ? )
- CHAR: 0 CHAR: 7 between? ;
-
-: hex-digit? ( n -- ? )
- {
- [ dup digit? ]
- [ dup CHAR: a CHAR: f between? ]
- [ dup CHAR: A CHAR: F between? ]
- } || nip ;
-
-: control-char? ( n -- ? )
- { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ;
-
-: punct? ( n -- ? )
- "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-
-: c-identifier-char? ( ch -- ? )
- { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ;
-
-: java-blank? ( n -- ? )
- {
- CHAR: \s
- CHAR: \t CHAR: \n CHAR: \r
- HEX: c HEX: 7 HEX: 1b
- } member? ;
-
-: java-printable? ( n -- ? )
- { [ dup alpha? ] [ dup punct? ] } || nip ;
-
-MEMO: 'ordinary-char' ( -- parser )
- [ "\\^*+?|(){}[$" member? not ] satisfy
- [ char=-quot ] action ;
-
-MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
-
-MEMO: 'octal' ( -- parser )
- "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq
- [ first oct> ] action ;
-
-MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
-
-MEMO: 'hex' ( -- parser )
- "x" token hide 'hex-digit' 2 exactly-n 2seq
- "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice
- [ first hex> ] action ;
-
-: satisfy-tokens ( assoc -- parser )
- [ >r token r> literal-action ] { } assoc>map choice ;
-
-MEMO: 'simple-escape-char' ( -- parser )
- {
- { "\\" CHAR: \\ }
- { "t" CHAR: \t }
- { "n" CHAR: \n }
- { "r" CHAR: \r }
- { "f" HEX: c }
- { "a" HEX: 7 }
- { "e" HEX: 1b }
- } [ char=-quot ] assoc-map satisfy-tokens ;
-
-MEMO: 'predefined-char-class' ( -- parser )
- {
- { "d" [ digit? ] }
- { "D" [ digit? not ] }
- { "s" [ java-blank? ] }
- { "S" [ java-blank? not ] }
- { "w" [ c-identifier-char? ] }
- { "W" [ c-identifier-char? not ] }
- } satisfy-tokens ;
-
-MEMO: 'posix-character-class' ( -- parser )
- {
- { "Lower" [ letter? ] }
- { "Upper" [ LETTER? ] }
- { "ASCII" [ ascii? ] }
- { "Alpha" [ Letter? ] }
- { "Digit" [ digit? ] }
- { "Alnum" [ alpha? ] }
- { "Punct" [ punct? ] }
- { "Graph" [ java-printable? ] }
- { "Print" [ java-printable? ] }
- { "Blank" [ " \t" member? ] }
- { "Cntrl" [ control-char? ] }
- { "XDigit" [ hex-digit? ] }
- { "Space" [ java-blank? ] }
- } satisfy-tokens "p{" "}" surrounded-by ;
-
-MEMO: 'simple-escape' ( -- parser )
- [
- 'octal' ,
- 'hex' ,
- "c" token hide [ LETTER? ] satisfy 2seq ,
- any-char ,
- ] choice* [ char=-quot ] action ;
-
-MEMO: 'escape' ( -- parser )
- "\\" token hide [
- 'simple-escape-char' ,
- 'predefined-char-class' ,
- 'posix-character-class' ,
- 'simple-escape' ,
- ] choice* 2seq ;
-
-MEMO: 'any-char' ( -- parser )
- "." token [ drop t ] literal-action ;
-
-MEMO: 'char' ( -- parser )
- 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ;
-
-DEFER: 'regexp'
-
-TUPLE: group-result str ;
-
-C: <group-result> group-result
-
-MEMO: 'non-capturing-group' ( -- parser )
- "?:" token hide 'regexp' ;
-
-MEMO: 'positive-lookahead-group' ( -- parser )
- "?=" token hide 'regexp' [ ensure ] action ;
-
-MEMO: 'negative-lookahead-group' ( -- parser )
- "?!" token hide 'regexp' [ ensure-not ] action ;
-
-MEMO: 'simple-group' ( -- parser )
- 'regexp' [ [ <group-result> ] action ] action ;
-
-MEMO: 'group' ( -- parser )
- [
- 'non-capturing-group' ,
- 'positive-lookahead-group' ,
- 'negative-lookahead-group' ,
- 'simple-group' ,
- ] choice* "(" ")" surrounded-by ;
-
-MEMO: 'range' ( -- parser )
- any-char "-" token hide any-char 3seq
- [ first2 char-between?-quot ] action ;
-
-MEMO: 'character-class-term' ( -- parser )
- 'range'
- 'escape'
- [ "\\]" member? not ] satisfy [ char=-quot ] action
- 3choice ;
-
-MEMO: 'positive-character-class' ( -- parser )
- ! todo
- "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq
- 'character-class-term' repeat1 2choice [ or-predicates ] action ;
-
-MEMO: 'negative-character-class' ( -- parser )
- "^" token hide 'positive-character-class' 2seq
- [ [ not ] append ] action ;
-
-MEMO: 'character-class' ( -- parser )
- 'negative-character-class' 'positive-character-class' 2choice
- "[" "]" surrounded-by [ satisfy ] action ;
-
-MEMO: 'escaped-seq' ( -- parser )
- any-char repeat1
- [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ;
-
-MEMO: 'break' ( quot -- parser )
- satisfy ensure
- epsilon just 2choice ;
-
-MEMO: 'break-escape' ( -- parser )
- "$" token [ "\r\n" member? ] 'break' literal-action
- "\\b" token [ blank? ] 'break' literal-action
- "\\B" token [ blank? not ] 'break' literal-action
- "\\z" token epsilon just literal-action 4choice ;
-
-MEMO: 'simple' ( -- parser )
- [
- 'escaped-seq' ,
- 'break-escape' ,
- 'group' ,
- 'character-class' ,
- 'char' ,
- ] choice* ;
-
-MEMO: 'exactly-n' ( -- parser )
- 'integer' [ exactly-n ] delay-action ;
-
-MEMO: 'at-least-n' ( -- parser )
- 'integer' "," token hide 2seq [ at-least-n ] delay-action ;
-
-MEMO: 'at-most-n' ( -- parser )
- "," token hide 'integer' 2seq [ at-most-n ] delay-action ;
-
-MEMO: 'from-m-to-n' ( -- parser )
- 'integer' "," token hide 'integer' 3seq
- [ first2 from-m-to-n ] delay-action ;
-
-MEMO: 'greedy-interval' ( -- parser )
- 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ;
-
-MEMO: 'interval' ( -- parser )
- 'greedy-interval'
- 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action
- 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action
- 3choice "{" "}" surrounded-by ;
-
-MEMO: 'repetition' ( -- parser )
- [
- ! Possessive
- ! "*+" token [ <!*> ] literal-action ,
- ! "++" token [ <!+> ] literal-action ,
- ! "?+" token [ <!?> ] literal-action ,
- ! Reluctant
- ! "*?" token [ <(*)> ] literal-action ,
- ! "+?" token [ <(+)> ] literal-action ,
- ! "??" token [ <(?)> ] literal-action ,
- ! Greedy
- "*" token [ repeat0 ] literal-action ,
- "+" token [ repeat1 ] literal-action ,
- "?" token [ optional ] literal-action ,
- ] choice* ;
-
-MEMO: 'dummy' ( -- parser )
- epsilon [ ] literal-action ;
-
-! todo -- check the action
-! MEMO: 'term' ( -- parser )
- ! 'simple'
- ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action
- ! <!+> [ <and-parser> ] action ;
-
{ spread 2 }\r
} at 0 or ;\r
\r
-: vsum { 0 0 } [ v+ ] reduce ;\r
+: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;\r
\r
GENERIC: noise ( obj -- pair )\r
\r
\r
M: array noise [ noise ] map vsum ;\r
\r
-: noise-factor / 100 * >integer ;\r
+: noise-factor ( x y -- z ) / 100 * >integer ;\r
\r
: quot-noise-factor ( quot -- n )\r
#! For very short words, noise doesn't count so much\r
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
- <feed xmlns="http://www.w3.org/2005/Atom">
- <title type="text">dive into mark</title>
- <subtitle type="html">
- A <em>lot</em> of effort
- went into making this effortless
- </subtitle>
- <updated>2005-07-31T12:29:29Z</updated>
- <id>tag:example.org,2003:3</id>
- <link rel="alternate" type="text/html"
- hreflang="en" href="http://example.org/"/>
- <link rel="self" type="application/atom+xml"
- href="http://example.org/feed.atom"/>
- <rights>Copyright (c) 2003, Mark Pilgrim</rights>
- <generator uri="http://www.example.com/" version="1.0">
- Example Toolkit
- </generator>
- <entry>
- <title>Atom draft-07 snapshot</title>
- <link rel="alternate" type="text/html"
- href="http://example.org/2005/04/02/atom"/>
- <link rel="enclosure" type="audio/mpeg" length="1337"
- href="http://example.org/audio/ph34r_my_podcast.mp3"/>
- <id>tag:example.org,2003:3.2397</id>
- <updated>2005-07-31T12:29:29Z</updated>
- <published>2003-12-13T08:29:29-04:00</published>
- <author>
- <name>Mark Pilgrim</name>
- <uri>http://example.org/</uri>
- <email>f8dy@example.com</email>
- </author>
- <contributor>
- <name>Sam Ruby</name>
- </contributor>
- <contributor>
- <name>Joe Gregorio</name>
- </contributor>
- <content type="xhtml" xml:lang="en"
- xml:base="http://diveintomark.org/">
- <div xmlns="http://www.w3.org/1999/xhtml">
- <p><i>[Update: The Atom draft is finished.]</i></p>
- </div>
- </content>
- </entry>
- </feed>
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-This library is a simple RSS2 parser and RSS reader web
-application. To run the web application you'll need to make sure you
-have the sqlite library working. This can be tested with
-
- "contrib/sqlite" require
- "contrib/sqlite" test-module
-
-Remember that to use "sqlite" you need to have done the following
-somewhere:
-
- USE: alien
- "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
-
-Replacing "libsqlite3.so" with the path to the sqlite shared library
-or DLL. I put this in my ~/.factor-rc.
-
-The RSS reader web application creates a database file called
-'rss-reader.db' in the same directory as the Factor executable when
-first started. This database contains all the feed information.
-
-To load the web application use:
-
- "contrib/rss" require
-
-Fire up the web server and navigate to the URL:
-
- http://localhost:8888/responder/maintain-feeds
-
-Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
-update the sqlite database with the feed contains. Use 'Database' to
-view the entries from the database for that feed.
-
+++ /dev/null
-USING: rss io kernel io.files tools.test io.encodings.utf8
-calendar ;
-IN: rss.tests
-
-: load-news-file ( filename -- feed )
- #! Load an news syndication file and process it, returning
- #! it as an feed tuple.
- utf8 file-contents read-feed ;
-
-[ T{
- feed
- f
- "Meerkat"
- "http://meerkat.oreillynet.com"
- {
- T{
- entry
- f
- "XML: A Disruptive Technology"
- "http://c.moreover.com/click/here.pl?r123"
- "\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n "
- f
- }
- }
-} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
-[ T{
- feed
- f
- "dive into mark"
- "http://example.org/"
- {
- T{
- entry
- f
- "Atom draft-07 snapshot"
- "http://example.org/2005/04/02/atom"
- "\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
-
- T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
- }
- }
-} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
+++ /dev/null
-! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml.utilities kernel assocs xml.generator math.order
- strings sequences xml.data xml.writer
- io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables
- calendar.format accessors continuations urls ;
-IN: rss
-
-: any-tag-named ( tag names -- tag-inside )
- f -rot [ tag-named nip dup ] with find 2drop ;
-
-TUPLE: feed title link entries ;
-
-C: <feed> feed
-
-TUPLE: entry title link description pub-date ;
-
-C: <entry> entry
-
-: try-parsing-timestamp ( string -- timestamp )
- [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
-
-: rss1.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ]
- [ "description" tag-named children>string ]
- [
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string try-parsing-timestamp ] when
- ]
- } cleave <entry> ;
-
-: rss1.0 ( xml -- feed )
- [
- "channel" tag-named
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ] bi
- ] [ "item" tags-named [ rss1.0-entry ] map ] bi
- <feed> ;
-
-: rss2.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ { "link" "guid" } any-tag-named children>string ]
- [ "description" tag-named children>string ]
- [
- { "date" "pubDate" } any-tag-named
- children>string try-parsing-timestamp
- ]
- } cleave <entry> ;
-
-: rss2.0 ( xml -- feed )
- "channel" tag-named
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ]
- [ "item" tags-named [ rss2.0-entry ] map ]
- tri <feed> ;
-
-: atom1.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ "link" tag-named "href" swap at ]
- [
- { "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
- [ children>string ] if
- ]
- [
- { "published" "updated" "issued" "modified" }
- any-tag-named children>string try-parsing-timestamp
- ]
- } cleave <entry> ;
-
-: atom1.0 ( xml -- feed )
- [ "title" tag-named children>string ]
- [ "link" tag-named "href" swap at ]
- [ "entry" tags-named [ atom1.0-entry ] map ]
- tri <feed> ;
-
-: xml>feed ( xml -- feed )
- dup name-tag {
- { "RDF" [ rss1.0 ] }
- { "rss" [ rss2.0 ] }
- { "feed" [ atom1.0 ] }
- } case ;
-
-: read-feed ( string -- feed )
- [ string>xml xml>feed ] with-html-entities ;
-
-: download-feed ( url -- feed )
- #! Retrieve an news syndication file, return as a feed tuple.
- http-get read-feed ;
-
-! Atom generation
-: simple-tag, ( content name -- )
- [ , ] tag, ;
-
-: simple-tag*, ( content name attrs -- )
- [ , ] tag*, ;
-
-: entry, ( entry -- )
- "entry" [
- dup title>> "title" { { "type" "html" } } simple-tag*,
- "link" over link>> dup url? [ url>string ] when "href" associate contained*,
- dup pub-date>> timestamp>rfc3339 "published" simple-tag,
- description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
- ] tag, ;
-
-: feed>xml ( feed -- xml )
- "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
- dup title>> "title" simple-tag,
- "link" over link>> dup url? [ url>string ] when "href" associate contained*,
- entries>> [ entry, ] each
- ] make-xml* ;
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-
-<rdf:RDF
- xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
- xmlns:dc="http://purl.org/dc/elements/1.1/"
- xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
- xmlns:co="http://purl.org/rss/1.0/modules/company/"
- xmlns:ti="http://purl.org/rss/1.0/modules/textinput/"
- xmlns="http://purl.org/rss/1.0/"
->
-
- <channel rdf:about="http://meerkat.oreillynet.com/?_fl=rss1.0">
- <title>Meerkat</title>
- <link>http://meerkat.oreillynet.com</link>
- <description>Meerkat: An Open Wire Service</description>
- <dc:publisher>The O'Reilly Network</dc:publisher>
- <dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>
- <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
- <dc:date>2000-01-01T12:00+00:00</dc:date>
- <sy:updatePeriod>hourly</sy:updatePeriod>
- <sy:updateFrequency>2</sy:updateFrequency>
- <sy:updateBase>2000-01-01T12:00+00:00</sy:updateBase>
-
- <image rdf:resource="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg" />
-
- <items>
- <rdf:Seq>
- <rdf:li resource="http://c.moreover.com/click/here.pl?r123" />
- </rdf:Seq>
- </items>
-
- <textinput rdf:resource="http://meerkat.oreillynet.com" />
-
- </channel>
-
- <image rdf:about="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg">
- <title>Meerkat Powered!</title>
- <url>http://meerkat.oreillynet.com/icons/meerkat-powered.jpg</url>
- <link>http://meerkat.oreillynet.com</link>
- </image>
-
- <item rdf:about="http://c.moreover.com/click/here.pl?r123">
- <title>XML: A Disruptive Technology</title>
- <link>http://c.moreover.com/click/here.pl?r123</link>
- <dc:description>
- XML is placing increasingly heavy loads on the existing technical
- infrastructure of the Internet.
- </dc:description>
- <dc:publisher>The O'Reilly Network</dc:publisher>
- <dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>
- <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
- <dc:subject>XML</dc:subject>
- <co:name>XML.com</co:name>
- <co:market>NASDAQ</co:market>
- <co:symbol>XML</co:symbol>
- </item>
-
- <textinput rdf:about="http://meerkat.oreillynet.com">
- <title>Search Meerkat</title>
- <description>Search Meerkat's RSS Database...</description>
- <name>s</name>
- <link>http://meerkat.oreillynet.com/</link>
- <ti:function>search</ti:function>
- <ti:inputType>regex</ti:inputType>
- </textinput>
-
-</rdf:RDF>
+++ /dev/null
-RSS 1.0, 2.0 and Atom feed parser
--- /dev/null
+collections
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
-[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: ,, building get peek push ;
-: v, V{ } clone , ;
-: ,v building get dup peek empty? [ dup pop* ] when drop ;
+: ,, ( obj -- ) building get peek push ;
+: v, ( -- ) V{ } clone , ;
+: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
[ find drop [ head-slice ] when* ] curry
[ dup ] prepose keep like ;
-: replicate ( seq quot -- newseq )
- #! quot: ( -- obj )
- [ drop ] prepose map ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
-: accumulator ( quot -- quot vec )
- V{ } clone [ [ push ] curry compose ] keep ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
: short ( seq n -- seq n' )
over length min ; inline
-<PRIVATE
-:: insert ( seq quot n -- )
- n zero? [
- n n 1- [ seq nth quot call ] bi@ >= [
- n n 1- seq exchange
- seq quot n 1- insert
- ] unless
- ] unless ; inline
-PRIVATE>
-
-: insertion-sort ( seq quot -- )
- ! quot is a transformation on elements
- over length [ insert ] 2with each ; inline
-
: if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline
--- /dev/null
+collections
--- /dev/null
+collections
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
-combinators.lib assocs ;
+assocs ;
IN: serialize.tests
: test-serialize-cell
[ t ] [
100 [
drop
- {
- [ 40 [ test-serialize-cell ] all? ]
- [ 4 [ 40 * test-serialize-cell ] all? ]
- [ 4 [ 400 * test-serialize-cell ] all? ]
- [ 4 [ 4000 * test-serialize-cell ] all? ]
- } &&
+ 40 [ test-serialize-cell ] all?
+ 4 [ 40 * test-serialize-cell ] all?
+ 4 [ 400 * test-serialize-cell ] all?
+ 4 [ 4000 * test-serialize-cell ] all?
+ and and and
] all?
] unit-test
gadget.
] ($block) ;
-: page-theme
+: page-theme ( gadget -- )
T{ gradient f { { 0.8 0.8 1.0 1.0 } { 0.8 1.0 1.0 1.0 } } }
swap set-gadget-interior ;
! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel prettyprint io io.timeouts io.server
+USING: combinators kernel prettyprint io io.timeouts
sequences namespaces io.sockets continuations calendar
io.encodings.ascii io.streams.duplex destructors ;
IN: smtp.server
call
] with-client ; inline
-: crlf "\r\n" write ;
+: crlf ( -- ) "\r\n" write ;
: command ( string -- ) write crlf flush ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+IN: sorting.insertion
+USING: sorting.insertion sequences kernel tools.test ;
+
+[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
--- /dev/null
+USING: locals sequences kernel math ;
+IN: sorting.insertion
+
+<PRIVATE
+:: insert ( seq quot n -- )
+ n zero? [
+ n n 1- [ seq nth quot call ] bi@ >= [
+ n n 1- seq exchange
+ seq quot n 1- insert
+ ] unless
+ ] unless ; inline
+PRIVATE>
+
+: insertion-sort ( seq quot -- )
+ ! quot is a transformation on elements
+ over length [ insert ] with with each ; inline
--- /dev/null
+Insertion sort
--- /dev/null
+collections
TUPLE: state place data ;
-TUPLE: missing-state ;
-: missing-state \ missing-state new throw ;
+ERROR: missing-state ;
+
M: missing-state error.
drop "Missing state" print ;
] with-string-writer ;\r
\r
TUPLE: unexpected-end < parsing-error ;\r
-: unexpected-end \ unexpected-end parsing-error throw ;\r
+: unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;\r
M: unexpected-end summary ( obj -- str )\r
[\r
call-next-method write\r
] with-string-writer ;\r
\r
TUPLE: missing-close < parsing-error ;\r
-: missing-close \ missing-close parsing-error throw ;\r
+: missing-close ( -- * ) \ missing-close parsing-error throw ;\r
M: missing-close summary ( obj -- str )\r
[\r
call-next-method write\r
[ dup get-char = ] take-until nip ;\r
\r
TUPLE: not-enough-characters < parsing-error ;\r
-: not-enough-characters\r
+: not-enough-characters ( -- * )\r
\ not-enough-characters parsing-error throw ;\r
M: not-enough-characters summary ( obj -- str )\r
[\r
] if next ;\r
\r
: expect-string ( string -- )\r
- dup [ drop get-char next ] map 2dup =\r
+ dup [ get-char next ] replicate 2dup =\r
[ 2drop ] [ expected ] if ;\r
\r
: init-parser ( -- )\r
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
+[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
alphanumeric-chars random ;
: random-alphanumeric-string ( length -- str )
- [ drop random-alphanumeric-char ] map "" like ;
-
+ [ random-alphanumeric-char ] "" replicate-as ;
SYMBOL: solutions
SYMBOL: board
-: pair+ swapd + >r + r> ;
+: pair+ ( a b c d -- a+b c+d ) swapd + >r + r> ;
-: row board get nth ;
-: board> row nth ;
-: >board row set-nth ;
-: f>board f -rot >board ;
+: row ( n -- row ) board get nth ;
+: board> ( m n -- x ) row nth ;
+: >board ( row m n -- ) row set-nth ;
+: f>board ( m n -- ) f -rot >board ;
: row-contains? ( n y -- ? ) row member? ;
: col-contains? ( n x -- ? ) board get swap <column> member? ;
--- /dev/null
+Daniel Ehrenberg
+Chris Double
+Slava Pestov
--- /dev/null
+This library is a simple RSS2 parser and RSS reader web
+application. To run the web application you'll need to make sure you
+have the sqlite library working. This can be tested with
+
+ "contrib/sqlite" require
+ "contrib/sqlite" test-module
+
+Remember that to use "sqlite" you need to have done the following
+somewhere:
+
+ USE: alien
+ "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
+
+Replacing "libsqlite3.so" with the path to the sqlite shared library
+or DLL. I put this in my ~/.factor-rc.
+
+The RSS reader web application creates a database file called
+'rss-reader.db' in the same directory as the Factor executable when
+first started. This database contains all the feed information.
+
+To load the web application use:
+
+ "contrib/rss" require
+
+Fire up the web server and navigate to the URL:
+
+ http://localhost:8888/responder/maintain-feeds
+
+Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
+update the sqlite database with the feed contains. Use 'Database' to
+view the entries from the database for that feed.
+
--- /dev/null
+RSS 1.0, 2.0 and Atom feed parser
--- /dev/null
+USING: syndication io kernel io.files tools.test io.encodings.utf8
+calendar urls ;
+IN: syndication.tests
+
+\ download-feed must-infer
+\ feed>xml must-infer
+
+: load-news-file ( filename -- feed )
+ #! Load an news syndication file and process it, returning
+ #! it as an feed tuple.
+ utf8 file-contents read-feed ;
+
+[ T{
+ feed
+ f
+ "Meerkat"
+ URL" http://meerkat.oreillynet.com"
+ {
+ T{
+ entry
+ f
+ "XML: A Disruptive Technology"
+ URL" http://c.moreover.com/click/here.pl?r123"
+ "\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n "
+ f
+ }
+ }
+} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test
+[ T{
+ feed
+ f
+ "dive into mark"
+ URL" http://example.org/"
+ {
+ T{
+ entry
+ f
+ "Atom draft-07 snapshot"
+ URL" http://example.org/2005/04/02/atom"
+ "\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
+
+ T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
+ }
+ }
+} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test
--- /dev/null
+! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
+! Portions copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml.utilities kernel assocs xml.generator math.order
+ strings sequences xml.data xml.writer
+ io.streams.string combinators xml xml.entities io.files io
+ http.client namespaces xml.generator hashtables
+ calendar.format accessors continuations urls present ;
+IN: syndication
+
+: any-tag-named ( tag names -- tag-inside )
+ f -rot [ tag-named nip dup ] with find 2drop ;
+
+TUPLE: feed title url entries ;
+
+: <feed> ( -- feed ) feed new ;
+
+TUPLE: entry title url description date ;
+
+: set-entries ( feed entries -- feed )
+ [ dup url>> ] dip
+ [ [ derive-url ] change-url ] with map
+ >>entries ;
+
+: <entry> ( -- entry ) entry new ;
+
+: try-parsing-timestamp ( string -- timestamp )
+ [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
+: rss1.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ]
+ [ "description" tag-named children>string >>description ]
+ [
+ f "date" "http://purl.org/dc/elements/1.1/" <name>
+ tag-named dup [ children>string try-parsing-timestamp ] when
+ >>date
+ ]
+ } cleave ;
+
+: rss1.0 ( xml -- feed )
+ feed new
+ swap [
+ "channel" tag-named
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ] bi
+ ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ;
+
+: rss2.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ { "link" "guid" } any-tag-named children>string >url >>url ]
+ [ "description" tag-named children>string >>description ]
+ [
+ { "date" "pubDate" } any-tag-named
+ children>string try-parsing-timestamp >>date
+ ]
+ } cleave ;
+
+: rss2.0 ( xml -- feed )
+ feed new
+ swap
+ "channel" tag-named
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ]
+ [ "item" tags-named [ rss2.0-entry ] map set-entries ]
+ tri ;
+
+: atom1.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named "href" swap at >url >>url ]
+ [
+ { "content" "summary" } any-tag-named
+ dup tag-children [ string? not ] contains?
+ [ tag-children [ write-chunk ] with-string-writer ]
+ [ children>string ] if >>description
+ ]
+ [
+ { "published" "updated" "issued" "modified" }
+ any-tag-named children>string try-parsing-timestamp
+ >>date
+ ]
+ } cleave ;
+
+: atom1.0 ( xml -- feed )
+ feed new
+ swap
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named "href" swap at >url >>url ]
+ [ "entry" tags-named [ atom1.0-entry ] map set-entries ]
+ tri ;
+
+: xml>feed ( xml -- feed )
+ dup name-tag {
+ { "RDF" [ rss1.0 ] }
+ { "rss" [ rss2.0 ] }
+ { "feed" [ atom1.0 ] }
+ } case ;
+
+: read-feed ( string -- feed )
+ [ string>xml xml>feed ] with-html-entities ;
+
+: download-feed ( url -- feed )
+ #! Retrieve an news syndication file, return as a feed tuple.
+ http-get nip read-feed ;
+
+! Atom generation
+: simple-tag, ( content name -- )
+ [ , ] tag, ;
+
+: simple-tag*, ( content name attrs -- )
+ [ , ] tag*, ;
+
+: entry, ( entry -- )
+ "entry" [
+ {
+ [ title>> "title" { { "type" "html" } } simple-tag*, ]
+ [ url>> present "href" associate "link" swap contained*, ]
+ [ date>> timestamp>rfc3339 "published" simple-tag, ]
+ [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
+ } cleave
+ ] tag, ;
+
+: feed>xml ( feed -- xml )
+ "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
+ [ title>> "title" simple-tag, ]
+ [ url>> present "href" associate "link" swap contained*, ]
+ [ entries>> [ entry, ] each ]
+ tri
+ ] make-xml* ;
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+ <feed xmlns="http://www.w3.org/2005/Atom">
+ <title type="text">dive into mark</title>
+ <subtitle type="html">
+ A <em>lot</em> of effort
+ went into making this effortless
+ </subtitle>
+ <updated>2005-07-31T12:29:29Z</updated>
+ <id>tag:example.org,2003:3</id>
+ <link rel="alternate" type="text/html"
+ hreflang="en" href="http://example.org/"/>
+ <link rel="self" type="application/atom+xml"
+ href="http://example.org/feed.atom"/>
+ <rights>Copyright (c) 2003, Mark Pilgrim</rights>
+ <generator uri="http://www.example.com/" version="1.0">
+ Example Toolkit
+ </generator>
+ <entry>
+ <title>Atom draft-07 snapshot</title>
+ <link rel="alternate" type="text/html"
+ href="http://example.org/2005/04/02/atom"/>
+ <link rel="enclosure" type="audio/mpeg" length="1337"
+ href="http://example.org/audio/ph34r_my_podcast.mp3"/>
+ <id>tag:example.org,2003:3.2397</id>
+ <updated>2005-07-31T12:29:29Z</updated>
+ <published>2003-12-13T08:29:29-04:00</published>
+ <author>
+ <name>Mark Pilgrim</name>
+ <uri>http://example.org/</uri>
+ <email>f8dy@example.com</email>
+ </author>
+ <contributor>
+ <name>Sam Ruby</name>
+ </contributor>
+ <contributor>
+ <name>Joe Gregorio</name>
+ </contributor>
+ <content type="xhtml" xml:lang="en"
+ xml:base="http://diveintomark.org/">
+ <div xmlns="http://www.w3.org/1999/xhtml">
+ <p><i>[Update: The Atom draft is finished.]</i></p>
+ </div>
+ </content>
+ </entry>
+ </feed>
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+
+<rdf:RDF
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:dc="http://purl.org/dc/elements/1.1/"
+ xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
+ xmlns:co="http://purl.org/rss/1.0/modules/company/"
+ xmlns:ti="http://purl.org/rss/1.0/modules/textinput/"
+ xmlns="http://purl.org/rss/1.0/"
+>
+
+ <channel rdf:about="http://meerkat.oreillynet.com/?_fl=rss1.0">
+ <title>Meerkat</title>
+ <link>http://meerkat.oreillynet.com</link>
+ <description>Meerkat: An Open Wire Service</description>
+ <dc:publisher>The O'Reilly Network</dc:publisher>
+ <dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>
+ <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
+ <dc:date>2000-01-01T12:00+00:00</dc:date>
+ <sy:updatePeriod>hourly</sy:updatePeriod>
+ <sy:updateFrequency>2</sy:updateFrequency>
+ <sy:updateBase>2000-01-01T12:00+00:00</sy:updateBase>
+
+ <image rdf:resource="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg" />
+
+ <items>
+ <rdf:Seq>
+ <rdf:li resource="http://c.moreover.com/click/here.pl?r123" />
+ </rdf:Seq>
+ </items>
+
+ <textinput rdf:resource="http://meerkat.oreillynet.com" />
+
+ </channel>
+
+ <image rdf:about="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg">
+ <title>Meerkat Powered!</title>
+ <url>http://meerkat.oreillynet.com/icons/meerkat-powered.jpg</url>
+ <link>http://meerkat.oreillynet.com</link>
+ </image>
+
+ <item rdf:about="http://c.moreover.com/click/here.pl?r123">
+ <title>XML: A Disruptive Technology</title>
+ <link>http://c.moreover.com/click/here.pl?r123</link>
+ <dc:description>
+ XML is placing increasingly heavy loads on the existing technical
+ infrastructure of the Internet.
+ </dc:description>
+ <dc:publisher>The O'Reilly Network</dc:publisher>
+ <dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>
+ <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
+ <dc:subject>XML</dc:subject>
+ <co:name>XML.com</co:name>
+ <co:market>NASDAQ</co:market>
+ <co:symbol>XML</co:symbol>
+ </item>
+
+ <textinput rdf:about="http://meerkat.oreillynet.com">
+ <title>Search Meerkat</title>
+ <description>Search Meerkat's RSS Database...</description>
+ <name>s</name>
+ <link>http://meerkat.oreillynet.com/</link>
+ <ti:function>search</ti:function>
+ <ti:inputType>regex</ti:inputType>
+ </textinput>
+
+</rdf:RDF>
] with-tangle ;
: new-sandbox ( -- )
- development-mode on
+ development? on
delete-db sandbox-db f <tangle>
[ make-sandbox ] [ <tangle-dispatcher> ] bi
main-responder set ;
: <tax-table> ( single married class -- obj )
>r tax-table boa r> construct-delegate ;
-: tax-bracket-range dup second swap first - ;
+: tax-bracket-range ( pair -- n ) dup second swap first - ;
: tax-bracket ( tax salary triples -- tax salary )
[ [ tax-bracket-range min ] keep third * + ] 2keep
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lazy-lists combinators system ;
+tetris.piece tetris.tetromino lists combinators system ;
IN: tetris.game
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays tetris.tetromino math math.vectors
-sequences quotations lazy-lists ;
+sequences quotations lists.lazy ;
IN: tetris.piece
#! A piece adds state to the tetromino that is the piece's delegate. The
IN: tools.crossref
: usage. ( word -- )
- usage sorted-definitions. ;
+ smart-usage sorted-definitions. ;
: words-matching ( str -- seq )
all-words [ dup word-name ] { } map>assoc completions ;
my-boot-image-name resource-path exists?
[ my-arch make-image ] unless ;
-: ?, [ , ] [ drop ] if ;
-
: bootstrap-profile ( -- profile )
- [
- "math" deploy-math? get ?,
- "compiler" deploy-compiler? get ?,
- "ui" deploy-ui? get ?,
- "io" native-io? ?,
- "random" deploy-random? get ?,
- ] { } make ;
+ {
+ { "math" deploy-math? }
+ { "compiler" deploy-compiler? }
+ { "ui" deploy-ui? }
+ { "random" deploy-random? }
+ } [ nip get ] assoc-filter keys
+ native-io? [ "io" suffix ] when ;
: staging-image-name ( profile -- name )
"staging."
{ 3 "Level 3 - Non-blocking streams and networking" }
} ;
-: strip-io? deploy-io get 1 = ;
+: strip-io? ( -- ? ) deploy-io get 1 = ;
-: native-io? deploy-io get 3 = ;
+: native-io? ( -- ? ) deploy-io get 3 = ;
SYMBOL: deploy-reflection
{ 6 "Level 6 - Full environment" }
} ;
-: strip-word-names? deploy-reflection get 2 < ;
-: strip-prettyprint? deploy-reflection get 3 < ;
-: strip-debugger? deploy-reflection get 4 < ;
-: strip-dictionary? deploy-reflection get 5 < ;
-: strip-globals? deploy-reflection get 6 < ;
+: strip-word-names? ( -- ? ) deploy-reflection get 2 < ;
+: strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ;
+: strip-debugger? ( -- ? ) deploy-reflection get 4 < ;
+: strip-dictionary? ( -- ? ) deploy-reflection get 5 < ;
+: strip-globals? ( -- ? ) deploy-reflection get 6 < ;
SYMBOL: deploy-word-props?
SYMBOL: deploy-word-defs?
classes:class-or-cache
classes:class<=-cache
classes:classes-intersect-cache
+ classes:implementors-map
classes:update-map
command-line:main-vocab-hook
compiled-crossref
USING: kernel threads threads.private ;
IN: debugger
-: print-error die ;
+: print-error ( error -- ) die drop ;
-: error. die ;
+: error. ( error -- ) die drop ;
M: thread error-in-thread ( error thread -- ) die 2drop ;
USING: libc.private ;
IN: libc
-: malloc (malloc) check-ptr ;
+: malloc ( size -- newalien ) (malloc) check-ptr ;
-: realloc (realloc) check-ptr ;
+: realloc ( alien size -- newalien ) (realloc) check-ptr ;
-: calloc (calloc) check-ptr ;
+: calloc ( size count -- newalien ) (calloc) check-ptr ;
-: free (free) ;
+: free ( alien -- ) (free) ;
IN: tools.deploy.test.1\r
USING: threads ;\r
\r
-: deploy-test-1 1000 sleep ;\r
+: deploy-test-1 ( -- ) 1000 sleep ;\r
\r
MAIN: deploy-test-1\r
IN: tools.deploy.test.2\r
USING: calendar calendar.format ;\r
\r
-: deploy-test-2 now (timestamp>string) ;\r
+: deploy-test-2 ( -- ) now (timestamp>string) ;\r
\r
MAIN: deploy-test-2\r
IN: tools.deploy.test.3\r
USING: io.encodings.ascii io.files kernel ;\r
\r
-: deploy-test-3\r
+: deploy-test-3 ( -- )\r
"resource:extra/tools/deploy/test/3/3.factor"\r
ascii file-contents drop ;\r
\r
generic ;
IN: tools.disassembler
-: in-file "gdb-in.txt" temp-file ;
+: in-file ( -- path ) "gdb-in.txt" temp-file ;
-: out-file "gdb-out.txt" temp-file ;
+: out-file ( -- path ) "gdb-out.txt" temp-file ;
GENERIC: make-disassemble-cmd ( obj -- )
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
-system sorting splitting math.parser classes memory combinators ;
+system sorting splitting grouping math.parser classes memory
+combinators ;
IN: tools.memory
<PRIVATE
HELP: usage-profile.
{ $values { "word" word } }
{ $description "Prints a table of call counts from the most recent invocation of " { $link profile } ", for words which directly call " { $snippet "word" } " only." }
-{ $notes "This word obtains the list of static usages with the " { $link usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." }
+{ $notes "This word obtains the list of static usages with the " { $link smart-usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." }
{ $examples { $code "\\ + usage-profile." } } ;
HELP: vocabs-profile.
[ ] [ \ + usage-profile. ] unit-test
-: callback-test "void" { } "cdecl" [ ] alien-callback ;
+: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
-: indirect-test "void" { } "cdecl" alien-indirect ;
+: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
: foobar ;
"Call counts for words which call " write
dup pprint
":" print
- usage [ word? ] filter counters counters. ;
+ smart-usage [ word? ] filter counters counters. ;
: vocabs-profile. ( -- )
"Call counts for all vocabularies:" print
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.vectors memory io io.styles prettyprint
-namespaces system sequences splitting assocs strings ;
+namespaces system sequences splitting grouping assocs strings ;
IN: tools.time
: benchmark ( quot -- runtime )
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 )
: 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 ;
[ vocab-dir? ] with filter\r
] curry map concat ;\r
\r
-: map>set ( seq quot -- )\r
- map concat prune natural-sort ; inline\r
-\r
MEMO: all-tags ( -- seq )\r
- all-vocabs-seq [ vocab-tags ] map>set ;\r
+ all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
\r
MEMO: all-authors ( -- seq )\r
- all-vocabs-seq [ vocab-authors ] map>set ;\r
+ all-vocabs-seq [ vocab-authors ] gather natural-sort ;\r
\r
: reset-cache ( -- )\r
root-cache get-global clear-assoc\r
: (step-into-quot) ( quot -- ) add-breakpoint call ;
-: (step-into-if) ? (step-into-quot) ;
+: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
-: (step-into-dispatch) nth (step-into-quot) ;
+: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
{
\ (step-into-execute) t "step-into?" set-word-prop
-: (step-into-continuation)
+: (step-into-continuation) ( -- )
continuation callstack >>call break ;
! Messages sent to walker thread
! For convenience
IN: syntax
-: B break ;
+: B ( -- ) break ;
: get-largest ( node -- node )
dup [ dup node-right [ nip get-largest ] when* ] when ;
-: splay-largest
+: splay-largest ( node -- node )
dup [ dup get-largest node-key swap splay-at ] when ;
: splay-join ( n2 n1 -- node )
: valid-tree? ( tree -- ? ) root>> valid-node? ;
-: tree-call ( node call -- )
- >r [ node-key ] keep node-value r> call ; inline
-
-: find-node ( node quot -- key value ? )
- {
- { [ over not ] [ 2drop f f f ] }
- { [ [
- >r left>> r> find-node
- ] 2keep rot ]
- [ 2drop t ] }
- { [ >r 2nip r> [ tree-call ] 2keep rot ]
- [ drop [ node-key ] keep node-value t ] }
- [ >r right>> r> find-node ]
- } cond ; inline
-
-M: tree assoc-find ( tree quot -- key value ? )
- >r root>> r> find-node ;
+: (node>alist) ( node -- )
+ [
+ [ left>> (node>alist) ]
+ [ [ node-key ] [ node-value ] bi 2array , ]
+ [ right>> (node>alist) ]
+ tri
+ ] when* ;
+
+M: tree >alist [ root>> (node>alist) ] { } make ;
M: tree clear-assoc
0 >>count
-USING: listener io.server io.encodings.utf8 ;
+USING: listener io.servers.connection io.encodings.utf8
+accessors kernel ;
IN: tty-server
-: tty-server ( port -- )
- local-server
- "tty-server"
- utf8 [ listener ] with-server ;
+: <tty-server> ( port -- )
+ <threaded-server>
+ "tty-server" >>name
+ utf8 >>encoding
+ swap local-server >>insecure
+ [ listener ] >>handler
+ start-server ;
-: default-tty-server 9999 tty-server ;
+: tty-server ( -- ) 9999 <tty-server> ;
-MAIN: default-tty-server
+MAIN: tty-server
IN: tuple-arrays
HELP: tuple-array
-{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ;
+{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ;
HELP: <tuple-array>
{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
-{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be f." } ;
+{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ;
! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting classes.tuple classes math kernel sequences
-arrays ;
+USING: splitting grouping classes.tuple classes math kernel
+sequences arrays ;
IN: tuple-arrays
TUPLE: tuple-array example ;
dup state-dir position [ + ] change
state-next state set ;
-: c
+: c ( -- )
#! Print current turing machine state.
state get .
tape get .
2 position get 2 * + CHAR: \s <string> write "^" print ;
-: n
+: n ( -- )
#! Do one step and print new state.
turing-step c ;
HOOK: flush-gl-context ui-backend ( handle -- )
+HOOK: beep ui-backend ( -- )
+
: with-gl-context ( handle quot -- )
swap [ select-gl-context call ] keep
glFlush flush-gl-context gl-error ; inline
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard boa ;
+: <clipboard> ( -- clipboard ) "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
2drop
] if ;
-: com-copy clipboard get gadget-copy ;
+: com-copy ( gadget -- ) clipboard get gadget-copy ;
-: com-copy-selection selection get gadget-copy ;
+: com-copy-selection ( gadget -- ) selection get gadget-copy ;
M: cocoa-ui-backend flush-gl-context ( handle -- )
handle-view -> openGLContext -> flushBuffer ;
+M: cocoa-ui-backend beep ( -- )
+ NSBeep ;
+
SYMBOL: cocoa-init-hook
M: cocoa-ui-backend ui
arrays assocs ;
IN: ui.commands
-: command-map-row
+: command-map-row ( children -- seq )
[
- dup first gesture>string ,
- second dup command-name ,
- dup command-word \ $link swap 2array ,
- command-description ,
- ] [ ] make ;
+ [ first gesture>string , ]
+ [
+ second
+ [ command-name , ]
+ [ command-word \ $link swap 2array , ]
+ [ command-description , ]
+ tri
+ ] bi
+ ] { } make ;
: command-map. ( command-map -- )
[ command-map-row ] map
$table ;
: $command-map ( element -- )
- first2
- dup (command-name) " commands" append $heading
- swap command-map
- dup command-map-blurb print-element command-map. ;
+ [ second (command-name) " commands" append $heading ]
+ [
+ first2 swap command-map
+ [ command-map-blurb print-element ] [ command-map. ] bi
+ ] bi ;
: $command ( element -- )
reverse first3 command-map value-at gesture>string $snippet ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.commands ui.gadgets ui.gadgets.borders
+USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
C: <button-paint> button-paint
-: find-button [ [ button? ] is? ] find-parent ;
+: find-button ( gadget -- button )
+ [ [ button? ] is? ] find-parent ;
: button-paint ( button paint -- button paint )
over find-button {
: toggle-model ( model -- )
[ not ] change-model ;
-: checkbox-theme
- f over set-gadget-interior
- { 5 5 } over set-pack-gap
- 1/2 swap set-pack-align ;
+: checkbox-theme ( gadget -- )
+ f >>interior
+ { 5 5 } >>gap
+ 1/2 >>align
+ drop ;
TUPLE: checkbox ;
#! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
-: radio-button-theme
- { 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
+: radio-button-theme ( gadget -- )
+ { 5 5 } >>gap
+ 1/2 >>align
+ drop ;
: <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right
[ <button> ] <radio-control>
dup radio-button-theme ;
-: radio-buttons-theme
- { 5 5 } swap set-pack-gap ;
+: radio-buttons-theme ( gadget -- )
+ { 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
M: editor pref-dim*
dup editor-font* swap control-value text-dim ;
-: contents-changed
+: contents-changed ( model editor -- )
editor-self swap
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop relayout ;
-: caret/mark-changed
+: caret/mark-changed ( model editor -- )
nip editor-self dup relayout-1 scroll>caret ;
M: editor model-changed
[ drop dup extend-selection dup editor-mark click-loc ]
[ select-elt ] if ;
-: insert-newline "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input ;
-: delete-next-character T{ char-elt } editor-delete ;
+: delete-next-character ( editor -- )
+ T{ char-elt } editor-delete ;
-: delete-previous-character T{ char-elt } editor-backspace ;
+: delete-previous-character ( editor -- )
+ T{ char-elt } editor-backspace ;
-: delete-previous-word T{ word-elt } editor-delete ;
+: delete-previous-word ( editor -- )
+ T{ word-elt } editor-delete ;
-: delete-next-word T{ word-elt } editor-backspace ;
+: delete-next-word ( editor -- )
+ T{ word-elt } editor-backspace ;
-: delete-to-start-of-line T{ one-line-elt } editor-delete ;
+: delete-to-start-of-line ( editor -- )
+ T{ one-line-elt } editor-delete ;
-: delete-to-end-of-line T{ one-line-elt } editor-backspace ;
+: delete-to-end-of-line ( editor -- )
+ T{ one-line-elt } editor-backspace ;
editor "general" f {
{ T{ key-down f f "DELETE" } delete-next-character }
{ T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
} define-command-map
-: paste clipboard get paste-clipboard ;
+: paste ( editor -- ) clipboard get paste-clipboard ;
-: paste-selection selection get paste-clipboard ;
+: paste-selection ( editor -- ) selection get paste-clipboard ;
-: cut clipboard get editor-cut ;
+: cut ( editor -- ) clipboard get editor-cut ;
editor "clipboard" f {
{ T{ paste-action } paste }
T{ char-elt } editor-next
] if ;
-: previous-line T{ line-elt } editor-prev ;
+: previous-line ( editor -- ) T{ line-elt } editor-prev ;
-: next-line T{ line-elt } editor-next ;
+: next-line ( editor -- ) T{ line-elt } editor-next ;
-: previous-word T{ word-elt } editor-prev ;
+: previous-word ( editor -- ) T{ word-elt } editor-prev ;
-: next-word T{ word-elt } editor-next ;
+: next-word ( editor -- ) T{ word-elt } editor-next ;
-: start-of-line T{ one-line-elt } editor-prev ;
+: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
-: end-of-line T{ one-line-elt } editor-next ;
+: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
editor "caret-motion" f {
{ T{ button-down } position-caret }
{ T{ key-down f { C+ } "END" } end-of-document }
} define-command-map
-: select-all T{ doc-elt } select-elt ;
+: select-all ( editor -- ) T{ doc-elt } select-elt ;
-: select-line T{ one-line-elt } select-elt ;
+: select-line ( editor -- ) T{ one-line-elt } select-elt ;
-: select-word T{ one-word-elt } select-elt ;
+: select-word ( editor -- ) T{ one-word-elt } select-elt ;
: selected-word ( editor -- string )
dup gadget-selection?
[ dup select-word ] unless
gadget-selection ;
-: select-previous-character T{ char-elt } editor-select-prev ;
+: select-previous-character ( editor -- )
+ T{ char-elt } editor-select-prev ;
-: select-next-character T{ char-elt } editor-select-next ;
+: select-next-character ( editor -- )
+ T{ char-elt } editor-select-next ;
-: select-previous-line T{ line-elt } editor-select-prev ;
+: select-previous-line ( editor -- )
+ T{ line-elt } editor-select-prev ;
-: select-next-line T{ line-elt } editor-select-next ;
+: select-next-line ( editor -- )
+ T{ line-elt } editor-select-next ;
-: select-previous-word T{ word-elt } editor-select-prev ;
+: select-previous-word ( editor -- )
+ T{ word-elt } editor-select-prev ;
-: select-next-word T{ word-elt } editor-select-next ;
+: select-next-word ( editor -- )
+ T{ word-elt } editor-select-next ;
-: select-start-of-line T{ one-line-elt } editor-select-prev ;
+: select-start-of-line ( editor -- )
+ T{ one-line-elt } editor-select-prev ;
-: select-end-of-line T{ one-line-elt } editor-select-next ;
+: select-end-of-line ( editor -- )
+ T{ one-line-elt } editor-select-next ;
-: select-start-of-document T{ doc-elt } editor-select-prev ;
+: select-start-of-document ( editor -- )
+ T{ doc-elt } editor-select-prev ;
-: select-end-of-document T{ doc-elt } editor-select-next ;
+: select-end-of-document ( editor -- )
+ T{ doc-elt } editor-select-next ;
editor "selection" f {
{ T{ button-down f { S+ } } extend-selection }
-USING: kernel alien.c-types combinators sequences splitting
+USING: kernel alien.c-types combinators sequences splitting grouping
opengl.gl ui.gadgets ui.render
math math.vectors accessors ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
-splitting math.vectors ui.gadgets.grids ui.gadgets ;
+splitting grouping math.vectors ui.gadgets.grids ui.gadgets ;
IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space.
TUPLE: frame ;
-: <frame-grid> 9 [ drop <gadget> ] map 3 group ;
+: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ;
: @left 0 1 ;
IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel dlists math sets
+namespaces models kernel dlists dequeues math sets
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
[
<dlist> \ graft-queue [
[ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
- [ t ] [ graft-queue dlist-empty? ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
] with-variable
<dlist> \ graft-queue [
- [ t ] [ graft-queue dlist-empty? ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
<mock-gadget> "g" set
[ ] [ "g" get queue-graft ] unit-test
- [ f ] [ graft-queue dlist-empty? ] unit-test
+ [ f ] [ graft-queue dequeue-empty? ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
- [ t ] [ graft-queue dlist-empty? ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ ] [ notify-queued ] unit-test
[ { t t } ] [ "g" get gadget-graft-state ] unit-test
- [ t ] [ graft-queue dlist-empty? ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { f t } ] [ "1" get gadget-graft-state ] unit-test
[ { f t } ] [ "2" get gadget-graft-state ] unit-test
[ { f t } ] [ "3" get gadget-graft-state ] unit-test
- [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
+ [ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test
[ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test
] with-variable ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables kernel models math namespaces sequences
-quotations math.vectors combinators sorting vectors dlists
-models threads concurrency.flags math.order ;
+USING: accessors arrays hashtables kernel models math namespaces
+sequences quotations math.vectors combinators sorting vectors
+dlists dequeues models threads concurrency.flags math.order ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
dup gadget-layout-state
[ drop ] [ dup invalidate layout-later ] if ;
-: show-gadget t swap set-gadget-visible? ;
+: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
-: hide-gadget f swap set-gadget-visible? ;
+: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
: (set-rect-dim) ( dim gadget quot -- )
>r 2dup rect-dim =
dup [ layout ] each-child
] when drop ;
-: graft-queue \ graft-queue get ;
+: graft-queue ( -- dlist ) \ graft-queue get ;
: unqueue-graft ( gadget -- )
- graft-queue over gadget-graft-node delete-node
- dup gadget-graft-state first { t t } { f f } ?
- swap set-gadget-graft-state ;
+ [ graft-node>> graft-queue delete-node ]
+ [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
: (queue-graft) ( gadget flags -- )
- over set-gadget-graft-state
- dup graft-queue push-front* swap set-gadget-graft-node
+ >>graft-state
+ dup graft-queue push-front* >>graft-node drop
notify-ui-thread ;
: queue-graft ( gadget -- )
SYMBOL: in-layout?
-: not-in-layout
+: not-in-layout ( -- )
in-layout? get
[ "Cannot add/remove gadgets in layout*" throw ] when ;
: pref-dim-grid ( grid -- dims )
grid-children [ [ pref-dim ] map ] map ;
-: (compute-grid) [ max-dim ] map ;
+: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert )
pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
{ 0.65 0.45 1.0 1.0 }
} } swap set-gadget-interior ;
-: <title-label> <label> dup title-theme ;
+: <title-label> ( text -- label ) <label> dup title-theme ;
: <title-bar> ( title quot -- gadget )
[
selection-color caret mark selecting? ;
: clear-selection ( pane -- )
- f over set-pane-caret
- f swap set-pane-mark ;
+ f >>caret
+ f >>mark
+ drop ;
-: add-output 2dup set-pane-output add-gadget ;
+: add-output ( current pane -- )
+ [ set-pane-output ] [ add-gadget ] 2bi ;
-: add-current 2dup set-pane-current add-gadget ;
+: add-current ( current pane -- )
+ [ set-pane-current ] [ add-gadget ] 2bi ;
: prepare-line ( pane -- )
- dup clear-selection
- dup pane-prototype clone swap add-current ;
+ [ clear-selection ]
+ [ [ pane-prototype clone ] keep add-current ] bi ;
: pane-caret&mark ( pane -- caret mark )
- dup pane-caret swap pane-mark ;
+ [ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
selected-children gadget-text ;
: pane-clear ( pane -- )
- dup clear-selection
- dup pane-output clear-incremental
- pane-current clear-gadget ;
+ [ clear-selection ]
+ [ pane-output clear-incremental ]
+ [ pane-current clear-gadget ]
+ tri ;
-: pane-theme ( editor -- )
- selection-color swap set-pane-selection-color ;
+: pane-theme ( pane -- )
+ selection-color >>selection-color drop ;
: <pane> ( -- pane )
pane new
<pile> over set-delegate
- <shelf> over set-pane-prototype
+ <shelf> >>prototype
<pile> <incremental> over add-output
dup prepare-line
dup pane-theme ;
: overrun? ( width -- ? ) x get + margin get > ;
-: zero-vars [ 0 swap set ] each ;
+: zero-vars ( seq -- ) [ 0 swap set ] each ;
: wrap-line ( -- )
line-height get y +@
: find-scroller ( gadget -- scroller/f )
[ [ scroller? ] is? ] find-parent ;
-: scroll-up-page scroller-y -1 swap slide-by-page ;
+: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
-: scroll-down-page scroller-y 1 swap slide-by-page ;
+: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
-: scroll-up-line scroller-y -1 swap slide-by-line ;
+: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
-: scroll-down-line scroller-y 1 swap slide-by-line ;
+: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- )
scroll-direction get-global first2
: <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
-: x-model g gadget-model model-dependencies first ;
+: x-model ( -- model ) g gadget-model model-dependencies first ;
-: y-model g gadget-model model-dependencies second ;
+: y-model ( -- model ) g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller )
<scroller-model> <frame> scroller construct-control [
: min-thumb-dim 15 ;
-: slider-value gadget-model range-value >fixnum ;
+: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
-: slider-page gadget-model range-page-value ;
+: slider-page ( gadget -- n ) gadget-model range-page-value ;
-: slider-max gadget-model range-max-value ;
+: slider-max ( gadget -- n ) gadget-model range-max-value ;
-: slider-max* gadget-model range-max-value* ;
+: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
: thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min
dup elevator-length over thumb-dim - 1 max
swap slider-max* 1 max / ;
-: slider>screen slider-scale * ;
+: slider>screen ( m scale -- n ) slider-scale * ;
-: screen>slider slider-scale / ;
+: screen>slider ( m scale -- n ) slider-scale / ;
M: slider model-changed nip slider-elevator relayout-1 ;
swap <thumb> g-> set-slider-thumb over add-gadget
@center frame, ;
-: <left-button> { 0 1 } arrow-left -1 <slide-button> ;
-: <right-button> { 0 1 } arrow-right 1 <slide-button> ;
+: <left-button> ( -- button )
+ { 0 1 } arrow-left -1 <slide-button> ;
+
+: <right-button> ( -- button )
+ { 0 1 } arrow-right 1 <slide-button> ;
: build-x-slider ( slider -- )
[
<right-button> @right frame,
] with-gadget ;
-: <up-button> { 1 0 } arrow-up -1 <slide-button> ;
-: <down-button> { 1 0 } arrow-down 1 <slide-button> ;
+: <up-button> ( -- button )
+ { 1 0 } arrow-up -1 <slide-button> ;
+
+: <down-button> ( -- button )
+ { 1 0 } arrow-down 1 <slide-button> ;
: build-y-slider ( slider -- )
[
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
colors ;
IN: ui.gadgets.theme
-: solid-interior <solid> swap set-gadget-interior ;
+: solid-interior ( gadget color -- )
+ <solid> swap set-gadget-interior ;
-: solid-boundary <solid> swap set-gadget-boundary ;
+: solid-boundary ( gadget color -- )
+ <solid> swap set-gadget-boundary ;
-: faint-boundary gray solid-boundary ;
+: faint-boundary ( gadget -- )
+ gray solid-boundary ;
-: selection-color light-purple ;
+: selection-color ( -- color ) light-purple ;
: plain-gradient
T{ gradient f {
TUPLE: viewport ;
-: find-viewport [ viewport? ] find-parent ;
+: find-viewport ( gadget -- viewport )
+ [ viewport? ] find-parent ;
: viewport-dim ( viewport -- dim )
gadget-child pref-dim viewport-gap 2 v*n v+ ;
fonts handle
loc ;
-: find-world [ world? ] find-parent ;
+: find-world ( gadget -- world ) [ world? ] find-parent ;
M: f world-status ;
C: <solid> solid
! Solid pen
-: (solid)
+: (solid) ( gadget paint -- loc dim )
solid-color gl-color rect-dim >r origin get dup r> v+ ;
M: solid draw-interior (solid) gl-fill-rect ;
USING: debugger ui.tools.workspace help help.topics kernel
models ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs ;
+ui.gadgets.buttons compiler.units assocs words vocabs
+accessors ;
IN: ui.tools.browser
TUPLE: browser-gadget pane history ;
: show-help ( link help -- )
- dup browser-gadget-history add-history
- >r >link r> browser-gadget-history set-model ;
+ dup history>> add-history
+ >r >link r> history>> set-model ;
: <help-pane> ( browser-gadget -- gadget )
- browser-gadget-history
- [ [ dup help ] try drop ] <pane-control> ;
+ history>> [ [ help ] curry try ] <pane-control> ;
: init-history ( browser-gadget -- )
- "handbook" >link <history>
- swap set-browser-gadget-history ;
+ "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget )
browser-gadget new
M: browser-gadget call-tool* show-help ;
M: browser-gadget tool-scroller
- browser-gadget-pane find-scroller ;
+ pane>> find-scroller ;
M: browser-gadget graft*
dup add-definition-observer
or or ;
M: browser-gadget definitions-changed ( assoc browser -- )
- browser-gadget-history
+ history>>
dup model-value rot showing-definition?
[ notify-connections ] [ drop ] if ;
: help-action ( browser-gadget -- link )
- browser-gadget-history model-value >link ;
+ history>> model-value >link ;
-: com-follow browser-gadget call-tool ;
+: com-follow ( link -- ) browser-gadget call-tool ;
-: com-back browser-gadget-history go-back ;
+: com-back ( browser -- ) history>> go-back ;
-: com-forward browser-gadget-history go-forward ;
+: com-forward ( browser -- ) history>> go-forward ;
-: com-documentation "handbook" swap show-help ;
+: com-documentation ( browser -- ) "handbook" swap show-help ;
-: com-vocabularies "vocab-index" swap show-help ;
+: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
-: browser-help "ui-browser" help-window ;
+: browser-help ( -- ) "ui-browser" help-window ;
\ browser-help H{ { +nullary+ t } } define-command
{ T{ button-down } request-focus }
} define-command-map
-: com-traceback error-continuation get traceback-window ;
+: com-traceback ( -- ) error-continuation get traceback-window ;
\ com-traceback H{ { +nullary+ t } } define-command
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-tools.deploy vocabs ui.tools.workspace system ;
+tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ;
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
-: deploy-settings-theme
- { 10 10 } over set-pack-gap
- 1 swap set-pack-fill ;
+: deploy-settings-theme ( gadget -- )
+ { 10 10 } >>gap
+ 1 >>fill
+ drop ;
: <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map [
namespace <mapping> over set-gadget-model
] bind ;
-: find-deploy-gadget
+: find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ;
-: find-deploy-vocab
+: find-deploy-vocab ( gadget -- vocab )
find-deploy-gadget deploy-gadget-vocab ;
-: find-deploy-config
+: find-deploy-config ( gadget -- config )
find-deploy-vocab deploy-config ;
-: find-deploy-settings
+: find-deploy-settings ( gadget -- settings )
find-deploy-gadget deploy-gadget-settings ;
: com-revert ( gadget -- )
{ T{ key-down f f "RET" } com-deploy }
} define-command-map
-: buttons,
+: buttons, ( -- )
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
\ globals H{ { +nullary+ t } { +listener+ t } } define-command
-: inspector-help "ui-inspector" help-window ;
+: inspector-help ( -- ) "ui-inspector" help-window ;
\ inspector-help H{ { +nullary+ t } } define-command
listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
-: listener-help "ui-listener" help-window ;
+: listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
-tools.vocabs classes compiler.units ;
+tools.vocabs classes compiler.units accessors ;
IN: ui.tools.operations
V{ } clone operations set-global
{ +listener+ t }
} define-operation
-: com-prettyprint . ;
+: com-prettyprint ( obj -- ) . ;
[ drop t ] \ com-prettyprint H{
{ +listener+ t }
} define-operation
-: com-push ;
+: com-push ( obj -- obj ) ;
[ drop t ] \ com-push H{
{ +listener+ t }
} define-operation
-: com-unparse unparse listener-input ;
+: com-unparse ( obj -- ) unparse listener-input ;
[ drop t ] \ com-unparse H{ } define-operation
! Input
-: com-input input-string listener-input ;
+: com-input ( obj -- ) string>> listener-input ;
[ input? ] \ com-input H{
{ +primary+ t }
} define-operation
! Pathnames
-: edit-file edit ;
+: edit-file ( pathname -- ) edit ;
[ pathname? ] \ edit-file H{
{ +keyboard+ T{ key-down f { C+ } "E" } }
} define-operation
! Vocabularies
-: com-vocab-words get-workspace swap show-vocab-words ;
+: com-vocab-words ( vocab -- )
+ get-workspace swap show-vocab-words ;
[ vocab? ] \ com-vocab-words H{
{ +secondary+ t }
{ +keyboard+ T{ key-down f { C+ } "B" } }
} define-operation
-: com-enter-in vocab-name set-in ;
+: com-enter-in ( vocab -- ) vocab-name set-in ;
[ vocab? ] \ com-enter-in H{
{ +keyboard+ T{ key-down f { C+ } "I" } }
{ +listener+ t }
} define-operation
-: com-use-vocab vocab-name use+ ;
+: com-use-vocab ( vocab -- ) vocab-name use+ ;
[ vocab-spec? ] \ com-use-vocab H{
{ +secondary+ t }
{ +listener+ t }
} define-operation
-: com-show-profile profiler-gadget call-tool ;
+: com-show-profile ( workspace -- )
+ profiler-gadget call-tool ;
: com-profile ( quot -- ) profile f com-show-profile ;
: com-method-profile ( gadget -- )
[ method-profile. ] with-profiler-pane ;
-: profiler-help "ui-profiler" help-window ;
+: profiler-help ( -- ) "ui-profiler" help-window ;
\ profiler-help H{ { +nullary+ t } } define-command
2drop t
] if ;
-: find-live-search [ [ live-search? ] is? ] find-parent ;
+: find-live-search ( gadget -- search )
+ [ [ live-search? ] is? ] find-parent ;
-: find-search-list find-live-search live-search-list ;
+: find-search-list ( gadget -- list )
+ find-live-search live-search-list ;
TUPLE: search-field ;
"Words in " rot vocab-name append show-titled-popup ;
: show-word-usage ( workspace word -- )
- "" over usage f <definition-search>
+ "" over smart-usage f <definition-search>
"Words and methods using " rot word-name append
show-titled-popup ;
[ workspace-window ] ui-hook set-global
-: com-listener stack-display select-tool ;
+: com-listener ( workspace -- ) stack-display select-tool ;
-: com-browser browser-gadget select-tool ;
+: com-browser ( workspace -- ) browser-gadget select-tool ;
-: com-inspector inspector-gadget select-tool ;
+: com-inspector ( workspace -- ) inspector-gadget select-tool ;
-: com-profiler profiler-gadget select-tool ;
+: com-profiler ( workspace -- ) profiler-gadget select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
g walker-gadget-traceback 1 track,
] { 0 1 } build-track ;
-: walker-help "ui-walker" help-window ;
+: walker-help ( -- ) "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command
TUPLE: workspace book listener popup ;
-: find-workspace [ workspace? ] find-parent ;
+: find-workspace ( gadget -- workspace )
+ [ workspace? ] find-parent ;
SYMBOL: workspace-window-hook
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces
-prettyprint dlists sequences threads sequences words
+prettyprint dlists dequeues sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
hashtables concurrency.flags sets ;
: event-loop? ( -- ? )
{
{ [ stop-after-last-window? get not ] [ t ] }
- { [ graft-queue dlist-empty? not ] [ t ] }
+ { [ graft-queue dequeue-empty? not ] [ t ] }
{ [ windows get-global empty? not ] [ t ] }
[ f ]
} cond ;
in-layout? on
layout-queue [
dup layout find-world [ , ] when*
- ] dlist-slurp
+ ] slurp-dequeue
] { } make prune ;
: redraw-worlds ( seq -- )
} case ;
: notify-queued ( -- )
- graft-queue [ notify ] dlist-slurp ;
+ graft-queue [ notify ] slurp-dequeue ;
: update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs ui
ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces prettyprint
+ui.gestures io kernel math math.vectors namespaces
sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations
SINGLETON: windows-ui-backend
-: crlf>lf CHAR: \r swap remove ;
-: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
+: crlf>lf ( str -- str' )
+ CHAR: \r swap remove ;
+
+: lf>crlf ( str -- str' )
+ [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
: enum-clipboard ( -- seq )
0
{ 123 "F12" }
} ;
-: key-state-down?
+: key-state-down? ( key -- ? )
GetKeyState 16 bit? ;
: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
"uint" { "void*" "uint" "long" "long" } "stdcall" [
[
pick
- trace-messages? get-global [ dup windows-message-name . ] when
+ trace-messages? get-global [ dup windows-message-name word-name print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] ui-try
] alien-callback ;
] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ;
+M: windows-ui-backend beep ( -- )
+ 0 MessageBeep drop ;
+
windows-ui-backend ui-backend set-global
[ "ui" ] main-vocab-hook set-global
SINGLETON: x11-ui-backend
-: XA_NET_WM_NAME "_NET_WM_NAME" x-atom ;
+: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
TUPLE: x11-handle window glx xic ;
] with-x
] ui-running ;
+M: x11-ui-backend beep ( -- )
+ dpy get 100 XBell drop ;
+
x11-ui-backend ui-backend set-global
[ "DISPLAY" system:os-env "ui" "listener" ? ]
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ]
- [ "Other_Grapheme_Extend" property? ] or? ;
+ { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
: grapheme-class ( ch -- class )
{
} cond ;
: init-grapheme-table ( -- table )
- graphemes [ drop graphemes f <array> ] map ;
+ graphemes [ graphemes f <array> ] replicate ;
SYMBOL: table
-USING: io io.files splitting unicode.collation sequences kernel\r
-io.encodings.utf8 math.parser math.order tools.test assocs\r
-io.streams.null words combinators.lib ;\r
+USING: io io.files splitting grouping unicode.collation\r
+sequences kernel io.encodings.utf8 math.parser math.order\r
+tools.test assocs io.streams.null words combinators.lib ;\r
IN: unicode.collation.tests\r
\r
: parse-test ( -- strings )\r
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;\r
\r
: illegal? ( char -- ? )\r
- [ "Noncharacter_Code_Point" property? ]\r
- [ category "Cs" = ] or? ;\r
+ { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;\r
\r
: derive-weight ( char -- weights )\r
first dup illegal?\r
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser hash2 math.order
+quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii values interval-maps ascii sets assocs.lib
+io.encodings.ascii values interval-maps ascii sets
combinators.lib combinators locals math.ranges sorting ;
IN: unicode.data
: (process-data) ( index data -- newdata )
filter-comments
- [ [ nth ] keep first swap 2array ] with map
+ [ [ nth ] keep first swap ] with { } map>assoc
[ >r hex> r> ] assoc-map ;
: process-data ( index data -- hash )
- (process-data) [ hex> ] assoc-map >hashtable ;
+ (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
: (chain-decomposed) ( hash value -- newvalue )
[
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] or? ;
+ second { [ empty? ] [ first ] } 1|| ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
:: fill-ranges ( table -- table )
name-map >alist sort-values keys
- [ [ "first>" tail? ] [ "last>" tail? ] or? ] filter
+ [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
[ swap table ?set-nth ] curry each
: properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc
- [ [ insert-at ] curry assoc-each ] keep
+ [ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;
: load-properties ( -- assoc )
USING: sequences namespaces unicode.data kernel math arrays
-locals combinators.lib sequences.lib combinators.lib ;
+locals combinators.lib sorting.insertion combinators.lib ;
IN: unicode.normalize
! Conjoining Jamo behavior
+++ /dev/null
-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
: cd ( n -- dimensioned ) { cd } { } <dimensioned> ;
! SI derived units
-: m^2 { m m } { } <dimensioned> ;
-: m^3 { m m m } { } <dimensioned> ;
-: m/s { m } { s } <dimensioned> ;
-: m/s^2 { m } { s s } <dimensioned> ;
-: 1/m { } { m } <dimensioned> ;
-: kg/m^3 { kg } { m m m } <dimensioned> ;
-: A/m^2 { A } { m m } <dimensioned> ;
-: A/m { A } { m } <dimensioned> ;
-: mol/m^3 { mol } { m m m } <dimensioned> ;
-: cd/m^2 { cd } { m m } <dimensioned> ;
-: kg/kg { kg } { kg } <dimensioned> ;
+: m^2 ( n -- dimensioned ) { m m } { } <dimensioned> ;
+: m^3 ( n -- dimensioned ) { m m m } { } <dimensioned> ;
+: m/s ( n -- dimensioned ) { m } { s } <dimensioned> ;
+: m/s^2 ( n -- dimensioned ) { m } { s s } <dimensioned> ;
+: 1/m ( n -- dimensioned ) { } { m } <dimensioned> ;
+: kg/m^3 ( n -- dimensioned ) { kg } { m m m } <dimensioned> ;
+: A/m^2 ( n -- dimensioned ) { A } { m m } <dimensioned> ;
+: A/m ( n -- dimensioned ) { A } { m } <dimensioned> ;
+: mol/m^3 ( n -- dimensioned ) { mol } { m m m } <dimensioned> ;
+: cd/m^2 ( n -- dimensioned ) { cd } { m m } <dimensioned> ;
+: kg/kg ( n -- dimensioned ) { kg } { kg } <dimensioned> ;
! Radians are really m/m, and steradians are m^2/m^2
! but they need to be in reduced form here.
: kat ( n -- katal ) { mol } { s } <dimensioned> ;
! Extensions to the SI
-: arc-deg pi 180 / * radians ;
-: arc-min pi 10800 / * radians ;
-: arc-sec pi 648000 / * radians ;
+: arc-deg ( n -- x ) pi 180 / * radians ;
+: arc-min ( n -- x ) pi 10800 / * radians ;
+: arc-sec ( n -- x ) pi 648000 / * radians ;
: L ( n -- liter ) 1/1000 * m^3 ;
: tons ( n -- metric-ton ) 1000 * kg ;
: Np ( n -- neper ) { } { } <dimensioned> ;
: bar ( n -- bar ) 100000 * Pa ;
: b ( n -- barn ) 1/10000000000000000000000000000 * m^2 ;
: Ci ( n -- curie ) 37000000000 * Bq ;
-: R 258/10000 { s A } { kg } <dimensioned> ;
-: rad 100 / Gy ;
+: R ( -- dimensioned ) 258/10000 { s A } { kg } <dimensioned> ;
+: rad ( n -- dimensioned ) 100 / Gy ;
! roentgen equivalent man, equal to one roentgen of X-rays
-: roentgen-equivalent-man 100 / Sv ;
+: roentgen-equivalent-man ( n -- dimensioned ) 100 / Sv ;
! inaccurate, use calendar where possible
-: minutes 60 * s ;
-: hours 60 * minutes ;
-: days 24 * hours ;
+: minutes ( n -- dimensioned ) 60 * s ;
+: hours ( n -- dimensioned ) 60 * minutes ;
+: days ( n -- dimensioned ) 24 * hours ;
! Y Z E P T G M k h da 1 d c m mu n p f a z y
-: yotta 1000000000000000000000000 * ;
-: zetta 1000000000000000000000 * ;
-: exa 1000000000000000000 * ;
-: peta 1000000000000000 * ;
-: tera 1000000000000 * ;
-: giga 1000000000 * ;
-: mega 1000000 * ;
-: kilo 1000 * ;
-: hecto 100 * ;
-: deca 10 * ;
-: deci 10 / ;
-: centi 100 / ;
-: milli 1000 / ;
-: micro 1000000 / ;
-: nano 1000000000 / ;
-: pico 1000000000000 / ;
-: femto 1000000000000000 / ;
-: atto 1000000000000000000 / ;
-: zepto 1000000000000000000000 / ;
-: yocto 1000000000000000000000000 / ;
-
-: km kilo m ;
-: cm centi m ;
-: mm milli m ;
-: nm nano m ;
-: g milli kg ;
-: ms milli s ;
-: angstrom 10 / nm ;
+: yotta ( n -- x ) 1000000000000000000000000 * ;
+: zetta ( n -- x ) 1000000000000000000000 * ;
+: exa ( n -- x ) 1000000000000000000 * ;
+: peta ( n -- x ) 1000000000000000 * ;
+: tera ( n -- x ) 1000000000000 * ;
+: giga ( n -- x ) 1000000000 * ;
+: mega ( n -- x ) 1000000 * ;
+: kilo ( n -- x ) 1000 * ;
+: hecto ( n -- x ) 100 * ;
+: deca ( n -- x ) 10 * ;
+: deci ( n -- x ) 10 / ;
+: centi ( n -- x ) 100 / ;
+: milli ( n -- x ) 1000 / ;
+: micro ( n -- x ) 1000000 / ;
+: nano ( n -- x ) 1000000000 / ;
+: pico ( n -- x ) 1000000000000 / ;
+: femto ( n -- x ) 1000000000000000 / ;
+: atto ( n -- x ) 1000000000000000000 / ;
+: zepto ( n -- x ) 1000000000000000000000 / ;
+: yocto ( n -- x ) 1000000000000000000000000 / ;
+
+: km ( n -- dimensioned ) kilo m ;
+: cm ( n -- dimensioned ) centi m ;
+: mm ( n -- dimensioned ) milli m ;
+: nm ( n -- dimensioned ) nano m ;
+: g ( n -- dimensioned ) milli kg ;
+: ms ( n -- dimensioned ) milli s ;
+: angstrom ( n -- dimensioned ) 10 / nm ;
[ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ;
-: 2values [ dimensioned-value ] bi@ ;
+: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ;
-: <dimension-op
+: <dimension-op ( dim dim -- top bot val val )
2dup check-dimensions dup dimensions 2swap 2values ;
-: dimension-op>
+: dimension-op> ( top bot val -- dim )
-rot <dimensioned> ;
: d+ ( d d -- d ) <dimension-op + dimension-op> ;
: IN_Q_OVERFLOW HEX: 4000 ; inline ! Event queued overflowed\r
: IN_IGNORED HEX: 8000 ; inline ! File was ignored\r
\r
-: IN_CLOSE IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close\r
-: IN_MOVE IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves\r
+: IN_CLOSE ( -- n ) IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close\r
+: IN_MOVE ( -- n ) IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves\r
\r
: IN_ONLYDIR HEX: 1000000 ; inline ! only watch the path if it is a directory\r
: IN_DONT_FOLLOW HEX: 2000000 ; inline ! don't follow a sym link\r
: IN_ISDIR HEX: 40000000 ; inline ! event occurred against dir\r
: IN_ONESHOT HEX: 80000000 ; inline ! only send event once\r
\r
-: IN_CHANGE_EVENTS\r
+: IN_CHANGE_EVENTS ( -- n )\r
{\r
IN_MODIFY IN_ATTRIB IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
} flags ; foldable\r
\r
-: IN_ALL_EVENTS\r
+: IN_ALL_EVENTS ( -- n )\r
{\r
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE\r
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM\r
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-: stat-st_atim stat-st_atimespec ;
-: stat-st_mtim stat-st_mtimespec ;
-: stat-st_ctim stat-st_ctimespec ;
+: stat-st_atim ( stat -- timespec ) stat-st_atimespec ;
+: stat-st_mtim ( stat -- timespec ) stat-st_mtimespec ;
+: stat-st_ctim ( stat -- timespec ) stat-st_ctimespec ;
FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ;
-: stat __stat30 ;
-: lstat __lstat30 ;
+: stat ( pathname buf -- n ) __stat30 ; inline
+: lstat ( pathname buf -- n ) __lstat30 ; inline
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
-: stat __stat13 ; inline
-: lstat __lstat13 ; inline
+: stat ( pathname buf -- n ) __stat13 ; inline
+: lstat ( pathname buf -- n ) __lstat13 ; inline
IN: urls.tests
-USING: urls tools.test tuple-syntax arrays kernel assocs ;
+USING: urls urls.private tools.test
+tuple-syntax arrays kernel assocs
+present accessors ;
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
] assoc-each
urls [
- swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
+ swap [ 1array ] [ [ present ] curry ] bi* unit-test
] assoc-each
[ "b" ] [ "a" "b" url-append-path ] unit-test
[ "a" ] [
<url> "a" "b" set-query-param "b" query-param
] unit-test
+
+[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test
fry namespaces assocs arrays strings io.sockets
io.sockets.secure io.encodings.string io.encodings.utf8
math math.parser accessors mirrors parser
-prettyprint.backend hashtables ;
+prettyprint.backend hashtables present ;
IN: urls
: url-quotable? ( ch -- ? )
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
- { [ dup "/_-.:" member? ] [ t ] }
+ { [ dup "/_-." member? ] [ t ] }
[ f ]
} cond nip ; foldable
+<PRIVATE
+
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+PRIVATE>
+
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
+<PRIVATE
+
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] if url-decode-iter
] if ;
+PRIVATE>
+
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
+<PRIVATE
+
: add-query-param ( value key assoc -- )
[
at [
] when*
] 2keep set-at ;
+PRIVATE>
+
: query>assoc ( query -- assoc )
dup [
"&" split H{ } clone [
: assoc>query ( hash -- str )
[
- {
- { [ dup number? ] [ number>string 1array ] }
- { [ dup string? ] [ 1array ] }
- { [ dup sequence? ] [ ] }
- } cond
+ dup array? [ [ present ] map ] [ present 1array ] if
] assoc-map
[
[
] when
] bi* ;
+<PRIVATE
+
: parse-host-part ( url protocol rest -- url string' )
[ >>protocol ] [
"//" ?head [ "Invalid URL" throw ] unless
] [ "/" prepend ] bi*
] bi* ;
+PRIVATE>
+
GENERIC: >url ( obj -- url )
+M: f >url drop <url> ;
+
M: url >url ;
M: string >url
]
[ url-decode >>anchor ] bi* ;
+<PRIVATE
+
: unparse-username-password ( url -- )
dup username>> dup [
% password>> [ ":" % % ] when* "@" %
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
-: url>string ( url -- string )
+M: url present
[
{
[ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
[ path>> url-encode % ]
[ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
- [ anchor>> [ "#" % url-encode % ] when* ]
+ [ anchor>> [ "#" % present url-encode % ] when* ]
} cleave
] "" make ;
[ [ "/" last-split1 drop "/" ] dip 3append ]
} cond ;
+PRIVATE>
+
: derive-url ( base url -- url' )
[ clone dup ] dip
2dup [ path>> ] bi@ url-append-path
! Literal syntax
: URL" lexer get skip-blank parse-string >url parsed ; parsing
-M: url pprint* dup url>string "URL\" " "\"" pprint-string ;
+M: url pprint* dup present "URL\" " "\"" pprint-string ;
USING: kernel sequences tools.test validators accessors
namespaces assocs ;
-: with-validation ( quot -- messages )
- [
- init-validation
- call
- validation-messages get
- named-validation-messages get >alist append
- ] with-scope ; inline
-
[ "" v-one-line ] must-fail
[ "hello world" ] [ "hello world" v-one-line ] unit-test
[ "hello\nworld" v-one-line ] must-fail
[ "4561_2612_1234_5467" v-credit-card ] must-fail
[ "4561-2621-1234-5467" v-credit-card ] must-fail
-
-
-[ 14 V{ } ] [
- [
- "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
- ] with-validation
-] unit-test
-
-[ f t ] [
- [
- "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
- ] with-validation first
- [ first "age" = ]
- [ second validation-error? ]
- [ second value>> "140" = ]
- tri and and
-] unit-test
-
-TUPLE: person name age ;
-
-person {
- { "name" [ ] }
- { "age" [ v-number 13 v-min-value 100 v-max-value ] }
-} define-validators
-
-[ t t ] [
- [
- { { "age" "" } } required-values
- validation-failed?
- ] with-validation first
- [ first "age" = ]
- [ second validation-error? ]
- [ second message>> "required" = ]
- tri and and
-] unit-test
-
-[ H{ { "a" 123 } } f V{ } ] [
- [
- H{
- { "a" "123" }
- { "b" "c" }
- { "c" "d" }
- }
- H{
- { "a" [ v-integer ] }
- } validate-values
- validation-failed?
- ] with-validation
-] unit-test
-
-[ t "foo" ] [
- [
- "foo" validation-error
- validation-failed?
- ] with-validation first message>>
-] unit-test
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences sequences.lib math
-namespaces sets math.parser math.ranges assocs regexp fry
-unicode.categories arrays hashtables words combinators mirrors
+namespaces sets math.parser math.ranges assocs regexp
+unicode.categories arrays hashtables words
classes quotations xmode.catalog ;
IN: validators
] [
"invalid credit card number format" throw
] if ;
-
-SYMBOL: validation-messages
-SYMBOL: named-validation-messages
-
-: init-validation ( -- )
- V{ } clone validation-messages set
- H{ } clone named-validation-messages set ;
-
-: (validation-message) ( obj -- )
- validation-messages get push ;
-
-: (validation-message-for) ( obj name -- )
- named-validation-messages get set-at ;
-
-TUPLE: validation-message message ;
-
-C: <validation-message> validation-message
-
-: validation-message ( string -- )
- <validation-message> (validation-message) ;
-
-: validation-message-for ( string name -- )
- [ <validation-message> ] dip (validation-message-for) ;
-
-TUPLE: validation-error message value ;
-
-C: <validation-error> validation-error
-
-: validation-error ( message -- )
- f <validation-error> (validation-message) ;
-
-: validation-error-for ( message value name -- )
- [ <validation-error> ] dip (validation-message-for) ;
-
-: validation-failed? ( -- ? )
- validation-messages get [ validation-error? ] contains?
- named-validation-messages get [ nip validation-error? ] assoc-contains?
- or ;
-
-: define-validators ( class validators -- )
- >hashtable "validators" set-word-prop ;
-
-: validate ( value name quot -- result )
- '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
-
-: required-values ( assoc -- )
- [ swap [ v-required ] validate drop ] assoc-each ;
-
-: validate-values ( assoc validators -- assoc' )
- swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
-USING: kernel parser sequences words ;
+USING: kernel parser sequences words effects ;
IN: values
: VALUE:
- CREATE-WORD { f } clone [ first ] curry define ; parsing
+ CREATE-WORD { f } clone [ first ] curry
+ (( -- value )) define-declared ; parsing
: set-value ( value word -- )
word-def first set-first ;
! Thanks to Mackenzie Straight for the idea
-USING: compiler.units kernel parser words namespaces
-sequences quotations ;
+USING: kernel parser words namespaces sequences quotations ;
IN: vars
-: define-var-symbol ( str -- ) create-in define-symbol ;
+: define-var-getter ( word -- )
+ [ word-name ">" append create-in ] [ [ get ] curry ] bi
+ (( -- value )) define-declared ;
-: define-var-getter ( str -- )
-dup ">" append create-in swap in get lookup [ get ] curry define ;
+: define-var-setter ( word -- )
+ [ word-name ">" prepend create-in ] [ [ set ] curry ] bi
+ (( value -- )) define-declared ;
-: define-var-setter ( str -- )
-">" over append create-in swap in get lookup [ set ] curry define ;
-
-: define-var ( str -- ) [
-dup define-var-symbol dup define-var-getter define-var-setter
-] with-compilation-unit ;
+: define-var ( str -- )
+ create-in
+ [ define-symbol ]
+ [ define-var-getter ]
+ [ define-var-setter ] tri ;
: VAR: ! var
scan define-var ; parsing
-: define-vars ( seq -- ) [ define-var ] each ;
+: define-vars ( seq -- )
+ [ define-var ] each ;
: VARS: ! vars ...
-";" parse-tokens define-vars ; parsing
+ ";" parse-tokens define-vars ; parsing
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:href="$blogs/posts.atom">Recent Posts</t:atom>
+
+ <t:style t:include="resource:extra/webapps/blogs/blogs.css" />
+
+ <div class="navbar">
+
+ <t:a t:href="$blogs/">All Posts</t:a>
+ | <t:a t:href="$blogs/by">My Posts</t:a>
+ | <t:a t:href="$blogs/new-post">New Post</t:a>
+
+ <t:if t:code="furnace.auth:logged-in?">
+
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+.post-form {
+ border: 2px solid #666;
+ padding: 10px;
+ background: #eee;
+}
+
+.post-title {
+ background-color:#f5f5ff;
+ padding: 3px;
+}
+
+.post-footer {
+ text-align: right;
+ font-size:90%;
+}
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences sorting math.order math.parser
+urls validators db db.types db.tuples calendar present namespaces
+html.forms
+html.components
+http.server.dispatchers
+furnace
+furnace.actions
+furnace.redirection
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.syndication ;
+IN: webapps.blogs
+
+TUPLE: blogs < dispatcher ;
+
+SYMBOL: can-administer-blogs?
+
+can-administer-blogs? define-capability
+
+: view-post-url ( id -- url )
+ present "$blogs/post/" prepend >url ;
+
+: view-comment-url ( parent id -- url )
+ [ view-post-url ] dip >>anchor ;
+
+: list-posts-url ( -- url )
+ "$blogs/" >url ;
+
+: posts-by-url ( author -- url )
+ "$blogs/by/" prepend >url ;
+
+TUPLE: entity id author date content ;
+
+GENERIC: entity-url ( entity -- url )
+
+M: entity feed-entry-url entity-url ;
+
+entity f {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
+ { "date" "DATE" TIMESTAMP +not-null+ }
+ { "content" "CONTENT" TEXT +not-null+ }
+} define-persistent
+
+M: entity feed-entry-date date>> ;
+
+TUPLE: post < entity title comments ;
+
+M: post feed-entry-title
+ [ author>> ] [ title>> ] bi ": " swap 3append ;
+
+M: post entity-url
+ id>> view-post-url ;
+
+\ post "BLOG_POSTS" {
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: <post> ( id -- post ) \ post new swap >>id ;
+
+TUPLE: comment < entity parent ;
+
+comment "COMMENTS" {
+ { "parent" "PARENT" INTEGER +not-null+ } ! post id
+} define-persistent
+
+M: comment feed-entry-title
+ author>> "Comment by " prepend ;
+
+M: comment entity-url
+ [ parent>> ] [ id>> ] bi view-comment-url ;
+
+: <comment> ( parent id -- post )
+ comment new
+ swap >>id
+ swap >>parent ;
+
+: post ( id -- post )
+ [ <post> select-tuple ] [ f <comment> select-tuples ] bi
+ >>comments ;
+
+: reverse-chronological-order ( seq -- sorted )
+ [ [ date>> ] compare invert-comparison ] sort ;
+
+: validate-author ( -- )
+ { { "author" [ v-username ] } } validate-params ;
+
+: list-posts ( -- posts )
+ f <post> "author" value >>author
+ select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
+ reverse-chronological-order ;
+
+: <list-posts-action> ( -- action )
+ <page-action>
+ [ list-posts "posts" set-value ] >>init
+ { blogs "list-posts" } >>template ;
+
+: <list-posts-feed-action> ( -- action )
+ <feed-action>
+ [ "Recent Posts" ] >>title
+ [ list-posts ] >>entries
+ [ list-posts-url ] >>url ;
+
+: <posts-by-action> ( -- action )
+ <page-action>
+
+ "author" >>rest
+
+ [
+ validate-author
+ list-posts "posts" set-value
+ ] >>init
+
+ { blogs "posts-by" } >>template ;
+
+: <posts-by-feed-action> ( -- action )
+ <feed-action>
+ "author" >>rest
+ [ validate-author ] >>init
+ [ "Recent Posts by " "author" value append ] >>title
+ [ list-posts ] >>entries
+ [ "author" value posts-by-url ] >>url ;
+
+: <post-feed-action> ( -- action )
+ <feed-action>
+ "id" >>rest
+ [ validate-integer-id "id" value post "post" set-value ] >>init
+ [ "post" value feed-entry-title ] >>title
+ [ "post" value entity-url ] >>url
+ [ "post" value comments>> ] >>entries ;
+
+: <view-post-action> ( -- action )
+ <page-action>
+
+ "id" >>rest
+
+ [
+ validate-integer-id
+ "id" value post from-object
+
+ "id" value
+ "new-comment" [
+ "parent" set-value
+ ] nest-form
+ ] >>init
+
+ { blogs "view-post" } >>template ;
+
+: validate-post ( -- )
+ {
+ { "title" [ v-one-line ] }
+ { "content" [ v-required ] }
+ } validate-params ;
+
+: <new-post-action> ( -- action )
+ <page-action>
+
+ [
+ validate-post
+ logged-in-user get username>> "author" set-value
+ ] >>validate
+
+ [
+ f <post>
+ dup { "title" "content" } to-object
+ logged-in-user get username>> >>author
+ now >>date
+ [ insert-tuple ] [ entity-url <redirect> ] bi
+ ] >>submit
+
+ { blogs "new-post" } >>template
+
+ <protected>
+ "make a new blog post" >>description ;
+
+: authorize-author ( author -- )
+ logged-in-user get username>> =
+ can-administer-blogs? have-capability? or
+ [ login-required ] unless ;
+
+: do-post-action ( -- )
+ validate-integer-id
+ "id" value <post> select-tuple from-object ;
+
+: <edit-post-action> ( -- action )
+ <page-action>
+
+ "id" >>rest
+
+ [ do-post-action ] >>init
+
+ [ do-post-action validate-post ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
+ [
+ "id" value <post>
+ dup { "title" "author" "date" "content" } to-object
+ [ update-tuple ] [ entity-url <redirect> ] bi
+ ] >>submit
+
+ { blogs "edit-post" } >>template
+
+ <protected>
+ "edit a blog post" >>description ;
+
+: delete-post ( id -- )
+ [ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
+
+: <delete-post-action> ( -- action )
+ <action>
+
+ [ do-post-action ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
+ [
+ [ "id" value delete-post ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
+
+: <delete-author-action> ( -- action )
+ <action>
+
+ [ validate-author ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
+ [
+ [
+ f <post> "author" value >>author select-tuples [ id>> delete-post ] each
+ f f <comment> "author" value >>author delete-tuples
+ ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
+
+: validate-comment ( -- )
+ {
+ { "parent" [ v-integer ] }
+ { "content" [ v-required ] }
+ } validate-params ;
+
+: <new-comment-action> ( -- action )
+ <action>
+
+ [
+ validate-comment
+ logged-in-user get username>> "author" set-value
+ ] >>validate
+
+ [
+ "parent" value f <comment>
+ "content" value >>content
+ logged-in-user get username>> >>author
+ now >>date
+ [ insert-tuple ] [ entity-url <redirect> ] bi
+ ] >>submit
+
+ <protected>
+ "make a comment" >>description ;
+
+: <delete-comment-action> ( -- action )
+ <action>
+
+ [
+ validate-integer-id
+ { { "parent" [ v-integer ] } } validate-params
+ ] >>validate
+
+ [
+ "parent" value <post> select-tuple
+ author>> authorize-author
+ ] >>authorize
+
+ [
+ f "id" value <comment> delete-tuples
+ "parent" value view-post-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a comment" >>description ;
+
+: <blogs> ( -- dispatcher )
+ blogs new-dispatcher
+ <list-posts-action> "" add-responder
+ <list-posts-feed-action> "posts.atom" add-responder
+ <posts-by-action> "by" add-responder
+ <posts-by-feed-action> "by.atom" add-responder
+ <view-post-action> "post" add-responder
+ <post-feed-action> "post.atom" add-responder
+ <new-post-action> "new-post" add-responder
+ <edit-post-action> "edit-post" add-responder
+ <delete-post-action> "delete-post" add-responder
+ <new-comment-action> "new-comment" add-responder
+ <delete-comment-action> "delete-comment" add-responder
+ <boilerplate>
+ { blogs "blogs-common" } >>template ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit: <t:label t:name="title" /></t:title>
+
+ <div class="post-form">
+ <t:form t:action="$blogs/edit-post" t:for="id">
+
+ <p>Title: <t:field t:name="title" t:size="60" /></p>
+ <p><t:textarea t:name="content" t:rows="30" t:cols="80" /></p>
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+ </div>
+
+ <div class="posting-footer">
+ Post by
+ <t:a t:href="$blogs/by" t:rest="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
+ |
+ <t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
+ </div>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recent Posts</t:title>
+
+ <t:bind-each t:name="posts">
+
+ <h2 class="post-title">
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" />
+ </p>
+
+ <div class="posting-footer">
+ Post by
+ <t:a t:href="$blogs/by" t:rest="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="comments" />
+ comments.
+ </t:a>
+ </div>
+
+ </t:bind-each>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New Post</t:title>
+
+ <div class="post-form">
+ <t:form t:action="$blogs/new-post">
+
+ <p>Title: <t:field t:name="title" t:size="60" /></p>
+ <p><t:textarea t:name="content" t:rows="30" t:cols="80" /></p>
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+ </div>
+
+ <t:validation-messages />
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:href="$blogs/by" t:rest="author">
+ Recent Posts by <t:label t:name="author" />
+ </t:atom>
+
+ <t:title>
+ Recent Posts by <t:label t:name="author" />
+ </t:title>
+
+ <t:bind-each t:name="posts">
+
+ <h2 class="post-title">
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" />
+ </p>
+
+ <div class="posting-footer">
+ Post by
+ <t:a t:href="$blogs/by" t:rest="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="comments" />
+ comments.
+ </t:a>
+ </div>
+
+ </t:bind-each>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:href="$blogs/post.atom" t:rest="id">
+ <t:label t:name="author" />: <t:label t:name="title" />
+ </t:atom>
+
+ <t:atom t:href="$blogs/by.atom" t:rest="author">
+ Recent Posts by <t:label t:name="author" />
+ </t:atom>
+
+ <t:title> <t:label t:name="author" />: <t:label t:name="title" /> </t:title>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" />
+ </p>
+
+ <div class="posting-footer">
+ Post by
+ <t:a t:href="$blogs/" t:rest="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
+ |
+ <t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
+ </div>
+
+ <t:bind-each t:name="comments">
+ <hr/>
+
+ <p class="comment-header">
+ <a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
+ </p>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" t:no-follow="true" t:disable-images="true" />
+ </p>
+
+ <t:button t:action="$blogs/delete-comment" t:for="id,parent" class="link-button link">Delete Comment</t:button>
+
+ </t:bind-each>
+
+ <t:bind t:name="new-comment">
+
+ <h2>New Comment</h2>
+
+ <div class="post-form">
+ <t:form t:action="$blogs/new-comment" t:for="parent">
+ <p><t:textarea t:name="content" t:rows="20" t:cols="60" /></p>
+ <p><input type="SUBMIT" value="Done" /></p>
+ </t:form>
+ </div>
+
+ </t:bind>
+
+</t:chloe>
USING: math kernel accessors http.server http.server.dispatchers
-furnace furnace.actions furnace.sessions
-html.components html.templates.chloe
+furnace furnace.actions furnace.sessions furnace.redirection
+html.components html.forms html.templates.chloe
fry urls ;
IN: webapps.counter
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs io.files io.sockets
-io.server
-namespaces db db.sqlite smtp
-http.server
-http.server.dispatchers
-furnace.db
-furnace.flows
-furnace.sessions
-furnace.auth.login
-furnace.auth.providers.db
-furnace.boilerplate
-webapps.pastebin
-webapps.planet
-webapps.todo
-webapps.wiki
-webapps.user-admin ;
-IN: webapps.factor-website
-
-: test-db "resource:test.db" sqlite-db ;
-
-: init-factor-db ( -- )
- test-db [
- init-users-table
- init-sessions-table
-
- init-pastes-table
- init-annotations-table
-
- init-blog-table
- init-postings-table
-
- init-todo-table
-
- init-articles-table
- init-revisions-table
- ] with-db ;
-
-TUPLE: factor-website < dispatcher ;
-
-: <factor-website> ( -- responder )
- factor-website new-dispatcher
- <todo-list> "todo" add-responder
- <pastebin> "pastebin" add-responder
- <planet-factor> "planet" add-responder
- <wiki> "wiki" add-responder
- <user-admin> "user-admin" add-responder
- <login>
- users-in-db >>users
- allow-registration
- allow-password-recovery
- allow-edit-profile
- <boilerplate>
- { factor-website "page" } >>template
- <flows>
- <sessions>
- test-db <db-persistence> ;
-
-: init-factor-website ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
-
- init-factor-db
-
- <factor-website> main-responder set-global ;
-
-: start-factor-website ( -- )
- test-db start-expiring-sessions
- test-db start-update-task
- 8812 httpd ;
+++ /dev/null
-body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
-}
-
-.link-button {
- padding: 0px;
- background: none;
- border: none;
-}
-
-a, .link {
- color: #222;
- border-bottom:1px dotted #666;
- text-decoration:none;
-}
-
-a:hover, .link:hover {
- border-bottom:1px solid #66a;
-}
-
-.error { color: #a00; }
-
-.errors li { color: #a00; }
-
-.field-label {
- text-align: right;
-}
-
-.inline {
- display: inline;
-}
-
-.navbar {
- background-color: #eee;
- padding: 5px;
- border: 1px solid #ccc;
-}
-
-.big-field-label {
- vertical-align: top;
-}
-
-.description {
- padding: 5px;
- color: #000;
-}
-
-.description pre {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
-}
-
-.description p:first-child {
- margin-top: 0px;
-}
-
-.description p:last-child {
- margin-bottom: 0px;
-}
-
-.description table, .description td {
- border-color: #666;
- border-style: solid;
-}
-
-.description table {
- border-width: 0 0 1px 1px;
- border-spacing: 0;
- border-collapse: collapse;
-}
-
-.description td {
- margin: 0;
- padding: 4px;
- border-width: 1px 1px 0 0;
-}
-
+++ /dev/null
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-
- <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <head>
- <t:write-title />
-
- <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
-
- <t:style t:include="resource:extra/webapps/factor-website/page.css" />
-
- <t:write-style />
-
- <t:write-atom />
- </head>
-
- <body>
- <t:call-next-template />
- </body>
-
- </t:chloe>
-
-</html>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="This paste" t:href="$pastebin/paste.atom" t:query="id" />
+ <t:atom t:href="$pastebin/paste.atom" t:query="id">
+ Paste: <t:label t:name="summary" />
+ </t:atom>
<t:title>Paste: <t:label t:name="summary" /></t:title>
<pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
- <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+ <t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
</t:bind-each>
<h2>New Annotation</h2>
- <t:form t:action="$pastebin/new-annotation" t:for="id">
+ <t:form t:action="$pastebin/new-annotation" t:for="parent">
<table>
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
- <tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>
</table>
<input type="SUBMIT" value="Done" />
+
</t:form>
</t:bind>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin" t:href="$pastebin/list.atom" />
+ <t:atom t:href="$pastebin/list.atom">Pastebin</t:atom>
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
-calendar calendar.format math.parser rss urls xml.writer
+calendar calendar.format math.parser syndication urls xml.writer
xmode.catalog validators
+html.forms
html.components
html.templates.chloe
http.server
http.server.redirection
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
-furnace.rss ;
+furnace.syndication ;
IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
! ! !
! DOMAIN MODEL
! ! !
{ "contents" "CONTENTS" TEXT +not-null+ }
} define-persistent
+GENERIC: entity-url ( entity -- url )
+
+M: entity feed-entry-title summary>> ;
+
+M: entity feed-entry-date date>> ;
+
+M: entity feed-entry-url entity-url ;
+
TUPLE: paste < entity annotations ;
\ paste "PASTES" { } define-persistent
swap >>id
swap >>parent ;
-: fetch-annotations ( paste -- paste )
- dup annotations>> [
- dup id>> f <annotation> select-tuples >>annotations
- ] unless ;
-
: paste ( id -- paste )
- <paste> select-tuple fetch-annotations ;
+ [ <paste> select-tuple ]
+ [ f <annotation> select-tuples ]
+ bi >>annotations ;
! ! !
! LINKS, ETC
! ! !
-: pastebin-link ( -- url )
+: pastebin-url ( -- url )
URL" $pastebin/list" ;
-GENERIC: entity-link ( entity -- url )
+: paste-url ( id -- url )
+ "$pastebin/paste" >url swap "id" set-query-param ;
-: paste-link ( id -- url )
- <url>
- "$pastebin/paste" >>path
- swap "id" set-query-param ;
-
-M: paste entity-link
- id>> paste-link ;
+M: paste entity-url
+ id>> paste-url ;
-: annotation-link ( parent id -- url )
- <url>
- "$pastebin/paste" >>path
+: annotation-url ( parent id -- url )
+ "$pastebin/paste" >url
swap number>string >>anchor
swap "id" set-query-param ;
-M: annotation entity-link
- [ parent>> ] [ id>> ] bi annotation-link ;
+M: annotation entity-url
+ [ parent>> ] [ id>> ] bi annotation-url ;
! ! !
! PASTE LIST
[ pastes "pastes" set-value ] >>init
{ pastebin "pastebin" } >>template ;
-: pastebin-feed-entries ( seq -- entries )
- <reversed> 20 short head [
- entry new
- swap
- [ summary>> >>title ]
- [ date>> >>pub-date ]
- [ entity-link adjust-url relative-to-request >>link ]
- tri
- ] map ;
-
-: pastebin-feed ( -- feed )
- feed new
- "Factor Pastebin" >>title
- pastebin-link >>link
- pastes pastebin-feed-entries >>entries ;
-
: <pastebin-feed-action> ( -- action )
- <feed-action> [ pastebin-feed ] >>feed ;
+ <feed-action>
+ [ pastebin-url ] >>url
+ [ "Factor Pastebin" ] >>title
+ [ pastes <reversed> ] >>entries ;
! ! !
! PASTES
"id" value
"new-annotation" [
- "id" set-value
+ "parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
- ] nest-values
+ ] nest-form
] >>init
{ pastebin "paste" } >>template ;
-: paste-feed-entries ( paste -- entries )
- fetch-annotations annotations>> pastebin-feed-entries ;
-
-: paste-feed ( paste -- feed )
- feed new
- swap
- [ "Paste " swap id>> number>string append >>title ]
- [ entity-link adjust-url relative-to-request >>link ]
- [ paste-feed-entries >>entries ]
- tri ;
-
: <paste-feed-action> ( -- action )
<feed-action>
[ validate-integer-id ] >>init
- [ "id" value paste paste-feed ] >>feed ;
+ [ "id" value paste-url ] >>url
+ [ "Paste " "id" value number>string append ] >>title
+ [ "id" value f <annotation> select-tuples ] >>entries ;
: validate-entity ( -- )
{
: deposit-entity-slots ( tuple -- )
now >>date
- { "summary" "author" "mode" "contents" } deposit-slots ;
+ { "summary" "author" "mode" "contents" } to-object ;
: <new-paste-action> ( -- action )
<page-action>
{ pastebin "new-paste" } >>template
- [ mode-names "modes" set-value ] >>validate
-
[
+ mode-names "modes" set-value
validate-entity
+ ] >>validate
+ [
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
- [ id>> paste-link <redirect> ]
+ [ id>> paste-url <redirect> ]
tri
] >>submit ;
: <delete-paste-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
[
- "id" value <paste> delete-tuples
- "id" value f <annotation> delete-tuples
+ [
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ ] with-transaction
URL" $pastebin/list" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities ;
! ! !
! ANNOTATIONS
: <new-annotation-action> ( -- action )
<action>
[
- { { "id" [ v-integer ] } } validate-params
- "id" value paste-link <redirect>
- ] >>display
-
- [
- { { "id" [ v-integer ] } } validate-params
+ mode-names "modes" set-value
+ { { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate
[
- "
id" value f <annotation>
+ "
parent" value f <annotation>
[ deposit-entity-slots ]
[ insert-tuple ]
- [ entity-link <redirect> ]
+ [ entity-url <redirect> ]
tri
] >>submit ;
: <delete-annotation-action> ( -- action )
<action>
+
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
f "id" value <annotation> select-tuple
[ delete-tuples ]
- [ parent>> paste-link <redirect> ]
+ [ parent>> paste-url <redirect> ]
bi
- ] >>submit ;
-
-SYMBOL: can-delete-pastes?
+ ] >>submit
-can-delete-pastes? define-capability
+ <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
- <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+ <delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
- <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
+ <delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
-
-: init-pastes-table \ paste ensure-table ;
-
-: init-annotations-table annotation ensure-table ;
</t:bind-each>
</ul>
- <p>
+ <div>
<t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
| <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
- </p>
+ </div>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <p class="news">
- <strong><t:view t:component="title" /></strong> <br/>
- <t:a value="link" class="more">Read More...</t:a>
- </p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h2 class="posting-title">
- <t:a t:value="link"><t:view t:component="title" /></t:a>
- </h2>
-
- <p class="posting-body">
- <t:view t:component="description" />
- </p>
-
- <p class="posting-date">
- <t:a t:value="link"><t:view t:component="pub-date" /></t:a>
- </p>
-
-</t:chloe>
<t:bind-each t:name="postings">
<p class="news">
- <strong><t:view t:component="title" /></strong> <br/>
+ <strong><t:label t:name="title" /></strong> <br/>
<t:a value="link" class="more">Read More...</t:a>
</p>
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:code="furnace.sessions:uid">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth:logged-in?">
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
+syndication urls xml.writer validators
+html.forms
html.components
-rss urls xml.writer
-validators
http.server
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.boilerplate
furnace.auth.login
furnace.auth
-furnace.rss ;
+furnace.syndication ;
IN: webapps.planet
TUPLE: planet-factor < dispatcher ;
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
- { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
- { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
+ { "www-url" "WWWURL" URL +not-null+ }
+ { "feed-url" "FEEDURL" URL +not-null+ }
} define-persistent
-! TUPLE: posting < entry id ;
-TUPLE: posting id title link description pub-date ;
+TUPLE: posting < entry id ;
posting "POSTINGS"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
- { "link" "LINK" { VARCHAR 256 } +not-null+ }
+ { "url" "LINK" URL +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ }
- { "pub-date" "DATE" TIMESTAMP +not-null+ }
+ { "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
-: init-blog-table blog ensure-table ;
-
-: init-postings-table posting ensure-table ;
-
: <blog> ( id -- todo )
blog new
swap >>id ;
: postings ( -- seq )
posting new select-tuples
- [ [ pub-date>> ] compare invert-comparison ] sort ;
+ [ [ date>> ] compare invert-comparison ] sort ;
: <edit-blogroll-action> ( -- action )
<page-action>
{ planet-factor "planet" } >>template ;
-: planet-feed ( -- feed )
- feed new
- "Planet Factor" >>title
- "http://planet.factorcode.org" >>link
- postings >>entries ;
-
: <planet-feed-action> ( -- action )
- <feed-action> [ planet-feed ] >>feed ;
+ <feed-action>
+ [ "Planet Factor" ] >>title
+ [ URL" $planet-factor" ] >>url
+ [ postings ] >>entries ;
:: <posting> ( entry name -- entry' )
posting new
name ": " entry title>> 3append >>title
- entry link>> >>link
+ entry url>> >>url
entry description>> >>description
- entry pub-date>> >>pub-date ;
+ entry date>> >>date ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
[ '[ , <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ pub-date>> ] compare invert-comparison ] sort ;
+ [ [ date>> ] compare invert-comparison ] sort ;
: update-cached-postings ( -- )
blogroll fetch-blogroll sort-entries 8 short head [
} validate-params ;
: deposit-blog-slots ( blog -- )
- { "name" "www-url" "feed-url" } deposit-slots ;
+ { "name" "www-url" "feed-url" } to-object ;
: <new-blog-action> ( -- action )
<page-action>
+
{ planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
]
tri
] >>submit ;
-
+
: <edit-blog-action> ( -- action )
<page-action>
+
[
validate-integer-id
"id" value <blog> select-tuple from-object
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder
- <delete-blog-action> "delete-blog" add-responder ;
-
-SYMBOL: can-administer-planet-factor?
-
-can-administer-planet-factor? define-capability
+ <delete-blog-action> "delete-blog" add-responder
+ <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities ;
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
- <feed-action> "feed.xml" add-responder
- <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+ <planet-feed-action> "feed.xml" add-responder
+ <planet-factor-admin> "admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;
<t:bind-each t:name="postings">
<h2 class="posting-title">
- <t:a t:value="link"><t:label t:name="title" /></t:a>
+ <t:a t:value="url"><t:label t:name="title" /></t:a>
</h2>
<p class="posting-body">
</p>
<p class="posting-date">
- <t:a t:value="link"><t:label t:name="pub-date" /></t:a>
+ <t:a t:value="url"><t:label t:name="date" /></t:a>
</p>
</t:bind-each>
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
db db.types db.tuples validators hashtables urls
+html.forms
html.components
html.templates.chloe
http.server
http.server.dispatchers
furnace
-furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
+furnace.redirection
furnace.db
furnace.auth.login ;
IN: webapps.todo
{ "description" "DESCRIPTION" { VARCHAR 256 } }
} define-persistent
-: init-todo-table todo ensure-table ;
-
: <todo> ( id -- todo )
todo new
swap >>id
- uid >>uid ;
+ logged-in-user get username>> >>uid ;
: <view-action> ( -- action )
<page-action>
{ "description" [ v-required ] }
} validate-params ;
+: view-todo-url ( id -- url )
+ <url> "$todo-list/view" >>path swap "id" set-query-param ;
+
: <new-action> ( -- action )
<page-action>
[ 0 "priority" set-value ] >>init
[
f <todo>
- dup { "summary" "priority" "description" } deposit-slots
- [ insert-tuple ]
- [
- <url>
- "$todo-list/view" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
- bi
+ dup { "summary" "priority" "description" } to-object
+ [ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
: <edit-action> ( -- action )
[
f <todo>
- dup { "id" "summary" "priority" "description" } deposit-slots
- [ update-tuple ]
- [
- <url>
- "$todo-list/view" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
- bi
+ dup { "id" "summary" "priority" "description" } to-object
+ [ update-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
+: todo-list-url ( -- url )
+ URL" $todo-list/list" ;
+
: <delete-action> ( -- action )
<action>
[ validate-integer-id ] >>validate
[
"id" get <todo> delete-tuples
- URL" $todo-list/list" <redirect>
+ todo-list-url <redirect>
] >>submit ;
: <list-action> ( -- action )
<delete-action> "delete" add-responder
<boilerplate>
{ todo-list "todo" } >>template
- f <protected> ;
+ <protected>
+ "view your todo list" >>description ;
<t:a t:href="$todo-list/list">List Items</t:a>
| <t:a t:href="$todo-list/new">Add Item</t:a>
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
</table>
<p>
- <button type="submit" class="link-button link">Update</button>
+ <button type="submit" >Update</button>
<t:validation-messages />
</p>
</t:form>
- <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
+ <t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
</t:chloe>
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
+html.forms
html.elements
html.components
furnace
furnace.auth.providers.db
furnace.auth.login
furnace.auth
-furnace.sessions
furnace.actions
+furnace.redirection
+furnace.utilities
http.server
http.server.dispatchers ;
IN: webapps.user-admin
TUPLE: user-admin < dispatcher ;
-: word>string ( word -- string )
- [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
-
-: words>strings ( seq -- seq' )
- [ word>string ] map ;
-
-: string>word ( string -- word )
- ":" split1 swap lookup ;
-
-: strings>words ( seq -- seq' )
- [ string>word ] map ;
-
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
: init-capabilities ( -- )
capabilities get words>strings "capabilities" set-value ;
-: selected-capabilities ( -- seq )
+: validate-capabilities ( -- )
"capabilities" value
- [ param empty? not ] filter
- [ string>word ] map ;
+ [ [ param empty? not ] keep set-value ] each ;
+
+: selected-capabilities ( -- seq )
+ "capabilities" value [ value ] filter [ string>word ] map ;
+
+: validate-user ( -- )
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params ;
: <new-user-action> ( -- action )
<page-action>
[
init-capabilities
+ validate-capabilities
+
+ validate-user
{
- { "username" [ v-username ] }
- { "realname" [ v-one-line ] }
{ "new-password" [ v-password ] }
{ "verify-password" [ v-password ] }
- { "email" [ [ v-email ] v-optional ] }
- { "capabilities" [ ] }
} validate-params
same-password-twice
: validate-username ( -- )
{ { "username" [ v-username ] } } validate-params ;
+: select-capabilities ( seq -- )
+ [ t swap word>string set-value ] each ;
+
: <edit-user-action> ( -- action )
<page-action>
[
validate-username
"username" value <user> select-tuple
- [ from-object ]
- [ capabilities>> [ "true" swap word>string set-value ] each ] bi
+ [ from-object ] [ capabilities>> select-capabilities ] bi
- capabilities get words>strings "capabilities" set-value
+ init-capabilities
] >>init
{ user-admin "edit-user" } >>template
[
+ "username" value <user> select-tuple
+ [ from-object ] [ capabilities>> select-capabilities ] bi
+
init-capabilities
+ validate-capabilities
+
+ validate-user
{
- { "username" [ v-username ] }
- { "realname" [ v-one-line ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
- { "email" [ [ v-email ] v-optional ] }
} validate-params
"new-password" "verify-password"
<action>
[
validate-username
-
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
+ "username" value <user> delete-tuples
URL" $user-admin" <redirect>
] >>submit ;
<delete-user-action> "delete" add-responder
<boilerplate>
{ user-admin "user-admin" } >>template
- { can-administer-users? } <protected> ;
+ <protected>
+ "administer users" >>description
+ { can-administer-users? } >>capabilities ;
: make-admin ( username -- )
<user>
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:form t:action="$wee-url">
+ <p>Shorten URL: <t:field t:name="url" t:size="40" /></p>
+ <input type="submit" value="Shorten" />
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <p>The URL:</p>
+ <blockquote><t:link t:name="url" /></blockquote>
+ <p>has been shortened to:</p>
+ <blockquote><t:link t:name="short" /></blockquote>
+ <p>enjoy!</p>
+
+</t:chloe>
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.ranges sequences random accessors combinators.lib
+kernel namespaces fry db.types db.tuples urls validators
+html.components html.forms http http.server.dispatchers furnace
+furnace.actions furnace.boilerplate furnace.redirection ;
+IN: webapps.wee-url
+
+TUPLE: wee-url < dispatcher ;
+
+TUPLE: short-url short url ;
+
+short-url "SHORT_URLS" {
+ { "short" "SHORT" TEXT +user-assigned-id+ }
+ { "url" "URL" TEXT +not-null+ }
+} define-persistent
+
+: letter-bank ( -- seq )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 1 CHAR: 0 [a,b]
+ 3append ; foldable
+
+: random-url ( -- string )
+ 1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
+
+: insert-short-url ( short-url -- short-url )
+ '[ , dup random-url >>short insert-tuple ] 10 retry ;
+
+: shorten ( url -- short )
+ short-url new swap >>url dup select-tuple
+ [ ] [ insert-short-url ] ?if short>> ;
+
+: short>url ( short -- url )
+ "$wee-url/go/" prepend >url adjust-url ;
+
+: expand-url ( string -- url )
+ short-url new swap >>short select-tuple url>> ;
+
+: <shorten-action> ( -- action )
+ <page-action>
+ { wee-url "shorten" } >>template
+ [ { { "url" [ v-url ] } } validate-params ] >>validate
+ [
+ "$wee-url/show/" "url" value shorten append >url <redirect>
+ ] >>submit ;
+
+: <show-action> ( -- action )
+ <page-action>
+ "short" >>rest
+ [
+ { { "short" [ v-one-word ] } } validate-params
+ "short" value expand-url "url" set-value
+ "short" value short>url "short" set-value
+ ] >>init
+ { wee-url "show" } >>template ;
+
+: <go-action> ( -- action )
+ <action>
+ "short" >>rest
+ [ { { "short" [ v-one-word ] } } validate-params ] >>init
+ [ "short" value expand-url <redirect> ] >>display ;
+
+: <wee-url> ( -- wee-url )
+ wee-url new-dispatcher
+ <shorten-action> "" add-responder
+ <show-action> "show" add-responder
+ <go-action> "go" add-responder
+ <boilerplate>
+ { wee-url "wee-url" } >>template ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>WeeURL!</t:title>
+
+ <div class="navbar"><t:a t:href="$wee-url">Shorten URL</t:a></div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
<ul>
<t:bind-each t:name="articles">
<li>
- <t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+ <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
</li>
</t:bind-each>
</ul>
<t:title>Recent Changes</t:title>
- <ul>
- <t:bind-each t:name="changes">
- <li>
- <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
- on
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
- by
- <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
- </li>
- </t:bind-each>
- </ul>
+ <div class="revisions">
+
+ <table>
+
+ <tr>
+ <th>Article</th>
+ <th>Date</th>
+ <th>By</th>
+ </tr>
+
+ <t:bind-each t:name="changes">
+ <tr>
+ <td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
+ <td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
+ <td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
+ </tr>
+ </t:bind-each>
+
+ </table>
+
+ </div>
</t:chloe>
<tr>
<th class="field-label">Old revision:</th>
<t:bind t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
<tr>
<th class="field-label">New revision:</th>
<t:bind t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
</table>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/revisions.atom" t:rest="title">
+ Revisions of <t:label t:name="title" />
+ </t:atom>
+
<t:call-next-template />
<div class="navbar">
- <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
- | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
- | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ <t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div>
<table>
<tr>
<th>Revision</th>
- <th>Author</th>
+ <th>By</th>
<th>Rollback</th>
</tr>
<t:bind-each t:name="revisions">
<tr>
- <td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
- <td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
- <td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
+ <td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
+ <td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
+ <td> <t:button t:action="$wiki/rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr>
</t:bind-each>
</table>
<h2>View Differences</h2>
- <form action="diff" method="get">
+ <t:form t:action="$wiki/diff" t:method="get">
<table>
<tr>
<th class="field-label">Old revision:</th>
</table>
<input type="submit" value="View" />
- </form>
+ </t:form>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/user-edits.atom" t:rest="author">
+ Edits by <t:label t:name="author" />
+ </t:atom>
+
<t:title>Edits by <t:label t:name="author" /></t:title>
<ul>
<t:bind-each t:name="user-edits">
<li>
- <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+ <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
on
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
</li>
</t:bind-each>
</ul>
<t:farkup t:name="content" />
</div>
- <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
+ <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/changes.atom">
+ Recent Changes
+ </t:atom>
+
<t:style t:include="resource:extra/webapps/wiki/wiki.css" />
<div class="navbar">
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
<h1><t:write-title /></h1>
- <t:call-next-template />
+ <table width="100%">
+ <tr>
+ <td> <t:call-next-template /> </td>
+ <t:if t:value="sidebar">
+ <td valign="top">
+ <t:bind t:name="sidebar">
+ <h2>
+ <t:a t:href="$wiki/view" t:query="title">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <t:farkup t:name="content" />
+ </t:bind>
+ </td>
+ </t:if>
+ </tr>
+ </table>
</t:chloe>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
-namespaces splitting sequences sorting math.order
-html.components
+namespaces splitting sequences sorting math.order present
+syndication
+html.components html.forms
http.server
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
+furnace.syndication
validators
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
+: wiki-url ( rest path -- url )
+ [ "$wiki/" % % "/" % % ] "" make
+ <url> swap >>path ;
+
+: view-url ( title -- url ) "view" wiki-url ;
+
+: edit-url ( title -- url ) "edit" wiki-url ;
+
+: revisions-url ( title -- url ) "revisions" wiki-url ;
+
+: revision-url ( id -- url ) "revision" wiki-url ;
+
+: user-edits-url ( author -- url ) "user-edits" wiki-url ;
+
TUPLE: wiki < dispatcher ;
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
TUPLE: article title revision ;
article "ARTICLES" {
{ "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
- ! { "AUTHOR" INTEGER +not-null+ } ! uid
- ! { "PROTECTED" BOOLEAN +not-null+ }
{ "revision" "REVISION" INTEGER +not-null+ } ! revision id
} define-persistent
: <article> ( title -- article ) article new swap >>title ;
-: init-articles-table article ensure-table ;
-
TUPLE: revision id title author date content ;
revision "REVISIONS" {
{ "content" "CONTENT" TEXT +not-null+ }
} define-persistent
+M: revision feed-entry-title
+ [ title>> ] [ drop " by " ] [ author>> ] tri 3append ;
+
+M: revision feed-entry-date date>> ;
+
+M: revision feed-entry-url id>> revision-url ;
+
+: reverse-chronological-order ( seq -- sorted )
+ [ [ date>> ] compare invert-comparison ] sort ;
+
: <revision> ( id -- revision )
revision new swap >>id ;
-: init-revisions-table revision ensure-table ;
-
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
+: validate-author ( -- )
+ { { "author" [ v-username ] } } validate-params ;
+
: <main-article-action> ( -- action )
<action>
- [
- <url>
- "$wiki/view" >>path
- "Front Page" "title" set-query-param
- <redirect>
- ] >>display ;
+ [ "Front Page" view-url <redirect> ] >>display ;
+
+: latest-revision ( title -- revision/f )
+ <article> select-tuple
+ dup [ revision>> <revision> select-tuple ] when ;
: <view-article-action> ( -- action )
<action>
- "title" >>rest-param
+
+ "title" >>rest
[
validate-title
- "view?title=" relative-link-prefix set
] >>init
[
- "title" value dup <article> select-tuple [
- revision>> <revision> select-tuple from-object
+ "title" value dup latest-revision [
+ from-object
{ wiki "view" } <chloe-content>
] [
- <url>
- "$wiki/edit" >>path
- swap "title" set-query-param
- <redirect>
+ edit-url <redirect>
] ?if
] >>display ;
: <view-revision-action> ( -- action )
<page-action>
+
+ "id" >>rest
+
[
- { { "id" [ v-integer ] } } validate-params
+ validate-integer-id
"id" value <revision>
select-tuple from-object
+ URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
{ wiki "view" } >>template ;
+: amend-article ( revision article -- )
+ swap id>> >>revision update-tuple ;
+
+: add-article ( revision -- )
+ [ title>> ] [ id>> ] bi article boa insert-tuple ;
+
: add-revision ( revision -- )
[ insert-tuple ]
[
- dup title>> <article> select-tuple [
- swap id>> >>revision update-tuple
- ] [
- [ title>> ] [ id>> ] bi article boa insert-tuple
- ] if*
+ dup title>> <article> select-tuple
+ [ amend-article ] [ add-article ] if*
] bi ;
: <edit-article-action> ( -- action )
<page-action>
+
+ "title" >>rest
+
[
validate-title
"title" value <article> select-tuple [
] >>init
{ wiki "edit" } >>template
-
+
[
validate-title
{ { "content" [ v-required ] } } validate-params
now >>date
logged-in-user get username>> >>author
"content" value >>content
- [ add-revision ]
- [
- <url>
- "$wiki/view" >>path
- swap title>> "title" set-query-param
- <redirect>
- ] bi
- ] >>submit ;
+ [ add-revision ] [ title>> view-url <redirect> ] bi
+ ] >>submit
+
+ <protected>
+ "edit wiki articles" >>description ;
+
+: list-revisions ( -- seq )
+ f <revision> "title" value >>title select-tuples
+ reverse-chronological-order ;
: <list-revisions-action> ( -- action )
<page-action>
+
+ "title" >>rest
+
[
validate-title
- f <revision> "title" value >>title select-tuples
- [ [ date>> ] compare invert-comparison ] sort
- "revisions" set-value
+ list-revisions "revisions" set-value
] >>init
{ wiki "revisions" } >>template ;
+: <list-revisions-feed-action> ( -- action )
+ <feed-action>
+
+ "title" >>rest
+
+ [ validate-title ] >>init
+
+ [ "Revisions of " "title" value append ] >>title
+
+ [ "title" value revisions-url ] >>url
+
+ [ list-revisions ] >>entries ;
+
: <rollback-action> ( -- action )
<action>
- [
- { { "id" [ v-integer ] } } validate-params
- ] >>validate
-
+
+ [ validate-integer-id ] >>validate
+
[
"id" value <revision> select-tuple clone f >>id
- [ add-revision ]
- [
- <url>
- "$wiki/view" >>path
- swap title>> "title" set-query-param
- <redirect>
- ] bi
+ [ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
+: list-changes ( -- seq )
+ f <revision> select-tuples
+ reverse-chronological-order ;
+
: <list-changes-action> ( -- action )
<page-action>
- [
- f <revision> select-tuples
- [ [ date>> ] compare invert-comparison ] sort
- "changes" set-value
- ] >>init
-
+ [ list-changes "changes" set-value ] >>init
{ wiki "changes" } >>template ;
+: <list-changes-feed-action> ( -- action )
+ <feed-action>
+ [ URL" $wiki/changes" ] >>url
+ [ "All changes" ] >>title
+ [ list-changes ] >>entries ;
+
: <delete-action> ( -- action )
<action>
+
[ validate-title ] >>validate
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
URL" $wiki" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities ;
: <diff-action> ( -- action )
<page-action>
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
[
- [ [ title>> "title" set-value ] [ "old" set-value ] bi ]
- [ "new" set-value ] bi*
+ [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ]
+ [ "new" [ from-object ] nest-form ] bi*
]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
: <list-articles-action> ( -- action )
<page-action>
+
[
f <article> select-tuples
[ [ title>> ] compare ] sort
{ wiki "articles" } >>template ;
+: list-user-edits ( -- seq )
+ f <revision> "author" value >>author select-tuples
+ reverse-chronological-order ;
+
: <user-edits-action> ( -- action )
<page-action>
+
+ "author" >>rest
+
[
- { { "author" [ v-username ] } } validate-params
- f <revision> "author" value >>author
- select-tuples "user-edits" set-value
+ validate-author
+ list-user-edits "user-edits" set-value
] >>init
{ wiki "user-edits" } >>template ;
+: <user-edits-feed-action> ( -- action )
+ <feed-action>
+ "author" >>rest
+ [ validate-author ] >>init
+ [ "Edits by " "author" value append ] >>title
+ [ "author" value user-edits-url ] >>url
+ [ list-user-edits ] >>entries ;
+
+: <article-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { wiki "page-common" } >>template ;
+
+: init-sidebar ( -- )
+ "Sidebar" latest-revision [
+ "sidebar" [ from-object ] nest-form
+ ] when* ;
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
- <dispatcher>
- <main-article-action> "" add-responder
- <view-article-action> "view" add-responder
- <view-revision-action> "revision" add-responder
- <list-revisions-action> "revisions" add-responder
- <diff-action> "diff" add-responder
- <edit-article-action> { } <protected> "edit" add-responder
- <boilerplate>
- { wiki "page-common" } >>template
- >>default
+ <main-article-action> <article-boilerplate> "" add-responder
+ <view-article-action> <article-boilerplate> "view" add-responder
+ <view-revision-action> <article-boilerplate> "revision" add-responder
+ <list-revisions-action> <article-boilerplate> "revisions" add-responder
+ <list-revisions-feed-action> "revisions.atom" add-responder
+ <diff-action> <article-boilerplate> "diff" add-responder
+ <edit-article-action> <article-boilerplate> "edit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
- <delete-action> { } <protected> "delete" add-responder
+ <user-edits-feed-action> "user-edits.atom" add-responder
+ <list-changes-feed-action> "changes.atom" add-responder
+ <delete-action> "delete" add-responder
<boilerplate>
+ [ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs io.files io.sockets
+io.sockets.secure io.servers.connection
+namespaces db db.tuples db.sqlite smtp urls
+logging.insomniac
+http.server
+http.server.dispatchers
+http.server.redirection
+furnace.alloy
+furnace.auth.login
+furnace.auth.providers.db
+furnace.auth.features.edit-profile
+furnace.auth.features.recover-password
+furnace.auth.features.registration
+furnace.auth.features.deactivate-user
+furnace.boilerplate
+furnace.redirection
+webapps.blogs
+webapps.pastebin
+webapps.planet
+webapps.todo
+webapps.wiki
+webapps.wee-url
+webapps.user-admin ;
+IN: websites.concatenative
+
+: test-db ( -- db params ) "resource:test.db" sqlite-db ;
+
+: init-factor-db ( -- )
+ test-db [
+ init-furnace-tables
+
+ {
+ post comment
+ paste annotation
+ blog posting
+ todo
+ short-url
+ article revision
+ } ensure-tables
+ ] with-db ;
+
+TUPLE: factor-website < dispatcher ;
+
+: <factor-website> ( -- responder )
+ factor-website new-dispatcher
+ <blogs> "blogs" add-responder
+ <todo-list> "todo" add-responder
+ <pastebin> "pastebin" add-responder
+ <planet-factor> "planet" add-responder
+ <wiki> "wiki" add-responder
+ <wee-url> "wee-url" add-responder
+ <user-admin> "user-admin" add-responder
+ URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
+ "Factor website" <login-realm>
+ "Factor website" >>name
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ allow-deactivation
+ <boilerplate>
+ { factor-website "page" } >>template
+ test-db <alloy> ;
+
+: init-factor-website ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "noreply@concatenative.org" lost-password-from set-global
+ "website@concatenative.org" insomniac-sender set-global
+ "slava@factorcode.org" insomniac-recipients set-global
+ init-factor-db
+ <factor-website> main-responder set-global ;
+
+: <factor-secure-config> ( -- config )
+ <secure-config>
+ "resource:extra/openssl/test/server.pem" >>key-file
+ "resource:extra/openssl/test/dh1024.pem" >>dh-file
+ "password" >>password ;
+
+: <factor-website-server> ( -- threaded-server )
+ <http-server>
+ <factor-secure-config> >>secure-config
+ 8080 >>insecure
+ 8431 >>secure ;
+
+: start-factor-website ( -- )
+ test-db start-expiring
+ test-db start-update-task
+ http-insomniac
+ <factor-website-server> start-server ;
--- /dev/null
+body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+}
+
+.link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+}
+
+a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+}
+
+a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+}
+
+.error { color: #a00; }
+
+.errors li { color: #a00; }
+
+.field-label {
+ text-align: right;
+}
+
+.inline {
+ display: inline;
+}
+
+.navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+}
+
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ padding: 5px;
+ color: #000;
+}
+
+.description pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+}
+
+.description p:first-child {
+ margin-top: 0px;
+}
+
+.description p:last-child {
+ margin-bottom: 0px;
+}
+
+.description table, .description td {
+ border-color: #666;
+ border-style: solid;
+}
+
+.description table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.description td {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head>
+ <t:write-title />
+
+ <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
+
+ <t:style t:include="resource:extra/websites/concatenative/page.css" />
+
+ <t:write-style />
+
+ <t:write-atom />
+ </head>
+
+ <body>
+ <t:call-next-template />
+ </body>
+
+ </t:chloe>
+
+</html>
-USING: alien.syntax kernel math windows.types math.bitfields ;
+USING: alias alien.syntax kernel math windows.types math.bitfields ;
IN: windows.advapi32
LIBRARY: advapi32
: TOKEN_QUERY HEX: 0008 ; inline
: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
+: TOKEN_READ ( -- n ) STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
-: TOKEN_WRITE
+: TOKEN_WRITE ( -- n )
{
STANDARD_RIGHTS_WRITE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_DEFAULT
} flags ; foldable
-: TOKEN_ALL_ACCESS
+: TOKEN_ALL_ACCESS ( -- n )
{
STANDARD_RIGHTS_REQUIRED
TOKEN_ASSIGN_PRIMARY
DWORD dwProvType,
DWORD dwFlags ) ;
-: CryptAcquireContext CryptAcquireContextW ;
+ALIAS: CryptAcquireContext CryptAcquireContextW
+
! : CryptContextAddRef ;
! : CryptCreateHash ;
! : CryptDecrypt ;
! : GetUserNameA ;
FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;
-: GetUserName GetUserNameW ;
+ALIAS: GetUserName GetUserNameW
! : GetWindowsAccountDomainSid ;
! : I_ScIsSecurityProcess ;
FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,
LPCTSTR lpName,
PLUID lpLuid ) ;
-: LookupPrivilegeValue LookupPrivilegeValueW ;
+ALIAS: LookupPrivilegeValue LookupPrivilegeValueW
! : LookupSecurityDescriptorPartsA ;
! : LookupSecurityDescriptorPartsW ;
USING: kernel windows.com windows.com.syntax windows.ole32
alien alien.syntax tools.test libc alien.c-types arrays.lib
namespaces arrays continuations accessors math windows.com.wrapper
-windows.com.wrapper.private destructors ;
+windows.com.wrapper.private destructors effects ;
IN: windows.com.tests
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test
+{ (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test
+{ (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test
+{ (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test
+{ (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test
+{ (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test
+
SYMBOL: +test-wrapper+
SYMBOL: +guinea-pig-implementation+
SYMBOL: +orig-wrapped-objects+
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
- 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
+ 20 1array [
+ +guinea-pig-implementation+ get
+ [ 20 IInherited::setX ]
+ [ IInherited::getX ] bi
+ ] unit-test
420 1array [
+guinea-pig-implementation+ get
IUnrelated-iid com-query-interface
USING: alien alien.c-types windows.com.syntax windows.ole32\r
-windows.types continuations kernel alien.syntax ;\r
+windows.types continuations kernel alien.syntax libc ;\r
IN: windows.com\r
\r
LIBRARY: ole32\r
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;\r
\r
: com-query-interface ( interface iid -- interface' )\r
- f <void*>\r
- [ IUnknown::QueryInterface ole32-error ] keep\r
- *void* ;\r
+ "void*" heap-size [\r
+ [ IUnknown::QueryInterface ole32-error ] keep *void*\r
+ ] with-malloc ;\r
\r
: com-add-ref ( interface -- interface )\r
[ IUnknown::AddRef drop ] keep ; inline\r
-USING: alien alien.c-types kernel windows.ole32 combinators.lib
-parser splitting sequences.lib sequences namespaces assocs
-quotations shuffle accessors words macros alien.syntax fry ;
+USING: alien alien.c-types effects kernel windows.ole32 combinators.lib
+parser splitting grouping sequences.lib sequences namespaces
+assocs quotations shuffle accessors words macros alien.syntax
+fry arrays ;
IN: windows.com.syntax
<PRIVATE
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
- [ 3 tail 2 group [ first ] map "void*" prefix ]
+ [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
tri
<com-function-definition> ;
dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ;
+: (invocation-quot) ( function return parameters -- quot )
+ [ first ] map [ com-invoke ] 3curry ;
+
+: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
+ swap
+ [ [ second ] map ]
+ [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
+ <effect> ;
+
: (define-word-for-function) ( function interface n -- )
-rot [ (function-word) swap ] 2keep drop
{ return>> parameters>> } get-slots
- [ com-invoke ] 3curry
- define ;
+ [ (invocation-quot) ] 2keep
+ (stack-effect-from-return-and-parameters)
+ define-declared ;
: define-words-for-com-interface ( definition -- )
- [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
+ [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
[ name>> "com-interface" swap typedef ]
[
dup family-tree-functions
USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
-sequences.lib namespaces windows.ole32 libc
+sequences.lib namespaces windows.ole32 libc vocabs
assocs accessors arrays sequences quotations combinators
-math combinators.lib words compiler.units destructors ;
+math combinators.lib words compiler.units destructors fry
+math.parser ;
IN: windows.com.wrapper
-TUPLE: com-wrapper vtbls freed? ;
+TUPLE: com-wrapper vtbls disposed ;
<PRIVATE
[ H{ } +wrapped-objects+ set-global ]
unless
+SYMBOL: +vtbl-counter+
++vtbl-counter+ get-global
+[ 0 +vtbl-counter+ set-global ]
+unless
+
+"windows.com.wrapper.callbacks" create-vocab drop
+
+: (next-vtbl-counter) ( -- n )
+ +vtbl-counter+ [ 1+ dup ] change ;
+
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
[ "invalid COM wrapping pointer" throw ] unless ;
[ +wrapped-objects+ get-global delete-at ] keep
free ;
-: (make-query-interface) ( interfaces -- quot )
+: (query-interface-cases) ( interfaces -- cases )
[
- [ swap 16 memory>byte-array ] %
+ [ find-com-interface-definition family-tree [ iid>> ] map ] dip
+ 1quotation [ 2array ] curry map
+ ] map-index concat
+ [ drop f ] suffix ;
+
+: (make-query-interface) ( interfaces -- quot )
+ (query-interface-cases)
+ '[
+ swap 16 memory>byte-array
+ , case
[
- >r find-com-interface-definition family-tree
- r> 1quotation [ >r iid>> r> 2array ] curry map
- ] map-index concat
- [ f ] suffix ,
- \ case ,
- "void*" heap-size
- [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
- curry ,
- [ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
- \ if* ,
- ] [ ] make ;
+ "void*" heap-size * rot <displaced-alien> com-add-ref
+ 0 rot set-void*-nth S_OK
+ ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
+ ] ;
: (make-add-ref) ( interfaces -- quot )
- length "void*" heap-size * [ swap <displaced-alien>
+ length "void*" heap-size * '[
+ , swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
- ] curry ;
+ ] ;
: (make-release) ( interfaces -- quot )
- length "void*" heap-size * [ over <displaced-alien>
+ length "void*" heap-size * '[
+ , over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
- ] curry ;
+ ] ;
: (make-iunknown-methods) ( interfaces -- quots )
[ (make-query-interface) ]
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
- [ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
+ [ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
if ;
-: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
- [ [ swap 2array ] curry map swap ] keep
- [ com-unwrap ] compose [ swap 2array ] curry map append ;
+: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
+ [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
+ [ '[ , [ swap 2array ] curry map ] ] bi bi*
+ swap append ;
-: compile-alien-callback ( return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- alien )
[ alien-callback ] 4 ncurry
- [ gensym [ swap define ] keep ] with-compilation-unit
+ [ [ (( -- alien )) define-declared ] pick slip ]
+ with-compilation-unit
execute ;
-: (make-vtbl) ( interface-name quots iunknown-methods n -- )
+: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+ [ byte-length malloc ] [ over byte-array>memory ] bi ;
+
+: (callback-word) ( function-name interface-name counter -- word )
+ [ "::" rot 3append "-callback-" ] dip number>string 3append
+ "windows.com.wrapper.callbacks" create ;
+
+: (finish-thunk) ( param-count thunk quot -- thunked-quot )
+ [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
+ dip compose ;
+
+: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
(thunk) (thunked-quots)
- swap find-com-interface-definition family-tree-functions [
- { return>> parameters>> } get-slots
- dup length 1- roll [
- first dup empty?
- [ 2drop [ ] ]
- [ swap [ ndip ] 2curry ]
- if
- ] [ second ] bi compose
+ swap [ find-com-interface-definition family-tree-functions ]
+ keep (next-vtbl-counter) '[
+ swap [
+ [ name>> , , (callback-word) ]
+ [ return>> ] [
+ parameters>>
+ [ [ first ] map ]
+ [ length ] bi
+ ] tri
+ ] [
+ first2 (finish-thunk)
+ ] bi*
"stdcall" swap compile-alien-callback
- ] 2map >c-void*-array [ byte-length malloc ] keep
- over byte-array>memory ;
+ ] 2map >c-void*-array
+ (byte-array-to-malloced-buffer) ;
: (make-vtbls) ( implementations -- vtbls )
dup [ first ] map (make-iunknown-methods)
: <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper boa ;
-M: com-wrapper dispose
- t >>freed?
+M: com-wrapper dispose*
vtbls>> [ free ] each ;
: com-wrap ( object wrapper -- wrapped-object )
- dup (malloc-wrapped-object) >r vtbls>> r>
+ [ vtbls>> ] [ (malloc-wrapped-object) ] bi
[ [ set-void*-nth ] curry each-index ] keep
[ +wrapped-objects+ get-global set-at ] keep ;
! FUNCTION: AbortDoc
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types ;
+USING: alien alien.syntax kernel windows.types alias ;
IN: windows.gdi32
! Stock Logical Objects
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types ;
+USING: alien alien.syntax kernel windows.types alias ;
IN: windows.kernel32
: MAX_PATH 260 ; inline
! FUNCTION: CopyFileExA
! FUNCTION: CopyFileExW
FUNCTION: BOOL CopyFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName, BOOL bFailIfExists ) ;
-: CopyFile CopyFileW ; inline
+ALIAS: CopyFile CopyFileW
! FUNCTION: CopyLZFile
! FUNCTION: CreateActCtxA
! FUNCTION: CreateActCtxW
! FUNCTION: CreateDirectoryExA
! FUNCTION: CreateDirectoryExW
FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ;
-: CreateDirectory CreateDirectoryW ; inline
+ALIAS: CreateDirectory CreateDirectoryW
! FUNCTION: CreateEventA
! FUNCTION: CreateEventW
FUNCTION: HANDLE CreateFileW ( LPCTSTR lpFileName, DWORD dwDesiredAccess, DWORD dwShareMode, LPSECURITY_ATTRIBUTES lpSecurityAttribures, DWORD dwCreationDisposition, DWORD dwFlagsAndAttributes, HANDLE hTemplateFile ) ;
-: CreateFile CreateFileW ; inline
+ALIAS: CreateFile CreateFileW
FUNCTION: HANDLE CreateFileMappingW ( HANDLE hFile,
LPSECURITY_ATTRIBUTES lpAttributes,
DWORD dwMaximumSizeHigh,
DWORD dwMaximumSizeLow,
LPCTSTR lpName ) ;
-: CreateFileMapping CreateFileMappingW ;
+ALIAS: CreateFileMapping CreateFileMappingW
! FUNCTION: CreateHardLinkA
! FUNCTION: CreateHardLinkW
! FUNCTION: CreateMutexW
! FUNCTION: CreateNamedPipeA
FUNCTION: HANDLE CreateNamedPipeW ( LPCTSTR lpName, DWORD dwOpenMode, DWORD dwPipeMode, DWORD nMaxInstances, DWORD nOutBufferSize, DWORD nInBufferSize, DWORD nDefaultTimeOut, LPSECURITY_ATTRIBUTES lpSecurityAttributes ) ;
-: CreateNamedPipe CreateNamedPipeW ;
+ALIAS: CreateNamedPipe CreateNamedPipeW
! FUNCTION: CreateNlsSecurityDescriptor
FUNCTION: BOOL CreatePipe ( PHANDLE hReadPipe, PHANDLE hWritePipe, LPSECURITY_ATTRIBUTES lpPipeAttributes, DWORD nSize ) ;
LPCTSTR lpCurrentDirectory,
LPSTARTUPINFO lpStartupInfo,
LPPROCESS_INFORMATION lpProcessInformation ) ;
-: CreateProcess CreateProcessW ;
+ALIAS: CreateProcess CreateProcessW
! FUNCTION: CreateProcessInternalA
! FUNCTION: CreateProcessInternalW
! FUNCTION: CreateProcessInternalWSecure
! FUNCTION: DeleteFiber
! FUNCTION: DeleteFileA
FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ;
-: DeleteFile DeleteFileW ;
+ALIAS: DeleteFile DeleteFileW
! FUNCTION: DeleteTimerQueue
! FUNCTION: DeleteTimerQueueEx
! FUNCTION: DeleteTimerQueueTimer
FUNCTION: HANDLE FindFirstChangeNotificationW ( LPCTSTR lpPathName,
BOOL bWatchSubtree,
DWORD dwNotifyFilter ) ;
-: FindFirstChangeNotification FindFirstChangeNotificationW ;
+ALIAS: FindFirstChangeNotification FindFirstChangeNotificationW
! FUNCTION: FindFirstFileA
! FUNCTION: FindFirstFileExA
! FUNCTION: FindFirstFileExW
FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFileData ) ;
-: FindFirstFile FindFirstFileW ;
+ALIAS: FindFirstFile FindFirstFileW
! FUNCTION: FindFirstVolumeA
! FUNCTION: FindFirstVolumeMountPointA
! FUNCTION: FindFirstVolumeMountPointW
FUNCTION: BOOL FindNextChangeNotification ( HANDLE hChangeHandle ) ;
! FUNCTION: FindNextFileA
FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileData ) ;
-: FindNextFile FindNextFileW ;
+ALIAS: FindNextFile FindNextFileW
! FUNCTION: FindNextVolumeA
! FUNCTION: FindNextVolumeMountPointA
! FUNCTION: FindNextVolumeMountPointW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
! FUNCTION: GetComputerNameExW
! FUNCTION: GetComputerNameW
-: GetComputerName GetComputerNameW ;
+ALIAS: GetComputerName GetComputerNameW
! FUNCTION: GetConsoleAliasA
! FUNCTION: GetConsoleAliasesA
! FUNCTION: GetConsoleAliasesLengthA
! FUNCTION: GetConsoleScreenBufferInfo
! FUNCTION: GetConsoleSelectionInfo
FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ;
-: GetConsoleTitle GetConsoleTitleW ; inline
+ALIAS: GetConsoleTitle GetConsoleTitleW
! FUNCTION: GetConsoleWindow
! FUNCTION: GetCPFileNameFromRegistry
! FUNCTION: GetCPInfo
! FUNCTION: GetCurrentConsoleFont
! FUNCTION: GetCurrentDirectoryA
FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ;
-: GetCurrentDirectory GetCurrentDirectoryW ; inline
+ALIAS: GetCurrentDirectory GetCurrentDirectoryW
FUNCTION: HANDLE GetCurrentProcess ( ) ;
FUNCTION: DWORD GetCurrentProcessId ( ) ;
FUNCTION: HANDLE GetCurrentThread ( ) ;
FUNCTION: BOOL GetFileAttributesExW ( LPCTSTR lpFileName, GET_FILEEX_INFO_LEVELS fInfoLevelId, LPVOID lpFileInformation ) ;
-: GetFileAttributesEx GetFileAttributesExW ;
+ALIAS: GetFileAttributesEx GetFileAttributesExW
FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ;
FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ;
! FUNCTION: GetFirmwareEnvironmentVariableW
! FUNCTION: GetFullPathNameA
FUNCTION: DWORD GetFullPathNameW ( LPCTSTR lpFileName, DWORD nBufferLength, LPTSTR lpBuffer, LPTSTR* lpFilePart ) ;
-: GetFullPathName GetFullPathNameW ;
+ALIAS: GetFullPathName GetFullPathNameW
! clear "license.txt" 32768 "char[32768]" <c-object> f over >r GetFullPathName r> swap 2 * head >string .
! FUNCTION: GetModuleFileNameA
! FUNCTION: GetModuleFileNameW
FUNCTION: HMODULE GetModuleHandleW ( LPCWSTR lpModuleName ) ;
-: GetModuleHandle GetModuleHandleW ; inline
+ALIAS: GetModuleHandle GetModuleHandleW
! FUNCTION: GetModuleHandleExA
! FUNCTION: GetModuleHandleExW
! FUNCTION: GetNamedPipeHandleStateA
! FUNCTION: GetSystemDefaultUILanguage
! FUNCTION: GetSystemDirectoryA
FUNCTION: UINT GetSystemDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
-: GetSystemDirectory GetSystemDirectoryW ; inline
+ALIAS: GetSystemDirectory GetSystemDirectoryW
FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ;
! FUNCTION: GetSystemPowerStatus
! FUNCTION: GetSystemRegistryQuota
! FUNCTION: GetSystemTimes
! FUNCTION: GetSystemWindowsDirectoryA
FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
-: GetSystemWindowsDirectory GetSystemWindowsDirectoryW ; inline
+ALIAS: GetSystemWindowsDirectory GetSystemWindowsDirectoryW
! FUNCTION: GetSystemWow64DirectoryA
! FUNCTION: GetSystemWow64DirectoryW
! FUNCTION: GetTapeParameters
! FUNCTION: GetVDMCurrentDirectories
FUNCTION: DWORD GetVersion ( ) ;
FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
-: GetVersionEx GetVersionExW ;
+ALIAS: GetVersionEx GetVersionExW
! FUNCTION: GetVolumeInformationA
! FUNCTION: GetVolumeInformationW
! FUNCTION: GetVolumeNameForVolumeMountPointA
! FUNCTION: GetVolumePathNameW
! FUNCTION: GetWindowsDirectoryA
FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
-: GetWindowsDirectory GetWindowsDirectoryW ; inline
+ALIAS: GetWindowsDirectory GetWindowsDirectoryW
! FUNCTION: GetWriteWatch
! FUNCTION: GlobalAddAtomA
! FUNCTION: GlobalAddAtomW
! FUNCTION: MoveFileExA
! FUNCTION: MoveFileExW
FUNCTION: BOOL MoveFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName ) ;
-: MoveFile MoveFileW ;
+ALIAS: MoveFile MoveFileW
! FUNCTION: MoveFileWithProgressA
! FUNCTION: MoveFileWithProgressW
! FUNCTION: MulDiv
FUNCTION: HANDLE OpenFileMappingW ( DWORD dwDesiredAccess,
BOOL bInheritHandle,
LPCTSTR lpName ) ;
-: OpenFileMapping OpenFileMappingW ;
+ALIAS: OpenFileMapping OpenFileMappingW
! FUNCTION: OpenJobObjectA
! FUNCTION: OpenJobObjectW
! FUNCTION: OpenMutexA
! FUNCTION: ReleaseSemaphore
! FUNCTION: RemoveDirectoryA
FUNCTION: BOOL RemoveDirectoryW ( LPCTSTR lpPathName ) ;
-: RemoveDirectory RemoveDirectoryW ;
+ALIAS: RemoveDirectory RemoveDirectoryW
! FUNCTION: RemoveLocalAlternateComputerNameA
! FUNCTION: RemoveLocalAlternateComputerNameW
! FUNCTION: RemoveVectoredExceptionHandler
! FUNCTION: SetConsoleScreenBufferSize
FUNCTION: BOOL SetConsoleTextAttribute ( HANDLE hConsoleOutput, WORD wAttributes ) ;
FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ;
-: SetConsoleTitle SetConsoleTitleW ;
+ALIAS: SetConsoleTitle SetConsoleTitleW
! FUNCTION: SetConsoleWindowInfo
! FUNCTION: SetCPGlobal
! FUNCTION: SetCriticalSectionSpinCount
! FUNCTION: SetCurrentDirectoryA
FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ;
-: SetCurrentDirectory SetCurrentDirectoryW ; inline
+ALIAS: SetCurrentDirectory SetCurrentDirectoryW
! FUNCTION: SetDefaultCommConfigA
! FUNCTION: SetDefaultCommConfigW
! FUNCTION: SetDllDirectoryA
: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
-: pfd-dwFlags
+: pfd-dwFlags ( -- n )
{ PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
! TODO: compare to http://www.nullterminator.net/opengl32.html
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math
-windows.types shuffle math.bitfields ;
+windows.types shuffle math.bitfields alias ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
: WS_MAXIMIZEBOX HEX: 00010000 ; inline
! Common window styles
-: WS_OVERLAPPEDWINDOW
+: WS_OVERLAPPEDWINDOW ( -- n )
{
WS_OVERLAPPED
WS_CAPTION
WS_MAXIMIZEBOX
} flags ; foldable
-: WS_POPUPWINDOW
+: WS_POPUPWINDOW ( -- n )
{ WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable
: WS_CHILDWINDOW WS_CHILD ; inline
: WS_TILED WS_OVERLAPPED ; inline
: WS_ICONIC WS_MINIMIZE ; inline
: WS_SIZEBOX WS_THICKFRAME ; inline
-: WS_TILEDWINDOW WS_OVERLAPPEDWINDOW ; inline
+: WS_TILEDWINDOW WS_OVERLAPPEDWINDOW ; inline
! Extended window styles
! FUNCTION: CloseWindowStation
! FUNCTION: CopyAcceleratorTableA
FUNCTION: int CopyAcceleratorTableW ( HACCEL hAccelSrc, LPACCEL lpAccelDst, int cAccelEntries ) ;
-: CopyAcceleratorTable CopyAcceleratorTableW ; inline
+ALIAS: CopyAcceleratorTable CopyAcceleratorTableW
! FUNCTION: CopyIcon
! FUNCTION: CopyImage
! FUNCTION: CopyRect
! FUNCTION: CountClipboardFormats
! FUNCTION: CreateAcceleratorTableA
FUNCTION: HACCEL CreateAcceleratorTableW ( LPACCEL lpaccl, int cEntries ) ;
-: CreateAcceleratorTable CreateAcceleratorTableW ; inline
+ALIAS: CreateAcceleratorTable CreateAcceleratorTableW
! FUNCTION: CreateCaret
! FUNCTION: CreateCursor
! FUNCTION: CreateDesktopA
HINSTANCE hInstance,
LPVOID lpParam ) ;
-: CreateWindowEx CreateWindowExW ; inline
+ALIAS: CreateWindowEx CreateWindowExW
-: CreateWindow 0 12 -nrot CreateWindowEx ;
+: CreateWindow 0 12 -nrot CreateWindowEx ; inline
! FUNCTION: CreateWindowStationA
! FUNCTION: DefMDIChildProcW
! FUNCTION: DefRawInputProc
FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam ) ;
-: DefWindowProc DefWindowProcW ; inline
+ALIAS: DefWindowProc DefWindowProcW
! FUNCTION: DeleteMenu
! FUNCTION: DeregisterShellHookWindow
FUNCTION: BOOL DestroyAcceleratorTable ( HACCEL hAccel ) ;
! FUNCTION: DisableProcessWindowsGhosting
FUNCTION: LONG DispatchMessageW ( MSG* lpMsg ) ;
-: DispatchMessage DispatchMessageW ; inline
+ALIAS: DispatchMessage DispatchMessageW
! FUNCTION: DisplayExitWindowsWarnings
! FUNCTION: DlgDirListA
! FUNCTION: GetCaretBlinkTime
! FUNCTION: GetCaretPos
FUNCTION: BOOL GetClassInfoW ( HINSTANCE hInst, LPCWSTR lpszClass, LPWNDCLASS lpwcx ) ;
-: GetClassInfo GetClassInfoW ;
+ALIAS: GetClassInfo GetClassInfoW
FUNCTION: BOOL GetClassInfoExW ( HINSTANCE hInst, LPCWSTR lpszClass, LPWNDCLASSEX lpwcx ) ;
-: GetClassInfoEx GetClassInfoExW ; inline
+ALIAS: GetClassInfoEx GetClassInfoExW
FUNCTION: ULONG_PTR GetClassLongW ( HWND hWnd, int nIndex ) ;
-: GetClassLong GetClassLongW ; inline
-: GetClassLongPtr GetClassLongW ; inline
+ALIAS: GetClassLong GetClassLongW
+ALIAS: GetClassLongPtr GetClassLongW
! FUNCTION: GetClassNameA
! FUNCTION: GetMenuStringW
FUNCTION: BOOL GetMessageW ( LPMSG lpMsg, HWND hWnd, UINT wMsgFilterMin, UINT wMsgFilterMax ) ;
-: GetMessage GetMessageW ; inline
+ALIAS: GetMessage GetMessageW
! FUNCTION: GetMessageExtraInfo
! FUNCTION: GetMessagePos
! FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, LPCWSTR lpCursorName ) ;
FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, ushort lpCursorName ) ;
-: LoadCursor LoadCursorW ; inline
+ALIAS: LoadCursor LoadCursorW
! FUNCTION: HICON LoadIconA ( HINSTANCE hInstance, LPCTSTR lpIconName ) ;
FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCTSTR lpIconName ) ;
-: LoadIcon LoadIconW ; inline
+ALIAS: LoadIcon LoadIconW
! FUNCTION: LoadImageA
! FUNCTION: LoadImageW
! FUNCTION: MapDialogRect
FUNCTION: UINT MapVirtualKeyW ( UINT uCode, UINT uMapType ) ;
-: MapVirtualKey MapVirtualKeyW ; inline
+ALIAS: MapVirtualKey MapVirtualKeyW
FUNCTION: UINT MapVirtualKeyExW ( UINT uCode, UINT uMapType, HKL dwhkl ) ;
-: MapVirtualKeyEx MapVirtualKeyExW ; inline
+ALIAS: MapVirtualKeyEx MapVirtualKeyExW
! FUNCTION: MapWindowPoints
! FUNCTION: MB_GetString
! FUNCTION: int MessageBoxIndirectW ( MSGBOXPARAMSW* params ) ;
-: MessageBox MessageBoxW ;
+ALIAS: MessageBox MessageBoxW
-: MessageBoxEx MessageBoxExW ;
+ALIAS: MessageBoxEx MessageBoxExW
! : MessageBoxIndirect
! \ MessageBoxIndirectW \ MessageBoxIndirectA unicode-exec ;
! FUNCTION: PaintMenuBar
FUNCTION: BOOL PeekMessageA ( LPMSG lpMsg, HWND hWnd, UINT wMsgFilterMin, UINT wMsgFilterMax, UINT wRemoveMsg ) ;
FUNCTION: BOOL PeekMessageW ( LPMSG lpMsg, HWND hWnd, UINT wMsgFilterMin, UINT wMsgFilterMax, UINT wRemoveMsg ) ;
-: PeekMessage PeekMessageW ;
+ALIAS: PeekMessage PeekMessageW
! FUNCTION: PostMessageA
! FUNCTION: PostMessageW
! FUNCTION: RecordShutdownReason
! FUNCTION: RedrawWindow
-FUNCTION: ATOM RegisterClassA ( WNDCLASS* lpWndClass) ;
+FUNCTION: ATOM RegisterClassA ( WNDCLASS* lpWndClass ) ;
FUNCTION: ATOM RegisterClassW ( WNDCLASS* lpWndClass ) ;
FUNCTION: ATOM RegisterClassExA ( WNDCLASSEX* lpwcx ) ;
FUNCTION: ATOM RegisterClassExW ( WNDCLASSEX* lpwcx ) ;
-: RegisterClass RegisterClassW ;
-: RegisterClassEx RegisterClassExW ;
+ALIAS: RegisterClass RegisterClassW
+ALIAS: RegisterClassEx RegisterClassExW
! FUNCTION: RegisterClipboardFormatA
! FUNCTION: RegisterClipboardFormatW
! FUNCTION: SendIMEMessageExW
! FUNCTION: UINT SendInput ( UINT nInputs, LPINPUT pInputs, int cbSize ) ;
FUNCTION: LRESULT SendMessageW ( HWND hWnd, UINT msg, WPARAM wParam, LPARAM lParam ) ;
-: SendMessage SendMessageW ;
+ALIAS: SendMessage SendMessageW
! FUNCTION: SendMessageCallbackA
! FUNCTION: SendMessageCallbackW
! FUNCTION: SendMessageTimeoutA
! FUNCTION: SetCaretPos
FUNCTION: ULONG_PTR SetClassLongW ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ;
-: SetClassLongPtr SetClassLongW ;
-: SetClassLong SetClassLongW ;
+ALIAS: SetClassLongPtr SetClassLongW
+ALIAS: SetClassLong SetClassLongW
! FUNCTION: SetClassWord
FUNCTION: HANDLE SetClipboardData ( UINT uFormat, HANDLE hMem ) ;
! FUNCTION: SetKeyboardState
! type is ignored
FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
-: SetLastError 0 SetLastErrorEx ;
+: SetLastError 0 SetLastErrorEx ; inline
! FUNCTION: SetLayeredWindowAttributes
! FUNCTION: SetLogonNotifyWindow
! FUNCTION: SetMenu
! FUNCTION: TranslateAccelerator
! FUNCTION: TranslateAcceleratorA
FUNCTION: int TranslateAcceleratorW ( HWND hWnd, HACCEL hAccTable, LPMSG lpMsg ) ;
-: TranslateAccelerator TranslateAcceleratorW ; inline
+ALIAS: TranslateAccelerator TranslateAcceleratorW
! FUNCTION: TranslateMDISysAccel
FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
! FUNCTION: UnlockWindowStation
! FUNCTION: UnpackDDElParam
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
-: UnregisterClass UnregisterClassW ;
+ALIAS: UnregisterClass UnregisterClassW
! FUNCTION: UnregisterDeviceNotification
! FUNCTION: UnregisterHotKey
! FUNCTION: UnregisterMessagePumpHook
win32-error-string throw
] when ;
-: expected-io-errors
+: expected-io-errors ( -- seq )
ERROR_SUCCESS
ERROR_IO_INCOMPLETE
ERROR_IO_PENDING
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors structs windows math.bitfields ;
+windows.errors structs windows math.bitfields alias ;
IN: windows.winsock
USE: libc
: AI_PASSIVE 1 ; inline
: AI_CANONNAME 2 ; inline
: AI_NUMERICHOST 4 ; inline
-: AI_MASK { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
+: AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
: NI_NUMERICHOST 1 ;
: NI_NUMERICSERV 2 ;
{ "sockaddr*" "addr" }
{ "addrinfo*" "next" } ;
-: hostent-addr hostent-addr-list *void* ; ! *uint ;
+: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
LIBRARY: winsock
LPWSAPROTOCOL_INFOW lpProtocolInfo,
GROUP g,
DWORD flags ) ;
-: WSASocket WSASocketW ;
+ALIAS: WSASocket WSASocketW
FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
WSAEVENT* lphEvents,
: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 ; inline
-: WSAID_CONNECTEX
+: WSAID_CONNECTEX ( -- GUID )
"GUID" <c-object>
HEX: 25a207b9 over set-GUID-Data1
HEX: ddf3 over set-GUID-Data2
! This code was based on by McCLIM's Backends/CLX/port.lisp
! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
-: XA_CLIPBOARD "CLIPBOARD" x-atom ;
+: XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
-: XA_UTF8_STRING "UTF8_STRING" x-atom ;
+: XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
TUPLE: x-clipboard atom contents ;
! with button names below.
-: AnyModifier 1 15 shift ; ! used in GrabButton, GrabKey
+: AnyModifier ( -- n ) 15 2^ ; ! used in GrabButton, GrabKey
! button names. Used as arguments to GrabButton and as detail in ButtonPress
! and ButtonRelease events. Not to be confused with button masks above.
! Used in SetInputFocus, GetInputFocus
-: RevertToNone None ;
-: RevertToPointerRoot PointerRoot ;
+: RevertToNone ( -- n ) None ;
+: RevertToPointerRoot ( -- n ) PointerRoot ;
: RevertToParent 2 ;
! *****************************************************************
! Flags used in StoreNamedColor, StoreColors
-: DoRed 1 0 shift ;
-: DoGreen 1 1 shift ;
-: DoBlue 1 2 shift ;
+: DoRed ( -- n ) 0 2^ ;
+: DoGreen ( -- n ) 1 2^ ;
+: DoBlue ( -- n ) 2 2^ ;
! *****************************************************************
! * CURSOR STUFF
! masks for ChangeKeyboardControl
-: KBKeyClickPercent 1 0 shift ;
-: KBBellPercent 1 1 shift ;
-: KBBellPitch 1 2 shift ;
-: KBBellDuration 1 3 shift ;
-: KBLed 1 4 shift ;
-: KBLedMode 1 5 shift ;
-: KBKey 1 6 shift ;
-: KBAutoRepeatMode 1 7 shift ;
+: KBKeyClickPercent ( -- n ) 0 2^ ;
+: KBBellPercent ( -- n ) 1 2^ ;
+: KBBellPitch ( -- n ) 2 2^ ;
+: KBBellDuration ( -- n ) 3 2^ ;
+: KBLed ( -- n ) 4 2^ ;
+: KBLedMode ( -- n ) 5 2^ ;
+: KBKey ( -- n ) 6 2^ ;
+: KBAutoRepeatMode ( -- n ) 7 2^ ;
: MappingSuccess 0 ;
: MappingBusy 1 ;
! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
-: USPosition 1 0 shift ; inline
-: USSize 1 1 shift ; inline
-: PPosition 1 2 shift ; inline
-: PSize 1 3 shift ; inline
-: PMinSize 1 4 shift ; inline
-: PMaxSize 1 5 shift ; inline
-: PResizeInc 1 6 shift ; inline
-: PAspect 1 7 shift ; inline
-: PBaseSize 1 8 shift ; inline
-: PWinGravity 1 9 shift ; inline
-: PAllHints
+: USPosition ( -- n ) 0 2^ ; inline
+: USSize ( -- n ) 1 2^ ; inline
+: PPosition ( -- n ) 2 2^ ; inline
+: PSize ( -- n ) 3 2^ ; inline
+: PMinSize ( -- n ) 4 2^ ; inline
+: PMaxSize ( -- n ) 5 2^ ; inline
+: PResizeInc ( -- n ) 6 2^ ; inline
+: PAspect ( -- n ) 7 2^ ; inline
+: PBaseSize ( -- n ) 8 2^ ; inline
+: PWinGravity ( -- n ) 9 2^ ; inline
+: PAllHints ( -- n )
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
C-STRUCT: XSizeHints
FUNCTION: void XFree ( void* data ) ;
FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
-
FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
+FUNCTION: int XBell ( Display* display, int percent ) ;
! !!! INPUT METHODS
: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
-: check-display
+: check-display ( alien -- alien' )
[
"Cannot connect to X server - check $DISPLAY" throw
] unless* ;
put-http-response ;
: test-rpc-arith
- "add" { 1 2 } <rpc-method> send-rpc xml>string
- "text/xml" swap "http://localhost:8080/responder/rpc/"
+ "add" { 1 2 } <rpc-method> send-rpc
+ "http://localhost:8080/responder/rpc/"
http-post ;
: post-rpc ( rpc url -- rpc )
! This needs to do something in the event of an error
- >r "text/xml" swap send-rpc xml>string r> http-post
- 2nip string>xml receive-rpc ;
+ >r send-rpc r> http-post nip string>xml receive-rpc ;
: invoke-method ( params method url -- )
>r swap <rpc-method> r> post-rpc ;
] with-string-writer ;
TUPLE: mismatched < parsing-error open close ;
-: <mismatched>
+: <mismatched> ( open close -- error )
\ mismatched parsing-error swap >>close swap >>open ;
M: mismatched summary ( obj -- str )
[
] with-string-writer ;
TUPLE: bad-version < parsing-error num ;
-: <bad-version>
+: <bad-version> ( num -- error )
\ bad-version parsing-error swap >>num ;
M: bad-version summary ( obj -- str )
[
TUPLE: mode file file-name-glob first-line-glob ;
-<TAGS: parse-mode-tag
+<TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
"NAME" over at >r
-USING: kernel strings assocs sequences hashtables sorting
- unicode.case unicode.categories sets ;
+USING: accessors kernel strings assocs sequences hashtables
+sorting unicode.case unicode.categories sets ;
IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap
H{ } clone { set-keyword-map-ignore-case? set-delegate }
keyword-map construct ;
-: invalid-no-word-sep f swap set-keyword-map-no-word-sep ;
+: invalid-no-word-sep ( keyword-map -- ) f >>no-word-sep drop ;
: handle-case ( key keyword-map -- key assoc )
[ keyword-map-ignore-case? [ >upper ] when ] keep
M: keyword-map >alist delegate >alist ;
-: (keyword-map-no-word-sep)
+: (keyword-map-no-word-sep) ( assoc -- str )
keys concat [ alpha? not ] filter prune natural-sort ;
: keyword-map-no-word-sep* ( keyword-map -- str )
! Based on org.gjt.sp.jedit.XModeHandler
! RULES and its children
-<TAGS: parse-rule-tag
+<TAGS: parse-rule-tag ( rule-set tag -- )
-TAG: PROPS ( rule-set tag -- )
+TAG: PROPS
parse-props-tag swap set-rule-set-props ;
-TAG: IMPORT ( rule-set tag -- )
+TAG: IMPORT
"DELEGATE" swap at swap import-rule-set ;
-TAG: TERMINATE ( rule-set tag -- )
+TAG: TERMINATE
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
RULE: SEQ seq-rule
TAGS>
-: ?<regexp> dup [ ignore-case? get <regexp> ] when ;
+: ?<regexp> ( string/f -- regexp/f )
+ dup [ ignore-case? get <regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set )
<rule-set>
[ string>token ]
} case ;
-: string>rule-set-name "MAIN" or ;
+: string>rule-set-name ( string -- name ) "MAIN" or ;
! PROP, PROPS
: parse-prop-tag ( tag -- key value )
dup children>string ignore-case? get <regexp>
swap position-attrs <matcher> ;
-: shared-tag-attrs
+: shared-tag-attrs ( -- )
{ "TYPE" string>token set-rule-body-token } , ; inline
-: delegate-attr
+: delegate-attr ( -- )
{ "DELEGATE" f set-rule-delegate } , ;
-: regexp-attr
+: regexp-attr ( -- )
{ "HASH_CHAR" f set-rule-chars } , ;
-: match-type-attr
+: match-type-attr ( -- )
{ "MATCH_TYPE" string>match-type set-rule-match-token } , ;
-: span-attrs
+: span-attrs ( -- )
{ "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
{ "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
{ "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
-: literal-start
+: literal-start ( -- )
[ parse-literal-matcher swap set-rule-start ] , ;
-: regexp-start
+: regexp-start ( -- )
[ parse-regexp-matcher swap set-rule-start ] , ;
-: literal-end
+: literal-end ( -- )
[ parse-literal-matcher swap set-rule-end ] , ;
! SPAN's children
-<TAGS: parse-begin/end-tag
+<TAGS: parse-begin/end-tag ( rule tag -- )
TAG: BEGIN
! XXX
TAGS>
-: parse-begin/end-tags
+: parse-begin/end-tags ( -- )
[
! XXX: handle position attrs on span tag itself
child-tags [ parse-begin/end-tag ] with each
] , ;
-: init-span-tag [ drop init-span ] , ;
+: init-span-tag ( -- ) [ drop init-span ] , ;
-: init-eol-span-tag [ drop init-eol-span ] , ;
+: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
: parse-keyword-tag ( tag keyword-map -- )
>r dup name-tag string>token swap children>string r> set-at ;
dup [ dupd matches? ] [ drop f ] if
] unless*
]
- } && nip ;
+ } 0&& nip ;
: mark-number ( keyword -- id )
keyword-number? DIGIT and ;
[ over matcher-at-line-start? over zero? implies ]
[ over matcher-at-whitespace-end? over whitespace-end get = implies ]
[ over matcher-at-word-start? over last-offset get = implies ]
- } && 2nip ;
+ } 0&& 2nip ;
: rest-of-line ( -- str )
line get position get tail-slice ;
dup rule-body-token prev-token,
rule-match-token* next-token, ;
-: do-escaped
+: do-escaped ( -- )
escaped? get [
escaped? off
! ...
[ check-end-delegate ]
[ check-every-rule ]
[ check-word-break ]
- } || drop
+ } 0|| drop
position inc
mark-token-loop
rule-set-imports push ;
: inverted-index ( hashes key index -- )
- [ swapd [ ?push ] change-at ] 2curry each ;
+ [ swapd push-at ] 2curry each ;
: ?push-all ( seq1 seq2 -- seq1+seq2 )
[
CREATE tag-handler-word set
H{ } clone tag-handlers set ; parsing
-: (TAG:) swap tag-handlers get set-at ;
+: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
: TAG:
- f set-word
scan parse-definition
(TAG:) ; parsing
IN: yahoo
HELP: search-yahoo
-{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }
-{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ;
+{ $values { "search" search } { "seq" "sequence of arrays of length 3" } }
+{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ;
-USING: tools.test yahoo kernel io.files xml sequences accessors ;
+USING: tools.test yahoo kernel io.files xml sequences accessors urls ;
[ T{
result
"Official site with news, tour dates, discography, store, community, and more."
} ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test
-[ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=2&similar_ok=1" ] [ "hi" <search> "Factor-search" >>appid 2 >>results t >>similar-ok query ] unit-test
+[ URL" http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=2&similar_ok=1" ] [ "hi" <search> "Factor-search" >>appid 2 >>results t >>similar-ok query ] unit-test
! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan
! See http://factorcode.org/license.txt for BSD license.
USING: http.client xml xml.utilities kernel sequences
-namespaces http math.parser help math.order locals
-urls accessors ;
+math.parser urls accessors locals ;
IN: yahoo
TUPLE: result title url summary ;
C: <result> result
-
+
TUPLE: search query results adult-ok start appid region type
format similar-ok language country site subscription license ;
] map ;
: yahoo-url ( -- str )
- "http://search.yahooapis.com/WebSearchService/V1/webSearch" ;
+ URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" ;
-: param ( search str quot -- search )
- >r over r> call [ url-encode [ % ] bi@ ] [ drop ] if* ;
- inline
+:: param ( search url name quot -- search url )
+ search url search quot call
+ [ name set-query-param ] when* ; inline
: num-param ( search str quot -- search )
[ dup [ number>string ] when ] compose param ; inline
[ "1" and ] compose param ; inline
: query ( search -- url )
- [
- yahoo-url %
- "?appid=" [ appid>> ] param
- "&query=" [ query>> ] param
- "®ion=" [ region>> ] param
- "&type=" [ type>> ] param
- "&format=" [ format>> ] param
- "&language=" [ language>> ] param
- "&country=" [ country>> ] param
- "&site=" [ site>> ] param
- "&subscription=" [ subscription>> ] param
- "&license=" [ license>> ] param
- "&results=" [ results>> ] num-param
- "&start=" [ start>> ] num-param
- "&adult_ok=" [ adult-ok>> ] bool-param
- "&similar_ok=" [ similar-ok>> ] bool-param
- drop
- ] "" make ;
+ yahoo-url clone
+ "appid" [ appid>> ] param
+ "query" [ query>> ] param
+ "region" [ region>> ] param
+ "type" [ type>> ] param
+ "format" [ format>> ] param
+ "language" [ language>> ] param
+ "country" [ country>> ] param
+ "site" [ site>> ] param
+ "subscription" [ subscription>> ] param
+ "license" [ license>> ] param
+ "results" [ results>> ] num-param
+ "start" [ start>> ] num-param
+ "adult_ok" [ adult-ok>> ] bool-param
+ "similar_ok" [ similar-ok>> ] bool-param
+ nip ;
: factor-id
"fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ;
swap >>query ;
: search-yahoo ( search -- seq )
- query http-get string>xml parse-yahoo ;
+ query http-get nip string>xml parse-yahoo ;
"SYMBOLS:"
))
+(defun factor-indent-line ()
+ "Indent current line as Factor code"
+ (indent-line-to (+ (current-indentation) 4)))
+
(defun factor-mode ()
"A mode for editing programs written in the Factor programming language."
(interactive)
(setq font-lock-defaults
'(factor-font-lock-keywords nil nil nil nil))
(set-syntax-table factor-mode-syntax-table)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'factor-indent-line)
(run-hooks 'factor-mode-hook))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
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
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;
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) \
projects / factor.git / commitdiff