[ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- )
- dup [ swap interval>> time+ ] change-time register-alarm ;
+ dup [ swap interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]
USING: help help.topics help.syntax help.crossref
help.definitions io io.files kernel namespaces vocabs sequences
-parser vocabs.loader ;
+parser vocabs.loader vocabs.loader.private accessors assocs ;
IN: bootstrap.help
: load-help ( -- )
t load-help? set-global
[ drop ] load-vocab-hook [
- vocabs
- [ vocab-docs-loaded? not ] filter
+ dictionary get values
+ [ docs-loaded?>> not ] filter
[ load-docs ] each
] with-variable ;
SYMBOL: jit-primitive
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
-SYMBOL: jit-push-literal
SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
-SYMBOL: jit-if-jump
+SYMBOL: jit-if-1
+SYMBOL: jit-if-2
SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch
+SYMBOL: jit-dip-word
+SYMBOL: jit-dip
+SYMBOL: jit-2dip-word
+SYMBOL: jit-2dip
+SYMBOL: jit-3dip-word
+SYMBOL: jit-3dip
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
! Default definition for undefined words
SYMBOL: undefined-quot
-: userenv-offset ( symbol -- n )
- {
+: userenvs ( -- assoc )
+ H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
{ jit-code-format 22 }
{ jit-primitive 25 }
{ jit-word-jump 26 }
{ jit-word-call 27 }
- { jit-push-literal 28 }
- { jit-if-word 29 }
- { jit-if-jump 30 }
+ { jit-if-word 28 }
+ { jit-if-1 29 }
+ { jit-if-2 30 }
{ jit-dispatch-word 31 }
{ jit-dispatch 32 }
{ jit-epilog 33 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
{ jit-save-stack 43 }
+ { jit-dip-word 44 }
+ { jit-dip 45 }
+ { jit-2dip-word 46 }
+ { jit-2dip 47 }
+ { jit-3dip-word 48 }
+ { jit-3dip 49 }
{ undefined-quot 60 }
- } at header-size + ;
+ } ; inline
+
+: userenv-offset ( symbol -- n )
+ userenvs at header-size + ;
: emit ( cell -- ) image get push ;
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
\ declare jit-declare-word set
+ \ dip jit-dip-word set
+ \ 2dip jit-2dip-word set
+ \ 3dip jit-3dip-word set
[ undefined ] undefined-quot set
{
jit-code-format
jit-primitive
jit-word-jump
jit-word-call
- jit-push-literal
jit-push-immediate
jit-if-word
- jit-if-jump
+ jit-if-1
+ jit-if-2
jit-dispatch-word
jit-dispatch
+ jit-dip-word
+ jit-dip
+ jit-2dip-word
+ jit-2dip
+ jit-3dip-word
+ jit-3dip
jit-epilog
jit-return
jit-profiling
: count-words ( pred -- )
all-words swap count number>string write ;
-: print-time ( time -- )
+: print-time ( ms -- )
1000 /i
60 /mod swap
number>string write
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
- "deploy-vocab" get [
+ "staging" get "deploy-vocab" get or [
"stage2: deployment mode" print
] [
"listener" require
{ $values { "timestamp" timestamp } }
{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
-HELP: millis>timestamp
+HELP: micros>timestamp
{ $values { "x" number } { "timestamp" timestamp } }
-{ $description "Converts a number of milliseconds into a timestamp value in GMT time." }
+{ $description "Converts a number of microseconds into a timestamp value in GMT time." }
{ $examples
{ $example "USING: accessors calendar prettyprint ;"
- "1000 millis>timestamp year>> ."
+ "1000 micros>timestamp year>> ."
"1970"
}
} ;
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
-[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
-[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
-[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
-[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
+[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
+[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
+[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
+[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
: checktime+ now dup clone [ rot time+ drop ] keep = ;
: timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ;
+: micros>timestamp ( x -- timestamp )
+ >r unix-1970 r> microseconds time+ ;
+
+: timestamp>micros ( timestamp -- n )
+ unix-1970 (time-) 1000000 * >integer ;
+
: gmt ( -- timestamp )
#! GMT time, right now
- unix-1970 millis milliseconds time+ ;
+ unix-1970 micros microseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
: since-1970 ( duration -- timestamp )
unix-1970 time+ >local-time ;
-M: timestamp sleep-until timestamp>millis sleep-until ;
+M: timestamp sleep-until timestamp>micros sleep-until ;
M: duration sleep hence sleep-until ;
\r
: (time-thread) ( -- )\r
now time get set-model\r
- 1000 sleep (time-thread) ;\r
+ 1 seconds sleep (time-thread) ;\r
\r
: time-thread ( -- )\r
[\r
[ -> filenames CF>string-array ] [ drop f ] if ;
: split-path ( path -- dir file )
- "/" last-split1 [ <NSString> ] bi@ ;
+ "/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
<NSSavePanel> dup
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
-HELP: n&&-rewrite
+HELP: n&&
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
-HELP: n||-rewrite
+HELP: n||
{ $values
- { "quots" "a sequence of quotations" } { "N" integer }
+ { "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
{ $subsection 2|| }
{ $subsection 3|| }
"Generalized combinators:"
-{ $subsection n&&-rewrite }
-{ $subsection n||-rewrite }
+{ $subsection n&& }
+{ $subsection n|| }
;
ABOUT: "combinators.short-circuit"
-
USING: kernel combinators quotations arrays sequences assocs
- locals generalizations macros fry ;
-
+locals generalizations macros fry ;
IN: combinators.short-circuit
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: n&&-rewrite ( quots N -- quot )
- quots
- [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
- map
- [ t ] [ N nnip ] 2array suffix
- '[ f _ cond ] ;
-
-MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
-MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
-MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
-MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: n||-rewrite ( quots N -- quot )
- quots
- [ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
- map
- [ drop N ndrop t ] [ f ] 2array suffix
- '[ f _ cond ] ;
-
-MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
-MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
-MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
-MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MACRO:: n&& ( quots n -- quot )
+ [ f ]
+ quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
+ [ n nnip ] suffix 1array
+ [ cond ] 3append ;
+
+MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
+MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
+MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
+MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
+
+MACRO:: n|| ( quots n -- quot )
+ [ f ]
+ quots
+ [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
+ { [ drop n ndrop t ] [ f ] } suffix 1array
+ [ cond ] 3append ;
+
+MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
+MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
+MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
+MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
-
USING: kernel sequences math stack-checker effects accessors macros
- combinators.short-circuit ;
-
+fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
PRIVATE>
-MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
+MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
-MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
+MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
-M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##string-nth defs-vregs dst/tmp-vregs ;
+M: ##compare defs-vregs dst/tmp-vregs ;
+M: ##compare-imm defs-vregs dst/tmp-vregs ;
+M: ##compare-float defs-vregs dst/tmp-vregs ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
-INSN: ##compare < ##binary cc ;
-INSN: ##compare-imm < ##binary-imm cc ;
+INSN: ##compare < ##binary cc temp ;
+INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
-INSN: ##compare-float < ##binary cc ;
+INSN: ##compare-float < ##binary cc temp ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math fry
+compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
- f \ ##compare-imm boa ;
+ i f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
- cc= f \ ##compare-imm boa ;
+ cc= f i \ ##compare-imm boa ;
M: ##compare rewrite
dup flip-comparison? [
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< f \ ##compare boa ] }
- { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
- { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+ { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
+ { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
+ { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test kernel math ;
+compiler.cfg.registers cpu.architecture tools.test kernel math
+combinators.short-circuit accessors sequences ;
+
+: trim-temps ( insns -- insns )
+ [
+ dup {
+ [ ##compare? ]
+ [ ##compare-imm? ]
+ [ ##compare-float? ]
+ } 1|| [ f >>temp ] when
+ ] map ;
+
[
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 }
- } value-numbering
+ } value-numbering trim-temps
] unit-test
[
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 }
- } value-numbering
+ } value-numbering trim-temps
] unit-test
[
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 }
- } value-numbering
+ } value-numbering trim-temps
] unit-test
[
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
- } value-numbering
+ } value-numbering trim-temps
] unit-test
M: _branch generate-insn
label>> lookup-label %jump-label ;
-: >compare< ( insn -- label cc src1 src2 )
+: >compare< ( insn -- dst temp cc src1 src2 )
{
[ dst>> register ]
+ [ temp>> register ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
-: rel-literal ( literal class -- )
- >r add-literal r> rt-literal rel-fixup ;
+: rel-immediate ( literal class -- )
+ >r add-literal r> rt-immediate rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
[
dup crossref?
[
- dependencies get >alist
- generic-dependencies get >alist
+ dependencies get
+ generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
! Relocation types
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
-: rt-literal 2 ; inline
-: rt-dispatch 3 ; inline
-: rt-xt 4 ; inline
-: rt-here 5 ; inline
-: rt-label 6 ; inline
-: rt-immediate 7 ; inline
-: rt-stack-chain 8 ; inline
+: rt-dispatch 2 ; inline
+: rt-xt 3 ; inline
+: rt-here 4 ; inline
+: rt-label 5 ; inline
+: rt-immediate 6 ; inline
+: rt-stack-chain 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
- "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+ "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
-combinators vectors float-arrays ;
+combinators vectors float-arrays grouping make ;
IN: compiler.tests
! Originally, this file did black box testing of templating
[ "a" ] [ 1 test-2 ] unit-test
[ "b" ] [ 2 test-2 ] unit-test
+
+! I accidentally fixnum/i-fast on PowerPC
+[ { { 1 2 } { 3 4 } } ] [
+ { 1 2 3 4 }
+ [
+ [ { array } declare 2 <groups> [ , ] each ] compile-call
+ ] { } make
+] unit-test
+
+[ 2 ] [
+ { 1 2 3 4 }
+ [ { array } declare 2 <groups> length ] compile-call
+] unit-test
[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
+[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
+[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
+[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
+[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
+
[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
HINTS: recursive-inline-hang-3 array ;
! Regression
-USE: sequences.private
-
-[ ] [ { (3append) } compile ] unit-test
+[ ] [ { 3append-as } compile ] unit-test
! Wow
: counter-example ( a b c d -- a' b' c' d' )
--- /dev/null
+USING: math fry macros eval tools.test ;
+IN: compiler.tests.redefine13
+
+: breakage-word ( a b -- c ) + ;
+
+MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ;
+
+GENERIC: breakage-caller ( a -- c )
+
+M: fixnum breakage-caller 2 breakage-macro ;
+
+: breakage ( -- obj ) 2 breakage-caller ;
+
+! [ ] [ "IN: compiler.tests.redefine13 : breakage-word ( a b -- c ) ;" eval ] unit-test
--- /dev/null
+USING: compiler.units definitions tools.test sequences ;
+IN: compiler.tests.redefine14
+
+! TUPLE: bad ;
+!
+! M: bad length 1 2 3 ;
+!
+! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
-namespaces sequences words combinators combinators.short-circuit
+namespaces sequences words combinators
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
{ [ over not ] [ 2drop f ] }
[
{
- [ [ class>> ] bi@ class<= ]
- [ [ interval>> ] bi@ interval-subset? ]
- [ literals<= ]
- [ [ length>> ] bi@ value-info<= ]
- [ [ slots>> ] bi@ [ value-info<= ] 2all? ]
- } 2&&
+ { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
+ { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
+ { [ 2dup literals<= not ] [ f ] }
+ { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
+ { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
+ [ t ]
+ } cond 2nip
]
} cond ;
: word-flat-length ( word -- n )
{
+ ! special-case
+ { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! recursive and inline
\r
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test\r
\r
-[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test\r
+[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test\r
\r
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
[ error>> "Even" = ] must-fail-with\r
IN: concurrency.flags.tests\r
USING: tools.test concurrency.flags concurrency.combinators\r
-kernel threads locals accessors ;\r
+kernel threads locals accessors calendar ;\r
\r
:: flag-test-1 ( -- )\r
[let | f [ <flag> ] |\r
\r
:: flag-test-2 ( -- )\r
[let | f [ <flag> ] |\r
- [ 1000 sleep f raise-flag ] "Flag test" spawn drop\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
f lower-flag\r
f value>>\r
] ;\r
\r
:: flag-test-5 ( -- )\r
[let | f [ <flag> ] |\r
- [ 1000 sleep f raise-flag ] "Flag test" spawn drop\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
f wait-for-flag\r
f value>>\r
] ;\r
\r
[ ] [\r
{ 1 2 } <flag>\r
- [ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ]\r
+ [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]\r
[ [ wait-for-flag drop ] curry parallel-each ] bi\r
] unit-test\r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: concurrency.promises concurrency.messaging kernel arrays\r
-continuations help.markup help.syntax quotations ;\r
+continuations help.markup help.syntax quotations calendar ;\r
IN: concurrency.futures\r
\r
HELP: future\r
"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;\r
\r
HELP: ?future-timeout\r
-{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } }\r
-{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to " { $snippet "timeout" } " milliseconds." }\r
+{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }\r
+{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." }\r
{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;\r
\r
HELP: ?future\r
c await\r
l [\r
4 v push\r
- 1000 sleep\r
+ 1 seconds sleep\r
5 v push\r
] with-write-lock\r
c'' count-down\r
l [\r
1 v push\r
c count-down\r
- 1000 sleep\r
+ 1 seconds sleep\r
2 v push\r
] with-write-lock\r
c' count-down\r
\r
HELP: ?promise-timeout\r
{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }\r
-{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." }\r
+{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." }\r
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;\r
\r
HELP: ?promise\r
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel threads init namespaces alien
-core-foundation ;
+core-foundation calendar ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
- kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
+ kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
-HOOK: %compare cpu ( dst cc src1 src2 -- )
-HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
-HOOK: %compare-float cpu ( dst cc src1 src2 -- )
+HOOK: %compare cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
\r
[\r
0 6 LOAD32\r
- 6 dup 0 LWZ\r
11 6 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
11 6 profile-count-offset STW\r
11 11 compiled-header-size ADDI\r
11 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define\r
+] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define\r
\r
[\r
0 6 LOAD32\r
0 1 lr-save stack-frame + STW\r
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define\r
\r
-[\r
- 0 6 LOAD32\r
- 6 dup 0 LWZ\r
- 6 ds-reg 4 STWU\r
-] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define\r
-\r
[\r
0 6 LOAD32\r
6 ds-reg 4 STWU\r
\r
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
\r
-: jit-call-quot ( -- )\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 0 3 \ f tag-number CMPI\r
+ 2 BEQ\r
+ 0 B\r
+] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define\r
+\r
+[\r
+ 0 B\r
+] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define\r
+\r
+: jit-jump-quot ( -- )\r
4 3 quot-xt-offset LWZ\r
4 MTCTR\r
BCTR ;\r
[\r
0 3 LOAD32\r
6 ds-reg 0 LWZ\r
- 0 6 \ f tag-number CMPI\r
- 2 BNE\r
- 3 3 4 ADDI\r
- 3 3 0 LWZ\r
- ds-reg dup 4 SUBI\r
- jit-call-quot\r
-] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define\r
-\r
-[\r
- 0 3 LOAD32\r
- 3 3 0 LWZ\r
- 6 ds-reg 0 LWZ\r
6 6 1 SRAWI\r
3 3 6 ADD\r
3 3 array-start-offset LWZ\r
ds-reg dup 4 SUBI\r
- jit-call-quot\r
-] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
+ jit-jump-quot\r
+] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define\r
+\r
+: jit->r ( -- )\r
+ 4 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 rs-reg 4 STWU ;\r
+\r
+: jit-2>r ( -- )\r
+ 4 ds-reg 0 LWZ\r
+ 5 ds-reg -4 LWZ\r
+ ds-reg dup 8 SUBI\r
+ rs-reg dup 8 ADDI\r
+ 4 rs-reg 0 STW\r
+ 5 rs-reg -4 STW ;\r
+\r
+: jit-3>r ( -- )\r
+ 4 ds-reg 0 LWZ\r
+ 5 ds-reg -4 LWZ\r
+ 6 ds-reg -8 LWZ\r
+ ds-reg dup 12 SUBI\r
+ rs-reg dup 12 ADDI\r
+ 4 rs-reg 0 STW\r
+ 5 rs-reg -4 STW\r
+ 6 rs-reg -8 STW ;\r
+\r
+: jit-r> ( -- )\r
+ 4 rs-reg 0 LWZ\r
+ rs-reg dup 4 SUBI\r
+ 4 ds-reg 4 STWU ;\r
+\r
+: jit-2r> ( -- )\r
+ 4 rs-reg 0 LWZ\r
+ 5 rs-reg -4 LWZ\r
+ rs-reg dup 8 SUBI\r
+ ds-reg dup 8 ADDI\r
+ 4 ds-reg 0 STW\r
+ 5 ds-reg -4 STW ;\r
+\r
+: jit-3r> ( -- )\r
+ 4 rs-reg 0 LWZ\r
+ 5 rs-reg -4 LWZ\r
+ 6 rs-reg -8 LWZ\r
+ rs-reg dup 12 SUBI\r
+ ds-reg dup 12 ADDI\r
+ 4 ds-reg 0 STW\r
+ 5 ds-reg -4 STW\r
+ 6 ds-reg -8 STW ;\r
+\r
+[\r
+ jit->r\r
+ 0 BL\r
+ jit-r>\r
+] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define\r
+\r
+[\r
+ jit-2>r\r
+ 0 BL\r
+ jit-2r>\r
+] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define\r
+\r
+[\r
+ jit-3>r\r
+ 0 BL\r
+ jit-3r>\r
+] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define\r
\r
[\r
0 1 lr-save stack-frame + LWZ\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- jit-call-quot\r
+ jit-jump-quot\r
] f f f \ (call) define-sub-primitive\r
\r
[\r
4 ds-reg 0 STW\r
] f f f \ -rot define-sub-primitive\r
\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 3 rs-reg 4 STWU\r
-] f f f \ >r define-sub-primitive\r
+[ jit->r ] f f f \ >r define-sub-primitive\r
\r
-[\r
- 3 rs-reg 0 LWZ\r
- rs-reg dup 4 SUBI\r
- 3 ds-reg 4 STWU\r
-] f f f \ r> define-sub-primitive\r
+[ jit-r> ] f f f \ r> define-sub-primitive\r
\r
! Comparisons\r
: jit-compare ( insn -- )\r
0 3 LOAD32\r
- 3 3 0 LWZ\r
4 ds-reg 0 LWZ\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
3 ds-reg 0 STW ;\r
\r
: define-jit-compare ( insn word -- )\r
- [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip\r
+ [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip\r
define-sub-primitive ;\r
\r
\ BEQ \ eq? define-jit-compare\r
ds-reg ds-reg 4 SUBI\r
4 ds-reg 0 LWZ\r
5 4 3 DIVW\r
+ 5 5 tag-bits get SLWI\r
5 ds-reg 0 STW\r
] f f f \ fixnum/i-fast define-sub-primitive\r
\r
5 4 3 DIVW\r
6 5 3 MULLW\r
7 6 4 SUBF\r
+ 5 5 tag-bits get SLWI\r
5 ds-reg -4 STW\r
7 ds-reg 0 STW\r
-] f f f \ fixnum-/mod-fast define-sub-primitive\r
+] f f f \ fixnum/mod-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
-M:: ppc %load-indirect ( reg obj -- )
- 0 reg LOAD32
- obj rc-absolute-ppc-2/2 rel-literal
- reg reg 0 LWZ ;
+M: ppc %load-indirect ( reg obj -- )
+ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
: ds-reg 29 ; inline
: rs-reg 30 ; inline
1 1 rot ADDI
0 MTLR ;
-:: (%boolean) ( dst word -- )
+:: (%boolean) ( dst temp word -- )
"end" define-label
dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
-: %boolean ( dst cc -- )
+: %boolean ( dst temp cc -- )
negate-cc {
{ cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] }
[ [ align-sub ] [ call ] bi* ]
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
-M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
-
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
: mod-arg ( -- reg ) EDX ;
: arg0 ( -- reg ) EAX ;
: arg1 ( -- reg ) EDX ;
+: arg2 ( -- reg ) ECX ;
: temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
-M: x86.64 rel-literal-x86 rc-relative rel-literal ;
-
M: x86.64 %prologue ( n -- )
temp-reg-1 0 MOV rc-absolute-cell rel-this
dup PUSH
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg0 ( -- reg ) RDI ;
: arg1 ( -- reg ) RSI ;
+: arg2 ( -- reg ) RDX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg0 ( -- reg ) RCX ;
: arg1 ( -- reg ) RDX ;
+: arg2 ( -- reg ) R8 ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
! Control flow
GENERIC: JMP ( op -- )
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
+M: f JMP (JMP) 2drop ;
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) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: f CALL (CALL) 2drop ;
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) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
+M: f JUMPcc nip (JUMPcc) drop ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
[
! Load word
temp-reg 0 MOV
- temp-reg dup [] MOV
! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
temp-reg compiled-header-size ADD
! Jump to XT
temp-reg JMP
-] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define
+] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
[
temp-reg 0 MOV ! load XT
stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
-[
- arg0 0 MOV ! load literal
- arg0 dup [] MOV
- ds-reg bootstrap-cell ADD ! increment datastack pointer
- ds-reg [] arg0 MOV ! store literal on datastack
-] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
-
[
arg0 0 MOV ! load literal
ds-reg bootstrap-cell ADD ! increment datastack pointer
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[
- (JMP) drop
+ f JMP
] rc-relative rt-xt 1 jit-word-jump jit-define
[
- (CALL) drop
+ f CALL
] rc-relative rt-xt 1 jit-word-call jit-define
[
- arg1 0 MOV ! load addr of true quotation
arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean
- 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-offset [+] JMP ! jump to quotation-xt
-] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
+ arg0 \ f tag-number CMP ! compare boolean with f
+ f JNE ! jump to true branch if not equal
+] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
+
+[
+ f JMP ! jump to false branch if equal
+] rc-relative rt-xt 1 jit-if-2 jit-define
[
arg1 0 MOV ! load dispatch table
- arg1 dup [] MOV
arg0 ds-reg [] MOV ! load index
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-offset [+] MOV ! load quotation
arg0 quot-xt-offset [+] JMP ! execute branch
-] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
+] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
+
+: jit->r ( -- )
+ rs-reg bootstrap-cell ADD
+ arg0 ds-reg [] MOV
+ ds-reg bootstrap-cell SUB
+ rs-reg [] arg0 MOV ;
+
+: jit-2>r ( -- )
+ rs-reg 2 bootstrap-cells ADD
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg 2 bootstrap-cells SUB
+ rs-reg [] arg0 MOV
+ rs-reg -1 bootstrap-cells [+] arg1 MOV ;
+
+: jit-3>r ( -- )
+ rs-reg 3 bootstrap-cells ADD
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ arg2 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg 3 bootstrap-cells SUB
+ rs-reg [] arg0 MOV
+ rs-reg -1 bootstrap-cells [+] arg1 MOV
+ rs-reg -2 bootstrap-cells [+] arg2 MOV ;
+
+: jit-r> ( -- )
+ ds-reg bootstrap-cell ADD
+ arg0 rs-reg [] MOV
+ rs-reg bootstrap-cell SUB
+ ds-reg [] arg0 MOV ;
+
+: jit-2r> ( -- )
+ ds-reg 2 bootstrap-cells ADD
+ arg0 rs-reg [] MOV
+ arg1 rs-reg -1 bootstrap-cells [+] MOV
+ rs-reg 2 bootstrap-cells SUB
+ ds-reg [] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV ;
+
+: jit-3r> ( -- )
+ ds-reg 3 bootstrap-cells ADD
+ arg0 rs-reg [] MOV
+ arg1 rs-reg -1 bootstrap-cells [+] MOV
+ arg2 rs-reg -2 bootstrap-cells [+] MOV
+ rs-reg 3 bootstrap-cells SUB
+ ds-reg [] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] arg2 MOV ;
+
+[
+ jit->r
+ f CALL
+ jit-r>
+] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
+
+[
+ jit-2>r
+ f CALL
+ jit-2r>
+] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
+
+[
+ jit-3>r
+ f CALL
+ jit-3r>
+] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
ds-reg [] arg1 MOV
] f f f \ -rot define-sub-primitive
-[
- rs-reg bootstrap-cell ADD
- arg0 ds-reg [] MOV
- ds-reg bootstrap-cell SUB
- rs-reg [] arg0 MOV
-] f f f \ >r define-sub-primitive
+[ jit->r ] f f f \ >r define-sub-primitive
-[
- ds-reg bootstrap-cell ADD
- arg0 rs-reg [] MOV
- rs-reg bootstrap-cell SUB
- ds-reg [] arg0 MOV
-] f f f \ r> define-sub-primitive
+[ jit-r> ] f f f \ r> define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
- arg1 0 MOV ! load t
- arg1 dup [] MOV
- temp-reg \ f tag-number MOV ! load f
+ temp-reg 0 MOV ! load t
+ arg1 \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
;
: define-jit-compare ( insn word -- )
- [ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip
+ [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
define-sub-primitive ;
-\ CMOVNE \ eq? define-jit-compare
-\ CMOVL \ fixnum>= define-jit-compare
-\ CMOVG \ fixnum<= define-jit-compare
-\ CMOVLE \ fixnum> define-jit-compare
-\ CMOVGE \ fixnum< define-jit-compare
+\ CMOVE \ eq? define-jit-compare
+\ CMOVGE \ fixnum>= define-jit-compare
+\ CMOVLE \ fixnum<= define-jit-compare
+\ CMOVG \ fixnum> define-jit-compare
+\ CMOVL \ fixnum< define-jit-compare
! Math
: jit-math ( insn -- )
ds-reg [] arg1 MOV ! push to stack
] f f f \ fixnum-shift-fast define-sub-primitive
-: jit-fixnum-/mod
+: jit-fixnum-/mod ( -- )
temp-reg ds-reg [] MOV ! load second parameter
div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
mod-arg div-arg MOV ! make a copy
M: x86 %load-immediate MOV ;
-HOOK: rel-literal-x86 cpu ( literal -- )
-
-M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
+M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
-: %boolean ( dst word -- )
- over \ f tag-number MOV
- 0 [] swap execute
- \ t rel-literal-x86 ; inline
+:: %boolean ( dst temp word -- )
+ dst \ f tag-number MOV
+ temp 0 MOV \ t rc-absolute-cell rel-immediate
+ dst temp word execute ; inline
-M: x86 %compare ( dst cc src1 src2 -- )
+M: x86 %compare ( dst temp cc src1 src2 -- )
CMP {
{ cc< [ \ CMOVL %boolean ] }
{ cc<= [ \ CMOVLE %boolean ] }
{ cc/= [ \ CMOVNE %boolean ] }
} case ;
-M: x86 %compare-imm ( dst cc src1 src2 -- )
+M: x86 %compare-imm ( dst temp cc src1 src2 -- )
%compare ;
-M: x86 %compare-float ( dst cc src1 src2 -- )
+M: x86 %compare-float ( dst temp cc src1 src2 -- )
UCOMISD {
{ cc< [ \ CMOVB %boolean ] }
{ cc<= [ \ CMOVBE %boolean ] }
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
-db.tuples db.types unicode.case accessors ;
+db.tuples db.types unicode.case accessors system ;
IN: db.postgresql.tests
: test-db ( -- postgresql-db )
"thepasswordistrust" >>password
"factor-test" >>database ;
-[ ] [ test-db [ ] with-db ] unit-test
+os windows? cpu x86.64? and [
+ [ ] [ test-db [ ] with-db ] unit-test
-[ ] [
- test-db [
- [ "drop table person;" sql-command ] ignore-errors
- "create table person (name varchar(30), country varchar(30));"
- sql-command
+ [ ] [
+ test-db [
+ [ "drop table person;" sql-command ] ignore-errors
+ "create table person (name varchar(30), country varchar(30));"
+ sql-command
- "insert into person values('John', 'America');" sql-command
- "insert into person values('Jane', 'New Zealand');" sql-command
- ] with-db
-] unit-test
+ "insert into person values('John', 'America');" sql-command
+ "insert into person values('Jane', 'New Zealand');" sql-command
+ ] with-db
+ ] unit-test
-[
- {
- { "John" "America" }
- { "Jane" "New Zealand" }
- }
-] [
- test-db [
- "select * from person" sql-query
- ] with-db
-] unit-test
+ [
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+ ] [
+ test-db [
+ "select * from person" sql-query
+ ] with-db
+ ] unit-test
-[
- {
- { "John" "America" }
- { "Jane" "New Zealand" }
- }
-] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+ [
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+ ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
-[
-] [
- test-db [
- "insert into person(name, country) values('Jimmy', 'Canada')"
- sql-command
- ] with-db
-] unit-test
+ [
+ ] [
+ test-db [
+ "insert into person(name, country) values('Jimmy', 'Canada')"
+ sql-command
+ ] with-db
+ ] unit-test
-[
- {
- { "John" "America" }
- { "Jane" "New Zealand" }
- { "Jimmy" "Canada" }
- }
-] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+ [
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ { "Jimmy" "Canada" }
+ }
+ ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
-[
- test-db [
- [
- "insert into person(name, country) values('Jose', 'Mexico')" sql-command
- "insert into person(name, country) values('Jose', 'Mexico')" sql-command
- "oops" throw
- ] with-transaction
- ] with-db
-] must-fail
+ [
+ test-db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "oops" throw
+ ] with-transaction
+ ] with-db
+ ] must-fail
-[ 3 ] [
- test-db [
- "select * from person" sql-query length
- ] with-db
-] unit-test
+ [ 3 ] [
+ test-db [
+ "select * from person" sql-query length
+ ] with-db
+ ] unit-test
-[
-] [
- test-db [
- [
- "insert into person(name, country) values('Jose', 'Mexico')"
- sql-command
- "insert into person(name, country) values('Jose', 'Mexico')"
- sql-command
- ] with-transaction
- ] with-db
-] unit-test
+ [
+ ] [
+ test-db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ ] with-transaction
+ ] with-db
+ ] unit-test
-[ 5 ] [
- test-db [
- "select * from person" sql-query length
- ] with-db
-] unit-test
+ [ 5 ] [
+ test-db [
+ "select * from person" sql-query length
+ ] with-db
+ ] unit-test
+] unless
: with-dummy-db ( quot -- )
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitwise
+db.postgresql accessors random math.bitwise system
math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests
: test-postgresql ( quot -- )
'[
- [ ] [ postgresql-db _ with-db ] unit-test
+ os windows? cpu x86.64? and [
+ [ ] [ postgresql-db _ with-db ] unit-test
+ ] unless
] call ; inline
! These words leak resources, but are useful for interactivel testing
M: no-case summary
drop "Fall-through in case" ;
-M: slice-error error.
- "Cannot create slice because " write
- reason>> print ;
+M: slice-error summary
+ drop "Cannot create slice" ;
M: bounds-error summary drop "Sequence index out of bounds" ;
math.order ;
IN: documents
-: +col ( loc n -- newloc ) >r first2 r> + 2array ;
+: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
-: +line ( loc n -- newloc ) >r first2 swap r> + swap 2array ;
+: +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
: =col ( n loc -- newloc ) first swap 2array ;
: doc-line ( n document -- string ) value>> nth ;
: doc-lines ( from to document -- slice )
- >r 1+ r> value>> <slice> ;
+ [ 1+ ] dip value>> <slice> ;
: start-on-line ( document from line# -- n1 )
- >r dup first r> = [ nip second ] [ 2drop 0 ] if ;
+ [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
: end-on-line ( document to line# -- n2 )
over first over = [
2over = [
3drop
] [
- >r [ first ] bi@ 1+ dup <slice> r> each
+ [ [ first ] bi@ 1+ dup <slice> ] dip each
] if ; inline
: start/end-on-line ( from to line# -- n1 n2 )
- tuck >r >r document get -rot start-on-line r> r>
- document get -rot end-on-line ;
+ tuck
+ [ [ document get ] 2dip start-on-line ]
+ [ [ document get ] 2dip end-on-line ]
+ 2bi* ;
: (doc-range) ( from to line# -- )
[ start/end-on-line ] keep document get doc-line <slice> , ;
: doc-range ( from to document -- string )
[
document set 2dup [
- >r 2dup r> (doc-range)
+ [ 2dup ] dip (doc-range)
] each-line 2drop
] { } make "\n" join ;
: text+loc ( lines loc -- loc )
- over >r over length 1 = [
- nip first2
- ] [
- first swap length 1- + 0
- ] if r> peek length + 2array ;
+ over [
+ over length 1 = [
+ nip first2
+ ] [
+ first swap length 1- + 0
+ ] if
+ ] dip peek length + 2array ;
: prepend-first ( str seq -- )
0 swap [ append ] change-nth ;
[ length 1- ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
- >r first2 swap r> nth swap ;
+ [ first2 swap ] dip nth swap ;
: prepare-insert ( newinput from to lines -- newinput )
- tuck loc-col/str tail-slice >r loc-col/str head-slice r>
+ tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
pick append-last over prepend-first ;
: (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep
- >r [ first ] bi@ 1+ r>
+ [ [ first ] bi@ 1+ ] dip
replace-slice ;
: set-doc-range ( string from to document -- )
[
- >r >r >r string-lines r> [ text+loc ] 2keep r> r>
+ [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
[ [ (set-doc-range) ] keep ] change-model
] keep update-locs ;
: remove-doc-range ( from to document -- )
- >r >r >r "" r> r> r> set-doc-range ;
+ [ "" ] 3dip set-doc-range ;
: last-line# ( document -- line )
value>> length 1- ;
dupd doc-line length 2array ;
: line-end? ( loc document -- ? )
- >r first2 swap r> doc-line length = ;
+ [ first2 swap ] dip doc-line length = ;
: doc-end ( document -- loc )
[ last-line# ] keep line-end ;
over first 0 < [
2drop { 0 0 }
] [
- >r first2 swap tuck r> validate-col 2array
+ [ first2 swap tuck ] dip validate-col 2array
] if
] if ;
value>> "\n" join ;
: set-doc-string ( string document -- )
- >r string-lines V{ } like r> [ set-model ] keep
+ [ string-lines V{ } like ] dip [ set-model ] keep
[ doc-end ] [ update-locs ] bi ;
: clear-doc ( document -- )
GENERIC: next-elt ( loc document elt -- newloc )
: prev/next-elt ( loc document elt -- start end )
- 3dup next-elt >r prev-elt r> ;
+ [ prev-elt ] [ next-elt ] 3bi ;
: elt-string ( loc document elt -- string )
- over >r prev/next-elt r> doc-range ;
+ [ prev/next-elt ] [ drop ] 2bi doc-range ;
TUPLE: char-elt ;
: (prev-char) ( loc document quot -- loc )
-rot {
{ [ over { 0 0 } = ] [ drop ] }
- { [ over second zero? ] [ >r first 1- r> line-end ] }
+ { [ over second zero? ] [ [ first 1- ] dip line-end ] }
[ pick call ]
} cond nip ; inline
M: one-char-elt next-elt 2drop ;
: (word-elt) ( loc document quot -- loc )
- pick >r
- >r >r first2 swap r> doc-line r> call
- r> =col ; inline
+ pick [
+ [ [ first2 swap ] dip doc-line ] dip call
+ ] dip =col ; inline
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
- [ >r blank? r> xor ] curry ; inline
+ [ [ blank? ] dip xor ] curry ; inline
: (prev-word) ( ? col str -- col )
rot break-detector find-last-from drop ?1+ ;
M: one-word-elt prev-elt
drop
- [ f -rot >r 1- r> (prev-word) ] (word-elt) ;
+ [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
M: one-word-elt next-elt
drop
- [ f -rot (next-word) ] (word-elt) ;
+ [ [ f ] 2dip (next-word) ] (word-elt) ;
TUPLE: word-elt ;
M: word-elt prev-elt
drop
- [ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
+ [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
(prev-char) ;
M: word-elt next-elt
2drop first 0 2array ;
M: one-line-elt next-elt
- drop >r first dup r> doc-line length 2array ;
+ drop [ first dup ] dip doc-line length 2array ;
TUPLE: line-elt ;
M: object error-line
drop f ;
-: :edit ( -- )
- error get [ error-file ] [ error-line ] bi
+: (:edit) ( error -- )
+ [ error-file ] [ error-line ] bi
2dup and [ edit-location ] [ 2drop ] if ;
+: :edit ( -- )
+ error get (:edit) ;
+
: edit-each ( seq -- )
[
[ "Editing " write . ]
--- /dev/null
+Marc Fauconneau
--- /dev/null
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 make ;
+IN: editors.notepad2
+
+: notepad2-path ( -- str )
+ \ notepad2-path get-global [
+ program-files "C:\\Windows\\system32\\notepad.exe" append-path
+ ] unless* ;
+
+: notepad2 ( file line -- )
+ [
+ notepad2-path ,
+ "/g" , number>string , ,
+ ] { } make run-detached drop ;
+
+[ notepad2 ] edit-hook set-global
\ No newline at end of file
--- /dev/null
+Notepad2 editor integration
--- /dev/null
+unportable
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
: simple-link-title ( string -- string' )
- dup absolute-url? [ "/" last-split1 swap or ] unless ;
+ dup absolute-url? [ "/" split1-last swap or ] unless ;
EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }\r
{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
+HELP: >r/r>-in-fry-error\r
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;\r
+\r
ARTICLE: "fry.examples" "Examples of fried quotations"\r
"The easiest way to understand fried quotations is to look at some examples."\r
$nl\r
} ;\r
\r
ARTICLE: "fry.limitations" "Fried quotation limitations"\r
-"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;\r
+"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."\r
+$nl\r
+"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"\r
+{ $subsection >r/r>-in-fry-error } ;\r
\r
ARTICLE: "fry" "Fried quotations"\r
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."\r
IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
-sequences ;
+sequences eval accessors ;
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
-[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
+[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
-[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
+[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
-[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
-[ [ "a" write "b" print ] ]
+[ [ "a" "b" [ write ] dip print ] ]
[ "a" "b" '[ _ write _ print ] ] unit-test
-[ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
-
[ 1/2 ] [
1 '[ [ _ ] dip / ] 2 swap call
] unit-test
[ { { { 3 } } } ] [
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
+
+[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
+[ error>> >r/r>-in-fry-error? ] must-fail-with
+
+[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
+ 1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call
+] unit-test
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math
-quotations arrays make words ;
+quotations arrays make words locals.backend summary sets ;
IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
: @ ( -- * ) "Only valid inside a fry" throw ;
+ERROR: >r/r>-in-fry-error ;
+
<PRIVATE
-DEFER: (shallow-fry)
-DEFER: shallow-fry
-
-: ((shallow-fry)) ( accum quot adder -- result )
- >r shallow-fry r>
- append swap [
- [ prepose ] curry append
- ] unless-empty ; inline
-
-: (shallow-fry) ( accum quot -- result )
- [ 1quotation ] [
- unclip {
- { \ _ [ [ curry ] ((shallow-fry)) ] }
- { \ @ [ [ compose ] ((shallow-fry)) ] }
- [ swap >r suffix r> (shallow-fry) ]
- } case
- ] if-empty ;
-
-: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
+: [ncurry] ( n -- quot )
+ {
+ { 0 [ [ ] ] }
+ { 1 [ [ curry ] ] }
+ { 2 [ [ 2curry ] ] }
+ { 3 [ [ 3curry ] ] }
+ [ \ curry <repetition> ]
+ } case ;
+
+M: >r/r>-in-fry-error summary
+ drop
+ "Explicit retain stack manipulation is not permitted in fried quotations" ;
+
+: check-fry ( quot -- quot )
+ dup { >r r> load-locals get-local drop-locals } intersect
+ empty? [ >r/r>-in-fry-error ] unless ;
+
+: shallow-fry ( quot -- quot' )
+ check-fry
+ [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
+ { _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test\r
[ ] [ { } 0 firstn ] unit-test\r
[ "a" ] [ { "a" } 1 firstn ] unit-test\r
+\r
+[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test\r
IN: generalizations\r
\r
MACRO: nsequence ( n seq -- quot )\r
- [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi\r
- [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;\r
+ [\r
+ [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi\r
+ [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce\r
+ ] keep\r
+ '[ @ _ like ] ;\r
\r
MACRO: narray ( n -- quot )\r
'[ _ { } nsequence ] ;\r
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
- [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test
+ [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
] with-file-vocabs
IN: help.handbook.tests
USING: help tools.test ;
-[ ] [ "article-index" help ] unit-test
-[ ] [ "primitive-index" help ] unit-test
-[ ] [ "error-index" help ] unit-test
-[ ] [ "type-index" help ] unit-test
-[ ] [ "class-index" help ] unit-test
+[ ] [ "article-index" print-topic ] unit-test
+[ ] [ "primitive-index" print-topic ] unit-test
+[ ] [ "error-index" print-topic ] unit-test
+[ ] [ "type-index" print-topic ] unit-test
+[ ] [ "class-index" print-topic ] unit-test
{ { "object" object } { "?" "a boolean" } } $values
[
"Tests if the object is an instance of the " ,
- first "predicating" word-prop \ $link swap 2array ,
+ first "predicating" word-prop <$link> ,
" class." ,
] { } make $description ;
append
] if ;
-M: word article-content
+<PRIVATE
+
+: (word-help) ( word -- element )
+ [
+ {
+ [ \ $vocabulary swap 2array , ]
+ [ word-help % ]
+ [ \ $related swap 2array , ]
+ [ get-global [ \ $value swap 2array , ] when* ]
+ [ \ $definition swap 2array , ]
+ } cleave
+ ] { } make ;
+
+M: word article-content (word-help) ;
+
+<PRIVATE
+
+: word-with-methods ( word -- elements )
[
- \ $vocabulary over 2array ,
- dup word-help %
- \ $related over 2array ,
- dup get-global [ \ $value swap 2array , ] when*
- \ $definition swap 2array ,
+ [ (word-help) % ]
+ [ \ $methods swap 2array , ]
+ bi
] { } make ;
+PRIVATE>
+
+M: generic article-content word-with-methods ;
+
+M: class article-content word-with-methods ;
+
M: word article-parent "help-parent" word-prop ;
M: word set-article-parent swap "help-parent" set-word-prop ;
":get ( var -- value ) accesses variables at time of the error" print
":vars - list all variables at error time" print ;
-: :help ( -- )
- error get error-help [ help ] [ "No help for this error. " print ] if*
+: (:help) ( error -- )
+ error-help [ help ] [ "No help for this error. " print ] if*
:help-debugger ;
+: :help ( -- )
+ error get (:help) ;
+
: remove-article ( name -- )
dup articles get key? [
dup unxref-article
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
-io.files html.streams html.elements html.components help kernel
+io.files html.streams html.elements help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
TUPLE: result title href ;
-M: result link-title title>> ;
-
-M: result link-href href>> ;
-
: offline-apropos ( string index -- results )
load-index swap >lower
'[ [ drop _ ] dip >lower subseq? ] assoc-filter
] each ;
: check-rendering ( word element -- )
- [ help ] with-string-writer drop ;
+ [ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
-[ ] [ \ quux>> help ] unit-test
-[ ] [ \ >>quux help ] unit-test
-[ ] [ \ blahblah? help ] unit-test
+[ ] [ \ quux>> print-topic ] unit-test
+[ ] [ \ >>quux print-topic ] unit-test
+[ ] [ \ blahblah? print-topic ] unit-test
: fooey "fooey" throw ;
-[ ] [ \ fooey help ] unit-test
+[ ] [ \ fooey print-topic ] unit-test
-[ ] [ gensym help ] unit-test
+[ ] [ gensym print-topic ] unit-test
: $see ( element -- ) first [ see ] ($see) ;
+: $see-methods ( element -- ) first [ see-methods ] ($see) ;
+
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
: $definition ( element -- )
"Definition" $heading $see ;
+: $methods ( element -- )
+ "Methods" $heading $see-methods ;
+
: $value ( object -- )
"Variable value" $heading
"Current value in global namespace:" print-element
] each
] curry each
] H{ } make-assoc keys ;
+
+: <$link> ( topic -- element )
+ \ $link swap 2array ;
: test-template ( path -- ? )
"resource:basis/html/templates/fhtml/test/"
prepend
- [
- ".fhtml" append <fhtml> [ call-template ] with-string-writer
- <string-reader> lines
- ] keep
- ".html" append utf8 file-lines
+ [ ".fhtml" append <fhtml> [ call-template ] with-string-writer ]
+ [ ".html" append utf8 file-contents ] bi
[ . . ] [ = ] 2bi ;
[ t ] [ "example" test-template ] unit-test
! See http://factorcode.org/license.txt for BSD license.\r
USING: calendar io io.files kernel math math.order\r
math.parser namespaces parser sequences strings\r
-assocs hashtables debugger mime-types sorting logging\r
+assocs hashtables debugger mime.types sorting logging\r
calendar.format accessors splitting\r
io.encodings.binary fry xml.entities destructors urls\r
html.elements html.templates.fhtml\r
USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users
-io.files.listing.private ;
+io.files.listing.private unix.stat math ;
IN: io.files.listing.unix
<PRIVATE
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
+: mode>symbol ( mode -- ch )
+ S_IFMT bitand
+ {
+ { [ dup S_IFDIR = ] [ drop "/" ] }
+ { [ dup S_IFIFO = ] [ drop "|" ] }
+ { [ dup any-execute? ] [ drop "*" ] }
+ { [ dup S_IFLNK = ] [ drop "@" ] }
+ { [ dup S_IFWHT = ] [ drop "%" ] }
+ { [ dup S_IFSOCK = ] [ drop "=" ] }
+ { [ t ] [ drop "" ] }
+ } cond ;
+
M: unix (directory.) ( path -- lines )
[ [
[
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.streams.duplex io.ports debugger prettyprint summary ;
+io.streams.duplex io.ports debugger prettyprint summary
+calendar ;
IN: io.launcher
TUPLE: process < identity-tuple
: wait-loop ( -- )
processes get assoc-empty?
[ wait-flag get-global lower-flag ]
- [ wait-for-processes [ 100 sleep ] when ] if ;
+ [ wait-for-processes [ 100 milliseconds sleep ] when ] if ;
: start-wait-thread ( -- )
<flag> wait-flag set-global
--- /dev/null
+! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
+! 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 summary
+splitting assocs random math.parser locals unicode.case openssl
+openssl.libcrypto openssl.libssl io.backend io.ports io.files
+io.encodings.8-bit io.timeouts io.sockets.secure ;
+IN: io.sockets.secure.openssl
+
+GENERIC: ssl-method ( symbol -- method )
+
+M: SSLv2 ssl-method drop SSLv2_client_method ;
+M: SSLv23 ssl-method drop SSLv23_method ;
+M: SSLv3 ssl-method drop SSLv3_method ;
+M: TLSv1 ssl-method drop TLSv1_method ;
+
+TUPLE: openssl-context < secure-context aliens sessions ;
+
+: set-session-cache ( ctx -- )
+ handle>>
+ [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
+ [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
+ bi ;
+
+: load-certificate-chain ( ctx -- )
+ dup config>> key-file>> [
+ [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
+ SSL_CTX_use_certificate_chain_file
+ ssl-error
+ ] [ drop ] if ;
+
+: password-callback ( -- alien )
+ "int" { "void*" "int" "bool" "void*" } "cdecl"
+ [| buf size rwflag password! |
+ password [ B{ 0 } password! ] unless
+
+ [let | len [ password strlen ] |
+ buf password len 1+ size min memcpy
+ len
+ ]
+ ] alien-callback ;
+
+: default-pasword ( ctx -- alien )
+ [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
+ [ push ] [ drop ] 2bi ;
+
+: set-default-password ( ctx -- )
+ [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
+ [
+ [ handle>> ] [ default-pasword ] bi
+ SSL_CTX_set_default_passwd_cb_userdata
+ ] bi ;
+
+: use-private-key-file ( ctx -- )
+ dup config>> key-file>> [
+ [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
+ SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
+ ssl-error
+ ] [ drop ] if ;
+
+: load-verify-locations ( ctx -- )
+ dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
+ [ handle>> ]
+ [
+ config>>
+ [ ca-file>> dup [ (normalize-path) ] when ]
+ [ ca-path>> dup [ (normalize-path) ] when ] bi
+ ] bi
+ SSL_CTX_load_verify_locations
+ ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
+
+: set-verify-depth ( ctx -- )
+ dup config>> verify-depth>> [
+ [ handle>> ] [ config>> verify-depth>> ] bi
+ SSL_CTX_set_verify_depth
+ ] [ drop ] if ;
+
+TUPLE: bio handle disposed ;
+
+: <bio> ( handle -- bio ) f bio boa ;
+
+M: bio dispose* handle>> BIO_free ssl-error ;
+
+: <file-bio> ( path -- bio )
+ normalize-path "r" BIO_new_file dup ssl-error <bio> ;
+
+: load-dh-params ( ctx -- )
+ dup config>> dh-file>> [
+ [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
+ handle>> f f f PEM_read_bio_DHparams dup ssl-error
+ SSL_CTX_set_tmp_dh ssl-error
+ ] [ drop ] if ;
+
+TUPLE: rsa handle disposed ;
+
+: <rsa> ( handle -- rsa ) f rsa boa ;
+
+M: rsa dispose* handle>> RSA_free ;
+
+: generate-eph-rsa-key ( ctx -- )
+ [ handle>> ]
+ [
+ config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
+ dup ssl-error <rsa> &dispose handle>>
+ ] bi
+ SSL_CTX_set_tmp_rsa ssl-error ;
+
+: <openssl-context> ( config ctx -- context )
+ openssl-context new
+ swap >>handle
+ swap >>config
+ V{ } clone >>aliens
+ H{ } clone >>sessions ;
+
+M: openssl <secure-context> ( config -- context )
+ maybe-init-ssl
+ [
+ dup method>> ssl-method SSL_CTX_new
+ dup ssl-error <openssl-context> |dispose
+ {
+ [ set-session-cache ]
+ [ load-certificate-chain ]
+ [ set-default-password ]
+ [ use-private-key-file ]
+ [ load-verify-locations ]
+ [ set-verify-depth ]
+ [ load-dh-params ]
+ [ generate-eph-rsa-key ]
+ [ ]
+ } cleave
+ ] with-destructors ;
+
+M: openssl-context dispose*
+ [ aliens>> [ free ] each ]
+ [ sessions>> values [ SSL_SESSION_free ] each ]
+ [ handle>> SSL_CTX_free ]
+ tri ;
+
+TUPLE: ssl-handle file handle connected disposed ;
+
+SYMBOL: default-secure-context
+
+: context-expired? ( context -- ? )
+ dup [ handle>> expired? ] [ drop t ] if ;
+
+: current-secure-context ( -- ctx )
+ secure-context get [
+ default-secure-context get dup context-expired? [
+ drop
+ <secure-config> <secure-context> default-secure-context set-global
+ current-secure-context
+ ] when
+ ] unless* ;
+
+: <ssl-handle> ( fd -- ssl )
+ current-secure-context handle>> SSL_new dup ssl-error
+ f f ssl-handle boa ;
+
+M: ssl-handle dispose*
+ [ handle>> SSL_free ] [ file>> dispose ] bi ;
+
+: check-verify-result ( ssl-handle -- )
+ SSL_get_verify_result dup X509_V_OK =
+ [ drop ] [ verify-message certificate-verify-error ] if ;
+
+: common-name ( certificate -- host )
+ X509_get_subject_name
+ NID_commonName 256 <byte-array>
+ [ 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 common-names-match?
+ [ 2drop ] [ common-name-verify-error ] if ;
+
+M: openssl check-certificate ( host ssl -- )
+ current-secure-context config>> verify>> [
+ handle>>
+ [ nip check-verify-result ]
+ [ check-common-name ]
+ 2bi
+ ] [ 2drop ] if ;
+
+: get-session ( addrspec -- session/f )
+ current-secure-context sessions>> at
+ dup expired? [ drop f ] when ;
+
+: save-session ( session addrspec -- )
+ current-secure-context sessions>> set-at ;
+
+openssl secure-socket-backend set-global
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups
-environment fry io.encodings.utf8 alien.strings unix.statfs ;
+environment fry io.encodings.utf8 alien.strings unix.statfs
+combinators.short-circuit ;
IN: io.unix.files
M: unix cwd ( -- path )
GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? )
+: any-read? ( obj -- ? )
+ { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
+
+: any-write? ( obj -- ? )
+ { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
+
+: any-execute? ( obj -- ? )
+ { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
+
M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ;
dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
: timestamp>timeval ( timestamp -- timeval )
- unix-1970 time- duration>milliseconds make-timeval ;
+ unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array )
[ dup [ timestamp>timeval ] when ] map make-timeval-array ;
: handle-kevents ( mx n -- )
[ over events>> kevent-nth handle-kevent ] with each ;
-M: kqueue-mx wait-for-events ( ms mx -- )
+M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ;
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
f ;
-M:: select-mx wait-for-events ( ms mx -- )
+M:: select-mx wait-for-events ( us mx -- )
mx
- [ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ]
+ [ init-fdsets us dup [ make-timeval ] when select multiplexer-error ]
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ;
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel debugger sequences namespaces math
-math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors
-openssl openssl.libcrypto openssl.libssl
-io.files io.ports io.unix.backend io.unix.sockets
-io.encodings.ascii io.buffers io.sockets io.sockets.secure
+USING: accessors unix byte-arrays kernel debugger sequences
+namespaces math math.order combinators init alien alien.c-types
+alien.strings libc continuations destructors openssl
+openssl.libcrypto openssl.libssl io.files io.ports
+io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
+io.sockets io.sockets.secure io.sockets.secure.openssl
io.timeouts system summary ;
IN: io.unix.sockets.secure
} cond
] with-timeout ;
-:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
+:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
master-completion-port get-global
0 <int> [ ! bytes
f <void*> ! key
f <void*> [ ! overlapped
- ms INFINITE or ! timeout
+ us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero?
] keep *void*
] keep *int spin ;
: resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ;
-: handle-overlapped ( timeout -- ? )
+: handle-overlapped ( us -- ? )
wait-for-overlapped [
dup [
>r drop GetLastError 1array r> resume-callback t
M: win32-handle cancel-operation
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
-M: winnt io-multiplex ( ms -- )
+M: winnt io-multiplex ( us -- )
handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )
"-" %
32 random-bits #
"-" %
- millis #
+ micros #
] "" make ;
M: winnt (pipe) ( -- pipe )
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
-io.buffers io.files io.ports io.sockets io.binary
-io.sockets io.timeouts windows.errors strings
-kernel math namespaces sequences windows windows.kernel32
-windows.shell32 windows.types windows.winsock splitting
-continuations math.bitwise system accessors ;
+io.buffers io.files io.ports io.binary io.timeouts
+windows.errors strings kernel math namespaces sequences windows
+windows.kernel32 windows.shell32 windows.types windows.winsock
+splitting continuations math.bitwise system accessors ;
IN: io.windows
: set-inherit ( handle ? -- )
{ $subsection hide-var }
"To add and remove multiple variables:"
{ $subsection show-vars }
-{ $subsection hide-vars } ;
+{ $subsection hide-vars }
+"Hiding all visible variables:"
+{ $subsection hide-all-vars } ;
+
+HELP: show-var
+{ $values { "var" "a variable name" } }
+{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
+
+HELP: show-vars
+{ $values { "seq" "a sequence of variable names" } }
+{ $description "Adds a sequence of variables to the watch list; their values will be printed by the listener after every expression." } ;
+
+HELP: hide-var
+{ $values { "var" "a variable name" } }
+{ $description "Removes a variable from the watch list." } ;
+
+HELP: hide-vars
+{ $values { "seq" "a sequence of variable names" } }
+{ $description "Removes a sequence of variables from the watch list." } ;
+
+HELP: hide-all-vars
+{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
SYMBOL: visible-vars
-: show-var ( sym -- ) visible-vars [ swap suffix ] change ;
+: show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
-: hide-var ( sym -- ) visible-vars [ remove ] change ;
+: hide-var ( var -- ) visible-vars [ remove ] change ;
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
+: hide-all-vars ( -- ) visible-vars off ;
+
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
] tabular-output
] unless-empty ;
+SYMBOL: display-stacks?
+
+t display-stacks? set-global
+
: stacks. ( -- )
- datastack [ nl "--- Data stack:" title. stack. ] unless-empty
- retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
+ display-stacks? get [
+ datastack [ nl "--- Data stack:" title. stack. ] unless-empty
+ retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty
+ ] when ;
: prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
ARTICLE: "locals-limitations" "Limitations of locals"
-"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator."
-$nl
+"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
+{ $subsection >r/r>-in-lambda-error }
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
{ $code
":: good-cond-usage ( a -- ... )"
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
-definitions compiler.units ;
+definitions compiler.units fry lexer ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
{ [ a b > ] [ 5 ] }
} cond ;
+\ cond-test must-infer
+
[ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test
[ 5 ] [ 3 2 cond-test ] unit-test
:: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
+\ 0&&-test must-infer
+
[ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test
[ f ] [ 8 0&&-test ] unit-test
:: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
+\ &&-test must-infer
+
[ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test
[ f ] [ 8 &&-test ] unit-test
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
+ERROR: punned-class x ;
+
+[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
+
:: literal-identity-test ( -- a b )
{ } V{ } ;
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
+[
+ "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
+] [ error>> >r/r>-in-fry-error? ] must-fail-with
+
+:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
+: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
+
+\ funny-macro-test must-infer
+
+[ t ] [ 3 funny-macro-test ] unit-test
+[ f ] [ 2 funny-macro-test ] unit-test
+
+! Some odd parser corner cases
+[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
+
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer classes ;
+locals.backend memoize macros.expander lexer classes summary ;
IN: locals
! Inspired by
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
+ERROR: >r/r>-in-lambda-error ;
+
+M: >r/r>-in-lambda-error summary
+ drop
+ "Explicit retain stack manipulation is not permitted in lambda bodies" ;
+
<PRIVATE
TUPLE: lambda vars body ;
: free-vars ( form -- vars )
[ free-vars* ] { } make prune ;
-: add-if-free ( object -- )
- {
- { [ dup local-writer? ] [ "local-reader" word-prop , ] }
- { [ dup lexical? ] [ , ] }
- { [ dup quote? ] [ local>> , ] }
- { [ t ] [ free-vars* ] }
- } cond ;
+M: local-writer free-vars* "local-reader" word-prop , ;
+
+M: lexical free-vars* , ;
+
+M: quote free-vars* , ;
M: object free-vars* drop ;
-M: quotation free-vars* [ add-if-free ] each ;
+M: quotation free-vars* [ free-vars* ] each ;
-M: lambda free-vars*
- [ vars>> ] [ body>> ] bi free-vars swap diff % ;
+M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
GENERIC: lambda-rewrite* ( obj -- )
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
+
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
[ rewrite-element ] each ;
: rewrite-sequence ( seq -- )
- [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
+ [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+M: quotation rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+
M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
- [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
+ [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: local rewrite-element , ;
M: hashtable local-rewrite* rewrite-element ;
+M: word local-rewrite*
+ dup { >r r> } memq?
+ [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
+
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
\ ] (parse-lambda) <lambda> ;
: parse-binding ( -- pair/f )
- scan dup "|" = [
- drop f
- ] [
- scan {
- { "[" [ \ ] parse-until >quotation ] }
- { "[|" [ parse-lambda ] }
- } case 2array
- ] if ;
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup "|" = ] [ drop f ] }
+ { [ dup "!" = ] [ drop POSTPONE: ! parse-binding ] }
+ [ scan-object 2array ]
+ } cond ;
: (parse-bindings) ( -- )
parse-binding [
- first2 >r make-local r> 2array ,
+ first2 [ make-local ] dip 2array ,
(parse-bindings)
] when* ;
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
- scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
+ "(" expect parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
: [| parse-lambda parsed-lambda ; parsing
: [let
- scan "|" assert= parse-bindings
+ "|" expect parse-bindings
\ ] (parse-lambda) <let> parsed-lambda ; parsing
: [let*
- scan "|" assert= parse-bindings*
+ "|" expect parse-bindings*
\ ] (parse-lambda) <let*> parsed-lambda ; parsing
: [wlet
- scan "|" assert= parse-wbindings
+ "|" expect parse-wbindings
\ ] (parse-lambda) <wlet> parsed-lambda ; parsing
: :: (::) define ; parsing
{ $subsection "logging.rotation" }
{ $subsection "logging.parser" }
{ $subsection "logging.analysis" }
-{ $subsection "logging.insomniac" }
{ $subsection "logging.server" } ;
ABOUT: "logging"
\r
"logging.parser" require\r
"logging.analysis" require\r
-"logging.insomniac" require\r
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
-: expand-macro ( quot -- )
- stack [ swap with-datastack >vector ] change
- stack get pop >quotation end (expand-macros) ;
+: word, ( word -- ) end , ;
+
+: expand-macro ( word quot -- )
+ '[
+ drop
+ stack [ _ with-datastack >vector ] change
+ stack get pop >quotation end (expand-macros)
+ ] [
+ drop
+ word,
+ ] recover ;
: expand-macro? ( word -- quot ? )
dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
stack get length <=
] [ 2drop f f ] if ;
-: word, ( word -- ) end , ;
-
M: word expand-macros*
dup expand-dispatch? [ drop expand-dispatch ] [
- dup expand-macro? [ nip expand-macro ] [
+ dup expand-macro? [ expand-macro ] [
drop word,
] if
] if ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs help.markup help.syntax io.streams.string sequences ;
-IN: mime-types
-
-HELP: mime-db
-{ $values
-
- { "seq" sequence } }
-{ $description "Outputs an array where the first element is a MIME type and the rest of the array is file extensions that have that MIME type." } ;
-
-HELP: mime-type
-{ $values
- { "filename" "a filename" }
- { "mime-type" "a MIME type string" } }
-{ $description "Outputs the MIME type associtated with a path by parsing the path's file extension and looking it up in the table returned by " { $link mime-types } "." } ;
-
-HELP: mime-types
-{ $values
-
- { "assoc" assoc } }
-{ $description "Outputs an " { $snippet "assoc" } " made from the data in the " { $link mime-db } " word where the keys are file extensions and the values are the corresponding MIME types." } ;
-
-HELP: nonstandard-mime-types
-{ $values
-
- { "assoc" assoc } }
-{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
-
-ARTICLE: "mime-types" "MIME types"
-"The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
-"Looking up a MIME type:"
-{ $subsection mime-type } ;
-
-ABOUT: "mime-types"
+++ /dev/null
-IN: mime-types.tests
-USING: mime-types tools.test ;
-
-[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
-[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
-[ "text/plain" ] [ "foo.factor" mime-type ] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.encodings.ascii assocs sequences splitting
-kernel namespaces fry memoize ;
-IN: mime-types
-
-MEMO: mime-db ( -- seq )
- "resource:basis/mime-types/mime.types" ascii file-lines
- [ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
-
-: nonstandard-mime-types ( -- assoc )
- H{
- { "factor" "text/plain" }
- { "cgi" "application/x-cgi-script" }
- { "fhtml" "application/x-factor-server-page" }
- } ;
-
-MEMO: mime-types ( -- assoc )
- [
- mime-db [ unclip '[ [ _ ] dip set ] each ] each
- ] H{ } make-assoc
- nonstandard-mime-types assoc-union ;
-
-: mime-type ( filename -- mime-type )
- file-extension mime-types at "application/octet-stream" or ;
+++ /dev/null
-# This is a comment. I love comments.
-
-# This file controls what Internet media types are sent to the client for
-# given file extension(s). Sending the correct media type to the client
-# is important so they know how to handle the content of the file.
-# Extra types can either be added here or by using an AddType directive
-# in your config files. For more information about Internet media types,
-# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
-# registry is at <http://www.iana.org/assignments/media-types/>.
-
-# MIME type Extensions
-application/activemessage
-application/andrew-inset ez
-application/applefile
-application/atom+xml atom
-application/atomcat+xml atomcat
-application/atomicmail
-application/atomsvc+xml atomsvc
-application/auth-policy+xml
-application/batch-smtp
-application/beep+xml
-application/cals-1840
-application/ccxml+xml ccxml
-application/cellml+xml
-application/cnrp+xml
-application/commonground
-application/conference-info+xml
-application/cpl+xml
-application/csta+xml
-application/cstadata+xml
-application/cybercash
-application/davmount+xml davmount
-application/dca-rft
-application/dec-dx
-application/dialog-info+xml
-application/dicom
-application/dns
-application/dvcs
-application/ecmascript ecma
-application/edi-consent
-application/edi-x12
-application/edifact
-application/epp+xml
-application/eshop
-application/fastinfoset
-application/fastsoap
-application/fits
-application/font-tdpfr pfr
-application/h224
-application/http
-application/hyperstudio stk
-application/iges
-application/im-iscomposing+xml
-application/index
-application/index.cmd
-application/index.obj
-application/index.response
-application/index.vnd
-application/iotp
-application/ipp
-application/isup
-application/javascript js
-application/json json
-application/kpml-request+xml
-application/kpml-response+xml
-application/mac-binhex40 hqx
-application/mac-compactpro cpt
-application/macwriteii
-application/marc mrc
-application/mathematica ma nb mb
-application/mathml+xml mathml
-application/mbms-associated-procedure-description+xml
-application/mbms-deregister+xml
-application/mbms-envelope+xml
-application/mbms-msk+xml
-application/mbms-msk-response+xml
-application/mbms-protection-description+xml
-application/mbms-reception-report+xml
-application/mbms-register+xml
-application/mbms-register-response+xml
-application/mbms-user-service-description+xml
-application/mbox mbox
-application/mediaservercontrol+xml mscml
-application/mikey
-application/mp4 mp4s
-application/mpeg4-generic
-application/mpeg4-iod
-application/mpeg4-iod-xmt
-application/msword doc dot
-application/mxf mxf
-application/nasdata
-application/news-message-id
-application/news-transmission
-application/nss
-application/ocsp-request
-application/ocsp-response
-application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
-application/oda oda
-application/oebps-package+xml
-application/ogg ogg
-application/parityfec
-application/pdf pdf
-application/pgp-encrypted pgp
-application/pgp-keys
-application/pgp-signature asc sig
-application/pics-rules prf
-application/pidf+xml
-application/pkcs10 p10
-application/pkcs7-mime p7m p7c
-application/pkcs7-signature p7s
-application/pkix-cert cer
-application/pkix-crl crl
-application/pkix-pkipath pkipath
-application/pkixcmp pki
-application/pls+xml pls
-application/poc-settings+xml
-application/postscript ai eps ps
-application/prs.alvestrand.titrax-sheet
-application/prs.cww cww
-application/prs.nprend
-application/prs.plucker
-application/qsig
-application/rdf+xml rdf
-application/reginfo+xml rif
-application/relax-ng-compact-syntax rnc
-application/remote-printing
-application/resource-lists+xml rl
-application/riscos
-application/rlmi+xml
-application/rls-services+xml rs
-application/rsd+xml rsd
-application/rss+xml rss
-application/rtf rtf
-application/rtx
-application/samlassertion+xml
-application/samlmetadata+xml
-application/sbml+xml sbml
-application/sdp sdp
-application/set-payment
-application/set-payment-initiation setpay
-application/set-registration
-application/set-registration-initiation setreg
-application/sgml
-application/sgml-open-catalog
-application/shf+xml shf
-application/sieve
-application/simple-filter+xml
-application/simple-message-summary
-application/simplesymbolcontainer
-application/slate
-application/smil
-application/smil+xml smi smil
-application/soap+fastinfoset
-application/soap+xml
-application/spirits-event+xml
-application/srgs gram
-application/srgs+xml grxml
-application/ssml+xml ssml
-application/timestamp-query
-application/timestamp-reply
-application/tve-trigger
-application/vemmi
-application/vividence.scriptfile
-application/vnd.3gpp.bsf+xml
-application/vnd.3gpp.pic-bw-large plb
-application/vnd.3gpp.pic-bw-small psb
-application/vnd.3gpp.pic-bw-var pvb
-application/vnd.3gpp.sms
-application/vnd.3gpp2.bcmcsinfo+xml
-application/vnd.3gpp2.sms
-application/vnd.3m.post-it-notes pwn
-application/vnd.accpac.simply.aso aso
-application/vnd.accpac.simply.imp imp
-application/vnd.acucobol acu
-application/vnd.acucorp atc acutc
-application/vnd.adobe.xdp+xml xdp
-application/vnd.adobe.xfdf xfdf
-application/vnd.aether.imp
-application/vnd.amiga.ami ami
-application/vnd.anser-web-certificate-issue-initiation cii
-application/vnd.anser-web-funds-transfer-initiation fti
-application/vnd.antix.game-component atx
-application/vnd.apple.installer+xml mpkg
-application/vnd.audiograph aep
-application/vnd.autopackage
-application/vnd.avistar+xml
-application/vnd.blueice.multipass mpm
-application/vnd.bmi bmi
-application/vnd.businessobjects rep
-application/vnd.cab-jscript
-application/vnd.canon-cpdl
-application/vnd.canon-lips
-application/vnd.cendio.thinlinc.clientconf
-application/vnd.chemdraw+xml cdxml
-application/vnd.chipnuts.karaoke-mmd mmd
-application/vnd.cinderella cdy
-application/vnd.cirpack.isdn-ext
-application/vnd.claymore cla
-application/vnd.clonk.c4group c4g c4d c4f c4p c4u
-application/vnd.commerce-battelle
-application/vnd.commonspace csp cst
-application/vnd.contact.cmsg cdbcmsg
-application/vnd.cosmocaller cmc
-application/vnd.crick.clicker clkx
-application/vnd.crick.clicker.keyboard clkk
-application/vnd.crick.clicker.palette clkp
-application/vnd.crick.clicker.template clkt
-application/vnd.crick.clicker.wordbank clkw
-application/vnd.criticaltools.wbs+xml wbs
-application/vnd.ctc-posml pml
-application/vnd.cups-pdf
-application/vnd.cups-postscript
-application/vnd.cups-ppd ppd
-application/vnd.cups-raster
-application/vnd.cups-raw
-application/vnd.curl curl
-application/vnd.cybank
-application/vnd.data-vision.rdz rdz
-application/vnd.denovo.fcselayout-link fe_launch
-application/vnd.dna dna
-application/vnd.dolby.mlp mlp
-application/vnd.dpgraph dpg
-application/vnd.dreamfactory dfac
-application/vnd.dvb.esgcontainer
-application/vnd.dvb.ipdcesgaccess
-application/vnd.dxr
-application/vnd.ecdis-update
-application/vnd.ecowin.chart mag
-application/vnd.ecowin.filerequest
-application/vnd.ecowin.fileupdate
-application/vnd.ecowin.series
-application/vnd.ecowin.seriesrequest
-application/vnd.ecowin.seriesupdate
-application/vnd.enliven nml
-application/vnd.epson.esf esf
-application/vnd.epson.msf msf
-application/vnd.epson.quickanime qam
-application/vnd.epson.salt slt
-application/vnd.epson.ssf ssf
-application/vnd.ericsson.quickcall
-application/vnd.eszigno3+xml es3 et3
-application/vnd.eudora.data
-application/vnd.ezpix-album ez2
-application/vnd.ezpix-package ez3
-application/vnd.fdf fdf
-application/vnd.ffsns
-application/vnd.fints
-application/vnd.flographit gph
-application/vnd.fluxtime.clip ftc
-application/vnd.framemaker fm frame maker
-application/vnd.frogans.fnc fnc
-application/vnd.frogans.ltf ltf
-application/vnd.fsc.weblaunch fsc
-application/vnd.fujitsu.oasys oas
-application/vnd.fujitsu.oasys2 oa2
-application/vnd.fujitsu.oasys3 oa3
-application/vnd.fujitsu.oasysgp fg5
-application/vnd.fujitsu.oasysprs bh2
-application/vnd.fujixerox.art-ex
-application/vnd.fujixerox.art4
-application/vnd.fujixerox.hbpl
-application/vnd.fujixerox.ddd ddd
-application/vnd.fujixerox.docuworks xdw
-application/vnd.fujixerox.docuworks.binder xbd
-application/vnd.fut-misnet
-application/vnd.fuzzysheet fzs
-application/vnd.genomatix.tuxedo txd
-application/vnd.google-earth.kml+xml kml
-application/vnd.google-earth.kmz kmz
-application/vnd.grafeq gqf gqs
-application/vnd.gridmp
-application/vnd.groove-account gac
-application/vnd.groove-help ghf
-application/vnd.groove-identity-message gim
-application/vnd.groove-injector grv
-application/vnd.groove-tool-message gtm
-application/vnd.groove-tool-template tpl
-application/vnd.groove-vcard vcg
-application/vnd.handheld-entertainment+xml zmm
-application/vnd.hbci hbci
-application/vnd.hcl-bireports
-application/vnd.hhe.lesson-player les
-application/vnd.hp-hpgl hpgl
-application/vnd.hp-hpid hpid
-application/vnd.hp-hps hps
-application/vnd.hp-jlyt jlt
-application/vnd.hp-pcl pcl
-application/vnd.hp-pclxl pclxl
-application/vnd.httphone
-application/vnd.hzn-3d-crossword x3d
-application/vnd.ibm.afplinedata
-application/vnd.ibm.electronic-media
-application/vnd.ibm.minipay mpy
-application/vnd.ibm.modcap afp listafp list3820
-application/vnd.ibm.rights-management irm
-application/vnd.ibm.secure-container sc
-application/vnd.igloader igl
-application/vnd.immervision-ivp ivp
-application/vnd.immervision-ivu ivu
-application/vnd.informedcontrol.rms+xml
-application/vnd.intercon.formnet xpw xpx
-application/vnd.intertrust.digibox
-application/vnd.intertrust.nncp
-application/vnd.intu.qbo qbo
-application/vnd.intu.qfx qfx
-application/vnd.ipunplugged.rcprofile rcprofile
-application/vnd.irepository.package+xml irp
-application/vnd.is-xpr xpr
-application/vnd.jam jam
-application/vnd.japannet-directory-service
-application/vnd.japannet-jpnstore-wakeup
-application/vnd.japannet-payment-wakeup
-application/vnd.japannet-registration
-application/vnd.japannet-registration-wakeup
-application/vnd.japannet-setstore-wakeup
-application/vnd.japannet-verification
-application/vnd.japannet-verification-wakeup
-application/vnd.jcp.javame.midlet-rms rms
-application/vnd.jisp jisp
-application/vnd.kahootz ktz ktr
-application/vnd.kde.karbon karbon
-application/vnd.kde.kchart chrt
-application/vnd.kde.kformula kfo
-application/vnd.kde.kivio flw
-application/vnd.kde.kontour kon
-application/vnd.kde.kpresenter kpr kpt
-application/vnd.kde.kspread ksp
-application/vnd.kde.kword kwd kwt
-application/vnd.kenameaapp htke
-application/vnd.kidspiration kia
-application/vnd.kinar kne knp
-application/vnd.koan skp skd skt skm
-application/vnd.liberty-request+xml
-application/vnd.llamagraphics.life-balance.desktop lbd
-application/vnd.llamagraphics.life-balance.exchange+xml lbe
-application/vnd.lotus-1-2-3 123
-application/vnd.lotus-approach apr
-application/vnd.lotus-freelance pre
-application/vnd.lotus-notes nsf
-application/vnd.lotus-organizer org
-application/vnd.lotus-screencam scm
-application/vnd.lotus-wordpro lwp
-application/vnd.macports.portpkg portpkg
-application/vnd.marlin.drm.actiontoken+xml
-application/vnd.marlin.drm.conftoken+xml
-application/vnd.marlin.drm.mdcf
-application/vnd.mcd mcd
-application/vnd.medcalcdata mc1
-application/vnd.mediastation.cdkey cdkey
-application/vnd.meridian-slingshot
-application/vnd.mfer mwf
-application/vnd.mfmp mfm
-application/vnd.micrografx.flo flo
-application/vnd.micrografx.igx igx
-application/vnd.mif mif
-application/vnd.minisoft-hp3000-save
-application/vnd.mitsubishi.misty-guard.trustweb
-application/vnd.mobius.daf daf
-application/vnd.mobius.dis dis
-application/vnd.mobius.mbk mbk
-application/vnd.mobius.mqy mqy
-application/vnd.mobius.msl msl
-application/vnd.mobius.plc plc
-application/vnd.mobius.txf txf
-application/vnd.mophun.application mpn
-application/vnd.mophun.certificate mpc
-application/vnd.motorola.flexsuite
-application/vnd.motorola.flexsuite.adsi
-application/vnd.motorola.flexsuite.fis
-application/vnd.motorola.flexsuite.gotap
-application/vnd.motorola.flexsuite.kmr
-application/vnd.motorola.flexsuite.ttc
-application/vnd.motorola.flexsuite.wem
-application/vnd.mozilla.xul+xml xul
-application/vnd.ms-artgalry cil
-application/vnd.ms-asf asf
-application/vnd.ms-cab-compressed cab
-application/vnd.ms-excel xls xlm xla xlc xlt xlw
-application/vnd.ms-fontobject eot
-application/vnd.ms-htmlhelp chm
-application/vnd.ms-ims ims
-application/vnd.ms-lrm lrm
-application/vnd.ms-playready.initiator+xml
-application/vnd.ms-powerpoint ppt pps pot
-application/vnd.ms-project mpp mpt
-application/vnd.ms-tnef
-application/vnd.ms-wmdrm.lic-chlg-req
-application/vnd.ms-wmdrm.lic-resp
-application/vnd.ms-wmdrm.meter-chlg-req
-application/vnd.ms-wmdrm.meter-resp
-application/vnd.ms-works wps wks wcm wdb
-application/vnd.ms-wpl wpl
-application/vnd.ms-xpsdocument xps
-application/vnd.mseq mseq
-application/vnd.msign
-application/vnd.music-niff
-application/vnd.musician mus
-application/vnd.ncd.control
-application/vnd.nervana
-application/vnd.netfpx
-application/vnd.neurolanguage.nlu nlu
-application/vnd.noblenet-directory nnd
-application/vnd.noblenet-sealer nns
-application/vnd.noblenet-web nnw
-application/vnd.nokia.catalogs
-application/vnd.nokia.conml+wbxml
-application/vnd.nokia.conml+xml
-application/vnd.nokia.isds-radio-presets
-application/vnd.nokia.iptv.config+xml
-application/vnd.nokia.landmark+wbxml
-application/vnd.nokia.landmark+xml
-application/vnd.nokia.landmarkcollection+xml
-application/vnd.nokia.n-gage.ac+xml
-application/vnd.nokia.n-gage.data ngdat
-application/vnd.nokia.n-gage.symbian.install n-gage
-application/vnd.nokia.ncd
-application/vnd.nokia.pcd+wbxml
-application/vnd.nokia.pcd+xml
-application/vnd.nokia.radio-preset rpst
-application/vnd.nokia.radio-presets rpss
-application/vnd.novadigm.edm edm
-application/vnd.novadigm.edx edx
-application/vnd.novadigm.ext ext
-application/vnd.oasis.opendocument.chart odc
-application/vnd.oasis.opendocument.chart-template otc
-application/vnd.oasis.opendocument.formula odf
-application/vnd.oasis.opendocument.formula-template otf
-application/vnd.oasis.opendocument.graphics odg
-application/vnd.oasis.opendocument.graphics-template otg
-application/vnd.oasis.opendocument.image odi
-application/vnd.oasis.opendocument.image-template oti
-application/vnd.oasis.opendocument.presentation odp
-application/vnd.oasis.opendocument.presentation-template otp
-application/vnd.oasis.opendocument.spreadsheet ods
-application/vnd.oasis.opendocument.spreadsheet-template ots
-application/vnd.oasis.opendocument.text odt
-application/vnd.oasis.opendocument.text-master otm
-application/vnd.oasis.opendocument.text-template ott
-application/vnd.oasis.opendocument.text-web oth
-application/vnd.obn
-application/vnd.olpc-sugar xo
-application/vnd.oma-scws-config
-application/vnd.oma-scws-http-request
-application/vnd.oma-scws-http-response
-application/vnd.oma.bcast.associated-procedure-parameter+xml
-application/vnd.oma.bcast.drm-trigger+xml
-application/vnd.oma.bcast.imd+xml
-application/vnd.oma.bcast.notification+xml
-application/vnd.oma.bcast.sgboot
-application/vnd.oma.bcast.sgdd+xml
-application/vnd.oma.bcast.sgdu
-application/vnd.oma.bcast.simple-symbol-container
-application/vnd.oma.bcast.smartcard-trigger+xml
-application/vnd.oma.bcast.sprov+xml
-application/vnd.oma.dd2+xml dd2
-application/vnd.oma.drm.risd+xml
-application/vnd.oma.group-usage-list+xml
-application/vnd.oma.poc.groups+xml
-application/vnd.oma.xcap-directory+xml
-application/vnd.omads-email+xml
-application/vnd.omads-file+xml
-application/vnd.omads-folder+xml
-application/vnd.omaloc-supl-init
-application/vnd.openofficeorg.extension oxt
-application/vnd.osa.netdeploy
-application/vnd.osgi.dp dp
-application/vnd.otps.ct-kip+xml
-application/vnd.palm prc pdb pqa oprc
-application/vnd.paos.xml
-application/vnd.pg.format str
-application/vnd.pg.osasli ei6
-application/vnd.piaccess.application-licence
-application/vnd.picsel efif
-application/vnd.poc.group-advertisement+xml
-application/vnd.pocketlearn plf
-application/vnd.powerbuilder6 pbd
-application/vnd.powerbuilder6-s
-application/vnd.powerbuilder7
-application/vnd.powerbuilder7-s
-application/vnd.powerbuilder75
-application/vnd.powerbuilder75-s
-application/vnd.preminet
-application/vnd.previewsystems.box box
-application/vnd.proteus.magazine mgz
-application/vnd.publishare-delta-tree qps
-application/vnd.pvi.ptid1 ptid
-application/vnd.pwg-multiplexed
-application/vnd.pwg-xhtml-print+xml
-application/vnd.qualcomm.brew-app-res
-application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
-application/vnd.rapid
-application/vnd.recordare.musicxml mxl
-application/vnd.recordare.musicxml+xml
-application/vnd.renlearn.rlprint
-application/vnd.rn-realmedia rm
-application/vnd.ruckus.download
-application/vnd.s3sms
-application/vnd.scribus
-application/vnd.sealed.3df
-application/vnd.sealed.csf
-application/vnd.sealed.doc
-application/vnd.sealed.eml
-application/vnd.sealed.mht
-application/vnd.sealed.net
-application/vnd.sealed.ppt
-application/vnd.sealed.tiff
-application/vnd.sealed.xls
-application/vnd.sealedmedia.softseal.html
-application/vnd.sealedmedia.softseal.pdf
-application/vnd.seemail see
-application/vnd.sema sema
-application/vnd.semd semd
-application/vnd.semf semf
-application/vnd.shana.informed.formdata ifm
-application/vnd.shana.informed.formtemplate itp
-application/vnd.shana.informed.interchange iif
-application/vnd.shana.informed.package ipk
-application/vnd.simtech-mindmapper twd twds
-application/vnd.smaf mmf
-application/vnd.solent.sdkm+xml sdkm sdkd
-application/vnd.spotfire.dxp dxp
-application/vnd.spotfire.sfs sfs
-application/vnd.sss-cod
-application/vnd.sss-dtf
-application/vnd.sss-ntf
-application/vnd.street-stream
-application/vnd.sun.wadl+xml
-application/vnd.sus-calendar sus susp
-application/vnd.svd svd
-application/vnd.swiftview-ics
-application/vnd.syncml+xml xsm
-application/vnd.syncml.dm+wbxml bdm
-application/vnd.syncml.dm+xml xdm
-application/vnd.syncml.ds.notification
-application/vnd.tao.intent-module-archive tao
-application/vnd.tmobile-livetv tmo
-application/vnd.trid.tpt tpt
-application/vnd.triscape.mxs mxs
-application/vnd.trueapp tra
-application/vnd.truedoc
-application/vnd.ufdl ufd ufdl
-application/vnd.uiq.theme utz
-application/vnd.umajin umj
-application/vnd.unity unityweb
-application/vnd.uoml+xml uoml
-application/vnd.uplanet.alert
-application/vnd.uplanet.alert-wbxml
-application/vnd.uplanet.bearer-choice
-application/vnd.uplanet.bearer-choice-wbxml
-application/vnd.uplanet.cacheop
-application/vnd.uplanet.cacheop-wbxml
-application/vnd.uplanet.channel
-application/vnd.uplanet.channel-wbxml
-application/vnd.uplanet.list
-application/vnd.uplanet.list-wbxml
-application/vnd.uplanet.listcmd
-application/vnd.uplanet.listcmd-wbxml
-application/vnd.uplanet.signal
-application/vnd.vcx vcx
-application/vnd.vd-study
-application/vnd.vectorworks
-application/vnd.vidsoft.vidconference
-application/vnd.visio vsd vst vss vsw
-application/vnd.visionary vis
-application/vnd.vividence.scriptfile
-application/vnd.vsf vsf
-application/vnd.wap.sic
-application/vnd.wap.slc
-application/vnd.wap.wbxml wbxml
-application/vnd.wap.wmlc wmlc
-application/vnd.wap.wmlscriptc wmlsc
-application/vnd.webturbo wtb
-application/vnd.wfa.wsc
-application/vnd.wordperfect wpd
-application/vnd.wqd wqd
-application/vnd.wrq-hp3000-labelled
-application/vnd.wt.stf stf
-application/vnd.wv.csp+wbxml
-application/vnd.wv.csp+xml
-application/vnd.wv.ssp+xml
-application/vnd.xara xar
-application/vnd.xfdl xfdl
-application/vnd.xmpie.cpkg
-application/vnd.xmpie.dpkg
-application/vnd.xmpie.plan
-application/vnd.xmpie.ppkg
-application/vnd.xmpie.xlim
-application/vnd.yamaha.hv-dic hvd
-application/vnd.yamaha.hv-script hvs
-application/vnd.yamaha.hv-voice hvp
-application/vnd.yamaha.smaf-audio saf
-application/vnd.yamaha.smaf-phrase spf
-application/vnd.yellowriver-custom-menu cmp
-application/vnd.zzazz.deck+xml zaz
-application/voicexml+xml vxml
-application/watcherinfo+xml
-application/whoispp-query
-application/whoispp-response
-application/winhlp hlp
-application/wita
-application/wordperfect5.1
-application/wsdl+xml wsdl
-application/wspolicy+xml wspolicy
-application/x-ace-compressed ace
-application/x-bcpio bcpio
-application/x-bittorrent torrent
-application/x-bzip bz
-application/x-bzip2 bz2 boz
-application/x-cdlink vcd
-application/x-chat chat
-application/x-chess-pgn pgn
-application/x-compress
-application/x-cpio cpio
-application/x-csh csh
-application/x-director dcr dir dxr fgd
-application/x-dvi dvi
-application/x-futuresplash spl
-application/x-gtar gtar
-application/x-gzip
-application/x-hdf hdf
-application/x-java-jnlp-file jnlp
-application/x-latex latex
-application/x-ms-wmd wmd
-application/x-ms-wmz wmz
-application/x-msaccess mdb
-application/x-msbinder obd
-application/x-mscardfile crd
-application/x-msclip clp
-application/x-msdownload exe dll com bat msi
-application/x-msmediaview mvb m13 m14
-application/x-msmetafile wmf
-application/x-msmoney mny
-application/x-mspublisher pub
-application/x-msschedule scd
-application/x-msterminal trm
-application/x-mswrite wri
-application/x-netcdf nc cdf
-application/x-pkcs12 p12 pfx
-application/x-pkcs7-certificates p7b spc
-application/x-pkcs7-certreqresp p7r
-application/x-rar-compressed rar
-application/x-sh sh
-application/x-shar shar
-application/x-shockwave-flash swf
-application/x-stuffit sit
-application/x-stuffitx sitx
-application/x-sv4cpio sv4cpio
-application/x-sv4crc sv4crc
-application/x-tar tar
-application/x-tcl tcl
-application/x-tex tex
-application/x-texinfo texinfo texi
-application/x-ustar ustar
-application/x-wais-source src
-application/x-x509-ca-cert der crt
-application/x400-bp
-application/xcap-att+xml
-application/xcap-caps+xml
-application/xcap-el+xml
-application/xcap-error+xml
-application/xcap-ns+xml
-application/xenc+xml xenc
-application/xhtml+xml xhtml xht
-application/xml xml xsl
-application/xml-dtd dtd
-application/xml-external-parsed-entity
-application/xmpp+xml
-application/xop+xml xop
-application/xslt+xml xslt
-application/xspf+xml xspf
-application/xv+xml mxml xhvml xvml xvm
-application/zip zip
-audio/32kadpcm
-audio/3gpp
-audio/3gpp2
-audio/ac3
-audio/amr
-audio/amr-wb
-audio/amr-wb+
-audio/asc
-audio/basic au snd
-audio/bv16
-audio/bv32
-audio/clearmode
-audio/cn
-audio/dat12
-audio/dls
-audio/dsr-es201108
-audio/dsr-es202050
-audio/dsr-es202211
-audio/dsr-es202212
-audio/dvi4
-audio/eac3
-audio/evrc
-audio/evrc-qcp
-audio/evrc0
-audio/evrc1
-audio/evrcb
-audio/evrcb0
-audio/evrcb1
-audio/g722
-audio/g7221
-audio/g723
-audio/g726-16
-audio/g726-24
-audio/g726-32
-audio/g726-40
-audio/g728
-audio/g729
-audio/g7291
-audio/g729d
-audio/g729e
-audio/gsm
-audio/gsm-efr
-audio/ilbc
-audio/l16
-audio/l20
-audio/l24
-audio/l8
-audio/lpc
-audio/midi mid midi kar rmi
-audio/mobile-xmf
-audio/mp4 mp4a
-audio/mp4a-latm m4a m4p
-audio/mpa
-audio/mpa-robust
-audio/mpeg mpga mp2 mp2a mp3 m2a m3a
-audio/mpeg4-generic
-audio/parityfec
-audio/pcma
-audio/pcmu
-audio/prs.sid
-audio/qcelp
-audio/red
-audio/rtp-enc-aescm128
-audio/rtp-midi
-audio/rtx
-audio/smv
-audio/smv0
-audio/smv-qcp
-audio/sp-midi
-audio/t140c
-audio/t38
-audio/telephone-event
-audio/tone
-audio/vdvi
-audio/vmr-wb
-audio/vnd.3gpp.iufp
-audio/vnd.4sb
-audio/vnd.audiokoz
-audio/vnd.celp
-audio/vnd.cisco.nse
-audio/vnd.cmles.radio-events
-audio/vnd.cns.anp1
-audio/vnd.cns.inf1
-audio/vnd.digital-winds eol
-audio/vnd.dlna.adts
-audio/vnd.dolby.mlp
-audio/vnd.everad.plj
-audio/vnd.hns.audio
-audio/vnd.lucent.voice lvp
-audio/vnd.nokia.mobile-xmf
-audio/vnd.nortel.vbk
-audio/vnd.nuera.ecelp4800 ecelp4800
-audio/vnd.nuera.ecelp7470 ecelp7470
-audio/vnd.nuera.ecelp9600 ecelp9600
-audio/vnd.octel.sbc
-audio/vnd.qcelp
-audio/vnd.rhetorex.32kadpcm
-audio/vnd.sealedmedia.softseal.mpeg
-audio/vnd.vmx.cvsd
-audio/wav wav
-audio/x-aiff aif aiff aifc
-audio/x-mpegurl m3u
-audio/x-ms-wax wax
-audio/x-ms-wma wma
-audio/x-pn-realaudio ram ra
-audio/x-pn-realaudio-plugin rmp
-audio/x-wav wav
-chemical/x-cdx cdx
-chemical/x-cif cif
-chemical/x-cmdf cmdf
-chemical/x-cml cml
-chemical/x-csml csml
-chemical/x-pdb pdb
-chemical/x-xyz xyz
-image/bmp bmp
-image/cgm cgm
-image/fits
-image/g3fax g3
-image/gif gif
-image/ief ief
-image/jp2 jp2
-image/jpeg jpeg jpg jpe
-image/jpm
-image/jpx
-image/naplps
-image/pict pict pic pct
-image/png png
-image/prs.btif btif
-image/prs.pti
-image/svg+xml svg svgz
-image/t38
-image/tiff tiff tif
-image/tiff-fx
-image/vnd.adobe.photoshop psd
-image/vnd.cns.inf2
-image/vnd.djvu djvu djv
-image/vnd.dwg dwg
-image/vnd.dxf dxf
-image/vnd.fastbidsheet fbs
-image/vnd.fpx fpx
-image/vnd.fst fst
-image/vnd.fujixerox.edmics-mmr mmr
-image/vnd.fujixerox.edmics-rlc rlc
-image/vnd.globalgraphics.pgb
-image/vnd.microsoft.icon ico
-image/vnd.mix
-image/vnd.ms-modi mdi
-image/vnd.net-fpx npx
-image/vnd.sealed.png
-image/vnd.sealedmedia.softseal.gif
-image/vnd.sealedmedia.softseal.jpg
-image/vnd.svf
-image/vnd.wap.wbmp wbmp
-image/vnd.xiff xif
-image/x-cmu-raster ras
-image/x-cmx cmx
-image/x-icon
-image/x-macpaint pntg pnt mac
-image/x-pcx pcx
-image/x-pict pic pct
-image/x-portable-anymap pnm
-image/x-portable-bitmap pbm
-image/x-portable-graymap pgm
-image/x-portable-pixmap ppm
-image/x-quicktime qtif qti
-image/x-rgb rgb
-image/x-xbitmap xbm
-image/x-xpixmap xpm
-image/x-xwindowdump xwd
-message/cpim
-message/delivery-status
-message/disposition-notification
-message/external-body
-message/http
-message/news
-message/partial
-message/rfc822 eml mime
-message/s-http
-message/sip
-message/sipfrag
-message/tracking-status
-model/iges igs iges
-model/mesh msh mesh silo
-model/vnd.dwf dwf
-model/vnd.flatland.3dml
-model/vnd.gdl gdl
-model/vnd.gs.gdl
-model/vnd.gtw gtw
-model/vnd.moml+xml
-model/vnd.mts mts
-model/vnd.parasolid.transmit.binary
-model/vnd.parasolid.transmit.text
-model/vnd.vtu vtu
-model/vrml wrl vrml
-multipart/alternative
-multipart/appledouble
-multipart/byteranges
-multipart/digest
-multipart/encrypted
-multipart/form-data
-multipart/header-set
-multipart/mixed
-multipart/parallel
-multipart/related
-multipart/report
-multipart/signed
-multipart/voice-message
-text/calendar ics ifb
-text/css css
-text/csv csv
-text/directory
-text/dns
-text/enriched
-text/html html htm
-text/parityfec
-text/plain txt text conf def list log in
-text/prs.fallenstein.rst
-text/prs.lines.tag dsc
-text/red
-text/rfc822-headers
-text/richtext rtx
-text/rtf
-text/rtp-enc-aescm128
-text/rtx
-text/sgml sgml sgm
-text/t140
-text/tab-separated-values tsv
-text/troff t tr roff man me ms
-text/uri-list uri uris urls
-text/vnd.abc
-text/vnd.curl
-text/vnd.dmclientscript
-text/vnd.esmertec.theme-descriptor
-text/vnd.fly fly
-text/vnd.fmi.flexstor flx
-text/vnd.in3d.3dml 3dml
-text/vnd.in3d.spot spot
-text/vnd.iptc.newsml
-text/vnd.iptc.nitf
-text/vnd.latex-z
-text/vnd.motorola.reflex
-text/vnd.ms-mediapackage
-text/vnd.net2phone.commcenter.command
-text/vnd.sun.j2me.app-descriptor jad
-text/vnd.trolltech.linguist
-text/vnd.wap.si
-text/vnd.wap.sl
-text/vnd.wap.wml wml
-text/vnd.wap.wmlscript wmls
-text/x-asm s asm
-text/x-c c cc cxx cpp h hh dic
-text/x-fortran f for f77 f90
-text/x-pascal p pas
-text/x-java-source java
-text/x-setext etx
-text/x-uuencode uu
-text/x-vcalendar vcs
-text/x-vcard vcf
-text/xml
-text/xml-external-parsed-entity
-video/3gpp 3gp
-video/3gpp-tt
-video/3gpp2 3g2
-video/bmpeg
-video/bt656
-video/celb
-video/dv
-video/h261 h261
-video/h263 h263
-video/h263-1998
-video/h263-2000
-video/h264 h264
-video/jpeg jpgv
-video/jpm jpm jpgm
-video/mj2 mj2 mjp2
-video/mp1s
-video/mp2p
-video/mp2t
-video/mp4 mp4 mp4v mpg4 m4v
-video/mp4v-es
-video/mpeg mpeg mpg mpe m1v m2v
-video/mpeg4-generic
-video/mpv
-video/nv
-video/parityfec
-video/pointer
-video/quicktime qt mov
-video/raw
-video/rtp-enc-aescm128
-video/rtx
-video/smpte292m
-video/vc1
-video/vnd.dlna.mpeg-tts
-video/vnd.fvt fvt
-video/vnd.hns.video
-video/vnd.motorola.video
-video/vnd.motorola.videop
-video/vnd.mpegurl mxu m4u
-video/vnd.nokia.interleaved-multimedia
-video/vnd.nokia.videovoip
-video/vnd.objectvideo
-video/vnd.sealed.mpeg1
-video/vnd.sealed.mpeg4
-video/vnd.sealed.swf
-video/vnd.sealedmedia.softseal.mov
-video/vnd.vivo viv
-video/x-dv dv dif
-video/x-fli fli
-video/x-ms-asf asf asx
-video/x-ms-wm wm
-video/x-ms-wmv wmv
-video/x-ms-wmx wmx
-video/x-ms-wvx wvx
-video/x-msvideo avi
-video/x-sgi-movie movie
-x-conference/x-cooltalk ice
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: accessors io io.streams.string kernel mime.multipart
+tools.test make multiline strings ;
+IN: mime.multipart.tests
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+
+[ { "a" "a" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" "zz" } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "az" "zb" "zz" "cz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" "zzb" "zzc" "zzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "az" "zbzz" "czzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "azz" "bzzcz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+
+[ { "a" "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+
+
+[ { "a" f "b" f "c" f "d" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" "zz" } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "az" "zb" "zz" "cz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" "zzb" "zzc" "zzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "az" "zbzz" "czzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "azz" "bzzcz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+
+: dog-upload ( -- string )
+ B{
+ 45 45 45 45 45 45 87 101 98 75 105 116 70 111 114 109 66
+ 111 117 110 100 97 114 121 115 105 103 113 43 53 113 87 116
+ 54 79 114 122 56 76 79 13 10 67 111 110 116 101 110 116 45
+ 68 105 115 112 111 115 105 116 105 111 110 58 32 102 111
+ 114 109 45 100 97 116 97 59 32 110 97 109 101 61 34 102 105
+ 108 101 34 59 32 102 105 108 101 110 97 109 101 61 34 100
+ 111 103 46 106 112 103 34 13 10 67 111 110 116 101 110 116
+ 45 84 121 112 101 58 32 105 109 97 103 101 47 106 112 101
+ 103 13 10 13 10 253 253 253 253 0 16 74 70 73 70 0 1 1 0 0
+ 1 0 1 0 0 253 253 0 67 0 5 3 4 4 4 3 5 4 4 4 5 5 5 6 7 12 8
+ 7 7 7 7 15 11 11 9 12 17 15 18 18 17 15 17 17 19 22 28 23
+ 19 20 26 21 17 17 24 33 24 26 29 29 31 31 31 19 23 34 36 34
+ 30 36 28 30 31 30 253 253 0 67 1 5 5 5 7 6 7 14 8 8 14 30
+ 20 17 20 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30
+ 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30 30
+ 30 30 30 30 30 30 30 30 30 30 30 30 30 253 253 0 17 8 1 49
+ 1 64 3 1 34 0 2 17 1 3 17 1 253 253 0 29 0 0 2 2 3 1 1 1 0
+ 0 0 0 0 0 0 0 0 4 5 6 7 2 3 8 0 1 9 253 253 0 74 16 0 2 1 3
+ 3 2 4 4 3 4 5 10 5 3 5 1 1 2 3 0 4 17 5 18 33 6 49 19 34 65
+ 81 7 50 97 113 20 35 253 21 51 66 82 36 52 253 253 253 8 53
+ 83 98 114 115 253 253 253 253 22 37 67 116 253 99 253 253
+ 23 68 84 100 253 253 253 253 0 25 1 0 3 1 1 1 0 0 0 0 0 0 0
+ 0 0 0 0 1 2 3 0 4 5 253 253 0 39 17 0 2 2 2 2 3 0 2 1 5 1 0
+ 0 0 0 0 0 1 2 17 3 33 18 49 34 50 65 19 81 4 5 20 35 66 97
+ 82 253 253 0 12 3 1 0 2 17 3 17 0 63 0 253 253 253 253 253
+ 253 253 253 253 68 253 253 112 60 21 45 253 91 253 57 253
+ 253 253 75 56 95 111 253 253 51 253 253 11 253 253 14 118
+ 253 22 253 253 104 253 118 82 46 253 45 253 98 79 253 102
+ 253 38 253 98 253 64 253 253 72 253 49 46 104 11 8 253 111
+ 253 253 253 253 70 253 12 253 112 61 253 57 36 253 31 82 7
+ 253 253 78 253 253 253 253 0 253 41 100 253 76 15 253 253
+ 118 60 31 253 85 253 126 253 253 253 253 253 253 113 253 66
+ 253 253 253 82 74 49 45 253 253 42 49 253 253 253 108 253
+ 99 21 68 253 88 116 253 83 17 253 253 253 253 109 253 253
+ 253 6 253 83 253 109 1 253 115 253 10 253 90 106 23 106 253
+ 95 59 73 253 253 77 44 111 89 79 253 24 253 253 253 253 86
+ 253 253 71 253 20 52 253 253 253 24 253 253 253 253 61 253
+ 66 253 65 253 253 253 64 253 5 253 127 253 45 3 99 42 253
+ 42 253 253 79 253 83 253 38 86 92 21 57 20 76 253 253 78
+ 253 98 88 31 253 253 125 253 253 45 108 253 253 97 253 0
+ 253 44 253 0 253 45 22 253 253 253 253 99 88 74 98 77 99 78
+ 253 69 111 14 253 253 23 28 253 48 15 253 253 30 253 21 253
+ 105 8 253 253 103 253 253 253 253 121 253 127 253 87 253
+ 253 253 253 31 253 253 253 253 253 28 88 253 253 120 99 253
+ 52 100 253 0 253 253 253 253 108 109 11 103 253 253 127 253
+ 253 118 82 71 253 47 253 253 253 11 253 30 74 81 253 102
+ 253 253 35 253 97 104 62 253 46 104 41 45 109 119 127 86
+ 253 253 21 48 253 253 9 253 104 105 253 24 118 53 76 77 81
+ 253 73 105 109 253 253 253 127 253 21 253 89 253 110 63 253
+ 97 253 0 253 69 65 253 110 15 39 253 253 253 253 253 41 6
+ 253 102 5 22 54 253 114 109 45 253 123 24 253 53 253 45 44
+ 253 253 79 253 253 253 253 253 118 101 112 253 253 253 102
+ 253 253 253 35 253 99 95 253 253 119 253 253 253 253 253 21
+ 18 253 125 253 92 253 2 253 253 16 253 15 253 253 253 71 46
+ 253 253 106 253 78 253 40 253 253 109 83 33 45 253 253 253
+ 253 253 253 253 253 30 253 253 69 45 37 253 253 253 253 12
+ 253 253 253 253 253 253 253 8 75 123 253 15 69 96 7 253 253
+ 253 253 253 31 253 253 253 253 253 102 120 253 0 68 253 253
+ 253 253 12 15 253 253 253 253 253 253 253 253 253 253 253
+ 253 7 253 123 80 253 253 253 118 253 66 253 253 118 62 253
+ 253 253 38 91 55 253 253 253 253 60 253 22 96 14 253 253
+ 107 84 253 69 253 253 253 253 100 253 0 65 18 253 43 253 82
+ 105 253 253 108 64 253 31 102 253 253 253 253 253 253 253
+ 39 253 73 38 50 84 253 253 112 253 19 253 4 118 54 253 253
+ 22 33 68 54 253 253 52 96 253 253 253 15 115 16 253 66 253
+ 253 77 253 253 40 115 253 90 253 91 73 253 116 253 29 253
+ 77 253 253 253 253 46 64 109 253 88 45 253 31 253 253 92
+ 127 253 253 19 97 99 253 16 253 125 253 253 63 253 20 100
+ 253 56 253 253 253 66 84 253 253 253 253 253 253 253 125 18
+ 253 125 253 253 108 72 7 253 125 253 63 253 45 109 253 77
+ 253 253 253 111 253 253 0 253 253 68 76 253 253 253 51 253
+ 103 43 0 253 253 253 253 72 253 253 54 113 253 5 91 120 50
+ 59 253 77 7 120 109 253 48 22 8 1 253 253 98 253 106 253
+ 253 253 45 253 253 253 93 41 97 253 253 73 97 253 96 19 253
+ 103 253 253 23 253 253 253 71 253 93 253 253 110 117 101 67
+ 90 253 253 253 55 253 97 253 253 37 122 124 253 253 48 118
+ 253 253 81 66 116 253 82 123 2 253 103 108 55 30 99 31 253
+ 253 253 253 63 56 253 253 253 253 26 90 253 253 56 20 109
+ 253 253 89 16 253 253 80 253 253 80 49 253 110 253 63 253
+ 253 253 107 74 62 44 253 36 253 253 17 253 253 253 253 26
+ 253 253 253 253 21 40 253 113 253 253 253 253 253 53 253
+ 253 63 253 57 253 253 85 55 253 34 5 87 126 124 253 123 26
+ 253 15 253 253 42 253 59 108 123 112 51 27 14 253 90 253 61
+ 68 253 253 253 253 58 35 7 253 253 57 253 253 253 91 25 82
+ 71 24 253 0 253 44 253 253 21 253 99 16 253 120 253 253 253
+ 97 253 253 99 81 253 5 253 74 253 253 29 253 253 253 99 121
+ 253 253 80 127 253 253 253 22 253 96 121 19 84 253 253 253
+ 253 77 106 61 62 253 25 35 114 253 253 1 253 43 253 253 253
+ 72 71 24 56 253 125 107 253 253 253 253 253 253 93 61 253
+ 35 76 253 42 43 253 253 253 253 253 58 123 85 253 9 37 67
+ 103 63 74 117 39 123 37 253 26 110 253 20 14 64 53 253 253
+ 253 253 22 253 21 253 253 111 83 69 22 80 72 253 89 253 103
+ 61 253 253 117 60 253 121 15 253 253 253 253 8 23 253 253
+ 253 253 253 253 36 253 11 253 253 28 85 123 253 253 93 64
+ 253 57 52 99 32 253 45 89 253 15 253 253 253 46 253 253 60
+ 253 253 48 43 69 253 253 24 253 109 253 61 253 21 57 118 96
+ 253 57 92 253 52 43 253 253 253 126 253 68 18 3 88 253 253
+ 253 253 108 253 253 8 107 64 62 65 253 253 253 253 91 25
+ 253 253 39 38 253 253 99 253 122 253 112 253 118 59 253 83
+ 253 114 54 59 46 253 253 89 39 253 90 93 89 88 115 253 110
+ 64 74 113 83 253 253 5 59 62 253 35 253 253 16 253 253 124
+ 109 253 123 253 253 19 13 253 35 38 253 253 69 62 253 105
+ 253 253 0 253 253 85 253 253 82 253 253 253 60 103 253 77
+ 253 253 253 66 253 98 253 253 82 253 73 24 253 45 34 81 253
+ 253 75 44 253 253 7 114 72 110 253 253 36 73 12 42 253 253
+ 253 253 73 52 253 253 253 253 253 253 253 253 113 253 253
+ 49 253 90 253 124 40 253 122 110 253 253 253 65 66 12 48
+ 253 253 253 94 54 253 61 253 253 94 28 123 10 253 10 78 59
+ 253 253 109 253 58 253 8 253 253 253 253 19 73 53 253 86 80
+ 253 253 253 1 253 107 253 253 77 101 105 103 51 253 253 36
+ 253 24 25 39 253 0 253 93 18 253 253 18 253 253 253 30 253
+ 253 85 253 253 109 39 253 253 253 253 110 8 253 253 253 253
+ 253 253 253 14 253 253 27 66 253 60 46 54 110 5 72 31 253
+ 82 253 57 253 72 253 253 253 64 253 70 127 253 13 253 253
+ 107 253 253 253 5 253 91 253 253 253 58 75 253 253 48 72 36
+ 47 117 253 71 39 113 4 23 253 253 253 253 96 100 114 107 24
+ 253 253 126 62 253 253 101 57 253 253 89 70 6 7 2 253 253
+ 35 253 71 102 253 84 40 253 253 110 57 38 253 253 3 253 86
+ 19 1 253 253 253 253 253 34 253 253 253 253 100 253 253 253
+ 52 121 77 253 253 253 67 117 253 253 253 253 253 17 253 81
+ 253 253 116 52 72 253 253 253 253 21 253 253 126 30 79 76
+ 46 253 62 253 16 27 253 7 34 55 253 55 63 253 116 253 253
+ 118 253 117 253 253 127 253 253 253 253 15 13 127 253 253
+ 16 10 253 253 253 69 43 253 253 253 88 23 253 71 70 32 110
+ 253 253 253 253 25 99 99 253 78 127 253 253 253 253 253 253
+ 253 253 86 35 253 253 42 253 253 253 253 50 65 253 253 53 9
+ 89 253 253 253 253 253 253 253 253 54 61 100 68 118 253 86
+ 253 89 253 253 121 253 72 1 2 253 253 253 253 253 253 70
+ 253 253 28 253 253 253 253 253 253 92 253 253 253 87 23 253
+ 92 253 253 253 253 253 121 253 253 107 253 253 103 253 253
+ 35 253 253 253 253 84 6 99 253 85 36 253 34 253 98 253 34
+ 100 89 89 253 43 6 97 253 35 253 253 95 94 86 17 2 253 56
+ 253 105 119 253 253 253 253 253 39 253 253 27 253 16 95 113
+ 79 95 253 16 253 30 253 253 253 11 253 60 253 59 253 75 253
+ 103 77 91 253 58 101 253 253 253 253 253 253 253 253 78 97
+ 253 253 253 253 253 10 31 65 253 253 253 100 253 21 253 253
+ 253 29 253 5 87 253 253 110 253 109 31 80 253 36 111 32 39
+ 57 253 57 253 77 253 253 92 69 253 253 49 253 126 253 105
+ 124 86 253 27 125 70 22 253 253 253 9 2 253 253 253 53 76
+ 66 38 253 253 65 109 48 111 8 253 18 123 81 253 20 253 253
+ 101 253 253 253 253 94 253 14 253 105 27 253 106 253 253 20
+ 11 253 125 51 253 253 253 70 253 253 104 253 87 28 85 117
+ 117 253 117 253 253 253 84 87 253 253 26 253 108 253 5 3
+ 253 77 253 78 253 74 253 253 253 7 253 115 18 253 253 253
+ 253 33 27 48 253 64 24 26 253 126 13 108 253 253 253 253 9
+ 253 79 106 26 92 253 253 253 253 253 93 253 124 253 48 107
+ 34 253 39 253 253 253 0 253 122 253 253 253 253 253 65 253
+ 253 27 253 24 253 101 253 40 253 253 253 49 253 90 109 85
+ 29 124 253 253 253 253 19 28 98 253 123 253 253 64 46 253
+ 13 122 22 253 39 28 253 253 86 253 253 4 19 90 1 253 253 50
+ 28 253 253 52 91 253 253 55 253 62 253 56 91 68 253 88 110
+ 253 30 253 37 253 49 253 253 106 58 253 51 73 253 253 119
+ 19 253 253 253 253 61 253 253 253 12 253 253 79 253 57 32
+ 253 253 51 253 253 90 253 65 253 253 253 8 253 0 51 104 46
+ 125 106 115 253 78 253 124 17 113 253 253 37 26 85 253 122
+ 109 253 113 68 253 96 49 253 253 125 253 253 85 59 90 64
+ 119 124 253 253 253 43 5 43 253 31 79 253 10 253 36 44 26
+ 70 253 253 253 30 253 253 253 253 253 253 253 10 253 98 253
+ 253 253 253 253 253 253 28 253 253 88 122 253 253 253 253
+ 253 52 253 253 88 98 253 253 253 253 36 46 112 15 53 253 56
+ 253 253 65 253 0 253 77 253 253 69 253 118 253 253 253 54
+ 118 253 253 253 116 73 72 253 253 253 253 253 253 253 31
+ 253 22 18 253 26 36 253 2 72 21 60 253 64 253 253 253 106
+ 253 253 67 38 253 37 36 253 253 51 90 91 253 253 104 253 13
+ 18 253 253 253 253 127 46 43 5 253 253 253 253 55 127 253
+ 253 253 43 85 253 100 253 253 253 94 71 20 253 253 103 23
+ 43 253 125 253 84 253 253 253 253 253 253 43 100 253 40 253
+ 9 22 253 253 45 253 253 253 253 253 253 40 93 79 253 67 62
+ 253 253 22 253 253 1 253 96 53 98 253 253 12 253 253 253
+ 253 3 253 102 81 253 71 82 41 99 12 59 253 74 117 91 114 45
+ 253 117 31 253 103 253 253 253 253 253 45 55 44 17 99 253
+ 29 23 12 253 28 6 3 20 20 19 127 71 253 253 253 42 253 28
+ 253 253 7 253 253 103 253 253 0 253 253 253 253 120 253 3
+ 12 12 253 69 111 253 253 253 253 66 253 36 253 90 253 253
+ 253 253 253 253 74 253 89 253 67 123 11 6 57 253 21 63 253
+ 253 253 68 253 253 110 253 102 253 253 253 253 253 253 60
+ 253 253 253 253 253 253 253 253 253 253 253 15 25 253 253
+ 253 39 253 43 63 15 79 19 76 7 253 253 253 253 253 30 253
+ 50 253 43 42 253 48 253 253 253 253 253 55 253 71 253 253
+ 97 253 253 28 99 253 253 69 117 30 253 31 105 30 253 253 46
+ 253 253 75 253 253 253 253 253 253 60 253 70 253 253 80 253
+ 253 75 253 34 253 101 253 54 253 25 102 253 55 70 35 3 253
+ 118 253 108 39 87 253 66 253 108 61 253 253 253 253 253 119
+ 82 49 253 253 253 123 10 253 253 82 89 36 88 253 253 38 253
+ 121 37 76 253 253 253 123 36 253 253 253 253 253 20 253 60
+ 61 253 253 72 253 253 127 253 23 70 253 253 253 253 253 253
+ 107 103 253 253 253 253 70 86 253 66 28 253 3 253 26 58 253
+ 253 43 253 66 92 66 253 79 253 115 253 108 56 253 253 105
+ 253 115 105 60 253 253 253 23 80 253 253 71 5 253 122 253
+ 253 253 253 29 253 42 253 22 253 253 253 253 253 253 253
+ 253 70 253 45 21 81 253 253 253 10 253 253 253 71 253 253
+ 77 253 49 8 253 84 253 253 35 253 93 112 253 253 253 253 60
+ 93 253 116 37 253 39 10 0 126 41 253 119 81 1 253 253 22
+ 120 253 35 92 253 253 253 253 253 253 33 253 253 65 87 253
+ 253 13 50 87 253 253 253 253 126 253 253 253 253 253 253 10
+ 253 46 253 253 115 253 72 253 253 253 41 253 253 253 67 253
+ 9 51 12 253 253 114 253 82 120 106 56 113 80 253 253 72 88
+ 5 76 31 253 20 253 253 253 253 253 253 253 50 102 37 118
+ 253 253 253 253 253 253 253 18 71 253 253 253 253 84 119
+ 253 1 73 253 49 253 253 253 253 110 253 253 106 253 253 104
+ 253 74 29 253 253 253 253 29 253 89 253 58 77 253 253 253
+ 253 20 112 253 253 125 253 6 253 253 253 75 253 253 65 36
+ 113 253 253 9 0 253 253 15 253 253 19 79 253 253 79 42 25
+ 253 253 253 31 74 76 253 253 71 84 49 253 253 253 253 68
+ 253 253 253 253 253 6 253 56 86 28 253 253 45 253 253 253
+ 253 66 253 30 61 253 253 253 253 253 253 26 15 40 39 253
+ 253 107 253 22 253 253 46 37 36 124 253 127 253 253 83 91
+ 118 86 253 253 253 14 253 253 253 103 253 253 253 253 253
+ 253 253 48 86 39 253 253 253 253 253 253 253 56 17 91 253
+ 253 81 253 17 88 53 253 253 253 28 114 56 92 122 253 253 27
+ 253 253 253 253 24 253 253 253 43 85 253 50 253 14 15 36
+ 253 87 109 34 253 27 253 121 253 54 108 253 253 12 118 253
+ 82 253 253 253 112 253 253 253 253 253 253 77 30 118 120
+ 253 253 253 253 122 253 48 107 54 253 103 253 253 253 253
+ 253 253 253 253 253 253 253 253 101 109 50 82 253 253 253
+ 253 253 115 71 253 11 55 253 253 253 88 253 17 253 253 1
+ 253 253 253 253 57 102 253 68 107 48 54 253 27 24 253 68 15
+ 114 49 253 253 253 253 19 37 253 253 38 253 253 120 10 253
+ 253 86 253 253 108 253 123 9 253 253 253 253 253 253 253
+ 253 59 253 253 70 49 253 73 253 253 91 80 99 253 253 62 253
+ 253 253 253 111 253 75 253 24 253 253 253 253 90 109 103 31
+ 253 97 253 115 84 253 28 253 40 253 253 117 253 100 12 118
+ 253 253 253 253 253 92 48 253 34 39 253 253 253 253 14 24
+ 253 49 64 253 253 253 78 253 87 253 253 61 43 84 253 253 94
+ 55 253 253 253 253 253 61 253 253 89 101 253 16 108 61 253
+ 253 253 253 253 253 11 253 253 253 253 91 253 253 253 100
+ 86 32 119 253 109 80 30 253 95 79 253 253 30 253 253 253
+ 253 127 18 253 0 101 110 253 23 253 43 253 253 107 253 5
+ 253 253 30 119 29 253 54 44 125 253 127 253 28 119 253 73
+ 72 253 253 40 253 60 31 122 253 253 253 253 38 253 253 3 32
+ 253 119 253 21 253 253 253 12 253 67 115 253 84 253 91 253
+ 253 97 89 64 253 32 253 84 253 253 119 67 253 253 53 253 38
+ 253 30 25 253 112 253 29 69 63 48 253 73 253 65 253 83 13
+ 65 48 37 1 124 253 253 253 55 61 253 40 20 109 253 253 90
+ 253 253 4 253 78 253 70 24 83 253 253 80 253 253 69 16 253
+ 14 14 87 253 104 11 253 104 253 90 118 5 84 253 253 125 253
+ 253 126 253 253 21 253 253 69 253 4 103 13 253 253 253 253
+ 253 70 55 253 38 88 253 39 253 13 253 253 34 253 33 253 253
+ 253 253 253 253 253 253 121 253 85 1 97 253 112 253 90 253
+ 90 253 253 253 64 27 45 253 253 127 253 253 253 253 253 98
+ 253 253 253 253 77 253 253 99 70 253 253 253 99 253 253 253
+ 43 123 77 62 84 37 70 88 253 53 253 253 20 122 253 253 253
+ 127 253 100 102 12 71 7 253 253 253 253 80 253 253 123 253
+ 93 92 253 90 92 48 253 126 11 3 85 253 253 52 253 72 253 36
+ 253 253 253 125 105 253 26 253 253 253 253 253 48 75 253 26
+ 50 253 31 253 253 86 253 253 253 120 114 70 67 253 253 253
+ 253 123 78 253 253 253 25 60 57 29 36 94 123 112 125 253 77
+ 253 116 253 253 253 253 92 70 3 69 253 253 14 72 30 253 94
+ 253 253 70 42 93 253 70 127 3 111 32 5 253 28 253 30 253
+ 253 13 46 253 253 24 7 253 106 253 253 253 39 253 253 25
+ 253 2 253 110 1 253 253 253 45 253 253 253 22 112 6 10 253
+ 253 253 253 25 79 253 83 113 90 253 43 253 253 253 253 253
+ 253 253 253 253 38 69 97 253 253 90 253 253 253 91 253 253
+ 85 253 18 253 103 7 253 253 253 253 253 68 74 253 253 104
+ 253 253 253 253 253 51 108 73 97 253 253 2 110 35 93 253
+ 253 253 253 253 253 22 253 253 75 253 79 49 253 253 253 76
+ 253 253 253 253 30 253 253 253 116 253 113 19 253 19 253
+ 253 87 118 253 253 66 253 253 113 253 253 0 84 123 26 253
+ 253 17 253 79 253 58 87 253 47 85 90 20 253 99 120 253 253
+ 48 253 7 253 253 44 253 72 110 33 115 28 253 253 253 107
+ 253 253 73 253 253 13 34 253 43 253 91 253 86 86 253 103
+ 253 43 253 253 21 117 253 253 253 253 253 52 253 253 253 42
+ 79 57 253 101 253 253 253 89 37 47 253 253 123 62 27 253
+ 253 66 253 253 253 253 87 72 253 253 253 253 31 253 253 83
+ 11 125 67 253 86 98 67 253 253 92 253 119 20 253 85 253 97
+ 108 253 253 253 124 118 253 253 253 7 253 53 253 253 77 253
+ 253 8 253 253 106 253 5 122 9 94 253 253 34 253 253 253 119
+ 94 29 253 113 253 108 89 253 253 11 127 16 253 111 253 21
+ 253 69 35 253 253 253 253 3 253 253 253 253 253 253 253 41
+ 253 253 109 86 72 253 253 99 253 32 253 21 50 253 67 51 13
+ 253 70 253 253 253 253 91 1 54 253 253 79 106 253 105 49 31
+ 46 253 1 253 253 91 125 253 253 253 253 114 253 253 87 253
+ 253 253 96 31 253 115 103 253 23 118 253 253 36 82 253 55
+ 253 253 90 253 47 253 253 253 39 25 59 121 253 253 109 253
+ 0 40 116 120 110 253 253 99 119 97 84 253 253 253 101 253
+ 253 88 15 19 77 12 127 74 253 28 124 80 253 50 40 253 253
+ 70 70 70 253 125 40 253 124 40 253 106 253 253 253 253 89
+ 109 253 34 93 253 253 112 118 10 12 51 23 28 26 253 253 16
+ 253 253 253 253 40 253 253 18 63 253 115 121 30 61 253 253
+ 253 253 69 44 253 124 253 41 253 253 253 54 253 55 253 49
+ 253 27 253 25 253 253 253 105 102 253 24 91 9 253 253 253
+ 63 20 253 94 35 253 253 5 253 47 253 9 253 0 253 61 43 70
+ 54 253 253 253 253 253 101 33 79 253 35 103 253 253 52 113
+ 253 253 253 253 253 37 253 253 253 253 22 253 26 253 108 64
+ 22 253 14 253 76 115 74 253 253 76 253 253 253 120 253 253
+ 25 116 253 30 253 114 253 253 115 253 253 103 253 2 69 22
+ 253 42 253 41 38 15 253 97 253 253 104 253 109 253 253 253
+ 70 52 253 253 83 253 253 253 73 253 253 103 65 124 33 253
+ 253 253 106 18 99 120 253 121 253 106 253 253 50 253 253
+ 103 80 95 24 21 0 253 17 121 29 253 79 253 27 253 253 7 253
+ 253 253 45 63 253 253 72 253 83 28 87 61 118 253 253 63 34
+ 5 253 47 253 253 113 35 253 123 82 11 253 21 253 11 24 253
+ 71 114 106 73 253 90 72 253 253 27 21 253 124 122 253 102
+ 253 53 253 253 253 253 0 61 253 37 89 253 29 253 53 75 253
+ 111 21 13 253 253 108 112 91 253 253 253 97 109 58 34 253
+ 18 253 253 97 253 25 253 253 253 253 126 253 253 82 253 33
+ 117 253 253 5 91 253 253 74 81 38 253 119 253 23 253 253 13
+ 36 64 111 253 253 120 107 68 253 77 253 59 253 253 99 253
+ 253 109 253 253 81 253 121 253 253 253 84 253 253 253 253
+ 55 119 18 90 253 253 253 253 253 253 107 253 79 253 32 253
+ 253 24 33 253 253 3 253 253 85 253 253 17 253 253 44 253
+ 116 39 42 87 253 253 106 253 77 253 83 253 61 31 45 253 253
+ 253 1 102 27 100 118 253 29 253 253 21 253 253 253 253 253
+ 117 88 99 32 253 102 0 253 79 253 253 253 114 253 253 91
+ 253 253 253 31 106 253 62 29 116 253 253 253 14 253 253 253
+ 115 253 253 253 79 253 253 85 23 253 253 40 253 116 253 93
+ 13 253 253 94 74 18 253 253 114 14 72 92 253 106 253 253 14
+ 253 253 253 253 253 49 253 253 72 253 253 253 48 253 30 253
+ 253 253 253 47 24 253 253 57 97 253 253 253 253 253 85 253
+ 253 100 34 253 253 57 28 122 253 102 253 253 58 97 20 253
+ 253 253 253 253 253 253 72 103 253 253 253 253 253 28 17 78
+ 83 253 253 253 4 253 96 7 111 126 253 58 253 108 253 90 253
+ 40 253 253 253 253 253 253 253 77 253 54 253 110 34 253 253
+ 113 123 101 115 115 253 253 253 101 253 253 113 81 253 106
+ 35 253 61 46 253 253 44 118 104 3 38 253 253 253 253 253
+ 253 253 45 253 101 119 0 9 35 253 41 14 253 104 253 73 101
+ 10 253 253 253 119 253 50 253 89 253 253 87 253 48 77 60
+ 253 253 110 253 253 253 253 1 253 253 253 253 253 253 253
+ 22 253 86 75 117 253 95 31 253 253 114 106 253 69 253 253
+ 52 71 111 57 46 113 253 253 253 253 253 253 253 253 110 90
+ 253 253 94 253 22 253 253 126 253 253 253 45 253 81 253 253
+ 253 253 105 35 253 253 253 41 67 253 122 15 253 253 253 253
+ 66 77 47 82 51 89 54 17 78 55 19 253 125 253 253 94 105 253
+ 253 253 22 253 16 253 44 124 64 125 90 253 253 253 253 253
+ 102 253 70 62 253 31 253 94 124 90 57 84 253 54 116 39 253
+ 253 253 253 253 78 253 124 92 52 99 12 24 253 84 253 125 74
+ 253 253 22 13 253 35 12 7 253 125 15 253 253 253 65 253 253
+ 253 253 253 12 253 253 253 253 253 253 30 253 253 66 253
+ 253 114 253 253 253 253 253 253 253 253 104 57 61 253 45
+ 253 253 48 52 253 253 253 34 253 37 253 67 26 253 81 253 61
+ 253 253 253 49 100 85 253 112 63 90 253 45 253 253 253 253
+ 79 82 37 80 253 253 102 253 26 9 253 67 120 253 72 85 91
+ 253 72 253 114 59 253 253 18 88 253 116 253 253 253 253 98
+ 253 253 66 253 253 253 253 31 74 253 253 253 253 253 35 253
+ 253 253 253 253 253 118 253 110 253 97 23 253 49 73 253 253
+ 54 253 29 92 253 253 253 109 253 115 253 253 253 87 51 253
+ 0 253 20 253 13 253 120 78 253 124 253 253 253 253 253 253
+ 27 123 23 50 76 82 69 253 253 253 92 253 253 253 253 253 93
+ 84 253 43 29 253 253 55 253 253 253 83 103 14 94 253 60 113
+ 50 75 18 253 79 253 253 52 94 253 2 253 253 253 253 84 253
+ 50 253 253 253 7 253 253 118 12 253 253 253 18 75 71 56 79
+ 253 25 101 81 253 99 253 253 253 253 253 27 253 253 253 74
+ 24 253 253 24 112 43 253 32 253 41 253 253 8 253 86 62 48
+ 253 253 253 253 93 253 45 3 253 253 253 253 253 90 105 253
+ 46 97 24 253 253 72 253 115 253 16 41 253 253 58 253 99 253
+ 93 28 124 253 57 31 253 76 253 70 35 253 64 253 8 253 253
+ 47 121 253 0 253 253 253 0 45 82 49 253 253 58 116 91 253
+ 253 253 253 253 253 253 53 35 105 60 253 253 71 253 59 111
+ 253 99 253 253 253 39 120 253 253 115 61 253 58 49 253 62
+ 253 27 106 40 253 11 253 253 253 253 90 52 110 112 15 124
+ 253 80 253 59 253 60 253 253 93 253 52 5 27 253 123 98 253
+ 253 253 253 121 123 23 111 253 253 25 19 253 253 253 25 253
+ 25 253 253 253 123 253 253 253 253 6 72 253 55 16 253 253
+ 253 253 61 253 253 253 253 253 76 253 12 22 253 253 49 99
+ 253 253 253 253 253 253 253 253 82 253 81 253 125 123 87 36
+ 253 253 117 253 253 96 58 253 253 253 59 253 253 20 253 253
+ 253 253 53 1 253 253 21 253 253 253 253 253 60 253 253 43
+ 87 94 253 125 253 253 20 253 73 17 253 118 25 253 253 253
+ 253 253 253 253 81 90 253 253 114 253 253 72 253 253 86 253
+ 91 253 253 34 253 253 51 253 253 253 253 86 120 81 64 43
+ 253 57 253 253 68 253 85 123 61 253 253 95 57 67 253 63 78
+ 253 253 26 107 253 12 253 253 253 253 253 61 253 1 113 118
+ 253 253 253 253 15 253 118 67 29 253 100 253 253 253 25 125
+ 127 253 37 253 253 253 253 253 15 253 39 253 59 88 253 96
+ 253 253 90 253 253 36 253 253 253 253 80 71 44 253 42 253
+ 253 102 56 81 253 253 253 253 253 87 119 100 253 253 253
+ 253 38 253 253 70 24 253 11 24 253 253 253 253 39 253 253
+ 253 253 13 253 114 107 91 40 63 18 33 253 114 253 253 72
+ 253 253 125 126 253 76 253 0 253 253 253 253 90 253 29 253
+ 253 253 92 253 253 253 253 253 118 253 29 253 253 57 31 95
+ 253 253 253 67 253 253 19 79 111 28 23 17 253 94 51 253 21
+ 253 0 10 253 253 253 253 14 42 253 253 253 51 253 56 253
+ 253 253 76 253 253 60 52 109 25 57 253 62 253 253 23 253 18
+ 93 21 253 101 66 253 253 253 253 253 253 60 62 42 253 253
+ 253 253 253 111 253 253 78 253 253 101 253 253 77 253 91 97
+ 53 253 253 56 86 253 19 253 253 253 253 0 253 253 99 253
+ 253 88 253 34 253 11 253 253 253 95 72 74 253 253 99 70 54
+ 96 118 28 10 87 127 110 100 253 112 118 47 115 77 253 253
+ 253 80 119 253 253 253 42 253 15 253 253 253 119 253 104 57
+ 39 253 37 117 96 85 253 253 253 51 253 125 105 102 253 253
+ 69 54 253 34 253 46 253 253 30 253 0 74 253 93 253 101 253
+ 35 47 253 253 33 253 65 253 111 61 253 253 253 253 253 70
+ 253 70 253 253 96 43 36 253 253 105 100 109 81 253 253 0 26
+ 122 94 253 253 119 19 36 253 69 30 60 253 32 36 253 253 0
+ 253 115 30 253 38 253 83 13 253 52 108 59 6 24 56 253 253
+ 63 253 253 253 92 105 253 21 253 253 253 19 103 253 21 87
+ 43 253 98 73 253 92 75 253 71 69 253 253 122 253 253 253
+ 109 253 104 253 35 253 24 32 125 72 253 253 253 253 100 114
+ 69 253 22 253 253 253 121 78 1 253 253 253 70 253 115 107
+ 34 253 253 98 253 253 122 253 253 6 100 253 253 79 106 253
+ 5 253 253 253 47 98 49 85 253 22 46 253 97 69 253 51 92 95
+ 253 253 253 253 5 253 99 61 253 253 105 116 253 253 111 113
+ 98 30 50 253 84 253 7 61 253 253 115 253 253 253 253 253 88
+ 47 253 253 52 108 26 253 253 253 253 253 253 253 11 253 253
+ 253 0 253 77 35 253 253 253 253 57 18 253 103 91 253 253
+ 253 110 23 116 253 253 102 50 125 13 77 116 75 253 109 109
+ 253 33 103 25 253 253 253 253 253 253 253 34 36 253 8 253
+ 36 104 253 7 253 253 7 253 253 253 253 77 90 253 253 253 26
+ 9 55 2 61 253 253 253 101 253 253 74 107 253 77 121 113 115
+ 253 253 253 70 36 253 253 30 99 47 253 253 253 253 62 46 90
+ 90 253 253 34 77 104 253 54 253 0 253 253 253 91 253 253
+ 253 113 19 96 253 36 253 253 253 253 253 253 51 106 253 86
+ 112 70 253 253 253 84 253 53 100 253 105 82 35 18 57 99 90
+ 7 253 43 4 253 33 91 253 123 86 107 253 110 253 253 36 101
+ 253 19 253 0 253 253 21 253 253 121 39 253 253 253 253 253
+ 32 253 71 253 253 253 105 253 253 8 253 253 253 253 253 109
+ 253 253 253 253 253 51 253 85 253 253 74 87 253 61 69 29
+ 253 253 253 253 253 40 253 57 253 51 103 6 253 253 8 93 58
+ 253 60 127 71 127 253 104 253 62 253 22 253 253 253 101 253
+ 127 253 253 253 0 45 20 253 24 85 253 73 26 253 65 253 253
+ 18 86 70 100 50 253 253 90 89 104 253 253 86 253 253 63 253
+ 63 253 253 253 100 253 253 112 253 253 253 69 37 101 99 253
+ 116 253 253 253 253 42 253 50 31 8 253 253 253 253 253 127
+ 87 0 253 94 9 253 253 253 78 14 51 253 253 253 253 253 253
+ 39 127 8 122 253 253 253 253 253 253 253 54 253 253 113 253
+ 52 71 92 124 78 253 253 23 253 253 253 28 253 253 253 113
+ 253 253 88 253 253 253 253 44 80 253 253 253 253 253 253 38
+ 253 253 253 253 121 49 73 253 101 63 253 79 45 253 253 253
+ 253 73 78 253 107 253 29 90 253 92 253 101 113 39 253 253
+ 253 34 104 102 253 253 253 56 253 104 253 6 61 253 253 253
+ 107 11 253 118 253 253 115 52 123 72 253 117 42 253 253 253
+ 253 57 35 253 15 24 253 253 253 115 114 14 253 253 253 253
+ 18 48 253 23 253 122 253 18 51 72 253 253 253 253 124 253
+ 89 253 253 253 82 45 15 253 253 253 253 64 35 253 253 50 60
+ 253 253 60 253 253 122 253 34 253 253 253 105 22 52 83 253
+ 56 21 119 124 40 253 61 22 11 120 117 14 253 91 71 253 253
+ 253 253 253 253 253 253 253 76 253 253 253 63 253 253 18
+ 253 18 57 54 253 100 253 253 253 63 253 91 58 253 90 125
+ 107 82 253 0 253 61 62 253 253 253 253 253 253 120 253 253
+ 82 82 253 69 253 253 253 253 253 253 253 36 253 253 27 253
+ 53 90 60 43 62 253 253 253 253 253 253 124 122 30 253 253
+ 31 29 52 104 253 253 95 253 32 5 27 100 36 253 45 253 253
+ 10 253 253 62 14 116 119 78 253 49 106 29 125 253 253 6 78
+ 253 253 253 253 253 253 253 126 25 253 253 0 253 31 253 253
+ 111 253 253 253 253 75 11 33 253 58 253 253 253 253 253 111
+ 253 253 253 18 253 105 41 253 127 11 55 77 253 253 13 253
+ 253 52 253 253 62 32 50 253 253 57 253 253 253 71 253 253
+ 253 253 122 253 5 253 105 253 253 57 253 14 11 253 120 253
+ 63 253 253 92 19 253 253 53 253 80 253 253 253 253 37 96 36
+ 8 112 28 122 30 61 49 87 123 253 75 105 253 99 253 52 253
+ 69 118 253 26 0 16 253 253 74 253 104 10 253 71 82 105 125
+ 92 253 27 253 253 253 253 253 12 41 37 253 45 253 68 75 253
+ 79 115 253 253 5 253 253 253 253 84 103 253 253 253 253 253
+ 253 23 49 253 121 21 93 253 36 253 253 253 63 253 90 253
+ 115 72 253 28 109 253 86 95 48 30 253 253 46 253 68 253 62
+ 253 253 22 88 78 21 253 253 46 120 253 44 126 253 253 253
+ 253 72 124 104 253 253 79 13 253 39 0 253 253 253 55 253 64
+ 44 102 54 86 40 36 33 28 253 7 21 76 253 62 253 115 253 253
+ 253 253 30 37 253 253 49 253 253 253 62 253 88 253 253 253
+ 62 34 253 253 58 102 253 2 121 12 14 253 120 80 253 253 253
+ 253 253 54 253 253 253 78 253 253 253 253 253 253 110 253
+ 253 253 16 253 40 253 253 78 113 253 253 253 17 53 127 253
+ 104 253 75 123 253 253 74 17 20 253 253 63 253 253 0 62 253
+ 82 116 253 253 253 117 70 253 107 253 253 253 120 253 253
+ 79 253 253 253 253 253 253 111 253 28 253 97 20 253 253 253
+ 253 253 58 99 87 253 253 253 73 107 36 48 253 16 253 253 70
+ 253 253 77 253 62 253 253 253 253 253 63 253 253 13 253 253
+ 253 108 253 26 9 253 13 46 253 115 253 3 253 81 85 253 123
+ 253 253 79 253 58 54 253 253 253 253 253 96 36 253 110 10
+ 253 253 64 253 103 253 70 126 35 124 48 253 253 99 6 253
+ 253 253 253 253 253 253 70 253 7 2 253 253 55 41 69 121 116
+ 68 62 34 253 106 253 253 253 73 100 253 61 253 253 17 253
+ 66 253 253 80 253 253 39 253 253 28 253 253 105 253 105 253
+ 87 253 253 26 59 253 253 253 127 13 253 23 253 253 44 14
+ 253 253 253 253 68 106 253 61 253 107 110 253 253 30 119 14
+ 253 253 253 253 253 120 253 66 253 253 253 33 253 64 42 79
+ 57 253 253 253 81 253 67 28 108 18 34 253 27 253 115 75 253
+ 13 58 253 253 253 57 253 105 30 253 26 50 253 253 12 253
+ 106 111 253 100 253 253 14 110 45 100 30 29 253 108 93 253
+ 253 253 253 253 253 253 253 253 46 253 253 65 116 253 253
+ 253 253 14 56 39 253 253 253 253 253 253 102 114 65 253 253
+ 29 45 253 253 253 253 253 123 82 253 13 253 253 253 111 94
+ 253 127 103 35 13 253 89 59 103 253 253 30 253 253 55 253
+ 253 253 253 28 253 253 81 14 253 253 46 253 42 253 52 253
+ 253 253 3 253 253 253 55 121 253 253 253 253 62 253 62 253
+ 119 253 106 33 86 39 253 15 253 81 80 253 28 253 253 102 84
+ 57 35 253 81 91 33 60 96 253 253 42 253 253 253 77 253 45
+ 72 53 253 65 253 28 253 253 12 110 20 253 253 107 50 253
+ 253 253 253 97 14 253 253 100 253 253 253 26 88 99 0 35 253
+ 253 253 35 41 253 62 253 126 253 34 253 101 76 115 75 35 4
+ 253 124 253 43 70 253 253 253 122 63 253 253 253 0 253 71
+ 73 253 87 253 122 7 80 253 0 54 94 253 0 253 253 253 90 41
+ 42 48 253 253 253 61 253 13 253 34 76 10 253 4 91 101 25
+ 253 253 253 253 95 253 253 253 74 253 13 123 253 40 253 253
+ 55 56 253 115 92 253 71 24 253 253 77 103 253 253 29 253
+ 253 23 253 3 253 104 29 53 253 69 253 253 28 253 253 32 48
+ 31 122 253 253 253 253 253 253 107 253 77 85 253 253 253
+ 253 253 253 253 75 20 253 253 253 38 253 253 253 253 95 83
+ 57 253 253 0 123 28 253 97 253 253 23 119 6 86 113 253 3 28
+ 3 64 73 118 105 253 253 75 253 253 71 96 253 253 62 253 253
+ 43 30 253 253 253 90 68 253 253 69 24 253 76 56 253 101 82
+ 71 253 84 253 253 253 253 253 117 125 13 253 54 253 253 30
+ 253 253 253 253 253 50 61 253 253 17 93 253 253 19 50 253
+ 102 24 78 253 253 253 253 29 55 105 99 253 253 253 104 253
+ 253 253 253 1 35 253 5 253 253 253 116 95 253 91 125 52 67
+ 53 253 253 253 12 22 9 253 126 253 105 253 253 54 58 126
+ 253 27 253 253 253 60 253 253 115 253 84 253 100 101 253
+ 253 253 253 127 16 35 253 253 54 253 107 253 253 82 253 253
+ 102 43 28 64 121 253 253 126 253 253 253 253 253 253 110
+ 253 253 59 253 253 55 120 114 253 0 23 124 253 253 253 36
+ 90 253 253 253 253 46 104 35 253 4 39 108 253 60 253 253
+ 253 253 115 84 102 253 253 253 3 253 253 253 253 253 98 49
+ 253 253 65 253 66 253 253 253 86 253 41 73 81 57 253 22 75
+ 126 54 92 253 106 253 105 253 45 253 80 253 62 253 253 127
+ 20 127 74 19 253 253 253 253 253 253 38 253 113 253 69 121
+ 103 125 101 56 253 44 99 102 253 6 60 253 253 103 253 253
+ 253 20 253 253 253 253 0 253 55 87 253 253 253 106 38 253
+ 29 67 24 253 33 253 7 31 253 253 80 253 42 253 77 253 9 253
+ 253 253 34 120 116 93 253 60 253 253 253 253 253 253 253
+ 253 36 63 253 253 253 253 122 59 253 253 28 95 253 44 42 62
+ 68 123 253 116 253 33 117 253 20 71 109 12 253 51 36 95 253
+ 253 253 0 253 51 253 253 73 253 27 253 253 253 253 253 71
+ 253 61 253 2 56 253 253 253 253 35 253 77 93 99 94 75 88 99
+ 72 253 253 253 253 10 253 9 253 253 122 35 69 253 253 253
+ 113 253 112 23 253 91 253 105 61 253 122 116 253 109 253
+ 253 253 253 72 253 99 253 44 253 253 253 253 253 253 253
+ 253 10 253 84 253 37 105 49 49 72 253 127 253 253 20 253
+ 253 253 253 86 107 115 34 253 253 69 108 253 253 21 253 253
+ 126 90 40 253 92 115 82 253 253 76 73 253 23 253 253 253
+ 253 253 17 77 43 73 110 253 253 66 57 253 36 253 93 26 253
+ 253 253 253 3 92 253 253 253 253 253 49 86 11 61 253 253
+ 105 20 253 253 253 80 48 43 69 253 253 253 253 253 28 107
+ 27 24 253 253 127 95 253 253 253 61 28 253 253 253 253 88
+ 253 13 44 253 43 73 31 253 89 253 0 253 253 65 124 52 253
+ 253 253 253 253 253 34 253 253 37 253 253 253 253 253 20
+ 253 253 10 253 7 106 253 114 1 253 31 253 39 74 253 253 253
+ 68 82 126 72 47 253 253 253 253 66 44 253 253 125 107 79 75
+ 123 253 253 253 253 36 253 112 14 10 48 253 253 86 253 253
+ 9 78 253 253 253 28 253 253 109 253 111 109 253 253 253 6
+ 253 45 253 98 253 89 34 13 253 253 253 40 253 253 253 122
+ 253 253 253 253 253 253 253 123 92 253 253 15 253 253 253
+ 253 253 253 62 94 59 253 85 78 253 253 253 85 253 253 253
+ 253 44 253 29 51 80 253 76 59 253 253 253 253 253 110 121
+ 253 253 253 111 88 253 86 253 253 253 53 7 76 253 23 253 35
+ 72 253 37 121 34 253 50 125 253 8 97 253 95 43 61 95 253
+ 253 0 59 22 124 80 253 35 253 82 80 253 51 75 253 253 253
+ 253 253 25 31 253 17 253 17 253 111 253 253 253 253 253 253
+ 253 109 103 71 253 59 16 253 73 253 91 253 28 99 253 253
+ 253 15 58 89 110 253 4 253 253 39 113 32 253 253 93 114 253
+ 253 0 82 43 253 253 253 22 253 107 2 253 253 253 253 253
+ 253 64 7 253 253 253 35 253 253 103 18 253 111 253 253 126
+ 54 253 253 47 253 253 253 253 12 253 253 34 253 75 253 253
+ 86 62 11 7 25 253 43 253 58 253 253 44 253 120 36 73 6 253
+ 253 99 253 4 19 253 42 253 253 253 253 98 253 253 126 51 78
+ 18 73 30 114 253 87 3 253 40 253 253 83 253 78 253 44 103
+ 52 253 78 253 253 54 253 253 122 127 47 253 253 119 125 31
+ 117 14 253 39 253 60 72 6 74 253 253 253 106 253 9 109 91
+ 44 253 253 28 110 20 253 253 253 253 59 253 30 253 253 6 21
+ 253 9 253 123 253 117 19 21 253 101 35 253 68 58 114 253 52
+ 41 253 253 253 64 253 253 58 253 120 108 253 253 77 35 253
+ 22 8 253 253 98 253 16 253 21 112 8 253 15 63 253 253 6 112
+ 125 43 253 35 110 253 0 253 0 253 87 23 65 24 66 253 121
+ 253 253 109 253 253 21 253 15 42 121 253 28 253 253 59 253
+ 253 24 79 253 253 84 253 253 253 253 253 79 253 253 253 253
+ 253 253 253 17 253 115 69 105 35 49 45 99 12 253 253 253
+ 253 15 253 101 253 253 253 253 0 253 253 101 24 10 253 74
+ 11 81 253 77 253 253 0 253 253 253 253 253 66 253 253 253
+ 253 253 103 105 253 253 42 253 57 253 117 57 39 253 107 103
+ 110 253 253 253 10 63 253 253 126 253 253 98 253 253 20 10
+ 253 67 56 253 65 253 16 253 15 122 57 253 253 253 253 115
+ 64 88 253 124 49 253 27 28 101 92 253 114 41 253 253 27 43
+ 253 253 38 61 66 76 115 253 127 74 253 91 253 102 253 87
+ 253 88 253 253 253 253 111 253 6 253 126 253 253 253 253
+ 253 253 24 253 2 50 57 62 253 253 253 253 120 253 106 253
+ 253 253 59 253 94 38 253 22 253 116 100 87 253 253 80 70 49
+ 253 253 58 43 73 68 253 253 253 52 253 253 253 23 35 56 253
+ 58 34 72 253 253 58 47 54 253 253 253 24 253 253 253 79 253
+ 31 77 16 253 253 253 67 25 6 253 42 13 253 253 253 253 123
+ 253 253 253 13 253 26 253 253 253 57 253 0 26 95 253 86 253
+ 14 38 0 253 17 253 125 42 75 20 6 20 41 26 253 253 40 253
+ 253 253 253 253 24 60 253 78 89 87 253 253 253 253 253 253
+ 253 253 253 22 253 60 253 253 253 74 1 34 253 253 253 253
+ 253 253 253 253 79 253 47 72 111 89 117 61 99 84 253 253
+ 253 103 33 253 253 253 10 253 0 42 253 253 253 253 253 253
+ 253 253 50 253 253 77 44 253 253 54 8 65 253 36 253 40 253
+ 253 253 253 95 253 253 253 73 17 253 91 253 253 253 253 253
+ 253 253 253 253 253 6 253 55 37 118 253 124 253 253 253 253
+ 253 253 253 118 253 253 80 74 54 253 1 90 97 253 253 253
+ 253 3 81 253 253 253 91 125 63 77 88 108 253 70 21 97 253
+ 253 43 253 53 45 120 119 253 253 253 253 253 253 124 24 253
+ 10 1 96 59 253 253 116 253 76 253 104 253 253 253 253 4 101
+ 253 253 253 94 91 253 253 253 253 11 26 91 253 47 253 253
+ 26 52 117 23 55 18 44 253 253 32 253 253 126 253 97 105 253
+ 20 118 253 253 120 107 253 2 121 52 253 18 107 253 253 117
+ 35 253 17 70 253 66 107 125 253 253 253 253 59 119 1 253
+ 253 253 253 106 118 51 105 253 99 27 253 253 20 253 253 85
+ 51 253 90 253 253 253 27 36 55 253 253 253 253 253 3 253 57
+ 253 253 253 253 253 253 32 253 101 44 253 99 53 59 41 253
+ 253 20 253 253 41 119 253 56 253 253 31 105 121 29 253 42
+ 253 253 3 253 253 42 253 107 120 2 16 253 100 253 253 253
+ 253 253 253 13 20 253 253 253 253 50 86 9 53 123 50 253 11
+ 11 107 253 41 253 60 99 35 4 253 0 125 85 253 71 253 82 253
+ 87 15 123 4 253 253 49 253 32 28 15 92 253 86 253 120 253
+ 40 4 33 253 12 253 54 253 253 253 253 37 253 253 75 253 253
+ 70 253 253 38 80 59 12 253 253 19 253 75 253 77 117 119 76
+ 253 117 23 78 253 47 253 99 253 253 121 253 253 54 253 3
+ 253 253 253 253 253 29 51 253 253 253 122 253 95 27 104 110
+ 253 253 76 253 253 83 253 117 43 87 61 253 76 54 253 118
+ 253 89 253 81 68 91 43 253 95 113 253 124 253 116 253 59
+ 253 54 23 81 253 110 253 253 253 64 54 122 253 39 253 104
+ 114 98 73 253 91 253 125 35 253 105 98 107 75 29 66 7 253
+ 253 60 253 57 0 59 121 253 39 253 253 253 253 56 45 253 253
+ 253 253 36 253 253 44 253 253 253 253 253 253 253 253 106
+ 253 111 43 77 19 68 121 253 253 253 253 253 253 79 253 253
+ 93 253 253 253 253 253 253 106 253 64 48 87 253 30 253 253
+ 40 253 253 253 5 253 77 253 36 102 48 253 7 36 253 253 253
+ 253 253 27 70 253 253 41 253 253 253 253 105 253 253 10 22
+ 12 253 109 253 253 253 126 253 90 253 119 110 253 6 253 253
+ 253 253 253 72 45 253 253 69 253 75 253 125 121 61 253 100
+ 5 30 253 253 115 253 253 253 253 253 68 253 253 32 25 253
+ 83 253 98 7 34 253 253 88 253 253 79 253 23 253 253 253 253
+ 10 253 253 0 253 41 80 99 115 120 253 253 3 253 67 6 253 28
+ 253 253 117 84 253 79 253 121 253 253 253 123 26 253 3 253
+ 253 81 14 253 253 253 253 253 253 253 253 253 82 253 50 23
+ 253 76 253 253 79 253 31 83 253 62 113 253 253 69 69 10 17
+ 253 56 253 66 70 253 20 253 115 68 71 56 0 125 120 253 253
+ 253 253 253 49 253 253 86 74 25 125 43 253 28 14 56 253 101
+ 253 253 84 48 253 89 82 253 46 54 253 253 109 253 253 49
+ 125 253 29 96 253 253 121 253 253 253 253 253 71 21 253 53
+ 253 253 253 253 29 253 109 70 54 253 253 120 253 253 54 253
+ 253 0 45 18 119 46 57 253 253 117 94 116 59 253 253 253 253
+ 0 253 107 24 253 89 51 27 24 6 15 253 253 253 253 13 253
+ 100 103 53 253 253 15 253 253 253 253 253 253 253 253 253
+ 253 110 253 253 99 253 109 59 253 127 253 22 85 73 60 253
+ 90 110 68 32 253 122 34 114 253 253 253 253 253 253 117 29
+ 89 39 253 16 253 253 54 253 253 6 253 54 101 29 253 54 9
+ 253 107 111 65 52 119 55 253 253 14 253 253 253 123 253 120
+ 253 111 253 253 253 1 253 76 253 33 253 253 113 71 253 41
+ 88 253 0 104 253 36 253 253 253 100 253 253 253 79 84 58
+ 126 71 78 253 253 67 253 91 71 31 38 76 42 17 253 86 253 71
+ 253 253 40 253 253 253 104 3 30 253 85 116 253 107 47 253
+ 253 253 26 121 253 106 253 253 253 68 253 253 253 253 103
+ 118 253 253 253 253 253 253 253 52 74 253 101 92 7 94 113
+ 81 253 253 253 253 65 45 253 115 0 66 253 253 253 13 253 85
+ 253 253 48 60 253 253 253 92 118 253 253 253 253 253 118 96
+ 253 253 63 253 253 125 0 253 253 253 107 253 26 41 253 253
+ 105 32 81 253 100 67 37 253 104 253 62 253 253 44 37 253
+ 253 253 127 253 93 253 253 253 253 34 85 253 107 253 253
+ 253 9 27 121 253 56 253 107 55 45 34 253 114 253 253 47 4
+ 253 9 253 10 253 253 79 89 253 97 27 94 77 34 253 47 253 51
+ 30 13 9 253 253 253 253 253 24 80 18 253 253 253 61 69 71
+ 253 253 253 88 253 88 85 21 45 253 60 5 39 253 51 80 253
+ 253 65 253 73 37 253 54 253 70 253 4 14 70 59 81 76 106 253
+ 253 23 55 253 91 253 127 253 105 253 48 253 48 253 253 3
+ 253 0 253 253 58 253 253 6 253 253 253 253 69 253 123 253
+ 84 253 253 253 253 11 85 101 253 47 253 53 30 253 253 253
+ 40 100 123 125 56 54 253 253 253 111 46 51 253 253 106 53
+ 253 253 253 253 253 253 15 253 70 43 253 7 253 100 15 253
+ 93 115 122 253 253 111 115 4 1 253 253 98 253 3 253 91 253
+ 253 253 253 253 44 117 253 23 112 253 17 66 253 253 253 9
+ 253 58 253 253 253 53 93 29 113 253 5 35 43 253 0 253 81
+ 127 253 253 68 15 253 0 253 47 253 86 253 118 253 253 76 23
+ 253 28 113 253 253 253 124 105 253 91 59 253 253 87 253 253
+ 253 253 99 253 35 253 62 253 116 253 76 126 31 253 253 44
+ 57 253 253 119 85 253 118 253 253 74 40 12 79 4 253 20 90
+ 111 253 27 253 46 253 253 253 253 19 253 253 109 253 253
+ 253 253 253 61 253 253 253 79 253 126 253 34 253 21 253 41
+ 26 253 253 253 253 8 253 253 253 29 253 253 253 100 253 41
+ 36 253 88 253 253 120 253 253 253 253 123 253 253 253 253
+ 253 253 253 253 19 76 253 36 253 253 253 253 253 9 253 253
+ 253 253 118 253 73 253 93 58 63 80 253 253 35 105 23 253
+ 108 253 46 6 253 253 253 253 253 253 253 89 253 65 27 74
+ 253 38 253 15 253 253 253 253 253 122 253 253 253 253 55 80
+ 253 253 20 253 18 47 253 253 253 253 117 111 253 67 253 253
+ 18 5 253 78 3 10 91 12 83 110 253 253 85 253 253 110 90 253
+ 68 253 6 95 253 42 60 253 253 79 253 72 253 125 111 38 253
+ 53 253 253 253 118 124 253 253 253 26 253 115 253 253 253 0
+ 88 253 88 253 85 253 253 68 116 253 253 34 119 253 253 69
+ 109 253 113 253 253 108 253 75 31 72 253 120 253 48 25 4
+ 253 12 253 43 116 253 253 253 15 13 99 98 8 253 253 105 253
+ 91 96 253 253 43 97 253 30 253 253 106 253 253 253 98 253
+ 253 253 253 253 253 91 36 253 58 43 253 253 253 72 46 32
+ 253 67 253 13 253 253 85 31 25 253 253 253 253 85 253 253
+ 21 253 253 253 253 30 61 69 91 253 94 127 21 104 95 4 253
+ 121 126 253 89 253 117 253 87 90 116 126 59 253 27 105 92
+ 253 64 21 37 26 118 91 253 253 253 253 62 253 253 53 16 253
+ 103 28 110 78 73 253 253 47 253 0 253 253 55 253 253 37 253
+ 70 61 57 253 29 89 253 92 104 253 253 253 253 253 34 124
+ 253 122 99 253 253 253 253 253 74 253 114 64 253 86 82 100
+ 253 253 67 34 108 46 115 69 71 38 253 253 41 100 47 253 122
+ 54 253 253 253 253 253 253 45 58 24 253 253 253 62 253 253
+ 253 103 253 253 68 253 253 94 253 96 20 14 106 253 34 97 0
+ 253 121 25 29 253 124 253 37 111 8 253 59 26 253 253 6 77
+ 253 253 123 253 122 253 70 253 253 121 253 253 253 253 253
+ 21 253 84 35 253 77 253 253 17 57 63 109 253 65 27 87 60 80
+ 253 253 253 0 253 111 127 253 253 253 24 253 253 38 21 253
+ 253 253 253 253 253 253 127 253 110 4 9 121 25 253 108 37
+ 85 253 253 95 85 253 110 253 253 253 253 253 36 7 253 26
+ 253 41 30 253 253 25 253 78 71 253 109 253 64 16 253 95 65
+ 253 88 90 16 109 253 253 28 86 253 253 119 253 60 253 253
+ 107 124 73 253 121 16 253 253 95 26 80 23 253 253 253 253
+ 253 9 253 121 253 253 253 253 51 57 39 253 253 253 253 253
+ 253 105 82 253 253 253 253 253 11 253 110 53 253 253 23 253
+ 253 253 122 44 81 253 48 253 253 0 61 49 74 24 253 14 122
+ 66 253 253 94 48 253 253 80 63 253 253 88 90 72 96 253 54
+ 56 253 105 7 78 88 253 31 52 253 253 94 88 253 253 79 253
+ 74 32 253 75 123 116 253 68 253 118 110 253 253 253 46 253
+ 253 58 65 18 253 74 253 253 112 59 84 115 253 46 253 253
+ 253 95 121 44 62 81 253 253 253 253 253 119 81 253 108 253
+ 253 42 25 253 90 253 253 253 102 93 253 253 119 96 41 253
+ 42 253 253 29 253 107 71 253 87 35 253 99 253 106 35 253 90
+ 253 78 5 253 253 22 99 253 41 253 253 253 44 26 83 52 101
+ 76 44 48 54 118 53 26 253 109 253 253 253 33 253 253 12 12
+ 253 25 253 253 47 12 111 76 253 124 53 253 253 16 45 253
+ 253 110 64 114 115 253 84 253 253 253 101 78 253 123 102
+ 253 26 56 253 253 102 253 123 67 253 75 123 51 101 8 13 253
+ 12 127 253 253 92 107 253 253 27 253 126 253 253 98 253 253
+ 253 124 253 253 105 253 28 253 253 68 253 52 253 12 48 44
+ 118 253 253 253 253 253 37 15 253 62 253 253 53 63 1 253 60
+ 39 253 253 84 253 253 46 253 253 253 109 62 253 253 51 92
+ 54 12 253 7 253 253 253 87 82 89 54 253 36 87 22 253 253 62
+ 94 59 85 34 253 253 253 110 253 97 124 56 253 45 253 8 28
+ 253 12 253 253 253 86 5 253 253 253 75 113 12 108 253 77
+ 253 110 56 253 35 253 13 253 91 253 38 53 253 253 111 253
+ 253 123 253 253 84 91 253 104 17 253 65 24 17 253 15 253
+ 116 66 105 253 113 67 109 70 91 88 253 253 118 0 253 5 72
+ 81 253 253 78 253 253 56 127 27 45 253 253 253 55 253 49
+ 253 253 110 253 253 29 58 101 253 42 5 253 253 66 12 122
+ 123 253 62 253 253 253 253 253 0 253 116 60 92 49 253 253
+ 253 253 253 55 72 253 80 93 253 253 50 8 253 253 253 253
+ 253 110 5 49 253 253 0 253 253 97 24 23 253 28 40 253 253
+ 127 253 107 253 253 73 119 50 253 253 253 253 253 114 121
+ 253 125 93 62 253 113 253 25 253 29 253 253 65 253 253 253
+ 253 12 253 114 253 253 73 69 253 253 95 8 26 253 253 253 54
+ 104 253 253 35 68 72 81 253 21 27 253 77 54 125 23 88 18
+ 253 253 253 253 69 51 253 0 37 253 27 253 253 253 253 74
+ 253 253 66 253 95 114 123 253 253 253 94 253 253 253 253
+ 253 42 36 98 114 19 253 126 253 25 253 40 253 50 46 64 61
+ 45 117 107 253 89 51 69 38 14 57 7 253 109 253 111 253 253
+ 10 13 253 46 60 253 253 25 253 15 76 253 92 88 253 70 5 5
+ 73 60 113 253 82 253 253 51 126 253 112 34 19 99 253 253
+ 119 30 253 253 0 253 104 116 52 253 79 69 253 109 119 253
+ 17 22 66 87 119 13 253 253 35 83 11 253 253 253 253 253 106
+ 45 253 253 120 253 36 253 25 253 253 81 75 253 40 88 253
+ 253 253 74 253 115 53 253 70 253 253 253 253 117 253 64 253
+ 253 53 93 253 253 253 52 253 23 253 62 14 0 95 253 253 90
+ 253 253 56 253 49 253 253 253 75 118 6 253 253 253 48 253
+ 253 253 105 24 253 48 71 253 253 36 55 39 253 253 127 20 33
+ 253 253 253 101 79 6 102 89 24 46 253 62 82 113 253 84 6 88
+ 22 44 52 44 253 253 94 253 253 253 253 58 47 253 104 38 253
+ 101 253 71 253 81 253 6 83 253 253 83 54 30 42 72 253 253
+ 253 3 253 48 253 110 126 253 64 253 104 253 253 253 253 253
+ 253 253 64 57 110 107 102 253 110 253 9 253 65 30 253 253
+ 253 104 253 35 253 253 42 253 253 253 100 253 46 99 63 253
+ 95 39 253 99 253 115 72 34 253 253 253 99 253 253 253 253
+ 67 253 106 87 20 253 253 253 253 253 253 30 253 253 253 253
+ 253 253 253 253 253 125 253 2 84 253 253 253 100 5 253 253
+ 0 53 40 7 253 253 44 80 90 253 253 253 122 114 127 253 61
+ 109 253 253 46 87 253 253 26 253 101 109 34 253 253 253 112
+ 126 253 253 70 253 253 52 253 111 253 91 253 28 253 253 253
+ 118 114 121 253 253 116 253 253 24 71 111 253 253 253 253
+ 253 253 5 98 253 253 89 253 253 115 253 253 66 253 99 5 253
+ 253 63 253 62 106 105 99 25 48 42 253 253 39 253 104 253
+ 253 29 253 253 1 21 83 112 253 253 111 253 253 37 48 14 253
+ 253 253 109 107 253 253 253 50 46 253 253 99 253 13 116 78
+ 253 56 253 253 20 253 81 253 80 13 253 253 253 85 253 253
+ 94 253 59 253 253 99 12 253 253 253 21 108 90 253 253 36 79
+ 10 30 0 253 88 253 253 253 253 23 253 253 253 96 253 253
+ 126 253 253 253 12 253 34 253 253 253 63 253 35 253 253 88
+ 80 35 67 253 79 253 15 253 253 41 253 55 50 71 3 253 253
+ 253 63 59 253 253 253 86 20 253 253 9 49 253 253 75 253 7
+ 14 59 26 253 122 253 101 253 253 253 253 70 253 79 57 253
+ 19 90 253 253 253 253 253 253 253 60 253 85 91 253 91 79
+ 121 123 35 126 42 20 85 57 253 253 253 253 39 253 52 59 21
+ 95 71 52 120 85 253 253 19 24 253 61 253 253 38 253 109 62
+ 56 84 95 120 253 52 253 12 70 23 253 253 253 8 45 33 102 62
+ 35 69 113 253 253 43 28 253 253 253 28 253 53 1 12 253 109
+ 253 56 69 30 253 90 89 71 253 87 58 90 44 253 253 253 108
+ 45 112 24 253 64 59 253 35 39 253 253 63 253 253 253 253
+ 110 35 77 90 16 253 253 71 31 253 253 118 63 253 253 0 95
+ 253 253 59 76 253 101 45 113 253 67 10 253 253 34 253 253
+ 57 253 253 95 116 253 253 253 109 253 19 66 253 32 253 253
+ 14 8 253 253 93 81 253 66 253 253 109 253 253 253 253 38
+ 253 125 253 92 253 253 82 120 115 253 3 253 253 253 253 81
+ 253 253 253 253 114 253 76 253 253 52 253 64 253 253 57 63
+ 83 79 253 108 253 58 51 253 102 253 72 93 32 119 36 100 119
+ 25 253 72 253 109 109 253 43 253 253 253 253 119 83 253 253
+ 81 83 253 116 253 253 43 253 253 253 253 253 53 87 253 109
+ 253 20 253 8 29 253 253 253 0 253 117 88 99 253 18 253 121
+ 75 253 112 15 253 10 115 253 253 104 253 253 109 253 47 253
+ 3 24 253 70 253 34 35 253 50 253 74 253 79 253 253 23 76 95
+ 253 68 253 87 253 37 253 253 26 53 97 28 253 253 253 253 0
+ 102 42 253 253 253 111 253 101 123 253 50 253 19 253 35 253
+ 253 84 253 68 104 4 253 253 98 112 6 125 253 84 82 27 253
+ 253 253 253 97 253 253 56 253 253 77 253 113 118 65 83 78
+ 253 58 253 253 36 253 253 253 253 121 253 253 253 253 253
+ 253 253 253 253 80 253 253 253 253 97 8 253 48 253 253 106
+ 253 253 117 11 77 19 76 125 54 253 30 57 82 9 28 3 79 253 0
+ 253 253 253 253 253 253 51 253 253 70 35 253 27 10 253 14
+ 59 253 253 70 9 253 253 101 20 253 116 253 253 61 10 253 71
+ 253 107 107 59 21 100 11 15 253 61 253 253 253 253 71 12 97
+ 253 253 253 1 253 253 253 83 13 26 253 43 88 253 75 108 35
+ 253 110 253 57 253 253 253 38 253 253 253 253 253 101 253
+ 48 253 253 253 253 253 253 98 56 253 253 253 253 75 3 103
+ 126 253 13 253 69 253 253 73 253 253 253 67 20 99 253 253
+ 253 102 253 13 27 253 253 28 253 18 77 53 253 93 253 253 79
+ 106 16 88 52 253 253 111 32 12 253 253 253 253 0 106 253
+ 253 59 253 253 97 116 84 108 85 3 72 36 56 253 34 253 80 70
+ 253 253 253 81 253 253 24 61 253 253 253 253 253 253 253
+ 253 101 45 253 253 253 253 88 253 95 93 44 106 253 81 253
+ 31 50 253 253 253 253 253 105 253 108 253 253 31 16 253 253
+ 51 27 253 253 253 74 253 94 253 25 253 253 253 22 94 114 87
+ 52 253 253 105 35 117 104 83 45 253 27 253 253 119 253 253
+ 19 253 62 25 85 110 253 253 52 76 85 253 0 17 253 253 253
+ 253 37 253 253 46 20 21 7 110 253 125 253 253 253 79 253 60
+ 253 39 32 253 79 253 107 253 122 253 68 253 75 86 253 25 92
+ 100 253 59 26 253 253 253 253 38 253 88 253 253 253 119 28
+ 30 107 24 253 253 14 253 44 253 253 79 253 253 99 75 110 45
+ 85 253 253 83 62 253 253 253 253 108 253 18 253 125 253 34
+ 253 110 253 92 253 86 17 253 71 37 253 0 253 253 253 253
+ 253 82 48 253 253 124 253 253 37 253 253 92 253 253 253 105
+ 253 253 253 19 33 253 127 109 63 253 253 253 253 253 253
+ 253 253 253 253 253 85 10 78 40 253 15 8 59 113 253 120 253
+ 96 253 253 50 29 253 26 253 253 68 19 72 253 62 253 11 253
+ 253 253 253 15 253 253 253 21 253 84 253 0 50 253 55 24 107
+ 119 24 253 97 14 253 36 102 253 32 253 253 253 116 253 253
+ 253 87 83 253 253 253 81 107 253 253 53 253 18 7 35 253 253
+ 253 44 253 37 105 17 119 28 253 253 82 28 253 253 82 253 18
+ 49 253 69 79 253 253 75 121 32 92 253 73 28 253 253 68 69
+ 253 65 253 106 253 253 253 36 49 253 38 61 87 253 253 253
+ 253 253 94 68 253 95 253 66 253 253 253 253 253 253 97 253
+ 72 253 106 109 6 103 93 253 253 253 253 253 58 110 253 253
+ 2 36 4 1 253 253 253 253 15 253 44 108 253 253 124 25 253
+ 127 253 253 71 253 82 107 123 49 34 253 113 253 253 71 253
+ 253 65 253 88 87 42 6 22 110 1 253 253 253 92 121 84 253
+ 253 253 5 253 253 253 88 253 84 19 253 93 253 65 111 103
+ 253 84 253 104 253 253 65 253 253 82 253 42 66 253 41 31
+ 253 253 17 253 253 44 28 253 92 253 109 253 253 113 110 253
+ 74 253 253 30 253 84 253 253 127 253 253 253 253 3 253 4
+ 253 253 253 253 108 253 253 14 114 49 253 95 253 253 127
+ 253 72 253 253 53 41 87 12 253 253 253 39 253 83 253 253
+ 253 253 253 253 26 253 253 253 11 253 253 16 82 114 78 78
+ 106 95 253 253 17 253 253 69 253 253 253 31 253 84 253 106
+ 253 253 253 27 98 253 253 102 10 87 29 253 106 99 253 253
+ 50 71 253 253 253 253 253 73 253 253 31 90 253 253 100 73
+ 45 23 31 79 253 253 253 104 84 253 253 253 120 253 253 71
+ 253 83 253 66 55 75 114 253 253 253 43 253 0 25 253 21 16
+ 253 253 18 107 104 253 110 11 55 0 15 253 123 84 253 253
+ 120 253 253 253 253 253 253 253 8 25 253 118 65 253 60 253
+ 253 119 253 253 253 49 253 36 253 253 253 92 253 253 253
+ 253 44 85 253 253 253 94 42 253 253 253 90 253 105 253 56
+ 253 253 253 253 253 253 253 117 253 253 9 253 123 253 253
+ 105 34 104 253 253 253 253 253 127 253 84 31 89 91 253 253
+ 253 99 253 30 82 55 40 29 253 253 253 253 23 253 41 112 253
+ 253 253 253 103 253 102 123 253 95 57 253 33 24 3 253 42 61
+ 253 120 51 36 69 109 119 3 47 253 61 78 15 21 33 253 253
+ 253 253 253 9 70 84 15 54 125 253 116 253 253 24 93 253 253
+ 253 6 6 59 26 253 17 253 72 253 253 253 98 108 27 117 4 253
+ 253 92 253 111 253 65 253 64 98 75 43 87 17 253 253 44 56
+ 253 253 253 3 107 110 99 99 52 253 50 253 56 99 253 253 123
+ 253 253 77 38 253 37 101 253 31 253 253 70 43 253 110 82 10
+ 253 253 253 253 53 253 71 253 87 253 28 253 88 121 125 43
+ 253 253 26 253 50 253 22 253 111 253 16 253 42 253 253 253
+ 9 253 253 253 253 126 10 253 13 109 253 115 253 31 253 253
+ 42 253 253 253 253 11 77 253 25 36 73 90 110 253 15 57 253
+ 253 253 25 253 84 55 253 253 97 21 253 74 253 253 15 54 253
+ 121 53 5 253 9 86 253 105 118 253 253 119 253 33 253 84 253
+ 253 21 253 253 253 253 35 253 253 0 49 253 56 253 253 253
+ 110 253 253 253 253 253 253 253 253 90 253 99 253 9 14 253
+ 90 57 49 253 253 111 253 87 253 253 79 4 253 52 253 43 253
+ 253 253 253 124 12 253 122 253 253 6 253 253 110 1 253 103
+ 63 253 253 81 253 94 253 253 25 253 40 87 70 253 127 81 253
+ 253 103 45 29 253 28 253 48 253 15 253 27 253 253 18 27 119
+ 253 2 63 76 85 253 253 89 253 73 26 42 253 253 28 253 85
+ 253 253 29 42 75 253 253 253 253 24 253 253 253 0 15 30 253
+ 113 253 253 55 16 253 253 253 253 60 253 123 85 99 253 114
+ 253 253 253 1 29 253 9 253 253 87 9 253 253 253 253 253 54
+ 73 253 76 253 253 253 121 119 112 64 253 42 68 34 23 10 4
+ 109 253 253 76 253 253 54 110 253 87 253 43 32 253 253 7
+ 253 253 62 104 253 107 26 118 99 253 253 253 253 14 121 253
+ 86 125 99 253 253 253 5 105 110 23 96 62 102 65 87 101 253
+ 253 101 30 59 253 121 253 253 51 70 50 13 67 253 253 46 253
+ 253 253 253 253 53 253 253 74 7 6 253 253 253 68 117 253 48
+ 8 253 72 253 50 38 253 33 116 108 253 253 19 253 253 62 59
+ 253 113 87 71 94 253 47 38 253 253 253 253 43 97 86 253 253
+ 253 253 34 253 253 48 85 253 253 253 43 2 74 253 253 253
+ 103 253 253 101 39 253 25 53 253 253 253 253 253 253 115 85
+ 64 52 253 22 80 253 24 56 253 253 78 253 8 0 119 253 23 253
+ 253 27 113 253 75 253 10 253 253 2 253 105 253 253 24 105
+ 58 110 10 253 74 18 253 0 63 253 110 253 253 253 253 253
+ 253 253 99 11 253 72 253 117 31 253 85 253 61 253 78 15 253
+ 253 253 253 253 90 253 116 253 76 50 253 253 253 253 21 253
+ 8 253 109 253 18 57 24 253 253 124 253 253 109 253 253 253
+ 22 253 20 253 253 253 118 253 253 29 253 253 35 253 62 253
+ 253 63 253 253 85 109 253 253 253 253 125 253 253 253 87
+ 253 98 253 117 42 253 113 253 90 253 253 253 253 77 253 110
+ 253 109 253 14 253 253 95 13 253 45 253 81 90 100 44 23 253
+ 253 253 127 253 253 253 91 253 68 45 106 253 253 253 24 253
+ 253 253 253 253 253 253 93 253 253 253 253 253 253 122 65
+ 253 25 253 95 253 253 16 51 253 79 27 105 253 253 253 253
+ 121 253 39 60 39 253 105 253 253 13 253 8 84 102 112 4 112
+ 253 253 253 52 108 80 71 23 253 253 253 253 253 253 253 32
+ 81 253 82 62 253 253 253 80 253 114 126 253 253 253 38 253
+ 59 17 121 1 113 253 118 253 253 253 253 107 253 253 36 105
+ 253 253 253 253 94 57 82 119 47 253 253 253 253 253 253 6
+ 72 31 253 35 253 253 106 253 253 253 5 253 124 86 101 12
+ 253 253 253 24 57 253 253 20 253 96 253 62 69 19 13 253 253
+ 253 71 253 120 253 102 52 253 253 105 253 253 61 253 253
+ 253 253 18 253 50 12 125 90 253 253 19 103 253 120 18 253
+ 96 253 0 125 104 103 253 253 101 253 106 253 27 79 111 74
+ 253 105 253 119 57 114 90 45 126 253 253 86 253 102 55 40 8
+ 253 253 78 253 31 60 86 95 253 107 253 253 253 111 47 36
+ 253 253 253 27 253 253 253 253 41 253 253 81 253 112 123
+ 253 253 253 253 253 253 253 253 253 253 253 253 56 99 253
+ 43 253 30 95 253 253 253 253 253 67 62 253 253 0 22 88 89
+ 78 253 89 253 24 85 62 253 68 253 253 20 253 253 120 253 15
+ 39 253 253 253 253 253 253 21 100 253 93 81 253 253 253 253
+ 121 253 253 27 253 9 24 97 75 253 109 253 123 253 253 118
+ 253 72 253 21 59 6 6 11 55 106 253 82 253 57 41 69 21 69
+ 253 107 60 253 93 253 253 253 253 75 55 4 26 2 253 55 93
+ 253 253 253 91 253 253 253 120 75 253 253 29 253 253 75 118
+ 30 253 100 81 28 253 253 253 70 72 253 253 253 0 76 253 124
+ 23 81 107 2 253 70 253 7 253 253 253 253 253 253 253 73 100
+ 253 253 253 253 35 12 21 253 253 9 253 51 253 105 253 253
+ 53 253 47 106 253 55 253 81 38 253 29 253 253 92 253 253
+ 253 253 93 2 253 253 253 55 27 253 253 97 253 253 15 253 0
+ 253 15 107 253 253 127 107 93 71 0 253 253 253 97 253 253
+ 253 113 30 18 114 86 36 253 253 253 253 253 253 253 20 15
+ 253 253 27 253 253 253 95 61 33 125 253 253 99 253 94 2 253
+ 115 73 32 253 253 253 84 253 253 253 253 253 253 253 253
+ 253 253 253 4 253 0 253 253 82 24 253 253 56 253 36 253 253
+ 113 253 253 37 253 31 253 36 253 253 26 253 253 53 253 253
+ 37 253 47 13 253 65 72 33 253 61 253 253 253 89 253 253 76
+ 97 253 43 49 253 10 253 127 253 253 61 253 48 253 93 253
+ 124 253 17 253 253 253 253 253 253 253 4 253 253 41 253 39
+ 253 253 87 62 73 253 253 98 253 253 77 70 253 105 110 253
+ 253 253 50 89 41 253 0 253 31 106 9 108 115 118 253 36 98
+ 88 253 253 95 253 13 31 102 253 253 253 253 35 60 253 253
+ 253 83 253 253 253 253 253 253 253 253 108 253 253 0 253
+ 253 53 72 253 121 20 116 253 19 253 253 253 253 12 107 17
+ 119 253 253 253 253 253 0 10 253 253 253 253 253 40 253 253
+ 253 81 253 253 253 253 253 253 253 18 40 253 82 0 5 253 253
+ 253 22 253 118 253 113 253 59 26 253 253 93 108 253 253 92
+ 253 253 53 253 127 253 253 78 87 253 30 253 253 253 253 25
+ 253 48 24 118 49 253 113 76 253 89 99 56 253 67 253 20 120
+ 253 253 125 13 55 16 8 111 253 76 253 253 37 39 25 253 14
+ 253 1 253 117 1 253 101 253 74 96 55 253 88 23 253 19 70
+ 253 253 253 253 253 62 253 21 253 72 253 54 253 70 253 84
+ 253 253 253 63 253 253 18 253 119 253 253 253 107 253 253
+ 101 112 48 74 253 253 253 253 55 253 21 253 101 109 253 118
+ 253 49 87 253 253 11 59 89 253 253 253 253 253 86 11 253 86
+ 253 253 7 253 41 253 253 253 13 253 119 119 20 253 31 26 4
+ 253 53 253 253 114 56 253 35 253 253 99 16 93 253 253 253
+ 10 253 253 253 51 11 253 253 253 253 253 253 253 253 253
+ 253 97 117 253 31 253 45 253 253 253 87 253 253 82 14 253
+ 253 253 65 253 103 253 40 13 74 48 116 253 253 28 253 0 70
+ 122 48 73 253 67 52 22 253 253 88 93 253 60 253 56 20 89
+ 253 253 253 33 253 253 253 253 253 253 25 98 253 253 55 122
+ 253 90 253 99 38 253 253 63 253 253 253 253 10 48 53 33 253
+ 253 36 17 76 55 59 253 28 253 86 253 253 253 82 71 253 85
+ 253 86 253 253 253 253 253 253 253 73 66 253 253 28 253 253
+ 253 57 253 253 253 83 71 253 72 253 97 253 39 106 253 58
+ 253 67 121 30 253 68 253 253 34 103 253 57 60 49 253 84 253
+ 253 253 59 114 253 42 253 28 253 2 7 97 80 110 253 253 5
+ 253 253 18 27 253 57 60 113 253 126 253 55 253 253 253 66
+ 38 253 253 253 253 120 57 63 253 89 253 253 57 253 253 35
+ 72 23 119 0 253 253 253 35 81 253 253 253 13 8 118 33 253
+ 253 253 253 101 253 32 253 253 6 62 50 253 119 99 253 253
+ 74 122 253 253 110 253 253 253 11 253 29 253 253 72 253 114
+ 71 21 253 48 253 10 253 253 83 253 253 65 253 45 20 253 88
+ 253 52 253 91 27 253 104 80 253 18 119 122 253 253 253 11
+ 253 123 253 110 31 78 253 93 253 67 253 123 87 79 107 253
+ 53 253 253 253 43 75 17 253 253 253 125 253 253 253 253 253
+ 73 114 100 84 96 253 253 13 253 126 253 25 70 253 253 253
+ 253 253 35 253 116 253 253 253 16 52 253 42 253 253 253 253
+ 253 253 253 54 253 253 105 90 253 253 61 253 253 11 28 253
+ 83 253 253 253 83 253 253 253 253 253 253 253 100 253 253
+ 253 67 96 114 61 253 253 253 52 253 117 253 17 90 56 253
+ 253 12 253 35 56 21 60 77 73 253 83 253 253 253 72 253 253
+ 45 112 253 253 26 86 59 20 253 4 253 22 253 52 253 98 253
+ 253 253 253 253 62 57 253 18 54 253 253 3 253 253 83 78 253
+ 253 112 99 253 253 253 45 13 253 32 253 116 125 253 253 121
+ 253 104 253 253 101 253 253 0 253 253 253 5 116 62 253 120
+ 253 82 123 39 58 253 88 253 117 253 253 253 253 75 124 86
+ 253 24 253 253 70 253 253 7 253 53 60 253 253 43 117 253
+ 253 75 253 253 253 253 18 89 253 253 44 253 253 253 253 21
+ 253 10 123 253 51 253 253 115 253 107 253 36 253 253 253
+ 253 253 253 253 253 82 109 7 253 31 89 104 253 71 109 109
+ 253 94 4 253 253 253 253 50 8 253 54 253 253 17 253 253 253
+ 88 87 253 253 31 253 253 253 126 253 253 43 13 48 94 88 61
+ 253 70 63 26 253 88 253 33 125 253 253 51 253 253 106 29
+ 253 253 103 253 58 253 253 253 253 253 253 83 35 32 88 253
+ 253 32 47 114 126 253 19 253 253 253 253 117 253 33 253 81
+ 253 253 253 253 253 12 80 120 253 110 253 253 253 71 253
+ 253 66 44 55 19 90 71 253 75 253 253 25 253 115 90 253 73
+ 46 253 253 253 53 67 253 78 253 95 20 253 77 253 50 121 253
+ 104 253 253 75 253 253 34 253 253 253 253 3 16 253 3 253 47
+ 67 253 253 253 64 253 253 253 71 35 253 253 14 253 253 106
+ 253 62 27 253 16 253 253 61 253 105 48 253 18 253 96 22 95
+ 253 253 253 253 4 253 253 253 7 253 29 47 125 30 253 53 253
+ 253 253 253 253 253 253 30 64 253 253 253 253 103 28 123
+ 100 253 253 253 120 84 110 253 253 83 126 253 253 253 253
+ 253 37 253 253 116 44 56 85 36 55 24 253 253 253 253 83 123
+ 118 94 66 67 19 253 106 253 116 253 253 73 18 94 253 253
+ 253 83 95 253 76 253 76 46 112 253 31 253 87 31 73 116 253
+ 253 253 49 253 253 14 1 253 253 111 253 23 11 20 34 8 35
+ 253 253 56 253 3 21 104 90 90 27 93 253 36 126 35 253 253
+ 253 79 31 74 253 253 7 86 253 60 253 97 118 253 253 77 253
+ 118 253 253 253 91 90 53 253 28 125 253 21 253 60 50 253
+ 253 253 253 119 253 253 42 53 58 253 253 51 42 253 253 65
+ 253 23 94 12 69 100 253 35 253 123 253 60 253 253 253 20 27
+ 253 71 253 253 62 253 90 1 35 253 115 43 40 113 32 253 55
+ 124 84 47 253 100 253 49 253 253 253 253 65 253 124 91 253
+ 253 85 253 98 253 253 253 103 42 253 121 253 253 253 253
+ 253 253 253 253 253 253 253 90 125 253 91 107 253 105 7 253
+ 253 253 53 253 68 253 253 47 107 253 95 253 253 49 253 253
+ 48 28 73 25 253 253 253 253 87 253 0 253 253 253 51 100 253
+ 110 253 87 94 106 67 88 253 55 253 253 253 31 92 113 253 14
+ 73 253 85 87 253 82 4 253 253 124 253 253 253 253 253 68 52
+ 89 253 73 52 2 253 253 121 253 109 253 50 253 253 253 88 17
+ 102 253 253 253 35 253 75 253 27 110 253 76 253 20 96 253
+ 253 253 253 85 253 253 14 54 253 253 26 253 253 61 41 102
+ 253 41 253 21 253 253 253 39 253 50 253 48 253 253 253 253
+ 253 63 5 63 253 253 253 253 17 253 102 122 48 63 253 253
+ 253 253 253 43 126 71 253 253 90 253 72 79 253 253 253 253
+ 253 36 253 18 45 253 75 17 81 101 253 253 253 253 253 61 77
+ 15 111 122 253 87 65 253 118 253 253 30 253 253 253 253 253
+ 253 57 253 90 253 253 121 34 110 71 40 7 56 28 253 253 253
+ 40 253 47 99 253 126 4 117 253 253 253 253 253 63 253 44
+ 253 120 24 253 253 78 253 65 81 253 253 253 118 253 115 28
+ 0 107 253 253 28 89 253 253 253 77 54 89 34 32 253 105 56
+ 39 253 253 253 253 253 253 253 84 87 102 17 76 253 48 6 9
+ 253 253 253 14 60 65 253 51 253 45 102 103 1 100 253 253
+ 121 5 78 69 99 253 253 54 253 253 253 253 253 253 253 77 11
+ 253 253 39 17 71 112 253 23 28 253 35 253 253 62 253 53 253
+ 253 253 253 45 33 253 253 253 0 44 253 98 253 253 19 36 117
+ 72 253 253 253 42 72 253 38 120 62 253 112 27 80 5 35 111
+ 253 253 118 19 120 253 1 96 253 253 1 253 253 44 253 80 110
+ 253 253 253 105 253 64 253 30 253 21 253 25 100 25 82 48 69
+ 84 253 0 18 122 82 19 35 253 101 32 253 100 10 253 3 46 56
+ 96 104 109 66 253 27 253 253 253 253 253 253 253 40 253 27
+ 28 253 253 253 91 253 253 253 91 253 43 63 253 20 71 60 253
+ 253 0 74 125 253 93 69 117 98 88 93 253 22 253 92 4 253 253
+ 253 91 253 253 76 108 253 72 253 80 51 253 253 106 253 253
+ 253 41 68 253 111 29 253 8 253 253 253 253 113 253 124 37
+ 103 124 36 253 42 253 44 121 46 108 53 253 253 253 69 253
+ 108 253 65 253 253 253 119 253 253 23 253 253 104 37 253
+ 253 10 63 253 253 253 253 253 37 253 253 58 253 112 253 253
+ 64 253 48 79 253 89 90 93 253 253 253 253 89 253 103 253
+ 253 253 123 15 113 253 253 71 43 253 103 52 253 46 52 253
+ 27 93 253 99 116 253 253 44 86 253 253 69 253 44 253 253
+ 253 84 30 253 64 107 107 253 253 253 56 31 46 7 253 118 253
+ 253 253 90 253 253 93 253 54 253 118 57 42 57 253 253 253
+ 106 125 33 253 253 120 100 88 86 104 253 96 101 107 253 50
+ 253 37 105 28 253 253 253 116 14 253 253 253 253 253 55 51
+ 49 253 253 253 253 253 125 55 253 253 54 253 45 253 253 72
+ 253 253 70 55 15 122 253 52 46 253 253 253 253 55 253 253
+ 20 253 253 99 253 83 253 90 104 253 84 253 97 253 86 49 253
+ 36 96 253 53 253 253 253 37 253 253 253 110 253 253 116 79
+ 10 253 121 20 253 253 253 4 124 253 107 253 253 253 253 253
+ 54 253 105 24 72 253 55 253 253 253 253 53 253 253 253 253
+ 109 253 36 253 112 30 68 114 253 253 114 77 87 253 73 121
+ 253 91 253 253 87 46 253 121 71 253 253 73 101 116 253 253
+ 253 253 51 45 96 106 26 253 253 253 122 253 99 253 45 253 5
+ 54 253 30 253 253 253 253 253 253 253 3 20 253 253 253 253
+ 253 30 40 253 253 253 253 70 25 253 26 253 253 111 253 99
+ 253 253 60 253 70 37 3 253 92 80 79 108 76 253 56 253 25
+ 116 63 79 253 253 253 253 253 79 253 125 79 253 74 23 253
+ 25 253 28 115 88 253 253 12 33 19 253 119 253 253 58 38 55
+ 56 31 90 253 253 253 105 253 99 58 253 46 253 96 253 118
+ 253 253 253 52 67 253 102 253 48 253 253 51 69 253 44 126
+ 25 60 253 253 14 253 253 253 96 84 253 253 253 5 253 32 253
+ 69 103 253 40 114 26 253 15 253 253 81 253 253 253 253 80
+ 83 95 73 253 253 33 56 253 0 91 253 253 253 29 68 108 99 48
+ 253 9 253 0 124 253 24 63 110 106 11 253 117 110 253 53 253
+ 253 253 253 253 253 253 112 114 253 253 88 253 44 46 253
+ 253 33 253 79 253 253 73 85 84 16 253 253 253 87 37 124 96
+ 253 11 91 253 78 75 11 75 253 21 253 19 253 70 56 253 39 86
+ 253 53 253 70 57 32 253 253 82 253 14 28 13 253 87 253 253
+ 253 69 253 58 29 253 253 253 42 67 113 123 118 92 253 253 0
+ 99 253 107 112 79 253 106 253 45 253 37 253 105 14 112 123
+ 31 122 33 253 253 253 60 55 108 125 40 253 99 104 81 97 112
+ 253 253 253 253 65 22 96 73 253 253 74 253 253 27 60 53 9
+ 253 43 43 104 253 112 57 253 21 253 33 253 253 253 98 253
+ 253 13 32 12 253 65 7 253 74 253 253 253 57 253 111 83 253
+ 253 73 38 127 24 71 253 60 69 253 25 253 253 49 253 120 253
+ 253 103 117 253 253 253 253 113 253 253 253 253 253 31 106
+ 22 253 40 253 253 253 253 253 62 105 253 25 253 30 109 42
+ 253 113 253 253 253 253 253 57 253 44 44 48 59 119 253 52
+ 103 85 253 44 253 253 76 8 127 93 253 85 253 253 253 253 42
+ 71 74 116 70 253 2 253 94 14 113 253 97 253 253 87 65 253
+ 36 253 253 253 40 253 8 253 47 113 253 253 253 109 253 107
+ 253 37 60 253 253 253 83 253 253 253 253 39 87 0 110 35 253
+ 253 253 253 253 102 253 253 253 253 253 58 103 253 253 35
+ 48 52 114 32 24 253 253 253 253 91 107 253 253 253 5 253 4
+ 24 253 56 253 253 77 253 253 89 68 253 55 253 83 253 76 14
+ 126 253 52 253 253 55 253 253 76 253 253 126 87 3 253 90 82
+ 85 70 74 253 44 116 24 253 253 78 119 103 253 253 48 71 253
+ 253 92 104 253 253 253 17 76 111 253 253 253 253 109 38 72
+ 100 253 6 253 253 253 118 253 123 253 253 253 11 109 9 28
+ 253 253 253 32 100 84 69 110 253 253 253 253 66 253 111 253
+ 253 253 47 253 78 114 5 72 45 253 86 253 253 253 114 40 93
+ 253 253 57 253 41 93 253 81 253 127 253 15 253 38 120 34
+ 253 253 106 64 58 253 28 121 80 57 111 115 72 60 23 253 253
+ 29 74 89 38 86 253 45 253 253 253 253 253 253 253 121 8 5
+ 253 64 9 253 72 253 253 55 48 253 4 253 253 253 49 30 104
+ 253 111 253 253 253 253 253 19 253 253 253 124 39 95 253
+ 253 78 76 87 75 253 253 253 113 121 98 20 253 253 57 35 253
+ 253 253 93 11 13 253 253 253 54 84 253 253 80 7 38 253 58
+ 35 53 253 253 93 253 104 253 253 73 253 1 253 108 253 253
+ 253 253 253 253 69 41 253 253 5 253 253 37 253 253 253 253
+ 17 59 84 14 253 253 81 253 253 109 67 78 253 253 11 34 253
+ 253 253 253 253 253 101 253 253 49 253 253 253 73 253 104
+ 253 253 105 253 253 253 253 113 72 253 253 253 253 103 253
+ 253 253 253 46 253 253 56 253 78 253 253 253 253 253 101
+ 107 253 23 37 89 253 253 70 77 253 78 15 53 53 253 253 108
+ 253 253 253 107 120 253 42 253 253 65 65 253 253 104 253 54
+ 107 253 253 88 253 36 82 253 253 125 253 111 253 53 101 253
+ 127 253 40 122 253 253 253 86 41 3 253 253 15 106 253 125
+ 123 253 253 253 253 109 253 54 3 253 253 253 74 253 253 253
+ 53 75 253 109 97 70 253 253 253 253 253 105 90 109 253 111
+ 253 253 9 253 253 253 41 253 253 105 253 78 253 21 78 253
+ 253 55 253 72 253 33 98 31 253 253 253 15 253 75 116 79 253
+ 114 8 253 111 35 253 123 118 253 119 31 90 253 52 253 54 27
+ 24 253 253 125 253 253 253 113 84 73 62 253 253 253 18 122
+ 100 95 253 253 102 29 46 97 253 64 253 23 253 253 253 253
+ 253 83 253 28 108 25 253 31 111 122 253 43 108 253 71 253
+ 253 253 80 109 253 109 77 253 253 17 30 121 25 253 77 72
+ 253 83 126 253 253 23 107 26 253 60 253 253 40 24 111 253
+ 253 111 14 8 253 253 78 75 103 253 253 87 50 5 253 253 2 59
+ 253 79 21 253 11 103 110 253 18 6 62 253 253 105 28 253 10
+ 253 85 123 38 253 45 253 88 253 81 253 67 32 30 253 253 253
+ 253 253 80 253 114 253 22 10 253 108 30 62 253 253 79 46 46
+ 86 123 98 100 102 253 7 30 94 253 253 26 28 69 253 52 56 95
+ 109 253 109 253 108 51 253 253 23 253 104 253 253 25 13 31
+ 253 253 253 253 253 27 253 6 56 84 253 253 46 120 12 253 2
+ 253 115 20 110 253 110 19 253 253 110 21 62 253 253 253 253
+ 52 101 253 43 64 253 253 253 253 104 69 127 74 253 80 253
+ 253 253 253 253 51 253 253 14 15 253 106 253 253 253 39 75
+ 253 253 253 253 253 21 253 112 126 84 98 23 253 253 39 87
+ 253 253 253 49 71 82 114 25 71 106 253 122 253 37 253 40 50
+ 77 55 253 64 0 15 253 86 253 53 20 87 81 74 253 253 253 35
+ 67 39 101 253 36 99 253 104 9 50 253 54 253 253 35 253 13
+ 19 253 45 36 96 65 27 253 253 57 253 253 253 253 253 253 20
+ 4 73 253 103 24 253 20 253 122 116 122 47 253 253 253 9 253
+ 253 72 253 253 253 32 3 253 122 253 63 53 253 253 253 253
+ 34 253 253 60 253 253 61 253 253 253 253 12 102 253 69 26
+ 253 253 253 253 253 253 253 92 5 253 253 253 70 253 105 11
+ 47 253 253 253 80 87 253 0 253 253 63 253 253 253 86 253
+ 253 253 3 253 253 253 99 253 41 253 253 0 253 122 253 17 92
+ 253 118 127 253 253 253 1 253 30 18 86 253 51 253 253 253
+ 87 253 253 13 50 12 253 64 27 31 253 76 253 253 253 253 253
+ 253 120 123 80 41 253 115 253 106 40 253 98 43 123 253 111
+ 55 253 253 113 253 253 86 7 70 253 76 253 253 31 253 68 253
+ 253 253 253 253 96 62 253 253 253 253 90 28 253 253 99 253
+ 253 253 59 253 0 253 15 253 253 83 110 253 253 9 102 253 45
+ 253 253 102 253 39 28 253 253 253 98 41 253 253 39 68 253 0
+ 253 253 253 253 58 253 253 73 253 253 253 253 73 253 1 30
+ 253 97 104 253 253 253 253 253 103 118 253 253 71 253 25
+ 253 253 253 63 70 253 253 62 253 253 253 21 253 118 253 70
+ 253 253 27 99 71 253 253 253 65 53 34 253 253 77 74 253 47
+ 253 114 58 253 68 253 253 31 99 89 253 11 253 253 253 253
+ 99 253 30 56 253 54 253 74 253 102 50 61 253 253 253 253
+ 120 56 63 32 61 253 78 23 253 53 94 105 26 253 253 253 34
+ 65 253 88 253 66 253 253 253 253 253 63 92 122 84 253 253
+ 253 75 253 253 68 253 34 253 79 253 1 253 253 74 70 19 118
+ 253 11 253 67 44 253 253 18 6 253 253 253 75 253 90 253 71
+ 102 253 253 124 253 253 64 253 253 253 253 97 253 253 50
+ 253 253 82 7 96 253 253 91 106 39 253 253 253 253 253 253
+ 253 253 253 71 253 35 84 253 21 253 253 253 49 34 253 13
+ 253 24 253 103 45 29 253 253 82 84 253 253 56 81 69 253 110
+ 49 40 48 52 89 28 253 19 253 21 253 253 253 73 253 104 253
+ 253 125 8 28 253 253 108 77 38 107 71 120 253 109 66 69 16
+ 38 82 253 253 28 253 80 86 73 58 66 99 117 124 253 57 70
+ 253 0 253 100 253 60 78 89 81 253 49 253 8 114 63 253 253
+ 116 48 99 44 253 63 45 253 123 253 253 253 253 120 253 253
+ 97 102 63 253 69 97 52 253 253 253 68 253 253 57 253 109
+ 253 0 106 85 253 92 92 253 21 69 112 253 253 32 253 22 253
+ 24 41 50 63 253 253 253 253 253 87 118 253 253 73 27 253
+ 253 101 126 253 253 122 253 93 117 30 253 38 253 253 94 253
+ 253 253 19 253 109 30 48 78 61 8 253 253 253 253 253 92 25
+ 97 105 87 253 253 253 253 85 253 17 253 3 72 253 125 66 13
+ 98 253 253 253 253 71 112 23 37 99 32 78 61 73 24 253 79 39
+ 25 253 120 253 253 253 253 1 253 55 105 253 17 253 253 253
+ 253 253 50 253 52 253 253 7 253 23 253 0 253 253 253 253 66
+ 253 253 52 253 253 253 253 253 28 253 253 104 115 253 97
+ 103 13 253 253 96 253 28 40 253 253 253 253 253 63 253 52
+ 253 46 47 253 253 48 50 253 253 253 253 253 71 81 68 114 91
+ 118 253 97 253 253 253 85 49 253 102 253 253 67 253 110 96
+ 88 253 77 109 119 50 253 253 24 253 45 253 71 109 24 101
+ 102 64 253 57 11 253 253 73 253 73 79 253 253 37 253 253
+ 253 253 40 14 253 253 115 253 7 253 7 113 54 253 48 253 253
+ 85 126 253 253 71 11 42 110 109 253 253 0 253 108 127 253
+ 105 72 101 253 253 253 253 88 253 253 2 54 15 253 83 59 253
+ 85 5 105 253 55 253 93 253 253 118 52 46 253 34 67 3 253
+ 253 93 253 101 3 36 83 68 253 84 92 253 100 125 253 38 253
+ 36 253 4 253 253 108 253 30 253 253 253 94 253 253 12 253
+ 253 90 253 253 99 86 111 12 54 91 105 253 21 39 253 85 253
+ 253 98 82 253 253 6 60 79 253 82 253 46 253 253 253 104 12
+ 1 253 78 253 114 104 253 253 253 253 253 57 60 253 6 101
+ 253 253 253 253 81 253 62 94 77 44 253 253 83 42 23 253 253
+ 253 253 21 29 253 253 34 253 253 253 253 69 1 3 45 52 253
+ 103 31 65 253 0 106 47 91 253 45 44 81 253 95 21 253 29 253
+ 26 33 44 253 253 21 16 253 126 253 253 8 253 109 13 253 253
+ 253 253 253 99 113 253 253 253 41 1 253 62 253 253 104 253
+ 69 36 253 49 42 23 253 52 253 253 99 253 61 253 253 253 53
+ 253 37 34 253 253 253 253 253 253 60 253 253 76 125 9 253
+ 86 14 253 253 114 73 40 253 253 54 109 253 45 253 72 253
+ 253 253 253 117 47 253 253 253 253 93 78 253 76 35 253 253
+ 253 253 253 253 79 21 253 253 253 253 58 253 253 253 39 253
+ 64 253 43 3 253 34 253 253 253 16 253 70 253 253 253 253 69
+ 75 117 253 253 253 253 253 253 37 253 253 15 253 253 112
+ 253 61 253 71 36 253 44 93 253 85 69 253 253 85 253 3 253
+ 253 253 253 96 253 253 253 253 253 63 74 253 29 253 53 253
+ 102 73 6 253 253 253 253 253 0 253 106 85 253 253 99 253 79
+ 45 253 38 30 253 253 253 253 253 120 253 253 64 8 253 15
+ 253 1 253 70 11 124 253 253 253 35 20 253 9 35 116 37 90
+ 253 5 253 29 253 65 253 18 253 0 67 253 253 0 116 253 90 41
+ 16 1 253 253 253 253 106 24 253 61 253 110 27 253 54 253 61
+ 253 78 253 253 110 34 253 47 253 55 253 253 253 253 253 253
+ 253 85 253 253 73 118 116 253 253 109 63 253 253 83 53 253
+ 253 126 253 253 253 80 80 253 253 253 15 253 122 95 253 253
+ 253 122 253 88 253 253 253 253 95 253 253 253 107 86 253
+ 253 253 253 253 87 253 31 253 253 77 253 121 253 0 253 253
+ 49 127 90 95 253 253 122 253 74 253 253 99 253 253 104 22
+ 253 253 125 253 253 253 253 69 126 253 253 253 253 253 79
+ 253 253 94 253 80 8 60 253 253 95 253 100 253 253 74 253
+ 122 253 253 62 46 253 26 253 253 253 79 253 253 94 253 47
+ 30 253 253 126 253 81 253 253 253 253 253 253 100 253 253
+ 63 45 125 253 253 253 253 0 109 122 253 80 253 253 51 91
+ 253 253 253 253 253 94 253 85 95 253 253 253 253 253 126
+ 253 111 253 63 253 94 253 83 46 253 253 253 253 253 253 91
+ 117 15 253 253 253 122 253 253 58 253 253 253 111 253 253
+ 253 127 253 39 253 85 253 253 17 88 116 253 253 253 253 253
+ 253 253 253 87 253 253 16 77 109 253 105 105 76 253 253 253
+ 253 94 253 253 253 87 253 0 50 253 0 253 88 71 253 10 253
+ 122 253 64 253 253 253 253 253 253 85 253 0 106 253 94 253
+ 125 253 35 47 253 58 105 99 253 68 253 0 253 253 87 253 253
+ 253 63 253 253 13 10 45 45 45 45 45 45 87 101 98 75 105 116
+ 70 111 114 109 66 111 117 110 100 97 114 121 115 105 103
+ 113 43 53 113 87 116 54 79 114 122 56 76 79 45 45 13 10
+ } >string ;
+
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io kernel locals math multiline
+sequences splitting prettyprint ;
+IN: mime.multipart
+
+TUPLE: multipart-stream stream n leftover separator ;
+
+: <multipart-stream> ( stream separator -- multipart-stream )
+ multipart-stream new
+ swap >>separator
+ swap >>stream
+ 16 2^ >>n ;
+
+<PRIVATE
+
+: ?append ( seq1 seq2 -- newseq/seq2 )
+ over [ append ] [ nip ] if ;
+
+: ?cut* ( seq n -- before after )
+ over length over <= [ drop f swap ] [ cut* ] if ;
+
+: read-n ( stream -- bytes end-stream? )
+ [ f ] change-leftover
+ [ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
+
+: multipart-split ( bytes separator -- before after seq=? )
+ 2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
+
+:: multipart-step-found ( bytes stream quot -- ? )
+ bytes [
+ quot unless-empty
+ ] [
+ stream (>>leftover)
+ quot unless-empty
+ ] if-empty f quot call f ;
+
+:: multipart-step-not-found ( stream end-stream? separator quot -- ? )
+ end-stream? [
+ quot unless-empty f
+ ] [
+ separator length 1- ?cut* stream (>>leftover)
+ quot unless-empty t
+ ] if ;
+
+:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
+ #! return t to loop again
+ bytes separator multipart-split
+ [ 2drop f quot call f ]
+ [
+ [ stream quot multipart-step-found ]
+ [ stream end-stream? separator quot multipart-step-not-found ] if*
+ ] if stream leftover>> end-stream? not or ;
+
+PRIVATE>
+
+:: multipart-step-loop ( stream quot1: ( bytes -- ) quot2: ( -- ) -- ? )
+ stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
+ swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
+
+: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
+ 3dup multipart-step-loop
+ [ multipart-loop-all ] [ 3drop ] if ;
--- /dev/null
+Slava Pestov
--- /dev/null
+# This is a comment. I love comments.
+
+# This file controls what Internet media types are sent to the client for
+# given file extension(s). Sending the correct media type to the client
+# is important so they know how to handle the content of the file.
+# Extra types can either be added here or by using an AddType directive
+# in your config files. For more information about Internet media types,
+# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
+# registry is at <http://www.iana.org/assignments/media-types/>.
+
+# MIME type Extensions
+application/activemessage
+application/andrew-inset ez
+application/applefile
+application/atom+xml atom
+application/atomcat+xml atomcat
+application/atomicmail
+application/atomsvc+xml atomsvc
+application/auth-policy+xml
+application/batch-smtp
+application/beep+xml
+application/cals-1840
+application/ccxml+xml ccxml
+application/cellml+xml
+application/cnrp+xml
+application/commonground
+application/conference-info+xml
+application/cpl+xml
+application/csta+xml
+application/cstadata+xml
+application/cybercash
+application/davmount+xml davmount
+application/dca-rft
+application/dec-dx
+application/dialog-info+xml
+application/dicom
+application/dns
+application/dvcs
+application/ecmascript ecma
+application/edi-consent
+application/edi-x12
+application/edifact
+application/epp+xml
+application/eshop
+application/fastinfoset
+application/fastsoap
+application/fits
+application/font-tdpfr pfr
+application/h224
+application/http
+application/hyperstudio stk
+application/iges
+application/im-iscomposing+xml
+application/index
+application/index.cmd
+application/index.obj
+application/index.response
+application/index.vnd
+application/iotp
+application/ipp
+application/isup
+application/javascript js
+application/json json
+application/kpml-request+xml
+application/kpml-response+xml
+application/mac-binhex40 hqx
+application/mac-compactpro cpt
+application/macwriteii
+application/marc mrc
+application/mathematica ma nb mb
+application/mathml+xml mathml
+application/mbms-associated-procedure-description+xml
+application/mbms-deregister+xml
+application/mbms-envelope+xml
+application/mbms-msk+xml
+application/mbms-msk-response+xml
+application/mbms-protection-description+xml
+application/mbms-reception-report+xml
+application/mbms-register+xml
+application/mbms-register-response+xml
+application/mbms-user-service-description+xml
+application/mbox mbox
+application/mediaservercontrol+xml mscml
+application/mikey
+application/mp4 mp4s
+application/mpeg4-generic
+application/mpeg4-iod
+application/mpeg4-iod-xmt
+application/msword doc dot
+application/mxf mxf
+application/nasdata
+application/news-message-id
+application/news-transmission
+application/nss
+application/ocsp-request
+application/ocsp-response
+application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
+application/oda oda
+application/oebps-package+xml
+application/ogg ogg
+application/parityfec
+application/pdf pdf
+application/pgp-encrypted pgp
+application/pgp-keys
+application/pgp-signature asc sig
+application/pics-rules prf
+application/pidf+xml
+application/pkcs10 p10
+application/pkcs7-mime p7m p7c
+application/pkcs7-signature p7s
+application/pkix-cert cer
+application/pkix-crl crl
+application/pkix-pkipath pkipath
+application/pkixcmp pki
+application/pls+xml pls
+application/poc-settings+xml
+application/postscript ai eps ps
+application/prs.alvestrand.titrax-sheet
+application/prs.cww cww
+application/prs.nprend
+application/prs.plucker
+application/qsig
+application/rdf+xml rdf
+application/reginfo+xml rif
+application/relax-ng-compact-syntax rnc
+application/remote-printing
+application/resource-lists+xml rl
+application/riscos
+application/rlmi+xml
+application/rls-services+xml rs
+application/rsd+xml rsd
+application/rss+xml rss
+application/rtf rtf
+application/rtx
+application/samlassertion+xml
+application/samlmetadata+xml
+application/sbml+xml sbml
+application/sdp sdp
+application/set-payment
+application/set-payment-initiation setpay
+application/set-registration
+application/set-registration-initiation setreg
+application/sgml
+application/sgml-open-catalog
+application/shf+xml shf
+application/sieve
+application/simple-filter+xml
+application/simple-message-summary
+application/simplesymbolcontainer
+application/slate
+application/smil
+application/smil+xml smi smil
+application/soap+fastinfoset
+application/soap+xml
+application/spirits-event+xml
+application/srgs gram
+application/srgs+xml grxml
+application/ssml+xml ssml
+application/timestamp-query
+application/timestamp-reply
+application/tve-trigger
+application/vemmi
+application/vividence.scriptfile
+application/vnd.3gpp.bsf+xml
+application/vnd.3gpp.pic-bw-large plb
+application/vnd.3gpp.pic-bw-small psb
+application/vnd.3gpp.pic-bw-var pvb
+application/vnd.3gpp.sms
+application/vnd.3gpp2.bcmcsinfo+xml
+application/vnd.3gpp2.sms
+application/vnd.3m.post-it-notes pwn
+application/vnd.accpac.simply.aso aso
+application/vnd.accpac.simply.imp imp
+application/vnd.acucobol acu
+application/vnd.acucorp atc acutc
+application/vnd.adobe.xdp+xml xdp
+application/vnd.adobe.xfdf xfdf
+application/vnd.aether.imp
+application/vnd.amiga.ami ami
+application/vnd.anser-web-certificate-issue-initiation cii
+application/vnd.anser-web-funds-transfer-initiation fti
+application/vnd.antix.game-component atx
+application/vnd.apple.installer+xml mpkg
+application/vnd.audiograph aep
+application/vnd.autopackage
+application/vnd.avistar+xml
+application/vnd.blueice.multipass mpm
+application/vnd.bmi bmi
+application/vnd.businessobjects rep
+application/vnd.cab-jscript
+application/vnd.canon-cpdl
+application/vnd.canon-lips
+application/vnd.cendio.thinlinc.clientconf
+application/vnd.chemdraw+xml cdxml
+application/vnd.chipnuts.karaoke-mmd mmd
+application/vnd.cinderella cdy
+application/vnd.cirpack.isdn-ext
+application/vnd.claymore cla
+application/vnd.clonk.c4group c4g c4d c4f c4p c4u
+application/vnd.commerce-battelle
+application/vnd.commonspace csp cst
+application/vnd.contact.cmsg cdbcmsg
+application/vnd.cosmocaller cmc
+application/vnd.crick.clicker clkx
+application/vnd.crick.clicker.keyboard clkk
+application/vnd.crick.clicker.palette clkp
+application/vnd.crick.clicker.template clkt
+application/vnd.crick.clicker.wordbank clkw
+application/vnd.criticaltools.wbs+xml wbs
+application/vnd.ctc-posml pml
+application/vnd.cups-pdf
+application/vnd.cups-postscript
+application/vnd.cups-ppd ppd
+application/vnd.cups-raster
+application/vnd.cups-raw
+application/vnd.curl curl
+application/vnd.cybank
+application/vnd.data-vision.rdz rdz
+application/vnd.denovo.fcselayout-link fe_launch
+application/vnd.dna dna
+application/vnd.dolby.mlp mlp
+application/vnd.dpgraph dpg
+application/vnd.dreamfactory dfac
+application/vnd.dvb.esgcontainer
+application/vnd.dvb.ipdcesgaccess
+application/vnd.dxr
+application/vnd.ecdis-update
+application/vnd.ecowin.chart mag
+application/vnd.ecowin.filerequest
+application/vnd.ecowin.fileupdate
+application/vnd.ecowin.series
+application/vnd.ecowin.seriesrequest
+application/vnd.ecowin.seriesupdate
+application/vnd.enliven nml
+application/vnd.epson.esf esf
+application/vnd.epson.msf msf
+application/vnd.epson.quickanime qam
+application/vnd.epson.salt slt
+application/vnd.epson.ssf ssf
+application/vnd.ericsson.quickcall
+application/vnd.eszigno3+xml es3 et3
+application/vnd.eudora.data
+application/vnd.ezpix-album ez2
+application/vnd.ezpix-package ez3
+application/vnd.fdf fdf
+application/vnd.ffsns
+application/vnd.fints
+application/vnd.flographit gph
+application/vnd.fluxtime.clip ftc
+application/vnd.framemaker fm frame maker
+application/vnd.frogans.fnc fnc
+application/vnd.frogans.ltf ltf
+application/vnd.fsc.weblaunch fsc
+application/vnd.fujitsu.oasys oas
+application/vnd.fujitsu.oasys2 oa2
+application/vnd.fujitsu.oasys3 oa3
+application/vnd.fujitsu.oasysgp fg5
+application/vnd.fujitsu.oasysprs bh2
+application/vnd.fujixerox.art-ex
+application/vnd.fujixerox.art4
+application/vnd.fujixerox.hbpl
+application/vnd.fujixerox.ddd ddd
+application/vnd.fujixerox.docuworks xdw
+application/vnd.fujixerox.docuworks.binder xbd
+application/vnd.fut-misnet
+application/vnd.fuzzysheet fzs
+application/vnd.genomatix.tuxedo txd
+application/vnd.google-earth.kml+xml kml
+application/vnd.google-earth.kmz kmz
+application/vnd.grafeq gqf gqs
+application/vnd.gridmp
+application/vnd.groove-account gac
+application/vnd.groove-help ghf
+application/vnd.groove-identity-message gim
+application/vnd.groove-injector grv
+application/vnd.groove-tool-message gtm
+application/vnd.groove-tool-template tpl
+application/vnd.groove-vcard vcg
+application/vnd.handheld-entertainment+xml zmm
+application/vnd.hbci hbci
+application/vnd.hcl-bireports
+application/vnd.hhe.lesson-player les
+application/vnd.hp-hpgl hpgl
+application/vnd.hp-hpid hpid
+application/vnd.hp-hps hps
+application/vnd.hp-jlyt jlt
+application/vnd.hp-pcl pcl
+application/vnd.hp-pclxl pclxl
+application/vnd.httphone
+application/vnd.hzn-3d-crossword x3d
+application/vnd.ibm.afplinedata
+application/vnd.ibm.electronic-media
+application/vnd.ibm.minipay mpy
+application/vnd.ibm.modcap afp listafp list3820
+application/vnd.ibm.rights-management irm
+application/vnd.ibm.secure-container sc
+application/vnd.igloader igl
+application/vnd.immervision-ivp ivp
+application/vnd.immervision-ivu ivu
+application/vnd.informedcontrol.rms+xml
+application/vnd.intercon.formnet xpw xpx
+application/vnd.intertrust.digibox
+application/vnd.intertrust.nncp
+application/vnd.intu.qbo qbo
+application/vnd.intu.qfx qfx
+application/vnd.ipunplugged.rcprofile rcprofile
+application/vnd.irepository.package+xml irp
+application/vnd.is-xpr xpr
+application/vnd.jam jam
+application/vnd.japannet-directory-service
+application/vnd.japannet-jpnstore-wakeup
+application/vnd.japannet-payment-wakeup
+application/vnd.japannet-registration
+application/vnd.japannet-registration-wakeup
+application/vnd.japannet-setstore-wakeup
+application/vnd.japannet-verification
+application/vnd.japannet-verification-wakeup
+application/vnd.jcp.javame.midlet-rms rms
+application/vnd.jisp jisp
+application/vnd.kahootz ktz ktr
+application/vnd.kde.karbon karbon
+application/vnd.kde.kchart chrt
+application/vnd.kde.kformula kfo
+application/vnd.kde.kivio flw
+application/vnd.kde.kontour kon
+application/vnd.kde.kpresenter kpr kpt
+application/vnd.kde.kspread ksp
+application/vnd.kde.kword kwd kwt
+application/vnd.kenameaapp htke
+application/vnd.kidspiration kia
+application/vnd.kinar kne knp
+application/vnd.koan skp skd skt skm
+application/vnd.liberty-request+xml
+application/vnd.llamagraphics.life-balance.desktop lbd
+application/vnd.llamagraphics.life-balance.exchange+xml lbe
+application/vnd.lotus-1-2-3 123
+application/vnd.lotus-approach apr
+application/vnd.lotus-freelance pre
+application/vnd.lotus-notes nsf
+application/vnd.lotus-organizer org
+application/vnd.lotus-screencam scm
+application/vnd.lotus-wordpro lwp
+application/vnd.macports.portpkg portpkg
+application/vnd.marlin.drm.actiontoken+xml
+application/vnd.marlin.drm.conftoken+xml
+application/vnd.marlin.drm.mdcf
+application/vnd.mcd mcd
+application/vnd.medcalcdata mc1
+application/vnd.mediastation.cdkey cdkey
+application/vnd.meridian-slingshot
+application/vnd.mfer mwf
+application/vnd.mfmp mfm
+application/vnd.micrografx.flo flo
+application/vnd.micrografx.igx igx
+application/vnd.mif mif
+application/vnd.minisoft-hp3000-save
+application/vnd.mitsubishi.misty-guard.trustweb
+application/vnd.mobius.daf daf
+application/vnd.mobius.dis dis
+application/vnd.mobius.mbk mbk
+application/vnd.mobius.mqy mqy
+application/vnd.mobius.msl msl
+application/vnd.mobius.plc plc
+application/vnd.mobius.txf txf
+application/vnd.mophun.application mpn
+application/vnd.mophun.certificate mpc
+application/vnd.motorola.flexsuite
+application/vnd.motorola.flexsuite.adsi
+application/vnd.motorola.flexsuite.fis
+application/vnd.motorola.flexsuite.gotap
+application/vnd.motorola.flexsuite.kmr
+application/vnd.motorola.flexsuite.ttc
+application/vnd.motorola.flexsuite.wem
+application/vnd.mozilla.xul+xml xul
+application/vnd.ms-artgalry cil
+application/vnd.ms-asf asf
+application/vnd.ms-cab-compressed cab
+application/vnd.ms-excel xls xlm xla xlc xlt xlw
+application/vnd.ms-fontobject eot
+application/vnd.ms-htmlhelp chm
+application/vnd.ms-ims ims
+application/vnd.ms-lrm lrm
+application/vnd.ms-playready.initiator+xml
+application/vnd.ms-powerpoint ppt pps pot
+application/vnd.ms-project mpp mpt
+application/vnd.ms-tnef
+application/vnd.ms-wmdrm.lic-chlg-req
+application/vnd.ms-wmdrm.lic-resp
+application/vnd.ms-wmdrm.meter-chlg-req
+application/vnd.ms-wmdrm.meter-resp
+application/vnd.ms-works wps wks wcm wdb
+application/vnd.ms-wpl wpl
+application/vnd.ms-xpsdocument xps
+application/vnd.mseq mseq
+application/vnd.msign
+application/vnd.music-niff
+application/vnd.musician mus
+application/vnd.ncd.control
+application/vnd.nervana
+application/vnd.netfpx
+application/vnd.neurolanguage.nlu nlu
+application/vnd.noblenet-directory nnd
+application/vnd.noblenet-sealer nns
+application/vnd.noblenet-web nnw
+application/vnd.nokia.catalogs
+application/vnd.nokia.conml+wbxml
+application/vnd.nokia.conml+xml
+application/vnd.nokia.isds-radio-presets
+application/vnd.nokia.iptv.config+xml
+application/vnd.nokia.landmark+wbxml
+application/vnd.nokia.landmark+xml
+application/vnd.nokia.landmarkcollection+xml
+application/vnd.nokia.n-gage.ac+xml
+application/vnd.nokia.n-gage.data ngdat
+application/vnd.nokia.n-gage.symbian.install n-gage
+application/vnd.nokia.ncd
+application/vnd.nokia.pcd+wbxml
+application/vnd.nokia.pcd+xml
+application/vnd.nokia.radio-preset rpst
+application/vnd.nokia.radio-presets rpss
+application/vnd.novadigm.edm edm
+application/vnd.novadigm.edx edx
+application/vnd.novadigm.ext ext
+application/vnd.oasis.opendocument.chart odc
+application/vnd.oasis.opendocument.chart-template otc
+application/vnd.oasis.opendocument.formula odf
+application/vnd.oasis.opendocument.formula-template otf
+application/vnd.oasis.opendocument.graphics odg
+application/vnd.oasis.opendocument.graphics-template otg
+application/vnd.oasis.opendocument.image odi
+application/vnd.oasis.opendocument.image-template oti
+application/vnd.oasis.opendocument.presentation odp
+application/vnd.oasis.opendocument.presentation-template otp
+application/vnd.oasis.opendocument.spreadsheet ods
+application/vnd.oasis.opendocument.spreadsheet-template ots
+application/vnd.oasis.opendocument.text odt
+application/vnd.oasis.opendocument.text-master otm
+application/vnd.oasis.opendocument.text-template ott
+application/vnd.oasis.opendocument.text-web oth
+application/vnd.obn
+application/vnd.olpc-sugar xo
+application/vnd.oma-scws-config
+application/vnd.oma-scws-http-request
+application/vnd.oma-scws-http-response
+application/vnd.oma.bcast.associated-procedure-parameter+xml
+application/vnd.oma.bcast.drm-trigger+xml
+application/vnd.oma.bcast.imd+xml
+application/vnd.oma.bcast.notification+xml
+application/vnd.oma.bcast.sgboot
+application/vnd.oma.bcast.sgdd+xml
+application/vnd.oma.bcast.sgdu
+application/vnd.oma.bcast.simple-symbol-container
+application/vnd.oma.bcast.smartcard-trigger+xml
+application/vnd.oma.bcast.sprov+xml
+application/vnd.oma.dd2+xml dd2
+application/vnd.oma.drm.risd+xml
+application/vnd.oma.group-usage-list+xml
+application/vnd.oma.poc.groups+xml
+application/vnd.oma.xcap-directory+xml
+application/vnd.omads-email+xml
+application/vnd.omads-file+xml
+application/vnd.omads-folder+xml
+application/vnd.omaloc-supl-init
+application/vnd.openofficeorg.extension oxt
+application/vnd.osa.netdeploy
+application/vnd.osgi.dp dp
+application/vnd.otps.ct-kip+xml
+application/vnd.palm prc pdb pqa oprc
+application/vnd.paos.xml
+application/vnd.pg.format str
+application/vnd.pg.osasli ei6
+application/vnd.piaccess.application-licence
+application/vnd.picsel efif
+application/vnd.poc.group-advertisement+xml
+application/vnd.pocketlearn plf
+application/vnd.powerbuilder6 pbd
+application/vnd.powerbuilder6-s
+application/vnd.powerbuilder7
+application/vnd.powerbuilder7-s
+application/vnd.powerbuilder75
+application/vnd.powerbuilder75-s
+application/vnd.preminet
+application/vnd.previewsystems.box box
+application/vnd.proteus.magazine mgz
+application/vnd.publishare-delta-tree qps
+application/vnd.pvi.ptid1 ptid
+application/vnd.pwg-multiplexed
+application/vnd.pwg-xhtml-print+xml
+application/vnd.qualcomm.brew-app-res
+application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
+application/vnd.rapid
+application/vnd.recordare.musicxml mxl
+application/vnd.recordare.musicxml+xml
+application/vnd.renlearn.rlprint
+application/vnd.rn-realmedia rm
+application/vnd.ruckus.download
+application/vnd.s3sms
+application/vnd.scribus
+application/vnd.sealed.3df
+application/vnd.sealed.csf
+application/vnd.sealed.doc
+application/vnd.sealed.eml
+application/vnd.sealed.mht
+application/vnd.sealed.net
+application/vnd.sealed.ppt
+application/vnd.sealed.tiff
+application/vnd.sealed.xls
+application/vnd.sealedmedia.softseal.html
+application/vnd.sealedmedia.softseal.pdf
+application/vnd.seemail see
+application/vnd.sema sema
+application/vnd.semd semd
+application/vnd.semf semf
+application/vnd.shana.informed.formdata ifm
+application/vnd.shana.informed.formtemplate itp
+application/vnd.shana.informed.interchange iif
+application/vnd.shana.informed.package ipk
+application/vnd.simtech-mindmapper twd twds
+application/vnd.smaf mmf
+application/vnd.solent.sdkm+xml sdkm sdkd
+application/vnd.spotfire.dxp dxp
+application/vnd.spotfire.sfs sfs
+application/vnd.sss-cod
+application/vnd.sss-dtf
+application/vnd.sss-ntf
+application/vnd.street-stream
+application/vnd.sun.wadl+xml
+application/vnd.sus-calendar sus susp
+application/vnd.svd svd
+application/vnd.swiftview-ics
+application/vnd.syncml+xml xsm
+application/vnd.syncml.dm+wbxml bdm
+application/vnd.syncml.dm+xml xdm
+application/vnd.syncml.ds.notification
+application/vnd.tao.intent-module-archive tao
+application/vnd.tmobile-livetv tmo
+application/vnd.trid.tpt tpt
+application/vnd.triscape.mxs mxs
+application/vnd.trueapp tra
+application/vnd.truedoc
+application/vnd.ufdl ufd ufdl
+application/vnd.uiq.theme utz
+application/vnd.umajin umj
+application/vnd.unity unityweb
+application/vnd.uoml+xml uoml
+application/vnd.uplanet.alert
+application/vnd.uplanet.alert-wbxml
+application/vnd.uplanet.bearer-choice
+application/vnd.uplanet.bearer-choice-wbxml
+application/vnd.uplanet.cacheop
+application/vnd.uplanet.cacheop-wbxml
+application/vnd.uplanet.channel
+application/vnd.uplanet.channel-wbxml
+application/vnd.uplanet.list
+application/vnd.uplanet.list-wbxml
+application/vnd.uplanet.listcmd
+application/vnd.uplanet.listcmd-wbxml
+application/vnd.uplanet.signal
+application/vnd.vcx vcx
+application/vnd.vd-study
+application/vnd.vectorworks
+application/vnd.vidsoft.vidconference
+application/vnd.visio vsd vst vss vsw
+application/vnd.visionary vis
+application/vnd.vividence.scriptfile
+application/vnd.vsf vsf
+application/vnd.wap.sic
+application/vnd.wap.slc
+application/vnd.wap.wbxml wbxml
+application/vnd.wap.wmlc wmlc
+application/vnd.wap.wmlscriptc wmlsc
+application/vnd.webturbo wtb
+application/vnd.wfa.wsc
+application/vnd.wordperfect wpd
+application/vnd.wqd wqd
+application/vnd.wrq-hp3000-labelled
+application/vnd.wt.stf stf
+application/vnd.wv.csp+wbxml
+application/vnd.wv.csp+xml
+application/vnd.wv.ssp+xml
+application/vnd.xara xar
+application/vnd.xfdl xfdl
+application/vnd.xmpie.cpkg
+application/vnd.xmpie.dpkg
+application/vnd.xmpie.plan
+application/vnd.xmpie.ppkg
+application/vnd.xmpie.xlim
+application/vnd.yamaha.hv-dic hvd
+application/vnd.yamaha.hv-script hvs
+application/vnd.yamaha.hv-voice hvp
+application/vnd.yamaha.smaf-audio saf
+application/vnd.yamaha.smaf-phrase spf
+application/vnd.yellowriver-custom-menu cmp
+application/vnd.zzazz.deck+xml zaz
+application/voicexml+xml vxml
+application/watcherinfo+xml
+application/whoispp-query
+application/whoispp-response
+application/winhlp hlp
+application/wita
+application/wordperfect5.1
+application/wsdl+xml wsdl
+application/wspolicy+xml wspolicy
+application/x-ace-compressed ace
+application/x-bcpio bcpio
+application/x-bittorrent torrent
+application/x-bzip bz
+application/x-bzip2 bz2 boz
+application/x-cdlink vcd
+application/x-chat chat
+application/x-chess-pgn pgn
+application/x-compress
+application/x-cpio cpio
+application/x-csh csh
+application/x-director dcr dir dxr fgd
+application/x-dvi dvi
+application/x-futuresplash spl
+application/x-gtar gtar
+application/x-gzip
+application/x-hdf hdf
+application/x-java-jnlp-file jnlp
+application/x-latex latex
+application/x-ms-wmd wmd
+application/x-ms-wmz wmz
+application/x-msaccess mdb
+application/x-msbinder obd
+application/x-mscardfile crd
+application/x-msclip clp
+application/x-msdownload exe dll com bat msi
+application/x-msmediaview mvb m13 m14
+application/x-msmetafile wmf
+application/x-msmoney mny
+application/x-mspublisher pub
+application/x-msschedule scd
+application/x-msterminal trm
+application/x-mswrite wri
+application/x-netcdf nc cdf
+application/x-pkcs12 p12 pfx
+application/x-pkcs7-certificates p7b spc
+application/x-pkcs7-certreqresp p7r
+application/x-rar-compressed rar
+application/x-sh sh
+application/x-shar shar
+application/x-shockwave-flash swf
+application/x-stuffit sit
+application/x-stuffitx sitx
+application/x-sv4cpio sv4cpio
+application/x-sv4crc sv4crc
+application/x-tar tar
+application/x-tcl tcl
+application/x-tex tex
+application/x-texinfo texinfo texi
+application/x-ustar ustar
+application/x-wais-source src
+application/x-x509-ca-cert der crt
+application/x400-bp
+application/xcap-att+xml
+application/xcap-caps+xml
+application/xcap-el+xml
+application/xcap-error+xml
+application/xcap-ns+xml
+application/xenc+xml xenc
+application/xhtml+xml xhtml xht
+application/xml xml xsl
+application/xml-dtd dtd
+application/xml-external-parsed-entity
+application/xmpp+xml
+application/xop+xml xop
+application/xslt+xml xslt
+application/xspf+xml xspf
+application/xv+xml mxml xhvml xvml xvm
+application/zip zip
+audio/32kadpcm
+audio/3gpp
+audio/3gpp2
+audio/ac3
+audio/amr
+audio/amr-wb
+audio/amr-wb+
+audio/asc
+audio/basic au snd
+audio/bv16
+audio/bv32
+audio/clearmode
+audio/cn
+audio/dat12
+audio/dls
+audio/dsr-es201108
+audio/dsr-es202050
+audio/dsr-es202211
+audio/dsr-es202212
+audio/dvi4
+audio/eac3
+audio/evrc
+audio/evrc-qcp
+audio/evrc0
+audio/evrc1
+audio/evrcb
+audio/evrcb0
+audio/evrcb1
+audio/g722
+audio/g7221
+audio/g723
+audio/g726-16
+audio/g726-24
+audio/g726-32
+audio/g726-40
+audio/g728
+audio/g729
+audio/g7291
+audio/g729d
+audio/g729e
+audio/gsm
+audio/gsm-efr
+audio/ilbc
+audio/l16
+audio/l20
+audio/l24
+audio/l8
+audio/lpc
+audio/midi mid midi kar rmi
+audio/mobile-xmf
+audio/mp4 mp4a
+audio/mp4a-latm m4a m4p
+audio/mpa
+audio/mpa-robust
+audio/mpeg mpga mp2 mp2a mp3 m2a m3a
+audio/mpeg4-generic
+audio/parityfec
+audio/pcma
+audio/pcmu
+audio/prs.sid
+audio/qcelp
+audio/red
+audio/rtp-enc-aescm128
+audio/rtp-midi
+audio/rtx
+audio/smv
+audio/smv0
+audio/smv-qcp
+audio/sp-midi
+audio/t140c
+audio/t38
+audio/telephone-event
+audio/tone
+audio/vdvi
+audio/vmr-wb
+audio/vnd.3gpp.iufp
+audio/vnd.4sb
+audio/vnd.audiokoz
+audio/vnd.celp
+audio/vnd.cisco.nse
+audio/vnd.cmles.radio-events
+audio/vnd.cns.anp1
+audio/vnd.cns.inf1
+audio/vnd.digital-winds eol
+audio/vnd.dlna.adts
+audio/vnd.dolby.mlp
+audio/vnd.everad.plj
+audio/vnd.hns.audio
+audio/vnd.lucent.voice lvp
+audio/vnd.nokia.mobile-xmf
+audio/vnd.nortel.vbk
+audio/vnd.nuera.ecelp4800 ecelp4800
+audio/vnd.nuera.ecelp7470 ecelp7470
+audio/vnd.nuera.ecelp9600 ecelp9600
+audio/vnd.octel.sbc
+audio/vnd.qcelp
+audio/vnd.rhetorex.32kadpcm
+audio/vnd.sealedmedia.softseal.mpeg
+audio/vnd.vmx.cvsd
+audio/wav wav
+audio/x-aiff aif aiff aifc
+audio/x-mpegurl m3u
+audio/x-ms-wax wax
+audio/x-ms-wma wma
+audio/x-pn-realaudio ram ra
+audio/x-pn-realaudio-plugin rmp
+audio/x-wav wav
+chemical/x-cdx cdx
+chemical/x-cif cif
+chemical/x-cmdf cmdf
+chemical/x-cml cml
+chemical/x-csml csml
+chemical/x-pdb pdb
+chemical/x-xyz xyz
+image/bmp bmp
+image/cgm cgm
+image/fits
+image/g3fax g3
+image/gif gif
+image/ief ief
+image/jp2 jp2
+image/jpeg jpeg jpg jpe
+image/jpm
+image/jpx
+image/naplps
+image/pict pict pic pct
+image/png png
+image/prs.btif btif
+image/prs.pti
+image/svg+xml svg svgz
+image/t38
+image/tiff tiff tif
+image/tiff-fx
+image/vnd.adobe.photoshop psd
+image/vnd.cns.inf2
+image/vnd.djvu djvu djv
+image/vnd.dwg dwg
+image/vnd.dxf dxf
+image/vnd.fastbidsheet fbs
+image/vnd.fpx fpx
+image/vnd.fst fst
+image/vnd.fujixerox.edmics-mmr mmr
+image/vnd.fujixerox.edmics-rlc rlc
+image/vnd.globalgraphics.pgb
+image/vnd.microsoft.icon ico
+image/vnd.mix
+image/vnd.ms-modi mdi
+image/vnd.net-fpx npx
+image/vnd.sealed.png
+image/vnd.sealedmedia.softseal.gif
+image/vnd.sealedmedia.softseal.jpg
+image/vnd.svf
+image/vnd.wap.wbmp wbmp
+image/vnd.xiff xif
+image/x-cmu-raster ras
+image/x-cmx cmx
+image/x-icon
+image/x-macpaint pntg pnt mac
+image/x-pcx pcx
+image/x-pict pic pct
+image/x-portable-anymap pnm
+image/x-portable-bitmap pbm
+image/x-portable-graymap pgm
+image/x-portable-pixmap ppm
+image/x-quicktime qtif qti
+image/x-rgb rgb
+image/x-xbitmap xbm
+image/x-xpixmap xpm
+image/x-xwindowdump xwd
+message/cpim
+message/delivery-status
+message/disposition-notification
+message/external-body
+message/http
+message/news
+message/partial
+message/rfc822 eml mime
+message/s-http
+message/sip
+message/sipfrag
+message/tracking-status
+model/iges igs iges
+model/mesh msh mesh silo
+model/vnd.dwf dwf
+model/vnd.flatland.3dml
+model/vnd.gdl gdl
+model/vnd.gs.gdl
+model/vnd.gtw gtw
+model/vnd.moml+xml
+model/vnd.mts mts
+model/vnd.parasolid.transmit.binary
+model/vnd.parasolid.transmit.text
+model/vnd.vtu vtu
+model/vrml wrl vrml
+multipart/alternative
+multipart/appledouble
+multipart/byteranges
+multipart/digest
+multipart/encrypted
+multipart/form-data
+multipart/header-set
+multipart/mixed
+multipart/parallel
+multipart/related
+multipart/report
+multipart/signed
+multipart/voice-message
+text/calendar ics ifb
+text/css css
+text/csv csv
+text/directory
+text/dns
+text/enriched
+text/html html htm
+text/parityfec
+text/plain txt text conf def list log in
+text/prs.fallenstein.rst
+text/prs.lines.tag dsc
+text/red
+text/rfc822-headers
+text/richtext rtx
+text/rtf
+text/rtp-enc-aescm128
+text/rtx
+text/sgml sgml sgm
+text/t140
+text/tab-separated-values tsv
+text/troff t tr roff man me ms
+text/uri-list uri uris urls
+text/vnd.abc
+text/vnd.curl
+text/vnd.dmclientscript
+text/vnd.esmertec.theme-descriptor
+text/vnd.fly fly
+text/vnd.fmi.flexstor flx
+text/vnd.in3d.3dml 3dml
+text/vnd.in3d.spot spot
+text/vnd.iptc.newsml
+text/vnd.iptc.nitf
+text/vnd.latex-z
+text/vnd.motorola.reflex
+text/vnd.ms-mediapackage
+text/vnd.net2phone.commcenter.command
+text/vnd.sun.j2me.app-descriptor jad
+text/vnd.trolltech.linguist
+text/vnd.wap.si
+text/vnd.wap.sl
+text/vnd.wap.wml wml
+text/vnd.wap.wmlscript wmls
+text/x-asm s asm
+text/x-c c cc cxx cpp h hh dic
+text/x-fortran f for f77 f90
+text/x-pascal p pas
+text/x-java-source java
+text/x-setext etx
+text/x-uuencode uu
+text/x-vcalendar vcs
+text/x-vcard vcf
+text/xml
+text/xml-external-parsed-entity
+video/3gpp 3gp
+video/3gpp-tt
+video/3gpp2 3g2
+video/bmpeg
+video/bt656
+video/celb
+video/dv
+video/h261 h261
+video/h263 h263
+video/h263-1998
+video/h263-2000
+video/h264 h264
+video/jpeg jpgv
+video/jpm jpm jpgm
+video/mj2 mj2 mjp2
+video/mp1s
+video/mp2p
+video/mp2t
+video/mp4 mp4 mp4v mpg4 m4v
+video/mp4v-es
+video/mpeg mpeg mpg mpe m1v m2v
+video/mpeg4-generic
+video/mpv
+video/nv
+video/parityfec
+video/pointer
+video/quicktime qt mov
+video/raw
+video/rtp-enc-aescm128
+video/rtx
+video/smpte292m
+video/vc1
+video/vnd.dlna.mpeg-tts
+video/vnd.fvt fvt
+video/vnd.hns.video
+video/vnd.motorola.video
+video/vnd.motorola.videop
+video/vnd.mpegurl mxu m4u
+video/vnd.nokia.interleaved-multimedia
+video/vnd.nokia.videovoip
+video/vnd.objectvideo
+video/vnd.sealed.mpeg1
+video/vnd.sealed.mpeg4
+video/vnd.sealed.swf
+video/vnd.sealedmedia.softseal.mov
+video/vnd.vivo viv
+video/x-dv dv dif
+video/x-fli fli
+video/x-ms-asf asf asx
+video/x-ms-wm wm
+video/x-ms-wmv wmv
+video/x-ms-wmx wmx
+video/x-ms-wvx wvx
+video/x-msvideo avi
+video/x-sgi-movie movie
+x-conference/x-cooltalk ice
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax io.streams.string sequences ;
+IN: mime.types
+
+HELP: mime-db
+{ $values
+
+ { "seq" sequence } }
+{ $description "Outputs an array where the first element is a MIME type and the rest of the array is file extensions that have that MIME type." } ;
+
+HELP: mime-type
+{ $values
+ { "filename" "a filename" }
+ { "mime-type" "a MIME type string" } }
+{ $description "Outputs the MIME type associtated with a path by parsing the path's file extension and looking it up in the table returned by " { $link mime-types } "." } ;
+
+HELP: mime-types
+{ $values
+
+ { "assoc" assoc } }
+{ $description "Outputs an " { $snippet "assoc" } " made from the data in the " { $link mime-db } " word where the keys are file extensions and the values are the corresponding MIME types." } ;
+
+HELP: nonstandard-mime-types
+{ $values
+
+ { "assoc" assoc } }
+{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
+
+ARTICLE: "mime.types" "MIME types"
+"The " { $vocab-link "mime.types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
+"Looking up a MIME type:"
+{ $subsection mime-type } ;
+
+ABOUT: "mime.types"
--- /dev/null
+IN: mime.types.tests
+USING: mime.types tools.test ;
+
+[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
+[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
+[ "text/plain" ] [ "foo.factor" mime-type ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.encodings.ascii assocs sequences splitting
+kernel namespaces fry memoize ;
+IN: mime.types
+
+MEMO: mime-db ( -- seq )
+ "resource:basis/mime/types/mime.types" ascii file-lines
+ [ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
+
+: nonstandard-mime-types ( -- assoc )
+ H{
+ { "factor" "text/plain" }
+ { "cgi" "application/x-cgi-script" }
+ { "fhtml" "application/x-factor-server-page" }
+ } ;
+
+MEMO: mime-types ( -- assoc )
+ [
+ mime-db [ unclip '[ [ _ ] dip set ] each ] each
+ ] H{ } make-assoc
+ nonstandard-mime-types assoc-union ;
+
+: mime-type ( filename -- mime-type )
+ file-extension mime-types at "application/octet-stream" or ;
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! 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 summary splitting assocs
-random math.parser locals unicode.case
-openssl.libcrypto openssl.libssl
-io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
-io.timeouts ;
+USING: init kernel namespaces openssl.libcrypto openssl.libssl
+sequences ;
IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/
SINGLETON: openssl
-GENERIC: ssl-method ( symbol -- method )
-
-M: SSLv2 ssl-method drop SSLv2_client_method ;
-M: SSLv23 ssl-method drop SSLv23_method ;
-M: SSLv3 ssl-method drop SSLv3_method ;
-M: TLSv1 ssl-method drop TLSv1_method ;
-
: (ssl-error-string) ( n -- string )
ERR_clear_error f ERR_error_string ;
] unless ;
[ f ssl-initialized? set-global ] "openssl" add-init-hook
-
-TUPLE: openssl-context < secure-context aliens sessions ;
-
-: set-session-cache ( ctx -- )
- handle>>
- [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
- [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
- bi ;
-
-: load-certificate-chain ( ctx -- )
- dup config>> key-file>> [
- [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
- SSL_CTX_use_certificate_chain_file
- ssl-error
- ] [ drop ] if ;
-
-: password-callback ( -- alien )
- "int" { "void*" "int" "bool" "void*" } "cdecl"
- [| buf size rwflag password! |
- password [ B{ 0 } password! ] unless
-
- [let | len [ password strlen ] |
- buf password len 1+ size min memcpy
- len
- ]
- ] alien-callback ;
-
-: default-pasword ( ctx -- alien )
- [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
- [ push ] [ drop ] 2bi ;
-
-: set-default-password ( ctx -- )
- [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
- [
- [ handle>> ] [ default-pasword ] bi
- SSL_CTX_set_default_passwd_cb_userdata
- ] bi ;
-
-: use-private-key-file ( ctx -- )
- dup config>> key-file>> [
- [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
- SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
- ssl-error
- ] [ drop ] if ;
-
-: load-verify-locations ( ctx -- )
- dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
- [ handle>> ]
- [
- config>>
- [ ca-file>> dup [ (normalize-path) ] when ]
- [ ca-path>> dup [ (normalize-path) ] when ] bi
- ] bi
- SSL_CTX_load_verify_locations
- ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
-
-: set-verify-depth ( ctx -- )
- dup config>> verify-depth>> [
- [ handle>> ] [ config>> verify-depth>> ] bi
- SSL_CTX_set_verify_depth
- ] [ drop ] if ;
-
-TUPLE: bio handle disposed ;
-
-: <bio> ( handle -- bio ) f bio boa ;
-
-M: bio dispose* handle>> BIO_free ssl-error ;
-
-: <file-bio> ( path -- bio )
- normalize-path "r" BIO_new_file dup ssl-error <bio> ;
-
-: load-dh-params ( ctx -- )
- dup config>> dh-file>> [
- [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
- handle>> f f f PEM_read_bio_DHparams dup ssl-error
- SSL_CTX_set_tmp_dh ssl-error
- ] [ drop ] if ;
-
-TUPLE: rsa handle disposed ;
-
-: <rsa> ( handle -- rsa ) f rsa boa ;
-
-M: rsa dispose* handle>> RSA_free ;
-
-: generate-eph-rsa-key ( ctx -- )
- [ handle>> ]
- [
- config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
- dup ssl-error <rsa> &dispose handle>>
- ] bi
- SSL_CTX_set_tmp_rsa ssl-error ;
-
-: <openssl-context> ( config ctx -- context )
- openssl-context new
- swap >>handle
- swap >>config
- V{ } clone >>aliens
- H{ } clone >>sessions ;
-
-M: openssl <secure-context> ( config -- context )
- maybe-init-ssl
- [
- dup method>> ssl-method SSL_CTX_new
- dup ssl-error <openssl-context> |dispose
- {
- [ set-session-cache ]
- [ load-certificate-chain ]
- [ set-default-password ]
- [ use-private-key-file ]
- [ load-verify-locations ]
- [ set-verify-depth ]
- [ load-dh-params ]
- [ generate-eph-rsa-key ]
- [ ]
- } cleave
- ] with-destructors ;
-
-M: openssl-context dispose*
- [ aliens>> [ free ] each ]
- [ sessions>> values [ SSL_SESSION_free ] each ]
- [ handle>> SSL_CTX_free ]
- tri ;
-
-TUPLE: ssl-handle file handle connected disposed ;
-
-SYMBOL: default-secure-context
-
-: context-expired? ( context -- ? )
- dup [ handle>> expired? ] [ drop t ] if ;
-
-: current-secure-context ( -- ctx )
- secure-context get [
- default-secure-context get dup context-expired? [
- drop
- <secure-config> <secure-context> default-secure-context set-global
- current-secure-context
- ] when
- ] unless* ;
-
-: <ssl-handle> ( fd -- ssl )
- current-secure-context handle>> SSL_new dup ssl-error
- f f ssl-handle boa ;
-
-M: ssl-handle dispose*
- [ handle>> SSL_free ] [ file>> dispose ] bi ;
-
-: check-verify-result ( ssl-handle -- )
- SSL_get_verify_result dup X509_V_OK =
- [ drop ] [ verify-message certificate-verify-error ] if ;
-
-: common-name ( certificate -- host )
- X509_get_subject_name
- NID_commonName 256 <byte-array>
- [ 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 common-names-match?
- [ 2drop ] [ common-name-verify-error ] if ;
-
-M: openssl check-certificate ( host ssl -- )
- current-secure-context config>> verify>> [
- handle>>
- [ nip check-verify-result ]
- [ check-common-name ]
- 2bi
- ] [ 2drop ] if ;
-
-: get-session ( addrspec -- session/f )
- current-secure-context sessions>> at
- dup expired? [ drop f ] when ;
-
-: save-session ( session addrspec -- )
- current-secure-context sessions>> set-at ;
-
-openssl secure-socket-backend set-global
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces make math assocs
-shuffle vectors arrays math.parser accessors unicode.categories
+vectors arrays math.parser accessors unicode.categories
sequences.deep peg peg.private peg.search math.ranges words ;
IN: peg.parsers
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces make math assocs
-shuffle debugger io vectors arrays math.parser math.order
+debugger io vectors arrays math.parser math.order
vectors combinators classes sets unicode.categories
compiler.units parser words quotations effects memoize accessors
locals effects splitting combinators.short-circuit
HELP: present
{ $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." }
-{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ;
+{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $vocab-link "urls" } " vocabularies." } ;
ABOUT: "present"
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
-
-GENERIC: valid-callable? ( obj -- ? )
-
-M: object valid-callable? drop f ;
-
-M: quotation valid-callable? drop t ;
-
-M: curry valid-callable? quot>> valid-callable? ;
-
-M: compose valid-callable?
- [ first>> ] [ second>> ] bi [ valid-callable? ] both? ;
-
-M: curry pprint*
- dup valid-callable? [ pprint-object ] [
- "( invalid curry )" swap present-text
- ] if ;
-
-M: compose pprint*
- dup valid-callable? [ pprint-object ] [
- "( invalid compose )" swap present-text
- ] if ;
+M: curry pprint* pprint-object ;
+M: compose pprint* pprint-object ;
M: wrapper pprint*
dup wrapped>> word? [
[ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
-[ ] [ 1 \ + curry unparse drop ] unit-test
-
-[ ] [ 1 \ + compose unparse drop ] unit-test
-
GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
] unit-test
-
-[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test
-[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test
-[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test
-[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test
] with-pprint nl
] unless-empty ;
-: vocabs. ( in use -- )
+: use/in. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
: prelude. ( -- )
- in get use get vocab-names vocabs. ;
+ in get use get vocab-names use/in. ;
[
nl
] print-use-hook set-global
: with-use ( obj quot -- )
- make-pprint vocabs. do-pprint ; inline
+ make-pprint use/in. do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline
#! Syntax: QUALIFIED-WITH: vocab prefix
scan scan define-qualified ; parsing
-: expect=> ( -- ) scan "=>" assert= ;
-
: partial-vocab ( words vocab -- assoc )
'[ dup _ lookup [ no-word-error ] unless* ]
{ } map>assoc ;
: FROM:
#! Syntax: FROM: vocab => words... ;
- scan dup load-vocab drop expect=>
+ scan dup load-vocab drop "=>" expect
";" parse-tokens swap partial-vocab use get push ; parsing
: partial-vocab-excluding ( words vocab -- assoc )
: EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ;
- scan expect=>
+ scan "=>" expect
";" parse-tokens swap partial-vocab-excluding use get push ; parsing
: RENAME:
#! Syntax: RENAME: word vocab => newname
scan scan dup load-vocab drop
dupd lookup [ ] [ no-word-error ] ?if
- expect=>
+ "=>" expect
scan associate use get push ; parsing
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math state-tables vectors ;
+USING: accessors hashtables kernel math vectors ;
IN: regexp.backend
TUPLE: regexp
GENERIC: class-member? ( obj class -- ? )
M: word class-member? ( obj class -- ? ) 2drop f ;
+
M: integer class-member? ( obj class -- ? ) 2drop f ;
M: character-class-range class-member? ( obj class -- ? )
M: any-char class-member? ( obj class -- ? )
2drop t ;
+
+M: any-char-no-nl class-member? ( obj class -- ? )
+ drop CHAR: \n = not ;
M: letter-class class-member? ( obj class -- ? )
drop letter? ;
M: unmatchable-class class-member? ( obj class -- ? )
2drop f ;
+
+M: terminator-class class-member? ( obj class -- ? )
+ drop {
+ [ CHAR: \r = ]
+ [ CHAR: \n = ]
+ [ CHAR: \u000085 = ]
+ [ CHAR: \u002028 = ]
+ [ CHAR: \u002029 = ]
+ } 1|| ;
dupd pop dup pick find-transitions rot
[
[ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
- >r swapd transition make-transition r> dfa-table>> add-transition
+ [ swapd transition make-transition ] dip
+ dfa-table>> add-transition
] curry with each
new-transitions
] if-empty ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs grouping kernel regexp.backend
-locals math namespaces regexp.parser sequences state-tables fry
-quotations math.order math.ranges vectors unicode.categories
-regexp.utils regexp.transition-tables words sets ;
+locals math namespaces regexp.parser sequences fry quotations
+math.order math.ranges vectors unicode.categories regexp.utils
+regexp.transition-tables words sets ;
IN: regexp.nfa
SYMBOL: negation-mode
SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
+SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
+SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
+SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
+
+: add-global-flag ( flag -- )
+ current-regexp get nfa-table>> flags>> conjoin ;
: next-state ( regexp -- state )
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
M: reluctant-kleene-star nfa-node ( node -- )
term>> <kleene-star> nfa-node ;
-!
+M: beginning-of-line nfa-node ( node -- )
+ drop
+ eps literal-transition add-simple-entry
+ beginning-of-line add-global-flag ;
+
+M: end-of-line nfa-node ( node -- )
+ drop
+ eps literal-transition add-simple-entry
+ end-of-line add-global-flag ;
+
+M: beginning-of-input nfa-node ( node -- )
+ drop
+ eps literal-transition add-simple-entry
+ beginning-of-input add-global-flag ;
+
+M: end-of-input nfa-node ( node -- )
+ drop
+ eps literal-transition add-simple-entry
+ end-of-input add-global-flag ;
M: negation nfa-node ( node -- )
negation-mode inc
kernel math math.parser namespaces qualified sets
quotations sequences splitting symbols vectors math.order
unicode.categories strings regexp.backend regexp.utils
-unicode.case words ;
+unicode.case words locals ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
SINGLETON: epsilon INSTANCE: epsilon node
SINGLETON: any-char INSTANCE: any-char node
-SINGLETON: front-anchor INSTANCE: front-anchor node
-SINGLETON: back-anchor INSTANCE: back-anchor node
+SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node
+SINGLETON: beginning-of-input INSTANCE: beginning-of-input node
+SINGLETON: end-of-input INSTANCE: end-of-input node
+SINGLETON: beginning-of-line INSTANCE: beginning-of-line node
+SINGLETON: end-of-line INSTANCE: end-of-line node
TUPLE: option-on option ; INSTANCE: option-on node
TUPLE: option-off option ; INSTANCE: option-off node
-SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case reversed-regexp ;
+SINGLETONS: unix-lines dotall multiline comments case-insensitive
+unicode-case reversed-regexp ;
SINGLETONS: letter-class LETTER-class Letter-class digit-class
alpha-class non-newline-blank-class
ascii-class punctuation-class java-printable-class blank-class
control-character-class hex-digit-class java-blank-class c-identifier-class
-unmatchable-class ;
+unmatchable-class terminator-class word-boundary-class ;
SINGLETONS: beginning-of-group end-of-group
beginning-of-character-class end-of-character-class
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
: <constant> ( obj -- constant )
dup Letter? get-case-insensitive and [
- [ ch>lower constant boa ]
- [ c
h>upper constant boa ] bi 2array <alternation>
+ [ ch>lower ] [ ch>upper ] bi
+ [ c
onstant boa ] bi@ 2array <alternation>
] [
constant boa
] if ;
[ drop1 (parse-special-group) ]
[ capture-group f nested-parse-regexp ] if ;
-: handle-dot ( -- ) any-char push-stack ;
+: handle-dot ( -- ) get-dotall any-char any-char-no-nl ? push-stack ;
: handle-pipe ( -- ) pipe push-stack ;
: (handle-star) ( obj -- kleene-star )
peek1 {
: handle-left-brace ( -- )
parse-repetition
- >r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r>
+ [ 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ ] dip
[
2dup and [ from-m-to-n ]
[ [ nip at-most-n ] [ at-least-n ] if* ] if
] [ drop 0 max exactly-n ] if ;
-SINGLETON: beginning-of-input
-SINGLETON: end-of-input
-
-: newlines ( -- obj1 obj2 obj3 )
- CHAR: \r <constant>
- CHAR: \n <constant>
- 2dup 2array <concatenation> ;
-
-: beginning-of-line ( -- obj )
- beginning-of-input newlines 4array <alternation> lookbehind boa ;
-
-: end-of-line ( -- obj )
- end-of-input newlines 4array <alternation> lookahead boa ;
-
: handle-front-anchor ( -- )
get-multiline beginning-of-line beginning-of-input ? push-stack ;
: parse-control-character ( -- n ) read1 ;
ERROR: bad-escaped-literals seq ;
-: parse-escaped-literals ( -- obj )
- "\\E" read-until [ bad-escaped-literals ] unless
+
+: parse-til-E ( -- obj )
+ "\\E" read-until [ bad-escaped-literals ] unless ;
+
+:: (parse-escaped-literals) ( quot: ( obj -- obj' ) -- obj )
+ parse-til-E
drop1
[ epsilon ] [
- [ <constant> ] V{ } map-as
+ [ quot call <constant> ] V{ } map-as
first|concatenation
- ] if-empty ;
+ ] if-empty ; inline
-ERROR: unrecognized-escape char ;
+: parse-escaped-literals ( -- obj )
+ [ ] (parse-escaped-literals) ;
+
+: lower-case-literals ( -- obj )
+ [ ch>lower ] (parse-escaped-literals) ;
+
+: upper-case-literals ( -- obj )
+ [ ch>upper ] (parse-escaped-literals) ;
: parse-escaped ( -- obj )
read1
{
- { CHAR: \ [ CHAR: \ <constant> ] }
- { CHAR: / [ CHAR: / <constant> ] }
- { CHAR: ^ [ CHAR: ^ <constant> ] }
- { CHAR: $ [ CHAR: $ <constant> ] }
- { CHAR: - [ CHAR: - <constant> ] }
- { CHAR: { [ CHAR: { <constant> ] }
- { CHAR: } [ CHAR: } <constant> ] }
- { CHAR: [ [ CHAR: [ <constant> ] }
- { CHAR: ] [ CHAR: ] <constant> ] }
- { CHAR: ( [ CHAR: ( <constant> ] }
- { CHAR: ) [ CHAR: ) <constant> ] }
- { CHAR: @ [ CHAR: @ <constant> ] }
- { CHAR: * [ CHAR: * <constant> ] }
- { CHAR: + [ CHAR: + <constant> ] }
- { CHAR: ? [ CHAR: ? <constant> ] }
- { CHAR: . [ CHAR: . <constant> ] }
- { CHAR: : [ CHAR: : <constant> ] }
{ CHAR: t [ CHAR: \t <constant> ] }
{ CHAR: n [ CHAR: \n <constant> ] }
{ CHAR: r [ CHAR: \r <constant> ] }
{ CHAR: a [ HEX: 7 <constant> ] }
{ CHAR: e [ HEX: 1b <constant> ] }
- { CHAR: d [ digit-class ] }
- { CHAR: D [ digit-class <negation> ] }
- { CHAR: s [ java-blank-class ] }
- { CHAR: S [ java-blank-class <negation> ] }
{ CHAR: w [ c-identifier-class ] }
{ CHAR: W [ c-identifier-class <negation> ] }
+ { CHAR: s [ java-blank-class ] }
+ { CHAR: S [ java-blank-class <negation> ] }
+ { CHAR: d [ digit-class ] }
+ { CHAR: D [ digit-class <negation> ] }
{ CHAR: p [ parse-posix-class ] }
{ CHAR: P [ parse-posix-class <negation> ] }
{ CHAR: 0 [ parse-octal <constant> ] }
{ CHAR: c [ parse-control-character ] }
- ! { CHAR: b [ handle-word-boundary ] }
- ! { CHAR: B [ handle-word-boundary <negation> ] }
+ { CHAR: Q [ parse-escaped-literals ] }
+
+ ! { CHAR: b [ word-boundary-class ] }
+ ! { CHAR: B [ word-boundary-class <negation> ] }
! { CHAR: A [ handle-beginning-of-input ] }
+ ! { CHAR: z [ handle-end-of-input ] }
+
+ ! { CHAR: Z [ handle-end-of-input ] } ! plus a final terminator
+
+ ! m//g mode
! { CHAR: G [ end of previous match ] }
- ! { CHAR: Z [ handle-end-of-input ] }
- ! { CHAR: z [ handle-end-of-input ] } ! except for terminator
+ ! Group capture
! { CHAR: 1 [ CHAR: 1 <constant> ] }
! { CHAR: 2 [ CHAR: 2 <constant> ] }
! { CHAR: 3 [ CHAR: 3 <constant> ] }
! { CHAR: 8 [ CHAR: 8 <constant> ] }
! { CHAR: 9 [ CHAR: 9 <constant> ] }
- { CHAR: Q [ parse-escaped-literals ] }
- [ unrecognized-escape ]
+ ! Perl extensions
+ ! can't do \l and \u because \u is already a 4-hex
+ { CHAR: L [ lower-case-literals ] }
+ { CHAR: U [ upper-case-literals ] }
+
+ [ <constant> ]
} case ;
: handle-escape ( -- ) parse-escaped push-stack ;
} case
[ (parse-character-class) ] when ;
+: push-constant ( ch -- ) <constant> push-stack ;
+
: parse-character-class-second ( -- )
read1 {
- { CHAR: [ [ CHAR: [ <constant> push-stack ] }
- { CHAR: ] [ CHAR: ] <constant> push-stack ] }
- { CHAR: - [ CHAR: - <constant> push-stack ] }
+ { CHAR: [ [ CHAR: [ push-constant ] }
+ { CHAR: ] [ CHAR: ] push-constant ] }
+ { CHAR: - [ CHAR: - push-constant ] }
[ push1 ]
} case ;
: parse-character-class-first ( -- )
read1 {
{ CHAR: ^ [ caret push-stack parse-character-class-second ] }
- { CHAR: [ [ CHAR: [ <constant> push-stack ] }
- { CHAR: ] [ CHAR: ] <constant> push-stack ] }
- { CHAR: - [ CHAR: - <constant> push-stack ] }
+ { CHAR: [ [ CHAR: [ push-constant ] }
+ { CHAR: ] [ CHAR: ] push-constant ] }
+ { CHAR: - [ CHAR: - push-constant ] }
[ push1 ]
} case ;
drop
handle-back-anchor f
] [
- <constant> push-stack t
+ push-constant t
] if
]
} case ;
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }
{ $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
-
-HELP: <iregexp>
-{ $values { "string" string } { "regexp" regexp } }
-{ $description "Compiles a case-insensitive regular expression into a DFA and returns this object. Otherwise, exactly the same as " { $link <regexp> } } ;
-
-{ <regexp> <iregexp> } related-words
USING: regexp tools.test kernel sequences regexp.parser
-regexp.traversal eval ;
+regexp.traversal eval strings ;
IN: regexp-tests
\ <regexp> must-infer
[ f ] [ "" "." <regexp> matches? ] unit-test
[ t ] [ "a" "." <regexp> matches? ] unit-test
[ t ] [ "." "." <regexp> matches? ] unit-test
-! [ f ] [ "\n" "." <regexp> matches? ] unit-test
+
+! Dotall mode -- when on, . matches newlines.
+! Off by default.
+[ f ] [ "\n" "." <regexp> matches? ] unit-test
+[ t ] [ "\n" "(?s)." <regexp> matches? ] unit-test
+[ t ] [ "\n" R/ ./s matches? ] unit-test
+[ f ] [ "\n\n" "(?s).(?-s)." <regexp> matches? ] unit-test
[ f ] [ "" ".+" <regexp> matches? ] unit-test
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
-!
[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
-[ t ] [ "aaa" "AAA" <iregexp> matches? ] unit-test
-[ f ] [ "aax" "AAA" <iregexp> matches? ] unit-test
-[ t ] [ "aaa" "A*" <iregexp> matches? ] unit-test
-[ f ] [ "aaba" "A*" <iregexp> matches? ] unit-test
-[ t ] [ "b" "[AB]" <iregexp> matches? ] unit-test
-[ f ] [ "c" "[AB]" <iregexp> matches? ] unit-test
-[ t ] [ "c" "[A-Z]" <iregexp> matches? ] unit-test
-[ f ] [ "3" "[A-Z]" <iregexp> matches? ] unit-test
+[ t ] [ "aaa" R/ AAA/i matches? ] unit-test
+[ f ] [ "aax" R/ AAA/i matches? ] unit-test
+[ t ] [ "aaa" R/ A*/i matches? ] unit-test
+[ f ] [ "aaba" R/ A*/i matches? ] unit-test
+[ t ] [ "b" R/ [AB]/i matches? ] unit-test
+[ f ] [ "c" R/ [AB]/i matches? ] unit-test
+[ t ] [ "c" R/ [A-Z]/i matches? ] unit-test
+[ f ] [ "3" R/ [A-Z]/i matches? ] unit-test
[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
-[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
-[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
-[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
+[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
+[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
+[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
+[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
[ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
-[ t ] [ "A" "[a-z]" <iregexp> matches? ] unit-test
+[ t ] [ "A" R/ [a-z]/i matches? ] unit-test
[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
-[ t ] [ "A" "\\p{Lower}" <iregexp> matches? ] unit-test
+[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
-[ t ] [ "abc" <reversed> "abc" <rregexp> matches? ] unit-test
-[ t ] [ "abc" <reversed> "a[bB][cC]" <rregexp> matches? ] unit-test
-[ t ] [ "adcbe" "a(?r)(bcd)(?-r)e" <rregexp> matches? ] unit-test
+[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
+[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
+[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/r matches? ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" <regexp> drop ] unit-test
-! Comment
+! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
+[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
-! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
+[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
-! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
-! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
-! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
-! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
-! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
-! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
+[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
+[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
+
+[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
+[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
+
+[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
+
+[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
+
+[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
-! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
-! [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+[ { "1" "2" "3" "4" } ]
+[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
+
+[ { "1" "2" "3" "4" } ]
+[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
+
+[ { "ABC" "DEF" "GHI" } ]
+[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
+
+[ 3 ]
+[ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
+
+[ 0 ]
+[ "123" R/ [A-Z]+/ count-matches ] unit-test
+
+[ "1.2.3.4" ]
+[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
+
+[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
+[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
+[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
+! Bug in parsing word
+[ t ] [ "a" R' a' matches? ] unit-test
+
+! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
+
+[ t ] [ "a" R/ ^a/ matches? ] unit-test
+[ f ] [ "\na" R/ ^a/ matches? ] unit-test
+[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
+[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
+
+[ t ] [ "a" R/ a$/ matches? ] unit-test
+[ f ] [ "a\n" R/ a$/ matches? ] unit-test
+[ f ] [ "a\r" R/ a$/ matches? ] unit-test
+[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
+
+! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
+! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
+! [ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
+! [ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
+
+! [ t ] [ "a" R/ \Aa/m matches? ] unit-test
+! [ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
+! [ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
+! [ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
+
+! [ t ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
+
+! [ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
+! [ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
+
+! [ t ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
+! [ t ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
+
+! [ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
+! [ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
+! [ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
+! [ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
+
+! [ t ] [ "a" R/ ^a/m matches? ] unit-test
+! [ t ] [ "\na" R/ ^a/m matches? ] unit-test
+! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
+! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
+
+! Convert to lowercase until E
+[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
+[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
+
+! Convert to uppercase until E
+[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
+[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
+
+! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
+! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
+! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test
+! [ t ] [ "a\r\n" "a$" R/ a$/m matches? ] unit-test
+
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
+! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
+! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
+! [ t ] [ "afoob" "\\bfoo\\b" <regexp> matches? ] unit-test
+! [ f ] [ "foo" "\\Bfoo\\B" <regexp> matches? ] unit-test
+
! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
-[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
-
-[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
-
-[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
-
-! Bug in parsing word
-! [ t ] [ "a" R' a' matches? ] unit-test
-
-! ((A)(B(C)))
-! 1. ((A)(B(C)))
-! 2. (A)
-! 3. (B(C))
-! 4. (C)
-
-! clear "a(?=b*)" <regexp> "ab" over match
-! clear "a(?=b*c)" <regexp> "abbbbbc" over match
-! clear "a(?=b*)" <regexp> "ab" over match
-
-! clear "^a" <regexp> "a" over match
-! clear "^a" <regexp> "\na" over match
-! clear "^a" <regexp> "\r\na" over match
-! clear "^a" <regexp> "\ra" over match
-
-! clear "a$" <regexp> "a" over match
-! clear "a$" <regexp> "a\n" over match
-! clear "a$" <regexp> "a\r" over match
-! clear "a$" <regexp> "a\r\n" over match
-
-! "(az)(?<=b)" <regexp> "baz" over first-match
-! "a(?<=b*)" <regexp> "cbaz" over first-match
-! "a(?<=b)" <regexp> "baz" over first-match
+! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
+! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
+! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
+! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
+! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
+! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
-! "a(?<!b)" <regexp> "baz" over first-match
-! "a(?<!b)" <regexp> "caz" over first-match
+! "ab" "a(?=b*)" <regexp> match
+! "abbbbbc" "a(?=b*c)" <regexp> match
+! "ab" "a(?=b*)" <regexp> match
-! "a(?=bcdefg)bcd" <regexp> "abcdefg" over first-match
-! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
-! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
+! "baz" "(az)(?<=b)" <regexp> first-match
+! "cbaz" "a(?<=b*)" <regexp> first-match
+! "baz" "a(?<=b)" <regexp> first-match
-[ { 0 1 } ] [ "ac" "a(?!b)" <regexp> first-match ] unit-test
-[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
+! "baz" "a(?<!b)" <regexp> first-match
+! "caz" "a(?<!b)" <regexp> first-match
-! "a(?<=b)" <regexp> "caba" over first-match
+! "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match
+! "abcdefg" "a(?#bcdefg)bcd" <regexp> first-match
+! "abcdefg" "a(?:bcdefg)" <regexp> first-match
-[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" <regexp> first-match ] unit-test
-[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match ] unit-test
-[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match ] unit-test
+! "caba" "a(?<=b)" <regexp> first-match
! capture group 1: "aaaa" 2: ""
! "aaaa" "(a*)(a*)" <regexp> match*
! "aaaa" "(a*)(a+)" <regexp> match*
-
-[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" <regexp> first-match ] unit-test
-[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" <regexp> first-match ] unit-test
-
-[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" <regexp> first-match ] unit-test
-[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
-
-[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-
-[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
-
-[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math math.ranges sequences
+USING: accessors combinators kernel math sequences strings
sets assocs prettyprint.backend make lexer namespaces parser
arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
-regexp.dfa regexp.traversal regexp.transition-tables ;
+regexp.dfa regexp.traversal regexp.transition-tables splitting
+sorting ;
IN: regexp
: default-regexp ( string -- regexp )
[ ]
} cleave ;
-: match ( string regexp -- pair )
- <dfa-traverser> do-match return-match ;
+: (match) ( string regexp -- dfa-traverser )
+ <dfa-traverser> do-match ; inline
-: match* ( string regexp -- pair captured-groups )
- <dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
+: match ( string regexp -- slice/f )
+ (match) return-match ;
+
+: match* ( string regexp -- slice/f captured-groups )
+ (match) [ return-match ] [ captured-groups>> ] bi ;
: matches? ( string regexp -- ? )
dupd match
- [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
+ [ [ length ] bi@ = ] [ drop f ] if* ;
-: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ;
+: match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
: match-at ( string m regexp -- n/f finished? )
[
[ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
] if ;
-: first-match ( string regexp -- pair/f )
- 0 swap match-range dup [ 2array ] [ 2drop f ] if ;
+: first-match ( string regexp -- slice/f )
+ dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
: re-cut ( string regexp -- end/f start )
dupd first-match
- [ [ second tail-slice ] [ first head ] 2bi ]
- [ "" like f swap ]
- if* ;
+ [ split1-slice swap ] [ "" like f swap ] if* ;
: re-split ( string regexp -- seq )
- [ dup ] swap '[ _ re-cut ] [ ] produce nip ;
+ [ dup length 0 > ] swap '[ _ re-cut ] [ ] produce nip ;
: re-replace ( string regexp replacement -- result )
[ re-split ] dip join ;
: next-match ( string regexp -- end/f match/f )
dupd first-match dup
- [ [ second tail-slice ] keep ]
- [ 2drop f f ]
- if ;
+ [ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
: all-matches ( string regexp -- seq )
- [ dup ] swap '[ _ next-match ] [ ] produce nip ;
+ [ dup ] swap '[ _ next-match ] [ ] produce nip harvest ;
: count-matches ( string regexp -- n )
- all-matches length 1- ;
+ all-matches length ;
-: initial-option ( regexp option -- regexp' )
- over options>> conjoin ;
+<PRIVATE
-: <regexp> ( string -- regexp )
- default-regexp construct-regexp ;
+: find-regexp-syntax ( string -- prefix suffix )
+ {
+ { "R/ " "/" }
+ { "R! " "!" }
+ { "R\" " "\"" }
+ { "R# " "#" }
+ { "R' " "'" }
+ { "R( " ")" }
+ { "R@ " "@" }
+ { "R[ " "]" }
+ { "R` " "`" }
+ { "R{ " "}" }
+ { "R| " "|" }
+ } swap [ subseq? not nip ] curry assoc-find drop ;
-: <iregexp> ( string -- regexp )
- default-regexp
- case-insensitive initial-option
- construct-regexp ;
+ERROR: unknown-regexp-option option ;
+
+: option>ch ( option -- string )
+ {
+ { case-insensitive [ CHAR: i ] }
+ { multiline [ CHAR: m ] }
+ { reversed-regexp [ CHAR: r ] }
+ { dotall [ CHAR: s ] }
+ [ unknown-regexp-option ]
+ } case ;
+
+: ch>option ( ch -- option )
+ {
+ { CHAR: i [ case-insensitive ] }
+ { CHAR: m [ multiline ] }
+ { CHAR: r [ reversed-regexp ] }
+ { CHAR: s [ dotall ] }
+ [ unknown-regexp-option ]
+ } case ;
+
+: string>options ( string -- options )
+ [ ch>option dup ] H{ } map>assoc ;
+
+: options>string ( options -- string )
+ keys [ option>ch ] map natural-sort >string ;
-: <rregexp> ( string -- regexp )
- default-regexp
- reversed-regexp initial-option
+PRIVATE>
+
+: <optioned-regexp> ( string option-string -- regexp )
+ [ default-regexp ] [ string>options ] bi* >>options
construct-regexp ;
+: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
+
+<PRIVATE
+
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
lexer get dup still-parsing-line?
[ (parse-token) ] [ drop f ] if
- "i" = [ <iregexp> ] [ <regexp> ] if parsed ;
+ <optioned-regexp> parsed ;
+
+PRIVATE>
: R! CHAR: ! parsing-regexp ; parsing
: R" CHAR: " parsing-regexp ; parsing
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
-: find-regexp-syntax ( string -- prefix suffix )
- {
- { "R/ " "/" }
- { "R! " "!" }
- { "R\" " "\"" }
- { "R# " "#" }
- { "R' " "'" }
- { "R( " ")" }
- { "R@ " "@" }
- { "R[ " "]" }
- { "R` " "`" }
- { "R{ " "}" }
- { "R| " "|" }
- } swap [ subseq? not nip ] curry assoc-find drop ;
-
-: option? ( option regexp -- ? )
- options>> key? ;
-
M: regexp pprint*
[
[
- dup raw>>
- dup find-regexp-syntax swap % swap % %
- case-insensitive swap option? [ "i" % ] when
+ [ raw>> dup find-regexp-syntax swap % swap % % ]
+ [ options>> options>string % ] bi
] "" make
] keep present-text ;
: <default-transition> ( from to -- transition )
t default-transition make-transition ;
-TUPLE: transition-table transitions start-state final-states ;
+TUPLE: transition-table transitions start-state final-states flags ;
: <transition-table> ( -- transition-table )
transition-table new
H{ } clone >>transitions
- H{ } clone >>final-states ;
+ H{ } clone >>final-states
+ H{ } clone >>flags ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
2dup [ to>> ] dip maybe-initialize-key
[ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
2dup at* [ 2nip insert-at ]
- [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
+ [ drop [ H{ } clone [ insert-at ] keep ] 2dip set-at ] if ;
: add-transition ( transition transition-table -- )
transitions>> set-transition ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators kernel math math.ranges
+USING: accessors assocs combinators kernel math
quotations sequences regexp.parser regexp.classes fry arrays
combinators.short-circuit regexp.utils prettyprint regexp.nfa
shuffle ;
capture-group-index
last-state current-state
text
+ match-failed?
start-index current-index
matches ;
H{ } clone >>captured-groups ;
: final-state? ( dfa-traverser -- ? )
- [ current-state>> ] [ dfa-table>> final-states>> ] bi
- key? ;
+ [ current-state>> ]
+ [ dfa-table>> final-states>> ] bi key? ;
+
+: beginning-of-text? ( dfa-traverser -- ? )
+ current-index>> 0 <= ; inline
+
+: end-of-text? ( dfa-traverser -- ? )
+ [ current-index>> ] [ text>> length ] bi >= ; inline
: text-finished? ( dfa-traverser -- ? )
{
[ current-state>> empty? ]
- [ [ current-index>> ] [ text>> length ] bi >= ]
- ! [ current-index>> 0 < ]
+ [ end-of-text? ]
+ [ match-failed?>> ]
} 1|| ;
: save-final-state ( dfa-straverser -- )
dup save-final-state
] when text-finished? ;
+: previous-text-character ( dfa-traverser -- ch )
+ [ text>> ] [ current-index>> 1- ] bi nth ;
+
+: current-text-character ( dfa-traverser -- ch )
+ [ text>> ] [ current-index>> ] bi nth ;
+
+: next-text-character ( dfa-traverser -- ch )
+ [ text>> ] [ current-index>> 1+ ] bi nth ;
+
GENERIC: flag-action ( dfa-traverser flag -- )
+
+M: beginning-of-input flag-action ( dfa-traverser flag -- )
+ drop
+ dup beginning-of-text? [ t >>match-failed? ] unless drop ;
+
+M: end-of-input flag-action ( dfa-traverser flag -- )
+ drop
+ dup end-of-text? [ t >>match-failed? ] unless drop ;
+
+
+M: beginning-of-line flag-action ( dfa-traverser flag -- )
+ drop
+ dup {
+ [ beginning-of-text? ]
+ [ previous-text-character terminator-class class-member? ]
+ } 1|| [ t >>match-failed? ] unless drop ;
+
+M: end-of-line flag-action ( dfa-traverser flag -- )
+ drop
+ dup {
+ [ end-of-text? ]
+ [ next-text-character terminator-class class-member? ]
+ } 1|| [ t >>match-failed? ] unless drop ;
+
+
+M: word-boundary flag-action ( dfa-traverser flag -- )
+ drop
+ dup {
+ [ end-of-text? ]
+ [ current-text-character terminator-class class-member? ]
+ } 1|| [ t >>match-failed? ] unless drop ;
+
+
M: lookahead-on flag-action ( dfa-traverser flag -- )
drop
lookahead-counters>> 0 swap push ;
[ [ 1+ ] change-current-index ]
[ [ 1- ] change-current-index ] if
dup current-state>> >>last-state
- ] dip
- first >>current-state ;
-
-: match-failed ( dfa-traverser -- dfa-traverser )
- V{ } clone >>matches ;
+ ] [ first ] bi* >>current-state ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> at at ;
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
: setup-match ( match -- obj state dfa-table )
- {
- [ current-index>> ] [ text>> ]
- [ current-state>> ] [ dfa-table>> ]
- } cleave
- [ nth ] 2dip ;
+ [ [ current-index>> ] [ text>> ] bi nth ]
+ [ current-state>> ]
+ [ dfa-table>> ] tri ;
: do-match ( dfa-traverser -- dfa-traverser )
dup process-flags
[ increment-state do-match ] when*
] unless ;
-: return-match ( dfa-traverser -- interval/f )
+: return-match ( dfa-traverser -- slice/f )
dup matches>>
[ drop f ]
- [ [ start-index>> ] [ peek ] bi* 1 <range> ] if-empty ;
+ [
+ [ [ text>> ] [ start-index>> ] bi ]
+ [ peek ] bi* rot <slice>
+ ] if-empty ;
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup kernel sequences ;
IN: sequences.deep
HELP: deep-each
-{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } }
-{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ;
+{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } }
+{ $description "Execute a quotation on each nested element of an object and its children, in preorder." }
+{ $see-also each } ;
HELP: deep-map
-{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } }
-{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ;
+{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "newobj" "the mapped object" } }
+{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." }
+{ $see-also map } ;
HELP: deep-filter
-{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } }
-{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ;
+{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a sequence" } }
+{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." }
+{ $see-also filter } ;
HELP: deep-find
-{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "elt" "an element" } }
-{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } ;
+{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "elt" "an element" } }
+{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." }
+{ $see-also find } ;
HELP: deep-contains?
-{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "?" "a boolean" } }
-{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ;
+{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
+{ $description "Tests whether the given object or any subnode satisfies the given quotation." }
+{ $see-also contains? } ;
HELP: flatten
-{ $values { "obj" "an object" } { "seq" "a sequence" } }
+{ $values { "obj" object } { "seq" "a sequence" } }
{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
HELP: deep-change-each
-{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } }
-{ $description "Modifies each sub-node of an object in place, in preorder." } ;
+{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
+{ $description "Modifies each sub-node of an object in place, in preorder." }
+{ $see-also change-each } ;
+
+ARTICLE: "sequences.deep" "Deep sequence combinators"
+"The combinators in the " { $vocab-link "sequences.deep" } " vocabulary are variants of standard sequence combinators which traverse nested subsequences."
+{ $subsection deep-each }
+{ $subsection deep-map }
+{ $subsection deep-filter }
+{ $subsection deep-find }
+{ $subsection deep-contains? }
+{ $subsection deep-change-each }
+"A utility word to collapse nested subsequences:"
+{ $subsection flatten } ;
+
+ABOUT: "sequences.deep"
[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
-[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find-from ] unit-test
+[ "foo" t ] [ { { "foo" } "bar" } [ string? ] (deep-find) ] unit-test
-[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find-from ] unit-test
+[ f f ] [ { { "foo" } "bar" } [ number? ] (deep-find) ] unit-test
-[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find-from ] unit-test
+[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] (deep-find) ] unit-test
: change-something ( seq -- newseq )
dup array? [ "hi" suffix ] [ "hello" append ] if ;
[ [ deep-map ] curry map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
- over >r
- pusher >r deep-each r>
- r> dup branch? [ like ] [ drop ] if ; inline recursive
+ over [ pusher [ deep-each ] dip ] dip
+ dup branch? [ like ] [ drop ] if ; inline recursive
-: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
+: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
- f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
+ f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean
] [ 2drop f f ] if
] if ; inline recursive
-: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
+: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
-: deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline
+: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
- over branch? [ [
- [ call ] keep over >r deep-change-each r>
- ] curry change-each ] [ 2drop ] if ; inline recursive
+ over branch? [
+ [ [ call ] keep over [ deep-change-each ] dip ] curry change-each
+ ] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;
"<" %
64 random-bits #
"-" %
- millis #
+ micros #
"@" %
smtp-domain get [ host-name ] unless* %
">" %
: extract-email ( recepient -- email )
! This could be much smarter.
- " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
+ " " split1-last swap or "<" ?head drop ">" ?tail drop ;
: email>headers ( email -- hashtable )
[
M: object infer-call*
\ literal-expected inference-warning ;
+: infer-slip ( -- )
+ 1 infer->r pop-d infer-call 1 infer-r> ;
+
+: infer-2slip ( -- )
+ 2 infer->r pop-d infer-call 2 infer-r> ;
+
+: infer-3slip ( -- )
+ 3 infer->r pop-d infer-call 3 infer-r> ;
+
: infer-curry ( -- )
2 consume-d
dup first2 <curried> make-known
{ \ declare [ infer-declare ] }
{ \ call [ pop-d infer-call ] }
{ \ (call) [ pop-d infer-call ] }
+ { \ slip [ infer-slip ] }
+ { \ 2slip [ infer-2slip ] }
+ { \ 3slip [ infer-3slip ] }
{ \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
(( value -- )) apply-word/effect ;
{
- >r r> declare call (call) curry compose execute (execute) if
-dispatch <tuple-boa> (throw) load-locals get-local drop-locals
-do-primitive alien-invoke alien-indirect alien-callback
+ >r r> declare call (call) slip 2slip 3slip curry compose
+ execute (execute) if dispatch <tuple-boa> (throw)
+ load-locals get-local drop-locals do-primitive alien-invoke
+ alien-indirect alien-callback
} [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
\ code-room { } { integer integer integer integer } define-primitive
\ code-room make-flushable
-\ millis { } { integer } define-primitive
-\ millis make-flushable
+\ micros { } { integer } define-primitive
+\ micros make-flushable
\ tag { object } { fixnum } define-primitive
\ tag make-foldable
\ modify-code-heap { array object } { } define-primitive
\ unimplemented { } { } define-primitive
+
+\ gc-reset { } { } define-primitive
+
+\ gc-stats { } { array } define-primitive
+
+\ jit-compile { quotation } { } define-primitive
: forget-effects ( -- )
forget-errors
- all-words [ f "inferred-effect" set-word-prop ] each ;
+ all-words [
+ dup subwords [ f "inferred-effect" set-word-prop ] each
+ f "inferred-effect" set-word-prop
+ ] each ;
\ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
- [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
-] 2 define-transform
+ [
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ [ inlined-dependency depends-on ] bi@
+ ] [ next-method-quot ] bi
+] 1 define-transform
! Constructors
\ boa [
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel state-tables tools.test ;
-IN: state-tables.tests
-
-: test-table
- <table>
- "a" "c" "z" <entry> over set-entry
- "a" "o" "y" <entry> over set-entry
- "a" "l" "x" <entry> over set-entry
- "b" "o" "y" <entry> over set-entry
- "b" "l" "x" <entry> over set-entry
- "b" "s" "u" <entry> over set-entry ;
-
-[
- T{
- table
- f
- H{
- { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
- { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
- }
- H{ { "l" t } { "s" t } { "c" t } { "o" t } }
- f
- H{ }
- }
-] [ test-table ] unit-test
-
-[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
-[ "har" t ] [
- "a" "z" "har" <entry> test-table [ set-entry ] keep
- >r "a" "z" r> get-entry
-] unit-test
-
-: vector-test-table
- <vector-table>
- "a" "c" "z" <entry> over add-entry
- "a" "c" "r" <entry> over add-entry
- "a" "o" "y" <entry> over add-entry
- "a" "l" "x" <entry> over add-entry
- "b" "o" "y" <entry> over add-entry
- "b" "l" "x" <entry> over add-entry
- "b" "s" "u" <entry> over add-entry ;
-
-[
-T{ vector-table f
- H{
- { "a"
- H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
- { "b"
- H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
- }
- H{ { "l" t } { "s" t } { "c" t } { "o" t } }
- f
- H{ }
-}
-] [ vector-test-table ] unit-test
-
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences vectors assocs accessors ;
-IN: state-tables
-
-TUPLE: table rows columns start-state final-states ;
-TUPLE: entry row-key column-key value ;
-
-GENERIC: add-entry ( entry table -- )
-
-: make-table ( class -- obj )
- new
- H{ } clone >>rows
- H{ } clone >>columns
- H{ } clone >>final-states ;
-
-: <table> ( -- obj )
- table make-table ;
-
-C: <entry> entry
-
-: (add-row) ( row-key table -- row )
- 2dup rows>> at* [
- 2nip
- ] [
- drop H{ } clone [ -rot rows>> set-at ] keep
- ] if ;
-
-: add-row ( row-key table -- )
- (add-row) drop ;
-
-: add-column ( column-key table -- )
- t -rot columns>> set-at ;
-
-: set-row ( row row-key table -- )
- rows>> set-at ;
-
-: lookup-row ( row-key table -- row/f ? )
- rows>> at* ;
-
-: row-exists? ( row-key table -- ? )
- lookup-row nip ;
-
-: lookup-column ( column-key table -- column/f ? )
- columns>> at* ;
-
-: column-exists? ( column-key table -- ? )
- lookup-column nip ;
-
-ERROR: no-row key ;
-ERROR: no-column key ;
-
-: get-row ( row-key table -- row )
- dupd lookup-row [
- nip
- ] [
- drop no-row
- ] if ;
-
-: get-column ( column-key table -- column )
- dupd lookup-column [
- nip
- ] [
- drop no-column
- ] if ;
-
-: get-entry ( row-key column-key table -- obj ? )
- swapd lookup-row [
- at*
- ] [
- 2drop f f
- ] if ;
-
-: (set-entry) ( entry table -- value column-key row )
- [ >r column-key>> r> add-column ] 2keep
- dupd >r row-key>> r> (add-row)
- >r [ value>> ] keep column-key>> r> ;
-
-: set-entry ( entry table -- )
- (set-entry) set-at ;
-
-: delete-entry ( entry table -- )
- >r [ column-key>> ] [ row-key>> ] bi r>
- lookup-row [ delete-at ] [ 2drop ] if ;
-
-: swap-rows ( row-key1 row-key2 table -- )
- [ tuck get-row >r get-row r> ] 3keep
- >r >r rot r> r> [ set-row ] keep set-row ;
-
-: member?* ( obj obj -- bool )
- 2dup = [ 2drop t ] [ member? ] if ;
-
-: find-by-column ( column-key data table -- seq )
- swapd 2dup lookup-column 2drop
- [
- rows>> [
- pick swap at* [
- >r pick r> member?* [ , ] [ drop ] if
- ] [
- 2drop
- ] if
- ] assoc-each
- ] { } make 2nip ;
-
-
-TUPLE: vector-table < table ;
-: <vector-table> ( -- obj )
- vector-table make-table ;
-
-: add-hash-vector ( value key hash -- )
- 2dup at* [
- dup vector? [
- 2nip push
- ] [
- V{ } clone [ push ] keep
- -rot >r >r [ push ] keep r> r> set-at
- ] if
- ] [
- drop set-at
- ] if ;
-
-M: vector-table add-entry ( entry table -- )
- (set-entry) add-hash-vector ;
{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
HELP: sleep-time
-{ $values { "ms/f" "a non-negative integer or " { $link f } } }
+{ $values { "us/f" "a non-negative integer or " { $link f } } }
{ $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ;
HELP: stop
f >>state
check-registered 2array run-queue push-front ;
-: sleep-time ( -- ms/f )
+: sleep-time ( -- us/f )
{
{ [ run-queue deque-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
- [ sleep-queue heap-peek nip millis [-] ]
+ [ sleep-queue heap-peek nip micros [-] ]
} cond ;
DEFER: stop
: expire-sleep? ( heap -- ? )
dup heap-empty?
- [ drop f ] [ heap-peek nip millis <= ] if ;
+ [ drop f ] [ heap-peek nip micros <= ] if ;
: expire-sleep ( thread -- )
f >>sleep-entry resume ;
GENERIC: sleep ( dt -- )
M: real sleep
- millis + >integer sleep-until ;
+ micros + >integer sleep-until ;
: interrupt ( thread -- )
dup state>> [
: staging-command-line ( profile -- flags )
[
+ "-staging" ,
+
dup empty? [
"-i=" my-boot-image-name append ,
] [
"tools.deploy.test.6" shake-and-bake\r
run-temp-image\r
] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.7" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
--- /dev/null
+USING: words ;
+IN: generic
+
+: next-method-quot ( method -- quot ) "next-method-quot" word-prop ;
tools.deploy.config vocabs sequences words words.private memory
kernel.private continuations io prettyprint vocabs.loader
debugger system strings sets vectors quotations byte-arrays
-sorting compiler.units definitions ;
+sorting compiler.units definitions generic generic.standard ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: layouts
-QUALIFIED: listener
QUALIFIED: prettyprint.config
QUALIFIED: source-files
QUALIFIED: vocabs
: stripped-word-props ( -- seq )
[
- strip-dictionary? deploy-compiler? get and [
- {
- "combination"
- "members"
- "methods"
- } %
- ] when
-
strip-dictionary? [
{
"alias"
"boa-check"
"cannot-infer"
"coercer"
+ "combination"
"compiled-effect"
"compiled-generic-uses"
"compiled-uses"
"local-writer?"
"local?"
"macro"
+ "members"
"memo-quot"
+ "methods"
"mixin"
"method-class"
"method-generic"
: stripped-globals ( -- seq )
[
- "callbacks" "alien.compiler" lookup ,
-
"inspector-hook" "inspector" lookup ,
{
- bootstrap.stage2:bootstrap-time
continuations:error
continuations:error-continuation
continuations:error-thread
continuations:restarts
- listener:error-hook
init:init-hooks
source-files:source-files
input-stream
"tools"
"io.launcher"
"random"
+ "compiler"
+ "stack-checker"
+ "bootstrap"
+ "listener"
} strip-vocab-globals %
strip-dictionary? [
{
gensym
name>char-hook
+ classes:next-method-quot-cache
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
- "<value>" "stack-checker.state" lookup [ , ] when*
-
"windows-messages" "windows.messages" lookup [ , ] when*
-
] { } make ;
: strip-globals ( stripped-globals -- )
] with-compilation-unit
] unless ;
-: compress ( pred string -- )
+: compress ( pred post-process string -- )
"Compressing " prepend show
- instances
- dup H{ } clone [ [ ] cache ] curry map
+ [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
: compress-byte-arrays ( -- )
- [ byte-array? ] "byte arrays" compress ;
+ [ byte-array? ] [ ] "byte arrays" compress ;
+
+: remain-compiled ( old new -- old new )
+ #! Quotations which were formerly compiled must remain
+ #! compiled.
+ 2dup [
+ 2dup [ compiled>> ] [ compiled>> not ] bi* and
+ [ nip jit-compile ] [ 2drop ] if
+ ] 2each ;
: compress-quotations ( -- )
- [ quotation? ] "quotations" compress ;
+ [ quotation? ] [ remain-compiled ] "quotations" compress ;
: compress-strings ( -- )
- [ string? ] "strings" compress ;
+ [ string? ] [ ] "strings" compress ;
: finish-deploy ( final-image -- )
"Finishing up" show
t "quiet" set-global
f output-stream set-global ;
+: compute-next-methods ( -- )
+ [ standard-generic? ] instances [
+ "methods" word-prop [
+ nip
+ dup next-method-quot "next-method-quot" set-word-prop
+ ] assoc-each
+ ] each
+ "resource:basis/tools/deploy/shaker/next-methods.factor" run-file ;
+
: strip ( -- )
init-stripper
strip-libc
strip-cocoa
strip-debugger
+ compute-next-methods
strip-init-hooks
strip-c-io
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
r> strip-words
compress-byte-arrays
compress-quotations
- compress-strings
- H{ } clone classes:next-method-quot-cache set-global ;
+ compress-strings ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
USING: compiler.units words vocabs kernel threads.private ;
IN: debugger
-: print-error ( error -- ) die drop ;
+: consume ( error -- )
+ #! We don't want DCE to drop the error before the die call!
+ drop ;
-: error. ( error -- ) die drop ;
+: print-error ( error -- ) die consume ;
+
+: error. ( error -- ) die consume ;
"threads" vocab [
[
IN: tools.deploy.test.1\r
USING: threads ;\r
\r
-: deploy-test-1 ( -- ) 1000 sleep ;\r
+: deploy-test-1 ( -- ) 1000000 sleep ;\r
\r
MAIN: deploy-test-1\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces ;
+IN: tools.deploy.test.7
+
+SYMBOL: my-var
+
+GENERIC: my-generic ( x -- b )
+
+M: integer my-generic sq ;
+
+M: fixnum my-generic call-next-method my-var get call ;
+
+: test-7 ( -- )
+ [ 1 + ] my-var set-global
+ 12 my-generic 145 assert= ;
+
+MAIN: test-7
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-threads? t }
+ { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-io 2 }
+ { deploy-math? t }
+ { "stop-after-last-window?" t }
+ { deploy-compiler? t }
+ { deploy-unicode? f }
+ { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-name "tools.deploy.test.7" }
+}
[ ] [ [ 10 [ gc ] times ] profile ] unit-test
-[ ] [ [ 1000 sleep ] profile ] unit-test
+[ ] [ [ 1000000 sleep ] profile ] unit-test
[ ] [ profile. ] unit-test
[ drop t ] must-fail-with ;
: (run-test) ( vocab -- )
- dup vocab-source-loaded? [
+ dup vocab source-loaded?>> [
vocab-tests [ run-file ] each
] [ drop ] if ;
] with-cell\r
[\r
sleep-entry>> [\r
- key>> millis [-] number>string write\r
- " ms" write\r
+ key>> micros [-] number>string write\r
+ " us" write\r
] when*\r
] with-cell ;\r
\r
"A lower-level word puts timings on the stack, intead of printing:"
{ $subsection benchmark }
"You can also read the system clock and garbage collection statistics directly:"
-{ $subsection millis }
+{ $subsection micros }
{ $subsection gc-stats }
{ $see-also "profiling" } ;
HELP: benchmark
{ $values { "quot" "a quotation" }
- { "runtime" "an integer denoting milliseconds" } }
+ { "runtime" "the runtime in microseconds" } }
{ $description "Runs a quotation, measuring the total wall clock time." }
{ $notes "A nicer word for interactive use is " { $link time } "." } ;
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
-{ benchmark millis time } related-words
+{ benchmark micros time } related-words
IN: tools.time
: benchmark ( quot -- runtime )
- millis >r call millis r> - ; inline
+ micros >r call micros r> - ; inline
: time. ( data -- )
unclip
- "==== RUNNING TIME" print nl pprint " ms" print nl
+ "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl
4 cut*
"==== GARBAGE COLLECTION" print nl
[
6 group
{
"GC count:"
- "Cumulative GC time (ms):"
- "Longest GC pause (ms):"
- "Average GC pause (ms):"
+ "Cumulative GC time (us):"
+ "Longest GC pause (us):"
+ "Average GC pause (us):"
"Objects copied:"
"Bytes copied:"
} prefix
[
nl
{
- "Total GC time (ms):"
+ "Total GC time (us):"
"Cards scanned:"
"Decks scanned:"
"Code heap literal scans:"
] bi* ;
: time ( quot -- )
- gc-reset millis >r call gc-stats millis r> - prefix time. ; inline
+ gc-reset micros >r call gc-stats micros r> - prefix time. ; inline
Slava Pestov
+Eduardo Cavazos
USING: help.markup help.syntax io strings ;
IN: tools.vocabs.browser
+ARTICLE: "vocab-tags" "Vocabulary tags"
+{ $all-tags } ;
+
+ARTICLE: "vocab-authors" "Vocabulary authors"
+{ $all-authors } ;
+
ARTICLE: "vocab-index" "Vocabulary index"
-{ $tags }
-{ $authors }
+{ $subsection "vocab-tags" }
+{ $subsection "vocab-authors" }
{ $describe-vocab "" } ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators vocabs vocabs.loader
-tools.vocabs io io.files io.styles help.markup help.stylesheet
-sequences assocs help.topics namespaces prettyprint words
-sorting definitions arrays summary sets generic ;
+USING: accessors arrays assocs classes classes.builtin
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple classes.union combinators
+definitions effects fry generic help help.markup
+help.stylesheet help.topics io io.files io.styles kernel macros
+make namespaces prettyprint sequences sets sorting summary
+tools.vocabs vocabs vocabs.loader words ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
: vocab. ( vocab -- )
[
- dup [ write-status ] with-cell
- dup [ ($link) ] with-cell
- [ vocab-summary write ] with-cell
+ [ [ write-status ] with-cell ]
+ [ [ ($link) ] with-cell ]
+ [ [ vocab-summary write ] with-cell ] tri
] with-row ;
: vocab-headings. ( -- )
[ "Children from " prepend ] [ "Children" ] if*
$heading ;
-: vocabs. ( assoc -- )
+: $vocabs ( assoc -- )
[
- [
- drop
- ] [
- swap root-heading.
- standard-table-style [
- vocab-headings. [ vocab. ] each
- ] ($grid)
+ [ drop ] [
+ [ root-heading. ]
+ [
+ standard-table-style [
+ vocab-headings. [ vocab. ] each
+ ] ($grid)
+ ] bi*
] if-empty
] assoc-each ;
-: describe-summary ( vocab -- )
- vocab-summary [
- "Summary" $heading print-element
- ] when* ;
-
TUPLE: vocab-tag name ;
INSTANCE: vocab-tag topic
C: <vocab-tag> vocab-tag
-: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
-
-: describe-tags ( vocab -- )
- vocab-tags f like [
- "Tags" $heading tags.
- ] when* ;
+: $tags ( seq -- ) [ <vocab-tag> ] map $links ;
TUPLE: vocab-author name ;
C: <vocab-author> vocab-author
-: authors. ( seq -- ) [ <vocab-author> ] map $links ;
-
-: describe-authors ( vocab -- )
- vocab-authors f like [
- "Authors" $heading authors.
- ] when* ;
+: $authors ( seq -- ) [ <vocab-author> ] map $links ;
: describe-help ( vocab -- )
- vocab-help [
- "Documentation" $heading ($link)
- ] when* ;
+ [
+ dup vocab-help
+ [ "Documentation" $heading ($link) ]
+ [ "Summary" $heading vocab-summary print-element ]
+ ?if
+ ] unless-empty ;
: describe-children ( vocab -- )
- vocab-name all-child-vocabs vocabs. ;
+ vocab-name all-child-vocabs $vocabs ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
] with-nesting
] with-style
] ($block)
- ] when* ;
+ ] unless-empty ;
-: describe-words ( vocab -- )
- words [
- "Words" $heading
- natural-sort $links
+: describe-tuple-classes ( classes -- )
+ [
+ "Tuple classes" $subheading
+ [
+ [ <$link> ]
+ [ superclass <$link> ]
+ [ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
+ tri 3array
+ ] map
+ { { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
+ $table
+ ] unless-empty ;
+
+: describe-predicate-classes ( classes -- )
+ [
+ "Predicate classes" $subheading
+ [
+ [ <$link> ]
+ [ superclass <$link> ]
+ bi 2array
+ ] map
+ { { $strong "Class" } { $strong "Superclass" } } prefix
+ $table
+ ] unless-empty ;
+
+: (describe-classes) ( classes heading -- )
+ '[
+ _ $subheading
+ [ <$link> 1array ] map $table
+ ] unless-empty ;
+
+: describe-builtin-classes ( classes -- )
+ "Builtin classes" (describe-classes) ;
+
+: describe-singleton-classes ( classes -- )
+ "Singleton classes" (describe-classes) ;
+
+: describe-mixin-classes ( classes -- )
+ "Mixin classes" (describe-classes) ;
+
+: describe-union-classes ( classes -- )
+ "Union classes" (describe-classes) ;
+
+: describe-intersection-classes ( classes -- )
+ "Intersection classes" (describe-classes) ;
+
+: describe-classes ( classes -- )
+ [ builtin-class? ] partition
+ [ tuple-class? ] partition
+ [ singleton-class? ] partition
+ [ predicate-class? ] partition
+ [ mixin-class? ] partition
+ [ union-class? ] partition
+ [ intersection-class? ] filter
+ {
+ [ describe-builtin-classes ]
+ [ describe-tuple-classes ]
+ [ describe-singleton-classes ]
+ [ describe-predicate-classes ]
+ [ describe-mixin-classes ]
+ [ describe-union-classes ]
+ [ describe-intersection-classes ]
+ } spread ;
+
+: word-syntax ( word -- string/f )
+ \ $syntax swap word-help elements dup length 1 =
+ [ first second ] [ drop f ] if ;
+
+: describe-parsing ( words -- )
+ [
+ "Parsing words" $subheading
+ [
+ [ <$link> ]
+ [ word-syntax dup [ \ $snippet swap 2array ] when ]
+ bi 2array
+ ] map
+ { { $strong "Word" } { $strong "Syntax" } } prefix
+ $table
] unless-empty ;
-: vocab-xref ( vocab quot -- vocabs )
- >r dup vocab-name swap words [ generic? not ] filter r> map
- [ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
- remove sift ; inline
+: (describe-words) ( words heading -- )
+ '[
+ _ $subheading
+ [
+ [ <$link> ]
+ [ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
+ bi 2array
+ ] map
+ { { $strong "Word" } { $strong "Stack effect" } } prefix
+ $table
+ ] unless-empty ;
+
+: describe-generics ( words -- )
+ "Generic words" (describe-words) ;
+
+: describe-macros ( words -- )
+ "Macro words" (describe-words) ;
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
+: describe-primitives ( words -- )
+ "Primitives" (describe-words) ;
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
+: describe-compounds ( words -- )
+ "Ordinary words" (describe-words) ;
-: describe-uses ( vocab -- )
- vocab-uses [
- "Uses" $heading
- $vocab-links
+: describe-predicates ( words -- )
+ "Class predicate words" (describe-words) ;
+
+: describe-symbols ( words -- )
+ [
+ "Symbol words" $subheading
+ [ <$link> 1array ] map $table
] unless-empty ;
-: describe-usage ( vocab -- )
- vocab-usage [
- "Used by" $heading
- $vocab-links
+: describe-words ( vocab -- )
+ words [
+ "Words" $heading
+
+ natural-sort
+ [ [ class? ] filter describe-classes ]
+ [
+ [ [ class? ] [ symbol? ] bi and not ] filter
+ [ parsing-word? ] partition
+ [ generic? ] partition
+ [ macro? ] partition
+ [ symbol? ] partition
+ [ primitive? ] partition
+ [ predicate? ] partition swap
+ {
+ [ describe-parsing ]
+ [ describe-generics ]
+ [ describe-macros ]
+ [ describe-symbols ]
+ [ describe-primitives ]
+ [ describe-compounds ]
+ [ describe-predicates ]
+ } spread
+ ] bi
] unless-empty ;
+: words. ( vocab -- )
+ last-element off
+ vocab-name describe-words ;
+
+: describe-metadata ( vocab -- )
+ [
+ [ vocab-tags [ "Tags:" swap \ $tags prefix 2array , ] unless-empty ]
+ [ vocab-authors [ "Authors:" swap \ $authors prefix 2array , ] unless-empty ]
+ bi
+ ] { } make
+ [ "Meta-data" $heading $table ] unless-empty ;
+
: $describe-vocab ( element -- )
- first
- dup describe-children
- dup find-vocab-root [
- dup describe-summary
- dup describe-tags
- dup describe-authors
- dup describe-files
- ] when
- dup vocab [
- dup describe-help
- dup describe-words
- dup describe-uses
- dup describe-usage
- ] when drop ;
+ first {
+ [ describe-help ]
+ [ describe-metadata ]
+ [ describe-words ]
+ [ describe-files ]
+ [ describe-children ]
+ } cleave ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
- first tagged vocabs. ;
+ first tagged $vocabs ;
: $authored-vocabs ( element -- )
- first authored vocabs. ;
+ first authored $vocabs ;
-: $tags ( element -- )
- drop "Tags" $heading all-tags tags. ;
+: $all-tags ( element -- )
+ drop "Tags" $heading all-tags $tags ;
-: $authors ( element -- )
- drop "Authors" $heading all-authors authors. ;
+: $all-authors ( element -- )
+ drop "Authors" $heading all-authors $authors ;
INSTANCE: vocab topic
vocabs.loader vocabs sequences namespaces make math.parser\r
arrays hashtables assocs memoize summary sorting splitting\r
combinators source-files debugger continuations compiler.errors\r
-init checksums checksums.crc32 sets accessors ;\r
+init checksums checksums.crc32 sets accessors generic\r
+definitions words ;\r
IN: tools.vocabs\r
\r
+: vocab-xref ( vocab quot -- vocabs )\r
+ [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map\r
+ [\r
+ [ [ word? ] [ generic? not ] bi and ] filter [\r
+ dup method-body?\r
+ [ "method-generic" word-prop ] when\r
+ vocabulary>>\r
+ ] map\r
+ ] gather natural-sort remove sift ; inline\r
+\r
+: vocabs. ( seq -- )\r
+ [ dup >vocab-link write-object nl ] each ;\r
+\r
+: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;\r
+\r
+: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;\r
+\r
+: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;\r
+\r
+: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;\r
+\r
: vocab-tests-file ( vocab -- path )\r
dup "-tests.factor" vocab-dir+ vocab-append-path dup\r
[ dup exists? [ drop f ] unless ] [ drop f ] if ;\r
[\r
[\r
[ modified-sources ]\r
- [ vocab-source-loaded? ]\r
+ [ vocab source-loaded?>> ]\r
[ vocab-source-path ]\r
tri (to-refresh)\r
] [\r
[ modified-docs ]\r
- [ vocab-docs-loaded? ]\r
+ [ vocab docs-loaded?>> ]\r
[ vocab-docs-path ]\r
tri (to-refresh)\r
] bi\r
: do-refresh ( modified-sources modified-docs unchanged -- )\r
unchanged-vocabs\r
[\r
- [ [ f swap set-vocab-source-loaded? ] each ]\r
- [ [ f swap set-vocab-docs-loaded? ] each ] bi*\r
+ [ [ vocab f >>source-loaded? drop ] each ]\r
+ [ [ vocab f >>docs-loaded? drop ] each ] bi*\r
]\r
[\r
append prune\r
] unit-test
[ { "Yo" 2 } ] [
- [ 2 >r "Yo" r> ] test-walker
+ [ 2 [ "Yo" ] dip ] test-walker
+] unit-test
+
+[ { "Yo" 2 3 } ] [
+ [ 2 [ "Yo" ] dip 3 ] test-walker
] unit-test
[ { 2 } ] [
: (step-into-quot) ( quot -- ) add-breakpoint call ;
+: (step-into-dip) ( quot -- ) add-breakpoint dip ;
+
+: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
+
+: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
+
: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
-: (step-into-call-next-method) ( class generic -- )
+: (step-into-call-next-method) ( method -- )
next-method-quot (step-into-quot) ;
! Messages sent to walker thread
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- >r clone r> [
- >r clone r>
+ [ clone ] dip [
+ [ clone ] dip
[
- >r
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi
- r> call
+ [
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi
+ ] dip call
]
[ drop set-innermost-frame-quot ]
[ drop ]
2tri
] curry change-call ; inline
-: step-msg ( continuation -- continuation' )
+: step-msg ( continuation -- continuation' ) USE: io
[
- 2dup nth \ break = [
- nip
- ] [
- swap 1+ cut [ break ] swap 3append
+ 2dup length = [ nip [ break ] append ] [
+ 2dup nth \ break = [ nip ] [
+ swap 1+ cut [ break ] swap 3append
+ ] if
] if
] change-frame ;
{
{ call [ (step-into-quot) ] }
+ { dip [ (step-into-dip) ] }
+ { 2dip [ (step-into-2dip) ] }
+ { 3dip [ (step-into-3dip) ] }
{ (throw) [ drop (step-into-quot) ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
: step-into-msg ( continuation -- continuation' )
[
swap cut [
- swap % unclip {
- { [ dup \ break eq? ] [ , ] }
- { [ dup quotation? ] [ add-breakpoint , \ break , ] }
- { [ dup array? ] [ add-breakpoint , \ break , ] }
- { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- [ , \ break , ]
- } cond %
+ swap %
+ [ \ break , ] [
+ unclip {
+ { [ dup \ break eq? ] [ , ] }
+ { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
+ { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+ [ , \ break , ]
+ } cond %
+ ] if-empty
] [ ] make
] change-frame ;
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
- [
- [ NSApp [ do-event ] curry loop ui-wait ] ui-try
- ] with-autorelease-pool ;
+ [ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;
{
{ S+ HEX: 20000 }
{ C+ HEX: 40000 }
- { A+ HEX: 80000 }
- { M+ HEX: 100000 }
+ { A+ HEX: 100000 }
+ { M+ HEX: 80000 }
} ;
: key-codes
: key-event>gesture ( event -- modifiers keycode action? )
dup event-modifiers swap key-code ;
-: send-key-event ( view event quot -- ? )
- >r key-event>gesture r> call swap window-focus
- send-gesture ; inline
-
-: send-user-input ( view string -- )
- CF>string swap window-focus user-input ;
+: send-key-event ( view gesture -- )
+ swap window-focus propagate-gesture ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
: send-key-down-event ( view event -- )
- 2dup [ <key-down> ] send-key-event
- [ interpret-key-event ] [ 2drop ] if ;
+ [ key-event>gesture <key-down> send-key-event ]
+ [ interpret-key-event ]
+ 2bi ;
: send-key-up-event ( view event -- )
- [ <key-up> ] send-key-event drop ;
+ key-event>gesture <key-up> send-key-event ;
: mouse-event>gesture ( event -- modifiers button )
dup event-modifiers swap button ;
: send-button-down$ ( view event -- )
- [ mouse-event>gesture <button-down> ] 2keep
- mouse-location rot window send-button-down ;
+ [ mouse-event>gesture <button-down> ]
+ [ mouse-location rot window send-button-down ] 2bi ;
: send-button-up$ ( view event -- )
[ mouse-event>gesture <button-up> ] 2keep
}
{ "mouseEntered:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "mouseExited:" "void" { "id" "SEL" "id" }
- [ [ 3drop forget-rollover ] ui-try ]
+ [ 3drop forget-rollover ]
}
{ "mouseMoved:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "mouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "mouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
+ [ nip send-button-down$ ]
}
{ "mouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
+ [ nip send-button-up$ ]
}
{ "rightMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
+ [ nip send-button-down$ ]
}
{ "rightMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
+ [ nip send-button-up$ ]
}
{ "otherMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
+ [ nip send-button-down$ ]
}
{ "otherMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
+ [ nip send-button-up$ ]
}
{ "scrollWheel:" "void" { "id" "SEL" "id" }
- [ [ nip send-wheel$ ] ui-try ]
+ [ nip send-wheel$ ]
}
{ "keyDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-down-event ] ui-try ]
+ [ nip send-key-down-event ]
}
{ "keyUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-up-event ] ui-try ]
+ [ nip send-key-up-event ]
}
{ "cut:" "id" { "id" "SEL" "id" }
- [ [ nip T{ cut-action } send-action$ ] ui-try ]
+ [ nip T{ cut-action } send-action$ ]
}
{ "copy:" "id" { "id" "SEL" "id" }
- [ [ nip T{ copy-action } send-action$ ] ui-try ]
+ [ nip T{ copy-action } send-action$ ]
}
{ "paste:" "id" { "id" "SEL" "id" }
- [ [ nip T{ paste-action } send-action$ ] ui-try ]
+ [ nip T{ paste-action } send-action$ ]
}
{ "delete:" "id" { "id" "SEL" "id" }
- [ [ nip T{ delete-action } send-action$ ] ui-try ]
+ [ nip T{ delete-action } send-action$ ]
}
{ "selectAll:" "id" { "id" "SEL" "id" }
- [ [ nip T{ select-all-action } send-action$ ] ui-try ]
+ [ nip T{ select-all-action } send-action$ ]
}
! Multi-touch gestures: this is undocumented.
! Text input
{ "insertText:" "void" { "id" "SEL" "id" }
- [ [ nip send-user-input ] ui-try ]
+ [ nip CF>string swap window-focus user-input ]
}
{ "hasMarkedText" "char" { "id" "SEL" }
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [
- [
- 2drop dup view-dim swap window (>>dim) yield
- ] ui-try
- ]
+ [ 2drop dup view-dim swap window (>>dim) yield ]
+}
+
+{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
+ [ 3drop ]
}
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
[ gesture>string , ]
[
[ command-name , ]
- [ command-word \ $link swap 2array , ]
+ [ command-word <$link> , ]
[ command-description , ]
tri
] bi*
: roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary
+ f f pressed-gradient f <button-paint> >>interior
align-left ; inline
: <roll-button> ( label quot -- button )
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
-: insert-newline ( editor -- ) "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input* drop ;
: delete-next-character ( editor -- )
T{ char-elt } editor-delete ;
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
-TUPLE: gadget < rect
- pref-dim parent children orientation focus
- visible? root? clipped? layout-state graft-state graft-node
- interior boundary
- model ;
+TUPLE: gadget < rect pref-dim parent children orientation focus
+visible? root? clipped? layout-state graft-state graft-node
+interior boundary model ;
M: gadget equal? 2drop f ;
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
-[ t ] [ [ \ = help ] test-gadget-text ] unit-test
+[ t ] [ [ \ = print-topic ] test-gadget-text ] unit-test
[ t ] [
[
[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
-[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-1" print-topic ] test-gadget-text ] unit-test
ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
-[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" print-topic ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
-<pane> [ \ = help ] with-pane
+<pane> [ \ = print-topic ] with-pane
[ ] [
\ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect ;
-
IN: ui.gadgets.panes
TUPLE: pane < pack
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }
- { T{ button-up f { S+ } 1 } [ drop ] }
+ { T{ button-up f { S+ } 1 } [ end-selection ] }
{ T{ button-up } [ end-selection ] }
{ T{ drag } [ extend-selection ] }
{ T{ copy-action } [ com-copy ] }
GENERIC: finish-editing ( slot-editor ref -- )
M: key-ref finish-editing
- drop T{ update-object } swap send-gesture drop ;
+ drop T{ update-object } swap propagate-gesture ;
M: value-ref finish-editing
- drop T{ update-slot } swap send-gesture drop ;
+ drop T{ update-slot } swap propagate-gesture ;
: slot-editor-value ( slot-editor -- object )
text>> control-value parse-fresh ;
: delete ( slot-editor -- )
dup ref>> delete-ref
- T{ update-object } swap send-gesture drop ;
+ T{ update-object } swap propagate-gesture ;
\ delete H{
{ +description+ "Delete the slot and close the slot editor." }
} define-command
: close ( slot-editor -- )
- T{ update-slot } swap send-gesture drop ;
+ T{ update-slot } swap propagate-gesture ;
\ close H{
{ +description+ "Close the slot editor without saving changes." }
: <edit-button> ( -- gadget )
"..."
- [ T{ edit-slot } swap send-gesture drop ]
+ [ T{ edit-slot } swap propagate-gesture ]
<roll-button> ;
: display-slot ( gadget editable-slot -- )
{ T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
{ T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
{ T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
+ { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
{ T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
+ { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
} set-gestures
+PREDICATE: specific-button-up < button-up #>> ;
+PREDICATE: specific-button-down < button-down #>> ;
+PREDICATE: specific-drag < drag #>> ;
+
+: generalize-gesture ( gesture -- )
+ clone f >># button-gesture ;
+
+M: world handle-gesture ( gesture gadget -- ? )
+ 2dup call-next-method [
+ {
+ { [ over specific-button-up? ] [ drop generalize-gesture f ] }
+ { [ over specific-button-down? ] [ drop generalize-gesture f ] }
+ { [ over specific-drag? ] [ drop generalize-gesture f ] }
+ [ 2drop t ]
+ } cond
+ ] [ 2drop f ] if ;
+
: close-global ( world global -- )
dup get-global find-world rot eq?
[ f swap set-global ] [ drop ] if ;
"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." }
{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
-{ send-gesture handle-gesture set-gestures } related-words
+{ propagate-gesture handle-gesture set-gestures } related-words
-HELP: send-gesture
-{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
+HELP: propagate-gesture
+{ $values { "gesture" "a gesture" } { "gadget" gadget } }
+{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
HELP: user-input
-{ $values { "str" string } { "gadget" gadget } }
+{ $values { "string" string } { "gadget" gadget } }
{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
HELP: motion
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $examples { $code "T{ select-all-action }" } } ;
-HELP: generalize-gesture
-{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
-{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
-
HELP: C+
{ $description "Control key modifier." } ;
{ $var-description "Global variable. The mouse button most recently pressed." } ;
HELP: hand-last-time
-{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link millis } "." } ;
+{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link micros } "." } ;
HELP: hand-buttons
{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs kernel math models namespaces
-make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets boxes calendar
-alarms symbols combinators sets columns ;
+USING: accessors arrays assocs kernel math math.order models
+namespaces make sequences words strings system hashtables
+math.parser math.vectors classes.tuple classes boxes calendar
+alarms symbols combinators sets columns fry deques ui.gadgets ;
IN: ui.gestures
-: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
[ "gestures" word-prop ] map
assoc-stack dup [ call f ] [ 2drop t ] if ;
-: send-gesture ( gesture gadget -- ? )
- [ dupd handle-gesture ] each-parent nip ;
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
+
+: gesture-queue ( -- deque ) \ gesture-queue get ;
+
+GENERIC: send-queued-gesture ( request -- )
+
+TUPLE: send-gesture gesture gadget ;
+
+M: send-gesture send-queued-gesture
+ [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
+
+: queue-gesture ( ... class -- )
+ boa gesture-queue push-front notify-ui-thread ; inline
+
+: send-gesture ( gesture gadget -- )
+ \ send-gesture queue-gesture ;
+
+: each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
-: user-input ( str gadget -- )
- over empty?
- [ [ dupd user-input* ] each-parent ] unless
- 2drop ;
+TUPLE: propagate-gesture gesture gadget ;
+
+M: propagate-gesture send-queued-gesture
+ [ gesture>> ] [ gadget>> ] bi
+ [ handle-gesture ] with each-parent drop ;
+
+: propagate-gesture ( gesture gadget -- )
+ \ propagate-gesture queue-gesture ;
+
+TUPLE: user-input string gadget ;
+
+M: user-input send-queued-gesture
+ [ string>> ] [ gadget>> ] bi
+ [ user-input* ] with each-parent drop ;
+
+: user-input ( string gadget -- )
+ '[ _ \ user-input queue-gesture ] unless-empty ;
! Gesture objects
TUPLE: motion ; C: <motion> motion
TUPLE: up-action ; C: <up-action> up-action
TUPLE: down-action ; C: <down-action> down-action
-TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
-
-: generalize-gesture ( gesture -- newgesture )
- clone f >># ;
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
! Modifiers
SYMBOLS: C+ A+ M+ S+ ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> boa ; inline
+ [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
SYMBOL: hand-last-button
SYMBOL: hand-last-time
0 hand-last-button set-global
-0 hand-last-time set-global
+<zero> hand-last-time set-global
SYMBOL: hand-buttons
V{ } clone hand-buttons set-global
{ 0 0 } scroll-direction set-global
SYMBOL: double-click-timeout
-300 double-click-timeout set-global
+300 milliseconds double-click-timeout set-global
: hand-moved? ( -- ? )
hand-loc get hand-click-loc get = not ;
: button-gesture ( gesture -- )
- hand-clicked get-global 2dup send-gesture [
- >r generalize-gesture r> send-gesture drop
- ] [
- 2drop
- ] if ;
+ hand-clicked get-global propagate-gesture ;
: drag-gesture ( -- )
hand-buttons get-global
: fire-motion ( -- )
hand-buttons get-global empty? [
- T{ motion } hand-gadget get-global send-gesture drop
+ T{ motion } hand-gadget get-global propagate-gesture
] [
drag-gesture
] if ;
-: each-gesture ( gesture seq -- )
- [ handle-gesture drop ] with each ;
-
: hand-gestures ( new old -- )
drop-prefix <reversed>
T{ mouse-leave } swap each-gesture
: forget-rollover ( -- )
f hand-world set-global
- hand-gadget get-global >r
- f hand-gadget set-global
- f r> parents hand-gestures ;
+ hand-gadget get-global
+ [ f hand-gadget set-global f ] dip
+ parents hand-gestures ;
: send-lose-focus ( gadget -- )
- T{ lose-focus } swap handle-gesture drop ;
+ T{ lose-focus } swap send-gesture ;
: send-gain-focus ( gadget -- )
- T{ gain-focus } swap handle-gesture drop ;
+ T{ gain-focus } swap send-gesture ;
: focus-child ( child gadget ? -- )
[
hand-click-loc get-global swap screen-loc v- ;
: multi-click-timeout? ( -- ? )
- millis hand-last-time get - double-click-timeout get <= ;
+ now hand-last-time get time- double-click-timeout get before=? ;
: multi-click-button? ( button -- button ? )
dup hand-last-button get = ;
1 hand-click# set
] if
hand-last-button set
- millis hand-last-time set
+ now hand-last-time set
] bind ;
: update-clicked ( -- )
: move-hand ( loc world -- )
dup hand-world set-global
- under-hand >r over hand-loc set-global
- pick-up hand-gadget set-global
- under-hand r> hand-gestures ;
+ under-hand [
+ over hand-loc set-global
+ pick-up hand-gadget set-global
+ under-hand
+ ] dip hand-gestures ;
: send-button-down ( gesture loc world -- )
move-hand
: send-wheel ( direction loc world -- )
move-hand
scroll-direction set-global
- T{ mouse-scroll } hand-gadget get-global send-gesture
- drop ;
+ T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
: world-focus ( world -- gadget )
dup focus>> [ world-focus ] [ ] ?if ;
: send-action ( world gesture -- )
- swap world-focus send-gesture drop ;
+ swap world-focus propagate-gesture ;
GENERIC: gesture>string ( gesture -- string/f )
\ browser-help H{ { +nullary+ t } } define-command
browser-gadget "toolbar" f {
- { T{ key-down f { A+ } "b" } com-back }
- { T{ key-down f { A+ } "f" } com-forward }
- { T{ key-down f { A+ } "h" } com-documentation }
- { T{ key-down f { A+ } "v" } com-vocabularies }
+ { T{ key-down f { A+ } "LEFT" } com-back }
+ { T{ key-down f { A+ } "RIGHT" } com-forward }
+ { f com-documentation }
+ { f com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
} ;
-{ <debugger> debugger-window ui-try } related-words
+{ <debugger> debugger-window } related-words
HELP: debugger-window
{ $values { "error" "an error" } }
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
- ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
- ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
- ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
- ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
- models namespaces sequences sequences words continuations
- debugger prettyprint ui.tools.traceback help editors ;
-
+USING: accessors arrays hashtables io kernel math models
+namespaces sequences sequences words continuations debugger
+prettyprint help editors ui ui.commands ui.gestures ui.gadgets
+ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
+ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ;
IN: ui.tools.debugger
-: <restart-list> ( restarts restart-hook -- gadget )
- [ name>> ] rot <model> <list> ;
+TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
+
+<PRIVATE
+
+: <restart-list> ( debugger -- gadget )
+ [ restart-hook>> ] [ restarts>> ] bi
+ [ name>> ] swap <model> <list> ; inline
-TUPLE: debugger < track restarts ;
+: <error-pane> ( error -- pane )
+ <pane> [ [ print-error ] with-pane ] keep ; inline
-: <debugger-display> ( restart-list error -- gadget )
+: <debugger-display> ( debugger -- gadget )
<filled-pile>
- <pane>
- swapd tuck [ print-error ] with-pane
- add-gadget
+ over error>> <error-pane> add-gadget
+ swap restart-list>> add-gadget ; inline
- swap add-gadget ;
+PRIVATE>
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
add-toolbar
- -rot <restart-list> >>restarts
- dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
+ swap >>restart-hook
+ swap >>restarts
+ swap >>error
+ error-continuation get >>continuation
+ dup <restart-list> >>restart-list
+ dup <debugger-display> <scroller> 1 track-add ;
-M: debugger focusable-child* restarts>> ;
+M: debugger focusable-child* restart-list>> ;
: debugger-window ( error -- )
#! No restarts for the debugger window
{ T{ button-down } request-focus }
} define-command-map
-: com-traceback ( -- ) error-continuation get traceback-window ;
+: com-traceback ( debugger -- ) continuation>> traceback-window ;
+
+\ com-traceback H{ } define-command
+
+: com-help ( debugger -- ) error>> (:help) ;
-\ com-traceback H{ { +nullary+ t } } define-command
+\ com-help H{ { +listener+ t } } define-command
-\ :help H{ { +nullary+ t } { +listener+ t } } define-command
+: com-edit ( debugger -- ) error>> (:edit) ;
-\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
+\ com-edit H{ { +listener+ t } } define-command
debugger "toolbar" f {
{ T{ key-down f f "s" } com-traceback }
- { T{ key-down f f "h" } :help }
- { T{ key-down f f "e" } :edit }
+ { T{ key-down f f "h" } com-help }
+ { T{ key-down f f "e" } com-edit }
} define-command-map
[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
-[ ] [ 1000 sleep ] unit-test
+[ ] [ 1 seconds sleep ] unit-test
[ ] [ "interactor" get interactor-eof ] unit-test
] in-thread
] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ 100 milliseconds sleep ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ 100 milliseconds sleep ] unit-test
[ ] [ "interactor" get interactor-eof ] unit-test
] in-thread
] unit-test
-[ ] [ 100 sleep ] unit-test
+[ ] [ 100 milliseconds sleep ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
- { [ dup not ] [ drop "\n" swap user-input f f ] }
+ { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
[ handle-parse-error f f ]
} cond ;
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic threads accessors listener math ;
+threads arrays generic threads accessors listener math
+calendar ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
[ ] [ "listener" get restart-listener ] unit-test
- [ ] [ 1000 sleep ] unit-test
+ [ ] [ 1 seconds sleep ] unit-test
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: inspector help help.markup io io.styles
-kernel models namespaces parser quotations sequences vocabs words
-prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors combinators assocs fry ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.labelled
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+USING: inspector help help.markup io io.styles kernel models
+namespaces parser quotations sequences vocabs words prettyprint
+listener debugger threads boxes concurrency.flags math arrays
+generic accessors combinators assocs fry ui.commands ui.gadgets
+ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
+ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
TUPLE: listener-gadget < track input output ;
-: listener-output, ( listener -- listener )
- <scrolling-pane>
- [ >>output ] [ <scroller> 1 track-add ] bi ;
-
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ;
-: listener-input, ( listener -- listener )
- dup <listener-input>
- [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
-
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
"handbook" ($link) ". To see a list of keyboard shortcuts," print
: insert-word ( word -- )
get-workspace listener>> input>>
- [ >r word-completion-string r> user-input ]
+ [ >r word-completion-string r> user-input* drop ]
[ interactor-use use-if-necessary ]
2bi ;
[ wait-for-listener ]
} cleave ;
+: init-listener ( listener -- listener )
+ <scrolling-pane> >>output
+ dup <listener-input> >>input ;
+
+: <listener-scroller> ( listener -- scroller )
+ <filled-pile>
+ over output>> add-gadget
+ swap input>> add-gadget
+ <scroller> ;
+
: <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track
add-toolbar
- listener-output,
- listener-input, ;
+ init-listener
+ dup <listener-scroller> 1 track-add ;
: listener-help ( -- ) "ui-listener" help-window ;
listener-gadget "toolbar" f {
{ f restart-listener }
- { T{ key-down f { A+ } "a" } com-auto-use }
- { T{ key-down f { A+ } "c" } clear-output }
- { T{ key-down f { A+ } "C" } clear-stack }
+ { T{ key-down f { A+ } "u" } com-auto-use }
+ { T{ key-down f { A+ } "k" } clear-output }
+ { T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
} define-command-map
USING: assocs ui.tools.search help.topics io.files io.styles
kernel namespaces sequences source-files threads
tools.test ui.gadgets ui.gestures vocabs accessors
-vocabs.loader words tools.test.ui debugger ;
+vocabs.loader words tools.test.ui debugger calendar ;
IN: ui.tools.search.tests
[ f ] [
: update-live-search ( search -- seq )
dup [
- 300 sleep
+ 300 milliseconds sleep
list>> control-value
] with-grafted-gadget ;
"" all-words t <definition-search>
dup [
{ "set-word-prop" } over field>> set-control-value
- 300 sleep
+ 300 milliseconds sleep
search-value \ set-word-prop eq?
] with-grafted-gadget
] unit-test
"Dynamic variables" open-status-window ;
: traceback-window ( continuation -- )
- <model> <traceback-gadget> "Traceback" open-window ;
+ <model> <traceback-gadget> "Traceback" open-status-window ;
{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
-HELP: ui-try
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
-{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
-
ARTICLE: "ui-glossary" "UI glossary"
{ $table
{ "color specifier"
--- /dev/null
+IN: ui.tests
+USING: ui tools.test ;
+
+\ event-loop must-infer
+\ open-window must-infer
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make
prettyprint dlists deques sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags sets accessors ;
+hashtables concurrency.flags sets accessors calendar ;
IN: ui
! Assoc mapping aliens to gadgets
: init-ui ( -- )
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
+ <dlist> \ gesture-queue set-global
V{ } clone windows set-global ;
: restore-gadget-later ( gadget -- )
: notify-queued ( -- )
graft-queue [ notify ] slurp-deque ;
+: send-queued-gestures ( -- )
+ gesture-queue [ send-queued-gesture ] slurp-deque ;
+
: update-ui ( -- )
- [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+ [
+ [
+ notify-queued
+ layout-queued
+ redraw-worlds
+ send-queued-gestures
+ ] assert-depth
+ ] [ ui-error ] recover ;
: ui-wait ( -- )
- 10 sleep ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;
+ 10 milliseconds sleep ;
SYMBOL: ui-thread
\ ui-running get-global ;
: update-ui-loop ( -- )
- ui-running? ui-thread get-global self eq? and [
- ui-notify-flag get lower-flag
- [ update-ui ] ui-try
- update-ui-loop
- ] when ;
+ [ ui-running? ui-thread get-global self eq? and ]
+ [ ui-notify-flag get lower-flag update-ui ]
+ [ ] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
ui.gestures io kernel math math.vectors namespaces make
sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types
-windows.nt windows threads libc combinators continuations
-command-line shuffle opengl ui.render unicode.case ascii
-math.bitwise locals symbols accessors math.geometry.rect ;
+windows.nt windows threads libc combinators
+combinators.short-circuit continuations command-line shuffle
+opengl ui.render ascii math.bitwise locals symbols accessors
+math.geometry.rect math.order ascii ;
IN: ui.windows
SINGLETON: windows-ui-backend
: alt? ( -- ? ) left-alt? right-alt? or ;
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
-: switch-case ( seq -- seq )
- dup first CHAR: a >= [ >upper ] [ >lower ] if ;
-
-: switch-case? ( -- ? ) shift? caps-lock? xor not ;
-
: key-modifiers ( -- seq )
[
shift? [ S+ , ] when
: exclude-key-wm-char? ( n -- bool )
exclude-keys-wm-char key? ;
-: keystroke>gesture ( n -- mods sym ? )
- dup wm-keydown-codes at* [
- nip >r key-modifiers r> t
- ] [
- drop 1string >r key-modifiers r>
- C+ pick member? >r A+ pick member? r> or [
- shift? [ >lower ] unless f
- ] [
- switch-case? [ switch-case ] when t
- ] if
- ] if ;
+: keystroke>gesture ( n -- mods sym )
+ wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
+
+: send-key-gesture ( sym action? quot hWnd -- )
+ [ [ key-modifiers ] 3dip call ] dip
+ window-focus propagate-gesture ; inline
+
+: send-key-down ( sym action? hWnd -- )
+ [ [ <key-down> ] ] dip send-key-gesture ;
+
+: send-key-up ( sym action? hWnd -- )
+ [ [ <key-up> ] ] dip send-key-gesture ;
+
+: key-sym ( wParam -- string/f action? )
+ {
+ {
+ [ dup LETTER? ]
+ [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
+ }
+ { [ dup digit? ] [ 1string f ] }
+ [ wm-keydown-codes at t ]
+ } cond ;
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-keydown? [
- wParam keystroke>gesture <key-down>
- hWnd window-focus send-gesture drop
+ wParam key-sym over [
+ dup ctrl? alt? xor or [
+ hWnd send-key-down
+ ] [ 2drop ] if
+ ] [ 2drop ] if
] unless ;
:: handle-wm-char ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-char? ctrl? alt? xor or [
- wParam 1string
- hWnd window-focus user-input
+ wParam exclude-key-wm-char? [
+ ctrl? alt? xor [
+ wParam 1string
+ [ f hWnd send-key-down ]
+ [ hWnd window-focus user-input ] bi
+ ] unless
] unless ;
:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
- wParam keystroke>gesture <key-up>
- hWnd window-focus send-gesture drop ;
+ wParam exclude-key-wm-keydown? [
+ wParam key-sym over [
+ hWnd send-key-up
+ ] [ 2drop ] if
+ ] unless ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
? hwnd window (>>active?)
: message>button ( uMsg -- button down? )
{
- { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
- { [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
- { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
- { [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
- { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
- { [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
-
- { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
- { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
- { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
- { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
- { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
- { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
- } cond ;
+ { WM_LBUTTONDOWN [ 1 t ] }
+ { WM_LBUTTONUP [ 1 f ] }
+ { WM_MBUTTONDOWN [ 2 t ] }
+ { WM_MBUTTONUP [ 2 f ] }
+ { WM_RBUTTONDOWN [ 3 t ] }
+ { WM_RBUTTONUP [ 3 f ] }
+
+ { WM_NCLBUTTONDOWN [ 1 t ] }
+ { WM_NCLBUTTONUP [ 1 f ] }
+ { WM_NCMBUTTONDOWN [ 2 t ] }
+ { WM_NCMBUTTONUP [ 2 f ] }
+ { WM_NCRBUTTONDOWN [ 3 t ] }
+ { WM_NCRBUTTONUP [ 3 f ] }
+ } case ;
! If the user clicks in the window border ("non-client area")
! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [
- [
- pick
- trace-messages? get-global [ dup windows-message-name name>> print flush ] when
- wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
- ] ui-try
+ pick
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] alien-callback ;
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
-environment ;
+environment ascii ;
IN: ui.x11
SINGLETON: x11-ui-backend
: event-modifiers ( event -- seq )
XKeyEvent-state modifiers modifier ;
+: valid-input? ( string gesture -- ? )
+ over empty? [ 2drop f ] [
+ mods>> { f { S+ } } member? [
+ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+ ] [
+ [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+ ] if
+ ] if ;
+
: key-down-event>gesture ( event world -- string gesture )
dupd
handle>> xic>> lookup-string
>r swap event-modifiers r> key-code <key-down> ;
M: world key-down-event
- [ key-down-event>gesture ] keep world-focus
- [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
+ [ key-down-event>gesture ] keep
+ world-focus
+ [ propagate-gesture drop ]
+ [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
+ 3bi ;
: key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
- >r key-up-event>gesture r> world-focus send-gesture drop ;
+ >r key-up-event>gesture r> world-focus propagate-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
dup event-modifiers over XButtonEvent-button
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
- [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
+ [ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap
: S_IFIFO OCT: 010000 ; inline ! FIFO.
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
: S_IFSOCK OCT: 140000 ; inline ! Socket.
+: S_IFWHT OCT: 160000 ; inline ! Whiteout.
FUNCTION: int chmod ( char* path, mode_t mode ) ;
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
{ "time_t" "sec" }
{ "long" "nsec" } ;
-: make-timeval ( ms -- timeval )
- 1000 /mod 1000 *
+: make-timeval ( us -- timeval )
+ 1000000 /mod
"timeval" <c-object>
[ set-timeval-usec ] keep
[ set-timeval-sec ] keep ;
-: make-timespec ( ms -- timespec )
- 1000 /mod 1000000 *
+: make-timespec ( us -- timespec )
+ 1000000 /mod 1000 *
"timespec" <c-object>
[ set-timespec-nsec ] keep
[ set-timespec-sec ] keep ;
{ [ dup empty? ] [ drop ] }
{ [ over "/" tail? ] [ append ] }
{ [ "/" pick start not ] [ nip ] }
- [ [ "/" last-split1 drop "/" ] dip 3append ]
+ [ [ "/" split1-last drop "/" ] dip 3append ]
} cond ;
PRIVATE>
"Gives all Factor threads a chance to run."
} }
{ {
- { $code "void factor_sleep(long ms)" }
- "Gives all Factor threads a chance to run for " { $snippet "ms" } " milliseconds."
+ { $code "void factor_sleep(long us)" }
+ "Gives all Factor threads a chance to run for " { $snippet "us" } " microseconds."
} }
} ;
M: array clone (clone) ;
M: array length length>> ;
-M: array nth-unsafe >r >fixnum r> array-nth ;
-M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
+M: array nth-unsafe [ >fixnum ] dip array-nth ;
+M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
M: array resize resize-array ;
: >array ( seq -- array ) { } clone-like ;
GENERIC: >alist ( assoc -- newassoc )
: (assoc-each) ( assoc quot -- seq quot' )
- >r >alist r> [ first2 ] prepose ; inline
+ [ >alist ] dip [ first2 ] prepose ; inline
: assoc-find ( assoc quot -- key value ? )
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
(assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
- >r accumulator >r assoc-each r> r> like ; inline
+ [ accumulator [ assoc-each ] dip ] dip like ; inline
: assoc-map-as ( assoc quot exemplar -- newassoc )
- >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
+ [ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
: assoc-map ( assoc quot -- newassoc )
over assoc-map-as ; inline
: assoc-push-if ( key value quot accum -- )
- >r 2keep r> roll
- [ >r 2array r> push ] [ 3drop ] if ; inline
+ [ 2keep rot ] dip swap
+ [ [ 2array ] dip push ] [ 3drop ] if ; inline
: assoc-pusher ( quot -- quot' accum )
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
+: assoc-filter-as ( assoc quot exemplar -- subassoc )
+ [ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline
+
: assoc-filter ( assoc quot -- subassoc )
- over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
+ over assoc-filter-as ; inline
: assoc-contains? ( assoc quot -- ? )
assoc-find 2nip ; inline
3drop f
] [
3dup nth-unsafe at*
- [ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
+ [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
] if ; inline recursive
: assoc-stack ( key seq -- value )
: assoc-hashcode ( n assoc -- code )
[
- >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
+ [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
] { } assoc>map hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection )
: cache ( key assoc quot -- value )
2over at* [
- >r 3drop r>
+ [ 3drop ] dip
] [
- drop pick rot >r >r call dup r> r> set-at
+ drop pick rot [ call dup ] 2dip set-at
] if ; inline
: change-at ( key assoc quot -- )
- [ >r at r> call ] 3keep drop set-at ; inline
+ [ [ at ] dip call ] 3keep drop set-at ; inline
: at+ ( n key assoc -- )
[ 0 or + ] change-at ;
: map>assoc ( seq quot exemplar -- assoc )
- >r [ 2array ] compose { } map-as r> assoc-like ; inline
+ [ [ 2array ] compose { } map-as ] dip assoc-like ; inline
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
M: sequence set-at
2dup search-alist
[ 2nip set-second ]
- [ drop >r swap 2array r> push ] if ;
+ [ drop [ swap 2array ] dip push ] if ;
M: sequence new-assoc drop <vector> ;
M: sequence assoc-size length ;
M: sequence assoc-clone-like
- >r >alist r> clone-like ;
+ [ >alist ] dip clone-like ;
M: sequence assoc-like
- >r >alist r> like ;
+ [ >alist ] dip like ;
M: sequence >alist ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
-hashtables.private io kernel math math.order namespaces make
-parser sequences strings vectors words quotations assocs layouts
-classes classes.builtin classes.tuple classes.tuple.private
-kernel.private vocabs vocabs.loader source-files definitions
-slots classes.union classes.intersection classes.predicate
-compiler.units bootstrap.image.private io.files accessors
-combinators ;
+hashtables.private io kernel math math.private math.order
+namespaces make parser sequences strings vectors words
+quotations assocs layouts classes classes.builtin classes.tuple
+classes.tuple.private kernel.private vocabs vocabs.loader
+source-files definitions slots classes.union
+classes.intersection classes.predicate compiler.units
+bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
- >r [ define-builtin-predicate ] keep
- r> define-builtin-slots ;
+ [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
"fixnum" "math" create register-builtin
"bignum" "math" create register-builtin
! A predicate class used for declarations
"array-capacity" "sequences.private" create
"fixnum" "math" lookup
-0 bootstrap-max-array-capacity <fake-bignum> [ between? ] 2curry
+[
+ [ dup 0 fixnum>= ] %
+ bootstrap-max-array-capacity <fake-bignum> [ fixnum<= ] curry ,
+ [ [ drop f ] if ] %
+] [ ] make
define-predicate-class
! Catch-all class for providing a default method.
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
- [ tuple-layout [ <tuple-boa> ] curry ]
+ [
+ [
+ callable instance-check-quot %
+ tuple-layout ,
+ \ <tuple-boa> ,
+ ] [ ] make
+ ]
} cleave
(( obj quot -- curry )) define-declared
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
- [ tuple-layout [ <tuple-boa> ] curry ]
+ [
+ [
+ callable instance-check-quot [ dip ] curry %
+ callable instance-check-quot %
+ tuple-layout ,
+ \ <tuple-boa> ,
+ ] [ ] make
+ ]
} cleave
(( quot1 quot2 -- compose )) define-declared
! Primitive words
: make-primitive ( word vocab n -- )
- >r create dup reset-word r>
+ [ create dup reset-word ] dip
[ do-primitive ] curry [ ] like define ;
{
{ "exit" "system" }
{ "data-room" "memory" }
{ "code-room" "memory" }
- { "millis" "system" }
+ { "micros" "system" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
+ { "jit-compile" "quotations" }
}
-[ >r first2 r> make-primitive ] each-index
+[ [ first2 ] dip make-primitive ] each-index
! Bump build number
"build" "kernel" create build 1+ 1quotation define
GENERIC: checksum-lines ( lines checksum -- value )
-M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
+M: checksum checksum-bytes
+ [ binary <byte-reader> ] dip checksum-stream ;
-M: checksum checksum-stream >r contents r> checksum-bytes ;
+M: checksum checksum-stream
+ [ contents ] dip checksum-bytes ;
-M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
+M: checksum checksum-lines
+ [ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
- >r binary <file-reader> r> checksum-stream ;
+ [ binary <file-reader> ] dip checksum-stream ;
: hex-string ( seq -- str )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
256 [
8 [
- dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
+ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum
] map 0 crc32-table copy
INSTANCE: crc32 checksum
-: init-crc32 drop >r HEX: ffffffff dup r> ; inline
+: init-crc32 drop [ HEX: ffffffff dup ] dip ; inline
: finish-crc32 bitxor 4 >be ; inline
\ flatten-class must-infer\r
\ flatten-builtin-class must-infer\r
\r
-: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;\r
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
\r
-: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;\r
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
\r
[ t ] [ object object object class-and* ] unit-test\r
[ t ] [ fixnum object fixnum class-and* ] unit-test\r
20 [ random-boolean-op ] [ ] replicate-as dup .\r
[ infer in>> [ random-boolean ] replicate dup . ] keep\r
\r
- [ >r [ ] each r> call ] 2keep\r
+ [ [ [ ] each ] dip call ] 2keep\r
\r
- >r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=\r
+ [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=\r
\r
=\r
] unit-test\r
C: <anonymous-complement> anonymous-complement\r
\r
: 2cache ( key1 key2 assoc quot -- value )\r
- >r >r 2array r> [ first2 ] r> compose cache ; inline\r
+ [ 2array ] 2dip [ first2 ] prepose cache ; inline\r
\r
GENERIC: valid-class? ( obj -- ? )\r
\r
swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
\r
: left-anonymous-union<= ( first second -- ? )\r
- >r members>> r> [ class<= ] curry all? ;\r
+ [ members>> ] dip [ class<= ] curry all? ;\r
\r
: right-anonymous-union<= ( first second -- ? )\r
members>> [ class<= ] with contains? ;\r
\r
: left-anonymous-intersection<= ( first second -- ? )\r
- >r participants>> r> [ class<= ] curry contains? ;\r
+ [ participants>> ] dip [ class<= ] curry contains? ;\r
\r
: right-anonymous-intersection<= ( first second -- ? )\r
participants>> [ class<= ] with all? ;\r
} cond ;\r
\r
: left-anonymous-complement<= ( first second -- ? )\r
- >r normalize-complement r> class<= ;\r
+ [ normalize-complement ] dip class<= ;\r
\r
PREDICATE: nontrivial-anonymous-complement < anonymous-complement\r
class>> {\r
: sort-classes ( seq -- newseq )\r
[ [ name>> ] compare ] sort >vector\r
[ dup empty? not ]\r
- [ dup largest-class >r over delete-nth r> ]\r
+ [ dup largest-class [ over delete-nth ] dip ]\r
[ ] produce nip ;\r
\r
: min-class ( class seq -- class/f )\r
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? )
- >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+ [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test
: tuple>array ( tuple -- array )
prepare-tuple>array
- >r copy-tuple-slots r>
+ [ copy-tuple-slots ] dip
first prefix ;
: tuple-slots ( tuple -- seq )
[
\ dup ,
[ "predicate" word-prop % ]
- [ [ bad-slot-value ] curry , ] bi
+ [ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
\ unless ,
] [ ] make ;
: update-slot ( old-values n class initial -- value )
pick [
- >r >r swap nth dup r> instance? r> swap
+ [ [ swap nth dup ] dip instance? ] dip swap
[ drop ] [ nip ] if
- ] [ >r 3drop r> ] if ;
+ ] [ [ 3drop ] dip ] if ;
: apply-slot-permutation ( old-values triples -- new-values )
[ first3 update-slot ] with map ;
class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
- >r subclasses r> each ; inline
+ [ subclasses ] dip each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
M: tuple hashcode*
[
[ class hashcode ] [ tuple-size ] [ ] tri
- >r rot r> [
+ [ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
] recursive-hashcode ;
{ $code
"! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } spread"
- ">r >r >r p r> q r> r r> s"
+ "[ [ [ p ] dip q ] dip r ] dip s"
}
} ;
! spread
: spread>quot ( seq -- quot )
- [ ] [
- [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
- append
- ] reduce ;
+ [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
: spread ( objs... seq -- )
spread>quot call ;
drop [ swap adjoin ] curry each
] [
[
- >r 2dup r> hashcode pick length rem rot nth adjoin
+ [ 2dup ] dip hashcode pick length rem rot nth adjoin
] each 2drop
] if ;
next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( alist initial quot -- buckets )
- swapd [ >r dup first r> call 2array ] curry map
+ swapd [ [ dup first ] dip call 2array ] curry map
[ length <buckets> dup ] keep
[ first2 (distribute-buckets) ] with each ; inline
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
- [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
+ [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
{ [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
{ [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
- { [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] }
+ { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
[ drop linear-case-quot ]
} cond ;
! assert-depth
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
- 2dup [ length ] bi@ min tuck tail >r tail r> ;
+ 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ;
ERROR: relative-underflow stack ;
ERROR: relative-overflow stack ;
: assert-depth ( quot -- )
- >r datastack r> dip >r datastack r>
+ [ datastack ] dip dip [ datastack ] dip
2dup [ length ] compare {
{ +lt+ [ trim-datastacks nip relative-underflow ] }
{ +eq+ [ 2drop ] }
: errors-of-type ( type -- assoc )
compiler-errors get-global
- swap [ >r nip compiler-error-type r> eq? ] curry
+ swap [ [ nip compiler-error-type ] dip eq? ] curry
assoc-filter ;
: compiler-errors. ( type -- )
#! ( value f r:capture r:restore )
#! Execution begins right after the call to 'continuation'.
#! The 'restore' branch is taken.
- >r >r dummy-1 continuation r> r> [ dummy-2 ] prepose ?if ; inline
+ [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
: callcc0 ( quot -- ) [ drop ] ifcc ; inline
set-catchstack
set-namestack
set-retainstack
- >r set-datastack r>
+ [ set-datastack ] dip
set-callstack ;
: (continue-with) ( obj continuation -- )
set-catchstack
set-namestack
set-retainstack
- >r set-datastack drop 4 getenv f 4 setenv f r>
+ [ set-datastack drop 4 getenv f 4 setenv f ] dip
set-callstack ;
PRIVATE>
c> continue-with ;
: recover ( try recovery -- )
- >r [ swap >c call c> drop ] curry r> ifcc ; inline
+ [ [ swap >c call c> drop ] curry ] dip ifcc ; inline
: ignore-errors ( quot -- )
[ drop ] recover ; inline
: cleanup ( try cleanup-always cleanup-error -- )
- over >r compose [ dip rethrow ] curry
- recover r> call ; inline
+ [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline
ERROR: attempt-all-error ;
{ sort-classes order } related-words
HELP: (call-next-method)
-{ $values { "class" class } { "generic" generic } }
+{ $values { "method" method-body } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
GENERIC: next-method-quot* ( class generic combination -- quot )
-: next-method-quot ( class generic -- quot )
+: next-method-quot ( method -- quot )
next-method-quot-cache get [
- dup "combination" word-prop next-method-quot*
- ] 2cache ;
+ [ "method-class" word-prop ]
+ [
+ "method-generic" word-prop
+ dup "combination" word-prop
+ ] bi next-method-quot*
+ ] cache ;
-: (call-next-method) ( class generic -- )
+: (call-next-method) ( method -- )
next-method-quot call ;
TUPLE: check-method class generic ;
: math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep
- >r over r> (math-upgrade) >r (math-upgrade)
- dup empty? [ [ dip ] curry [ ] like ] unless
- r> append ;
+ [ over ] dip (math-upgrade) [
+ (math-upgrade)
+ dup empty? [ [ dip ] curry [ ] like ] unless
+ ] dip append ;
ERROR: no-math-method left right generic ;
: math-method ( word class1 class2 -- quot )
2dup and [
- 2dup math-upgrade >r
- math-class-max over order min-class applicable-method
- r> prepend
+ 2dup math-upgrade
+ [ math-class-max over order min-class applicable-method ] dip
+ prepend
] [
2drop object-method
] if ;
dup
\ over [
dup math-class? [
- \ dup [ >r 2dup r> math-method ] math-vtable
+ \ dup [ [ 2dup ] dip math-method ] math-vtable
] [
over object-method
] if nip
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
-SYMBOL: current-class
-SYMBOL: current-generic
-
-: with-method-definition ( quot -- parsed )
- [
- [
- [ "method-class" word-prop current-class set ]
- [ "method-generic" word-prop current-generic set ]
- [ ] tri
- ] dip call
- ] with-scope ; inline
+SYMBOL: current-method
+
+: with-method-definition ( method quot -- )
+ [ dup current-method ] dip with-variable ; inline
: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;
[ over assumed [ engine>quot ] with-variable ] assoc-map ;
: if-small? ( assoc true false -- )
- >r >r dup assoc-size 4 <= r> r> if ; inline
+ [ dup assoc-size 4 <= ] 2dip if ; inline
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
- [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+ [ 1- (picker) [ dip swap ] curry ]
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;
C: <predicate-dispatch-engine> predicate-dispatch-engine
: class-predicates ( assoc -- assoc )
- [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+ [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
: keep-going? ( assoc -- ? )
assumed get swap second first class<= ;
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots*
- [ >r lo-tag-number r> ] assoc-map
+ [ [ lo-tag-number ] dip ] assoc-map
[
picker % [ tag ] % [
sort-tags linear-dispatch-quot
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots*
- [ >r hi-tag-number r> ] assoc-map
+ [ [ hi-tag-number ] dip ] assoc-map
[
picker % hi-tag-quot % [
sort-tags linear-dispatch-quot
] [
num-tags get , \ fixnum-fast ,
- [ >r num-tags get - r> ] assoc-map
+ [ [ num-tags get - ] dip ] assoc-map
num-hi-tags direct-dispatch-quot
] if-small? %
] [ ] make ;
] change-at ;
: flatten-method ( class method assoc -- )
- >r >r dup flatten-class keys swap r> r> [
- >r spin r> push-method
+ [ dup flatten-class keys swap ] 2dip [
+ [ spin ] dip push-method
] 3curry each ;
: flatten-methods ( assoc -- assoc' )
T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' )
- >r #>> (dispatch#) r> with-variable ; inline
+ [ #>> (dispatch#) ] dip with-variable ; inline
M: standard-generic extra-values drop 0 ;
growable-check
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
- >r >fixnum r>
+ [ >fixnum ] dip
over 1 fixnum+fast over (>>length)
] [
- >r >fixnum r>
+ [ >fixnum ] dip
] if ; inline
M: growable set-nth ensure set-nth-unsafe ;
[ H{ { -1 4 } { -3 16 } { -5 36 } } ] [
H{ { 1 2 } { 3 4 } { 5 6 } }
- [ >r neg r> sq ] assoc-map
+ [ [ neg ] dip sq ] assoc-map
] unit-test
! Bug discovered by littledan
length>> 1 fixnum-fast fixnum-bitand ; inline
: hash@ ( key array -- i )
- >r hashcode >fixnum dup fixnum+fast r> wrap ; inline
+ [ hashcode >fixnum dup fixnum+fast ] dip wrap ; inline
: probe ( array i -- array i )
2 fixnum+fast over wrap ; inline
M: hashtable delete-at ( key hash -- )
tuck key@ [
- >r >r ((tombstone)) dup r> r> set-nth-pair
+ [ ((tombstone)) dup ] 2dip set-nth-pair
hash-deleted+
] [
3drop
[ count>> ] [ deleted>> ] bi - ;
: rehash ( hash -- )
- dup >alist >r
+ dup >alist [
dup clear-assoc
- r> (rehash) ;
+ ] dip (rehash) ;
M: hashtable set-at ( value key hash -- )
dup ?grow-hash
: push-unsafe ( elt seq -- )
[ length ] keep
[ underlying>> set-array-nth ]
- [ >r 1+ r> (>>length) ]
+ [ [ 1+ ] dip (>>length) ]
2bi ; inline
PRIVATE>
M: hashtable >alist
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
[
- >r
- >r 1 fixnum-shift-fast r>
- [ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r>
+ [
+ [ 1 fixnum-shift-fast ] dip
+ [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
+ ] dip
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
] 2curry each
] keep { } like ;
byte-arrays ;
HELP: io-multiplex
-{ $values { "ms" "a non-negative integer" } }
-{ $contract "Waits up to " { $snippet "ms" } " milliseconds for pending I/O requests to complete." } ;
+{ $values { "us" "a non-negative integer" } }
+{ $contract "Waits up to " { $snippet "us" } " microseconds for pending I/O requests to complete." } ;
HELP: init-io
{ $contract "Initializes the I/O system. Called on startup." } ;
SINGLETON: c-io-backend
-c-io-backend io-backend set-global
+io-backend global [ c-io-backend or ] change-at
HOOK: init-io io-backend ( -- )
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
-HOOK: io-multiplex io-backend ( ms -- )
+HOOK: io-multiplex io-backend ( us -- )
HOOK: normalize-directory io-backend ( str -- newstr )
: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
dup call
- [ >r drop "" like r> ]
+ [ [ drop "" like ] dip ]
[ pick push ((read-until)) ] if ; inline recursive
: (read-until) ( quot -- string/f sep/f )
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
- >r <file-reader> r> with-input-stream ; inline
+ [ <file-reader> ] dip with-input-stream ; inline
: file-contents ( path encoding -- str )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
- >r <file-writer> r> with-output-stream ; inline
+ [ <file-writer> ] dip with-output-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
- >r <file-appender> r> with-output-stream ; inline
+ [ <file-appender> ] dip with-output-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
{ [ dup head.? ] [ rest trim-left-separators append-path ] }
{ [ dup head..? ] [
2 tail trim-left-separators
- >r parent-directory r> append-path
+ [ parent-directory ] dip append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
- >r 2 head r> append
+ [ 2 head ] dip append
] }
[
- >r trim-right-separators "/" r>
+ [ trim-right-separators "/" ] dip
trim-left-separators 3append
]
} cond ;
] unless ;
: file-extension ( filename -- extension )
- "." last-split1 nip ;
+ "." split1-last nip ;
! File info
TUPLE: file-info type size permissions created modified
HOOK: read-link io-backend ( symlink -- path )
: copy-link ( target symlink -- )
- >r read-link r> make-link ;
+ [ read-link ] dip make-link ;
SYMBOL: +regular-file+
SYMBOL: +directory+
(normalize-path) current-directory set ;
: with-directory ( path quot -- )
- >r (normalize-path) current-directory r> with-variable ; inline
+ [ (normalize-path) current-directory ] dip with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
[ ] cleanup ; inline
: tabular-output ( style quot -- )
- swap >r { } make r> output-stream get stream-write-table ; inline
+ swap [ { } make ] dip output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
] if ; inline
: with-nesting ( style quot -- )
- >r output-stream get make-block-stream
- r> with-output-stream ; inline
+ [ output-stream get make-block-stream ] dip
+ with-output-stream ; inline
: print ( string -- ) output-stream get stream-print ;
512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array )
- >r <byte-writer> r> [ output-stream get ] compose with-output-stream*
+ [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
dup encoder? [ stream>> ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
- >r >byte-vector dup reverse-here r> <decoder> ;
+ [ >byte-vector dup reverse-here ] dip <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
- >r <byte-reader> r> with-input-stream* ; inline
+ [ <byte-reader> ] dip with-input-stream* ; inline
M: c-io-backend (init-stdio) init-c-stdio ;
-M: c-io-backend io-multiplex 60 60 * 1000 * or (sleep) ;
+M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;
#! print stuff from contexts where the I/O system would
#! otherwise not work (tools.deploy.shaker, the I/O
#! multiplexer thread).
- "\r\n" append >byte-array
+ "\n" append >byte-array
stdout-handle fwrite
stdout-handle fflush ;
[ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
- >r 1string r> stream-write ;
+ [ 1string ] dip stream-write ;
M: style-stream make-span-stream
do-nested-style make-span-stream ;
] unless ;
: map-last ( seq quot -- seq )
- >r dup length <reversed> [ zero? ] r> compose 2map ; inline
+ [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
PRIVATE>
>sbuf dup reverse-here null-encoding <decoder> ;
: with-string-reader ( str quot -- )
- >r <string-reader> r> with-input-stream ; inline
+ [ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer
HELP: roll $shuffle ;
HELP: -roll $shuffle ;
-HELP: >r ( x -- )
-{ $values { "x" object } } { $description "Moves the top of the data stack to the retain stack." } ;
-
-HELP: r> ( -- x )
-{ $values { "x" object } } { $description "Moves the top of the retain stack to the data stack." } ;
-
HELP: datastack ( -- ds )
{ $values { "ds" array } }
{ $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
{ $description "Calls a quotation while hiding the top three stack elements." } ;
HELP: keep
-{ $values { "quot" { $quotation "( x -- )" } } { "x" object } }
-{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } ;
+{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
+{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
+{ $examples
+ { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
+} ;
HELP: 2keep
-{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } }
+{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
-{ $values { "quot" { $quotation "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
+{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] bi*"
- ">r p r> q"
+ "[ p ] dip q"
}
} ;
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] 2bi*"
- ">r >r p r> r> q"
+ "[ p ] 2dip q"
}
} ;
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] [ r ] tri*"
- ">r >r p r> q r> r"
+ "[ [ p ] dip q ] dip r"
}
} ;
HELP: bi@
-{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- )" } } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." }
{ $examples
"The following two lines are equivalent:"
{ $code
"[ p ] bi@"
- ">r p r> p"
+ "[ p ] dip p"
}
"The following two lines are also equivalent:"
{ $code
} ;
HELP: 2bi@
-{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- )" } } }
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
{ $code
"[ p ] 2bi@"
- ">r >r p r> r> p"
+ "[ p ] 2dip p"
}
"The following two lines are also equivalent:"
{ $code
} ;
HELP: tri@
-{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
{ $code
"[ p ] tri@"
- ">r >r p r> p r> p"
+ "[ [ p ] dip p ] dip p"
}
"The following two lines are also equivalent:"
{ $code
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
-{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" quotation } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
HELP: when*
-{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } }
{ $description "Variant of " { $link if* } " with no false quotation."
$nl
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
-{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" { $quotation "( default -- )" } } }
+{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" { $quotation "( default -- ... )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
- "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
- { $code
- "[ 3 >r ] [ r> . ] compose"
- }
- "Except for this restriction, the following two lines are equivalent:"
+ "The following two lines are equivalent:"
{ $code
"compose call"
"append call"
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
- "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
- { $code
- "[ >r ] swap [ r> ] 3compose"
- }
- "The correct way to achieve the effect of the above is the following:"
- { $code
- "[ dip ] curry"
- }
- "Excepting the retain stack restriction, the following two lines are equivalent:"
+ "The following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
HELP: dip
{ $values { "x" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
-{ $notes "The following are equivalent:"
- { $code ">r foo bar r>" }
- { $code "[ foo bar ] dip" }
+{ $examples
+ { $example "USING: arrays kernel math prettyprint ;" "10 20 30 [ / ] dip 2array ." "{ 1/2 30 }" }
} ;
HELP: 2dip
{ $values { "x" object } { "y" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
- { $code ">r >r foo bar r> r>" }
+ { $code "[ [ foo bar ] dip ] dip" }
{ $code "[ foo bar ] 2dip" }
} ;
{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
- { $code ">r >r >r foo bar r> r> r>" }
+ { $code "[ [ [ foo bar ] dip ] dip ] dip" }
{ $code "[ foo bar ] 3dip" }
} ;
{ $subsection -rot }
{ $subsection spin }
{ $subsection roll }
-{ $subsection -roll }
-"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
-{ $subsection >r }
-{ $subsection r> }
-"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
-{ $example "1 2 3 >r .s r>" "1\n2" }
-"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
-$nl
-"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
+{ $subsection -roll } ;
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
{ $subsection tri* }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
- "! First alternative; uses retain stack explicitly"
- ">r >r 1 +"
- "r> 1 -"
- "r> 2 *"
+ "! First alternative; uses dip"
+ "[ [ 1 + ] dip 1 - dip ] 2 *"
"! Second alternative: uses tri*"
- "[ 1 + ]"
- "[ 1 - ]"
- "[ 2 * ] tri*"
+ "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
$nl
{ $subsection both? }
{ $subsection either? } ;
-ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
+ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
+$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip }
{ $subsection 2dip }
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
{ $code
": keep ( x quot -- x )"
- " over >r call r> ; inline"
+ " over [ call ] dip ; inline"
}
"Word inlining is documented in " { $link "declarations" } "." ;
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
+{ $subsection "slip-keep-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
-{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
-sequences.private ;
+sequences.private accessors ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
! Regression
: (loop) ( a b c d -- )
- >r pick r> swap >r pick r> swap
- < [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline
+ [ pick ] dip swap [ pick ] dip swap
+ < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline
: loop ( obj obj -- )
- H{ } values swap >r dup length swap r> 0 -roll (loop) ;
+ H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ loop ] must-fail
[ [ sq ] tri@ ] must-infer
[ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test
+
+! Test traceback accuracy
+: last-frame ( -- pair )
+ error-continuation get call>> callstack>array 4 head* 2 tail* ;
+
+[
+ { [ 1 2 [ 3 throw ] call 4 ] 3 }
+] [
+ [ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
+ last-frame
+] unit-test
+
+[
+ { [ 1 2 [ 3 throw ] dip 4 ] 3 }
+] [
+ [ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
+ last-frame
+] unit-test
+
+[
+ { [ 1 2 3 throw [ ] call 4 ] 3 }
+] [
+ [ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
+ last-frame
+] unit-test
+
+[
+ { [ 1 2 3 throw [ ] dip 4 ] 3 }
+] [
+ [ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
+ last-frame
+] unit-test
+
+[
+ { [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
+] [
+ [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
+ last-frame
+] unit-test
USING: kernel.private slots.private classes.tuple.private ;
IN: kernel
+DEFER: dip
+DEFER: 2dip
+DEFER: 3dip
+
! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline
-: roll ( x y z t -- y z t x ) >r rot r> swap ; inline
+: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline
-: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
+: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline
: 2over ( x y z -- x y z x y ) pick pick ; inline
pick [ roll 2drop call ] [ 2nip call ] if ; inline
! Slippers
-: slip ( quot x -- x ) >r call r> ; inline
-
-: 2slip ( quot x y -- x y ) >r >r call r> r> ; inline
-
-: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
+: slip ( quot x -- x )
+ #! 'slip' and 'dip' can be defined in terms of each other
+ #! because the JIT special-cases a 'dip' preceeded by
+ #! a literal quotation.
+ [ call ] dip ;
+
+: 2slip ( quot x y -- x y )
+ #! '2slip' and '2dip' can be defined in terms of each other
+ #! because the JIT special-cases a '2dip' preceeded by
+ #! a literal quotation.
+ [ call ] 2dip ;
+
+: 3slip ( quot x y z -- x y z )
+ #! '3slip' and '3dip' can be defined in terms of each other
+ #! because the JIT special-cases a '3dip' preceeded by
+ #! a literal quotation.
+ [ call ] 3dip ;
: dip ( x quot -- x ) swap slip ; inline
-: 2dip ( x y quot -- x y ) swap >r dip r> ; inline
+: 2dip ( x y quot -- x y ) -rot 2slip ; inline
-: 3dip ( x y z quot -- x y z ) swap >r 2dip r> ; inline
+: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
! Keepers
-: keep ( x quot -- x ) dupd dip ; inline
+: keep ( x quot -- x ) over slip ; inline
-: 2keep ( x y quot -- x y ) >r 2dup r> 2dip ; inline
+: 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline
-: 3keep ( x y z quot -- x y z ) >r 3dup r> 3dip ; inline
+: 3keep ( x y z quot -- x y z ) [ 3dup ] dip 3dip ; inline
! Cleavers
: bi ( x p q -- )
- >r keep r> call ; inline
+ [ keep ] dip call ; inline
: tri ( x p q r -- )
- >r >r keep r> keep r> call ; inline
+ [ [ keep ] dip keep ] dip call ; inline
! Double cleavers
: 2bi ( x y p q -- )
- >r 2keep r> call ; inline
+ [ 2keep ] dip call ; inline
: 2tri ( x y p q r -- )
- >r >r 2keep r> 2keep r> call ; inline
+ [ [ 2keep ] dip 2keep ] dip call ; inline
! Triple cleavers
: 3bi ( x y z p q -- )
- >r 3keep r> call ; inline
+ [ 3keep ] dip call ; inline
: 3tri ( x y z p q r -- )
- >r >r 3keep r> 3keep r> call ; inline
+ [ [ 3keep ] dip 3keep ] dip call ; inline
! Spreaders
: bi* ( x y p q -- )
- >r dip r> call ; inline
+ [ dip ] dip call ; inline
: tri* ( x y z p q r -- )
- >r >r 2dip r> dip r> call ; inline
+ [ [ 2dip ] dip dip ] dip call ; inline
! Double spreaders
: 2bi* ( w x y z p q -- )
- >r 2dip r> call ; inline
+ [ 2dip ] dip call ; inline
! Appliers
: bi@ ( x y quot -- )
dup slip swap [ loop ] [ drop ] if ; inline recursive
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
- >r >r dup slip r> r> roll
- [ >r tuck 2slip r> while ]
+ [ dup slip ] 2dip roll
+ [ [ tuck 2slip ] dip while ]
[ 2nip call ] if ; inline recursive
! Object protocol
: either? ( x y quot -- ? ) bi@ or ; inline
: most ( x y quot -- z )
- >r 2dup r> call [ drop ] [ nip ] if ; inline
+ [ 2dup ] dip call [ drop ] [ nip ] if ; inline
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
lexer new-lexer ;
: skip ( i seq ? -- n )
- >r tuck r>
+ [ tuck ] dip
[ swap CHAR: \s eq? xor ] curry find-from drop
[ ] [ length ] ?if ;
: unexpected-eof ( word -- * ) f unexpected ;
+: expect ( token -- )
+ scan
+ [ 2dup = [ 2drop ] [ unexpected ] if ]
+ [ unexpected-eof ]
+ if* ;
+
: (parse-tokens) ( accum end -- accum )
scan 2dup = [
2drop
M: fixnum - fixnum- ;
M: fixnum * fixnum* ;
M: fixnum /i fixnum/i ;
-M: fixnum /f >r >float r> >float float/f ;
+M: fixnum /f [ >float ] dip >float float/f ;
M: fixnum mod fixnum-mod ;
M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum )
- dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
+ dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ;
inline recursive
M: fixnum (log2) 0 swap (fixnum-log2) ;
: pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ -
- tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
+ tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
-rot ; inline
! Second step: loop
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
- [ >r shift-mantissa r> ]
+ [ [ shift-mantissa ] dip ]
[ ] while /mod ; inline
! Third step: post-scaling
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
- >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
+ [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
: post-scale ( scale mantissa -- n )
2/ dup log2 52 > [ shift-mantissa ] when
2dup >= [
drop
] [
- >r 1 shift r> (next-power-of-2)
+ [ 1 shift ] dip (next-power-of-2)
] if ;
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
: iterate-prep 0 -rot ; inline
-: if-iterate? >r >r 2over < r> r> if ; inline
+: if-iterate? [ 2over < ] 2dip if ; inline
: iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n.
- swap >r 2dup 2slip r> swap ; inline
+ swap [ 2dup 2slip ] dip swap ; inline
-: iterate-next >r >r 1+ r> r> ; inline
+: iterate-next [ 1+ ] 2dip ; inline
PRIVATE>
2dup 2slip rot [
drop
] [
- >r 1- r> find-last-integer
+ [ 1- ] dip find-last-integer
] if
] if ; inline recursive
: (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n )
- sign split1 >r (base>) r>
+ sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"-" ?head dup negative? set swap
- "/" split1 (base>) >r whole-part r>
+ "/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: valid-digits? ( seq -- ? )
{
{
[ CHAR: e over member? ]
- [ "e" split1 >r fix-float "e" r> 3append ]
+ [ "e" split1 [ fix-float "e" ] dip 3append ]
} {
[ CHAR: . over member? ]
[ ]
: off ( variable -- ) f swap set ; inline
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
-: change ( variable quot -- ) >r dup get r> rot slip set ; inline
+: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
H{ } clone >n call ndrop ; inline
: with-variable ( value key quot -- )
- >r associate >n r> call ndrop ; inline
+ [ associate >n ] dip call ndrop ; inline
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
-vocabs.loader accessors eval combinators ;
+vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
[
[ error>> error>> def>> \ blah eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
+
+[ "CHAR: \\u9999999999999" eval ] must-fail
: location ( -- loc )
file get lexer get line>> 2dup and
- [ >r path>> r> 2array ] [ 2drop f ] if ;
+ [ [ path>> ] dip 2array ] [ 2drop f ] if ;
: save-location ( definition -- )
location remember-definition ;
} cond ;
: (parse-until) ( accum end -- accum )
- dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ;
+ [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
: parse-until ( end -- vec )
100 <vector> swap (parse-until) ;
lexer-factory get call (parse-lines) ;
: parse-literal ( accum end quot -- accum )
- >r parse-until r> call parsed ; inline
+ [ parse-until ] dip call parsed ; inline
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
-! [ 1 \ + curry ] must-fail
+[ 1 \ + curry ] must-fail
M: curry length quot>> length 1+ ;
M: curry nth
- over zero? [ nip obj>> literalize ] [ >r 1- r> quot>> nth ] if ;
+ over 0 =
+ [ nip obj>> literalize ]
+ [ [ 1- ] dip quot>> nth ]
+ if ;
INSTANCE: curry immutable-sequence
GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq )
- over >r >r new-sequence r> call r> like ; inline
+ over [ [ new-sequence ] dip call ] dip like ; inline
M: sequence like drop ;
[ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
- [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
- >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
+ [ tuck [ nth-unsafe ] 2bi@ ]
+ [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
: (head) ( seq n -- from to seq ) 0 spin ; inline
: (tail) ( seq n -- from to seq ) over length rot ; inline
-: from-end >r dup length r> - ; inline
+: from-end [ dup length ] dip - ; inline
: (2sequence)
tuck 1 swap set-nth-unsafe
{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
- [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
+ [ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline
-ERROR: slice-error reason ;
+ERROR: slice-error from to seq reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
: prepare-subseq ( from to seq -- dst i src j n )
#! The check-length call forces partial dispatch
- [ >r swap - r> new-sequence dup 0 ] 3keep
+ [ [ swap - ] dip new-sequence dup 0 ] 3keep
-rot drop roll length check-length ; inline
: check-copy ( src n dst -- )
over 0 < [ bounds-error ] when
- >r swap length + r> lengthen ; inline
+ [ swap length + ] dip lengthen ; inline
PRIVATE>
: copy ( src i dst -- )
#! The check-length call forces partial dispatch
- pick length check-length >r 3dup check-copy spin 0 r>
+ pick length check-length [ 3dup check-copy spin 0 ] dip
(copy) drop ; inline
M: sequence clone-like
- >r dup length r> new-sequence [ 0 swap copy ] keep ;
+ [ dup length ] dip new-sequence [ 0 swap copy ] keep ;
M: immutable-sequence clone-like like ;
<PRIVATE
-: ((append)) ( seq1 seq2 accum -- accum )
- [ >r over length r> copy ]
- [ 0 swap copy ]
+: (append) ( seq1 seq2 accum -- accum )
+ [ [ over length ] dip copy ]
+ [ 0 swap copy ]
[ ] tri ; inline
-: (append) ( seq1 seq2 exemplar -- newseq )
- >r over length over length + r>
- [ ((append)) ] new-like ; inline
+PRIVATE>
-: (3append) ( seq1 seq2 seq3 exemplar -- newseq )
- >r pick length pick length pick length + + r> [
- [ >r pick length pick length + r> copy ]
- [ ((append)) ] bi
- ] new-like ; inline
+: append-as ( seq1 seq2 exemplar -- newseq )
+ [ over length over length + ] dip
+ [ (append) ] new-like ; inline
-PRIVATE>
+: 3append-as ( seq1 seq2 seq3 exemplar -- newseq )
+ [ pick length pick length pick length + + ] dip [
+ [ [ pick length pick length + ] dip copy ]
+ [ (append) ] bi
+ ] new-like ; inline
-: append ( seq1 seq2 -- newseq ) over (append) ;
+: append ( seq1 seq2 -- newseq ) over append-as ;
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
-: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
+: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ;
: change-nth ( i seq quot -- )
- [ >r nth r> call ] 3keep drop set-nth ; inline
+ [ [ nth ] dip call ] 3keep drop set-nth ; inline
: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
<PRIVATE
: (each) ( seq quot -- n quot' )
- >r dup length swap [ nth-unsafe ] curry r> compose ; inline
+ [ dup length swap [ nth-unsafe ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' )
- [ >r keep r> set-nth-unsafe ] 2curry ; inline
+ [ [ keep ] dip set-nth-unsafe ] 2curry ; inline
: collect ( n quot into -- )
(collect) each-integer ; inline
: map-into ( seq quot into -- )
- >r (each) r> collect ; inline
+ [ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
- >r over r> nth-unsafe >r nth-unsafe r> ; inline
+ [ over ] dip nth-unsafe [ nth-unsafe ] dip ; inline
: (2each) ( seq1 seq2 quot -- n quot' )
- >r [ min-length ] 2keep r>
- [ >r 2nth-unsafe r> call ] 3curry ; inline
+ [ [ min-length ] 2keep ] dip
+ [ [ 2nth-unsafe ] dip call ] 3curry ; inline
: 2map-into ( seq1 seq2 quot into -- newseq )
- >r (2each) r> collect ; inline
+ [ (2each) ] dip collect ; inline
: finish-find ( i seq -- i elt )
over [ dupd nth-unsafe ] [ drop f ] if ; inline
: (find) ( seq quot quot' -- i elt )
- pick >r >r (each) r> call r> finish-find ; inline
+ pick [ [ (each) ] dip call ] dip finish-find ; inline
: (find-from) ( n seq quot quot' -- i elt )
[ 2dup bounds-check? ] 2dip
swapd each ; inline
: map-as ( seq quot exemplar -- newseq )
- >r over length r> [ [ map-into ] keep ] new-like ; inline
+ [ over length ] dip [ [ map-into ] keep ] new-like ; inline
: map ( seq quot -- newseq )
over map-as ; inline
[ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
- >r [ drop ] prepose r> map-as ; inline
+ [ [ drop ] prepose ] dip map-as ; inline
: change-each ( seq quot -- )
over map-into ; inline
(2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- )
- >r [ <reversed> ] bi@ r> 2each ; inline
+ [ [ <reversed> ] bi@ ] dip 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result )
- >r -rot r> 2each ; inline
+ [ -rot ] dip 2each ; inline
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
- >r 2over min-length r>
+ [ 2over min-length ] dip
[ [ 2map-into ] keep ] new-like ; inline
: 2map ( seq1 seq2 quot -- newseq )
[ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt )
- [ >r 1- r> find-last-integer ] (find) ; inline
+ [ [ 1- ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? )
(each) all-integers? ; inline
: push-if ( elt quot accum -- )
- >r keep r> rot [ push ] [ 2drop ] if ; inline
+ [ keep ] dip rot [ push ] [ 2drop ] if ; inline
: pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline
: filter ( seq quot -- subseq )
- over >r pusher >r each r> r> like ; inline
+ over [ pusher [ each ] dip ] dip like ; inline
: push-either ( elt quot accum1 accum2 -- )
- >r >r keep swap r> r> ? push ; inline
+ [ keep swap ] 2dip ? push ; inline
: 2pusher ( quot -- quot accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
- over >r 2pusher >r >r each r> r> r> tuck [ like ] 2bi@ ; inline
+ over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
: monotonic? ( seq quot -- ? )
- >r dup length 1- swap r> (monotonic) all? ; inline
+ [ dup length 1- swap ] dip (monotonic) all? ; inline
: interleave ( seq between quot -- )
- [ (interleave) ] 2curry >r dup length swap r> 2each ; inline
+ [ (interleave) ] 2curry [ dup length swap ] dip 2each ; inline
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
: produce-as ( pred quot tail exemplar -- seq )
- >r swap accumulator >r swap while r> r> like ; inline
+ [ swap accumulator [ swap while ] dip ] dip like ; inline
: produce ( pred quot tail -- seq )
{ } produce-as ; inline
: follow ( obj quot -- seq )
- >r [ dup ] r> [ keep ] curry [ ] produce nip ; inline
+ [ dup ] swap [ keep ] curry [ ] produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
- >r dup length r> ; inline
+ [ dup length ] dip ; inline
: each-index ( seq quot -- )
prepare-index 2each ; inline
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
- >r 3drop r>
+ [ 3drop ] dip
] [
- drop swap >r over >r call dup r> r> set-nth
+ drop swap [ over [ call dup ] dip ] dip set-nth
] if ; inline
: mismatch ( seq1 seq2 -- i )
[ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq )
- over >r over length 1+ r> [
+ over [ over length 1+ ] dip [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
: suffix ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ >r over length r> set-nth-unsafe ] keep
+ over [ over length 1+ ] dip [
+ [ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
2over = [
2drop 2drop
] [
- [ >r 2over + pick r> move >r 1+ r> ] keep
+ [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
move-backward
] if ;
2over = [
2drop 2drop
] [
- [ >r pick >r dup dup r> + swap r> move 1- ] keep
+ [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
move-forward
] if ;
: (open-slice) ( shift from to seq ? -- )
[
- >r [ 1- ] bi@ r> move-forward
+ [ [ 1- ] bi@ ] dip move-forward
] [
- >r >r over - r> r> move-backward
+ [ over - ] 2dip move-backward
] if ;
PRIVATE>
pick 0 = [
3drop
] [
- pick over length + over >r >r
- pick 0 > >r [ length ] keep r> (open-slice)
- r> r> set-length
+ pick over length + over
+ [ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip
+ set-length
] if ;
: delete-slice ( from to seq -- )
- check-slice >r over >r - r> r> open-slice ;
+ check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
- >r dup 1+ r> delete-slice ;
+ [ dup 1+ ] dip delete-slice ;
: replace-slice ( new from to seq -- )
- [ >r >r dup pick length + r> - over r> open-slice ] keep
+ [ [ [ dup pick length + ] dip - over ] dip open-slice ] keep
copy ;
: remove-nth ( n seq -- seq' )
: reverse-here ( seq -- )
dup length dup 2/ [
- >r 2dup r>
+ [ 2dup ] dip
tuck - 1- rot exchange-unsafe
] each 2drop ;
<PRIVATE
: joined-length ( seq glue -- n )
- >r dup sum-lengths swap length 1 [-] r> length * + ;
+ [ dup sum-lengths swap length 1 [-] ] dip length * + ;
PRIVATE>
] dip compose if ; inline
: pad-left ( seq n elt -- padded )
- [ swap dup (append) ] padding ;
+ [ swap dup append-as ] padding ;
: pad-right ( seq n elt -- padded )
[ append ] padding ;
>fixnum {
[ drop nip ]
[ 2drop first ]
- [ >r drop first2 r> call ]
- [ >r drop first3 r> bi@ ]
+ [ [ drop first2 ] dip call ]
+ [ [ drop first3 ] dip bi@ ]
} dispatch
] [
drop
- >r >r halves r> r>
+ [ halves ] 2dip
[ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline recursive
: (start) ( subseq seq n -- subseq seq ? )
pick length [
- >r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe =
+ [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
] all? nip ; inline
PRIVATE>
: start* ( subseq seq n -- i )
pick length pick length swap - 1+
[ (start) ] find-from
- swap >r 3drop r> ;
+ swap [ 3drop ] dip ;
: start ( subseq seq -- i ) 0 start* ; inline
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless*
- tuck tail-slice >r tail-slice r> ;
+ tuck [ tail-slice ] 2bi@ ;
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
inline
: trim-left-slice ( seq quot -- slice )
- over >r [ not ] compose find drop r> swap
+ over [ [ not ] compose find drop ] dip swap
[ tail-slice ] [ dup length tail-slice ] if* ; inline
: trim-left ( seq quot -- newseq )
over [ trim-left-slice ] dip like ; inline
: trim-right-slice ( seq quot -- slice )
- over >r [ not ] compose find-last drop r> swap
+ over [ [ not ] compose find-last drop ] dip swap
[ 1+ head-slice ] [ 0 head-slice ] if* ; inline
: trim-right ( seq quot -- newseq )
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings words effects generic generic.standard
classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien ;
+words sequences.private assocs alien quotations ;
IN: slots
TUPLE: slot-spec name offset class initial read-only ;
3bi ;
: create-accessor ( name effect -- word )
- >r "accessors" create dup r>
+ [ "accessors" create dup ] dip
"declared-effect" set-word-prop ;
: reader-quot ( slot-spec -- quot )
offset>> , \ set-slot , ;
: writer-quot/coerce ( slot-spec -- )
- [ \ >r , class>> "coercer" word-prop % \ r> , ]
+ [ class>> "coercer" word-prop [ dip ] curry % ]
[ offset>> , \ set-slot , ]
bi ;
bi ;
: writer-quot/fixnum ( slot-spec -- )
- [ >r >fixnum r> ] % writer-quot/check ;
+ [ [ >fixnum ] dip ] % writer-quot/check ;
: writer-quot ( slot-spec -- quot )
[
: define-changer ( name -- )
dup changer-word dup deferred? [
[
- [ over >r >r ] %
- over reader-word ,
- [ r> call r> swap ] %
+ \ over ,
+ over reader-word 1quotation
+ [ dip call ] curry [ dip swap ] curry %
swap setter-word ,
] [ ] make define-inline
] [ 2drop ] if ;
: dump ( from to seq accum -- )
#! Optimize common case where to - from = 1, 2, or 3.
- >r >r 2dup swap - r> r> pick 1 =
- [ >r >r 2drop r> nth-unsafe r> push ] [
+ [ 2dup swap - ] 2dip pick 1 =
+ [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [
- >r >r 2drop dup 1+
- r> [ nth-unsafe ] curry bi@
- r> [ push ] curry bi@
+ [
+ [ 2drop dup 1+ ] dip
+ [ nth-unsafe ] curry bi@
+ ] dip [ push ] curry bi@
] [
pick 3 = [
- >r >r 2drop dup 1+ dup 1+
- r> [ nth-unsafe ] curry tri@
- r> [ push ] curry tri@
- ] [
- >r nip subseq r> push-all
- ] if
+ [
+ [ 2drop dup 1+ dup 1+ ] dip
+ [ nth-unsafe ] curry tri@
+ ] dip [ push ] curry tri@
+ ] [ [ nip subseq ] dip push-all ] if
] if
] if ; inline
{ $subsection ?tail }
{ $subsection ?tail-slice }
{ $subsection split1 }
+{ $subsection split1-slice }
+{ $subsection split1-last }
+{ $subsection split1-last-slice }
{ $subsection split }
"Splitting a string into lines:"
{ $subsection string-lines } ;
{ $values { "seq" "a sequence" } { "subseq" "a sequence" } { "before" "a new sequence" } { "after" "a new sequence" } }
{ $description "Splits " { $snippet "seq" } " at the first occurrence of " { $snippet "subseq" } ", and outputs the pieces before and after the split. If " { $snippet "subseq" } " does not occur in " { $snippet "seq" } ", then " { $snippet "before" } " is just " { $snippet "seq" } " and " { $snippet "after" } " is " { $link f } "." } ;
-HELP: last-split1
+HELP: split1-slice
+{ $values { "seq" "a sequence" } { "subseq" "a sequence" } { "before-slice" slice } { "after-slice" slice } }
+{ $description "Splits " { $snippet "seq" } " at the first occurrence of " { $snippet "subseq" } ", and outputs the pieces before and after the split as slices. If " { $snippet "subseq" } " does not occur in " { $snippet "seq" } ", then " { $snippet "before" } " is just " { $snippet "seq" } " and " { $snippet "after" } " is " { $link f } "." } ;
+
+HELP: split1-last
{ $values { "seq" "a sequence" } { "subseq" "a sequence" } { "before" "a new sequence" } { "after" "a new sequence" } }
{ $description "Splits " { $snippet "seq" } " at the last occurrence of " { $snippet "subseq" } ", and outputs the pieces before and after the split. If " { $snippet "subseq" } " does not occur in " { $snippet "seq" } ", then " { $snippet "before" } " is just " { $snippet "seq" } " and " { $snippet "after" } " is " { $link f } "." } ;
-{ split1 last-split1 } related-words
+HELP: split1-last-slice
+{ $values { "seq" "a sequence" } { "subseq" "a sequence" } { "before-slice" slice } { "after-slice" slice } }
+{ $description "Splits " { $snippet "seq" } " at the last occurrence of " { $snippet "subseq" } ", and outputs the pieces before and after the split as slices. If " { $snippet "subseq" } " does not occur in " { $snippet "seq" } ", then " { $snippet "before" } " is just " { $snippet "seq" } " and " { $snippet "after" } " is " { $link f } "." } ;
+
+{ split1 split1-slice split1-last split1-last-slice } related-words
HELP: split
{ $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } }
-USING: splitting tools.test kernel sequences arrays ;
+USING: splitting tools.test kernel sequences arrays strings ;
IN: splitting.tests
[ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test
[ "goodbye" f ] [ "goodbye" " " split1 ] unit-test
[ "" "" ] [ "great" "great" split1 ] unit-test
-[ "hello world" "." ] [ "hello world ." " " last-split1 ] unit-test
-[ "hello-+world" "." ] [ "hello-+world-+." "-+" last-split1 ] unit-test
-[ "goodbye" f ] [ "goodbye" " " last-split1 ] unit-test
-[ "" "" ] [ "great" "great" last-split1 ] unit-test
+[ "hello world" "." ] [ "hello world ." " " split1-last ] unit-test
+[ "hello-+world" "." ] [ "hello-+world-+." "-+" split1-last ] unit-test
+[ "goodbye" f ] [ "goodbye" " " split1-last ] unit-test
+[ "" "" ] [ "great" "great" split1-last ] unit-test
+
+[ "hello world" "." ] [ "hello world ." " " split1-last-slice [ >string ] bi@ ] unit-test
+[ "hello-+world" "." ] [ "hello-+world-+." "-+" split1-last-slice [ >string ] bi@ ] unit-test
+[ "goodbye" f ] [ "goodbye" " " split1-last-slice [ >string ] dip ] unit-test
+[ "" f ] [ "great" "great" split1-last-slice [ >string ] dip ] unit-test
[ "and end" t ] [ "Beginning and end" "Beginning " ?head ] unit-test
[ "Beginning and end" f ] [ "Beginning and end" "Beginning x" ?head ] unit-test
: split1 ( seq subseq -- before after )
dup pick start dup [
- [ >r over r> head -rot length ] keep + tail
+ [ [ over ] dip head -rot length ] keep + tail
] [
2drop f
] if ;
-: last-split1 ( seq subseq -- before after )
+: split1-slice ( seq subseq -- before-slice after-slice )
+ dup pick start dup [
+ [ [ over ] dip head-slice -rot length ] keep + tail-slice
+ ] [
+ 2drop f
+ ] if ;
+
+: split1-last ( seq subseq -- before after )
[ <reversed> ] bi@ split1 [ reverse ] bi@
dup [ swap ] when ;
+: split1-last-slice ( seq subseq -- before-slice after-slice )
+ [ <reversed> ] bi@ split1-slice [ <reversed> ] bi@
+ [ f ] [ swap ] if-empty ;
+
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ]
: unicode-escape ( str -- ch str' )
"{" ?head-slice [
CHAR: } over index cut-slice
- >r >string name>char-hook get call r>
+ [ >string name>char-hook get call ] dip
rest-slice
] [
- 6 cut-slice >r hex> r>
+ 6 cut-slice [ hex> ] dip
] if ;
: next-escape ( str -- ch str' )
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
- >r cut-slice >r % r> rest-slice r>
+ [ cut-slice [ % ] dip rest-slice ] dip
dup CHAR: " = [
drop from>>
] [
- drop next-escape >r , r> (parse-string)
+ drop next-escape [ , ] dip (parse-string)
] if
] [
"Unterminated string" throw
length>> ;
M: string nth-unsafe
- >r >fixnum r> string-nth ;
+ [ >fixnum ] dip string-nth ;
M: string set-nth-unsafe
dup reset-string-hashcode
- >r >fixnum >r >fixnum r> r> set-string-nth ;
+ [ [ >fixnum ] dip >fixnum ] dip set-string-nth ;
M: string clone
(clone) [ clone ] change-aux ;
"syntax" lookup t "delimiter" set-word-prop ;
: define-syntax ( name quot -- )
- >r "syntax" lookup dup r> define t "parsing" set-word-prop ;
+ [ "syntax" lookup dup ] dip define t "parsing" set-word-prop ;
[
{ "]" "}" ";" ">>" } [ define-delimiter ] each
"CHAR:" [
scan {
{ [ dup length 1 = ] [ first ] }
- { [ "\\" ?head ] [ next-escape drop ] }
+ { [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call ]
} cond parsed
] define-syntax
] define-syntax
"INSTANCE:" [
- location >r
- scan-word scan-word 2dup add-mixin-instance
- <mixin-instance> r> remember-definition
+ location [
+ scan-word scan-word 2dup add-mixin-instance
+ <mixin-instance>
+ ] dip remember-definition
] define-syntax
"PREDICATE:" [
] define-syntax
"call-next-method" [
- current-class get current-generic get
- 2dup [ word? ] both? [
- [ literalize parsed ] bi@
+ current-method get [
+ literalize parsed
\ (call-next-method) parsed
] [
not-in-a-method-error
- ] if
+ ] if*
] define-syntax
"initial:" "syntax" lookup define-symbol
{ $subsection vm }
{ $subsection image }
"Getting the current time:"
+{ $subsection micros }
{ $subsection millis }
"Exiting the Factor VM:"
{ $subsection exit } ;
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
-HELP: millis ( -- n )
-{ $values { "n" integer } }
+HELP: micros ( -- us )
+{ $values { "us" integer } }
+{ $description "Outputs the number of microseconds ellapsed since midnight January 1, 1970." }
+{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
+
+HELP: millis ( -- ms )
+{ $values { "ms" integer } }
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
] "system" add-init-hook
: embedded? ( -- ? ) 15 getenv ;
+
+: millis ( -- ms ) micros 1000 /i ;
[ t ] [
V{ 1 2 3 4 } dup underlying>> length
- >r clone underlying>> length r>
+ [ clone underlying>> length ] dip
=
] unit-test
[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [
- 100 >array dup >vector <reversed> >array >r reverse r> =
+ 100 >array dup >vector <reversed> >array [ reverse ] dip =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
-USING: vocabs help.markup help.syntax words strings io ;
+USING: vocabs vocabs.loader.private help.markup help.syntax
+words strings io ;
IN: vocabs.loader
ARTICLE: "vocabs.roots" "Vocabulary roots"
2 [
[ "vocabs.loader.test.a" require ] must-fail
- [ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test
+ [ f ] [ "vocabs.loader.test.a" vocab source-loaded?>> ] unit-test
[ t ] [
"resource:core/vocabs/loader/test/a/a.factor"
] with-compilation-unit
] unit-test
-[ t ] [
+[ +done+ ] [
[ "vocabs.loader.test.d" require ] [ :1 ] recover
- "vocabs.loader.test.d" vocab-source-loaded?
+ "vocabs.loader.test.d" vocab source-loaded?>>
] unit-test
: forget-junk
[ "vocabs.loader.test.e" require ]
[ relative-overflow? ] must-fail-with
+
+0 "vocabs.loader.test.g" set-global
+
+[
+ "vocabs.loader.test.f" forget-vocab
+ "vocabs.loader.test.g" forget-vocab
+] with-compilation-unit
+
+[ ] [ "vocabs.loader.test.g" require ] unit-test
+
+[ 1 ] [ "vocabs.loader.test.g" get-global ] unit-test
+
+[
+ "vocabs.loader.test.h" forget-vocab
+ "vocabs.loader.test.i" forget-vocab
+] with-compilation-unit
+
+[ ] [ "vocabs.loader.test.h" require ] unit-test
vocab-name { { CHAR: . CHAR: / } } substitute ;
: vocab-dir+ ( vocab str/f -- path )
- >r vocab-name "." split r>
- [ >r dup peek r> append suffix ] when*
+ [ vocab-name "." split ] dip
+ [ [ dup peek ] dip append suffix ] when*
"/" join ;
: vocab-dir? ( root name -- ? )
- over [
- ".factor" vocab-dir+ append-path exists?
- ] [
- 2drop f
- ] if ;
+ over
+ [ ".factor" vocab-dir+ append-path exists? ]
+ [ 2drop f ]
+ if ;
SYMBOL: root-cache
H{ } clone root-cache set-global
+<PRIVATE
+
: (find-vocab-root) ( name -- path/f )
vocab-roots get swap [ vocab-dir? ] curry find nip ;
+PRIVATE>
+
: find-vocab-root ( vocab -- path/f )
vocab-name dup root-cache get at [ ] [ (find-vocab-root) ] ?if ;
SYMBOL: load-help?
-: load-source ( vocab -- vocab )
- f over set-vocab-source-loaded?
- [ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
- t swap set-vocab-source-loaded?
- [ % ] [ assert-depth ] if-bootstrapping ;
+ERROR: circular-dependency name ;
-: load-docs ( vocab -- vocab )
- load-help? get [
- f over set-vocab-docs-loaded?
- [ vocab-docs-path [ ?run-file ] when* ] keep
- t swap set-vocab-docs-loaded?
- ] [ drop ] if ;
+<PRIVATE
-: reload ( name -- )
+: load-source ( vocab -- )
[
- dup vocab [ [ load-source ] [ load-docs ] bi ] [ no-vocab ] ?if
- ] with-compiler-errors ;
+ +parsing+ >>source-loaded?
+ dup vocab-source-path [ parse-file ] [ [ ] ] if*
+ [ % ] [ assert-depth ] if-bootstrapping
+ +done+ >>source-loaded? drop
+ ] [ ] [ f >>source-loaded? ] cleanup ;
+
+: load-docs ( vocab -- )
+ load-help? get [
+ [
+ +parsing+ >>docs-loaded?
+ [ vocab-docs-path [ ?run-file ] when* ] keep
+ +done+ >>docs-loaded?
+ ] [ ] [ f >>docs-loaded? ] cleanup
+ ] when drop ;
+
+PRIVATE>
: require ( vocab -- )
- load-vocab drop ;
+ [ load-vocab drop ] with-compiler-errors ;
+
+: reload ( name -- )
+ dup vocab
+ [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ]
+ [ require ]
+ ?if ;
: run ( vocab -- )
dup load-vocab vocab-main [
SYMBOL: blacklist
+<PRIVATE
+
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
M: vocab (load-vocab)
[
- dup vocab-source-loaded? [ dup load-source ] unless
- dup vocab-docs-loaded? [ dup load-docs ] unless
- drop
+ dup source-loaded?>> +parsing+ eq? [
+ dup source-loaded?>> [ dup load-source ] unless
+ dup docs-loaded?>> [ dup load-docs ] unless
+ ] unless drop
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: vocab-link (load-vocab)
[
[
- dup vocab-name blacklist get at* [
- rethrow
- ] [
- drop
- dup find-vocab-root [
- [ (load-vocab) ] with-compiler-errors
- ] [
- dup vocab [ drop ] [ no-vocab ] if
- ] if
+ dup vocab-name blacklist get at* [ rethrow ] [
+ drop dup find-vocab-root
+ [ [ (load-vocab) ] with-compiler-errors ]
+ [ dup vocab [ drop ] [ no-vocab ] if ]
+ if
] if
] with-compiler-errors
] load-vocab-hook set-global
+PRIVATE>
+
: vocab-where ( vocab -- loc )
vocab-source-path dup [ 1 2array ] when ;
--- /dev/null
+IN: vocabs.laoder.test.f
+USE: vocabs.loader
+
+"vocabs.loader.test.g" require
--- /dev/null
+unportable
--- /dev/null
+IN: vocabs.loader.test.g
+USING: vocabs.loader.test.f namespaces ;
+
+global [ "vocabs.loader.test.g" inc ] bind
--- /dev/null
+unportable
--- /dev/null
+USE: vocabs.loader.test.i
--- /dev/null
+unportable
--- /dev/null
+IN: vocabs.loader.test.i
+USE: vocabs.loader.test.h
--- /dev/null
+unportable
{ $values { "vocab-spec" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
{ $description "Outputs the words defined in a vocabulary." } ;
-HELP: vocab-source-loaded?
-{ $values { "vocab-spec" "a vocabulary specifier" } { "?" "a boolean" } }
-{ $description "Outputs if the source for this vocubulary has been loaded." } ;
-
-HELP: vocab-docs-loaded?
-{ $values { "vocab-spec" "a vocabulary specifier" } { "?" "a boolean" } }
-{ $description "Outputs if the documentation for this vocubulary has been loaded." } ;
-
HELP: words
{ $values { "vocab" string } { "seq" "a sequence of words" } }
{ $description "Outputs a sequence of words defined in the vocabulary, or " { $link f } " if no vocabulary with this name exists." } ;
main help
source-loaded? docs-loaded? ;
+! sources-loaded? slot is one of these two
+SYMBOL: +parsing+
+SYMBOL: +running+
+SYMBOL: +done+
+
: <vocab> ( name -- vocab )
\ vocab new
swap >>name
M: f vocab-main ;
-GENERIC: vocab-source-loaded? ( vocab-spec -- ? )
-
-M: vocab vocab-source-loaded? source-loaded?>> ;
-
-M: object vocab-source-loaded?
- vocab vocab-source-loaded? ;
-
-M: f vocab-source-loaded? ;
-
-GENERIC: set-vocab-source-loaded? ( ? vocab-spec -- )
-
-M: vocab set-vocab-source-loaded? (>>source-loaded?) ;
-
-M: object set-vocab-source-loaded?
- vocab set-vocab-source-loaded? ;
-
-M: f set-vocab-source-loaded? 2drop ;
-
-GENERIC: vocab-docs-loaded? ( vocab-spec -- ? )
-
-M: vocab vocab-docs-loaded? docs-loaded?>> ;
-
-M: object vocab-docs-loaded?
- vocab vocab-docs-loaded? ;
-
-M: f vocab-docs-loaded? ;
-
-GENERIC: set-vocab-docs-loaded? ( ? vocab-spec -- )
-
-M: vocab set-vocab-docs-loaded? (>>docs-loaded?) ;
-
-M: object set-vocab-docs-loaded?
- vocab set-vocab-docs-loaded? ;
-
-M: f set-vocab-docs-loaded? 2drop ;
-
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
M: array (quot-uses) seq-uses ;
-M: hashtable (quot-uses) >r >alist r> seq-uses ;
+M: hashtable (quot-uses) [ >alist ] dip seq-uses ;
M: callable (quot-uses) seq-uses ;
-M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;
+M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ;
: quot-uses ( quot -- assoc )
global [ H{ } clone [ (quot-uses) ] keep ] bind ;
bi* 2bi ;
: compiled-xref ( word dependencies generic-dependencies -- )
- [ [ drop crossref? ] assoc-filter ] bi@
+ [ [ drop crossref? ] { } assoc-filter-as f like ] bi@
[ over ] dip
[ "compiled-uses" compiled-crossref (compiled-xref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
: (compiled-unxref) ( word word-prop variable -- )
[ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
- [ drop [ f swap set-word-prop ] curry ]
+ [ drop [ remove-word-prop ] curry ]
2bi bi ;
: compiled-unxref ( word -- )
dup [ 2nip ] [ drop <word> dup reveal ] if ;
: constructor-word ( name vocab -- word )
- >r "<" swap ">" 3append r> create ;
+ [ "<" swap ">" 3append ] dip create ;
PREDICATE: parsing-word < word "parsing" word-prop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: deep-fry ( quot -- quot )
- { _ } last-split1 dup
+ { _ } split1-last dup
[
shallow-fry [ >r ] rot
deep-fry [ [ dip ] curry r> compose ] 4array concat
MACRO: fry ( seq -- quot ) [fry] ;
-: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
\ No newline at end of file
+: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger ;
+continuations debugger math ;
IN: benchmark
: run-benchmark ( vocab -- result )
standard-table-style [
[
[ "Benchmark" write ] with-cell
- [ "Time (ms)" write ] with-cell
+ [ "Time (seconds)" write ] with-cell
] with-row
[
[
[ [ 1array $vocab-link ] with-cell ]
- [ pprint-cell ] bi*
+ [ 1000000 /f pprint-cell ] bi*
] with-row
] assoc-each
] tabular-output ;
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
\r
-: fib-main ( -- ) 25 fib drop ;\r
+: fib-main ( -- ) 34 fib drop ;\r
\r
MAIN: fib-main\r
[ t ] [
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
- [ regex-dna ] with-string-writer <string-reader> lines
+ [ regex-dna ] with-string-writer
"resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
- ascii file-lines =
+ ascii file-contents =
] unit-test
: count-patterns ( string -- )
{
- R/ agggtaaa|tttaccct/i,
- R/ [cgt]gggtaaa|tttaccc[acg]/i,
- R/ a[act]ggtaaa|tttacc[agt]t/i,
- R/ ag[act]gtaaa|tttac[agt]ct/i,
- R/ agg[act]taaa|ttta[agt]cct/i,
- R/ aggg[acg]aaa|ttt[cgt]ccct/i,
- R/ agggt[cgt]aa|tt[acg]accct/i,
- R/ agggta[cgt]a|t[acg]taccct/i,
+ R/ agggtaaa|tttaccct/i
+ R/ [cgt]gggtaaa|tttaccc[acg]/i
+ R/ a[act]ggtaaa|tttacc[agt]t/i
+ R/ ag[act]gtaaa|tttac[agt]ct/i
+ R/ agg[act]taaa|ttta[agt]cct/i
+ R/ aggg[acg]aaa|ttt[cgt]ccct/i
+ R/ agggt[cgt]aa|tt[acg]accct/i
+ R/ agggta[cgt]a|t[acg]taccct/i
R/ agggtaa[cgt]|[acg]ttaccct/i
} [
[ raw>> write bl ]
-USING: combinators.short-circuit kernel namespaces
+USING: kernel namespaces
math
math.constants
math.functions
math.physics.vel
combinators arrays sequences random vars
combinators.lib
+ combinators.short-circuit
accessors ;
IN: boids
2&& ;
: alignment-neighborhood ( self -- boids )
-boids> [ within-alignment-neighborhood? ] with filter ;
+ boids> [ within-alignment-neighborhood? ] with filter ;
: alignment-force ( self -- force )
alignment-neighborhood
: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
-: cfdg-window* ( -- )
+: cfdg-window* ( -- slate )
C[ display ] <slate>
{ 500 500 } >>pdim
C[ delete-dlist ] >>ungraft
dup "CFDG" open-window ;
-: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
+: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: kernel math threads system ;
+USING: kernel math threads system calendar ;
IN: crypto.timing
: with-timing ( quot n -- )
#! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + sleep ; inline
+ millis 2slip millis - + milliseconds sleep ; inline
+++ /dev/null
-
-USING: kernel namespaces sequences math
- listener io prettyprint sequences.lib bake bake.fry ;
-
-IN: display-stack
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: watched-variables
-
-: watch-var ( sym -- ) watched-variables get push ;
-
-: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
-
-: unwatch-var ( sym -- ) watched-variables get delete ;
-
-: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
-
-: print-watched-variables ( -- )
- watched-variables get length 0 >
- [
- "----------" print
- watched-variables get
- watched-variables get [ unparse ] map longest length 2 +
- '[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
- each
-
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: display-stack ( -- )
- V{ } clone watched-variables set
- [
- print-watched-variables
- "----------" print
- datastack [ . ] each
- "----------" print
- retainstack reverse [ . ] each
- ]
- listener-hook set ;
-
USING: tools.deploy.config ;
H{
- { deploy-c-types? f }
- { deploy-name "Hello world (console)" }
{ deploy-threads? f }
+ { deploy-name "Hello world (console)" }
+ { deploy-word-defs? f }
{ deploy-word-props? f }
- { deploy-reflection 2 }
- { deploy-io 2 }
- { deploy-math? f }
{ deploy-ui? f }
{ deploy-compiler? f }
+ { deploy-io 2 }
+ { deploy-math? f }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
{ "stop-after-last-window?" t }
- { deploy-word-defs? f }
+ { deploy-c-types? f }
}
] unit-test
] with-irc
+[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+ ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+ ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+ participants>>
+ ] unit-test
+] with-irc
+
! Namelist change notification
[ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
+
+! Mode change
+[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircserver.net MODE #factortest +o ircuser" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
-TUPLE: irc-channel-chat < irc-chat name password timeout participants ;
+TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
<mailbox> f irc-server-chat boa ;
: <irc-channel-chat> ( name -- irc-channel-chat )
- [ <mailbox> f ] dip f 60 seconds H{ } clone
+ [ <mailbox> f ] dip f 60 seconds H{ } clone t
irc-channel-chat boa ;
: <irc-nick-chat> ( name -- irc-nick-chat )
: change-participant-mode ( channel mode nick -- )
rot chat>
[ participants>> set-at ]
- [ [ [ +mode+ ] dip <participant-changed> ] dip to-chat ] 3bi ; ! FIXME
+ [ [ participant-changed new
+ [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
+ 3bi ; ! FIXME
DEFER: me?
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
M: logged-in process-message
- name>> f irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
+ name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
values [ initialize-chat ] each ;
M: ping process-message trailing>> /PONG ;
M: nick-in-use process-message name>> "_" append /NICK ;
M: nick process-message
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
-! M: mode process-message ( mode -- )
-! [ channel-mode? ] keep and [
-! [ name>> ] [ mode>> ] [ parameter>> ] tri
-! [ change-participant-mode ] [ 2drop ] if*
-! ] when* ;
+M: mode process-message ( mode -- )
+ [ channel-mode? ] keep and [
+ [ name>> ] [ mode>> ] [ parameter>> ] tri
+ [ change-participant-mode ] [ 2drop ] if*
+ ] when* ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
+: maybe-clean-participants ( channel-chat -- )
+ dup clean-participants>> [
+ H{ } clone >>participants f >>clean-participants
+ ] when drop ;
+
M: names-reply process-message
[ names-reply>participants ] [ channel>> chat> ] bi [
- [ (>>participants) ]
- [ [ f f f <participant-changed> ] dip name>> to-chat ] bi
+ [ maybe-clean-participants ]
+ [ participants>> 2array assoc-combine ]
+ [ (>>participants) ] tri
] [ drop ] if* ;
+M: end-of-names process-message
+ channel>> chat> [
+ t >>clean-participants
+ [ f f f <participant-changed> ] dip name>> to-chat
+ ] when* ;
+
! ======================================
! Client message handling
! ======================================
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who channel ;
+TUPLE: end-of-names < irc-message who channel ;
TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message )
M: names-reply >>command-parameters ( names-reply params -- names-reply )
first3 nip [ >>who ] [ >>channel ] bi* ;
+M: end-of-names >>command-parameters ( names-reply params -- names-reply )
+ first2 [ >>who ] [ >>channel ] bi* ;
+
M: mode >>command-parameters ( mode params -- mode )
dup length 3 = [
first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
{ "001" [ logged-in ] }
{ "433" [ nick-in-use ] }
{ "353" [ names-reply ] }
+ { "366" [ end-of-names ] }
{ "JOIN" [ join ] }
{ "PART" [ part ] }
{ "NICK" [ nick ] }
\r
IN: irc.ui.commandparser\r
\r
-"irc.ui.commands" require\r
-\r
: command ( string string -- string command )\r
[ "say" ] when-empty\r
dup "irc.ui.commands" lookup\r
! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
-USING: accessors kernel arrays irc.client irc.messages irc.ui namespaces ;\r
+USING: accessors kernel sequences arrays irc.client\r
+ irc.messages irc.ui namespaces ;\r
\r
IN: irc.ui.commands\r
\r
[ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
[ chat>> speak ] 2bi ;\r
\r
+: me ( string -- ) ! Placeholder until I make /me look different\r
+ "ACTION " 1 prefix prepend 1 suffix say ;\r
+\r
: join ( string -- )\r
irc-tab get window>> join-channel ;\r
\r
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
io io.styles namespaces calendar calendar.format models continuations\r
irc.client irc.client.private irc.messages\r
- irc.ui.commandparser irc.ui.load ;\r
+ irc.ui.commandparser irc.ui.load vocabs.loader ;\r
\r
RENAME: join sequences => sjoin\r
\r
: main-run ( -- ) run-ircui ;\r
\r
MAIN: main-run\r
+\r
+"irc.ui.commands" require\r
] [
[ jamshred>> jamshred-update ]
[ relayout-1 ]
- [ 10 sleep yield jamshred-loop ] tri
+ [ 10 milliseconds sleep yield jamshred-loop ] tri
] if ;
: fullscreen ( gadget -- )
USING: kernel namespaces assocs io.files io.encodings.utf8
prettyprint help.lint benchmark tools.time bootstrap.stage2
tools.test tools.vocabs help.html mason.common words generic
-accessors compiler.errors sequences sets sorting ;
+accessors compiler.errors sequences sets sorting math ;
IN: mason.test
: do-load ( -- )
: do-benchmarks ( -- )
run-benchmarks benchmarks-file to-file ;
+: benchmark-ms ( quot -- ms )
+ benchmark 1000 /i ; inline
+
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
- [ do-load do-compile-errors ] benchmark load-time-file to-file
- [ generate-help ] benchmark html-help-time-file to-file
- [ do-tests ] benchmark test-time-file to-file
- [ do-help-lint ] benchmark help-lint-time-file to-file
- [ do-benchmarks ] benchmark benchmark-time-file to-file
+ [ do-load do-compile-errors ] benchmark-ms load-time-file to-file
+ [ generate-help ] benchmark-ms html-help-time-file to-file
+ [ do-tests ] benchmark-ms test-time-file to-file
+ [ do-help-lint ] benchmark-ms help-lint-time-file to-file
+ [ do-benchmarks ] benchmark-ms benchmark-time-file to-file
] with-directory ;
MAIN: do-all
\ No newline at end of file
+++ /dev/null
-Phil Dawes
+++ /dev/null
-IN: micros.backend
-USING: io.backend ;
-
-HOOK: (micros) io-backend ( -- n )
+++ /dev/null
-IN: micros
-USING: help.syntax help.markup kernel prettyprint sequences ;
-
-HELP: micros
-{ $values { "n" "an integer" } }
-{ $description "Outputs the number of microseconds ellapsed since midnight January 1, 1970"
-} ;
-
-
-HELP: micro-time
-{ $values { "quot" "a quot" }
- { "n" "an integer" } }
-{ $description "executes the quotation and pushes the number of microseconds taken onto the stack"
-} ;
+++ /dev/null
-IN: micros.tests
-USING: micros tools.test math math.functions system kernel ;
-
-! a bit racy but I can't think of a better way to check this right now
-[ t ]
-[ millis 1000 / micros 1000000 / [ truncate ] bi@ = ] unit-test
-
+++ /dev/null
-IN: micros
-USING: micros.backend system kernel combinators vocabs.loader math ;
-
-: micros ( -- n ) (micros) ; inline
-
-: micro-time ( quot -- n )
- micros slip micros swap - ; inline
-
-{
- { [ os unix? ] [ "micros.unix" ] }
- { [ os windows? ] [ "micros.windows" ] }
-} cond require
-
+++ /dev/null
-Microsecond precision clock
+++ /dev/null
-unportable
+++ /dev/null
-IN: micros.unix
-USING: micros.backend io.backend system alien.c-types kernel unix.time math ;
-
-M: unix (micros)
- "timespec" <c-object> dup f gettimeofday drop
- [ timespec-sec 1000000 * ] [ timespec-nsec ] bi + ;
+++ /dev/null
-unportable
+++ /dev/null
-IN: micros.windows
-USING: system kernel windows.time math math.functions micros.backend ;
-
-! 116444736000000000 is the windowstime epoch offset
-! since windowstime starts at 1600 and unix epoch is 1970
-M: windows (micros)
- windows-time 116444736000000000 - 10 / truncate ;
\ No newline at end of file
USING: arrays kernel math opengl opengl.gl opengl.glu
-opengl.demo-support ui ui.gadgets ui.render threads accessors ;
+opengl.demo-support ui ui.gadgets ui.render threads accessors
+calendar ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
: width 256 ;
: height 256 ;
-: redraw-interval 10 ;
+: redraw-interval ( -- dt ) 10 milliseconds ;
: <nehe4-gadget> ( -- gadget )
nehe4-gadget new-gadget
USING: arrays kernel math opengl opengl.gl opengl.glu\r
-opengl.demo-support ui ui.gadgets ui.render threads accessors ;\r
+opengl.demo-support ui ui.gadgets ui.render threads accessors\r
+calendar ;\r
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
: width 256 ;\r
: height 256 ;\r
-: redraw-interval 10 ;\r
+: redraw-interval ( -- dt ) 10 milliseconds ;\r
\r
: <nehe5-gadget> ( -- gadget )\r
nehe5-gadget new-gadget\r
! See http://factorcode.org/license.txt for BSD license.\r
!\r
IN: openal.example\r
-USING: openal kernel alien threads sequences ;\r
+USING: openal kernel alien threads sequences calendar ;\r
\r
: play-hello ( -- )\r
init-openal\r
1 gen-sources\r
first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
source-play\r
- 1000 sleep ;\r
+ 1000 milliseconds sleep ;\r
\r
: (play-file) ( source -- )\r
- 100 sleep\r
+ 100 milliseconds sleep\r
dup source-playing? [ (play-file) ] [ drop ] if ;\r
\r
: play-file ( filename -- )\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors ui ui.gadgets ui.gadgets.buttons ui.render ;
+IN: ui.gadgets.broken
+
+! An intentionally broken gadget -- used to test UI error handling,
+! make sure that one bad gadget doesn't bring the whole system down
+
+: <bad-button> ( -- button )
+ "Click me if you dare"
+ [ "Haha" throw ]
+ <bevel-button> ;
+
+TUPLE: bad-gadget < gadget ;
+
+M: bad-gadget draw-gadget* "Lulz" throw ;
+
+M: bad-gadget pref-dim* drop { 100 100 } ;
+
+: <bad-gadget> ( -- gadget ) bad-gadget new-gadget ;
+
+: bad-gadget-test ( -- )
+ <bad-button> "Test 1" open-window
+ <bad-gadget> "Test 2" open-window ;
+
+MAIN: bad-gadget-test
\r
DEFER: (del-page)\r
\r
-:: add-toggle ( model n name toggler -- )\r
+:: add-toggle ( n name model toggler -- )\r
<frame>\r
- n name toggler parent>> '[ _ _ _ (del-page) ] "X" swap <bevel-button>\r
+ n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
@right grid-add\r
n model name <toggle-button> @center grid-add\r
toggler swap add-gadget drop ;\r
[ names>> ] [ model>> ] [ toggler>> ] tri\r
[ clear-gadget ] keep\r
[ [ length ] keep ] 2dip\r
- '[ [ _ ] 2dip _ add-toggle ] 2each ;\r
+ '[ _ _ add-toggle ] 2each ;\r
\r
: refresh-book ( tabbed -- )\r
model>> [ ] change-model ;\r
\r
: add-page ( page name tabbed -- )\r
[ names>> push ] 2keep\r
- [ [ model>> swap ]\r
- [ names>> length 1 - swap ]\r
+ [ [ names>> length 1 - swap ]\r
+ [ model>> ]\r
[ toggler>> ] tri add-toggle ]\r
[ content>> swap add-gadget drop ]\r
[ refresh-book ] tri ;\r
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors http.server.dispatchers
http.server.static furnace.actions furnace.redirection urls
-validators locals io.files html.forms help.html ;
+validators locals io.files html.forms html.components help.html ;
IN: webapps.help
TUPLE: help-webapp < dispatcher ;
+M: result link-title title>> ;
+
+M: result link-href href>> ;
+
:: <search-action> ( help-dir -- action )
<page-action>
{ help-webapp "search" } >>template
USING: kernel sequences namespaces make math assocs words arrays
-tools.annotations vocabs sorting prettyprint io micros
-math.statistics accessors ;
+tools.annotations vocabs sorting prettyprint io system
+math.statistics accessors tools.time ;
IN: wordtimer
SYMBOL: *wordtimes*
*calling* get-global at ; inline
: timed-call ( quot word -- )
- [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline
+ [ calling ] [ >r benchmark r> register-time ] [ finished ] tri ; inline
: time-unless-recursing ( quot word -- )
dup called-recursively? not
: dummy-word ( -- ) ;
: time-dummy-word ( -- n )
- [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ;
+ [ 100000 [ [ dummy-word ] benchmark , ] times ] { } make median ;
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
[ first2 ] dip
: wordtimer-call ( quot -- )
reset-word-timer
- [ call ] micro-time >r
+ benchmark >r
correct-for-timing-overhead
"total time:" write r> pprint nl
print-word-timings nl ;
over [ reset-vocab ] [ add-timers ] bi
reset-word-timer
"executing quotation..." print flush
- [ call ] micro-time >r
+ benchmark >r
"resetting annotations..." print flush
reset-vocab
correct-for-timing-overhead
(require 'font-lock)
(require 'comint)
+(require 'view)
;;; Customization:
:type '(file :must-match t)
:group 'factor)
+(defcustom factor-use-doc-window t
+ "When on, use a separate window to display help information.
+Disable to see that information in the factor-listener comint
+window."
+ :type 'boolean
+ :group 'factor)
+
+(defcustom factor-listener-use-other-window t
+ "Use a window other than the current buffer's when switching to
+the factor-listener buffer."
+ :type 'boolean
+ :group 'factor)
+
+(defcustom factor-listener-window-allow-split t
+ "Allow window splitting when switching to the factor-listener
+buffer."
+ :type 'boolean
+ :group 'factor)
+
+(defcustom factor-help-always-ask t
+ "When enabled, always ask for confirmation in help prompts."
+ :type 'boolean
+ :group 'factor)
+
(defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files."
:type 'boolean
:type 'hook
:group 'factor)
+(defcustom factor-help-mode-hook nil
+ "Hook run by `factor-help-mode'."
+ :type 'hook
+ :group 'factor)
+
(defgroup factor-faces nil
"Faces used in Factor mode"
:group 'factor
"Face for parsing words."
:group 'factor-faces)
+(defface factor-font-lock-help-mode-headlines '((t (:bold t :weight bold)))
+ "Face for headlines in help buffers."
+ :group 'factor-faces)
+
\f
;;; Factor mode font lock:
+(defconst factor--regexp-word-start
+ (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+ (format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|"))))
+
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
(defconst factor-font-lock-keywords
- `(("#!.*$" . 'factor-font-lock-comment)
- ("!( .* )" . 'factor-font-lock-comment)
- ("^!.*$" . 'factor-font-lock-comment)
- (" !.*$" . 'factor-font-lock-comment)
- ("( .* )" . 'factor-font-lock-stack-effect)
- ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string)
+ `(("( .* )" . 'factor-font-lock-stack-effect)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
'(2 'factor-font-lock-parsing-word)))
\f
;;; Factor mode syntax:
+(defconst factor--font-lock-syntactic-keywords
+ `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
+ (,factor--regexp-word-start (2 "(;"))
+ ("\\(;\\)" (1 "):"))
+ ("\\(#!\\)" (1 "<"))
+ ("\\(!\\)" (1 "<"))
+ ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
+
(defvar factor-mode-syntax-table nil
"Syntax table used while in Factor mode.")
;; Whitespace
(modify-syntax-entry ?\t " " factor-mode-syntax-table)
- (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
(modify-syntax-entry ?\f " " factor-mode-syntax-table)
(modify-syntax-entry ?\r " " factor-mode-syntax-table)
(modify-syntax-entry ? " " factor-mode-syntax-table)
+ ;; (end of) Comments
+ (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
+
+ ;; Parenthesis
(modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
(modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
(modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
(modify-syntax-entry ?\( "()" factor-mode-syntax-table)
(modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
- (modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
+
+ ;; Strings
+ (modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
+ (modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
\f
;;; Factor mode indentation:
(defvar factor-indent-width factor-default-indent-width
"Indentation width in factor buffers. A local variable."))
-(defconst factor--regexp-word-start
- (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
- (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
-
(defun factor--guess-indent-width ()
"Chooses an indentation value from existing code."
(let ((word-cont "^ +[^ ]")
(factor-send-region (search-backward ":")
(search-forward ";")))
-(defun factor-see ()
- (interactive)
- (comint-send-string "*factor*" "\\ ")
- (comint-send-string "*factor*" (thing-at-point 'sexp))
- (comint-send-string "*factor*" " see\n"))
-
-(defun factor-help ()
- (interactive)
- (comint-send-string "*factor*" "\\ ")
- (comint-send-string "*factor*" (thing-at-point 'sexp))
- (comint-send-string "*factor*" " help\n"))
-
(defun factor-edit ()
(interactive)
(comint-send-string "*factor*" "\\ ")
(defvar factor-mode-map (make-sparse-keymap)
"Key map used by Factor mode.")
-(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
-(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
-(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
-(define-key factor-mode-map "\C-c\C-s" 'factor-see)
-(define-key factor-mode-map "\C-ce" 'factor-edit)
-(define-key factor-mode-map "\C-c\C-h" 'factor-help)
-(define-key factor-mode-map "\C-cc" 'comment-region)
-(define-key factor-mode-map [return] 'newline-and-indent)
-(define-key factor-mode-map [tab] 'indent-for-tab-command)
-
-
\f
;; Factor mode:
(setq major-mode 'factor-mode)
(setq mode-name "Factor")
(set (make-local-variable 'comment-start) "! ")
+ (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
+ (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
(set (make-local-variable 'font-lock-defaults)
- '(factor-font-lock-keywords t nil nil nil))
+ `(factor-font-lock-keywords
+ nil nil nil nil
+ (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
(set-syntax-table factor-mode-syntax-table)
(set (make-local-variable 'indent-line-function) 'factor--indent-line)
(setq factor-indent-width (factor--guess-indent-width))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
\f
-;;; Factor listener mode
+;;; Factor listener mode:
;;;###autoload
-(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
-
-(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
+ "Major mode for interacting with an inferior Factor listener process.
+\\{factor-listener-mode-map}"
+ (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
+
+(defvar factor--listener-buffer nil
+ "The buffer in which the Factor listener is running.")
+
+(defun factor--listener-start-process ()
+ "Start an inferior Factor listener process, using
+`factor-binary' and `factor-image'."
+ (setq factor--listener-buffer
+ (apply 'make-comint "factor" (expand-file-name factor-binary) nil
+ `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
+ (with-current-buffer factor--listener-buffer
+ (factor-listener-mode)))
+
+(defun factor--listener-process ()
+ (or (and (buffer-live-p factor--listener-buffer)
+ (get-buffer-process factor--listener-buffer))
+ (progn (factor--listener-start-process)
+ (factor--listener-process))))
;;;###autoload
-(defun run-factor ()
- "Start a factor listener inside emacs, or switch to it if it
-already exists."
+(defalias 'switch-to-factor 'run-factor)
+;;;###autoload
+(defun run-factor (&optional arg)
+ "Show the factor-listener buffer, starting the process if needed."
(interactive)
- (switch-to-buffer
- (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
- (concat "-i=" (expand-file-name factor-image))
- "-run=listener"))
- (factor-listener-mode))
+ (let ((buf (process-buffer (factor--listener-process)))
+ (pop-up-windows factor-listener-window-allow-split))
+ (if factor-listener-use-other-window
+ (pop-to-buffer buf)
+ (switch-to-buffer buf))))
+
+\f
+;;;; Factor help mode:
+
+(defvar factor-help-mode-map (make-sparse-keymap)
+ "Keymap for Factor help mode.")
+
+(defconst factor--help-headlines
+ (regexp-opt '("Definition"
+ "Examples"
+ "Generic word contract"
+ "Inputs and outputs"
+ "Parent topics:"
+ "Syntax"
+ "Vocabulary"
+ "Warning"
+ "Word description")
+ t))
+
+(defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
+
+(defconst factor--help-font-lock-keywords
+ `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
+ ,@factor-font-lock-keywords))
+
+(defun factor-help-mode ()
+ "Major mode for displaying Factor help messages.
+\\{factor-help-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map factor-help-mode-map)
+ (setq mode-name "Factor Help")
+ (setq major-mode 'factor-help-mode)
+ (set (make-local-variable 'font-lock-defaults)
+ '(factor--help-font-lock-keywords t nil nil nil))
+ (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+ (set (make-local-variable 'view-no-disable-on-exit) t)
+ (view-mode)
+ (setq view-exit-action
+ (lambda (buffer)
+ ;; Use `with-current-buffer' to make sure that `bury-buffer'
+ ;; also removes BUFFER from the selected window.
+ (with-current-buffer buffer
+ (bury-buffer))))
+ (run-mode-hooks 'factor-help-mode-hook))
+
+(defun factor--listener-help-buffer ()
+ (set-buffer (get-buffer-create "*factor-help*"))
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max)))
+ (factor-help-mode)
+ (current-buffer))
+
+(defvar factor--help-history nil)
+
+(defun factor--listener-show-help (&optional see)
+ (let* ((def (thing-at-point 'sexp))
+ (prompt (format "%s (%s): " (if see "See" "Help") def))
+ (ask (or (not (eq major-mode 'factor-mode))
+ (not def)
+ factor-help-always-ask))
+ (cmd (format "\\ %s %s"
+ (if ask (read-string prompt nil 'factor--help-history def) def)
+ (if see "see" "help")))
+ (hb (factor--listener-help-buffer))
+ (proc (factor--listener-process)))
+ (comint-redirect-send-command-to-process cmd hb proc nil)
+ (pop-to-buffer hb)))
+
+(defun factor-see ()
+ (interactive)
+ (factor--listener-show-help t))
+
+(defun factor-help ()
+ (interactive)
+ (factor--listener-show-help))
+
+\f
(defun factor-refresh-all ()
"Reload source files and documentation for all loaded
(comint-send-string "*factor*" "refresh-all\n"))
\f
+;;; Key bindings:
+
+(defmacro factor--define-key (key cmd &optional both)
+ (let ((m (gensym))
+ (ms '(factor-mode-map)))
+ (when both (push 'factor-help-mode-map ms))
+ `(dolist (,m (list ,@ms))
+ (define-key ,m [(control ?c) ,key] ,cmd)
+ (define-key ,m [(control ?c) (control ,key)] ,cmd))))
+
+(factor--define-key ?f 'factor-run-file)
+(factor--define-key ?r 'factor-send-region)
+(factor--define-key ?d 'factor-send-definition)
+(factor--define-key ?s 'factor-see t)
+(factor--define-key ?e 'factor-edit)
+(factor--define-key ?z 'switch-to-factor t)
+(factor--define-key ?c 'comment-region)
+
+(define-key factor-mode-map "\C-ch" 'factor-help)
+(define-key factor-help-mode-map "\C-ch" 'factor-help)
+(define-key factor-mode-map "\C-m" 'newline-and-indent)
+(define-key factor-mode-map [tab] 'indent-for-tab-command)
+(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+
+
+\f
(provide 'factor)
;;; factor.el ends here
+++ /dev/null
-
-USING: kernel words accessors
- classes
- classes.builtin
- classes.tuple
- classes.predicate
- vocabs
- arrays
- sequences sorting
- io help.markup
- effects
- generic
- prettyprint
- prettyprint.sections
- prettyprint.backend
- combinators.cleave
- obj.print ;
-
-IN: vocab-browser
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: word-effect-as-string ( word -- string )
- stack-effect dup
- [ effect>string ]
- [ drop "" ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: print-vocabulary-summary ( vocabulary -- )
-
- dup vocab words [ builtin-class? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Builtin Classes" $heading nl
- print-seq
- ]
- if
-
- dup vocab words [ tuple-class? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Tuple Classes" $heading nl
- [
- { [ ] [ superclass ] [ "slots" word-prop [ name>> ] map " " join ] }
- 1arr
- ]
- map
- { "CLASS" "PARENT" "SLOTS" } prefix
- print-table
- ]
- if
-
- dup vocab words [ predicate-class? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Predicate Classes" $heading nl
- ! [ pprint-class ] each
- [ { [ ] [ superclass ] } 1arr ] map
- { "CLASS" "SUPERCLASS" } prefix
- print-table
- ]
- if
-
- dup vocab words [ class? not ] filter [ symbol? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Symbols" $heading nl
- print-seq
- ]
- if
-
- dup vocab words [ generic? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Generic words" $heading nl
- [ [ ] [ stack-effect effect>string ] bi 2array ] map
- print-table
- ]
- if
-
- "Words" $heading nl
- dup vocab words
- [ predicate-class? not ] filter
- [ builtin-class? not ] filter
- [ tuple-class? not ] filter
- [ generic? not ] filter
- [ symbol? not ] filter
- [ word? ] filter
- natural-sort
- [ [ ] [ word-effect-as-string ] bi 2array ] map
- print-table
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: vocabs.loader tools.vocabs.browser ;
-
-: $vocab-summary ( seq -- )
- first
- dup vocab
- [
- dup print-vocabulary-summary
- dup describe-help
- ! dup describe-uses
- ! dup describe-usage
- ]
- when
- dup find-vocab-root
- [
- dup describe-summary
- dup describe-tags
- dup describe-authors
- ! dup describe-files
- ]
- when
- ! dup describe-children
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: assocs ui.tools.browser ui.operations io.styles ;
-
-! IN: tools.vocabs.browser
-
-! : $describe-vocab ( element -- ) $vocab-summary ;
-
-USING: tools.vocabs ;
-
-: print-vocabs ( -- )
- vocabs
- [ { [ vocab ] [ vocab-summary ] } 1arr ]
- map
- print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : $all-vocabs ( seq -- ) drop print-vocabs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: help.syntax help.topics ;
-
-! ARTICLE: "vocab-index" "Vocabulary Index" { $all-vocabs } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: vocab-spec article-content ( vocab-spec -- content )
- { $vocab-summary } swap name>> suffix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: loaded-and-unloaded-vocabs ( -- seq )
- "" all-child-vocabs values concat [ name>> ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! ARTICLE: "loaded-vocabs-index" "Loaded Vocabularies" { $loaded-vocabs } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: debugger ;
-
-TUPLE: load-this-vocab name ;
-
-! : do-load-vocab ( ltv -- )
-! dup name>> require
-! name>> vocab com-follow ;
-
-: do-load-vocab ( ltv -- )
- [
- dup name>> require
- name>> vocab com-follow
- ]
- curry
- try ;
-
-[ load-this-vocab? ] \ do-load-vocab { { +primary+ t } } define-operation
-
-M: load-this-vocab pprint* ( obj -- )
- [ name>> "*" append ] [ ] bi write-object ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: vocab-or-loader ( name -- obj )
- dup vocab
- [ vocab ]
- [ load-this-vocab boa ]
- if ;
-
-: vocab-summary-text ( vocab-name -- text )
- dup vocab-summary-path vocab-file-contents
- dup empty?
- [ drop "" ]
- [ first ]
- if ;
-
-! : vocab-table-entry ( vocab-name -- seq )
-! { [ vocab-or-loader ] [ vocab-summary ] } 1arr ;
-
-: vocab-table-entry ( vocab-name -- seq )
- { [ vocab-or-loader ] [ vocab-summary-text ] } 1arr ;
-
-: print-these-vocabs ( seq -- ) [ vocab-table-entry ] map print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : vocab-list ( -- seq ) "" all-child-vocabs values concat [ name>> ] map ;
-
-: all-vocab-names ( -- seq )
- all-vocabs values concat [ name>> ] map natural-sort ;
-
-: loaded-vocab-names ( -- seq ) all-vocab-names [ vocab ] filter ;
-
-: unloaded-vocab-names ( -- seq ) all-vocab-names [ vocab not ] filter ;
-
-: root->names ( root -- seq ) all-vocabs at [ name>> ] map natural-sort ;
-
-: vocab-names-core ( -- seq ) "resource:core" root->names ;
-: vocab-names-basis ( -- seq ) "resource:basis" root->names ;
-: vocab-names-extra ( -- seq ) "resource:extra" root->names ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: $all-vocabs ( seq -- ) drop all-vocab-names print-these-vocabs ;
-: $loaded-vocabs ( seq -- ) drop loaded-vocab-names print-these-vocabs ;
-: $unloaded-vocabs ( seq -- ) drop unloaded-vocab-names print-these-vocabs ;
-
-: $vocabs-core ( seq -- ) drop vocab-names-core print-these-vocabs ;
-: $vocabs-basis ( seq -- ) drop vocab-names-basis print-these-vocabs ;
-: $vocabs-extra ( seq -- ) drop vocab-names-extra print-these-vocabs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! { "" }
-
-! all-child-vocabs values concat [ name>> ] map
-
-! : vocab-tree ( vocab -- seq )
-! dup
-! all-child-vocabs values concat [ name>> ] map prune
-! [ vocab-tree ]
-! map
-! concat
-! swap prefix
-! [ vocab-source-path ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: vocab-author pprint* ( vocab-author -- ) [ name>> ] [ ] bi write-object ;
-
-: $vocab-authors ( seq -- )
- drop all-authors [ vocab-author boa ] map print-seq ;
-
-ARTICLE: "vocab-authors" "Vocabulary Authors" { $vocab-authors } ;
-
-: vocabs-by-author ( author -- vocab-names )
- authored values concat [ name>> ] map ;
-
-: $vocabs-by-author ( seq -- )
- first name>> vocabs-by-author print-these-vocabs ;
-
-M: vocab-author article-content ( vocab-author -- content )
- { $vocabs-by-author } swap suffix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: vocab-tag pprint* ( vocab-tag -- ) [ name>> ] [ ] bi write-object ;
-
-: print-vocab-tags ( -- ) all-tags [ vocab-tag boa ] map print-seq ;
-
-: $vocab-tags ( seq -- ) drop print-vocab-tags ;
-
-ARTICLE: "vocab-tags" "Vocabulary Tags" { $vocab-tags } ;
-
-: $vocabs-with-tag ( seq -- )
- first tagged values concat [ name>> ] map print-these-vocabs ;
-
-M: vocab-tag article-content ( vocab-tag -- content )
- name>> { $vocabs-with-tag } swap suffix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "vocab-index-all" "All Vocabularies" { $all-vocabs } ;
-ARTICLE: "vocab-index-loaded" "Loaded Vocabularies" { $loaded-vocabs } ;
-ARTICLE: "vocab-index-unloaded" "Unloaded Vocabularies" { $loaded-vocabs } ;
-
-ARTICLE: "vocab-index-core" "Core Vocabularies" { $vocabs-core } ;
-ARTICLE: "vocab-index-basis" "Basis Vocabularies" { $vocabs-basis } ;
-ARTICLE: "vocab-index-extra" "Extra Vocabularies" { $vocabs-extra } ;
-
-ARTICLE: "vocab-indices" "Vocabulary Indices"
- { $subsection "vocab-index-core" }
- { $subsection "vocab-index-basis" }
- { $subsection "vocab-index-extra" }
- { $subsection "vocab-index-all" }
- { $subsection "vocab-index-loaded" }
- { $subsection "vocab-index-unloaded" }
- { $subsection "vocab-authors" }
- { $subsection "vocab-tags" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
/* Copy all literals referenced from a code block to newspace */
void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
- CELL scan;
- CELL literal_end = literals_start + compiled->literals_length;
+ if(collecting_gen >= compiled->last_scan)
+ {
+ CELL scan;
+ CELL literal_end = literals_start + compiled->literals_length;
+
+ if(collecting_accumulation_gen_p())
+ compiled->last_scan = collecting_gen;
+ else
+ compiled->last_scan = collecting_gen + 1;
+
+ for(scan = literals_start; scan < literal_end; scan += CELLS)
+ copy_handle((CELL*)scan);
+
+ if(compiled->relocation != F)
+ {
+ copy_handle(&compiled->relocation);
- copy_handle(&compiled->relocation);
+ F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
- for(scan = literals_start; scan < literal_end; scan += CELLS)
- copy_handle((CELL*)scan);
+ F_REL *rel = (F_REL *)(relocation + 1);
+ F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
+
+ while(rel < rel_end)
+ {
+ if(REL_TYPE(rel) == RT_IMMEDIATE)
+ {
+ CELL offset = rel->offset + code_start;
+ F_FIXNUM absolute_value = get(CREF(literals_start,REL_ARGUMENT(rel)));
+ apply_relocation(REL_CLASS(rel),offset,absolute_value);
+ }
+
+ rel++;
+ }
+ }
+
+ flush_icache(code_start,literals_start - code_start);
+ }
}
/* Copy literals referenced from all code blocks to newspace */
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
-#define CREF(array,i) ((CELL)(array) + CELLS * (i))
-
INLINE CELL get_literal(CELL literals_start, CELL num)
{
return get(CREF(literals_start,num));
INLINE CELL compute_code_rel(F_REL *rel,
CELL code_start, CELL literals_start)
{
+ CELL obj;
+
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
return (CELL)primitives[REL_ARGUMENT(rel)];
case RT_DLSYM:
return (CELL)get_rel_symbol(rel,literals_start);
- case RT_LITERAL:
- return CREF(literals_start,REL_ARGUMENT(rel));
case RT_IMMEDIATE:
return get(CREF(literals_start,REL_ARGUMENT(rel)));
case RT_XT:
- return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
+ obj = get(CREF(literals_start,REL_ARGUMENT(rel)));
+ if(type_of(obj) == WORD_TYPE)
+ return (CELL)untag_word(obj)->xt;
+ else
+ return (CELL)untag_quotation(obj)->xt;
case RT_HERE:
return rel->offset + code_start + (short)REL_ARGUMENT(rel);
case RT_LABEL:
/* compiled header */
F_COMPILED *header = (void *)here;
header->type = type;
+ header->last_scan = NURSERY;
header->code_length = code_length;
header->literals_length = literals_length;
header->relocation = relocation;
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM,
- /* an indirect literal from the word's literal table */
- RT_LITERAL,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a compiled word reference */
unsigned int offset;
} F_REL;
+#define CREF(array,i) ((CELL)(array) + CELLS * (i))
+
+void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value);
+
void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate);
DEF(void,lazy_jit_compile,(CELL quot)):
mov r1,sp /* save stack pointer */
PROLOGUE
- bl MANGLE(primitive_jit_compile)
+ bl MANGLE(lazy_jit_compile_impl)
EPILOGUE
JUMP_QUOT /* call the quotation */
DEF(void,lazy_jit_compile,(CELL quot)):
mr r4,r1 /* save stack pointer */
PROLOGUE
- bl MANGLE(primitive_jit_compile)
+ bl MANGLE(lazy_jit_compile_impl)
EPILOGUE
JUMP_QUOT /* call the quotation */
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */
sub $STACK_PADDING,STACK_REG
- call MANGLE(primitive_jit_compile)
+ call MANGLE(lazy_jit_compile_impl)
mov RETURN_REG,ARG0 /* No-op on 32-bit */
add $STACK_PADDING,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
- F_CARD *ptr;
- for(ptr = first_card; ptr < last_card; ptr++) *ptr = 0;
+ memset(first_card,0,last_card - first_card);
}
void clear_decks(CELL from, CELL to)
/* NOTE: reverse order due to heap layout. */
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
- F_DECK *ptr;
- for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0;
+ memset(first_deck,0,last_deck - first_deck);
}
void clear_allot_markers(CELL from, CELL to)
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
- F_CARD *ptr;
- for(ptr = first_card; ptr < last_card; ptr++) *ptr = INVALID_ALLOT_MARKER;
+ memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
}
void set_data_heap(F_DATA_HEAP *data_heap_)
/* Scan all the objects in the card */
void collect_card(F_CARD *ptr, CELL gen, CELL here)
{
- CELL offset = CARD_OFFSET(ptr);
-
- if(offset != INVALID_ALLOT_MARKER)
- {
- if(offset & TAG_MASK)
- critical_error("Bad card",(CELL)ptr);
+ CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
+ CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
- CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
- CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
+ if(here < card_end)
+ card_end = here;
- while(card_scan < card_end && card_scan < here)
- card_scan = collect_next(card_scan);
+ collect_next_loop(card_scan,&card_end);
- cards_scanned++;
- }
+ cards_scanned++;
}
void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
/* Given a pointer to oldspace, copy it to newspace */
INLINE void *copy_untagged_object(void *pointer, CELL size)
{
- void *newpointer;
if(newspace->here + size >= newspace->end)
longjmp(gc_jmp,1);
allot_barrier(newspace->here);
- newpointer = allot_zone(newspace,size);
+ void *newpointer = allot_zone(newspace,size);
F_GC_STATS *s = &gc_stats[collecting_gen];
s->object_count++;
we ignore. */
CELL binary_payload_start(CELL pointer)
{
+ F_TUPLE *tuple;
+ F_TUPLE_LAYOUT *layout;
+
switch(untag_header(get(pointer)))
{
/* these objects do not refer to other objects at all */
case STRING_TYPE:
return sizeof(F_STRING);
/* everything else consists entirely of pointers */
+ case ARRAY_TYPE:
+ return array_size(array_capacity((F_ARRAY*)pointer));
+ case TUPLE_TYPE:
+ tuple = untag_object(pointer);
+ layout = untag_object(tuple->layout);
+ return tuple_size(layout);
+ case RATIO_TYPE:
+ return sizeof(F_RATIO);
+ case COMPLEX_TYPE:
+ return sizeof(F_COMPLEX);
+ case WRAPPER_TYPE:
+ return sizeof(F_WRAPPER);
default:
- return unaligned_object_size(pointer);
+ critical_error("Invalid header",pointer);
+ return -1; /* can't happen */
}
}
}
}
-/* This function is performance-critical */
-CELL collect_next(CELL scan)
+CELL collect_next_nursery(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
- obj++;
-
- CELL newspace_start = newspace->start;
- CELL newspace_end = newspace->end;
-
- if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+ if(obj != end)
{
+ obj++;
+
CELL nursery_start = nursery.start;
CELL nursery_end = nursery.end;
*obj = copy_object(pointer);
}
}
- else if(HAVE_AGING_P && collecting_gen == AGING)
+
+ return scan + untagged_object_size(scan);
+}
+
+CELL collect_next_aging(CELL scan)
+{
+ CELL *obj = (CELL *)scan;
+ CELL *end = (CELL *)(scan + binary_payload_start(scan));
+
+ if(obj != end)
{
- F_ZONE *tenured = &data_heap->generations[TENURED];
+ obj++;
+
+ CELL tenured_start = data_heap->generations[TENURED].start;
+ CELL tenured_end = data_heap->generations[TENURED].end;
- CELL tenured_start = tenured->start;
- CELL tenured_end = tenured->end;
+ CELL newspace_start = newspace->start;
+ CELL newspace_end = newspace->end;
for(; obj < end; obj++)
{
*obj = copy_object(pointer);
}
}
- else if(collecting_gen == TENURED)
+
+ return scan + untagged_object_size(scan);
+}
+
+/* This function is performance-critical */
+CELL collect_next_tenured(CELL scan)
+{
+ CELL *obj = (CELL *)scan;
+ CELL *end = (CELL *)(scan + binary_payload_start(scan));
+
+ if(obj != end)
{
+ obj++;
+
+ CELL newspace_start = newspace->start;
+ CELL newspace_end = newspace->end;
+
for(; obj < end; obj++)
{
CELL pointer = *obj;
- if(!immediate_p(pointer)
- && !(pointer >= newspace_start && pointer < newspace_end))
+ if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end))
*obj = copy_object(pointer);
}
-
- do_code_slots(scan);
}
- else
- critical_error("Bug in collect_next",0);
+
+ do_code_slots(scan);
return scan + untagged_object_size(scan);
}
+void collect_next_loop(CELL scan, CELL *end)
+{
+ if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+ {
+ while(scan < *end)
+ scan = collect_next_nursery(scan);
+ }
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ {
+ while(scan < *end)
+ scan = collect_next_aging(scan);
+ }
+ else if(collecting_gen == TENURED)
+ {
+ while(scan < *end)
+ scan = collect_next_tenured(scan);
+ }
+}
+
INLINE void reset_generation(CELL i)
{
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
if(collecting_gen != NURSERY)
reset_generations(NURSERY,collecting_gen - 1);
}
+ else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+ {
+ nursery.here = nursery.start;
+ }
else
{
/* all generations up to and including the one
return;
}
- s64 start = current_millis();
+ s64 start = current_micros();
performing_gc = true;
growing_data_heap = growing_data_heap_;
}
}
- while(scan < newspace->here)
- scan = collect_next(scan);
+ collect_next_loop(scan,&newspace->here);
- CELL gc_elapsed = (current_millis() - start);
+ CELL gc_elapsed = (current_micros() - start);
end_gc(gc_elapsed);
GROWABLE_ARRAY(stats);
CELL i;
- CELL total_gc_time = 0;
+ u64 total_gc_time = 0;
for(i = 0; i < MAX_GEN_COUNT; i++)
{
F_GC_STATS *s = &gc_stats[i];
GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time));
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time)));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time)));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
- GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
/* statistics */
typedef struct {
CELL collections;
- CELL gc_time;
- CELL max_gc_time;
+ u64 gc_time;
+ u64 max_gc_time;
CELL object_count;
u64 bytes_copied;
} F_GC_STATS;
return object;
}
-CELL collect_next(CELL scan);
+void collect_next_loop(CELL scan, CELL *end);
void primitive_gc(void);
void primitive_gc_stats(void);
print_obj(frame_scan(frame));
print_string("\n");
print_cell_hex((CELL)frame_executing(frame));
+ print_string(" ");
print_cell_hex((CELL)frame->xt);
+ print_string("\n");
}
void print_callstack(void)
if(p->image == NULL)
p->image = default_image_path();
- srand(current_millis());
+ srand(current_micros());
init_ffi();
init_stacks(p->ds_size,p->rs_size);
load_image(p);
callback();
}
-void factor_sleep(long ms)
+void factor_sleep(long us)
{
void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]);
- callback(ms);
+ callback(us);
}
save_image(unbox_native_string());
}
-void strip_compiled_quotations(void)
-{
- begin_scan();
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
- quot->compiledp = F;
- }
- }
- gc_off = false;
-}
-
void primitive_save_image_and_exit(void)
{
/* We unbox this before doing anything else. This is the only point
REGISTER_C_STRING(path);
- /* This reduces deployed image size */
- strip_compiled_quotations();
-
/* strip out userenv data which is set on startup anyway */
CELL i;
for(i = 0; i < FIRST_SAVE_ENV; i++)
/* The compiled code heap is structured into blocks. */
typedef struct
{
- CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
+ char type; /* this is WORD_TYPE or QUOTATION_TYPE */
+ char last_scan; /* the youngest generation in which this block's literals may live */
CELL code_length; /* # bytes */
CELL literals_length; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
{
F_FIXNUM y = get(ds);
F_FIXNUM x = get(ds - CELLS);
- if(y == -1 && x == tag_fixnum(FIXNUM_MIN))
+ if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
{
put(ds - CELLS,allot_integer(-FIXNUM_MIN));
put(ds,tag_fixnum(0));
static void *null_dll;
-s64 current_millis(void)
+s64 current_micros(void)
{
struct timeval t;
gettimeofday(&t,NULL);
- return (s64)t.tv_sec * 1000 + t.tv_usec / 1000;
+ return (s64)t.tv_sec * 1000000 + t.tv_usec;
}
-void sleep_millis(CELL msec)
+void sleep_micros(CELL usec)
{
- usleep(msec * 1000);
+ usleep(usec);
}
void init_ffi(void)
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-s64 current_millis(void);
-void sleep_millis(CELL msec);
+s64 current_micros(void);
+void sleep_micros(CELL usec);
void open_console(void);
#include "master.h"
-s64 current_millis(void)
+s64 current_micros(void)
{
SYSTEMTIME st;
FILETIME ft;
GetSystemTime(&st);
SystemTimeToFileTime(&st, &ft);
return (((s64)ft.dwLowDateTime
- | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000;
+ | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
}
char *strerror(int err)
#define snprintf _snprintf
#define snwprintf _snwprintf
-s64 current_millis(void);
+s64 current_micros(void);
void c_to_factor_toplevel(CELL quot);
void open_console(void);
#include "master.h"
-s64 current_millis(void)
+s64 current_micros(void)
{
FILETIME t;
GetSystemTimeAsFileTime(&t);
return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
- - EPOCH_OFFSET) / 10000;
+ - EPOCH_OFFSET) / 10;
}
long exception_handler(PEXCEPTION_POINTERS pe)
return g_pagesize;
}
-void sleep_millis(DWORD msec)
+void sleep_micros(DWORD usec)
{
- Sleep(msec);
+ Sleep(usec);
}
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
void ffi_dlclose(F_DLL *dll);
-void sleep_millis(DWORD msec);
+void sleep_micros(DWORD msec);
INLINE void init_signals(void) {}
INLINE void early_init(void) {}
const F_CHAR *default_image_path(void);
long getpagesize (void);
-s64 current_millis(void);
+s64 current_micros(void);
primitive_exit,
primitive_data_room,
primitive_code_room,
- primitive_millis,
+ primitive_micros,
primitive_modify_code_heap,
primitive_dlopen,
primitive_dlsym,
primitive_dll_validp,
primitive_unimplemented,
primitive_gc_reset,
+ primitive_jit_compile,
};
machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+Calls to words and constant quotations (referenced by conditionals and dips)
+are direct jumps to machine code blocks. Literals are also referenced directly
+without going through the literal table.
+
It actually does do a little bit of very simple optimization:
1) Tail call optimization.
'if' and 'dispatch' conditionals are generated inline, instead of as a call to
the 'if' word.
-4) When preceded by an array, calls to the 'declare' word are optimized out
+4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
+open-coded as retain stack manipulation surrounding a subroutine call.
+
+5) When preceded by an array, calls to the 'declare' word are optimized out
entirely. This word is only used by the optimizing compiler, and with the
non-optimizing compiler it would otherwise just decrease performance to have to
push the array and immediately drop it after.
-5) Sub-primitives are primitive words which are implemented in assembly and not
+6) Sub-primitives are primitive words which are implemented in assembly and not
in the VM. They are open-coded and no subroutine call is generated. This
includes stack shufflers, some fixnum arithmetic words, and words such as tag,
slot and eq?. A primitive call is relatively expensive (two subroutine calls)
&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
}
+bool jit_fast_dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_DIP_WORD];
+}
+
+bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD];
+}
+
+bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
+{
+ return (i + 2) <= array_capacity(array)
+ && type_of(array_nth(array,i)) == QUOTATION_TYPE
+ && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD];
+}
+
bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
{
return (i + 1) < array_capacity(array)
if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
return true;
}
+ else if(type_of(obj) == QUOTATION_TYPE)
+ {
+ if(jit_fast_dip_p(array,i)
+ || jit_fast_2dip_p(array,i)
+ || jit_fast_3dip_p(array,i))
+ return true;
+ }
}
return false;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
+ EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1);
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
if(stack_frame)
EMIT(userenv[JIT_EPILOG],0);
+ jit_compile(array_nth(untag_object(array),i),relocate);
+ jit_compile(array_nth(untag_object(array),i + 1),relocate);
+
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_IF_1],literals_count - 1);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(userenv[JIT_IF_JUMP],literals_count - 2);
+ EMIT(userenv[JIT_IF_2],literals_count - 1);
i += 2;
tail_call = true;
break;
}
+ else if(jit_fast_dip_p(untag_object(array),i))
+ {
+ jit_compile(obj,relocate);
+
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_DIP],literals_count - 1);
+
+ i++;
+ break;
+ }
+ else if(jit_fast_2dip_p(untag_object(array),i))
+ {
+ jit_compile(obj,relocate);
+
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_2DIP],literals_count - 1);
+
+ i++;
+ break;
+ }
+ else if(jit_fast_3dip_p(untag_object(array),i))
+ {
+ jit_compile(obj,relocate);
+
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ EMIT(userenv[JIT_3DIP],literals_count - 1);
+
+ i++;
+ break;
+ }
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
}
default:
GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1);
+ EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1);
break;
}
}
struct.) */
#define COUNT(name,scan) \
{ \
+ CELL size = array_capacity(code_to_emit(name)) * code_format; \
if(offset == 0) return scan - 1; \
- offset -= array_capacity(code_to_emit(name)) * code_format; \
+ if(offset < size) return scan + 1; \
+ offset -= size; \
}
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
COUNT(userenv[JIT_WORD_CALL],i)
break;
case WRAPPER_TYPE:
- COUNT(userenv[JIT_PUSH_LITERAL],i)
+ COUNT(userenv[JIT_PUSH_IMMEDIATE],i)
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
if(stack_frame)
COUNT(userenv[JIT_EPILOG],i)
+ COUNT(userenv[JIT_IF_1],i)
+ COUNT(userenv[JIT_IF_2],i)
i += 2;
- COUNT(userenv[JIT_IF_JUMP],i)
-
tail_call = true;
break;
}
+ else if(jit_fast_dip_p(untag_object(array),i))
+ {
+ COUNT(userenv[JIT_DIP],i)
+ i++;
+ break;
+ }
+ else if(jit_fast_2dip_p(untag_object(array),i))
+ {
+ COUNT(userenv[JIT_2DIP],i)
+ i++;
+ break;
+ }
+ else if(jit_fast_3dip_p(untag_object(array),i))
+ {
+ COUNT(userenv[JIT_3DIP],i)
+ i++;
+ break;
+ }
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
break;
}
default:
- COUNT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],i)
+ COUNT(userenv[JIT_PUSH_IMMEDIATE],i)
break;
}
}
return -1;
}
-F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
+F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
{
stack_chain->callstack_top = stack;
REGISTER_ROOT(quot);
return quot;
}
+void primitive_jit_compile(void)
+{
+ jit_compile(dpop(),true);
+}
+
/* push a new quotation on the stack */
void primitive_array_to_quotation(void)
{
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
void jit_compile(CELL quot, bool relocate);
-F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
+F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
void primitive_array_to_quotation(void);
void primitive_quotation_xt(void);
+void primitive_jit_compile(void);
}
}
+F_CONTEXT *alloc_context(void)
+{
+ F_CONTEXT *context;
+
+ if(unused_contexts)
+ {
+ context = unused_contexts;
+ unused_contexts = unused_contexts->next;
+ }
+ else
+ {
+ context = safe_malloc(sizeof(F_CONTEXT));
+ context->datastack_region = alloc_segment(ds_size);
+ context->retainstack_region = alloc_segment(rs_size);
+ }
+
+ return context;
+}
+
+void dealloc_context(F_CONTEXT *context)
+{
+ context->next = unused_contexts;
+ unused_contexts = context;
+}
+
/* called on entry into a compiled callback */
void nest_stacks(void)
{
- F_CONTEXT *new_stacks = safe_malloc(sizeof(F_CONTEXT));
+ F_CONTEXT *new_stacks = alloc_context();
new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
new_stacks->callstack_top = (F_STACK_FRAME *)-1;
new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
- new_stacks->datastack_region = alloc_segment(ds_size);
- new_stacks->retainstack_region = alloc_segment(rs_size);
-
new_stacks->next = stack_chain;
stack_chain = new_stacks;
/* called when leaving a compiled callback */
void unnest_stacks(void)
{
- dealloc_segment(stack_chain->datastack_region);
- dealloc_segment(stack_chain->retainstack_region);
-
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
F_CONTEXT *old_stacks = stack_chain;
stack_chain = old_stacks->next;
- free(old_stacks);
+ dealloc_context(old_stacks);
}
/* called on startup */
ds_size = ds_size_;
rs_size = rs_size_;
stack_chain = NULL;
+ unused_contexts = NULL;
}
bool stack_to_array(CELL bottom, CELL top)
exit(to_fixnum(dpop()));
}
-void primitive_millis(void)
+void primitive_micros(void)
{
- box_unsigned_8(current_millis());
+ box_unsigned_8(current_micros());
}
void primitive_sleep(void)
{
- sleep_millis(to_cell(dpop()));
+ sleep_micros(to_cell(dpop()));
}
void primitive_set_slot(void)
JIT_PRIMITIVE,
JIT_WORD_JUMP,
JIT_WORD_CALL,
- JIT_PUSH_LITERAL,
JIT_IF_WORD,
- JIT_IF_JUMP,
+ JIT_IF_1,
+ JIT_IF_2,
JIT_DISPATCH_WORD,
JIT_DISPATCH,
JIT_EPILOG,
JIT_PUSH_IMMEDIATE,
JIT_DECLARE_WORD = 42,
JIT_SAVE_STACK,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
STACK_TRACES_ENV = 59,
DLLEXPORT F_CONTEXT *stack_chain;
+F_CONTEXT *unused_contexts;
+
CELL ds_size, rs_size;
#define ds_bot (stack_chain->datastack_region->start)
void primitive_set_os_env(void);
void primitive_unset_os_env(void);
void primitive_set_os_envs(void);
-void primitive_millis(void);
+void primitive_micros(void);
void primitive_sleep(void);
void primitive_set_slot(void);
projects / factor.git / commitdiff