diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 380c9b2348..c7d87776a1 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -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 ; diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 748f9d124c..433459cb24 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -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? } diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 943ba8c3d5..00d5730745 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -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 diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index e2564b5a28..793c771b64 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -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 diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index ca793de1b7..c0d5bf79a6 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -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 diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b34e5f8232..5619a70740 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 69cd5e5669..3ad716d847 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 41f4bf47a5..6656cd11f7 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -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 ] } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index fe3da93130..9f134c02d7 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 41df6e7ae5..fa6a3c7b21 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -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 diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 8242311287..4d8d935477 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -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 ] "outputs" set-word-prop ] each + +{ (log2) fixnum-log2 bignum-log2 } [ + [ + [ class>> ] [ interval>> interval-log2 ] bi + ] "outputs" set-word-prop +] each + \ string-nth [ 2drop fixnum 0 23 2^ [a,b] ] "outputs" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index aa04b58de7..d95245fe83 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 8e5051e75d..d63a66dbe7 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -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: ( number -- alien ) + M: integer [ f kCFNumberLongLongType ] dip CFNumberCreate ; + M: float [ f kCFNumberDoubleType ] dip CFNumberCreate ; + M: t drop f kCFNumberIntType 1 CFNumberCreate ; + M: f drop f kCFNumberIntType 0 CFNumberCreate ; : ( 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 [ CFBundleLoadExecutable drop @@ -141,8 +162,11 @@ M: f ] ?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 diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 9a5666b5d3..c334297122 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -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? [ diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 836385574d..c609b9e98d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index d22ff4d615..445c7082bc 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 46986dc5e6..c555c4b809 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -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 ; diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 27c00cb3c0..2bea887295 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -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 ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index c477e98aa7..44300a75f9 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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 diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 4e96fb5a4d..32c5ca0075 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -164,7 +164,7 @@ M: sqlite-db ( 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 1, ; diff --git a/basis/editors/editpadlite/authors.txt b/basis/editors/editpadlite/authors.txt new file mode 100644 index 0000000000..aa43d6ea12 --- /dev/null +++ b/basis/editors/editpadlite/authors.txt @@ -0,0 +1,2 @@ +Ryan Murphy +Doug Coleman diff --git a/basis/editors/editpadlite/editpadlite-docs.factor b/basis/editors/editpadlite/editpadlite-docs.factor new file mode 100644 index 0000000000..4f0c8f800d --- /dev/null +++ b/basis/editors/editpadlite/editpadlite-docs.factor @@ -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" diff --git a/basis/editors/editpadlite/editpadlite.factor b/basis/editors/editpadlite/editpadlite.factor new file mode 100644 index 0000000000..c002c2fa75 --- /dev/null +++ b/basis/editors/editpadlite/editpadlite.factor @@ -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 diff --git a/basis/editors/editpadlite/summary.txt b/basis/editors/editpadlite/summary.txt new file mode 100644 index 0000000000..445e15f75d --- /dev/null +++ b/basis/editors/editpadlite/summary.txt @@ -0,0 +1 @@ +EditPadLite editor integration diff --git a/extra/hardware-info/linux/tags.txt b/basis/editors/editpadlite/tags.txt similarity index 100% rename from extra/hardware-info/linux/tags.txt rename to basis/editors/editpadlite/tags.txt diff --git a/basis/editors/editpadpro/editpadpro-docs.factor b/basis/editors/editpadpro/editpadpro-docs.factor index f3484917cb..4f0c8f800d 100644 --- a/basis/editors/editpadpro/editpadpro-docs.factor +++ b/basis/editors/editpadpro/editpadpro-docs.factor @@ -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" \ No newline at end of file +ABOUT: "editors.editpadpro" diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor index 09f59f0916..2a7f92f932 100644 --- a/basis/editors/editpadpro/editpadpro.factor +++ b/basis/editors/editpadpro/editpadpro.factor @@ -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 diff --git a/basis/editors/editplus/editplus.factor b/basis/editors/editplus/editplus.factor index 8af036f290..9fa477f51a 100644 --- a/basis/editors/editplus/editplus.factor +++ b/basis/editors/editplus/editplus.factor @@ -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 -- ) diff --git a/basis/editors/emeditor/emeditor.factor b/basis/editors/emeditor/emeditor.factor index 9aec22eed1..fc3deae670 100644 --- a/basis/editors/emeditor/emeditor.factor +++ b/basis/editors/emeditor/emeditor.factor @@ -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 -- ) diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor index 316bd24cfa..c4b3ad35c1 100755 --- a/basis/editors/etexteditor/etexteditor.factor +++ b/basis/editors/etexteditor/etexteditor.factor @@ -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 -- ) diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor index 8c4e1aaacb..2f733f3c2f 100644 --- a/basis/editors/gvim/windows/windows.factor +++ b/basis/editors/gvim/windows/windows.factor @@ -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* ; diff --git a/basis/editors/notepad2/notepad2.factor b/basis/editors/notepad2/notepad2.factor index 4d333e45dd..e22de4f68d 100644 --- a/basis/editors/notepad2/notepad2.factor +++ b/basis/editors/notepad2/notepad2.factor @@ -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 \ No newline at end of file +[ notepad2 ] edit-hook set-global diff --git a/basis/editors/notepadpp/notepadpp.factor b/basis/editors/notepadpp/notepadpp.factor index 540612aeec..d68008c2ca 100644 --- a/basis/editors/notepadpp/notepadpp.factor +++ b/basis/editors/notepadpp/notepadpp.factor @@ -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 -- ) diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index 10152f53d5..e0b48a3e72 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -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 diff --git a/basis/editors/scite/summary.txt b/basis/editors/scite/summary.txt index 1088ee7f5a..c5f9bb9a09 100644 --- a/basis/editors/scite/summary.txt +++ b/basis/editors/scite/summary.txt @@ -1 +1 @@ -SciTE editor integration +Scintilla text editor (SciTE) integration diff --git a/basis/editors/ted-notepad/ted-notepad.factor b/basis/editors/ted-notepad/ted-notepad.factor index b4135c92a0..994dc60ba3 100644 --- a/basis/editors/ted-notepad/ted-notepad.factor +++ b/basis/editors/ted-notepad/ted-notepad.factor @@ -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 diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor index 6942e24534..cccc94b539 100644 --- a/basis/editors/textedit/textedit.factor +++ b/basis/editors/textedit/textedit.factor @@ -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 - - diff --git a/basis/editors/ultraedit/ultraedit.factor b/basis/editors/ultraedit/ultraedit.factor index 7c9c41df7a..f1929ebf64 100644 --- a/basis/editors/ultraedit/ultraedit.factor +++ b/basis/editors/ultraedit/ultraedit.factor @@ -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 -- ) diff --git a/basis/editors/wordpad/wordpad.factor b/basis/editors/wordpad/wordpad.factor index 3f3dd6cab1..fa0f6852dd 100644 --- a/basis/editors/wordpad/wordpad.factor +++ b/basis/editors/wordpad/wordpad.factor @@ -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 diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index dc3d970fbf..cfcc653776 100644 --- a/basis/grouping/grouping-tests.factor +++ b/basis/grouping/grouping-tests.factor @@ -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 2 over set-length >array diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index fa92f18d34..2149bf7bf6 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -26,7 +26,7 @@ SYMBOL: html #! dynamically creating words. [ elements-vocab create ] 2dip define-declared ; -: ( str -- ) "<" swap ">" 3append ; +: ( str -- ) "<" ">" surround ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned @@ -49,14 +49,14 @@ SYMBOL: html #! word. foo> [ ">" write-html ] (( -- )) html-word ; -: ( str -- ) "" 3append ; +: ( str -- ) "" surround ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. dup '[ _ write-html ] (( -- )) html-word ; -: ( str -- ) "<" swap "/>" 3append ; +: ( str -- ) "<" "/>" surround ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor index 5b128143d9..322358ba14 100644 --- a/basis/io/unix/files/macosx/macosx.factor +++ b/basis/io/unix/files/macosx/macosx.factor @@ -13,7 +13,8 @@ M: macosx file-systems ( -- array ) f 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 ; diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index ba4240de7f..6b687a8afb 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -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" >>events ; + max-events "kevent" >>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" - 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" - 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" - 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 ; - -: ( 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 ; diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index 212b405a54..fd31ca999f 100644 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -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 ) diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index 5a96c7aceb..d8a80340ba 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -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 } "." } ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4182d25524..ed76ccaedd 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -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 diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 1f819d281d..7ee56866ce 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -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 ; diff --git a/basis/nmake/nmake.factor b/basis/nmake/nmake.factor index 80c3ce3411..61a0950ce4 100644 --- a/basis/nmake/nmake.factor +++ b/basis/nmake/nmake.factor @@ -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% ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 7a5b16a3c2..76c3918f63 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -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* ; diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index 8a2a5031fa..fe58e3d07c 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - >r r> with-random ; + [ ] dip with-random ; [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 7f14945633..f689ad0858 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -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 ; diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index dab5414b49..9341f39426 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -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 r> state-parse ; inline + [ ] dip state-parse ; inline diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index e3fd9b9a7c..9cc48972fa 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -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 diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor new file mode 100644 index 0000000000..c495928bf2 --- /dev/null +++ b/basis/tools/deploy/test/8/8.factor @@ -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 diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor new file mode 100644 index 0000000000..3bea1edfc7 --- /dev/null +++ b/basis/tools/deploy/test/8/deploy.factor @@ -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 } +} diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 58c24ef6ca..18baedae0a 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -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 > ] [ 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. diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 4cd5653ab4..e9e8d27870 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -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>> ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index b0d152fc88..6c0eaaa9ac 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -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 diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 127269b325..f023b0959a 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -119,5 +119,5 @@ deploy-gadget "toolbar" f { : deploy-tool ( vocab -- ) vocab-name [ 10 ] - [ "Deploying \"" swap "\"" 3append ] bi + [ "Deploying \"" "\"" surround ] bi open-window ; diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 6401ce201e..0083e49672 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -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 diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 932f72960a..ea1baa6e9c 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -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 = ; diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 157ac013e3..4a998a1ebb 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -12,9 +12,9 @@ M: array resize resize-array ; : >array ( seq -- array ) { } clone-like ; -M: object new-sequence drop f ; +M: object new-sequence drop 0 ; -M: f new-sequence drop dup zero? [ drop f ] [ f ] if ; +M: f new-sequence drop dup zero? [ drop f ] [ 0 ] if ; M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index a0d16084b1..76745cc015 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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? ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index fffb172204..43018f6358 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -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 ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 63043b50b9..66f2da7191 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -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 ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index a52ac65d18..8663f25a70 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -40,7 +40,7 @@ TUPLE: hashtable 0 >>count 0 >>deleted drop ; inline : reset-hash ( n hash -- ) - swap >>array init-hash ; + swap >>array init-hash ; inline : (new-key@) ( key keys i -- keys n empty? ) 3dup swap array-nth dup ((empty)) eq? [ diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index fcb1b65d80..30903e3269 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -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? ; diff --git a/core/math/math.factor b/core/math/math.factor index 5c53d99cff..2434bf8ec6 100644 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -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 diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 427c294759..36559095cb 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 3f3af935b6..4586cfe34e 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 ) [ diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 08831579bb..0b3e0003ac 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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 } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 0d795d453a..dcca525e2b 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 995a8bba4c..8c9eff94f5 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 35aa49d053..187db02c5c 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -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 ; diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index b4cade44db..a6bfef71d0 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -8,7 +8,7 @@ TUPLE: vector { underlying array } { length array-capacity } ; -: ( n -- vector ) f 0 vector boa ; inline +: ( n -- vector ) 0 0 vector boa ; inline : >vector ( seq -- vector ) V{ } clone-like ; diff --git a/core/words/words.factor b/core/words/words.factor index b36f8be677..8c144b03a2 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -239,7 +239,7 @@ ERROR: bad-create name vocab ; dup [ 2nip ] [ drop dup reveal ] if ; : constructor-word ( name vocab -- word ) - [ "<" swap ">" 3append ] dip create ; + [ "<" ">" surround ] dip create ; PREDICATE: parsing-word < word "parsing" word-prop ; diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 6117a0fdea..3cf3f94d73 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -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 diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 838bb08b92..9489798b9b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -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 } [ diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index ac8c3d11d8..5e78d183b0 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -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 diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 25e67d01ce..9d5c65aa94 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -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 ; - - diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index d98e8a9798..b480c18913 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -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 diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index 8fdb807c6a..b2a59a1851 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -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 diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 6e3a605f5c..662881f8cc 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -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 ; diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 976a5ba91f..2f414d2aa5 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -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? diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 61c5da6bca..0e3d48fe5b 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -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] ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 8237e59a1b..75d08b60f8 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -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 ; + + +: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) [ ] dip [ keep and ] curry iterate-directory ; inline -: each-file ( path bfs? quot -- ) +: each-file ( path bfs? quot: ( obj -- ? ) -- ) [ ] dip [ f ] compose iterate-directory drop ; inline -: find-all-files ( path bfs? quot -- paths ) +: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths ) [ ] 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 diff --git a/extra/hardware-info/authors.txt b/extra/io/paths/windows/authors.txt similarity index 100% rename from extra/hardware-info/authors.txt rename to extra/io/paths/windows/authors.txt diff --git a/extra/hardware-info/macosx/tags.txt b/extra/io/paths/windows/tags.txt similarity index 100% rename from extra/hardware-info/macosx/tags.txt rename to extra/io/paths/windows/tags.txt diff --git a/extra/io/paths/windows/windows.factor b/extra/io/paths/windows/windows.factor new file mode 100644 index 0000000000..b4858aaef8 --- /dev/null +++ b/extra/io/paths/windows/windows.factor @@ -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 diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index bea9bf37b1..8054dc8075 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -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> diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index b96d3e1bdc..fd64e9a07e 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -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 ) diff --git a/extra/hardware-info/backend/authors.txt b/extra/lint/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/hardware-info/backend/authors.txt rename to extra/lint/authors.txt diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor new file mode 100644 index 0000000000..e2ca8816d9 --- /dev/null +++ b/extra/lint/lint-tests.factor @@ -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 diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor new file mode 100644 index 0000000000..77b0b11238 --- /dev/null +++ b/extra/lint/lint.factor @@ -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 + 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. ; diff --git a/unmaintained/lint/summary.txt b/extra/lint/summary.txt similarity index 100% rename from unmaintained/lint/summary.txt rename to extra/lint/summary.txt diff --git a/extra/math/finance/finance-docs.factor b/extra/math/finance/finance-docs.factor index 5024e83bff..a1e81bf665 100644 --- a/extra/math/finance/finance-docs.factor +++ b/extra/math/finance/finance-docs.factor @@ -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" diff --git a/extra/math/finance/finance-tests.factor b/extra/math/finance/finance-tests.factor index dce701bb2f..fc4ad0d07e 100644 --- a/extra/math/finance/finance-tests.factor +++ b/extra/math/finance/finance-tests.factor @@ -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 diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index e02f4be624..4823e358b0 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -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 diff --git a/extra/math/numerical-integration/numerical-integration.factor b/extra/math/numerical-integration/numerical-integration.factor index dfaa618b53..6b46ba0243 100644 --- a/extra/math/numerical-integration/numerical-integration.factor +++ b/extra/math/numerical-integration/numerical-integration.factor @@ -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 / ; : generate-simpson-weights ( seq -- seq ) - { 1 4 } - swap length 2 / 2 - { 2 4 } concat - { 1 } 3append ; + length 2 / 2 - { 2 4 } concat + { 1 4 } { 1 } surround ; : integrate-simpson ( from to f -- x ) [ setup-simpson-range dup ] dip diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 682abf3a5d..14062b15db 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -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 ) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index cd781508a7..92778194e3 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -5,7 +5,7 @@ IN: opengl.demo-support : FOV 2.0 sqrt 1+ ; inline : MOUSE-MOTION-SCALE 0.5 ; inline -: KEY-ROTATE-STEP 1.0 ; inline +: KEY-ROTATE-STEP 10.0 ; inline SYMBOL: last-drag-loc diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor index fdf32bddb1..be6c01aab8 100755 --- a/extra/parser-combinators/simple/simple-docs.factor +++ b/extra/parser-combinators/simple/simple-docs.factor @@ -41,7 +41,7 @@ HELP: 'bold' "commonly used in markup languages to indicate bold " "faced text." } { $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } -{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"\" \"\" surround ] <@ parse-1 ." "\"foo\"" } ; HELP: 'italic' { $values @@ -53,7 +53,7 @@ HELP: 'italic' "faced text." } { $examples { $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } -{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"\" \"\" surround ] <@ parse-1 ." "\"foo\"" } } ; HELP: comma-list { $values { "element" "a parser object" } { "parser" "a parser object" } } diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor index 7174066227..b90a98173e 100644 --- a/extra/project-euler/117/117.factor +++ b/extra/project-euler/117/117.factor @@ -27,9 +27,6 @@ IN: project-euler.117 ( -- gadget ) 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; @@ -182,9 +182,11 @@ M: spheres-gadget graft* ( gadget -- ) (make-reflection-texture) >>reflection-texture (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep (make-reflection-framebuffer) >>reflection-framebuffer + t >>initialized? drop ; M: spheres-gadget ungraft* ( gadget -- ) + f >>initialized? dup find-gl-context { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] @@ -238,9 +240,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) ] bi ; : reflection-frustum ( gadget -- -x x -y y near far ) - [ near-plane ] [ far-plane ] bi [ - drop dup [ -+ ] bi@ - ] 2keep ; + [ near-plane ] [ far-plane ] bi + [ drop dup [ -+ ] bi@ ] 2keep ; : (reflection-face) ( gadget face -- ) swap reflection-texture>> >r >r @@ -280,7 +281,7 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) [ dim>> 0 0 rot first2 glViewport ] } cleave ] with-framebuffer ; -M: spheres-gadget draw-gadget* ( gadget -- ) +: (draw-gadget) ( gadget -- ) GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable 0.15 0.15 1.0 1.0 glClearColor { @@ -297,6 +298,9 @@ M: spheres-gadget draw-gadget* ( gadget -- ) ] } cleave ; +M: spheres-gadget draw-gadget* ( gadget -- ) + dup initialized?>> [ (draw-gadget) ] [ drop ] if ; + : spheres-window ( -- ) [ "Spheres" open-window ] with-ui ; diff --git a/extra/hardware-info/linux/authors.txt b/extra/system-info/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/hardware-info/linux/authors.txt rename to extra/system-info/authors.txt diff --git a/extra/hardware-info/macosx/authors.txt b/extra/system-info/backend/authors.txt similarity index 100% rename from extra/hardware-info/macosx/authors.txt rename to extra/system-info/backend/authors.txt diff --git a/extra/hardware-info/backend/backend.factor b/extra/system-info/backend/backend.factor similarity index 75% rename from extra/hardware-info/backend/backend.factor rename to extra/system-info/backend/backend.factor index 283fea6fcc..6e6715f619 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/system-info/backend/backend.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: system ; -IN: hardware-info.backend +IN: system-info.backend HOOK: cpus os ( -- n ) HOOK: cpu-mhz os ( -- n ) diff --git a/extra/hardware-info/windows/authors.txt b/extra/system-info/linux/authors.txt similarity index 100% rename from extra/hardware-info/windows/authors.txt rename to extra/system-info/linux/authors.txt diff --git a/extra/hardware-info/linux/linux.factor b/extra/system-info/linux/linux.factor similarity index 84% rename from extra/hardware-info/linux/linux.factor rename to extra/system-info/linux/linux.factor index ba0cb0c170..d7f53fb9fb 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings io.unix.backend splitting ; -IN: hardware-info.linux +IN: system-info.linux : (uname) ( buf -- int ) "int" f "uname" { "char*" } alien-invoke ; diff --git a/extra/hardware-info/windows/ce/tags.txt b/extra/system-info/linux/tags.txt similarity index 100% rename from extra/hardware-info/windows/ce/tags.txt rename to extra/system-info/linux/tags.txt diff --git a/extra/hardware-info/windows/ce/authors.txt b/extra/system-info/macosx/authors.txt similarity index 100% rename from extra/hardware-info/windows/ce/authors.txt rename to extra/system-info/macosx/authors.txt diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/system-info/macosx/macosx.factor similarity index 90% rename from extra/hardware-info/macosx/macosx.factor rename to extra/system-info/macosx/macosx.factor index e3c604f2fd..a06c01b950 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/system-info/macosx/macosx.factor @@ -1,8 +1,9 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax byte-arrays kernel namespaces sequences unix -hardware-info.backend system io.unix.backend io.encodings.ascii -; -IN: hardware-info.macosx +system-info.backend system io.unix.backend io.encodings.utf8 ; +IN: system-info.macosx ! See /usr/include/sys/sysctl.h for constants @@ -20,7 +21,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) - 4096 sysctl-query ascii malloc-string ; + 4096 sysctl-query utf8 alien>string ; : sysctl-query-uint ( seq -- n ) 4 sysctl-query *uint ; @@ -53,4 +54,3 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; : tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; : mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; - diff --git a/extra/hardware-info/windows/nt/tags.txt b/extra/system-info/macosx/tags.txt similarity index 100% rename from extra/hardware-info/windows/nt/tags.txt rename to extra/system-info/macosx/tags.txt diff --git a/extra/hardware-info/summary.txt b/extra/system-info/summary.txt similarity index 100% rename from extra/hardware-info/summary.txt rename to extra/system-info/summary.txt diff --git a/extra/hardware-info/hardware-info.factor b/extra/system-info/system-info.factor similarity index 60% rename from extra/hardware-info/hardware-info.factor rename to extra/system-info/system-info.factor index cc345c7537..5bf886abd8 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/system-info/system-info.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax kernel math prettyprint io math.parser -combinators vocabs.loader hardware-info.backend system ; -IN: hardware-info +combinators vocabs.loader system-info.backend system ; +IN: system-info : write-unit ( x n str -- ) [ 2^ /f number>string write bl ] [ write ] bi* ; @@ -11,13 +13,13 @@ IN: hardware-info : ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ; << { - { [ os windows? ] [ "hardware-info.windows" ] } - { [ os linux? ] [ "hardware-info.linux" ] } - { [ os macosx? ] [ "hardware-info.macosx" ] } + { [ os windows? ] [ "system-info.windows" ] } + { [ os linux? ] [ "system-info.linux" ] } + { [ os macosx? ] [ "system-info.macosx" ] } [ f ] } cond [ require ] when* >> -: hardware-report. ( -- ) +: system-report. ( -- ) "CPUs: " write cpus number>string write nl "CPU Speed: " write cpu-mhz ghz nl "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/windows/nt/authors.txt b/extra/system-info/windows/authors.txt similarity index 100% rename from extra/hardware-info/windows/nt/authors.txt rename to extra/system-info/windows/authors.txt diff --git a/unmaintained/lint/authors.txt b/extra/system-info/windows/ce/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from unmaintained/lint/authors.txt rename to extra/system-info/windows/ce/authors.txt diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/system-info/windows/ce/ce.factor similarity index 76% rename from extra/hardware-info/windows/ce/ce.factor rename to extra/system-info/windows/ce/ce.factor index 6537661b3e..13c7cb9433 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/system-info/windows/ce/ce.factor @@ -1,6 +1,8 @@ -USING: alien.c-types hardware-info kernel math namespaces -windows windows.kernel32 hardware-info.backend system ; -IN: hardware-info.windows.ce +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types system-info kernel math namespaces +windows windows.kernel32 system-info.backend system ; +IN: system-info.windows.ce : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" diff --git a/extra/hardware-info/windows/tags.txt b/extra/system-info/windows/ce/tags.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/hardware-info/windows/tags.txt rename to extra/system-info/windows/ce/tags.txt diff --git a/extra/system-info/windows/nt/authors.txt b/extra/system-info/windows/nt/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/system-info/windows/nt/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor similarity index 85% rename from extra/hardware-info/windows/nt/nt.factor rename to extra/system-info/windows/nt/nt.factor index 6274e7974c..7f71e08e83 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/system-info/windows/nt/nt.factor @@ -1,8 +1,10 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings -kernel libc math namespaces hardware-info.backend -hardware-info.windows windows windows.advapi32 +kernel libc math namespaces system-info.backend +system-info.windows windows windows.advapi32 windows.kernel32 system byte-arrays ; -IN: hardware-info.windows.nt +IN: system-info.windows.nt M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; diff --git a/extra/system-info/windows/nt/tags.txt b/extra/system-info/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/system-info/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/system-info/windows/tags.txt b/extra/system-info/windows/tags.txt new file mode 100755 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/system-info/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/hardware-info/windows/windows.factor b/extra/system-info/windows/windows.factor similarity index 87% rename from extra/hardware-info/windows/windows.factor rename to extra/system-info/windows/windows.factor index d3ebe87501..66abb59ee9 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -1,8 +1,10 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -words combinators vocabs.loader hardware-info.backend +words combinators vocabs.loader system-info.backend system alien.strings ; -IN: hardware-info.windows +IN: system-info.windows : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; @@ -65,6 +67,6 @@ IN: hardware-info.windows << { - { [ os wince? ] [ "hardware-info.windows.ce" ] } - { [ os winnt? ] [ "hardware-info.windows.nt" ] } + { [ os wince? ] [ "system-info.windows.ce" ] } + { [ os winnt? ] [ "system-info.windows.nt" ] } } cond require >> diff --git a/extra/taxes/usa/usa-tests.factor b/extra/taxes/usa/usa-tests.factor index 002299fef1..6c12a423eb 100644 --- a/extra/taxes/usa/usa-tests.factor +++ b/extra/taxes/usa/usa-tests.factor @@ -1,6 +1,6 @@ USING: kernel money tools.test taxes.usa taxes.usa.federal taxes.usa.mn -calendar taxes.usa.w4 usa-cities ; +calendar taxes.usa.w4 usa-cities math.finance ; IN: taxes.usa.tests [ diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index b78dc25d79..f2c0600ed5 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -230,7 +230,7 @@ M: revision feed-entry-url id>> revision-url ; [ list-revisions ] >>entries ; : rollback-description ( description -- description' ) - [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ; + [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ; : ( -- action ) diff --git a/unmaintained/README.libs.txt b/unmaintained/README.libs.txt deleted file mode 100644 index fb5430ae75..0000000000 --- a/unmaintained/README.libs.txt +++ /dev/null @@ -1,88 +0,0 @@ -This directory contains Factor code that is not part of the core -library, but is useful enough to ship with the Factor distribution. - -Modules can be loaded from the listener: - - "libs/modulename" require - -Available libraries: - -- alarms -- call a quotation at a calendar date (Doug Coleman) -- alien -- Alien utility words (Eduardo Cavazos) -- base64 -- base64 encoding/decoding (Doug Coleman) -- basic-authentication -- basic authentication implementation for HTTP server (Chris Double) -- cairo -- cairo bindings (Sampo Vuori) -- calendar -- timestamp/calendar with timezones (Doug Coleman) -- canvas -- Gadget which renders an OpenGL display list (Slava Pestov) -- cocoa-callbacks -- Allows you to use Factor quotations as actions (Slava Pestov) -- concurrency -- Erlang/Termite-style distibuted concurrency (Chris Double) -- coroutines -- coroutines (Chris Double) -- cryptlib -- cryptlib binding (Elie Chaftari) -- crypto -- Various cryptographic algorithms (Doug Coleman) -- csv -- Comma-separated values parser (Daniel Ehrenberg) -- dlists -- double-linked-lists (Mackenzie Straight) -- editpadpro -- EditPadPro integration for Windows (Ryan Murphy) -- emacs -- emacs integration (Eduardo Cavazos) -- farkup -- Wiki-style markup (Matthew Willis) -- file-appender -- append to existing files (Doug Coleman) -- fjsc -- Factor to Javascript compiler (Chris Double) -- furnace -- Web framework (Slava Pestov) -- gap-buffer -- Efficient text editor buffer (Alex Chapman) -- graphics -- Graphics library in Factor (Doug Coleman) -- hardware-info -- Information about your computer (Doug Coleman) -- handler -- Gesture handler mixin (Eduardo Cavazos) -- heap -- Binary min heap implementation (Ryan Murphy) -- hexdump -- Hexdump routine (Doug Coleman) -- http -- Code shared by HTTP server and client (Slava Pestov) -- http-client -- HTTP client (Slava Pestov) -- id3 -- ID3 parser (Adam Wendt) -- io -- mmap, filesystem utils (Doug Coleman) -- jedit -- jEdit editor integration (Slava Pestov) -- jni -- Java Native Interface Wrapper (Chris Double) -- json -- JSON reader and writer (Chris Double) -- koszul -- Lie algebra cohomology and central representation (Slava Pestov) -- lazy-lists -- Lazy evaluation lists (Chris Double, Matthew Willis) -- locals -- Crappy local variables (Slava Pestov) -- mad -- Wrapper for libmad MP3 decoder (Adam Wendt) -- match -- pattern matching (Chris Double) -- math -- extended math library (Doug Coleman, Slava Pestov) -- matrices -- Matrix math (Slava Pestov) -- memoize -- memoization (caching word results) (Slava Pestov) -- mmap -- memory mapped files (Doug Coleman) -- mysql -- MySQL binding (Berlin Brown) -- null-stream -- Something akin to /dev/null (Slava Pestov) -- odbc -- Wrapper for ODBC library (Chris Double) -- ogg -- Wrapper for libogg library (Chris Double) -- openal -- Wrapper for OpenAL and alut sound libraries (Chris Double) -- oracle -- Oracle binding (Elie Chaftari) -- parser-combinators -- Haskell-style parser combinators (Chris Double) -- porter-stemmer -- Porter stemming algorithm (Slava Pestov) -- postgresql -- PostgreSQL binding (Doug Coleman) -- process -- Run external programs (Slava Pestov, Doug Coleman) -- qualified -- Qualified names for words in other vocabularies (Daniel Ehrenberg) -- rewrite-closures -- Turn quotations into closures (Eduardo Cavazos) -- scite -- SciTE editor integration (Clemens F. Hofreither) -- sequences -- Non-core sequence words (Eduardo Cavazos) -- serialize -- Binary object serialization (Chris Double) -- server -- The with-server combinator formely found in the core (Slava Pestov) -- slate -- Framework for graphical demos (Eduardo Cavazos) -- shuffle -- Shuffle words not in the core library (Chris Double) -- smtp -- SMTP client library (Elie Chaftari) -- splay-trees -- Splay trees (Mackenzie Straight) -- sqlite -- SQLite binding (Chris Double) -- state-machine -- Finite state machine abstraction (Daniel Ehrenberg) -- state-parser -- State-based parsing mechanism (Daniel Ehrenberg) -- textmate -- TextMate integration (Benjamin Pollack) -- theora -- Wrapper for libtheora library (Chris Double) -- trees -- Binary search and AVL (balanced) trees (Alex Chapman) -- usb -- Wrapper for libusb (Chris Double) -- unicode -- Partial Unicode support beyond the core (Daniel Ehrenberg) -- units -- Unit conversion (Doug Coleman) -- vars -- Alternative syntax for variables (Eduardo Cavazos) -- vim -- VIM integration (Alex Chapman) -- visitor -- Double dispatch through the visitor pattern (Daniel Ehrenberg) -- vorbis -- Wrapper for Ogg Vorbis library (Chris Double) -- x11 -- X Window System client library (Eduardo Cavazos) -- xml -- XML parser (Daniel Ehrenberg) -- xml-rpc -- XML-RPC client and server (Daniel Ehrenberg) -- yahoo -- Yahoo! automated search (Daniel Ehrenberg) diff --git a/unmaintained/README.txt b/unmaintained/README.txt deleted file mode 100644 index 91b1c5fe88..0000000000 --- a/unmaintained/README.txt +++ /dev/null @@ -1,30 +0,0 @@ -This directory contains Factor code that is not part of the core -library, but is useful enough to ship with the Factor distribution. - -Modules can be loaded from the listener: - - "apps/modulename" require - -Available applications: - -- article-manager -- Web-based content management system (Chris Double) -- automata -- Graphics demo for the UI (Eduardo Cavazos) -- benchmarks -- Various performance benchmarks (Slava Pestov) -- boids -- Graphics demo for the UI (Eduardo Cavazos) -- factory -- X11 window manager (Eduardo Cavazos) -- furnace-fjsc -- Web frontend for libs/fjsc (Chris Double) -- furnace-onigiri -- Weblog engine (Matthew Willis) -- furnace-pastebin -- demo app for Furnace (Slava Pestov) -- help-lint -- online documentation typo checker (Slava Pestov) -- icfp-2006 -- implements the icfp 2006 vm, boundvariable.org (Gavin Harrison) -- http-server -- HTTP server (Slava Pestov, Chris Double) -- lindenmayer -- L-systems tool (Eduardo Cavazos) -- lisppaste -- Lisppaste XML-RPC demo (Slava Pestov) -- ogg-player -- Ogg Vorbis (audio) and Theora (video) player (Chris Double) -- print-dataflow -- Code to print compiler dataflow IR to the console, or show it in the UI (Slava Pestov) -- random-tester -- Random compiler tester (Doug Coleman) -- rss -- An RSS1, RSS2 and Atom parser and aggregator (Chris Double, Daniel Ehrenberg) -- space-invaders -- Intel 8080-based Space Invaders arcade machine emulator (Chris Double) -- tetris -- Tetris game (Alex Chapman) -- turing -- Turing machine demo (Slava Pestov) -- wee-url -- Web app to make short URLs from long ones (Doug Coleman) diff --git a/unmaintained/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor deleted file mode 100644 index 9a39980c9f..0000000000 --- a/unmaintained/lint/lint-tests.factor +++ /dev/null @@ -1,18 +0,0 @@ -USING: io lint kernel math tools.test ; -IN: lint.tests - -! Don't write code like this -: lint1 - [ "hi" print ] [ ] if ; ! when - -[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test - -: lint2 - 1 + ; ! 1+ -[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test - -: lint3 - dup -rot ; ! tuck - -[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test - diff --git a/unmaintained/lint/lint.factor b/unmaintained/lint/lint.factor deleted file mode 100644 index ab1a67a83e..0000000000 --- a/unmaintained/lint/lint.factor +++ /dev/null @@ -1,182 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.accessors arrays assocs -combinators.lib io kernel macros math namespaces prettyprint -quotations sequences vectors vocabs words html.elements sets -slots.private combinators.short-circuit math.order hashtables -sequences.deep ; -IN: lint - -SYMBOL: def-hash -SYMBOL: def-hash-keys - -: set-hash-vector ( val key hash -- ) - 2dup at -rot [ ?push ] 2dip set-at ; - -: add-word-def ( word quot -- ) - dup callable? [ - def-hash get-global set-hash-vector - ] [ - 2drop - ] if ; - -: more-defs ( -- ) - { - { [ swap >r swap r> ] -rot } - { [ swap swapd ] -rot } - { [ >r swap r> swap ] rot } - { [ swapd swap ] rot } - { [ dup swap ] over } - { [ dup -rot ] tuck } - { [ >r swap r> ] swapd } - { [ nip nip ] 2nip } - { [ drop drop ] 2drop } - { [ drop drop drop ] 3drop } - { [ 0 = ] zero? } - { [ pop drop ] pop* } - { [ [ ] if ] when } - { [ f = not ] >boolean } - } [ first2 swap add-word-def ] 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 - 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 - { - [ get ] [ t ] [ { } ] [ . ] [ drop f ] - [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ] - [ ">" write-html ] [ "/>" write-html ] - } ; - -H{ } clone def-hash set-global -all-words [ dup def>> add-word-def ] each -more-defs - -! 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 set-alien-cell, etc. -[ - drop [ accessor-words diff ] keep [ length ] bi@ = -] assoc-filter - -! Remove trivial defs -[ - drop trivial-defs member? not -] assoc-filter - -[ - drop { - [ [ wrapper? ] deep-contains? ] - [ [ hashtable? ] deep-contains? ] - } 1|| not -] assoc-filter - -! Remove n m shift defs -[ - drop dup length 3 = [ - dup first2 [ number? ] both? - swap third \ shift = and not - ] [ drop t ] if -] assoc-filter - -! Remove [ n slot ] -[ - drop dup length 2 = [ - first2 \ slot = swap number? and not - ] [ drop t ] if -] assoc-filter def-hash set-global - -: find-duplicates ( -- seq ) - def-hash get-global [ - nip length 1 > - ] assoc-filter ; - -def-hash get-global keys def-hash-keys set-global - -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 [ - swap subseq/member? - ] with filter ; - -M: word lint ( word -- seq ) - def>> dup callable? [ lint ] [ drop f ] if ; - -: word-path. ( word -- ) - [ vocabulary>> ":" ] keep unparse 3append write nl ; - -: (lint.) ( pair -- ) - first2 >r word-path. r> [ - bl bl bl bl - dup . - "-----------------------------------" print - def-hash get at [ bl bl bl bl word-path. ] each - nl - ] 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 at - [ first ] bi@ literalize = not - ] assoc-filter ; - -M: sequence run-lint ( seq -- seq ) - [ - global [ dup . flush ] bind - 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. ; diff --git a/vm/bignum.c b/vm/bignum.c index 72616afbc5..1f4bc3ce76 100644 --- a/vm/bignum.c +++ b/vm/bignum.c @@ -1396,7 +1396,7 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p) } #define BIGNUM_REDUCE_LENGTH(source, length) \ - source = reallot_array(source,length + 1,0) + source = reallot_array(source,length + 1) /* allocates memory */ bignum_type diff --git a/vm/math.c b/vm/math.c index dd01e852ad..f0aa874886 100644 --- a/vm/math.c +++ b/vm/math.c @@ -197,7 +197,7 @@ void primitive_bignum_xor(void) void primitive_bignum_shift(void) { - F_FIXNUM y = to_fixnum(dpop()); + F_FIXNUM y = untag_fixnum_fast(dpop()); F_ARRAY* x = untag_object(dpop()); dpush(tag_bignum(bignum_arithmetic_shift(x,y))); } diff --git a/vm/types.c b/vm/types.c index a614011e7e..1afbcd3a40 100755 --- a/vm/types.c +++ b/vm/types.c @@ -157,27 +157,18 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) return tag_object(a); } -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill) +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) { - int i; - F_ARRAY* new_array; - CELL to_copy = array_capacity(array); if(capacity < to_copy) to_copy = capacity; REGISTER_UNTAGGED(array); - REGISTER_ROOT(fill); - - new_array = allot_array_internal(untag_header(array->header),capacity); - - UNREGISTER_ROOT(fill); + F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); UNREGISTER_UNTAGGED(array); memcpy(new_array + 1,array + 1,to_copy * CELLS); - - for(i = to_copy; i < capacity; i++) - put(AREF(new_array,i),fill); + memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); return new_array; } @@ -186,7 +177,7 @@ void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity,F))); + dpush(tag_object(reallot_array(array,capacity))); } F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count) @@ -195,8 +186,7 @@ F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count) if(*result_count == array_capacity(result)) { - result = reallot_array(result, - *result_count * 2,F); + result = reallot_array(result,*result_count * 2); } UNREGISTER_ROOT(elt); @@ -214,7 +204,7 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun CELL new_size = *result_count + elts_size; if(new_size >= array_capacity(result)) - result = reallot_array(result,new_size * 2,F); + result = reallot_array(result,new_size * 2); UNREGISTER_UNTAGGED(elts); @@ -433,7 +423,7 @@ void primitive_string(void) dpush(tag_object(allot_string(length,initial))); } -F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) +F_STRING* reallot_string(F_STRING* string, CELL capacity) { CELL to_copy = string_capacity(string); if(capacity < to_copy) @@ -462,7 +452,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) REGISTER_UNTAGGED(string); REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,fill); + fill_string(new_string,to_copy,capacity,'\0'); UNREGISTER_UNTAGGED(new_string); UNREGISTER_UNTAGGED(string); @@ -473,7 +463,7 @@ void primitive_resize_string(void) { F_STRING* string = untag_string(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_string(string,capacity,0))); + dpush(tag_object(reallot_string(string,capacity))); } /* Some ugly macros to prevent a 2x code duplication */ diff --git a/vm/types.h b/vm/types.h index 242939c502..ba8d9689fe 100755 --- a/vm/types.h +++ b/vm/types.h @@ -118,7 +118,7 @@ void primitive_tuple_layout(void); void primitive_byte_array(void); void primitive_clone(void); -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); +F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); void primitive_resize_array(void); void primitive_resize_byte_array(void); @@ -126,7 +126,7 @@ void primitive_resize_byte_array(void); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); void primitive_string(void); -F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); +F_STRING *reallot_string(F_STRING *string, CELL capacity); void primitive_resize_string(void); F_STRING *memory_to_char_string(const char *string, CELL length); @@ -177,7 +177,7 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun result = tag_object(growable_array_append(untag_object(result),elts,&result##_count)) #define GROWABLE_ARRAY_TRIM(result) \ - result = tag_object(reallot_array(untag_object(result),result##_count,F)) + result = tag_object(reallot_array(untag_object(result),result##_count)) /* Macros to simulate a byte vector in C */ #define GROWABLE_BYTE_ARRAY(result) \