Merge branch 'master' of http://factorcode.org/git/factor
Eduardo Cavazos
commit
b92acd65d0
|
|
@ -23,7 +23,7 @@ IN: bootstrap.image
|
|||
os name>> cpu name>> arch ;
|
||||
|
||||
: boot-image-name ( arch -- string )
|
||||
"boot." swap ".image" 3append ;
|
||||
"boot." ".image" surround ;
|
||||
|
||||
: my-boot-image-name ( -- string )
|
||||
my-arch boot-image-name ;
|
||||
|
|
|
|||
|
|
@ -99,48 +99,6 @@ HELP: seconds-per-year
|
|||
{ $values { "integer" integer } }
|
||||
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
|
||||
|
||||
HELP: biweekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of two week periods in a year." } ;
|
||||
|
||||
HELP: daily-360
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 360-day year." } ;
|
||||
|
||||
HELP: daily-365
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 365-day year." } ;
|
||||
|
||||
HELP: monthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of months in a year." } ;
|
||||
|
||||
HELP: semimonthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
|
||||
|
||||
HELP: weekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of weeks in a year." } ;
|
||||
|
||||
HELP: julian-day-number
|
||||
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
|
||||
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
|
||||
|
|
@ -582,8 +540,6 @@ ARTICLE: "calendar" "Calendar"
|
|||
{ $subsection "years" }
|
||||
{ $subsection "months" }
|
||||
{ $subsection "days" }
|
||||
"Calculating amounts per period of time:"
|
||||
{ $subsection "time-period-calculations" }
|
||||
"Meta-data about the calendar:"
|
||||
{ $subsection "calendar-facts" }
|
||||
;
|
||||
|
|
@ -670,18 +626,6 @@ ARTICLE: "calendar-facts" "Calendar facts"
|
|||
{ $subsection day-of-week }
|
||||
;
|
||||
|
||||
ARTICLE: "time-period-calculations" "Calculations over periods of time"
|
||||
{ $subsection monthly }
|
||||
{ $subsection semimonthly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection weekly }
|
||||
{ $subsection daily-360 }
|
||||
{ $subsection daily-365 }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection biweekly }
|
||||
;
|
||||
|
||||
ARTICLE: "years" "Year operations"
|
||||
"Leap year predicate:"
|
||||
{ $subsection leap-year? }
|
||||
|
|
|
|||
|
|
@ -167,5 +167,3 @@ IN: calendar.tests
|
|||
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
|
||||
|
||||
[ 4+1/6 ] [ 100 semimonthly ] unit-test
|
||||
|
|
|
|||
|
|
@ -89,13 +89,6 @@ PRIVATE>
|
|||
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
|
||||
: seconds-per-year ( -- integer ) 31556952 ; inline
|
||||
|
||||
: monthly ( x -- y ) 12 / ; inline
|
||||
: semimonthly ( x -- y ) 24 / ; inline
|
||||
: biweekly ( x -- y ) 26 / ; inline
|
||||
: weekly ( x -- y ) 52 / ; inline
|
||||
: daily-360 ( x -- y ) 360 / ; inline
|
||||
: daily-365 ( x -- y ) 365 / ; inline
|
||||
|
||||
:: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ IN: compiler.cfg.hats
|
|||
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
|
||||
: ^^not ( src -- dst ) ^^i1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
|
||||
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
|
||||
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
|
||||
|
|
|
|||
|
|
@ -92,6 +92,7 @@ INSN: ##shl-imm < ##binary-imm ;
|
|||
INSN: ##shr-imm < ##binary-imm ;
|
||||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##not < ##unary ;
|
||||
INSN: ##log2 < ##unary ;
|
||||
|
||||
! Overflowing arithmetic
|
||||
TUPLE: ##fixnum-overflow < insn src1 src2 ;
|
||||
|
|
|
|||
|
|
@ -53,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: emit-fixnum-bitnot ( -- )
|
||||
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
|
||||
|
||||
: emit-fixnum-log2 ( -- )
|
||||
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: (emit-fixnum*fast) ( -- dst )
|
||||
2inputs ^^untag-fixnum ^^mul ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ QUALIFIED: slots.private
|
|||
QUALIFIED: strings.private
|
||||
QUALIFIED: classes.tuple.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: math.integers.private
|
||||
QUALIFIED: alien.accessors
|
||||
IN: compiler.cfg.intrinsics
|
||||
|
||||
|
|
@ -93,6 +94,9 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
|
||||
: emit-intrinsic ( node word -- node/f )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||
|
|
@ -108,6 +112,7 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
|
||||
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
|
||||
|
|
|
|||
|
|
@ -163,6 +163,7 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
|
|||
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
||||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
M: ##log2 generate-insn dst/src %log2 ;
|
||||
|
||||
: src1/src2 ( insn -- src1 src2 )
|
||||
[ src1>> register ] [ src2>> register ] bi ; inline
|
||||
|
|
|
|||
|
|
@ -375,3 +375,9 @@ DEFER: loop-bbb
|
|||
: loop-ccc ( -- ) loop-bbb ;
|
||||
|
||||
[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
|
||||
|
||||
! Type inference issue
|
||||
[ 4 3 ] [
|
||||
1 >bignum 2 >bignum
|
||||
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel effects accessors math math.private math.libm
|
||||
math.partial-dispatch math.intervals math.parser math.order
|
||||
layouts words sequences sequences.private arrays assocs classes
|
||||
classes.algebra combinators generic.math splitting fry locals
|
||||
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||
definitions strings.private vectors hashtables
|
||||
USING: kernel effects accessors math math.private
|
||||
math.integers.private math.partial-dispatch math.intervals
|
||||
math.parser math.order layouts words sequences sequences.private
|
||||
arrays assocs classes classes.algebra combinators generic.math
|
||||
splitting fry locals classes.tuple alien.accessors
|
||||
classes.tuple.private slots.private definitions strings.private
|
||||
vectors hashtables
|
||||
stack-checker.state
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
[ rational math-class-max ] dip
|
||||
] unless ;
|
||||
|
||||
: ensure-math-class ( class must-be -- class' )
|
||||
[ class<= ] 2keep ? ;
|
||||
|
||||
: number-valued ( class interval -- class' interval' )
|
||||
[ number math-class-min ] dip ;
|
||||
[ number ensure-math-class ] dip ;
|
||||
|
||||
: integer-valued ( class interval -- class' interval' )
|
||||
[ integer math-class-min ] dip ;
|
||||
[ integer ensure-math-class ] dip ;
|
||||
|
||||
: real-valued ( class interval -- class' interval' )
|
||||
[ real math-class-min ] dip ;
|
||||
[ real ensure-math-class ] dip ;
|
||||
|
||||
: float-valued ( class interval -- class' interval' )
|
||||
over null-class? [
|
||||
|
|
@ -230,7 +234,7 @@ generic-comparison-ops [
|
|||
} [
|
||||
[
|
||||
in-d>> second value-info >literal<
|
||||
[ power-of-2? [ 1- bitand ] f ? ] when
|
||||
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
|
|
@ -247,6 +251,15 @@ generic-comparison-ops [
|
|||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
{ numerator denominator }
|
||||
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
||||
|
||||
{ (log2) fixnum-log2 bignum-log2 } [
|
||||
[
|
||||
[ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
\ string-nth [
|
||||
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
|
||||
] "outputs" set-word-prop
|
||||
|
|
|
|||
|
|
@ -34,17 +34,57 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
|
||||
|
||||
[ V{ number } ] [ [ + ] final-classes ] unit-test
|
||||
! Test type propagation for math ops
|
||||
: cleanup-math-class ( obj -- class )
|
||||
{ null fixnum bignum integer ratio rational float real complex number }
|
||||
[ class= ] with find nip ;
|
||||
|
||||
[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
|
||||
: final-math-class ( quot -- class )
|
||||
final-classes first cleanup-math-class ;
|
||||
|
||||
[ V{ float } ] [ [ /f ] final-classes ] unit-test
|
||||
[ number ] [ [ + ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ /i ] final-classes ] unit-test
|
||||
[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ { integer } declare bitnot ] final-classes
|
||||
] unit-test
|
||||
[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { real float } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float real } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ /f ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ /i ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
|
||||
|
||||
[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
|
||||
|
||||
[ null ] [ [ { null null } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
|
||||
|
||||
[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
||||
|
|
@ -66,18 +106,6 @@ IN: compiler.tree.propagation.tests
|
|||
[ { fixnum } declare 615949 * ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ null } ] [
|
||||
[ { null null } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ null } ] [
|
||||
[ { null fixnum } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { float fixnum } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ 255 bitand >fixnum 3 bitor ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -279,14 +307,6 @@ IN: compiler.tree.propagation.tests
|
|||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { real float } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { float real } declare + ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -604,6 +624,22 @@ MIXIN: empty-mixin
|
|||
[ { integer } declare 127 bitand ] final-info first interval>>
|
||||
] unit-test
|
||||
|
||||
[ V{ bignum } ] [
|
||||
[ { bignum } declare dup 1- bitxor ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ bignum integer } ] [
|
||||
[ { bignum integer } declare [ shift ] keep ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare log2 ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ word } ] [
|
||||
[ { fixnum } declare log2 0 >= ] final-classes
|
||||
] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef
|
|||
TYPEDEF: void* CFURLRef
|
||||
TYPEDEF: void* CFUUIDRef
|
||||
TYPEDEF: void* CFTypeRef
|
||||
TYPEDEF: void* CFFileDescriptorRef
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: long CFIndex
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: uint UInt32
|
||||
TYPEDEF: ulong CFTypeID
|
||||
TYPEDEF: UInt32 CFOptionFlags
|
||||
TYPEDEF: double CFTimeInterval
|
||||
TYPEDEF: double CFAbsoluteTime
|
||||
TYPEDEF: int CFFileDescriptorNativeDescriptor
|
||||
TYPEDEF: void* CFFileDescriptorCallBack
|
||||
|
||||
TYPEDEF: int CFNumberType
|
||||
: kCFNumberSInt8Type 1 ; inline
|
||||
|
|
@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
|||
] keep CFRelease ;
|
||||
|
||||
GENERIC: <CFNumber> ( number -- alien )
|
||||
|
||||
M: integer <CFNumber>
|
||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
||||
|
||||
M: float <CFNumber>
|
||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
||||
|
||||
M: t <CFNumber>
|
||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
||||
|
||||
M: f <CFNumber>
|
||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
||||
|
||||
: <CFData> ( byte-array -- alien )
|
||||
[ f ] dip dup length CFDataCreate ;
|
||||
|
||||
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
|
||||
CFAllocatorRef allocator,
|
||||
CFFileDescriptorNativeDescriptor fd,
|
||||
Boolean closeOnInvalidate,
|
||||
CFFileDescriptorCallBack callout,
|
||||
CFFileDescriptorContext* context
|
||||
) ;
|
||||
|
||||
FUNCTION: void CFFileDescriptorEnableCallBacks (
|
||||
CFFileDescriptorRef f,
|
||||
CFOptionFlags callBackTypes
|
||||
) ;
|
||||
|
||||
: load-framework ( name -- )
|
||||
dup <CFBundle> [
|
||||
CFBundleLoadExecutable drop
|
||||
|
|
@ -141,8 +162,11 @@ M: f <CFNumber>
|
|||
] ?if ;
|
||||
|
||||
TUPLE: CFRelease-destructor alien disposed ;
|
||||
|
||||
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
||||
|
||||
: &CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa &dispose drop ; inline
|
||||
|
||||
: |CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa |dispose drop ; inline
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ IN: core-foundation.run-loop
|
|||
: kCFRunLoopRunHandledSource 4 ; inline
|
||||
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
TYPEDEF: void* CFRunLoopSourceRef
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
|
||||
|
|
@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
|
|||
Boolean returnAfterSourceHandled
|
||||
) ;
|
||||
|
||||
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
|
||||
CFAllocatorRef allocator,
|
||||
CFFileDescriptorRef f,
|
||||
CFIndex order
|
||||
) ;
|
||||
|
||||
FUNCTION: void CFRunLoopAddSource (
|
||||
CFRunLoopRef rl,
|
||||
CFRunLoopSourceRef source,
|
||||
CFStringRef mode
|
||||
) ;
|
||||
|
||||
: CFRunLoopDefaultMode ( -- alien )
|
||||
#! Ugly, but we don't have static NSStrings
|
||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||
|
|
|
|||
|
|
@ -77,6 +77,7 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- )
|
|||
HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
HOOK: %log2 cpu ( dst src -- )
|
||||
|
||||
HOOK: %fixnum-add cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
|
||||
|
|
|
|||
|
|
@ -329,14 +329,15 @@ big-endian on
|
|||
! Math
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZ
|
||||
ds-reg ds-reg 4 SUBI
|
||||
4 ds-reg 0 LWZ
|
||||
3 3 4 OR
|
||||
3 3 tag-mask get ANDI
|
||||
\ f tag-number 4 LI
|
||||
0 3 0 CMPI
|
||||
2 BNE
|
||||
1 tag-fixnum 4 LI
|
||||
4 ds-reg 4 STWU
|
||||
4 ds-reg 0 STW
|
||||
] f f f \ both-fixnums? define-sub-primitive
|
||||
|
||||
: jit-math ( insn -- )
|
||||
|
|
|
|||
|
|
@ -37,8 +37,8 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
|||
M: ppc %load-indirect ( reg obj -- )
|
||||
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: ds-reg 29 ; inline
|
||||
: rs-reg 30 ; inline
|
||||
|
|
@ -145,8 +145,8 @@ M:: ppc %string-nth ( dst src index temp -- )
|
|||
temp temp index ADD
|
||||
temp temp index ADD
|
||||
temp temp byte-array-offset LHZ
|
||||
temp temp 8 SLWI
|
||||
dst dst temp OR
|
||||
temp temp 7 SLWI
|
||||
dst dst temp XOR
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -172,7 +172,7 @@ M: ppc %sar-imm SRAWI ;
|
|||
M: ppc %not NOT ;
|
||||
|
||||
: %alien-invoke-tail ( func dll -- )
|
||||
scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
|
||||
[ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
|
||||
|
||||
:: exchange-regs ( r1 r2 -- )
|
||||
scratch-reg r1 MR
|
||||
|
|
@ -411,7 +411,7 @@ M: ppc %set-alien-float swap 0 STFS ;
|
|||
M: ppc %set-alien-double swap 0 STFD ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
[ "nursery" f ] dip %load-dlsym ;
|
||||
"nursery" f %alien-global ;
|
||||
|
||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
|
||||
|
|
@ -433,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
|
|||
dst class store-header
|
||||
dst class store-tagged ;
|
||||
|
||||
: %alien-global ( dst name -- )
|
||||
[ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
|
||||
|
||||
: load-cards-offset ( dst -- )
|
||||
"cards_offset" %alien-global ;
|
||||
[ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
|
||||
|
||||
: load-decks-offset ( dst -- )
|
||||
"decks_offset" %alien-global ;
|
||||
[ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
|
||||
|
||||
M:: ppc %write-barrier ( src card# table -- )
|
||||
card-mark scratch-reg LI
|
||||
|
|
@ -627,14 +624,14 @@ M: ppc %prepare-alien-invoke
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f scratch-reg %load-dlsym
|
||||
scratch-reg "stack_chain" f %alien-global
|
||||
scratch-reg scratch-reg 0 LWZ
|
||||
1 scratch-reg 0 STW
|
||||
ds-reg scratch-reg 8 STW
|
||||
rs-reg scratch-reg 12 STW ;
|
||||
|
||||
M: ppc %alien-invoke ( symbol dll -- )
|
||||
11 %load-dlsym 11 MTLR BLRL ;
|
||||
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
|
||||
|
||||
M: ppc %alien-callback ( quot -- )
|
||||
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
|
|
|||
|
|
@ -384,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ;
|
|||
|
||||
: XCHG ( dst src -- ) OCT: 207 2-operand ;
|
||||
|
||||
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
|
||||
|
||||
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
|
||||
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
|
||||
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
|
||||
|
|
|
|||
|
|
@ -5,10 +5,12 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
|||
kernel kernel.private math memory namespaces make sequences
|
||||
words system layouts combinators math.order fry locals
|
||||
compiler.constants compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.codegen
|
||||
compiler.codegen.fixup ;
|
||||
compiler.cfg.instructions compiler.cfg.intrinsics
|
||||
compiler.codegen compiler.codegen.fixup ;
|
||||
IN: cpu.x86
|
||||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
||||
M: x86 two-operand? t ;
|
||||
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
|
|
@ -92,6 +94,7 @@ M: x86 %shl-imm nip SHL ;
|
|||
M: x86 %shr-imm nip SHR ;
|
||||
M: x86 %sar-imm nip SAR ;
|
||||
M: x86 %not drop NOT ;
|
||||
M: x86 %log2 BSR ;
|
||||
|
||||
: ?MOV ( dst src -- )
|
||||
2dup = [ 2drop ] [ MOV ] if ; inline
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
|
|||
|
||||
M: sqlite-db bind# ( spec obj -- )
|
||||
[
|
||||
[ column-name>> ":" swap next-sql-counter 3append dup 0% ]
|
||||
[ column-name>> ":" next-sql-counter surround dup 0% ]
|
||||
[ type>> ] bi
|
||||
] dip <literal-bind> 1, ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Ryan Murphy
|
||||
Doug Coleman
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: editors.editpadpro
|
||||
|
||||
ARTICLE: "editors.editpadpro" "EditPad Pro support"
|
||||
"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
|
||||
|
||||
ABOUT: "editors.editpadpro"
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
USING: definitions kernel parser words sequences math.parser
|
||||
namespaces editors io.launcher windows.shell32 io.files
|
||||
io.paths.windows strings unicode.case make ;
|
||||
IN: editors.editpadlite
|
||||
|
||||
: editpadlite-path ( -- path )
|
||||
\ editpadlite-path get-global [
|
||||
"JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: editpadlite ( file line -- )
|
||||
[
|
||||
editpadlite-path , drop ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ editpadlite ] edit-hook set-global
|
||||
|
|
@ -0,0 +1 @@
|
|||
EditPadLite editor integration
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: editors.editpadpro
|
||||
|
||||
ARTICLE: "editpadpro" "EditPad Pro support"
|
||||
"Just load this module and you will be able to edit documentation with EditPadPro. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
|
||||
ARTICLE: "editors.editpadpro" "EditPad Pro support"
|
||||
"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
|
||||
|
||||
ABOUT: "editpadpro"
|
||||
ABOUT: "editors.editpadpro"
|
||||
|
|
|
|||
|
|
@ -1,17 +1,16 @@
|
|||
USING: definitions kernel parser words sequences math.parser
|
||||
namespaces editors io.launcher windows.shell32 io.files
|
||||
io.paths strings unicode.case make ;
|
||||
io.paths.windows strings unicode.case make ;
|
||||
IN: editors.editpadpro
|
||||
|
||||
: editpadpro-path
|
||||
: editpadpro-path ( -- path )
|
||||
\ editpadpro-path get-global [
|
||||
program-files "JGsoft" append-path
|
||||
t [ >lower "editpadpro.exe" tail? ] find-file
|
||||
"JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: editpadpro ( file line -- )
|
||||
[
|
||||
editpadpro-path , "/l" swap number>string append , ,
|
||||
editpadpro-path , number>string "/l" prepend , ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ editpadpro ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences windows.shell32 make io.paths.windows ;
|
||||
IN: editors.editplus
|
||||
|
||||
: editplus-path ( -- path )
|
||||
\ editplus-path get-global [
|
||||
program-files "\\EditPlus 2\\editplus.exe" append-path
|
||||
"EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: editplus ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
USING: editors hardware-info.windows io.files io.launcher
|
||||
kernel math.parser namespaces sequences windows.shell32
|
||||
make ;
|
||||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make io.paths.windows ;
|
||||
IN: editors.emeditor
|
||||
|
||||
: emeditor-path ( -- path )
|
||||
\ emeditor-path get-global [
|
||||
program-files "\\EmEditor\\EmEditor.exe" append-path
|
||||
"EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: emeditor ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2008 Kibleur Christophe.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences windows.shell32 io.paths.windows make ;
|
||||
IN: editors.etexteditor
|
||||
|
||||
: etexteditor-path ( -- str )
|
||||
\ etexteditor-path get-global [
|
||||
program-files "e\\e.exe" append-path
|
||||
"e" t [ "e.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: etexteditor ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: editors.gvim io.files io.windows kernel namespaces
|
||||
sequences windows.shell32 io.paths system ;
|
||||
sequences windows.shell32 io.paths.windows system ;
|
||||
IN: editors.gvim.windows
|
||||
|
||||
M: windows gvim-path
|
||||
\ gvim-path get-global [
|
||||
program-files "vim" append-path
|
||||
t [ "gvim.exe" tail? ] find-file
|
||||
"vim" t [ "gvim.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@ USING: editors io.files io.launcher kernel math.parser
|
|||
namespaces sequences windows.shell32 make ;
|
||||
IN: editors.notepad2
|
||||
|
||||
: notepad2-path ( -- str )
|
||||
: notepad2-path ( -- path )
|
||||
\ notepad2-path get-global [
|
||||
program-files "C:\\Windows\\system32\\notepad.exe" append-path
|
||||
] unless* ;
|
||||
"C:\\Windows\\system32\\notepad.exe"
|
||||
] unless* ;
|
||||
|
||||
: notepad2 ( file line -- )
|
||||
[
|
||||
|
|
@ -13,4 +13,4 @@ IN: editors.notepad2
|
|||
"/g" , number>string , ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ notepad2 ] edit-hook set-global
|
||||
[ notepad2 ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences io.paths.windows make ;
|
||||
IN: editors.notepadpp
|
||||
|
||||
: notepadpp-path
|
||||
: notepadpp-path ( -- path )
|
||||
\ notepadpp-path get-global [
|
||||
program-files "notepad++\\notepad++.exe" append-path
|
||||
"notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: notepadpp ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,34 +1,25 @@
|
|||
! Basic SciTE integration for Factor.
|
||||
!
|
||||
! By Clemens F. Hofreither, 2007.
|
||||
! Copyright (C) 2007 Clemens F. Hofreither.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! clemens.hofreither@gmx.net
|
||||
!
|
||||
! In your .factor-rc or .factor-boot-rc,
|
||||
! require this module and set the scite-path
|
||||
! variable to point to your executable,
|
||||
! if not on the path.
|
||||
!
|
||||
USING: io.files io.launcher kernel namespaces math
|
||||
math.parser editors sequences windows.shell32 make ;
|
||||
USING: io.files io.launcher kernel namespaces io.paths.windows
|
||||
math math.parser editors sequences make unicode.case ;
|
||||
IN: editors.scite
|
||||
|
||||
: scite-path ( -- path )
|
||||
\ scite-path get-global [
|
||||
program-files "ScITE Source Code Editor\\SciTE.exe" append-path
|
||||
dup exists? [
|
||||
drop program-files "wscite\\SciTE.exe" append-path
|
||||
] unless
|
||||
"Scintilla Text Editor" t
|
||||
[ >lower "scite.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: scite-command ( file line -- cmd )
|
||||
swap
|
||||
[
|
||||
scite-path ,
|
||||
,
|
||||
"-goto:" swap number>string append ,
|
||||
] { } make ;
|
||||
swap
|
||||
[
|
||||
scite-path ,
|
||||
,
|
||||
number>string "-goto:" prepend ,
|
||||
] { } make ;
|
||||
|
||||
: scite-location ( file line -- )
|
||||
scite-command run-detached drop ;
|
||||
scite-command run-detached drop ;
|
||||
|
||||
[ scite-location ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
SciTE editor integration
|
||||
Scintilla text editor (SciTE) integration
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 make ;
|
||||
namespaces sequences io.paths.windows make ;
|
||||
IN: editors.ted-notepad
|
||||
|
||||
: ted-notepad-path
|
||||
: ted-notepad-path ( -- path )
|
||||
\ ted-notepad-path get-global [
|
||||
program-files "\\TED Notepad\\TedNPad.exe" append-path
|
||||
"TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: ted-notepad ( file line -- )
|
||||
[
|
||||
ted-notepad-path , "/l" swap number>string append , ,
|
||||
ted-notepad-path ,
|
||||
number>string "/l" prepend , ,
|
||||
] { } make run-detached drop ;
|
||||
|
||||
[ ted-notepad ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.textedit
|
||||
|
||||
: textedit-location ( file line -- )
|
||||
|
|
@ -9,5 +8,3 @@ IN: editors.textedit
|
|||
try-process ;
|
||||
|
||||
[ textedit-location ] edit-hook set-global
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
USING: editors io.files io.launcher kernel math.parser
|
||||
namespaces sequences windows.shell32 wne ;
|
||||
namespaces sequences io.paths.windows make ;
|
||||
IN: editors.ultraedit
|
||||
|
||||
: ultraedit-path ( -- path )
|
||||
\ ultraedit-path get-global [
|
||||
program-files
|
||||
"IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
|
||||
"IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: ultraedit ( file line -- )
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
USING: editors hardware-info.windows io.launcher kernel
|
||||
math.parser namespaces sequences windows.shell32 io.files
|
||||
arrays ;
|
||||
USING: editors io.launcher kernel io.paths.windows
|
||||
math.parser namespaces sequences io.files arrays ;
|
||||
IN: editors.wordpad
|
||||
|
||||
: wordpad-path ( -- path )
|
||||
\ wordpad-path get [
|
||||
program-files "Windows NT\\Accessories\\wordpad.exe" append-path
|
||||
"Windows NT\\Accessories" t
|
||||
[ "wordpad.exe" tail? ] find-in-program-files
|
||||
] unless* ;
|
||||
|
||||
: wordpad ( file line -- )
|
||||
drop wordpad-path swap 2array dup . run-detached drop ;
|
||||
drop wordpad-path swap 2array run-detached drop ;
|
||||
|
||||
[ wordpad ] edit-hook set-global
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: grouping.tests
|
|||
|
||||
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
|
||||
|
||||
[ { V{ "a" "b" } V{ f f } } ] [
|
||||
[ { V{ "a" "b" } V{ 0 0 } } ] [
|
||||
V{ "a" "b" } clone 2 <groups>
|
||||
2 over set-length
|
||||
>array
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ SYMBOL: html
|
|||
#! dynamically creating words.
|
||||
[ elements-vocab create ] 2dip define-declared ;
|
||||
|
||||
: <foo> ( str -- <str> ) "<" swap ">" 3append ;
|
||||
: <foo> ( str -- <str> ) "<" ">" surround ;
|
||||
|
||||
: def-for-html-word-<foo> ( name -- )
|
||||
#! Return the name and code for the <foo> patterned
|
||||
|
|
@ -49,14 +49,14 @@ SYMBOL: html
|
|||
#! word.
|
||||
foo> [ ">" write-html ] (( -- )) html-word ;
|
||||
|
||||
: </foo> ( str -- </str> ) "</" swap ">" 3append ;
|
||||
: </foo> ( str -- </str> ) "</" ">" surround ;
|
||||
|
||||
: def-for-html-word-</foo> ( name -- )
|
||||
#! Return the name and code for the </foo> patterned
|
||||
#! word.
|
||||
</foo> dup '[ _ write-html ] (( -- )) html-word ;
|
||||
|
||||
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
|
||||
: <foo/> ( str -- <str/> ) "<" "/>" surround ;
|
||||
|
||||
: def-for-html-word-<foo/> ( name -- )
|
||||
#! Return the name and code for the <foo/> patterned
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@ M: macosx file-systems ( -- array )
|
|||
f <void*> dup 0 getmntinfo64 dup io-error
|
||||
[ *void* ] dip
|
||||
"statfs64" heap-size [ * memory>byte-array ] keep group
|
||||
[ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
[ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
|
||||
! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
|
||||
M: macosx new-file-system-info macosx-file-system-info new ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel math math.bitwise namespaces
|
||||
locals accessors combinators threads vectors hashtables
|
||||
sequences assocs continuations sets
|
||||
unix unix.time unix.kqueue unix.process
|
||||
io.ports io.unix.backend io.launcher io.unix.launcher
|
||||
io.monitors ;
|
||||
USING: accessors alien.c-types combinators io.unix.backend
|
||||
kernel math.bitwise sequences struct-arrays unix unix.kqueue
|
||||
unix.time ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx < mx events monitors ;
|
||||
|
|
@ -19,131 +16,66 @@ TUPLE: kqueue-mx < mx events monitors ;
|
|||
kqueue-mx new-mx
|
||||
H{ } clone >>monitors
|
||||
kqueue dup io-error >>fd
|
||||
max-events "kevent" <c-array> >>events ;
|
||||
max-events "kevent" <struct-array> >>events ;
|
||||
|
||||
GENERIC: io-task-filter ( task -- n )
|
||||
|
||||
M: input-task io-task-filter drop EVFILT_READ ;
|
||||
|
||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||
|
||||
GENERIC: io-task-fflags ( task -- n )
|
||||
|
||||
M: io-task io-task-fflags drop 0 ;
|
||||
|
||||
: make-kevent ( task flags -- event )
|
||||
: make-kevent ( fd filter flags -- event )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
over io-task-fd over set-kevent-ident
|
||||
over io-task-fflags over set-kevent-fflags
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
[ set-kevent-flags ] keep
|
||||
[ set-kevent-filter ] keep
|
||||
[ set-kevent-ident ] keep ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
fd>> swap 1 f 0 f kevent
|
||||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||
fd>> swap 1 f 0 f kevent io-error ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
[ >r EV_ADD make-kevent r> register-kevent ]
|
||||
[ call-next-method ]
|
||||
2bi ;
|
||||
M: kqueue-mx add-input-callback ( thread fd mx -- )
|
||||
[ call-next-method ] [
|
||||
[ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||
register-kevent
|
||||
] 2bi ;
|
||||
|
||||
M: kqueue-mx unregister-io-task ( task mx -- )
|
||||
[ call-next-method ]
|
||||
[ >r EV_DELETE make-kevent r> register-kevent ]
|
||||
2bi ;
|
||||
M: kqueue-mx add-output-callback ( thread fd mx -- )
|
||||
[ call-next-method ] [
|
||||
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] 2bi ;
|
||||
|
||||
: cancel-input-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ EVFILT_READ EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] [ remove-input-callbacks ] 2bi ;
|
||||
|
||||
: cancel-output-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||
register-kevent
|
||||
] [ remove-output-callbacks ] 2bi ;
|
||||
|
||||
M: fd cancel-operation ( fd -- )
|
||||
dup disposed>> [ drop ] [
|
||||
fd>>
|
||||
mx get-global
|
||||
[ cancel-input-callbacks [ t swap resume-with ] each ]
|
||||
[ cancel-output-callbacks [ t swap resume-with ] each ]
|
||||
2bi
|
||||
] if ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||
[
|
||||
[ fd>> f 0 ]
|
||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||
] dip kevent
|
||||
dup multiplexer-error ;
|
||||
|
||||
:: kevent-read-task ( mx fd kevent -- )
|
||||
mx fd mx reads>> at perform-io-task ;
|
||||
|
||||
:: kevent-write-task ( mx fd kevent -- )
|
||||
mx fd mx writes>> at perform-io-task ;
|
||||
|
||||
:: kevent-proc-task ( mx pid kevent -- )
|
||||
pid wait-for-pid
|
||||
pid find-process
|
||||
dup [ swap notify-exit ] [ 2drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
NOTE_DELETE +remove-file+ ?flag
|
||||
NOTE_WRITE +modify-file+ ?flag
|
||||
NOTE_EXTEND +modify-file+ ?flag
|
||||
NOTE_ATTRIB +modify-file+ ?flag
|
||||
NOTE_RENAME +rename-file+ ?flag
|
||||
NOTE_REVOKE +remove-file+ ?flag
|
||||
drop
|
||||
] { } make prune ;
|
||||
|
||||
:: kevent-vnode-task ( mx kevent fd -- )
|
||||
""
|
||||
kevent kevent-fflags parse-action
|
||||
fd mx monitors>> at queue-change ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
[ ] [ kevent-ident ] [ kevent-filter ] tri {
|
||||
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
||||
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
|
||||
{ [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
|
||||
} cond ;
|
||||
[ kevent-ident swap ] [ kevent-filter ] bi {
|
||||
{ EVFILT_READ [ input-available ] }
|
||||
{ EVFILT_WRITE [ output-available ] }
|
||||
} case ;
|
||||
|
||||
: handle-kevents ( mx n -- )
|
||||
[ over events>> kevent-nth handle-kevent ] with each ;
|
||||
[ dup events>> ] dip head-slice [ handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( us mx -- )
|
||||
swap dup [ make-timespec ] when
|
||||
dupd wait-kevent handle-kevents ;
|
||||
|
||||
! Procs
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-ident
|
||||
EV_ADD over set-kevent-flags
|
||||
EVFILT_PROC over set-kevent-filter
|
||||
NOTE_EXIT over set-kevent-fflags ;
|
||||
|
||||
: register-pid-task ( pid mx -- )
|
||||
swap make-proc-kevent swap register-kevent ;
|
||||
|
||||
! VNodes
|
||||
TUPLE: vnode-monitor < monitor fd ;
|
||||
|
||||
: vnode-fflags ( -- n )
|
||||
{
|
||||
NOTE_DELETE
|
||||
NOTE_WRITE
|
||||
NOTE_EXTEND
|
||||
NOTE_ATTRIB
|
||||
NOTE_LINK
|
||||
NOTE_RENAME
|
||||
NOTE_REVOKE
|
||||
} flags ;
|
||||
|
||||
: make-vnode-kevent ( fd flags -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
tuck set-kevent-ident
|
||||
EVFILT_VNODE over set-kevent-filter
|
||||
vnode-fflags over set-kevent-fflags ;
|
||||
|
||||
: register-monitor ( monitor mx -- )
|
||||
>r dup fd>> r>
|
||||
[ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
|
||||
[ monitors>> set-at ] 3bi ;
|
||||
|
||||
: unregister-monitor ( monitor mx -- )
|
||||
>r fd>> r>
|
||||
[ monitors>> delete-at ]
|
||||
[ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
|
||||
|
||||
: <vnode-monitor> ( path mailbox -- monitor )
|
||||
>r [ O_RDONLY 0 open dup io-error ] keep r>
|
||||
vnode-monitor new-monitor swap >>fd
|
||||
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
|
||||
|
||||
M: vnode-monitor dispose
|
||||
[ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ TUPLE: CreateProcess-args
|
|||
|
||||
: escape-argument ( str -- newstr )
|
||||
CHAR: \s over member? [
|
||||
"\"" swap fix-trailing-backslashes "\"" 3append
|
||||
fix-trailing-backslashes "\"" dup surround
|
||||
] when ;
|
||||
|
||||
: join-arguments ( args -- cmd-line )
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
|
|||
{ $subsection interval-bitnot }
|
||||
{ $subsection interval-recip }
|
||||
{ $subsection interval-2/ }
|
||||
{ $subsection interval-abs } ;
|
||||
{ $subsection interval-abs }
|
||||
{ $subsection interval-log2 } ;
|
||||
|
||||
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
|
||||
{ $subsection interval-contains? }
|
||||
|
|
@ -203,6 +204,10 @@ HELP: interval-abs
|
|||
{ $values { "i1" interval } { "i2" interval } }
|
||||
{ $description "Absolute value of an interval." } ;
|
||||
|
||||
HELP: interval-log2
|
||||
{ $values { "i1" interval } { "i2" interval } }
|
||||
{ $description "Integer-valued Base-2 logarithm of an interval." } ;
|
||||
|
||||
HELP: interval-intersect
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
||||
USING: accessors kernel sequences arrays math math.order
|
||||
combinators generic ;
|
||||
combinators generic layouts ;
|
||||
IN: math.intervals
|
||||
|
||||
SYMBOL: empty-interval
|
||||
|
|
@ -365,7 +365,7 @@ SYMBOL: incomparable
|
|||
2dup [ interval-nonnegative? ] both?
|
||||
[
|
||||
[ interval>points [ first ] bi@ ] bi@
|
||||
4array supremum 0 swap next-power-of-2 [a,b]
|
||||
4array supremum 0 swap >integer next-power-of-2 [a,b]
|
||||
] [ 2drop [-inf,inf] ] if
|
||||
] do-empty-interval ;
|
||||
|
||||
|
|
@ -373,6 +373,18 @@ SYMBOL: incomparable
|
|||
#! Inaccurate.
|
||||
interval-bitor ;
|
||||
|
||||
: interval-log2 ( i1 -- i2 )
|
||||
{
|
||||
{ empty-interval [ empty-interval ] }
|
||||
{ full-interval [ 0 [a,inf] ] }
|
||||
[
|
||||
to>> first 1 max dup most-positive-fixnum >
|
||||
[ drop full-interval interval-log2 ]
|
||||
[ 1+ >integer log2 0 swap [a,b] ]
|
||||
if
|
||||
]
|
||||
} case ;
|
||||
|
||||
: assume< ( i1 i2 -- i3 )
|
||||
dup special-interval? [ drop ] [
|
||||
to>> first [-inf,a) interval-intersect
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel memoize tools.test parser
|
||||
USING: math kernel memoize tools.test parser generalizations
|
||||
prettyprint io.streams.string sequences eval ;
|
||||
IN: memoize.tests
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
|
|||
|
||||
[ 89 ] [ 10 fib ] unit-test
|
||||
|
||||
[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
|
||||
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
|
||||
|
||||
MEMO: see-test ( a -- b ) reverse ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ SYMBOL: building-seq
|
|||
|
||||
: n, ( obj n -- ) get-building-seq push ;
|
||||
: n% ( seq n -- ) get-building-seq push-all ;
|
||||
: n# ( num n -- ) >r number>string r> n% ;
|
||||
: n# ( num n -- ) [ number>string ] dip n% ;
|
||||
|
||||
: 0, ( obj -- ) 0 n, ;
|
||||
: 0% ( seq -- ) 0 n% ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: prettyprint.backend
|
|||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
||||
M: effect pprint* effect>string "(" swap ")" 3append text ;
|
||||
M: effect pprint* effect>string "(" ")" surround text ;
|
||||
|
||||
: ?effect-height ( word -- n )
|
||||
stack-effect [ effect-height ] [ 0 ] if* ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
|
|||
100 [ 100 random ] replicate ;
|
||||
|
||||
: test-rng ( seed quot -- )
|
||||
>r <mersenne-twister> r> with-random ;
|
||||
[ <mersenne-twister> ] dip with-random ;
|
||||
|
||||
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -72,10 +72,12 @@ ERROR: bad-email-address email ;
|
|||
[ bad-email-address ] unless ;
|
||||
|
||||
: mail-from ( fromaddr -- )
|
||||
"MAIL FROM:<" swap validate-address ">" 3append command ;
|
||||
validate-address
|
||||
"MAIL FROM:<" ">" surround command ;
|
||||
|
||||
: rcpt-to ( to -- )
|
||||
"RCPT TO:<" swap validate-address ">" 3append command ;
|
||||
validate-address
|
||||
"RCPT TO:<" ">" surround command ;
|
||||
|
||||
: data ( -- )
|
||||
"DATA" command ;
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ M: not-enough-characters summary ( obj -- str )
|
|||
|
||||
: expect ( ch -- )
|
||||
get-char 2dup = [ 2drop ] [
|
||||
>r 1string r> 1string expected
|
||||
[ 1string ] bi@ expected
|
||||
] if next ;
|
||||
|
||||
: expect-string ( string -- )
|
||||
|
|
@ -155,4 +155,4 @@ M: not-enough-characters summary ( obj -- str )
|
|||
swap [ init-parser call ] with-input-stream ; inline
|
||||
|
||||
: string-parse ( input quot -- )
|
||||
>r <string-reader> r> state-parse ; inline
|
||||
[ <string-reader> ] dip state-parse ; inline
|
||||
|
|
|
|||
|
|
@ -14,34 +14,22 @@ urls math.parser ;
|
|||
: small-enough? ( n -- ? )
|
||||
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ 500000 small-enough? ] unit-test
|
||||
[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "sudoku" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 800000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 1300000 small-enough? ] unit-test
|
||||
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
|
||||
|
||||
[ "staging.math-compiler-threads-ui-strip.image" ] [
|
||||
"hello-ui" deploy-config
|
||||
[ bootstrap-profile staging-image-name file-name ] bind
|
||||
] unit-test
|
||||
|
||||
[ ] [ "maze" shake-and-bake ] unit-test
|
||||
[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
|
||||
|
||||
[ t ] [ 1200000 small-enough? ] unit-test
|
||||
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
|
||||
|
||||
[ ] [ "tetris" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [ 1500000 small-enough? ] unit-test
|
||||
|
||||
! [ ] [ "bunny" shake-and-bake ] unit-test
|
||||
|
||||
! [ t ] [ 2500000 small-enough? ] unit-test
|
||||
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
|
||||
|
||||
: run-temp-image ( -- )
|
||||
vm
|
||||
|
|
@ -110,3 +98,8 @@ M: quit-responder call-responder*
|
|||
"tools.deploy.test.7" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.8" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
USING: kernel ;
|
||||
IN: tools.deploy.test.8
|
||||
|
||||
: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
|
||||
: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
|
||||
|
||||
: literal-merge-test ( -- )
|
||||
literal-merge-test-1
|
||||
literal-merge-test-2 eq? t assert= ;
|
||||
|
||||
MAIN: literal-merge-test
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-name "tools.deploy.test.8" }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-threads? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-math? f }
|
||||
}
|
||||
|
|
@ -1,14 +1,15 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators io io.files kernel
|
||||
math.parser sequences system vocabs.loader calendar ;
|
||||
math.parser sequences system vocabs.loader calendar math
|
||||
symbols fry prettyprint ;
|
||||
IN: tools.files
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ls-time ( timestamp -- string )
|
||||
[ hour>> ] [ minute>> ] bi
|
||||
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
|
||||
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
|
||||
|
||||
: ls-timestamp ( timestamp -- string )
|
||||
[ month>> month-abbreviation ]
|
||||
|
|
@ -32,7 +33,37 @@ PRIVATE>
|
|||
: directory. ( path -- )
|
||||
[ (directory.) ] with-directory-files [ print ] each ;
|
||||
|
||||
SYMBOLS: device-name mount-point type
|
||||
available-space free-space used-space total-space
|
||||
percent-used percent-free ;
|
||||
|
||||
: percent ( real -- integer ) 100 * >integer ; inline
|
||||
|
||||
: file-system-spec ( file-system-info obj -- str )
|
||||
{
|
||||
{ device-name [ device-name>> ] }
|
||||
{ mount-point [ mount-point>> ] }
|
||||
{ type [ type>> ] }
|
||||
{ available-space [ available-space>> ] }
|
||||
{ free-space [ free-space>> ] }
|
||||
{ used-space [ used-space>> ] }
|
||||
{ total-space [ total-space>> ] }
|
||||
{ percent-used [
|
||||
[ used-space>> ] [ total-space>> ] bi dup 0 =
|
||||
[ 2drop 0 ] [ / percent ] if
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: file-systems-info ( spec -- seq )
|
||||
file-systems swap '[ _ [ file-system-spec ] with map ] map ;
|
||||
|
||||
: file-systems. ( spec -- )
|
||||
[ file-systems-info ]
|
||||
[ [ unparse ] map ] bi prefix simple-table. ;
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "tools.files.unix" ] }
|
||||
{ [ os windows? ] [ "tools.files.windows" ] }
|
||||
} cond require
|
||||
|
||||
! { device-name free-space used-space total-space percent-used } file-systems.
|
||||
|
|
|
|||
|
|
@ -289,7 +289,7 @@ M: vocab-spec article-parent drop "vocab-index" ;
|
|||
M: vocab-tag >link ;
|
||||
|
||||
M: vocab-tag article-title
|
||||
name>> "Vocabularies tagged ``" swap "''" 3append ;
|
||||
name>> "Vocabularies tagged ``" "''" surround ;
|
||||
|
||||
M: vocab-tag article-name name>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ M: freetype-renderer free-fonts ( world -- )
|
|||
} at ;
|
||||
|
||||
: ttf-path ( name -- string )
|
||||
"resource:fonts/" swap ".ttf" 3append ;
|
||||
"resource:fonts/" ".ttf" surround ;
|
||||
|
||||
: (open-face) ( path length -- face )
|
||||
#! We use FT_New_Memory_Face, not FT_New_Face, since
|
||||
|
|
|
|||
|
|
@ -119,5 +119,5 @@ deploy-gadget "toolbar" f {
|
|||
: deploy-tool ( vocab -- )
|
||||
vocab-name
|
||||
[ <deploy-gadget> 10 <border> ]
|
||||
[ "Deploying \"" swap "\"" 3append ] bi
|
||||
[ "Deploying \"" "\"" surround ] bi
|
||||
open-window ;
|
||||
|
|
|
|||
|
|
@ -16,3 +16,9 @@ USING: unicode.case tools.test namespaces ;
|
|||
"lt" locale set
|
||||
! Lithuanian casing tests
|
||||
] with-scope
|
||||
|
||||
[ t ] [ "asdf" lower? ] unit-test
|
||||
[ f ] [ "asdF" lower? ] unit-test
|
||||
|
||||
[ t ] [ "ASDF" upper? ] unit-test
|
||||
[ f ] [ "ASDf" upper? ] unit-test
|
||||
|
|
|
|||
|
|
@ -100,11 +100,10 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
: >case-fold ( string -- fold )
|
||||
>upper >lower ;
|
||||
|
||||
: lower? ( string -- ? )
|
||||
dup >lower = ;
|
||||
: upper? ( string -- ? )
|
||||
dup >lower = ;
|
||||
: title? ( string -- ? )
|
||||
dup >title = ;
|
||||
: case-fold? ( string -- ? )
|
||||
dup >case-fold = ;
|
||||
: lower? ( string -- ? ) dup >lower = ;
|
||||
|
||||
: upper? ( string -- ? ) dup >upper = ;
|
||||
|
||||
: title? ( string -- ? ) dup >title = ;
|
||||
|
||||
: case-fold? ( string -- ? ) dup >case-fold = ;
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ M: array resize resize-array ;
|
|||
|
||||
: >array ( seq -- array ) { } clone-like ;
|
||||
|
||||
M: object new-sequence drop f <array> ;
|
||||
M: object new-sequence drop 0 <array> ;
|
||||
|
||||
M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
|
||||
M: f new-sequence drop dup zero? [ drop f ] [ 0 <array> ] if ;
|
||||
|
||||
M: array equal?
|
||||
over array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
] if ; inline recursive
|
||||
|
||||
: assoc-stack ( key seq -- value )
|
||||
dup length 1- swap (assoc-stack) ;
|
||||
dup length 1- swap (assoc-stack) ; flushable
|
||||
|
||||
: assoc-subset? ( assoc1 assoc2 -- ? )
|
||||
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ PREDICATE: intersection-class < class
|
|||
[ drop t ]
|
||||
] [
|
||||
unclip "predicate" word-prop swap [
|
||||
"predicate" word-prop [ dup ] swap [ not ] 3append
|
||||
"predicate" word-prop [ dup ] [ not ] surround
|
||||
[ drop f ]
|
||||
] { } map>assoc alist>quot
|
||||
] if-empty ;
|
||||
|
|
|
|||
|
|
@ -28,9 +28,6 @@ PREDICATE: math-class < class
|
|||
: math-class-max ( class1 class2 -- class )
|
||||
[ math-class<=> ] most ;
|
||||
|
||||
: math-class-min ( class1 class2 -- class )
|
||||
[ swap math-class<=> ] most ;
|
||||
|
||||
: (math-upgrade) ( max class -- quot )
|
||||
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ TUPLE: hashtable
|
|||
0 >>count 0 >>deleted drop ; inline
|
||||
|
||||
: reset-hash ( n hash -- )
|
||||
swap <hash-array> >>array init-hash ;
|
||||
swap <hash-array> >>array init-hash ; inline
|
||||
|
||||
: (new-key@) ( key keys i -- keys n empty? )
|
||||
3dup swap array-nth dup ((empty)) eq? [
|
||||
|
|
|
|||
|
|
@ -40,11 +40,10 @@ M: fixnum bitnot fixnum-bitnot ;
|
|||
|
||||
M: fixnum bit? neg shift 1 bitand 0 > ;
|
||||
|
||||
: (fixnum-log2) ( accum n -- accum )
|
||||
dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ;
|
||||
inline recursive
|
||||
: fixnum-log2 ( x -- n )
|
||||
0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ;
|
||||
|
||||
M: fixnum (log2) 0 swap (fixnum-log2) ;
|
||||
M: fixnum (log2) fixnum-log2 ;
|
||||
|
||||
M: bignum >fixnum bignum>fixnum ;
|
||||
M: bignum >bignum ;
|
||||
|
|
@ -74,7 +73,7 @@ M: bignum /mod bignum/mod ;
|
|||
M: bignum bitand bignum-bitand ;
|
||||
M: bignum bitor bignum-bitor ;
|
||||
M: bignum bitxor bignum-bitxor ;
|
||||
M: bignum shift bignum-shift ;
|
||||
M: bignum shift >fixnum bignum-shift ;
|
||||
|
||||
M: bignum bitnot bignum-bitnot ;
|
||||
M: bignum bit? bignum-bit? ;
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ PRIVATE>
|
|||
"log2 expects positive inputs" throw
|
||||
] [
|
||||
(log2)
|
||||
] if ; foldable
|
||||
] if ; inline
|
||||
|
||||
: zero? ( x -- ? ) 0 number= ; inline
|
||||
: 1+ ( x -- y ) 1 + ; inline
|
||||
|
|
@ -103,14 +103,8 @@ M: float fp-infinity? ( float -- ? )
|
|||
drop f
|
||||
] if ;
|
||||
|
||||
: (next-power-of-2) ( i n -- n )
|
||||
2dup >= [
|
||||
drop
|
||||
] [
|
||||
[ 1 shift ] dip (next-power-of-2)
|
||||
] if ;
|
||||
|
||||
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
|
||||
: next-power-of-2 ( m -- n )
|
||||
dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
|
||||
|
||||
: power-of-2? ( n -- ? )
|
||||
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
|
||||
|
|
|
|||
|
|
@ -12,12 +12,12 @@ IN: namespaces
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: namespace ( -- namespace ) namestack* peek ;
|
||||
: namespace ( -- namespace ) namestack* peek ; inline
|
||||
: namestack ( -- namestack ) namestack* clone ;
|
||||
: set-namestack ( namestack -- ) >vector 0 setenv ;
|
||||
: global ( -- g ) 21 getenv { hashtable } declare ; inline
|
||||
: init-namespaces ( -- ) global 1array set-namestack ;
|
||||
: get ( variable -- value ) namestack* assoc-stack ; flushable
|
||||
: get ( variable -- value ) namestack* assoc-stack ; inline
|
||||
: set ( value variable -- ) namespace set-at ;
|
||||
: on ( variable -- ) t swap set ; inline
|
||||
: off ( variable -- ) f swap set ; inline
|
||||
|
|
@ -28,7 +28,7 @@ PRIVATE>
|
|||
: inc ( variable -- ) 1 swap +@ ; inline
|
||||
: dec ( variable -- ) -1 swap +@ ; inline
|
||||
: bind ( ns quot -- ) swap >n call ndrop ; inline
|
||||
: counter ( variable -- n ) global [ dup inc get ] bind ;
|
||||
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
|
||||
|
||||
: make-assoc ( quot exemplar -- hash )
|
||||
20 swap new-assoc [ >n call ndrop ] keep ; inline
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ TUPLE: no-current-vocab ;
|
|||
|
||||
: word-restarts ( name possibilities -- restarts )
|
||||
natural-sort
|
||||
[ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
|
||||
[ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
|
||||
swap "Defer word in current vocabulary" swap 2array
|
||||
suffix ;
|
||||
|
||||
|
|
@ -89,7 +89,7 @@ SYMBOL: auto-use?
|
|||
dup vocabulary>>
|
||||
[ (use+) ]
|
||||
[ amended-use get dup [ push ] [ 2drop ] if ]
|
||||
[ "Added ``" swap "'' vocabulary to search path" 3append note. ]
|
||||
[ "Added ``" "'' vocabulary to search path" surround note. ]
|
||||
tri
|
||||
] [ create-in ] if ;
|
||||
|
||||
|
|
@ -292,7 +292,7 @@ print-use-hook global [ [ ] or ] change-at
|
|||
] with-compilation-unit ;
|
||||
|
||||
: parse-file-restarts ( file -- restarts )
|
||||
"Load " swap " again" 3append t 2array 1array ;
|
||||
"Load " " again" surround t 2array 1array ;
|
||||
|
||||
: parse-file ( file -- quot )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -416,11 +416,6 @@ HELP: interleave
|
|||
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
|
||||
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
|
||||
|
||||
HELP: cache-nth
|
||||
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
|
||||
{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
|
||||
{ $side-effects "seq" } ;
|
||||
|
||||
HELP: index
|
||||
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
|
||||
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
|
||||
|
|
@ -1497,7 +1492,6 @@ ARTICLE: "sequences-destructive" "Destructive operations"
|
|||
"Changing elements:"
|
||||
{ $subsection change-each }
|
||||
{ $subsection change-nth }
|
||||
{ $subsection cache-nth }
|
||||
"Deleting elements:"
|
||||
{ $subsection delete }
|
||||
{ $subsection delq }
|
||||
|
|
|
|||
|
|
@ -190,16 +190,6 @@ unit-test
|
|||
|
||||
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
|
||||
|
||||
[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
|
||||
V{ } clone "cache-test" set
|
||||
1 "cache-test" get [ sq ] cache-nth
|
||||
2 "cache-test" get [ sq ] cache-nth
|
||||
3 "cache-test" get [ sq ] cache-nth
|
||||
4 "cache-test" get [ sq ] cache-nth
|
||||
4 "cache-test" get [ "wrong" ] cache-nth
|
||||
"cache-test" get
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
|
||||
|
||||
! Pathological case
|
||||
|
|
|
|||
|
|
@ -523,13 +523,6 @@ PRIVATE>
|
|||
: harvest ( seq -- newseq )
|
||||
[ empty? not ] filter ;
|
||||
|
||||
: cache-nth ( i seq quot -- elt )
|
||||
2over ?nth dup [
|
||||
[ 3drop ] dip
|
||||
] [
|
||||
drop swap [ over [ call dup ] dip ] dip set-nth
|
||||
] if ; inline
|
||||
|
||||
: mismatch ( seq1 seq2 -- i )
|
||||
[ min-length ] 2keep
|
||||
[ 2nth-unsafe = not ] 2curry
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ PREDICATE: writer < word "writer" word-prop ;
|
|||
define-typecheck ;
|
||||
|
||||
: writer-word ( name -- word )
|
||||
"(>>" swap ")" 3append (( value object -- )) create-accessor
|
||||
"(>>" ")" surround (( value object -- )) create-accessor
|
||||
dup t "writer" set-word-prop ;
|
||||
|
||||
ERROR: bad-slot-value value class ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: vector
|
|||
{ underlying array }
|
||||
{ length array-capacity } ;
|
||||
|
||||
: <vector> ( n -- vector ) f <array> 0 vector boa ; inline
|
||||
: <vector> ( n -- vector ) 0 <array> 0 vector boa ; inline
|
||||
|
||||
: >vector ( seq -- vector ) V{ } clone-like ;
|
||||
|
||||
|
|
|
|||
|
|
@ -239,7 +239,7 @@ ERROR: bad-create name vocab ;
|
|||
dup [ 2nip ] [ drop <word> dup reveal ] if ;
|
||||
|
||||
: constructor-word ( name vocab -- word )
|
||||
[ "<" swap ">" 3append ] dip create ;
|
||||
[ "<" ">" surround ] dip create ;
|
||||
|
||||
PREDICATE: parsing-word < word "parsing" word-prop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
USING: arrays bunny.model bunny.cel-shaded continuations
|
||||
destructors kernel math multiline opengl opengl.shaders
|
||||
opengl.framebuffers opengl.gl opengl.demo-support
|
||||
opengl.capabilities sequences ui.gadgets combinators accessors ;
|
||||
opengl.framebuffers opengl.gl opengl.demo-support fry
|
||||
opengl.capabilities sequences ui.gadgets combinators accessors
|
||||
macros ;
|
||||
IN: bunny.outlined
|
||||
|
||||
STRING: outlined-pass1-fragment-shader-main-source
|
||||
|
|
@ -176,24 +177,30 @@ TUPLE: bunny-outlined
|
|||
} cleave
|
||||
] [ drop ] if ;
|
||||
|
||||
MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
|
||||
'[ _ _ (framebuffer-texture) [ @ drop ] keep ] ;
|
||||
|
||||
: (make-framebuffer-textures) ( draw dim -- draw color normal depth )
|
||||
{
|
||||
[ drop ]
|
||||
[ GL_RGBA16F_ARB GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ]
|
||||
[ GL_RGBA16F_ARB GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
|
||||
[
|
||||
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT
|
||||
[ >>depth-texture ] (framebuffer-texture>>draw)
|
||||
]
|
||||
} 2cleave ;
|
||||
|
||||
: remake-framebuffer ( draw -- )
|
||||
[ dispose-framebuffer ]
|
||||
[ dup gadget>> dim>>
|
||||
[ (make-framebuffer-textures) (make-framebuffer) >>framebuffer ]
|
||||
[ >>framebuffer-dim drop ] bi
|
||||
] bi ;
|
||||
|
||||
: remake-framebuffer-if-needed ( draw -- )
|
||||
dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
|
||||
[ drop ] [
|
||||
[ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
|
||||
[
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>color-texture drop ] keep
|
||||
] [
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>normal-texture drop ] keep
|
||||
] [
|
||||
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
|
||||
[ >>depth-texture drop ] keep
|
||||
]
|
||||
} 2cleave
|
||||
[ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi
|
||||
drop
|
||||
] if ;
|
||||
[ drop ] [ remake-framebuffer ] if ;
|
||||
|
||||
: clear-framebuffer ( -- )
|
||||
GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: combinators.lib.tests
|
|||
|
||||
[ { "foo" "xbarx" } ]
|
||||
[
|
||||
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
|
||||
{ "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
|
||||
] unit-test
|
||||
|
||||
{ 1 1 } [
|
||||
|
|
|
|||
|
|
@ -116,18 +116,9 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
|
|||
[ dip ] curry swap 1quotation [ keep ] curry compose
|
||||
] { } assoc>map concat compose ;
|
||||
|
||||
: either ( object first second -- ? )
|
||||
>r keep swap [ r> drop ] [ r> call ] ?if ; inline
|
||||
|
||||
: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
|
||||
>r pick >r with r> r> swapd with ;
|
||||
|
||||
: or? ( obj quot1 quot2 -- ? )
|
||||
[ keep ] dip rot [ 2nip ] [ call ] if* ; inline
|
||||
|
||||
: and? ( obj quot1 quot2 -- ? )
|
||||
[ keep ] dip rot [ call ] [ 2drop f ] if ; inline
|
||||
|
||||
MACRO: multikeep ( word out-indexes -- ... )
|
||||
[
|
||||
dup >r [ \ npick \ >r 3array % ] each
|
||||
|
|
|
|||
|
|
@ -8,5 +8,3 @@ IN: crypto.barrett
|
|||
#! size = word size in bits (8, 16, 32, 64, ...)
|
||||
[ [ log2 1+ ] [ / 2 * ] bi* ]
|
||||
[ 2^ rot ^ swap /i ] 2bi ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators checksums checksums.md5
|
||||
checksums.sha1 checksums.md5.private io io.binary io.files
|
||||
io.streams.byte-array kernel math math.vectors memoize sequences
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math threads system calendar ;
|
||||
IN: crypto.timing
|
||||
|
||||
|
|
|
|||
|
|
@ -8,5 +8,5 @@ IN: crypto.xor
|
|||
ERROR: empty-xor-key ;
|
||||
|
||||
: xor-crypt ( seq key -- seq' )
|
||||
dup empty? [ empty-xor-key ] when
|
||||
[ empty-xor-key ] when-empty
|
||||
[ dup length ] dip '[ _ mod-nth bitxor ] 2map ;
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@ IN: html.parser.utils
|
|||
[ ?head drop ] [ ?tail drop ] bi ;
|
||||
|
||||
: single-quote ( str -- newstr )
|
||||
"'" swap "'" 3append ;
|
||||
"'" dup surround ;
|
||||
|
||||
: double-quote ( str -- newstr )
|
||||
"\"" swap "\"" 3append ;
|
||||
"\"" dup surround ;
|
||||
|
||||
: quote ( str -- newstr )
|
||||
CHAR: ' over member?
|
||||
|
|
|
|||
|
|
@ -9,14 +9,12 @@ combinators.short-circuit fry qualified ;
|
|||
RENAME: _ fry => __
|
||||
IN: inverse
|
||||
|
||||
TUPLE: fail ;
|
||||
: fail ( -- * ) \ fail new throw ;
|
||||
ERROR: fail ;
|
||||
M: fail summary drop "Unification failed" ;
|
||||
|
||||
: assure ( ? -- ) [ fail ] unless ;
|
||||
|
||||
: =/fail ( obj1 obj2 -- )
|
||||
= assure ;
|
||||
: =/fail ( obj1 obj2 -- ) = assure ;
|
||||
|
||||
! Inverse of a quotation
|
||||
|
||||
|
|
@ -26,25 +24,26 @@ M: fail summary drop "Unification failed" ;
|
|||
pick 1quotation 3array "math-inverse" set-word-prop ;
|
||||
|
||||
: define-pop-inverse ( word n quot -- )
|
||||
>r dupd "pop-length" set-word-prop r>
|
||||
[ dupd "pop-length" set-word-prop ] dip
|
||||
"pop-inverse" set-word-prop ;
|
||||
|
||||
TUPLE: no-inverse word ;
|
||||
: no-inverse ( word -- * ) \ no-inverse new throw ;
|
||||
ERROR: no-inverse word ;
|
||||
M: no-inverse summary
|
||||
drop "The word cannot be used in pattern matching" ;
|
||||
|
||||
ERROR: bad-math-inverse ;
|
||||
|
||||
: next ( revquot -- revquot* first )
|
||||
[ "Badly formed math inverse" throw ]
|
||||
[ bad-math-inverse ]
|
||||
[ unclip-slice ] if-empty ;
|
||||
|
||||
: constant-word? ( word -- ? )
|
||||
stack-effect
|
||||
[ out>> length 1 = ] keep
|
||||
in>> length 0 = and ;
|
||||
[ out>> length 1 = ]
|
||||
[ in>> empty? ] bi and ;
|
||||
|
||||
: assure-constant ( constant -- quot )
|
||||
dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
|
||||
dup word? [ bad-math-inverse ] when 1quotation ;
|
||||
|
||||
: swap-inverse ( math-inverse revquot -- revquot* quot )
|
||||
next assure-constant rot second '[ @ swap @ ] ;
|
||||
|
|
@ -55,8 +54,7 @@ M: no-inverse summary
|
|||
: ?word-prop ( word/object name -- value/f )
|
||||
over word? [ word-prop ] [ 2drop f ] if ;
|
||||
|
||||
: undo-literal ( object -- quot )
|
||||
[ =/fail ] curry ;
|
||||
: undo-literal ( object -- quot ) [ =/fail ] curry ;
|
||||
|
||||
PREDICATE: normal-inverse < word "inverse" word-prop ;
|
||||
PREDICATE: math-inverse < word "math-inverse" word-prop ;
|
||||
|
|
@ -65,13 +63,13 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
|
||||
: enough? ( stack word -- ? )
|
||||
dup deferred? [ 2drop f ] [
|
||||
[ >r length r> 1quotation infer in>> >= ]
|
||||
[ [ length ] dip 1quotation infer in>> >= ]
|
||||
[ 3drop f ] recover
|
||||
] if ;
|
||||
|
||||
: fold-word ( stack word -- stack )
|
||||
2dup enough?
|
||||
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
|
||||
[ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
|
||||
|
||||
: fold ( quot -- folded-quot )
|
||||
[ { } swap [ fold-word ] each % ] [ ] make ;
|
||||
|
|
@ -95,13 +93,15 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
throw
|
||||
] recover ;
|
||||
|
||||
ERROR: undefined-inverse ;
|
||||
|
||||
GENERIC: inverse ( revquot word -- revquot* quot )
|
||||
|
||||
M: object inverse undo-literal ;
|
||||
|
||||
M: symbol inverse undo-literal ;
|
||||
|
||||
M: word inverse drop "Inverse is undefined" throw ;
|
||||
M: word inverse undefined-inverse ;
|
||||
|
||||
M: normal-inverse inverse
|
||||
"inverse" word-prop ;
|
||||
|
|
@ -112,8 +112,8 @@ M: math-inverse inverse
|
|||
[ drop swap-inverse ] [ pull-inverse ] if ;
|
||||
|
||||
M: pop-inverse inverse
|
||||
[ "pop-length" word-prop cut-slice swap >quotation ] keep
|
||||
"pop-inverse" word-prop compose call ;
|
||||
[ "pop-length" word-prop cut-slice swap >quotation ]
|
||||
[ "pop-inverse" word-prop ] bi compose call ;
|
||||
|
||||
: (undo) ( revquot -- )
|
||||
[ unclip-slice inverse % (undo) ] unless-empty ;
|
||||
|
|
@ -129,7 +129,7 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
\ dup [ [ =/fail ] keep ] define-inverse
|
||||
\ 2dup [ over =/fail over =/fail ] define-inverse
|
||||
\ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
|
||||
\ pick [ >r pick r> =/fail ] define-inverse
|
||||
\ pick [ [ pick ] dip =/fail ] define-inverse
|
||||
\ tuck [ swapd [ =/fail ] keep ] define-inverse
|
||||
|
||||
\ not [ not ] define-inverse
|
||||
|
|
@ -151,9 +151,12 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
\ sq [ sqrt ] define-inverse
|
||||
\ sqrt [ sq ] define-inverse
|
||||
|
||||
ERROR: missing-literal ;
|
||||
|
||||
: assert-literal ( n -- n )
|
||||
dup [ word? ] keep symbol? not and
|
||||
[ "Literal missing in pattern matching" throw ] when ;
|
||||
dup
|
||||
[ word? ] [ symbol? not ] bi and
|
||||
[ missing-literal ] when ;
|
||||
\ + [ - ] [ - ] define-math-inverse
|
||||
\ - [ + ] [ - ] define-math-inverse
|
||||
\ * [ / ] [ / ] define-math-inverse
|
||||
|
|
@ -162,7 +165,7 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
|
||||
\ ? 2 [
|
||||
[ assert-literal ] bi@
|
||||
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
|
||||
[ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
|
||||
2curry
|
||||
] define-pop-inverse
|
||||
|
||||
|
|
@ -217,7 +220,7 @@ DEFER: _
|
|||
dup wrapper? [ wrapped>> ] when ;
|
||||
|
||||
: boa-inverse ( class -- quot )
|
||||
[ deconstruct-pred ] keep slot-readers compose ;
|
||||
[ deconstruct-pred ] [ slot-readers ] bi compose ;
|
||||
|
||||
\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
|
||||
|
||||
|
|
@ -232,7 +235,7 @@ DEFER: _
|
|||
|
||||
: recover-fail ( try fail -- )
|
||||
[ drop call ] [
|
||||
>r nip r> dup fail?
|
||||
[ nip ] dip dup fail?
|
||||
[ drop call ] [ nip throw ] if
|
||||
] recover ; inline
|
||||
|
||||
|
|
@ -243,12 +246,11 @@ DEFER: _
|
|||
in>> [ ndrop f ] curry [ recover-fail ] curry ;
|
||||
|
||||
: [matches?] ( quot -- undoes?-quot )
|
||||
[undo] dup infer [ true-out ] keep false-recover curry ;
|
||||
[undo] dup infer [ true-out ] [ false-recover ] bi curry ;
|
||||
|
||||
MACRO: matches? ( quot -- ? ) [matches?] ;
|
||||
|
||||
TUPLE: no-match ;
|
||||
: no-match ( -- * ) \ no-match new throw ;
|
||||
ERROR: no-match ;
|
||||
M: no-match summary drop "Fall through in switch" ;
|
||||
|
||||
: recover-chain ( seq -- quot )
|
||||
|
|
@ -256,7 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
|
|||
|
||||
: [switch] ( quot-alist -- quot )
|
||||
[ dup quotation? [ [ ] swap 2array ] when ] map
|
||||
reverse [ >r [undo] r> compose ] { } assoc>map
|
||||
reverse [ [ [undo] ] dip compose ] { } assoc>map
|
||||
recover-chain ;
|
||||
|
||||
MACRO: switch ( quot-alist -- ) [switch] ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,13 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files kernel sequences accessors
|
||||
dlists deques arrays ;
|
||||
USING: accessors arrays deques dlists io.files io.paths.private
|
||||
kernel sequences system vocabs.loader fry continuations ;
|
||||
IN: io.paths
|
||||
|
||||
TUPLE: directory-iterator path bfs queue ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: qualified-directory ( path -- seq )
|
||||
dup directory-files [ append-path ] with map ;
|
||||
|
||||
|
|
@ -25,25 +27,32 @@ TUPLE: directory-iterator path bfs queue ;
|
|||
[ over push-directory next-file ] [ nip ] if
|
||||
] if ;
|
||||
|
||||
: iterate-directory ( iter quot -- obj )
|
||||
: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
|
||||
over next-file [
|
||||
over call
|
||||
[ 2drop ] [ iterate-directory ] if
|
||||
[ 2nip ] [ iterate-directory ] if*
|
||||
] [
|
||||
2drop f
|
||||
] if* ; inline recursive
|
||||
|
||||
: find-file ( path bfs? quot -- path/f )
|
||||
PRIVATE>
|
||||
|
||||
: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
|
||||
[ <directory-iterator> ] dip
|
||||
[ keep and ] curry iterate-directory ; inline
|
||||
|
||||
: each-file ( path bfs? quot -- )
|
||||
: each-file ( path bfs? quot: ( obj -- ? ) -- )
|
||||
[ <directory-iterator> ] dip
|
||||
[ f ] compose iterate-directory drop ; inline
|
||||
|
||||
: find-all-files ( path bfs? quot -- paths )
|
||||
: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
|
||||
[ <directory-iterator> ] dip
|
||||
pusher [ [ f ] compose iterate-directory drop ] dip ; inline
|
||||
|
||||
: recursive-directory ( path bfs? -- paths )
|
||||
[ ] accumulator [ each-file ] dip ;
|
||||
|
||||
: find-in-directories ( directories bfs? quot -- path' )
|
||||
'[ _ _ find-file ] attempt-all ; inline
|
||||
|
||||
os windows? [ "io.paths.windows" require ] when
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays continuations fry io.files io.paths
|
||||
kernel windows.shell32 sequences ;
|
||||
IN: io.paths.windows
|
||||
|
||||
: program-files-directories ( -- array )
|
||||
program-files program-files-x86 2array ; inline
|
||||
|
||||
: find-in-program-files ( base-directory bfs? quot -- path )
|
||||
[
|
||||
[ program-files-directories ] dip '[ _ append-path ] map
|
||||
] 2dip find-in-directories ; inline
|
||||
|
|
@ -90,11 +90,11 @@ M: end-of-names >>command-parameters ( names-reply params -- names-reply )
|
|||
first2 [ >>who ] [ >>channel ] bi* ;
|
||||
|
||||
M: mode >>command-parameters ( mode params -- mode )
|
||||
dup length 3 = [
|
||||
first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
|
||||
] [
|
||||
first2 [ >>name ] [ >>mode ] bi*
|
||||
] if ;
|
||||
dup length {
|
||||
{ 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
|
||||
{ 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
|
||||
[ drop first >>name dup trailing>> >>mode ]
|
||||
} case ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -135,12 +135,12 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
|||
|
||||
: copy-message-in ( command irc-message -- command )
|
||||
{
|
||||
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
|
||||
[ line>> >>line ]
|
||||
[ prefix>> >>prefix ]
|
||||
[ command>> >>command ]
|
||||
[ trailing>> >>trailing ]
|
||||
[ timestamp>> >>timestamp ]
|
||||
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
|
||||
} cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
|
|||
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
|
||||
io io.styles namespaces calendar calendar.format models continuations
|
||||
irc.client irc.client.private irc.messages
|
||||
irc.ui.commandparser irc.ui.load vocabs.loader ;
|
||||
irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;
|
||||
|
||||
RENAME: join sequences => sjoin
|
||||
|
||||
|
|
@ -30,6 +30,7 @@ TUPLE: irc-tab < frame chat client window ;
|
|||
foreground associate format ;
|
||||
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
|
||||
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
|
||||
: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;
|
||||
|
||||
: dot-or-parens ( string -- string )
|
||||
[ "." ]
|
||||
|
|
@ -41,14 +42,14 @@ M: ping write-irc
|
|||
drop "* Ping" blue write-color ;
|
||||
|
||||
M: privmsg write-irc
|
||||
"<" blue write-color
|
||||
"<" dark-blue write-color
|
||||
[ irc-message-sender write ] keep
|
||||
"> " blue write-color
|
||||
"> " dark-blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
M: notice write-irc
|
||||
[ type>> blue write-color ] keep
|
||||
": " blue write-color
|
||||
[ type>> dark-blue write-color ] keep
|
||||
": " dark-blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
TUPLE: own-message message nick timestamp ;
|
||||
|
|
@ -57,9 +58,9 @@ TUPLE: own-message message nick timestamp ;
|
|||
now own-message boa ;
|
||||
|
||||
M: own-message write-irc
|
||||
"<" blue write-color
|
||||
"<" dark-blue write-color
|
||||
[ nick>> bold font-style associate format ] keep
|
||||
"> " blue write-color
|
||||
"> " dark-blue write-color
|
||||
message>> write ;
|
||||
|
||||
M: join write-irc
|
||||
|
|
@ -87,26 +88,23 @@ M: kick write-irc
|
|||
" from the channel" dark-red write-color
|
||||
trailing>> dot-or-parens dark-red write-color ;
|
||||
|
||||
: full-mode ( message -- mode )
|
||||
parameters>> rest " " sjoin ;
|
||||
|
||||
M: mode write-irc
|
||||
"* " blue write-color
|
||||
[ irc-message-sender write ] keep
|
||||
" has applied mode " blue write-color
|
||||
[ full-mode write ] keep
|
||||
" to " blue write-color
|
||||
channel>> write ;
|
||||
"* " dark-blue write-color
|
||||
[ name>> write ] keep
|
||||
" has applied mode " dark-blue write-color
|
||||
[ mode>> write ] keep
|
||||
" to " dark-blue write-color
|
||||
parameter>> write ;
|
||||
|
||||
M: nick write-irc
|
||||
"* " blue write-color
|
||||
"* " dark-blue write-color
|
||||
[ irc-message-sender write ] keep
|
||||
" is now known as " blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
M: unhandled write-irc
|
||||
"UNHANDLED: " write
|
||||
line>> blue write-color ;
|
||||
line>> dark-blue write-color ;
|
||||
|
||||
M: irc-end write-irc
|
||||
drop "* You have left IRC" dark-red write-color ;
|
||||
|
|
@ -121,7 +119,10 @@ M: irc-chat-end write-irc
|
|||
drop ;
|
||||
|
||||
M: irc-message write-irc
|
||||
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
|
||||
"UNIMPLEMENTED" write
|
||||
[ class pprint ] keep
|
||||
": " write
|
||||
line>> dark-blue write-color ;
|
||||
|
||||
GENERIC: time-happened ( message -- timestamp )
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
USING: io lint kernel math tools.test ;
|
||||
IN: lint.tests
|
||||
|
||||
! Don't write code like this
|
||||
: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
|
||||
|
||||
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
|
||||
|
||||
: lint2 ( n -- n' ) 1 + ; ! 1+
|
||||
[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
|
||||
|
||||
: lint3 dup -rot ; ! tuck
|
||||
|
||||
[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
|
||||
|
|
@ -0,0 +1,179 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.accessors arrays assocs
|
||||
combinators.short-circuit fry hashtables html.elements io
|
||||
kernel math namespaces prettyprint quotations sequences
|
||||
sequences.deep sets slots.private vectors vocabs words
|
||||
kernel.private ;
|
||||
IN: lint
|
||||
|
||||
SYMBOL: def-hash
|
||||
SYMBOL: def-hash-keys
|
||||
|
||||
: set-hash-vector ( val key hash -- )
|
||||
2dup at -rot [ ?push ] 2dip set-at ;
|
||||
|
||||
: more-defs ( hash -- )
|
||||
{
|
||||
{ -rot [ swap >r swap r> ] }
|
||||
{ -rot [ swap swapd ] }
|
||||
{ rot [ >r swap r> swap ] }
|
||||
{ rot [ swapd swap ] }
|
||||
{ over [ dup swap ] }
|
||||
{ tuck [ dup -rot ] }
|
||||
{ swapd [ >r swap r> ] }
|
||||
{ 2nip [ nip nip ] }
|
||||
{ 2drop [ drop drop ] }
|
||||
{ 3drop [ drop drop drop ] }
|
||||
{ pop* [ pop drop ] }
|
||||
{ when [ [ ] if ] }
|
||||
{ >boolean [ f = not ] }
|
||||
} swap '[ first2 _ set-hash-vector ] each ;
|
||||
|
||||
: accessor-words ( -- seq )
|
||||
{
|
||||
alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
|
||||
alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
|
||||
<displaced-alien> alien-unsigned-cell set-alien-signed-cell
|
||||
set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
|
||||
set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
|
||||
set-alien-unsigned-8 set-alien-signed-8
|
||||
alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
|
||||
set-alien-float alien-float
|
||||
} ;
|
||||
|
||||
: trivial-defs
|
||||
{
|
||||
[ drop ] [ 2array ]
|
||||
[ bitand ]
|
||||
|
||||
[ . ]
|
||||
[ get ]
|
||||
[ t ] [ f ]
|
||||
[ { } ]
|
||||
[ drop f ]
|
||||
[ "cdecl" ]
|
||||
[ first ] [ second ] [ third ] [ fourth ]
|
||||
[ ">" write-html ] [ "/>" write-html ]
|
||||
} ;
|
||||
|
||||
! ! Add definitions
|
||||
H{ } clone def-hash set-global
|
||||
|
||||
all-words [
|
||||
dup def>> dup callable?
|
||||
[ def-hash get-global set-hash-vector ] [ drop ] if
|
||||
] each
|
||||
|
||||
! ! Remove definitions
|
||||
|
||||
! Remove empty word defs
|
||||
def-hash get-global [ drop empty? not ] assoc-filter
|
||||
|
||||
! Remove constants [ 1 ]
|
||||
[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
|
||||
|
||||
! Remove words that are their own definition
|
||||
[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
|
||||
|
||||
! Remove set-alien-cell, etc.
|
||||
[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
|
||||
|
||||
! Remove trivial defs
|
||||
[ drop trivial-defs member? not ] assoc-filter
|
||||
|
||||
! Remove numbers only defs
|
||||
[ drop [ number? ] all? not ] assoc-filter
|
||||
|
||||
! Remove curry only defs
|
||||
[ drop [ \ curry = ] all? not ] assoc-filter
|
||||
|
||||
! Remove tag defs
|
||||
[
|
||||
drop {
|
||||
[ length 3 = ]
|
||||
[ first \ tag = ] [ second number? ] [ third \ eq? = ]
|
||||
} 1&& not
|
||||
] assoc-filter
|
||||
|
||||
[
|
||||
drop {
|
||||
[ [ wrapper? ] deep-contains? ]
|
||||
[ [ hashtable? ] deep-contains? ]
|
||||
} 1|| not
|
||||
] assoc-filter
|
||||
|
||||
! Remove n m shift defs
|
||||
[
|
||||
drop dup length 3 = [
|
||||
[ first2 [ number? ] both? ]
|
||||
[ third \ shift = ] bi and not
|
||||
] [ drop t ] if
|
||||
] assoc-filter
|
||||
|
||||
! Remove [ n slot ]
|
||||
[
|
||||
drop dup length 2 =
|
||||
[ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
|
||||
] assoc-filter
|
||||
|
||||
|
||||
dup more-defs
|
||||
|
||||
[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
|
||||
|
||||
: find-duplicates ( -- seq )
|
||||
def-hash get-global [ nip length 1 > ] assoc-filter ;
|
||||
|
||||
GENERIC: lint ( obj -- seq )
|
||||
|
||||
M: object lint ( obj -- seq ) drop f ;
|
||||
|
||||
: subseq/member? ( subseq/member seq -- ? )
|
||||
{ [ start ] [ member? ] } 2|| ;
|
||||
|
||||
M: callable lint ( quot -- seq )
|
||||
[ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
|
||||
|
||||
M: word lint ( word -- seq )
|
||||
def>> dup callable? [ lint ] [ drop f ] if ;
|
||||
|
||||
: word-path. ( word -- )
|
||||
[ vocabulary>> ] [ unparse ] bi ":" glue print ;
|
||||
|
||||
: 4bl ( -- ) bl bl bl bl ;
|
||||
|
||||
: (lint.) ( pair -- )
|
||||
first2 [ word-path. ] dip [
|
||||
[ 4bl . "-----------------------------------" print ]
|
||||
[ def-hash get-global at [ 4bl word-path. ] each nl ] bi
|
||||
] each nl nl ;
|
||||
|
||||
: lint. ( alist -- ) [ (lint.) ] each ;
|
||||
|
||||
GENERIC: run-lint ( obj -- obj )
|
||||
|
||||
: (trim-self) ( val key -- obj ? )
|
||||
def-hash get-global at*
|
||||
[ dupd remove empty? not ] [ drop f ] if ;
|
||||
|
||||
: trim-self ( seq -- newseq )
|
||||
[ [ (trim-self) ] filter ] assoc-map ;
|
||||
|
||||
: filter-symbols ( alist -- alist )
|
||||
[
|
||||
nip first dup def-hash get-global at
|
||||
[ first ] bi@ literalize = not
|
||||
] assoc-filter ;
|
||||
|
||||
M: sequence run-lint ( seq -- seq )
|
||||
[ dup lint ] { } map>assoc trim-self
|
||||
[ second empty? not ] filter filter-symbols ;
|
||||
|
||||
M: word run-lint ( word -- seq ) 1array run-lint ;
|
||||
|
||||
: lint-all ( -- seq ) all-words run-lint dup lint. ;
|
||||
|
||||
: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
|
||||
|
||||
: lint-word ( word -- seq ) 1array run-lint dup lint. ;
|
||||
|
|
@ -1,8 +1,6 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! Copyright (C) 2008 John Benediktsson, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
USING: help.markup help.syntax math ;
|
||||
IN: math.finance
|
||||
|
||||
HELP: sma
|
||||
|
|
@ -32,3 +30,59 @@ HELP: momentum
|
|||
{ $list "MOM[t] = SEQ[t] - SEQ[t-n]" }
|
||||
} ;
|
||||
|
||||
HELP: biweekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of two week periods in a year." } ;
|
||||
|
||||
HELP: daily-360
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 360-day year." } ;
|
||||
|
||||
HELP: daily-365
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of days in a 365-day year." } ;
|
||||
|
||||
HELP: monthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of months in a year." } ;
|
||||
|
||||
HELP: semimonthly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
|
||||
|
||||
HELP: weekly
|
||||
{ $values
|
||||
{ "x" number }
|
||||
{ "y" number }
|
||||
}
|
||||
{ $description "Divides a number by the number of weeks in a year." } ;
|
||||
|
||||
ARTICLE: "time-period-calculations" "Calculations over periods of time"
|
||||
{ $subsection monthly }
|
||||
{ $subsection semimonthly }
|
||||
{ $subsection biweekly }
|
||||
{ $subsection weekly }
|
||||
{ $subsection daily-360 }
|
||||
{ $subsection daily-365 } ;
|
||||
|
||||
ARTICLE: "math.finance" "Financial math"
|
||||
"The " { $vocab-link "math.finance" } " vocabulary contains financial calculation words." $nl
|
||||
"Calculating payroll over periods of time:"
|
||||
{ $subsection "time-period-calculations" } ;
|
||||
|
||||
ABOUT: "math.finance"
|
||||
|
|
|
|||
|
|
@ -6,3 +6,4 @@ IN: math.finance.tests
|
|||
|
||||
[ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
|
||||
|
||||
[ 4+1/6 ] [ 100 semimonthly ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 John Benediktsson.
|
||||
! Copyright (C) 2008 John Benediktsson, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel grouping sequences shuffle
|
||||
math math.functions math.statistics math.vectors ;
|
||||
|
|
@ -26,3 +26,14 @@ PRIVATE>
|
|||
: momentum ( seq n -- newseq )
|
||||
[ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
|
||||
|
||||
: monthly ( x -- y ) 12 / ; inline
|
||||
|
||||
: semimonthly ( x -- y ) 24 / ; inline
|
||||
|
||||
: biweekly ( x -- y ) 26 / ; inline
|
||||
|
||||
: weekly ( x -- y ) 52 / ; inline
|
||||
|
||||
: daily-360 ( x -- y ) 360 / ; inline
|
||||
|
||||
: daily-365 ( x -- y ) 365 / ; inline
|
||||
|
|
|
|||
|
|
@ -4,15 +4,16 @@ USING: arrays kernel sequences namespaces make math math.ranges
|
|||
math.vectors vectors ;
|
||||
IN: math.numerical-integration
|
||||
|
||||
SYMBOL: num-steps 180 num-steps set-global
|
||||
SYMBOL: num-steps
|
||||
|
||||
180 num-steps set-global
|
||||
|
||||
: setup-simpson-range ( from to -- frange )
|
||||
2dup swap - num-steps get / <range> ;
|
||||
|
||||
: generate-simpson-weights ( seq -- seq )
|
||||
{ 1 4 }
|
||||
swap length 2 / 2 - { 2 4 } <repetition> concat
|
||||
{ 1 } 3append ;
|
||||
length 2 / 2 - { 2 4 } <repetition> concat
|
||||
{ 1 4 } { 1 } surround ;
|
||||
|
||||
: integrate-simpson ( from to f -- x )
|
||||
[ setup-simpson-range dup ] dip
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ SYMBOL: total
|
|||
{ 0 [ [ dup ] ] }
|
||||
{ 1 [ [ over ] ] }
|
||||
{ 2 [ [ pick ] ] }
|
||||
[ 1- picker [ >r ] swap [ r> swap ] 3append ]
|
||||
[ 1- picker [ >r ] [ r> swap ] surround ]
|
||||
} case ;
|
||||
|
||||
: (multi-predicate) ( class picker -- quot )
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue