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 ;
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 )
"@"
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 }
$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 } }
GENERIC: >alist ( assoc -- newassoc )
-GENERIC# assoc-find 1 ( assoc quot -- key value ? ) 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 ? )
+ >r >alist r> [ first2 ] prepose find swap
+ [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
: 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 ;
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
! 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
"\""
"#!"
"("
+ "(("
":"
";"
"<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
] 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
[ \ 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 ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
-: predicate-effect 1 { "?" } <effect> ;
+: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
M: word reset-class drop ;
-<PRIVATE
-
! update-map
: class-uses ( class -- seq )
[
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
+<PRIVATE
+
: update-map+ ( class -- )
dup class-uses update-map get add-vertex ;
: (define-class) ( word props -- )
>r
dup reset-class
+ dup class? [ dup new-class ] unless
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props
M: class update-class drop ;
-GENERIC: update-methods ( assoc -- )
+GENERIC: update-methods ( class assoc -- )
: update-classes ( class -- )
- class-usages
- [ [ drop update-class ] assoc-each ]
+ dup class-usages
+ [ nip keys [ update-class ] each ]
[ update-methods ]
- bi ;
+ 2bi ;
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
! 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
+ [ keys [ 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 drop
+ dup new-class? [ 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 ;
[ 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 ;
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
[ swap save-effect ]
[ compiled-unxref ]
[
- dup compiled-crossref?
+ dup crossref?
[ dependencies get compiled-xref ] [ drop ] if
] tri ;
! 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 ] [
! 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 tools.test math parser ;
+
+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
! 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 ( -- )
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
- dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
- ;
+ 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
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
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 ;
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: ( }
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 ;
: word-dataflow ( word -- effect dataflow )
[
- dup "no-effect" word-prop [ no-effect ] when
- dup "no-compile" word-prop [ no-effect ] when
+ 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
] with-infer ;
! 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 ;
\ check-method boa throw
] unless ; inline
-: with-methods ( generic quot -- )
- swap [ "methods" word-prop swap call ] keep make-generic ;
+: affected-methods ( class generic -- seq )
+ "methods" word-prop swap
+ [ nip classes-intersect? ] curry assoc-filter
+ values ;
+
+: update-generic ( class generic -- )
+ [ affected-methods [ +called+ changed-definition ] each ]
+ [ make-generic ]
+ bi ;
+
+: with-methods ( class generic quot -- )
+ [ [ "methods" word-prop ] dip call ]
+ [ drop update-generic ] 3bi ;
inline
: method-word-name ( class word -- string )
M: method-spec forget*
first2 method forget* ;
+M: method-spec smart-usage
+ second smart-usage ;
+
M: method-body definer
drop \ M: \ ; ;
[ t "forgotten" set-word-prop ] bi
] if ;
-: implementors* ( classes -- words )
+M: method-body smart-usage
+ "method-generic" word-prop smart-usage ;
+
+GENERIC: implementors ( class/classes -- seq )
+
+M: class implementors
+ all-words [ "methods" word-prop key? ] with filter ;
+
+M: assoc implementors
all-words [
- "methods" word-prop keys
+ "methods" word-prop keys
swap [ key? ] curry contains?
] with filter ;
-: implementors ( class -- seq )
- dup associate implementors* ;
-
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
]
[ call-next-method ] bi ;
-M: assoc update-methods ( assoc -- )
- implementors* [ make-generic ] each ;
+M: assoc update-methods ( class assoc -- )
+ implementors [ update-generic ] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [
\ 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? drop t ;
+
+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 ;
--- /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: 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
--- /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
--- /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 < groups ;
+
+: <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 ;
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 ]
+ [ dup visited get set-at ]
+ [
+ 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
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
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 ;
: infer-word ( word -- effect )
[
finish-word
current-effect
] with-scope
- ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
+ ] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
: 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."
{ $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 ] [ ] [ ] while ] infer ] must-fail
-
-! : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
-
-! [ [ erg's-inference-bug ] 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 ;
+!
+! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+!
+! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a 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 ;
+!
+! \ inference-invalidation-d must-infer
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+!
+! [ [ inference-invalidation-d ] infer ] must-fail
: 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 )
\ 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? } ;
{ $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 -- )" } } }
>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 -- )
: 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 ;
[ 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 -- ? )
{
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
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' )
! 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
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
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 )
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*
: 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
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
+{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $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? [
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 ;
{ $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
+ ")" parse-effect word
[ swap "declared-effect" set-word-prop ] [ drop ] if*
] define-syntax
+ "((" [
+ "))" parse-effect parsed
+ ] define-syntax
+
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [
: 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 ;
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." } ;
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
- [ drop compiled-crossref? ] assoc-filter
+ [ drop crossref? ] assoc-filter
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
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 ;
: define-declared ( word def effect -- )
: 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 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 ;
USING: kernel math sequences namespaces io.binary splitting
- strings hashtables ;
+grouping strings hashtables ;
IN: base64
<PRIVATE
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:
parser vocabs.loader ;
IN: bootstrap.help
-: load-help
+: load-help ( -- )
"alien.syntax" require
"compiler" require
"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 [
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
! 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
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
\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
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
+! Copysecond (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
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
: 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 )
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%
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
+: count-tuples ( tuple -- n )
+ select-tuples length ;
+
: select-tuple ( tuple -- tuple/f )
dup dup class f f f 1 <advanced-select-statement>
do-select ?first ;
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
--- /dev/null
+
+USING: kernel
+ combinators
+ sequences
+ math
+ io.sockets
+ unicode.case
+ accessors
+ combinators.cleave
+ newfx
+ dns ;
+
+IN: dns.server
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: records ( -- vector ) V{ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: filter-by-name ( records name -- records ) swap [ name>> = ] with filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-rrs? ( query -- query rrs/f ? ) dup matching-rrs dup empty? not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-cname? ( query -- query rr/f ? )
+ dup clone CNAME >>type matching-rrs
+ dup empty? [ drop f f ] [ 1st t ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: query->rrs
+
+: query-canonical ( query rr -- rrs )
+ tuck [ clone ] [ rdata>> ] bi* >>name query->rrs prefix-on ;
+
+: query->rrs ( query -- rrs/f )
+ {
+ { [ matching-rrs? ] [ nip ] }
+ { [ drop matching-cname? ] [ query-canonical ] }
+ { [ drop t ] [ drop f ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delegate-servers? ( name -- name rrs ? )
+ dup NS IN query boa matching-rrs dup empty? not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delegate-servers ( name -- rrs )
+ {
+ { [ dup "" = ] [ drop { } ] }
+ { [ delegate-servers? ] [ nip ] }
+ { [ drop t ] [ cdr-name delegate-servers ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delegate-addresses ( rrs-ns -- rrs-a )
+ [ rdata>> A IN query boa matching-rrs ] map concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: have-delegates? ( query -- query rrs-ns ? )
+ dup name>> delegate-servers dup empty? not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-additional ( message -- message )
+ dup authority-section>> delegate-addresses >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: no-records-with-name? ( query -- query ? )
+ dup name>> records [ name>> = ] with filter empty? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+ dup message-query ! message query
+ {
+ { [ dup query->rrs dup ] [ nip >>answer-section 1 >>aa ] }
+ { [ drop have-delegates? ] [ nip >>authority-section fill-additional ] }
+ { [ drop no-records-with-name? ] [ drop NAME-ERROR >>rcode ] }
+ { [ drop t ] [ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (socket) ( -- vec ) V{ f } ;
+
+: socket ( -- socket ) (socket) 1st ;
+
+: init-socket-on-port ( port -- )
+ f swap <inet4> <datagram> 0 (socket) as-mutate ;
+
+: init-socket ( -- ) 53 init-socket-on-port ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: loop ( -- )
+ socket receive
+ swap
+ parse-message
+ find-answer
+ message->ba
+ swap
+ socket send
+ loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( -- ) init-socket loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: start
\ No newline at end of file
! 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 ;
{ "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)
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.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
\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
-TUPLE: action rest-param init display validate submit ;\r
+TUPLE: action rest init display validate submit ;\r
\r
: new-action ( class -- action )\r
new\r
: <action> ( -- action )\r
action new-action ;\r
\r
+: flashed-variables ( -- seq )\r
+ { validation-messages named-validation-messages } ;\r
+\r
: handle-get ( action -- response )\r
- blank-values\r
- [ init>> call ]\r
- [ display>> call ]\r
- bi ;\r
+ '[\r
+ ,\r
+ [ init>> call ]\r
+ [ drop flashed-variables restore-flash ]\r
+ [ display>> call ]\r
+ tri\r
+ ] with-exit-continuation ;\r
\r
: validation-failed ( -- * )\r
- request get method>> "POST" =\r
- [ action get display>> call ] [ <400> ] if exit-with ;\r
+ request get method>> "POST" = [ f ] [ <400> ] if exit-with ;\r
\r
-: handle-post ( action -- response )\r
- init-validation\r
- blank-values\r
- [ validate>> call ]\r
- [ submit>> call ] bi ;\r
+: (handle-post) ( action -- response )\r
+ [ validate>> call ] [ 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
+: param ( name -- value )\r
+ params get at ;\r
\r
-M: action call-responder* ( path action -- response )\r
- dup action set\r
- '[\r
- , dup empty? [ drop ] [ handle-rest-param ] if\r
+: revalidate-url-key "__u" ;\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
- ] with-exit-continuation ;\r
+: check-url ( url -- ? )\r
+ request get url>>\r
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;\r
\r
-: param ( name -- value )\r
- params get at ;\r
+: revalidate-url ( -- url/f )\r
+ revalidate-url-key param dup [ >url dup check-url swap and ] when ;\r
+\r
+: handle-post ( action -- response )\r
+ '[\r
+ form-nesting-key params get at " " split\r
+ [ , (handle-post) ]\r
+ [ swap '[ , , nest-values ] ] reduce\r
+ call\r
+ ] with-exit-continuation\r
+ [\r
+ revalidate-url\r
+ [ flashed-variables <flash-redirect> ] [ <403> ] if*\r
+ ] unless* ;\r
+\r
+: handle-rest ( path action -- assoc )\r
+ rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
+\r
+: init-action ( path action -- )\r
+ blank-values\r
+ init-validation\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
--- /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.asides
+
+TUPLE: asides < filter-responder ;
+
+C: <asides> asides
+
+: begin-aside* ( -- id )
+ request get
+ [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+ asides sget set-at-unique
+ session-changed ;
+
+: end-aside-post ( url post-data -- response )
+ request [
+ clone
+ swap >>post-data
+ swap >>url
+ ] change
+ request get url>> path>> split-path
+ asides get responder>> call-responder ;
+
+ERROR: end-aside-in-get-error ;
+
+: end-aside* ( url id -- response )
+ request get method>> "POST" = [ end-aside-in-get-error ] unless
+ asides sget at [
+ first3 {
+ { "GET" [ drop <redirect> ] }
+ { "HEAD" [ drop <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* ;
+
+M: asides call-responder*
+ dup asides set
+ aside-id-key request get request-params at aside-id set
+ call-next-method ;
+
+M: asides init-session*
+ H{ } clone asides sset
+ 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 ;
! 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
+fry arrays threads qualified random validators words\r
io\r
io.sockets\r
io.encodings.utf8\r
furnace.auth.providers\r
furnace.auth.providers.db\r
furnace.actions\r
-furnace.flows\r
+furnace.asides\r
+furnace.flash\r
furnace.sessions\r
furnace.boilerplate ;\r
QUALIFIED: smtp\r
IN: furnace.auth.login\r
\r
+: word>string ( word -- string )\r
+ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;\r
+\r
+: words>strings ( seq -- seq' )\r
+ [ word>string ] map ;\r
+\r
+: string>word ( string -- word )\r
+ ":" split1 swap lookup ;\r
+\r
+: strings>words ( seq -- seq' )\r
+ [ string>word ] map ;\r
+\r
TUPLE: login < dispatcher users checksum ;\r
\r
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
: users ( -- provider )\r
login get users>> ;\r
\r
\r
! ! ! Login\r
: successful-login ( user -- response )\r
- username>> set-uid URL" $login" end-flow ;\r
+ username>> set-uid URL" $login" end-aside ;\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
\r
: <login-action> ( -- action )\r
<page-action>\r
+ [\r
+ protected fget [\r
+ [ description>> "description" set-value ]\r
+ [ capabilities>> words>strings "capabilities" set-value ] bi\r
+ ] when*\r
+ ] >>init\r
+\r
{ login "login" } >>template\r
\r
[\r
\r
drop\r
\r
- URL" $login" end-flow\r
+ URL" $login" end-aside\r
] >>submit ;\r
\r
! ! ! Password recovery\r
<action>\r
[\r
f set-uid\r
- URL" $login" end-flow\r
+ URL" $login" end-aside\r
] >>submit ;\r
\r
! ! ! Authentication logic\r
-\r
-TUPLE: protected < filter-responder capabilities ;\r
-\r
-C: <protected> protected\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
\r
: show-login-page ( -- response )\r
- begin-flow\r
- URL" $login/login" <redirect> ;\r
+ begin-aside\r
+ URL" $login/login" { protected } <flash-redirect> ;\r
\r
: check-capabilities ( responder user -- ? )\r
[ capabilities>> ] bi@ subset? ;\r
\r
M: protected call-responder* ( path responder -- response )\r
+ dup protected set\r
uid dup [\r
users get-user 2dup check-capabilities [\r
[ logged-in-user set ] [ save-user-after ] bi\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> f <protected> <login-boilerplate>\r
+ <edit-profile-action> <protected>\r
+ "edit your profile" >>description\r
+ <login-boilerplate>\r
"edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\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>
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
-: init-users-table user ensure-table ;
+: init-users-table ( -- ) user ensure-table ;
SINGLETON: users-in-db
TUPLE: boilerplate < filter-responder template ;
-: <boilerplate> f boilerplate boa ;
+: <boilerplate> ( responder -- boilerplate ) f boilerplate boa ;
M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs assocs.lib kernel sequences urls
+http http.server http.server.filters http.server.redirection
+furnace furnace.sessions ;
+IN: furnace.flash
+
+: flash-id-key "__f" ;
+
+TUPLE: flash-scopes < filter-responder ;
+
+C: <flash-scopes> flash-scopes
+
+SYMBOL: flash-scope
+
+: fget ( key -- value ) flash-scope get at ;
+
+M: flash-scopes call-responder*
+ flash-id-key
+ request get request-params at
+ flash-scopes sget at flash-scope set
+ call-next-method ;
+
+M: flash-scopes init-session*
+ H{ } clone flash-scopes sset
+ call-next-method ;
+
+: make-flash-scope ( seq -- id )
+ [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
+ session-changed ;
+
+: <flash-redirect> ( url seq -- response )
+ make-flash-scope
+ [ clone ] dip flash-id-key set-query-param
+ <redirect> ;
+
+: restore-flash ( seq -- )
+ [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
+++ /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.templates
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
+EXCLUDE: xml.utilities => children>string ;
IN: furnace
: nested-responders ( -- seq )
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 ;
+M: string adjust-url ;
+
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
-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 ;
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 ;
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom
- [ "title" required-attr ]
+ [ children>string ]
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ] tri
<url>
[ drop </a> ]
tri ;
+: hidden-form-field ( value name -- )
+ over [
+ <input
+ "hidden" =type
+ =name
+ present =value
+ input/>
+ ] [ 2drop ] if ;
+
+: form-nesting-key "__n" ;
+
+: form-magic ( tag -- )
+ [ modify-form ] each-responder
+ nested-values get " " join f like form-nesting-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
+ "POST" =method
+ [ link-attrs ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ tri
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: 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 ;
: get-session ( id -- session )
dup [ <session> select-tuple ] when ;
-: init-sessions-table session ensure-table ;
+: init-sessions-table ( -- ) session ensure-table ;
: start-expiring-sessions ( db seq -- )
'[
[ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ;
-: session-id-key "factorsessid" ;
+: session-id-key "__s" ;
: cookie-session-id ( request -- id/f )
session-id-key get-cookie
dup [ value>> string>number ] when ;
: post-session-id ( request -- id/f )
- session-id-key swap post-data>> at string>number ;
+ session-id-key swap request-params at string>number ;
: request-session-id ( -- id/f )
request get dup method>> {
: put-session-cookie ( response -- response' )
session get id>> number>string <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
--- /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 ;
csv accessors assocs strings math splitting ;
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? [
! 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." }
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
+
+
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
[ ] [ "jimmy" "red" set-value ] unit-test
-[ "123.5" ] [ 123.5 object>string ] unit-test
-
[ "jimmy" ] [
[
"red" label render
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 ;
+lcs.diff2html urls present ;
IN: html.components
SYMBOL: values
-: value values get at ;
+: value ( name -- value ) values get at ;
-: set-value values get set-at ;
+: set-value ( value name -- ) values get set-at ;
-: blank-values H{ } clone values set ;
+: blank-values ( -- ) H{ } clone values set ;
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
: deposit-slots ( destination names -- )
[ <mirror> ] dip deposit-values ;
-: with-each-index ( seq quot -- )
- '[
+: with-each-value ( name quot -- )
+ [ value ] dip '[
[
values [ clone ] change
- 1+ "index" set-value @
+ 1+ "index" set-value
+ "value" set-value
+ @
] with-scope
] each-index ; inline
-: with-each-value ( seq quot -- )
- '[ "value" set-value @ ] with-each-index ; inline
+: with-each-object ( name quot -- )
+ [ value ] dip '[
+ [
+ blank-values
+ 1+ "index" set-value
+ from-object
+ @
+ ] with-scope
+ ] each-index ; inline
-: with-each-object ( seq quot -- )
- '[ from-object @ ] with-each-index ; inline
+SYMBOL: nested-values
-: with-values ( object quot -- )
- '[ blank-values , from-object @ ] with-scope ; inline
+: with-values ( name quot -- )
+ '[
+ ,
+ [ nested-values [ swap prefix ] change ]
+ [ value blank-values from-object ]
+ bi
+ @
+ ] with-scope ; inline
: nest-values ( name quot -- )
swap [
<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
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 ;
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 ;
+ (( -- )) 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 ;
+ (( -- )) 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 ] curry (( -- )) 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 ;
+ (( -- )) 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 ] curry (( string -- )) html-word ;
! Define some closed HTML tags
[
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 )
"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
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+ H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "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
+
+[ ] [
+ blank-values
+ { "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.elements
html.components
: (bind-tag) ( tag quot -- )
[
- [ "name" required-attr value ] keep
+ [ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
CHLOE: call-next-template drop call-next-template ;
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
+
+: if-satisfied? ( tag -- ? )
+ [ "code" optional-attr [ attr>word execute ] [ 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
: 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>
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? [
: 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 ;
+assocs io.sockets db db.sqlite continuations urls hashtables ;
IN: http.tests
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
-GET http://foo/bar HTTP/1.1
+POST http://foo/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"
+ 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
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
- cookies: V{ }
+ cookies: { }
content-type: "text/html"
content-charset: "UTF8"
}
[ ] [
[
<dispatcher>
+ <action> <protected>
<login>
<sessions>
"" add-responder
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
+
+USING: html.components html.elements 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 ] unit-test
assocs 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
unicode.case unicode.categories qualified
-urls html.templates ;
+urls html.templates xml xml.data xml.writer ;
EXCLUDE: fry => , ;
IN: http
-: crlf "\r\n" write ;
+: crlf ( -- ) "\r\n" write ;
: add-header ( value key assoc -- )
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
: 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 )
version
header
post-data
-post-data-type
cookies ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
-: <request>
+: <request> ( -- request )
request new
"1.1" >>version
<url>
: 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
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* ;
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 ;
+ dup url>> relative-url present 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 ;
-
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: 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 post-data>> [
+ [ raw>> length "content-length" pick set-at ]
+ [ content-type>> "content-type" pick set-at ]
+ bi
+ ] when*
over cookies>> f like [ unparse-cookies "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
content-charset
body ;
-: <response>
+: <response> ( -- response )
response new
"1.1" >>version
H{ } clone >>header
now timestamp>http-string "date" set-header
V{ } clone >>cookies ;
-: read-response-version
+: read-response-version ( response -- response )
" \t" read-until
[ "Bad response: version" throw ] unless
parse-version
>>version ;
-: read-response-code
+: read-response-code ( response -- response )
" \t" read-until [ "Bad response: code" throw ] unless
string>number [ "Bad response: code" throw ] unless*
>>code ;
-: read-response-message
+: read-response-message ( response -- response )
read-crlf >>message ;
-: read-response-header
+: read-response-header ( response -- response )
read-header >>header
- extract-cookies
+ dup "set-cookie" header parse-cookies >>cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
] when* ;
http accessors sequences strings math.parser fry urls ;\r
IN: http.server.cgi\r
\r
-: post? request get method>> "POST" = ;\r
+: post? ( -- ? ) request get method>> "POST" = ;\r
\r
: cgi-variables ( script-path -- assoc )\r
#! This needs some work.\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
+ 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 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
--- /dev/null
+USING: http http.server math sequences continuations tools.test ;
+IN: http.server.tests
+
+[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
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-mode 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 method>> "HEAD" = [ drop ] [
+ '[ , write-response-body ]
+ [
+ development-mode get
+ [ http-error. ] [ drop "Response error" ] if
+ ] recover
+ ] if ;
LOG: httpd-hit NOTICE
! 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
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 ;
! 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 sequences.lib 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 )
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
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>
[ >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 )
: 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 )
! 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
[ 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
! 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 ;
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
{ 5 } [
[ 2 3 ] "+" <lisp-symbol> funcall
] 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
+ "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
+ ] unit-test
+
+ { T{ lisp-symbol f "if" } } [
+ "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
+ ] unit-test
+
+ { t } [
+ T{ lisp-symbol f "if" } lisp-macro?
] unit-test
{ 1 } [
- "(if #t 1 2)" lisp-string>factor call
+ "(if #t 1 2)" lisp-eval
] unit-test
{ "b" } [
- "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
+ "(cond (#f \"a\") (#t \"b\"))" lisp-eval
] unit-test
{ 5 } [
- "(begin (+ 1 4))" lisp-string>factor call
+ "(begin (+ 1 4))" lisp-eval
] unit-test
{ 3 } [
- "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
+ "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
] unit-test
-] with-interactive-vocabs
\ No newline at end of file
+
+] 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 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: macro-expand
+DEFER: define-lisp-macro
+
! 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 '[ , [ funcall ] 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@ [ '[ @ funcall ] ] 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 ;
-
+ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
+
: localize-lambda ( body vars -- newbody newvars )
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 )
+ 3car -rot nip [ name>> ] lmap>array ; inline
-: rest-lambda ( body vars -- quot )
+: rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi
localize-lambda <lambda>
'[ , cut '[ @ , ] , compose ] ;
localize-lambda <lambda> '[ , compose ] ;
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 )
+ cdr 1quotation ;
+
+: convert-unquoted ( cons -- quot )
+ "unquote not valid outside of quasiquote!" throw ;
+
+: convert-unquoted-splicing ( cons -- quot )
+ "unquote-splicing not valid outside of quasiquote!" throw ;
+
+<PRIVATE
+: quasiquote-unquote ( cons -- newcons )
+ [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
+ [ cadr ] traverse ;
+
+: quasiquote-unquote-splicing ( cons -- newcons )
+ [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ]
+ [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ]
+ [ dup cadr cdr >>cdr ] traverse ;
+PRIVATE>
+
+: convert-quasiquoted ( cons -- newcons )
+ quasiquote-unquote quasiquote-unquote-splicing ;
+
+: 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 ] }
+ { "unquote" [ convert-unquoted ] }
+ { "unquote-splicing" [ convert-unquoted-splicing ] }
+ { "quasiquote" [ convert-quasiquoted ] }
+ { "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-symbol? ] [ '[ , lookup-var ] ] }
+ [ 1quotation ]
} cond ;
+: compile-form ( lisp-ast -- quot )
+ convert-form lambda-rewrite call ; inline
+
+: macro-call ( lambda -- cons )
+ call ; inline
+
+: macro-expand ( cons -- quot )
+ uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* ;
+
: 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
+
+ERROR: no-such-var variable-name ;
+M: no-such-var summary drop "No such variable" ;
: 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 ;
: 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 ;
: funcall ( quot sym -- * )
dup lisp-symbol? [ lookup-var ] when call ; inline
-: define-primitve ( name vocab word -- )
- swap lookup 1quotation '[ , compose call ] lisp-define ;
\ No newline at end of file
+: define-primitive ( name vocab word -- )
+ swap lookup 1quotation '[ , 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 ;
+
+: 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> ]]
+list-item = _ ( atom | s-expression ) _ => [[ second ]]
+s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
;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 lazy-lists 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
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Chris Double & 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 ;
+
+: 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
\r
<PRIVATE\r
\r
-: one-string?\r
+: one-string? ( obj -- ? )\r
{\r
[ dup array? ]\r
[ dup length 1 = ]\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
: 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
! 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
: 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
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,
: 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
+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 ;
splitting words byte-arrays assocs combinators.lib ;
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 [
! 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
+continuations destructors debugger inspector splitting
locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
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 ;
[ 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 -- )
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
--- /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 [ drop 16 random-bits ] PV{ } map-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
! 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
#! 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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: ,, 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 )
[
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 ;
call
] with-client ; inline
-: crlf "\r\n" write ;
+: crlf ( -- ) "\r\n" write ;
: command ( string -- ) write crlf flush ;
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
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 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>
: <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?
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 )
: (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
"tty-server"
utf8 [ listener ] with-server ;
-: default-tty-server 9999 tty-server ;
+: default-tty-server ( -- ) 9999 tty-server ;
MAIN: default-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 ;
! 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 ;
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 [ drop <gadget> ] map 3 group ;
: @center 1 1 ;
: @left 0 1 ;
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
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>> [ [ dup help ] try drop ] <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
! 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 ;
-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
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
combinators.lib combinators locals math.ranges sorting ;
: (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 )
[
: 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 ;
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: url >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 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.sessions:uid">
+
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/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 html.components db.types db.tuples calendar
+http.server.dispatchers
+furnace furnace.actions furnace.auth.login furnace.boilerplate
+furnace.sessions furnace.syndication ;
+IN: webapps.blogs
+
+TUPLE: blogs < dispatcher ;
+
+: view-post-url ( id -- url )
+ number>string "$blogs/post/" prepend >url ;
+
+: view-comment-url ( parent id -- url )
+ [ view-post-url ] dip >>anchor ;
+
+: list-posts-url ( -- url )
+ URL" $blogs/" ;
+
+: user-posts-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>> ] [ drop ": " ] [ title>> ] tri 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 ;
+
+: init-posts-table ( -- ) \ post ensure-table ;
+
+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 ;
+
+: init-comments-table ( -- ) comment ensure-table ;
+
+: 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 ] v-optional ] } } validate-params ;
+
+: list-posts ( -- posts )
+ f <post> "author" value >>author
+ select-tuples [ dup id>> f <comment> 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 ;
+
+: <user-posts-action> ( -- action )
+ <page-action>
+ "author" >>rest
+ [
+ validate-author
+ list-posts "posts" set-value
+ ] >>init
+ { blogs "user-posts" } >>template ;
+
+: <user-posts-feed-action> ( -- action )
+ <feed-action>
+ [ validate-author ] >>init
+ [ "Recent Posts by " "author" value append ] >>title
+ [ list-posts ] >>entries
+ [ "author" value user-posts-url ] >>url ;
+
+: <post-feed-action> ( -- action )
+ <feed-action>
+ [ 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-values
+ ] >>init
+
+ { blogs "view-post" } >>template ;
+
+: validate-post ( -- )
+ {
+ { "title" [ v-one-line ] }
+ { "content" [ v-required ] }
+ } validate-params ;
+
+: <new-post-action> ( -- action )
+ <page-action>
+ [
+ validate-post
+ uid "author" set-value
+ ] >>validate
+
+ [
+ f <post>
+ dup { "title" "content" } deposit-slots
+ uid >>author
+ now >>date
+ [ insert-tuple ] [ entity-url <redirect> ] bi
+ ] >>submit
+
+ { blogs "new-post" } >>template ;
+
+: <edit-post-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <post> select-tuple from-object
+ ] >>init
+
+ [
+ validate-integer-id
+ validate-post
+ ] >>validate
+
+ [
+ "id" value <post> select-tuple
+ dup { "title" "content" } deposit-slots
+ [ update-tuple ] [ entity-url <redirect> ] bi
+ ] >>submit
+
+ { blogs "edit-post" } >>template ;
+
+: <delete-post-action> ( -- action )
+ <action>
+ [
+ validate-integer-id
+ { { "author" [ v-username ] } } validate-params
+ ] >>validate
+ [
+ "id" value <post> delete-tuples
+ "author" value user-posts-url <redirect>
+ ] >>submit ;
+
+: validate-comment ( -- )
+ {
+ { "parent" [ v-integer ] }
+ { "content" [ v-required ] }
+ } validate-params ;
+
+: <new-comment-action> ( -- action )
+ <action>
+
+ [
+ validate-comment
+ uid "author" set-value
+ ] >>validate
+
+ [
+ "parent" value f <comment>
+ "content" value >>content
+ uid >>author
+ now >>date
+ [ insert-tuple ] [ entity-url <redirect> ] bi
+ ] >>submit ;
+
+: <delete-comment-action> ( -- action )
+ <action>
+ [
+ validate-integer-id
+ { { "parent" [ v-integer ] } } validate-params
+ ] >>validate
+ [
+ f "id" value <comment> delete-tuples
+ "parent" value view-post-url <redirect>
+ ] >>submit ;
+
+: <blogs> ( -- dispatcher )
+ blogs new-dispatcher
+ <list-posts-action> "" add-responder
+ <list-posts-feed-action> "posts.atom" add-responder
+ <user-posts-action> "by" add-responder
+ <user-posts-feed-action> "by.atom" add-responder
+ <view-post-action> "post" add-responder
+ <post-feed-action> "post.atom" add-responder
+ <new-post-action> <protected>
+ "make a new blog post" >>description
+ "new-post" add-responder
+ <edit-post-action> <protected>
+ "edit a blog post" >>description
+ "edit-post" add-responder
+ <delete-post-action> <protected>
+ "delete a blog post" >>description
+ "delete-post" add-responder
+ <new-comment-action> <protected>
+ "make a comment" >>description
+ "new-comment" add-responder
+ <delete-comment-action> <protected>
+ "delete a comment" >>description
+ "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/" t:query="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:for="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:query="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:query="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:query="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:query="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:query="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:query="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:query="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:query="id">
+ <t:label t:name="author" />: <t:label t:name="title" />
+ </t:atom>
+
+ <t:atom t:href="$blogs/by.atom" t:query="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:query="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/edit-post" t:query="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">
+ Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+ </p>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" />
+ </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>
http.server
http.server.dispatchers
furnace.db
-furnace.flows
+furnace.asides
+furnace.flash
furnace.sessions
furnace.auth.login
furnace.auth.providers.db
furnace.boilerplate
+webapps.blogs
webapps.pastebin
webapps.planet
webapps.todo
webapps.wiki
+webapps.wee-url
webapps.user-admin ;
IN: webapps.factor-website
-: test-db "resource:test.db" sqlite-db ;
+: test-db ( -- db params ) "resource:test.db" sqlite-db ;
: init-factor-db ( -- )
test-db [
init-articles-table
init-revisions-table
+
+ init-postings-table
+ init-comments-table
+
+ init-short-url-table
] with-db ;
TUPLE: factor-website < dispatcher ;
: <factor-website> ( -- responder )
- factor-website new-dispatcher
+ 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
<login>
users-in-db >>users
allow-edit-profile
<boilerplate>
{ factor-website "page" } >>template
- <flows>
- <sessions>
+ <asides> <flash-scopes> <sessions>
test-db <db-persistence> ;
: init-factor-website ( -- )
<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: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:a t:href="$login/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/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.components
html.templates.chloe
furnace.auth
furnace.auth.login
furnace.boilerplate
-furnace.rss ;
+furnace.syndication ;
IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
{ "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-link ( id -- url )
- <url>
- "$pastebin/paste" >>path
- swap "id" set-query-param ;
+: paste-url ( id -- url )
+ "$pastebin/paste" >url 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
{ 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 ( -- )
{
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
- [ id>> paste-link <redirect> ]
+ [ id>> paste-url <redirect> ]
tri
] >>submit ;
: <new-annotation-action> ( -- action )
<action>
[
- { { "id" [ v-integer ] } } validate-params
- "id" value paste-link <redirect>
- ] >>display
-
- [
- { { "id" [ v-integer ] } } validate-params
+ { { "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 ;
[
f "id" value <annotation> select-tuple
[ delete-tuples ]
- [ parent>> paste-link <redirect> ]
+ [ parent>> paste-url <redirect> ]
bi
] >>submit ;
<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> <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities "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> <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
-: init-pastes-table \ paste ensure-table ;
+: init-pastes-table ( -- ) \ paste ensure-table ;
-: init-annotations-table annotation 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: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:a t:href="$login/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/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
html.components
-rss urls xml.writer
+syndication urls xml.writer
validators
http.server
http.server.dispatchers
furnace.boilerplate
furnace.auth.login
furnace.auth
-furnace.rss ;
+furnace.syndication ;
IN: webapps.planet
TUPLE: planet-factor < dispatcher ;
{ "feed-url" "FEEDURL" { VARCHAR 256 } +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" { VARCHAR 256 } +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-blog-table ( -- ) blog ensure-table ;
-: init-postings-table posting ensure-table ;
+: init-postings-table ( -- ) posting ensure-table ;
: <blog> ( id -- todo )
blog new
: 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 [
: <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> <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities
+ "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>
{ "description" "DESCRIPTION" { VARCHAR 256 } }
} define-persistent
-: init-todo-table todo ensure-table ;
+: init-todo-table ( -- ) todo ensure-table ;
: <todo> ( id -- todo )
todo new
{ "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
+ [ 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
+ [ 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/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:a t:href="$login/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/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
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
[ from-object ]
[ capabilities>> [ "true" swap word>string set-value ] each ] bi
- capabilities get words>strings "capabilities" set-value
+ init-capabilities
] >>init
{ user-admin "edit-user" } >>template
<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/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:a t:href="$login/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/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 http http.server.dispatchers furnace
+furnace.actions furnace.boilerplate ;
+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
+
+: init-short-url-table ( -- )
+ short-url ensure-table ;
+
+: 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 [ drop letter-bank random ] "" map-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="changes">
<li>
- <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
+ <t:a t:href="view" 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:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/revisions.atom" t:query="title">
+ Revisions of <t:label t:name="title" />
+ </t:atom>
+
<t:call-next-template />
<div class="navbar">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/user-edits.atom" t:query="author">
+ Edits by <t:label t:name="author" />
+ </t:atom>
+
<t:title>Edits by <t:label t:name="author" /></t:title>
<ul>
<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: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:a t:href="$login/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/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order
-html.components
+html.components syndication
http.server
http.server.dispatchers
furnace
furnace.auth
furnace.auth.login
furnace.boilerplate
+furnace.syndication
validators
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
+: view-url ( title -- url )
+ "$wiki/view/" prepend >url ;
+
+: edit-url ( title -- url )
+ "$wiki/edit" >url swap "title" set-query-param ;
+
+: revisions-url ( title -- url )
+ "$wiki/revisions" >url swap "title" set-query-param ;
+
+: revision-url ( id -- url )
+ "$wiki/revision" >url swap "id" set-query-param ;
+
+: user-edits-url ( author -- url )
+ "$wiki/user-edits" >url swap "author" set-query-param ;
+
TUPLE: wiki < dispatcher ;
TUPLE: article title revision ;
: <article> ( title -- article ) article new swap >>title ;
-: init-articles-table article ensure-table ;
+: init-articles-table ( -- ) article ensure-table ;
TUPLE: revision id title author date content ;
{ "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 ;
+: 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 ;
: <view-article-action> ( -- action )
<action>
- "title" >>rest-param
+ "title" >>rest
[
validate-title
revision>> <revision> select-tuple 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" [ v-integer ] } } validate-params
+ validate-integer-id
"id" value <revision>
select-tuple from-object
+ "view?title=" relative-link-prefix set
] >>init
{ wiki "view" } >>template ;
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
+ [ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
+: list-revisions ( -- seq )
+ f <revision> "title" value >>title select-tuples
+ reverse-chronological-order ;
+
: <list-revisions-action> ( -- action )
<page-action>
[
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>
+ [ 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 )
+ "id" value <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
{ wiki "articles" } >>template ;
+: list-user-edits ( -- seq )
+ f <revision> "author" value >>author select-tuples
+ reverse-chronological-order ;
+
: <user-edits-action> ( -- action )
<page-action>
[
- { { "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>
+ [ validate-author ] >>init
+ [ "Edits by " "author" value append ] >>title
+ [ "author" value user-edits-url ] >>url
+ [ list-user-edits ] >>entries ;
+
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
+: <article-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { wiki "page-common" } >>template ;
+
: <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> <protected>
+ "edit wiki articles" >>description
+ "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> <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities
+ "delete" add-responder
<boilerplate>
{ wiki "wiki-common" } >>template ;
-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: alien alien.c-types kernel windows.ole32 combinators.lib
-parser splitting sequences.lib sequences namespaces assocs
-quotations shuffle accessors words macros alien.syntax fry ;
+parser splitting grouping sequences.lib sequences namespaces
+assocs quotations shuffle accessors words macros alien.syntax
+fry ;
IN: windows.com.syntax
<PRIVATE
! 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
: 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 )
[
-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 )
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-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 rule-body-token prev-token,
rule-match-token* next-token, ;
-: do-escaped
+: do-escaped ( -- )
escaped? get [
escaped? off
! ...
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
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry
- define ; parsing
+ (( tag -- )) define-declared ; 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." } ;
"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))
projects / factor.git / commitdiff