[ 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-if-jump
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-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-if-jump
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 -- )
- 1000 /i
+: print-time ( us -- )
+ 1000000 /i
60 /mod swap
number>string write
" minutes and " write number>string write " seconds." print ;
[
! We time bootstrap
- millis
+ micros
default-image-name "output-image" set-global
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
[
load-components
- millis over - core-bootstrap-time set-global
+ micros over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
] [ print-error 1 exit ] recover
] set-boot-quot
- millis swap - bootstrap-time set-global
+ micros swap - bootstrap-time set-global
print-report
"output-image" get save-image-and-exit
{ $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
[
dup crossref?
[
- dependencies get >alist
- generic-dependencies get >alist
+ dependencies get
+ generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
[ 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
--- /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
\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 ( -- )
\r
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
\r
-: jit-call-quot ( -- )\r
+: jit-jump-quot ( -- )\r
4 3 quot-xt-offset LWZ\r
4 MTCTR\r
BCTR ;\r
\r
+: jit-call-quot ( -- )\r
+ 4 3 quot-xt-offset LWZ\r
+ 4 MTLR\r
+ BLR ;\r
+\r
[\r
0 3 LOAD32\r
6 ds-reg 0 LWZ\r
3 3 4 ADDI\r
3 3 0 LWZ\r
ds-reg dup 4 SUBI\r
- jit-call-quot\r
+ jit-jump-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define\r
\r
[\r
3 3 6 ADD\r
3 3 array-start-offset LWZ\r
ds-reg dup 4 SUBI\r
- jit-call-quot\r
+ jit-jump-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
\r
+! These should not clobber r3 since we store a quotation in there\r
+! in jit-dip\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 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 rs-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
+: prepare-dip ( -- )\r
+ 0 3 LOAD32\r
+ 3 3 0 LWZ ;\r
+\r
+[\r
+ prepare-dip\r
+ jit->r\r
+ jit-call-quot\r
+ jit-r>\r
+] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define\r
+\r
+[\r
+ prepare-dip\r
+ jit-2>r\r
+ jit-call-quot\r
+ jit-2r>\r
+] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define\r
+\r
+[\r
+ prepare-dip\r
+ jit-3>r\r
+ jit-call-quot\r
+ jit-3r>\r
+] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define\r
+\r
[\r
0 1 lr-save stack-frame + LWZ\r
1 1 stack-frame ADDI\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
: 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 ;
: 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
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
+! The jit->r words cannot clobber arg0
+
+: jit->r ( -- )
+ rs-reg bootstrap-cell ADD
+ temp-reg ds-reg [] MOV
+ ds-reg bootstrap-cell SUB
+ rs-reg [] temp-reg MOV ;
+
+: jit-2>r ( -- )
+ rs-reg 2 bootstrap-cells ADD
+ temp-reg ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg 2 bootstrap-cells SUB
+ rs-reg [] temp-reg MOV
+ rs-reg -1 bootstrap-cells [+] arg1 MOV ;
+
+: jit-3>r ( -- )
+ rs-reg 3 bootstrap-cells ADD
+ temp-reg 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 [] temp-reg MOV
+ rs-reg -1 bootstrap-cells [+] arg1 MOV
+ rs-reg -2 bootstrap-cells [+] arg2 MOV ;
+
+: jit-r> ( -- )
+ ds-reg bootstrap-cell ADD
+ temp-reg rs-reg [] MOV
+ rs-reg bootstrap-cell SUB
+ ds-reg [] temp-reg MOV ;
+
+: jit-2r> ( -- )
+ ds-reg 2 bootstrap-cells ADD
+ temp-reg rs-reg [] MOV
+ arg1 rs-reg -1 bootstrap-cells [+] MOV
+ rs-reg 2 bootstrap-cells SUB
+ ds-reg [] temp-reg MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV ;
+
+: jit-3r> ( -- )
+ ds-reg 3 bootstrap-cells ADD
+ temp-reg 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 [] temp-reg MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] arg2 MOV ;
+
+[
+ arg0 0 MOV ! load quotation addr
+ arg0 arg0 [] MOV ! load quotation
+ jit->r
+ arg0 quot-xt-offset [+] CALL ! call quotation
+ jit-r>
+] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define
+
+[
+ arg0 0 MOV ! load quotation addr
+ arg0 arg0 [] MOV ! load quotation
+ jit-2>r
+ arg0 quot-xt-offset [+] CALL ! call quotation
+ jit-2r>
+] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define
+
+[
+ arg0 0 MOV ! load quotation addr
+ arg0 arg0 [] MOV ! load quotation
+ jit-3>r
+ arg0 quot-xt-offset [+] CALL ! call quotation
+ jit-3r>
+] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define
+
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define
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 -- )
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
{ "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" ]]
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
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
"-" %
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 ? -- )
! 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
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? ;
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
SINGLETON: epsilon INSTANCE: epsilon node
SINGLETON: any-char INSTANCE: any-char node
+SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node
SINGLETON: front-anchor INSTANCE: front-anchor node
SINGLETON: back-anchor INSTANCE: back-anchor node
[ 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 {
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
+[ 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
! Comment
[ 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
+
+[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] 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
+
+[ { "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
+[ "1.2.3.4" ]
+[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
+
+[ f ] [ "ab" "a(?!b)" <regexp> first-match ] 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
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
! [ 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
! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
-[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
! "a(?<=b)" <regexp> "caba" over first-match
-[ "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
! capture group 1: "aaaa" 2: ""
! "aaaa" "(a*)(a*)" <regexp> match*
! "aaaa" "(a*)(a+)" <regexp> match*
-
-[ "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
USING: accessors combinators kernel math sequences
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 ;
IN: regexp
: default-regexp ( string -- regexp )
[ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
] if ;
-: first-match ( string regexp -- pair/f )
+: 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
- [ [ length 1+ 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- ;
"<" %
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
: 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 [
{ $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
{
{ [ 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 -- )
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
[\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
: (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
{ $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 boxes calendar
+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
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 ;
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 ( -- )
[ ] [ [ "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
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
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
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
] [ ui-error ] recover ;
: ui-wait ( -- )
- 10 sleep ;
+ 10 milliseconds sleep ;
SYMBOL: ui-thread
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 propagate-gesture
+ 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 propagate-gesture ;
+ 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
{ "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 ;
[ "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
[ ]
[
[
- \ >r ,
- callable instance-check-quot %
- \ r> ,
+ callable instance-check-quot [ dip ] curry %
callable instance-check-quot %
tuple-layout ,
\ <tuple-boa> ,
! 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" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
}
-[ >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 )
: 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"
}
} ;
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." } ;
: ((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." } ;
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." } ;
+{ $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 } }
"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"
}
} ;
"The following two lines are equivalent:"
{ $code
"[ p ] bi@"
- ">r p r> p"
+ "[ p ] dip p"
}
"The following two lines are also equivalent:"
{ $code
"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
"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
{ $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" }
! 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
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 ;
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
[ 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 ;
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 from to seq reason ;
: 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 millis }
+{ $subsection micros }
"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 { "us" 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
-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
] [
[ jamshred>> jamshred-update ]
[ relayout-1 ]
- [ 10 sleep yield jamshred-loop ] tri
+ [ 10 milliseconds sleep yield jamshred-loop ] tri
] if ;
: fullscreen ( gadget -- )
: 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 ] 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 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 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
USING: kernel sequences namespaces make math assocs words arrays
-tools.annotations vocabs sorting prettyprint io micros
+tools.annotations vocabs sorting prettyprint io system
math.statistics accessors ;
IN: wordtimer
*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
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);
- 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;
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);
}
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(msec / 1000);
}
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,
&& 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;
tail_call = true;
break;
}
+ else if(jit_fast_dip_p(untag_object(array),i))
+ {
+ 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))
+ {
+ 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))
+ {
+ 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))
{
tail_call = true;
break;
}
+ else if(jit_fast_dip_p(untag_object(array),i))
+ {
+ i++;
+ COUNT(userenv[JIT_DIP],i)
+ break;
+ }
+ else if(jit_fast_2dip_p(untag_object(array),i))
+ {
+ i++;
+ COUNT(userenv[JIT_2DIP],i)
+ break;
+ }
+ else if(jit_fast_3dip_p(untag_object(array),i))
+ {
+ i++;
+ COUNT(userenv[JIT_3DIP],i)
+ break;
+ }
case ARRAY_TYPE:
if(jit_fast_dispatch_p(untag_object(array),i))
{
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_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,
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