steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-11-23 11:21:04 -06:00
parent afc97627f9 65b89eea9e
commit ce54c54ba0
151 changed files with 1112 additions and 856 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms.factor
View File

@ -35,7 +35,7 @@ ERROR: bad-alarm-frequency frequency ;
[ 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 ]

6
basis/bootstrap/help/help.factor
View File

@ -1,6 +1,6 @@
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 ( -- )
@ -10,8 +10,8 @@ IN: bootstrap.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 ;

30
basis/bootstrap/image/image.factor
View File

@ -130,6 +130,12 @@ SYMBOL: jit-if-word
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
@ -139,8 +145,8 @@ SYMBOL: jit-save-stack
! 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 }
@ -160,8 +166,17 @@ SYMBOL: undefined-quot
{ 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 ;
@ -443,6 +458,9 @@ M: quotation '
\ 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
@ -457,6 +475,12 @@ M: quotation '
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

10
basis/bootstrap/stage2.factor
View File

@ -32,8 +32,8 @@ SYMBOL: bootstrap-time
: 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 ;
@ -52,7 +52,7 @@ SYMBOL: bootstrap-time
[
! We time bootstrap
millis
micros
default-image-name "output-image" set-global
@ -77,7 +77,7 @@ SYMBOL: bootstrap-time
[
load-components
millis over - core-bootstrap-time set-global
micros over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
@ -100,7 +100,7 @@ SYMBOL: bootstrap-time
] [ 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

6
basis/calendar/calendar-docs.factor
View File

@ -365,12 +365,12 @@ HELP: unix-1970
{ $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"
}
} ;

8
basis/calendar/calendar-tests.factor
View File

@ -143,10 +143,10 @@ IN: calendar.tests
[ +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 = ;

10
basis/calendar/calendar.factor
View File

@ -325,9 +325,15 @@ M: duration time-
: 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+ ;
@ -404,7 +410,7 @@ PRIVATE>
: 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 ;

2
basis/calendar/model/model.factor
View File

@ -7,7 +7,7 @@ SYMBOL: time
: (time-thread) ( -- )
now time get set-model
1000 sleep (time-thread) ;
1 seconds sleep (time-thread) ;
: time-thread ( -- )
[

4
basis/compiler/compiler.factor
View File

@ -91,8 +91,8 @@ t compile-dependencies? set-global
[
dup crossref?
[
dependencies get >alist
generic-dependencies get >alist
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;

2
basis/compiler/tests/alien.factor
View File

@ -361,7 +361,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ 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

14
basis/compiler/tests/redefine13.factor Normal file
View File

@ -0,0 +1,14 @@
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

8
basis/compiler/tests/redefine14.factor Normal file
View File

@ -0,0 +1,8 @@
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

2
basis/concurrency/combinators/combinators-tests.factor
View File

@ -11,7 +11,7 @@ math.parser ;
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
[ error>> "Even" = ] must-fail-with

8
basis/concurrency/flags/flags-tests.factor
View File

@ -1,6 +1,6 @@
IN: concurrency.flags.tests
USING: tools.test concurrency.flags concurrency.combinators
kernel threads locals accessors ;
kernel threads locals accessors calendar ;
:: flag-test-1 ( -- )
[let | f [ <flag> ] |
@ -13,7 +13,7 @@ kernel threads locals accessors ;
:: flag-test-2 ( -- )
[let | f [ <flag> ] |
[ 1000 sleep f raise-flag ] "Flag test" spawn drop
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>>
] ;
@ -39,7 +39,7 @@ kernel threads locals accessors ;
:: flag-test-5 ( -- )
[let | f [ <flag> ] |
[ 1000 sleep f raise-flag ] "Flag test" spawn drop
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>>
] ;
@ -48,6 +48,6 @@ kernel threads locals accessors ;
[ ] [
{ 1 2 } <flag>
[ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ]
[ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]
[ [ wait-for-flag drop ] curry parallel-each ] bi
] unit-test

6
basis/concurrency/futures/futures-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.messaging kernel arrays
continuations help.markup help.syntax quotations ;
continuations help.markup help.syntax quotations calendar ;
IN: concurrency.futures
HELP: future
@ -11,8 +11,8 @@ $nl
"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 } "." } ;
HELP: ?future-timeout
{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } }
{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to " { $snippet "timeout" } " milliseconds." }
{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }
{ $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." }
{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;
HELP: ?future

4
basis/concurrency/locks/locks-tests.factor
View File

@ -100,7 +100,7 @@ threads sequences calendar accessors ;
c await
l [
4 v push
1000 sleep
1 seconds sleep
5 v push
] with-write-lock
c'' count-down
@ -139,7 +139,7 @@ threads sequences calendar accessors ;
l [
1 v push
c count-down
1000 sleep
1 seconds sleep
2 v push
] with-write-lock
c' count-down

2
basis/concurrency/promises/promises-docs.factor
View File

@ -13,7 +13,7 @@ HELP: promise-fulfilled?
HELP: ?promise-timeout
{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
{ $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." }
{ $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." }
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;
HELP: ?promise

4
basis/core-foundation/run-loop/run-loop.factor
View File

@ -1,7 +1,7 @@
! 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
@ -30,7 +30,7 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )

99
basis/cpu/ppc/bootstrap.factor
View File

@ -71,11 +71,16 @@ big-endian on
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call-quot ( -- )
: jit-jump-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTCTR
BCTR ;
: jit-call-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTLR
BLRL ;
[
0 3 LOAD32
6 ds-reg 0 LWZ
@ -84,7 +89,7 @@ big-endian on
3 3 4 ADDI
3 3 0 LWZ
ds-reg dup 4 SUBI
jit-call-quot
jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
[
@ -95,9 +100,83 @@ big-endian on
3 3 6 ADD
3 3 array-start-offset LWZ
ds-reg dup 4 SUBI
jit-call-quot
jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
! These should not clobber r3 since we store a quotation in there
! in jit-dip
: jit->r ( -- )
4 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 rs-reg 4 STWU ;
: jit-2>r ( -- )
4 ds-reg 0 LWZ
5 ds-reg -4 LWZ
ds-reg dup 8 SUBI
rs-reg dup 8 ADDI
4 rs-reg 0 STW
5 rs-reg -4 STW ;
: jit-3>r ( -- )
4 ds-reg 0 LWZ
5 ds-reg -4 LWZ
6 ds-reg -8 LWZ
ds-reg dup 12 SUBI
rs-reg dup 12 ADDI
4 rs-reg 0 STW
5 rs-reg -4 STW
6 rs-reg -8 STW ;
: jit-r> ( -- )
4 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 rs-reg 4 STWU ;
: jit-2r> ( -- )
4 rs-reg 0 LWZ
5 rs-reg -4 LWZ
rs-reg dup 8 SUBI
ds-reg dup 8 ADDI
4 ds-reg 0 STW
5 ds-reg -4 STW ;
: jit-3r> ( -- )
4 rs-reg 0 LWZ
5 rs-reg -4 LWZ
6 rs-reg -8 LWZ
rs-reg dup 12 SUBI
ds-reg dup 12 ADDI
4 ds-reg 0 STW
5 ds-reg -4 STW
6 ds-reg -8 STW ;
: prepare-dip ( -- )
0 3 LOAD32
3 3 0 LWZ ;
[
prepare-dip
jit->r
jit-call-quot
jit-r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define
[
prepare-dip
jit-2>r
jit-call-quot
jit-2r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define
[
prepare-dip
jit-3>r
jit-call-quot
jit-3r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define
[
0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI
@ -112,7 +191,7 @@ big-endian on
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
jit-call-quot
jit-jump-quot
] f f f \ (call) define-sub-primitive
[
@ -245,17 +324,9 @@ big-endian on
4 ds-reg 0 STW
] f f f \ -rot define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
3 rs-reg 4 STWU
] f f f \ >r define-sub-primitive
[ jit->r ] f f f \ >r define-sub-primitive
[
3 rs-reg 0 LWZ
rs-reg dup 4 SUBI
3 ds-reg 4 STWU
] f f f \ r> define-sub-primitive
[ jit-r> ] f f f \ r> define-sub-primitive
! Comparisons
: jit-compare ( insn -- )

1
basis/cpu/x86/32/bootstrap.factor
View File

@ -12,6 +12,7 @@ IN: bootstrap.x86
: 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 ;

1
basis/cpu/x86/64/unix/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: 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

1
basis/cpu/x86/64/winnt/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: 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

90
basis/cpu/x86/bootstrap.factor
View File

@ -73,6 +73,80 @@ big-endian off
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
@ -223,19 +297,9 @@ big-endian off
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 -- )
@ -305,7 +369,7 @@ big-endian off
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

6
basis/help/html/html.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files html.streams html.elements html.components help kernel
io.files html.streams html.elements help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
@ -104,10 +104,6 @@ MEMO: load-index ( name -- index )
TUPLE: result title href ;
M: result link-title title>> ;
M: result link-href href>> ;
: offline-apropos ( string index -- results )
load-index swap >lower
'[ [ drop _ ] dip >lower subseq? ] assoc-filter

5
basis/io/launcher/launcher.factor
View File

@ -4,7 +4,8 @@ USING: system kernel namespaces strings hashtables sequences
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
@ -65,7 +66,7 @@ SYMBOL: wait-flag
: 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

196
basis/io/sockets/secure/openssl/openssl.factor Normal file
View File

@ -0,0 +1,196 @@
! 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

2
basis/io/unix/files/files.factor
View File

@ -303,7 +303,7 @@ M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
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 ;

2
basis/io/unix/kqueue/kqueue.factor
View File

@ -94,7 +94,7 @@ M: kqueue-mx unregister-io-task ( task mx -- )
: 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 ;

4
basis/io/unix/select/select.factor
View File

@ -48,9 +48,9 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
[ 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 ;

12
basis/io/unix/sockets/secure/secure.factor
View File

@ -1,11 +1,11 @@
! 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

2
basis/io/windows/nt/pipes/pipes.factor
View File

@ -35,7 +35,7 @@ IN: io.windows.nt.pipes
"-" %
32 random-bits #
"-" %
millis #
micros #
] "" make ;
M: winnt (pipe) ( -- pipe )

9
basis/io/windows/windows.factor Normal file → Executable file
View File

@ -1,11 +1,10 @@
! 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 ? -- )

1
basis/logging/logging-docs.factor
View File

@ -117,7 +117,6 @@ ARTICLE: "logging" "Logging framework"
{ $subsection "logging.rotation" }
{ $subsection "logging.parser" }
{ $subsection "logging.analysis" }
{ $subsection "logging.insomniac" }
{ $subsection "logging.server" } ;
ABOUT: "logging"

1
basis/logging/logging.factor
View File

@ -123,4 +123,3 @@ USE: vocabs.loader
"logging.parser" require
"logging.analysis" require
"logging.insomniac" require

196
basis/openssl/openssl.factor
View File

@ -1,25 +1,13 @@
! 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 ;
@ -47,183 +35,3 @@ SYMBOL: ssl-initialized?
] 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

2
basis/peg/parsers/parsers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces 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

2
basis/peg/peg.factor
View File

@ -1,7 +1,7 @@
! 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

2
basis/smtp/smtp.factor
View File

@ -145,7 +145,7 @@ ERROR: invalid-header-string string ;
"<" %
64 random-bits #
"-" %
millis #
micros #
"@" %
smtp-domain get [ host-name ] unless* %
">" %

23
basis/stack-checker/known-words/known-words.factor
View File

@ -87,6 +87,15 @@ M: composed infer-call*
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
@ -150,6 +159,9 @@ M: object infer-call*
{ \ 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 ] }
@ -175,9 +187,10 @@ M: object infer-call*
(( 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 }
@ -423,8 +436,8 @@ do-primitive alien-invoke alien-indirect alien-callback
\ 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

5
basis/stack-checker/stack-checker.factor
View File

@ -24,4 +24,7 @@ M: callable infer ( quot -- effect )
: 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 ;

2
basis/threads/threads-docs.factor
View File

@ -100,7 +100,7 @@ HELP: sleep-queue
{ $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

6
basis/threads/threads.factor
View File

@ -93,7 +93,7 @@ PRIVATE>
{
{ [ 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
@ -106,7 +106,7 @@ 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 ;
@ -184,7 +184,7 @@ M: f sleep-until
GENERIC: sleep ( dt -- )
M: real sleep
millis + >integer sleep-until ;
micros + >integer sleep-until ;
: interrupt ( thread -- )
dup state>> [

2
basis/tools/deploy/test/1/1.factor
View File

@ -1,6 +1,6 @@
IN: tools.deploy.test.1
USING: threads ;
: deploy-test-1 ( -- ) 1000 sleep ;
: deploy-test-1 ( -- ) 1000000 sleep ;
MAIN: deploy-test-1

2
basis/tools/profiler/profiler-tests.factor
View File

@ -11,7 +11,7 @@ words ;
[ ] [ [ 10 [ gc ] times ] profile ] unit-test
[ ] [ [ 1000 sleep ] profile ] unit-test
[ ] [ [ 1000000 sleep ] profile ] unit-test
[ ] [ profile. ] unit-test

2
basis/tools/test/test.factor
View File

@ -49,7 +49,7 @@ SYMBOL: this-test
[ drop t ] must-fail-with ;
: (run-test) ( vocab -- )
dup vocab-source-loaded? [
dup vocab source-loaded?>> [
vocab-tests [ run-file ] each
] [ drop ] if ;

4
basis/tools/threads/threads.factor
View File

@ -14,8 +14,8 @@ IN: tools.threads
] with-cell
[
sleep-entry>> [
key>> millis [-] number>string write
" ms" write
key>> micros [-] number>string write
" us" write
] when*
] with-cell ;

6
basis/tools/time/time-docs.factor
View File

@ -7,7 +7,7 @@ ARTICLE: "timing" "Timing code"
"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" } ;
@ -15,7 +15,7 @@ ABOUT: "timing"
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 } "." } ;
@ -23,4 +23,4 @@ HELP: 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

14
basis/tools/time/time.factor
View File

@ -5,20 +5,20 @@ namespaces system sequences splitting grouping assocs strings ;
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
@ -29,7 +29,7 @@ IN: tools.time
[
nl
{
"Total GC time (ms):"
"Total GC time (us):"
"Cards scanned:"
"Decks scanned:"
"Code heap literal scans:"
@ -37,4 +37,4 @@ IN: tools.time
] 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

8
basis/tools/vocabs/vocabs.factor
View File

@ -134,12 +134,12 @@ SYMBOL: modified-docs
[
[
[ modified-sources ]
[ vocab-source-loaded? ]
[ vocab source-loaded?>> ]
[ vocab-source-path ]
tri (to-refresh)
] [
[ modified-docs ]
[ vocab-docs-loaded? ]
[ vocab docs-loaded?>> ]
[ vocab-docs-path ]
tri (to-refresh)
] bi
@ -154,8 +154,8 @@ SYMBOL: modified-docs
: do-refresh ( modified-sources modified-docs unchanged -- )
unchanged-vocabs
[
[ [ f swap set-vocab-source-loaded? ] each ]
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
[ [ vocab f >>source-loaded? drop ] each ]
[ [ vocab f >>docs-loaded? drop ] each ] bi*
]
[
append prune

2
basis/ui/gestures/gestures-docs.factor
View File

@ -143,7 +143,7 @@ HELP: hand-last-button
{ $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." } ;

14
basis/ui/gestures/gestures.factor
View File

@ -1,8 +1,8 @@
! 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
@ -109,7 +109,7 @@ SYMBOL: hand-click#
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
@ -118,7 +118,7 @@ SYMBOL: scroll-direction
{ 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 ;
@ -199,7 +199,7 @@ SYMBOL: drag-timer
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 = ;
@ -224,7 +224,7 @@ SYMBOL: drag-timer
1 hand-click# set
] if
hand-last-button set
millis hand-last-time set
now hand-last-time set
] bind ;
: update-clicked ( -- )

8
basis/ui/tools/interactor/interactor-tests.factor
View File

@ -38,7 +38,7 @@ tools.test kernel calendar parser accessors calendar io ;
[ ] [ [ "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
@ -57,11 +57,11 @@ tools.test kernel calendar parser accessors calendar io ;
] 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
@ -80,7 +80,7 @@ tools.test kernel calendar parser accessors calendar io ;
] in-thread
] unit-test
[ ] [ 100 sleep ] unit-test
[ ] [ 100 milliseconds sleep ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test

5
basis/ui/tools/listener/listener-tests.factor
View File

@ -2,7 +2,8 @@ USING: continuations documents ui.tools.interactor
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
@ -47,7 +48,7 @@ IN: ui.tools.listener.tests
[ ] [ "listener" get restart-listener ] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [ 1 seconds sleep ] unit-test
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget

6
basis/ui/tools/search/search-tests.factor
View File

@ -1,7 +1,7 @@
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 ] [
@ -14,7 +14,7 @@ IN: ui.tools.search.tests
: update-live-search ( search -- seq )
dup [
300 sleep
300 milliseconds sleep
list>> control-value
] with-grafted-gadget ;
@ -30,7 +30,7 @@ IN: ui.tools.search.tests
"" 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

4
basis/ui/ui.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make
prettyprint dlists deques sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
hashtables concurrency.flags sets accessors ;
hashtables concurrency.flags sets accessors calendar ;
IN: ui
! Assoc mapping aliens to gadgets
@ -153,7 +153,7 @@ SYMBOL: ui-hook
] [ ui-error ] recover ;
: ui-wait ( -- )
10 sleep ;
10 milliseconds sleep ;
SYMBOL: ui-thread

8
basis/unix/time/time.factor
View File

@ -11,14 +11,14 @@ C-STRUCT: timespec
{ "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 ;

4
core/alien/alien-docs.factor
View File

@ -281,8 +281,8 @@ $nl
"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."
} }
} ;

4
core/arrays/arrays.factor
View File

@ -6,8 +6,8 @@ IN: arrays
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 ;

33
core/assocs/assocs.factor
View File

@ -21,7 +21,7 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
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
@ -32,23 +32,26 @@ GENERIC: >alist ( assoc -- newassoc )
(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
@ -83,7 +86,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
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 )
@ -97,7 +100,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: 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 )
@ -130,19 +133,19 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: 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 ;
@ -173,7 +176,7 @@ M: sequence at*
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> ;
@ -186,10 +189,10 @@ M: sequence delete-at
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 ;

33
core/bootstrap/primitives.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math math.order namespaces make
parser sequences strings vectors words quotations assocs layouts
classes classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union classes.intersection classes.predicate
compiler.units bootstrap.image.private io.files accessors
combinators ;
hashtables.private io kernel math math.private math.order
namespaces make parser sequences strings vectors words
quotations assocs layouts classes classes.builtin classes.tuple
classes.tuple.private kernel.private vocabs vocabs.loader
source-files definitions slots classes.union
classes.intersection classes.predicate compiler.units
bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -129,8 +129,7 @@ bootstrapping? on
[ "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
@ -186,7 +185,11 @@ define-union-class
! A predicate class used for declarations
"array-capacity" "sequences.private" create
"fixnum" "math" lookup
0 bootstrap-max-array-capacity <fake-bignum> [ between? ] 2curry
[
[ dup 0 fixnum>= ] %
bootstrap-max-array-capacity <fake-bignum> [ fixnum<= ] curry ,
[ [ drop f ] if ] %
] [ ] make
define-predicate-class
! Catch-all class for providing a default method.
@ -327,9 +330,7 @@ tuple
[ ]
[
[
\ >r ,
callable instance-check-quot %
\ r> ,
callable instance-check-quot [ dip ] curry %
callable instance-check-quot %
tuple-layout ,
\ <tuple-boa> ,
@ -389,7 +390,7 @@ tuple
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r>
[ create dup reset-word ] dip
[ do-primitive ] curry [ ] like define ;
{
@ -460,7 +461,7 @@ tuple
{ "exit" "system" }
{ "data-room" "memory" }
{ "code-room" "memory" }
{ "millis" "system" }
{ "micros" "system" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
@ -533,7 +534,7 @@ tuple
{ "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

11
core/checksums/checksums.factor
View File

@ -12,14 +12,17 @@ GENERIC: checksum-stream ( stream checksum -- value )
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 ;

4
core/checksums/crc32/crc32.factor
View File

@ -11,7 +11,7 @@ IN: checksums.crc32
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
@ -24,7 +24,7 @@ SINGLETON: crc32
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

8
core/classes/algebra/algebra-tests.factor
View File

@ -13,9 +13,9 @@ IN: classes.algebra.tests
\ flatten-class must-infer
\ flatten-builtin-class must-infer
: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
[ t ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum class-and* ] unit-test
@ -240,9 +240,9 @@ UNION: z1 b1 c1 ;
20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer in>> [ random-boolean ] replicate dup . ] keep
[ >r [ ] each r> call ] 2keep
[ [ [ ] each ] dip call ] 2keep
>r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=
[ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
=
] unit-test

10
core/classes/algebra/algebra.factor
View File

@ -18,7 +18,7 @@ TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
[ 2array ] 2dip [ first2 ] prepose cache ; inline
GENERIC: valid-class? ( obj -- ? )
@ -66,13 +66,13 @@ DEFER: (class-or)
swap superclass dup [ swap class<= ] [ 2drop f ] if ;
: left-anonymous-union<= ( first second -- ? )
>r members>> r> [ class<= ] curry all? ;
[ members>> ] dip [ class<= ] curry all? ;
: right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with contains? ;
: left-anonymous-intersection<= ( first second -- ? )
>r participants>> r> [ class<= ] curry contains? ;
[ participants>> ] dip [ class<= ] curry contains? ;
: right-anonymous-intersection<= ( first second -- ? )
participants>> [ class<= ] with all? ;
@ -95,7 +95,7 @@ DEFER: (class-or)
} cond ;
: left-anonymous-complement<= ( first second -- ? )
>r normalize-complement r> class<= ;
[ normalize-complement ] dip class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement
class>> {
@ -212,7 +212,7 @@ M: anonymous-complement (classes-intersect?)
: sort-classes ( seq -- newseq )
[ [ name>> ] compare ] sort >vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ dup largest-class [ over delete-nth ] dip ]
[ ] produce nip ;
: min-class ( class seq -- class/f )

2
core/classes/tuple/tuple-tests.factor
View File

@ -485,7 +485,7 @@ must-fail-with
[ 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

10
core/classes/tuple/tuple.factor
View File

@ -58,7 +58,7 @@ PRIVATE>
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
[ copy-tuple-slots ] dip
first prefix ;
: tuple-slots ( tuple -- seq )
@ -178,9 +178,9 @@ ERROR: bad-superclass class ;
: 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 ;
@ -233,7 +233,7 @@ M: tuple-class update-class
class-usages [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
[ subclasses ] dip each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
@ -320,7 +320,7 @@ M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
M: tuple hashcode*
[
[ class hashcode ] [ tuple-size ] [ ] tri
>r rot r> [
[ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
] recursive-hashcode ;

2
core/combinators/combinators-docs.factor
View File

@ -74,7 +74,7 @@ HELP: spread
{ $code
"! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } spread"
">r >r >r p r> q r> r r> s"
"[ [ [ p ] dip q ] dip r ] dip s"
}
} ;

12
core/combinators/combinators.factor
View File

@ -80,7 +80,7 @@ ERROR: no-case ;
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 ;
@ -88,13 +88,13 @@ ERROR: no-case ;
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
@ -130,20 +130,20 @@ ERROR: no-case ;
{ [ 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 ] }

2
core/compiler/errors/errors.factor
View File

@ -20,7 +20,7 @@ SYMBOL: with-compiler-errors?
: 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 -- )

11
core/continuations/continuations.factor
View File

@ -65,7 +65,7 @@ C: <continuation> continuation
#! ( 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
@ -78,7 +78,7 @@ C: <continuation> continuation
set-catchstack
set-namestack
set-retainstack
>r set-datastack r>
[ set-datastack ] dip
set-callstack ;
: (continue-with) ( obj continuation -- )
@ -87,7 +87,7 @@ C: <continuation> 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>
@ -135,14 +135,13 @@ SYMBOL: thread-error-hook
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 ;

15
core/generic/math/math.factor
View File

@ -36,9 +36,10 @@ PREDICATE: math-class < class
: 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 ;
@ -55,9 +56,9 @@ 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 ;
@ -85,7 +86,7 @@ M: math-combination perform-combination
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

4
core/generic/standard/engines/engines.factor
View File

@ -18,7 +18,7 @@ GENERIC: engine>quot ( engine -- quot )
[ 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
@ -45,7 +45,7 @@ GENERIC: engine>quot ( engine -- quot )
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
[ 1- (picker) [ dip swap ] curry ]
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;

2
core/generic/standard/engines/predicate/predicate.factor
View File

@ -10,7 +10,7 @@ TUPLE: predicate-dispatch-engine methods ;
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<= ;

6
core/generic/standard/engines/tag/tag.factor
View File

@ -26,7 +26,7 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
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
@ -53,13 +53,13 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
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 ;

6
core/generic/standard/standard.factor
View File

@ -33,8 +33,8 @@ ERROR: no-method object generic ;
] 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' )
@ -113,7 +113,7 @@ PREDICATE: simple-generic < standard-generic
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 ;

4
core/growable/growable.factor
View File

@ -43,10 +43,10 @@ M: growable set-length ( n seq -- )
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 ;

2
core/hashtables/hashtables-tests.factor
View File

@ -134,7 +134,7 @@ H{ } "x" set
[ 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

17
core/hashtables/hashtables.factor
View File

@ -15,7 +15,7 @@ TUPLE: hashtable
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
@ -105,7 +105,7 @@ M: hashtable clear-assoc ( hash -- )
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
@ -115,9 +115,9 @@ M: hashtable assoc-size ( hash -- n )
[ 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
@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- )
: push-unsafe ( elt seq -- )
[ length ] keep
[ underlying>> set-array-nth ]
[ >r 1+ r> (>>length) ]
[ [ 1+ ] dip (>>length) ]
2bi ; inline
PRIVATE>
@ -141,9 +141,10 @@ 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 ;

4
core/io/backend/backend-docs.factor
View File

@ -2,8 +2,8 @@ USING: help.markup help.syntax io io.backend strings
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." } ;

2
core/io/encodings/encodings.factor
View File

@ -95,7 +95,7 @@ M: decoder stream-read-partial stream-read ;
: ((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 )

16
core/io/files/files.factor
View File

@ -26,13 +26,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
<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 ;
@ -41,7 +41,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ 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? ;
@ -127,13 +127,13 @@ PRIVATE>
{ [ 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 ;
@ -166,7 +166,7 @@ HOOK: make-link io-backend ( target symlink -- )
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+
@ -228,7 +228,7 @@ M: object normalize-path ( path -- path' )
(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 -- )

6
core/io/io.factor
View File

@ -69,7 +69,7 @@ SYMBOL: error-stream
[ ] 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
@ -89,8 +89,8 @@ SYMBOL: error-stream
] 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 ;

6
core/io/streams/byte-array/byte-array.factor
View File

@ -6,11 +6,11 @@ IN: io.streams.byte-array
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

2
core/io/streams/c/c.factor
View File

@ -67,7 +67,7 @@ M: c-io-backend init-io ;
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> ;

2
core/io/streams/nested/nested.factor
View File

@ -56,7 +56,7 @@ M: style-stream stream-write
[ 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 ;

4
core/io/streams/string/string.factor
View File

@ -24,7 +24,7 @@ M: null-encoding decode-char drop stream-read1 ;
] unless ;
: map-last ( seq quot -- seq )
>r dup length <reversed> [ zero? ] r> compose 2map ; inline
[ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
PRIVATE>
@ -75,7 +75,7 @@ M: growable stream-read-partial
>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

76
core/kernel/kernel-docs.factor
View File

@ -29,12 +29,6 @@ HELP: spin $shuffle ;
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." } ;
@ -212,7 +206,10 @@ HELP: 3slip
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 } }
@ -347,7 +344,7 @@ HELP: bi*
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] bi*"
">r p r> q"
"[ p ] dip q"
}
} ;
@ -358,7 +355,7 @@ HELP: 2bi*
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] 2bi*"
">r >r p r> r> q"
"[ p ] 2dip q"
}
} ;
@ -369,7 +366,7 @@ HELP: tri*
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] [ r ] tri*"
">r >r p r> q r> r"
"[ [ p ] dip q ] dip r"
}
} ;
@ -380,7 +377,7 @@ HELP: bi@
"The following two lines are equivalent:"
{ $code
"[ p ] bi@"
">r p r> p"
"[ p ] dip p"
}
"The following two lines are also equivalent:"
{ $code
@ -396,7 +393,7 @@ HELP: 2bi@
"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
@ -412,7 +409,7 @@ HELP: tri@
"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
@ -565,11 +562,7 @@ HELP: compose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
"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"
@ -589,15 +582,7 @@ HELP: 3compose
{ $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"
@ -608,16 +593,15 @@ HELP: 3compose
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" }
} ;
@ -625,7 +609,7 @@ HELP: 3dip
{ $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" }
} ;
@ -692,15 +676,7 @@ $nl
{ $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 } "."
@ -793,14 +769,10 @@ $nl
{ $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
@ -819,7 +791,9 @@ $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 }
@ -851,7 +825,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators"
"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" } "." ;
@ -935,10 +909,10 @@ ARTICLE: "dataflow" "Data and control flow"
{ $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" }

6
core/kernel/kernel-tests.factor
View File

@ -106,11 +106,11 @@ IN: kernel.tests
! 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

60
core/kernel/kernel.factor
View File

@ -3,12 +3,16 @@
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
@ -49,56 +53,68 @@ DEFER: if
pick [ roll 2drop call ] [ 2nip call ] if ; inline
! Slippers
: slip ( quot x -- x ) >r call 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 ) >r >r call r> r> ; inline
: 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 ) >r >r >r call r> r> r> ; inline
: 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 -- )
@ -115,8 +131,8 @@ DEFER: if
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
@ -182,7 +198,7 @@ GENERIC: boa ( ... class -- tuple )
: 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

2
core/lexer/lexer.factor
View File

@ -23,7 +23,7 @@ TUPLE: lexer text line line-text line-length column ;
lexer new-lexer ;
: skip ( i seq ? -- n )
>r tuck r>
[ tuck ] dip
[ swap CHAR: \s eq? xor ] curry find-from drop
[ ] [ length ] ?if ;

10
core/math/integers/integers.factor
View File

@ -25,7 +25,7 @@ M: fixnum + fixnum+ ;
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 ;
@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ;
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) ;
@ -94,7 +94,7 @@ M: bignum (log2) bignum-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
@ -103,7 +103,7 @@ M: bignum (log2) bignum-log2 ;
: /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
@ -111,7 +111,7 @@ M: bignum (log2) bignum-log2 ;
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

10
core/math/math.factor
View File

@ -107,7 +107,7 @@ M: float fp-infinity? ( float -- ? )
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
@ -122,13 +122,13 @@ M: float fp-infinity? ( float -- ? )
: 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>
@ -167,6 +167,6 @@ PRIVATE>
2dup 2slip rot [
drop
] [
>r 1- r> find-last-integer
[ 1- ] dip find-last-integer
] if
] if ; inline recursive

6
core/math/parser/parser.factor
View File

@ -51,12 +51,12 @@ SYMBOL: negative?
: (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 -- ? )
@ -137,7 +137,7 @@ M: ratio >base
{
{
[ CHAR: e over member? ]
[ "e" split1 >r fix-float "e" r> 3append ]
[ "e" split1 [ fix-float "e" ] dip 3append ]
} {
[ CHAR: . over member? ]
[ ]

4
core/namespaces/namespaces.factor
View File

@ -23,7 +23,7 @@ PRIVATE>
: 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
@ -37,4 +37,4 @@ PRIVATE>
H{ } clone >n call ndrop ; inline
: with-variable ( value key quot -- )
>r associate >n r> call ndrop ; inline
[ associate >n ] dip call ndrop ; inline

2
core/parser/parser-tests.factor
View File

@ -498,3 +498,5 @@ DEFER: blah
[ error>> error>> def>> \ blah eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
[ "CHAR: \\u9999999999999" eval ] must-fail

6
core/parser/parser.factor
View File

@ -10,7 +10,7 @@ IN: parser
: 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 ;
@ -140,7 +140,7 @@ ERROR: staging-violation word ;
} 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) ;
@ -156,7 +156,7 @@ ERROR: staging-violation word ;
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 ;

5
core/quotations/quotations.factor
View File

@ -49,7 +49,10 @@ M: wrapper literalize <wrapper> ;
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

148
core/sequences/sequences.factor
View File

@ -16,7 +16,7 @@ GENERIC: like ( seq exemplar -- newseq ) flushable
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 ;
@ -111,14 +111,14 @@ INSTANCE: integer immutable-sequence
[ 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
@ -188,7 +188,7 @@ TUPLE: slice
{ 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 ;
@ -253,12 +253,12 @@ INSTANCE: repetition immutable-sequence
: 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>
@ -279,11 +279,11 @@ 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 ;
@ -291,31 +291,31 @@ 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
: (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
PRIVATE>
: append ( seq1 seq2 -- newseq ) over (append) ;
: append-as ( seq1 seq2 exemplar -- newseq )
[ over length over length + ] dip
[ (append) ] new-like ; inline
: 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-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
@ -324,32 +324,32 @@ PRIVATE>
<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
@ -373,7 +373,7 @@ PRIVATE>
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
@ -382,7 +382,7 @@ PRIVATE>
[ 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
@ -394,13 +394,13 @@ PRIVATE>
(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 )
@ -422,49 +422,49 @@ PRIVATE>
[ 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
@ -518,9 +518,9 @@ PRIVATE>
: 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 )
@ -575,14 +575,14 @@ PRIVATE>
[ 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 ;
@ -596,7 +596,7 @@ PRIVATE>
2over = [
2drop 2drop
] [
[ >r 2over + pick r> move >r 1+ r> ] keep
[ [ 2over + pick ] dip move [ 1+ ] dip ] keep
move-backward
] if ;
@ -604,15 +604,15 @@ PRIVATE>
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>
@ -621,19 +621,19 @@ 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' )
@ -652,7 +652,7 @@ PRIVATE>
: reverse-here ( seq -- )
dup length dup 2/ [
>r 2dup r>
[ 2dup ] dip
tuck - 1- rot exchange-unsafe
] each 2drop ;
@ -679,7 +679,7 @@ PRIVATE>
<PRIVATE
: joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ;
[ dup sum-lengths swap length 1 [-] ] dip length * + ;
PRIVATE>
@ -696,7 +696,7 @@ 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 ;
@ -735,12 +735,12 @@ PRIVATE>
>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
@ -755,7 +755,7 @@ PRIVATE>
: (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>
@ -763,7 +763,7 @@ 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
@ -771,7 +771,7 @@ PRIVATE>
: 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 ;
@ -801,14 +801,14 @@ PRIVATE>
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 )

14
core/slots/slots.factor
View File

@ -3,7 +3,7 @@
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 ;
@ -23,7 +23,7 @@ PREDICATE: writer < word "writer" word-prop ;
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 )
@ -59,7 +59,7 @@ ERROR: bad-slot-value value class ;
offset>> , \ set-slot , ;
: writer-quot/coerce ( slot-spec -- )
[ \ >r , class>> "coercer" word-prop % \ r> , ]
[ class>> "coercer" word-prop [ dip ] curry % ]
[ offset>> , \ set-slot , ]
bi ;
@ -75,7 +75,7 @@ ERROR: bad-slot-value value class ;
bi ;
: writer-quot/fixnum ( slot-spec -- )
[ >r >fixnum r> ] % writer-quot/check ;
[ [ >fixnum ] dip ] % writer-quot/check ;
: writer-quot ( slot-spec -- quot )
[
@ -108,9 +108,9 @@ ERROR: bad-slot-value value class ;
: 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 ;

22
core/sorting/sorting.factor
View File

@ -25,20 +25,20 @@ TUPLE: merge
: 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

Some files were not shown because too many files have changed in this diff Show More