diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index dabdeea741..9968af4330 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -60,7 +60,7 @@ nl "." write flush { - new-sequence nth push pop peek + new-sequence nth push pop peek flip } compile-uncompiled "." write flush diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index f352a4a254..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 ; @@ -351,7 +351,12 @@ M: wrapper ' : pad-bytes ( seq -- newseq ) dup length bootstrap-cell align 0 pad-right ; +: check-string ( string -- ) + [ 127 > ] contains? + [ "Bootstrap cannot emit non-ASCII strings" throw ] when ; + : emit-string ( string -- ptr ) + dup check-string string type-number object tag-number [ dup length emit-fixnum f ' emit 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/cocoa/application/application.factor b/basis/cocoa/application/application.factor index c62fab0f15..ab12a93a31 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -27,17 +27,19 @@ IN: cocoa.application : NSApp ( -- app ) NSApplication -> sharedApplication ; +: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline + FUNCTION: void NSBeep ( ) ; : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; inline : next-event ( app -- event ) - 0 f CFRunLoopDefaultMode 1 + NSAnyEventMask f CFRunLoopDefaultMode 1 -> nextEventMatchingMask:untilDate:inMode:dequeue: ; : do-event ( app -- ? ) - dup next-event [ -> sendEvent: t ] [ drop f ] if* ; + dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ; : add-observer ( observer selector name object -- ) [ @@ -49,14 +51,7 @@ FUNCTION: void NSBeep ( ) ; [ NSNotificationCenter -> defaultCenter ] dip -> removeObserver: ; -: finish-launching ( -- ) NSApp -> finishLaunching ; - -: cocoa-app ( quot -- ) - [ - call - finish-launching - NSApp -> run - ] with-cocoa ; inline +: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline : install-delegate ( receiver delegate -- ) -> alloc -> init -> setDelegate: ; @@ -81,6 +76,6 @@ M: objc-error summary ( error -- ) running.app? [ drop ] [ - "The " swap " requires you to run Factor from an application bundle." - 3append throw + "The " " requires you to run Factor from an application bundle." + surround throw ] if ; diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index e1d6672872..59ea91c3cf 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,7 +1,7 @@ IN: cocoa.tests USING: cocoa cocoa.messages cocoa.subclassing cocoa.types compiler kernel namespaces cocoa.classes tools.test memory -compiler.units ; +compiler.units math ; CLASS: { { +superclass+ "NSObject" } @@ -45,3 +45,27 @@ Bar [ [ 2.0 ] [ "x" get NSRect-y ] unit-test [ 101.0 ] [ "x" get NSRect-w ] unit-test [ 102.0 ] [ "x" get NSRect-h ] unit-test + +! Make sure that we can add methods +CLASS: { + { +superclass+ "NSObject" } + { +name+ "Bar" } +} { + "bar" + "NSRect" + { "id" "SEL" } + [ 2drop test-foo "x" get ] +} { + "babb" + "int" + { "id" "SEL" "int" } + [ 2nip sq ] +} ; + +[ 144 ] [ + Bar [ + -> alloc -> init + dup 12 -> babb + swap -> release + ] compile-call +] unit-test diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 791674428b..e33217a691 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -combinators compiler compiler.alien kernel math namespaces make -parser prettyprint prettyprint.sections quotations sequences -strings words cocoa.runtime io macros memoize debugger -io.encodings.ascii effects libc libc.private parser lexer init -core-foundation fry generalizations +continuations combinators compiler compiler.alien kernel math +namespaces make parser prettyprint prettyprint.sections +quotations sequences strings words cocoa.runtime io macros +memoize debugger io.encodings.ascii effects libc libc.private +parser lexer init core-foundation fry generalizations specialized-arrays.direct.alien ; IN: cocoa.messages @@ -85,9 +85,17 @@ MACRO: (send) ( selector super? -- quot ) \ super-send soft "break-after" set-word-prop ! Runtime introspection -: (objc-class) ( string word -- class ) - dupd execute - [ ] [ "No such class: " prepend throw ] ?if ; inline +SYMBOL: class-init-hooks + +class-init-hooks global [ H{ } clone or ] change-at + +: (objc-class) ( name word -- class ) + 2dup execute dup [ 2nip ] [ + drop over class-init-hooks get at [ assert-depth ] when* + 2dup execute dup [ 2nip ] [ + 2drop "No such class: " prepend throw + ] if + ] if ; inline : objc-class ( string -- class ) \ objc_getClass (objc-class) ; @@ -221,23 +229,19 @@ assoc-union alien>objc-types set-global : class-exists? ( string -- class ) objc_getClass >boolean ; -: unless-defined ( class quot -- ) - [ class-exists? ] dip unless ; inline - -: define-objc-class-word ( name quot -- ) +: define-objc-class-word ( quot name -- ) + [ class-init-hooks get set-at ] [ - over , , \ unless-defined , dup , \ objc-class , - ] [ ] make [ "cocoa.classes" create ] dip - (( -- class )) define-declared ; + [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi + (( -- class )) define-declared + ] bi ; : import-objc-class ( name quot -- ) - 2dup unless-defined - dupd define-objc-class-word + over define-objc-class-word '[ _ - dup - objc-class register-objc-methods - objc-meta-class register-objc-methods + [ objc-class register-objc-methods ] + [ objc-meta-class register-objc-methods ] bi ] try ; : root-class ( class -- root ) diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 40f21d25b8..b49d55a30b 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2006, 2008 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays assocs combinators compiler hashtables kernel libc math namespaces -parser sequences words cocoa.messages cocoa.runtime -compiler.units io.encodings.ascii generalizations -continuations make ; +parser sequences words cocoa.messages cocoa.runtime locals +compiler.units io.encodings.ascii continuations make fry ; IN: cocoa.subclassing : init-method ( method -- sel imp types ) @@ -12,22 +11,25 @@ IN: cocoa.subclassing [ sel_registerName ] [ execute ] [ ascii string>alien ] tri* ; -: throw-if-false ( YES/NO -- ) - zero? [ "Failed to add method or protocol to class" throw ] - when ; +: throw-if-false ( obj what -- ) + swap { f 0 } member? + [ "Failed to " prepend throw ] [ drop ] if ; + +: add-method ( class sel imp types -- ) + class_addMethod "add method to class" throw-if-false ; : add-methods ( methods class -- ) - swap - [ init-method class_addMethod throw-if-false ] with each ; + '[ [ _ ] dip init-method add-method ] each ; + +: add-protocol ( class protocol -- ) + class_addProtocol "add protocol to class" throw-if-false ; : add-protocols ( protocols class -- ) - swap [ objc-protocol class_addProtocol throw-if-false ] - with each ; + '[ [ _ ] dip objc-protocol add-protocol ] each ; -: (define-objc-class) ( protocols superclass name imeth -- ) - -rot +: (define-objc-class) ( imeth protocols superclass name -- ) [ objc-class ] dip 0 objc_allocateClassPair - [ add-methods ] [ add-protocols ] [ objc_registerClassPair ] + [ add-protocols ] [ add-methods ] [ objc_registerClassPair ] tri ; : encode-types ( return types -- encoding ) @@ -45,28 +47,19 @@ IN: cocoa.subclassing [ first4 prepare-method 3array ] map ] with-compilation-unit ; -: types= ( a b -- ? ) - [ ascii alien>string ] bi@ = ; - -: (verify-method-type) ( class sel types -- ) - [ class_getInstanceMethod method_getTypeEncoding ] - dip types= - [ "Objective-C method types cannot be changed once defined" throw ] - unless ; -: verify-method-type ( class sel imp types -- class sel imp types ) - 4 ndup nip (verify-method-type) ; - -: (redefine-objc-method) ( class method -- ) - init-method ! verify-method-type - drop - [ class_getInstanceMethod ] dip method_setImplementation drop ; +:: (redefine-objc-method) ( class method -- ) + method init-method [| sel imp types | + class sel class_getInstanceMethod [ + imp method_setImplementation drop + ] [ + class sel imp types add-method + ] if* + ] call ; : redefine-objc-methods ( imeth name -- ) dup class-exists? [ - objc_getClass swap [ (redefine-objc-method) ] with each - ] [ - 2drop - ] if ; + objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each + ] [ 2drop ] if ; SYMBOL: +name+ SYMBOL: +protocols+ @@ -76,10 +69,10 @@ SYMBOL: +superclass+ clone [ prepare-methods +name+ get "cocoa.classes" create drop - +name+ get 2dup redefine-objc-methods swap [ - +protocols+ get , +superclass+ get , +name+ get , , - \ (define-objc-class) , - ] [ ] make import-objc-class + +name+ get 2dup redefine-objc-methods swap + +protocols+ get +superclass+ get +name+ get + '[ _ _ _ _ (define-objc-class) ] + import-objc-class ] bind ; : CLASS: diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 98569d868c..90227bb5da 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces assocs hashtables sequences +USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.copy-prop ; @@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ; M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; +M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; M: ##peek insn-object loc>> class ; M: ##replace insn-object loc>> class ; @@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; +M: ##alien-global insn-object drop \ ##alien-global ; : init-alias-analysis ( -- ) H{ } clone histories set @@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases* M: ##load-indirect analyze-aliases* dup dst>> set-heap-ac ; +M: ##alien-global analyze-aliases* + dup dst>> set-heap-ac ; + M: ##allot analyze-aliases* #! A freshly allocated object is distinct from any other #! object. diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 3825ae480e..068a6a6377 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -15,6 +15,7 @@ M: ##dispatch defs-vregs temp>> 1array ; M: ##slot defs-vregs dst/tmp-vregs ; M: ##set-slot defs-vregs temp>> 1array ; M: ##string-nth defs-vregs dst/tmp-vregs ; +M: ##set-string-nth-fast defs-vregs temp>> 1array ; M: ##compare defs-vregs dst/tmp-vregs ; M: ##compare-imm defs-vregs dst/tmp-vregs ; M: ##compare-float defs-vregs dst/tmp-vregs ; @@ -31,6 +32,7 @@ M: ##slot-imm uses-vregs obj>> 1array ; M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ; M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ; M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ; +M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ; M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##compare-imm-branch uses-vregs src1>> 1array ; M: ##dispatch uses-vregs src>> 1array ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 4b98ccb0ae..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 @@ -65,6 +66,7 @@ IN: compiler.cfg.hats : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline +: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 62d4990c92..5619a70740 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ; ! String element access INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ; +INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ; ! Integer arithmetic INSN: ##add < ##commutative ; @@ -91,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 ; @@ -160,6 +162,8 @@ INSN: ##set-alien-double < ##alien-setter ; INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##write-barrier < ##effect card# table ; +INSN: ##alien-global < ##read symbol library ; + ! FFI INSN: ##alien-invoke params ; INSN: ##alien-indirect params ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 68ee7489f8..3ad716d847 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -12,8 +12,7 @@ compiler.cfg.registers ; IN: compiler.cfg.intrinsics.fixnum : emit-both-fixnums? ( -- ) - D 0 ^^peek - D 1 ^^peek + 2inputs ^^or tag-mask get ^^and-imm 0 cc= ^^compare-imm @@ -54,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 aaa45c3937..6656cd11f7 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float compiler.cfg.intrinsics.slots +compiler.cfg.intrinsics.misc compiler.cfg.iterator ; QUALIFIED: kernel QUALIFIED: arrays @@ -18,11 +19,13 @@ QUALIFIED: slots.private QUALIFIED: strings.private QUALIFIED: classes.tuple.private QUALIFIED: math.private +QUALIFIED: math.integers.private QUALIFIED: alien.accessors IN: compiler.cfg.intrinsics { kernel.private:tag + kernel.private:getenv math.private:both-fixnums? math.private:fixnum+ math.private:fixnum- @@ -45,6 +48,7 @@ IN: compiler.cfg.intrinsics slots.private:slot slots.private:set-slot strings.private:string-nth + strings.private:set-string-nth-fast classes.tuple.private: arrays: byte-arrays: @@ -90,9 +94,13 @@ 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 ] } + { \ kernel.private:getenv [ emit-getenv iterate-next ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] } { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } @@ -104,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 ] } @@ -126,6 +135,7 @@ IN: compiler.cfg.intrinsics { \ slots.private:slot [ emit-slot iterate-next ] } { \ slots.private:set-slot [ emit-set-slot iterate-next ] } { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] } + { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] } { \ classes.tuple.private: [ emit- iterate-next ] } { \ arrays: [ emit- iterate-next ] } { \ byte-arrays: [ emit- iterate-next ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor new file mode 100644 index 0000000000..f9f2182a4e --- /dev/null +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces layouts sequences kernel +accessors compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.misc + +: emit-tag ( -- ) + ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; + +: emit-getenv ( node -- ) + "userenv" f ^^alien-global + swap node-input-infos first literal>> + [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if* + ds-push ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index fec234a576..bc46e6149c 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.intrinsics.slots -: emit-tag ( -- ) - ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; - : value-tag ( info -- n ) class>> class-tag ; inline : (emit-slot) ( infos -- dst ) @@ -54,3 +51,7 @@ IN: compiler.cfg.intrinsics.slots : emit-string-nth ( -- ) 2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ; + +: emit-set-string-nth-fast ( -- ) + 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri* + swap i ##set-string-nth-fast ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index e943fb4828..dabecaeec4 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel sequences sequences.deep +USING: accessors arrays kernel sequences compiler.utilities compiler.cfg.instructions cpu.architecture ; IN: compiler.cfg.two-operand @@ -55,6 +55,6 @@ M: insn convert-two-operand* ; : convert-two-operand ( mr -- mr' ) [ two-operand? [ - [ convert-two-operand* ] map flatten + [ convert-two-operand* ] map-flat ] when ] change-instructions ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 2161c8b091..9f134c02d7 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -131,6 +131,14 @@ M: ##string-nth generate-insn [ temp>> register ] } cleave %string-nth ; +M: ##set-string-nth-fast generate-insn + { + [ src>> register ] + [ obj>> register ] + [ index>> register ] + [ temp>> register ] + } cleave %set-string-nth-fast ; + : dst/src ( insn -- dst src ) [ dst>> register ] [ src>> register ] bi ; inline @@ -155,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 @@ -228,6 +237,10 @@ M: _gc generate-insn drop %gc ; M: ##loop-entry generate-insn drop %loop-entry ; +M: ##alien-global generate-insn + [ dst>> register ] [ symbol>> ] [ library>> ] tri + %alien-global ; + ! ##alien-invoke GENERIC: reg-size ( register-class -- n ) @@ -443,7 +456,7 @@ M: ##alien-indirect generate-insn TUPLE: callback-context ; -: current-callback 2 getenv ; +: current-callback ( -- id ) 2 getenv ; : wait-to-return ( token -- ) dup current-callback eq? [ diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 0302218652..a56ae04a7b 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -9,7 +9,7 @@ IN: compiler.codegen.fixup GENERIC: fixup* ( obj -- ) -: code-format 22 getenv ; +: code-format ( -- n ) 22 getenv ; : compiled-offset ( -- n ) building get length code-format * ; 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/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index becac01cd5..1b0343faa9 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences sequences.deep combinators fry +USING: kernel accessors sequences combinators fry classes.algebra namespaces assocs words math math.private math.partial-dispatch math.intervals classes classes.tuple classes.tuple.private layouts definitions stack-checker.state stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup ( nodes -- nodes' ) #! We don't recurse into children here, instead the methods #! do it since the logic is a bit more involved - [ cleanup* ] map flatten ; + [ cleanup* ] map-flat ; : cleanup-folding? ( #call -- ? ) node-output-infos diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 40bbf81a03..030df8484f 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs fry kernel accessors sequences sequences.deep arrays -stack-checker.inlining namespaces compiler.tree ; +USING: assocs fry kernel accessors sequences compiler.utilities +arrays stack-checker.inlining namespaces compiler.tree +math.order ; IN: compiler.tree.combinators : each-node ( nodes quot: ( node -- ) -- ) @@ -27,7 +28,7 @@ IN: compiler.tree.combinators [ _ map-nodes ] change-child ] when ] if - ] map flatten ; inline recursive + ] map-flat ; inline recursive : contains-node? ( nodes quot: ( node -- ? ) -- ? ) dup dup '[ @@ -48,12 +49,6 @@ IN: compiler.tree.combinators : sift-children ( seq flags -- seq' ) zip [ nip ] assoc-filter keys ; -: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline - -: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline - -: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline - : until-fixed-point ( #recursive quot: ( node -- ) -- ) over label>> t >>fixed-point drop [ with-scope ] 2keep diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor index 44b71935c8..9ece5d340b 100644 --- a/basis/compiler/tree/dead-code/liveness/liveness.factor +++ b/basis/compiler/tree/dead-code/liveness/liveness.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs deques search-deques -dlists kernel sequences sequences.deep words sets +dlists kernel sequences compiler.utilities words sets stack-checker.branches compiler.tree compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.dead-code.liveness @@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' ) M: node remove-dead-code* ; : (remove-dead-code) ( nodes -- nodes' ) - [ remove-dead-code* ] map flatten ; + [ remove-dead-code* ] map-flat ; diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor index edfe633057..9b2a2038da 100644 --- a/basis/compiler/tree/def-use/simplified/simplified.factor +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences sequences.deep kernel +USING: sequences kernel fry vectors compiler.tree compiler.tree.def-use ; IN: compiler.tree.def-use.simplified @@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified ! A 'real' usage is a usage of a value that is not a #renaming. TUPLE: real-usage value node ; -GENERIC: actually-used-by* ( value node -- real-usages ) - ! Def GENERIC: actually-defined-by* ( value node -- real-usage ) @@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ; M: node actually-defined-by* real-usage boa ; ! Use -: (actually-used-by) ( value -- real-usages ) - dup used-by [ actually-used-by* ] with map ; +GENERIC# actually-used-by* 1 ( value node accum -- ) + +: (actually-used-by) ( value accum -- ) + [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ; M: #renaming actually-used-by* - inputs/outputs [ indices ] dip nths - [ (actually-used-by) ] map ; + [ inputs/outputs [ indices ] dip nths ] dip + '[ _ (actually-used-by) ] each ; -M: #return-recursive actually-used-by* real-usage boa ; +M: #return-recursive actually-used-by* [ real-usage boa ] dip push ; -M: node actually-used-by* real-usage boa ; +M: node actually-used-by* [ real-usage boa ] dip push ; : actually-used-by ( value -- real-usages ) - (actually-used-by) flatten ; + 10 [ (actually-used-by) ] keep ; diff --git a/basis/compiler/tree/escape-analysis/branches/branches.factor b/basis/compiler/tree/escape-analysis/branches/branches.factor index b728e9a1ba..2eee3e698b 100644 --- a/basis/compiler/tree/escape-analysis/branches/branches.factor +++ b/basis/compiler/tree/escape-analysis/branches/branches.factor @@ -33,4 +33,4 @@ M: #branch escape-analysis* 2bi ; M: #phi escape-analysis* - [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ; + [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ; diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor new file mode 100644 index 0000000000..333b3fa636 --- /dev/null +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes classes.tuple math math.private accessors +combinators kernel compiler.tree compiler.tree.combinators +compiler.tree.propagation.info ; +IN: compiler.tree.escape-analysis.check + +GENERIC: run-escape-analysis* ( node -- ? ) + +M: #push run-escape-analysis* + literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ; + +M: #call run-escape-analysis* + { + { [ dup word>> \ eq? ] [ t ] } + { [ dup immutable-tuple-boa? ] [ t ] } + [ f ] + } cond nip ; + +M: node run-escape-analysis* drop f ; + +: run-escape-analysis? ( nodes -- ? ) + [ run-escape-analysis* ] contains-node? ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 16a27e020a..ecd5429baf 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences words memoize classes.builtin +USING: kernel accessors sequences words memoize combinators +classes classes.builtin classes.tuple math.partial-dispatch fry assocs compiler.tree compiler.tree.combinators @@ -12,7 +13,7 @@ IN: compiler.tree.finalization ! See the comment in compiler.tree.late-optimizations. ! This pass runs after propagation, so that it can expand -! built-in type predicates; these cannot be expanded before +! type predicates; these cannot be expanded before ! propagation since we need to see 'fixnum?' instead of ! 'tag 0 eq?' and so on, for semantic reasoning. @@ -33,16 +34,24 @@ M: #shuffle finalize* [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] bi and [ drop f ] when ; -: builtin-predicate? ( #call -- ? ) - word>> "predicating" word-prop builtin-class? ; - -MEMO: builtin-predicate-expansion ( word -- nodes ) +MEMO: cached-expansion ( word -- nodes ) def>> splice-final ; -: expand-builtin-predicate ( #call -- nodes ) - word>> builtin-predicate-expansion ; +GENERIC: finalize-word ( #call word -- nodes ) + +M: predicate finalize-word + "predicating" word-prop { + { [ dup builtin-class? ] [ drop word>> cached-expansion ] } + { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + [ drop ] + } cond ; + +! M: math-partial finalize-word +! dup primitive? [ drop ] [ nip cached-expansion ] if ; + +M: word finalize-word drop ; M: #call finalize* - dup builtin-predicate? [ expand-builtin-predicate ] when ; + dup word>> finalize-word ; M: node finalize* ; diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index bebe2e91b6..8c13de296a 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math accessors kernel arrays -combinators sequences.deep assocs +combinators compiler.utilities assocs stack-checker.backend stack-checker.branches stack-checker.inlining +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.normalization.introductions @@ -46,7 +47,7 @@ M: #branch normalize* [ [ [ - [ normalize* ] map flatten + [ normalize* ] map-flat introduction-stack get 2array ] with-scope @@ -70,7 +71,7 @@ M: #phi normalize* : (normalize) ( nodes introductions -- nodes ) introduction-stack [ - [ normalize* ] map flatten + [ normalize* ] map-flat ] with-variable ; M: #recursive normalize* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index e37323a2ec..54c6c2c117 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -6,6 +6,7 @@ compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis +compiler.tree.escape-analysis.check compiler.tree.tuple-unboxing compiler.tree.identities compiler.tree.def-use @@ -22,8 +23,10 @@ SYMBOL: check-optimizer? normalize propagate cleanup - escape-analysis - unbox-tuples + dup run-escape-analysis? [ + escape-analysis + unbox-tuples + ] when apply-identities compute-def-use remove-dead-code diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 424cd8a01c..f2613022fc 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -3,6 +3,7 @@ USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -78,7 +79,7 @@ SYMBOL: condition-value M: #phi propagate-before ( #phi -- ) [ annotate-phi-inputs ] - [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ] + [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; : branch-phi-constraints ( output values booleans -- ) @@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- ) M: #phi propagate-after ( #phi -- ) condition-value get [ [ out-d>> ] - [ phi-in-d>> ] - [ phi-info-d>> ] tri + [ phi-in-d>> flip ] + [ phi-info-d>> flip ] tri [ [ possible-boolean-values ] map branch-phi-constraints diff --git a/basis/compiler/tree/propagation/copy/copy.factor b/basis/compiler/tree/propagation/copy/copy.factor index 2452aba4aa..53b7d17326 100644 --- a/basis/compiler/tree/propagation/copy/copy.factor +++ b/basis/compiler/tree/propagation/copy/copy.factor @@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ; ] 2each ; M: #phi compute-copy-equiv* - [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ; + [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ; M: node compute-copy-equiv* drop ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 3a94029756..fcc3b01dc0 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -128,8 +128,8 @@ DEFER: (flat-length) 45 node-count get [-] 8 /i ; : body-length-bias ( word -- n ) - [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi * - 24 swap [-] 4 /i ; + [ flat-length ] [ inlining-count get at 0 or ] bi + over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ; : inlining-rank ( #call word -- n ) [ classes-known? 2 0 ? ] @@ -184,7 +184,7 @@ SYMBOL: history over in-d>> second value-info literal>> dup class? [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; -: do-inlining ( #call word -- ? ) +: (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition #! is built at the end of the compilation unit. We do not @@ -195,7 +195,6 @@ SYMBOL: history #! discouraged, but it should still work.) { { [ dup deferred? ] [ 2drop f ] } - { [ dup custom-inlining? ] [ inline-custom ] } { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } @@ -203,3 +202,10 @@ SYMBOL: history { [ dup method-body? ] [ inline-method-body ] } [ 2drop f ] } cond ; + +: do-inlining ( #call word -- ? ) + #! Note the logic here: if there's a custom inlining hook, + #! it is permitted to return f, which means that we try the + #! normal inlining heuristic. + dup custom-inlining? [ 2dup inline-custom ] [ f ] if + [ 2drop t ] [ (do-inlining) ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 163b17094a..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 +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? [ @@ -144,10 +148,9 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -generic-comparison-ops [ - dup specific-comparison - '[ _ _ define-comparison-constraints ] each-derived-op -] each +! generic-comparison-ops [ +! dup specific-comparison define-comparison-constraints +! ] each ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) @@ -195,6 +198,11 @@ generic-comparison-ops [ 2bi and maybe-or-never ] "outputs" set-word-prop +\ both-fixnums? [ + [ class>> fixnum classes-intersect? not ] either? + f object-info ? +] "outputs" set-word-prop + { { >fixnum fixnum } { bignum>fixnum fixnum } @@ -226,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 @@ -243,6 +251,19 @@ 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 + { alien-signed-1 alien-unsigned-1 @@ -284,6 +305,15 @@ generic-comparison-ops [ "outputs" set-word-prop ] each +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop hashtable new ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 2c4769abe0..d95245fe83 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -8,7 +8,8 @@ math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals -specialized-arrays.double system sorting math.libm ; +specialized-arrays.double system sorting math.libm +math.intervals ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -33,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 @@ -65,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 @@ -278,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 @@ -599,6 +620,26 @@ MIXIN: empty-mixin [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test +[ T{ interval f { 0 t } { 127 t } } ] [ + [ { 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/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 52903fce8d..f6726e4404 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs accessors kernel combinators -classes.algebra sequences sequences.deep slots.private +classes.algebra sequences slots.private fry vectors classes.tuple.private math math.private arrays stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes ) : (expand-#push) ( object value -- nodes ) dup unboxed-allocation dup [ [ object-slots ] [ drop ] [ ] tri* - [ (expand-#push) ] 2map + [ (expand-#push) ] 2map-flat ] [ drop #push ] if ; @@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ drop { } ] when ; -: (flatten-values) ( values -- values' ) - [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; +: (flatten-values) ( values accum -- ) + dup '[ + dup unboxed-allocation + [ _ (flatten-values) ] [ _ push ] ?if + ] each ; : flatten-values ( values -- values' ) - dup empty? [ (flatten-values) flatten ] unless ; + dup empty? [ + 10 [ (flatten-values) ] keep + ] unless ; : prepare-slot-access ( #call -- tuple-values outputs slot-values ) [ in-d>> flatten-values ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor new file mode 100644 index 0000000000..1f488b3dde --- /dev/null +++ b/basis/compiler/utilities/utilities.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private arrays vectors fry +math.order ; +IN: compiler.utilities + +: flattener ( seq quot -- seq vector quot' ) + over length [ + dup + '[ + @ [ + dup array? + [ _ push-all ] [ _ push ] if + ] when* + ] + ] keep ; inline + +: flattening ( seq quot combinator -- seq' ) + [ flattener ] dip dip { } like ; inline + +: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline + +: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline + +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ [ [ length ] tri@ min min ] 3keep ] dip + '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline + +: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 25538cd594..3bd2d330c3 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -8,20 +8,20 @@ HELP: send { $values { "message" object } { "thread" thread } } -{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } +{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } { $see-also receive receive-if } ; HELP: receive { $values { "message" object } } -{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } +{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." } { $see-also send receive-if } ; HELP: receive-if { $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } } { "message" object } } -{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } +{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } { $see-also send receive } ; HELP: spawn-linked @@ -29,7 +29,7 @@ HELP: spawn-linked { "name" string } { "thread" thread } } -{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } +{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" } { $see-also spawn } ; ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages" @@ -64,7 +64,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" } -"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them." +"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them." { $subsection spawn-linked } "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:" { $code "[" @@ -74,11 +74,11 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions" "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: "concurrency.messaging" "Message-passing concurrency" -"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system." +"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "." $nl -"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends." +"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends." $nl -"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." +"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code." { $subsection { "concurrency" "messaging" } } { $subsection { "concurrency" "synchronous-sends" } } { $subsection { "concurrency" "exceptions" } } ; 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 12b6809df9..c609b9e98d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -59,6 +59,7 @@ HOOK: %set-slot cpu ( src obj slot tag temp -- ) HOOK: %set-slot-imm cpu ( src obj slot tag -- ) HOOK: %string-nth cpu ( dst obj index temp -- ) +HOOK: %set-string-nth-fast cpu ( ch obj index temp -- ) HOOK: %add cpu ( dst src1 src2 -- ) HOOK: %add-imm cpu ( dst src1 src2 -- ) @@ -76,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 -- ) @@ -119,6 +121,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- ) HOOK: %set-alien-float cpu ( ptr value -- ) HOOK: %set-alien-double cpu ( ptr value -- ) +HOOK: %alien-global cpu ( dst symbol library -- ) + HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %gc cpu ( -- ) 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 6b51585750..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 @@ -139,17 +139,21 @@ M:: ppc %string-nth ( dst src index temp -- ) "end" define-label temp src index ADD dst temp string-offset LBZ + 0 dst HEX: 80 CMPI + "end" get BLT temp src string-aux-offset LWZ - 0 temp \ f tag-number CMPI - "end" get BEQ 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 ; +M:: ppc %set-string-nth-fast ( ch obj index temp -- ) + temp obj index ADD + ch temp string-offset STB ; + M: ppc %add ADD ; M: ppc %add-imm ADDI ; M: ppc %sub swap SUBF ; @@ -168,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 @@ -407,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 ; @@ -429,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 @@ -623,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/32/32.factor b/basis/cpu/x86/32/32.factor index 3df072208d..5e06e72118 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ; M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; - M: x86.32 %alien-invoke (CALL) rel-dlsym ; M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 6472ec0edf..2077f51e0a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- ) M: x86.64 %prepare-var-args RAX RAX XOR ; -M: x86.64 %alien-global - [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ; - M: x86.64 %alien-invoke R11 0 MOV rc-absolute-cell rel-dlsym 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/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 42df1c8437..597a2c9d31 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -381,8 +381,8 @@ big-endian off [ arg0 ds-reg [] MOV - arg0 ds-reg bootstrap-cell neg [+] OR - ds-reg bootstrap-cell ADD + ds-reg bootstrap-cell SUB + arg0 ds-reg [] OR arg0 tag-mask get AND arg0 \ f tag-number MOV arg1 1 tag-fixnum MOV diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 3dbcd2eabf..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 @@ -365,23 +368,38 @@ M:: x86 %box-alien ( dst src temp -- ) M:: x86 %string-nth ( dst src index temp -- ) "end" define-label dst { src index temp } [| new-dst | + ! Load the least significant 7 bits into new-dst. + ! 8th bit indicates whether we have to load from + ! the aux vector or not. temp src index [+] LEA new-dst 1 small-reg temp string-offset [+] MOV new-dst new-dst 1 small-reg MOVZX + ! Do we have to look at the aux vector? + new-dst HEX: 80 CMP + "end" get JL + ! Yes, this is a non-ASCII character. Load aux vector temp src string-aux-offset [+] MOV - temp \ f tag-number CMP - "end" get JE new-dst temp XCHG + ! Compute index new-dst index ADD new-dst index ADD + ! Load high 16 bits new-dst 2 small-reg new-dst byte-array-offset [+] MOV new-dst new-dst 2 small-reg MOVZX - new-dst 8 SHL - new-dst temp OR + new-dst 7 SHL + ! Compute code point + new-dst temp XOR "end" resolve-label dst new-dst ?MOV ] with-small-register ; +M:: x86 %set-string-nth-fast ( ch str index temp -- ) + ch { index str temp } [| new-ch | + new-ch ch ?MOV + temp str index [+] LEA + temp string-offset [+] new-ch 1 small-reg MOV + ] with-small-register ; + :: %alien-integer-getter ( dst src size quot -- ) dst { src } [| new-dst | new-dst dup size small-reg dup src [] MOV @@ -443,19 +461,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- ) dst class store-tagged nursery-ptr size inc-allot-ptr ; -HOOK: %alien-global cpu ( symbol dll register -- ) - M:: x86 %write-barrier ( src card# table -- ) #! Mark the card pointed to by vreg. ! Mark the card card# src MOV card# card-bits SHR - "cards_offset" f table %alien-global + table "cards_offset" f %alien-global + table table [] MOV table card# [+] card-mark MOV ! Mark the card deck card# deck-bits card-bits - SHR - "decks_offset" f table %alien-global + table "decks_offset" f %alien-global + table table [] MOV table card# [+] card-mark MOV ; M: x86 %gc ( -- ) @@ -470,6 +488,9 @@ M: x86 %gc ( -- ) "minor_gc" f %alien-invoke "end" resolve-label ; +M: x86 %alien-global + [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; + HOOK: stack-reg cpu ( -- reg ) : decr-stack-reg ( n -- ) @@ -580,7 +601,8 @@ M: x86 %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 temp-reg-1 %alien-global + temp-reg-1 "stack_chain" f %alien-global + temp-reg-1 temp-reg-1 [] MOV temp-reg-1 [] stack-reg MOV temp-reg-1 [] cell SUB temp-reg-1 2 cells [+] ds-reg MOV 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/debugger/debugger.factor b/basis/debugger/debugger.factor index 94ceff8a23..35b09713d3 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -72,12 +72,6 @@ M: string error. print ; : try ( quot -- ) [ print-error-and-restarts ] recover ; -M: relative-underflow summary - drop "Too many items removed from data stack" ; - -M: relative-overflow summary - drop "Superfluous items pushed to data stack" ; - : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; 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/help/lint/lint.factor b/basis/help/lint/lint.factor index c7d505d86a..0a392733ac 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -67,7 +67,7 @@ IN: help.lint vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless ] each ; -: check-rendering ( word element -- ) +: check-rendering ( element -- ) [ print-topic ] with-string-writer drop ; : all-word-help ( words -- seq ) @@ -87,13 +87,14 @@ M: help-error error. : check-word ( word -- ) dup word-help [ [ - dup word-help [ - 2dup check-examples - 2dup check-values - 2dup check-see-also - 2dup nip check-modules - 2dup drop check-rendering - ] assert-depth 2drop + dup word-help '[ + _ _ { + [ check-examples ] + [ check-values ] + [ check-see-also ] + [ [ check-rendering ] [ check-modules ] bi* ] + } 2cleave + ] assert-depth ] check-something ] [ drop ] if ; @@ -101,9 +102,9 @@ M: help-error error. : check-article ( article -- ) [ - dup article-content [ - 2dup check-modules check-rendering - ] assert-depth 2drop + dup article-content + '[ _ check-rendering _ check-modules ] + assert-depth ] check-something ; : files>vocabs ( -- assoc ) 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/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index da3f80e9a5..73cc239a56 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,6 +4,7 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml logging +continuations xml.data html.forms html.elements diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index ac784f8c2a..d4f34ab8aa 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -3,7 +3,7 @@ USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present xml.writer xml.data xml.entities html.forms -html.templates html.templates.chloe.syntax ; +html.templates html.templates.chloe.syntax continuations ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) 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/logging/server/server.factor b/basis/logging/server/server.factor index 47656e8655..1872bb0af2 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -26,7 +26,7 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; -: multiline-header 20 CHAR: - ; foldable +: multiline-header ( -- string ) 20 CHAR: - ; foldable : (write-message) ( msg name>> level multi? -- ) [ 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/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 56da09ccdd..19715357ee 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private words -sequences parser namespaces make assocs quotations arrays locals +sequences parser namespaces make assocs quotations arrays generic generic.math hashtables effects compiler.units -classes.algebra ; +classes.algebra fry combinators ; IN: math.partial-dispatch PREDICATE: math-partial < word @@ -45,60 +45,62 @@ M: word integer-op-input-classes { bitnot fixnum-bitnot } } at swap or ; -:: fixnum-integer-op ( a b fix-word big-word -- c ) - b tag 0 eq? [ - a b fix-word execute - ] [ - a fixnum>bignum b big-word execute - ] if ; inline - -:: integer-fixnum-op ( a b fix-word big-word -- c ) - a tag 0 eq? [ - a b fix-word execute - ] [ - a b fixnum>bignum big-word execute - ] if ; inline - -:: integer-integer-op ( a b fix-word big-word -- c ) - b tag 0 eq? [ - a b fix-word big-word integer-fixnum-op - ] [ - a dup tag 0 eq? [ fixnum>bignum ] when - b big-word execute - ] if ; inline - -: integer-op-combinator ( triple -- word ) +: integer-fixnum-op-quot ( fix-word big-word -- quot ) [ - [ second name>> % "-" % ] - [ third name>> % "-op" % ] - bi - ] "" make "math.partial-dispatch" lookup ; + [ over fixnum? ] % + [ '[ _ execute ] , ] + [ '[ fixnum>bignum _ execute ] , ] bi* + \ if , + ] [ ] make ; + +: fixnum-integer-op-quot ( fix-word big-word -- quot ) + [ + [ dup fixnum? ] % + [ '[ _ execute ] , ] + [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi* + \ if , + ] [ ] make ; + +: integer-integer-op-quot ( fix-word big-word -- quot ) + [ + [ dup fixnum? ] % + 2dup integer-fixnum-op-quot , + [ + [ over fixnum? [ [ fixnum>bignum ] dip ] when ] % + nip , + ] [ ] make , + \ if , + ] [ ] make ; : integer-op-word ( triple -- word ) [ name>> ] map "-" join "math.partial-dispatch" create ; -: integer-op-quot ( triple fix-word big-word -- quot ) - rot integer-op-combinator 1quotation 2curry ; +: integer-op-quot ( fix-word big-word triple -- quot ) + [ second ] [ third ] bi 2array { + { { fixnum integer } [ fixnum-integer-op-quot ] } + { { integer fixnum } [ integer-fixnum-op-quot ] } + { { integer integer } [ integer-integer-op-quot ] } + } case ; -: define-integer-op-word ( triple fix-word big-word -- ) +: define-integer-op-word ( fix-word big-word triple -- ) [ - [ 2drop integer-op-word ] [ integer-op-quot ] 3bi + [ 2nip integer-op-word ] [ integer-op-quot ] 3bi (( x y -- z )) define-declared ] [ - 2drop + 2nip [ integer-op-word ] keep "derived-from" set-word-prop ] 3bi ; : define-integer-op-words ( triples fix-word big-word -- ) - [ define-integer-op-word ] 2curry each ; + '[ [ _ _ ] dip define-integer-op-word ] each ; : integer-op-triples ( word -- triples ) { { fixnum integer } { integer fixnum } { integer integer } - } swap [ prefix ] curry map ; + } swap '[ _ prefix ] map ; : define-integer-ops ( word fix-word big-word -- ) [ @@ -138,7 +140,7 @@ SYMBOL: fast-math-ops [ drop math-class-max swap specific-method >boolean ] if ; : (derived-ops) ( word assoc -- words ) - swap [ rot first eq? nip ] curry assoc-filter ; + swap '[ swap first _ eq? nip ] assoc-filter ; : derived-ops ( word -- words ) [ 1array ] [ math-ops get (derived-ops) values ] bi append ; 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/peg/peg.factor b/basis/peg/peg.factor index 1fb5909bcf..8a62365f53 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -4,8 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs debugger io vectors arrays math.parser math.order vectors combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors -locals effects splitting combinators.short-circuit -combinators.short-circuit.smart generalizations ; +locals effects splitting combinators.short-circuit generalizations ; IN: peg USE: prettyprint @@ -278,7 +277,8 @@ GENERIC: (compile) ( peg -- quot ) : parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd id>> "peg-id" set-word-prop + gensym 2dup swap peg>> (compile) (( -- result )) define-declared + swap dupd id>> "peg-id" set-word-prop [ execute-parser ] curry ; : preset-parser-word ( parser -- parser word ) @@ -306,7 +306,7 @@ SYMBOL: delayed #! Work through all delayed parsers and recompile their #! words to have the correct bodies. delayed get [ - call compile-parser 1quotation 0 1 define-declared + call compile-parser 1quotation (( -- result )) define-declared ] assoc-each ; : compile ( parser -- word ) @@ -421,7 +421,7 @@ M: seq-parser (compile) ( peg -- quot ) [ parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry , [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each - ] { } make , \ && , + ] { } make , \ 1&& , ] [ ] make ; TUPLE: choice-parser parsers ; @@ -431,7 +431,7 @@ M: choice-parser (compile) ( peg -- quot ) [ parsers>> [ compile-parser ] map unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each - ] { } make , \ || , + ] { } make , \ 0|| , ] [ ] make ; TUPLE: repeat0-parser p1 ; 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/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 357ab87966..67b0fa23e7 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -11,48 +11,39 @@ IN: random.mersenne-twister TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; -: mt-n 624 ; inline -: mt-m 397 ; inline -: mt-a HEX: 9908b0df ; inline +: n 624 ; inline +: m 397 ; inline +: a uint-array{ 0 HEX: 9908b0df } ; inline -: mersenne-wrap ( n -- n' ) - dup mt-n > [ mt-n - ] when ; inline +: y ( n seq -- y ) + [ nth-unsafe 31 mask-bit ] + [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline -: wrap-nth ( n seq -- obj ) - [ mersenne-wrap ] dip nth-unsafe ; inline - -: set-wrap-nth ( obj n seq -- ) - [ mersenne-wrap ] dip set-nth-unsafe ; inline - -: calculate-y ( n seq -- y ) - [ wrap-nth 31 mask-bit ] - [ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline - -: (mt-generate) ( n seq -- next-mt ) +: mt[k] ( offset n seq -- ) [ - calculate-y - [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor - ] [ - [ mt-m + ] [ wrap-nth ] bi* - ] 2bi bitxor ; inline + [ [ + ] dip nth-unsafe ] + [ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi + bitxor + ] 2keep set-nth-unsafe ; inline : mt-generate ( mt -- ) [ - mt-n swap seq>> '[ - _ [ (mt-generate) ] [ set-wrap-nth ] 2bi - ] each + seq>> + [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ] + [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] + bi ] [ 0 >>i drop ] bi ; inline : init-mt-formula ( i seq -- f(seq[i]) ) - dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline + dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline : init-mt-rest ( seq -- ) - mt-n 1- swap '[ - _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi + n 1- swap '[ + _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi ] each ; inline : init-mt-seq ( seed -- seq ) - 32 bits mt-n + 32 bits n [ set-first ] [ init-mt-rest ] [ ] tri ; inline : mt-temper ( y -- yt ) @@ -62,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; dup -18 shift bitxor ; inline : next-index ( mt -- i ) - dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline + dup i>> dup n < [ nip ] [ drop mt-generate 0 ] if ; inline PRIVATE> @@ -75,7 +66,7 @@ M: mersenne-twister seed-random ( mt seed -- ) M: mersenne-twister random-32* ( mt -- r ) [ next-index ] - [ seq>> wrap-nth mt-temper ] + [ seq>> nth-unsafe mt-temper ] [ [ 1+ ] change-i drop ] tri ; USE: init 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/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 07030085a6..7f8c920b19 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -148,7 +148,7 @@ M: object apply-object push-literal ; { [ dup inline? ] [ drop f ] } { [ dup deferred? ] [ drop f ] } { [ dup crossref? not ] [ drop f ] } - [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ] + [ def>> [ word? ] contains? ] } cond ; : ?missing-effect ( word -- ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 26e1b81c93..28634f2d44 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -99,21 +99,18 @@ M: object infer-call* 3 infer->r infer-call 3 infer-r> ; : infer-dip ( -- ) - commit-literals literals get [ \ dip def>> infer-quot-here ] [ pop 1 infer->r infer-quot-here 1 infer-r> ] if-empty ; : infer-2dip ( -- ) - commit-literals literals get [ \ 2dip def>> infer-quot-here ] [ pop 2 infer->r infer-quot-here 2 infer-r> ] if-empty ; : infer-3dip ( -- ) - commit-literals literals get [ \ 3dip def>> infer-quot-here ] [ pop 3 infer->r infer-quot-here 3 infer-r> ] @@ -307,7 +304,7 @@ M: object infer-call* \ { real real } { complex } define-primitive \ make-foldable -\ both-fixnums? { object object } { object object object } define-primitive +\ both-fixnums? { object object } { object } define-primitive \ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable @@ -562,7 +559,8 @@ M: object infer-call* \ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable -\ set-string-nth { fixnum fixnum string } { } define-primitive +\ set-string-nth-slow { fixnum fixnum string } { } define-primitive +\ set-string-nth-fast { fixnum fixnum string } { } define-primitive \ resize-array { integer array } { array } define-primitive \ resize-array make-flushable 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/threads/threads-docs.factor b/basis/threads/threads-docs.factor index cc2216545d..a1d7e50594 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io threads.private continuations init quotations strings -assocs heaps boxes namespaces deques ; +assocs heaps boxes namespaces deques dlists ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" @@ -82,7 +82,7 @@ $nl { $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; HELP: run-queue -{ $values { "queue" deque } } +{ $values { "dlist" dlist } } { $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." $nl "By convention, threads are queued with " { $link push-front } @@ -97,6 +97,7 @@ HELP: resume-with { $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ; HELP: sleep-queue +{ $values { "heap" min-heap } } { $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; HELP: sleep-time diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 1e04ad88c2..305ef0cca3 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -36,7 +36,7 @@ sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads 64 getenv ; +: threads ( -- assoc ) 64 getenv ; : thread ( id -- thread ) threads at ; @@ -73,9 +73,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue 65 getenv ; +: run-queue ( -- dlist ) 65 getenv ; -: sleep-queue 66 getenv ; +: sleep-queue ( -- heap ) 66 getenv ; : resume ( thread -- ) f >>state diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index c61b4547a9..c88e959b8e 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -4,9 +4,17 @@ IN: tools.annotations ARTICLE: "tools.annotations" "Word annotations" "The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question." +$nl +"Printing messages when a word is called or returns:" { $subsection watch } +{ $subsection watch-vars } +"Starting the walker when a word is called:" { $subsection breakpoint } { $subsection breakpoint-if } +"Timing words:" +{ $subsection reset-word-timing } +{ $subsection add-timing } +{ $subsection word-timing. } "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:" { $subsection annotate } ; @@ -63,3 +71,13 @@ HELP: word-inputs { "seq" sequence } } { $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ; +HELP: add-timing +{ $values { "word" word } } +{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." } +{ $see-also "timing" "profiling" } ; + +HELP: reset-word-timing +{ $description "Resets the word timing table." } ; + +HELP: word-timing. +{ $description "Prints the word timing table." } ; diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 1e1eccb8b5..1e766e3dec 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test tools.annotations math parser eval +USING: tools.test tools.annotations tools.time math parser eval io.streams.string kernel ; IN: tools.annotations.tests diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 9847b16bc2..ecf3ba0a76 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel words parser io summary quotations -sequences prettyprint continuations effects definitions -compiler.units namespaces assocs tools.walker generic -inspector fry ; +USING: accessors kernel math sorting words parser io summary +quotations sequences prettyprint continuations effects +definitions compiler.units namespaces assocs tools.walker +tools.time generic inspector fry ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -20,9 +20,11 @@ M: word reset f "unannotated-def" set-word-prop ] [ drop ] if ; +ERROR: cannot-annotate-twice word ; + : annotate ( word quot -- ) over "unannotated-def" word-prop [ - "Cannot annotate a word twice" throw + over cannot-annotate-twice ] when [ over dup def>> "unannotated-def" set-word-prop @@ -82,3 +84,21 @@ M: word annotate-methods : breakpoint-if ( word quot -- ) '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ; + +SYMBOL: word-timing + +word-timing global [ H{ } clone or ] change-at + +: reset-word-timing ( -- ) + word-timing get clear-assoc ; + +: (add-timing) ( def word -- def' ) + '[ _ benchmark _ word-timing get at+ ] ; + +: add-timing ( word -- ) + dup '[ _ (add-timing) ] annotate ; + +: word-timing. ( -- ) + word-timing get + >alist [ 1000000 /f ] assoc-map sort-values + simple-table. ; 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/test/test-docs.factor b/basis/tools/test/test-docs.factor index f19ffb83a4..3cabff457f 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -86,7 +86,7 @@ HELP: test-all { $description "Runs unit tests for all loaded vocabularies." } ; HELP: run-all-tests -{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $values { "failures" "an association list of unit test failures" } } { $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; HELP: test-failures. diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor new file mode 100644 index 0000000000..473335645f --- /dev/null +++ b/basis/tools/test/test-tests.factor @@ -0,0 +1,4 @@ +IN: tools.test.tests +USING: tools.test ; + +\ test-all must-infer diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 080db86338..704a7f1bd5 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -88,7 +88,7 @@ SYMBOL: this-test : test ( prefix -- ) run-tests test-failures. ; -: run-all-tests ( prefix -- failures ) +: run-all-tests ( -- failures ) "" run-tests ; : test-all ( -- ) 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/tr/tr.factor b/basis/tr/tr.factor index 30d0efb28b..66d8df7d44 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -1,13 +1,25 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays strings sequences sequences.private -fry kernel words parser lexer assocs math.order ; +fry kernel words parser lexer assocs math math.order summary ; IN: tr +ERROR: bad-tr ; + +M: bad-tr summary + drop "TR: can only be used with ASCII characters" ; + : TR: scan parse-definition unclip-last [ unclip-last ] dip compute-tr + [ check-tr ] [ [ create-tr ] dip define-tr ] - [ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ; + [ [ "-fast" append create-tr ] dip define-fast-tr ] 2tri ; parsing diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 8861f8ffa2..811d35a8a1 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors math arrays cocoa cocoa.application +USING: accessors math arrays assocs cocoa cocoa.application command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system @@ -129,16 +129,29 @@ M: handle flush-gl-context ( handle -- ) M: cocoa-ui-backend beep ( -- ) NSBeep ; +CLASS: { + { +superclass+ "NSObject" } + { +name+ "FactorApplicationDelegate" } +} + +{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" } + [ 3drop event-loop ] +} ; + +: install-app-delegate ( -- ) + NSApp FactorApplicationDelegate install-delegate ; + SYMBOL: cocoa-init-hook +cocoa-init-hook global [ [ install-app-delegate ] or ] change-at + M: cocoa-ui-backend ui "UI" assert.app [ [ init-clipboard - cocoa-init-hook get [ call ] when* + cocoa-init-hook get call start-ui - finish-launching - event-loop + NSApp -> run ] ui-running ] with-cocoa ; diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor index a8ade05a86..ccaae0c1ab 100644 --- a/basis/ui/cocoa/tools/tools.factor +++ b/basis/ui/cocoa/tools/tools.factor @@ -20,8 +20,8 @@ IN: ui.cocoa.tools ! Handle Open events from the Finder CLASS: { - { +superclass+ "NSObject" } - { +name+ "FactorApplicationDelegate" } + { +superclass+ "FactorApplicationDelegate" } + { +name+ "FactorWorkspaceApplicationDelegate" } } { "application:openFiles:" "void" { "id" "SEL" "id" "id" } @@ -49,7 +49,7 @@ CLASS: { } ; : install-app-delegate ( -- ) - NSApp FactorApplicationDelegate install-delegate ; + NSApp FactorWorkspaceApplicationDelegate install-delegate ; ! Service support; evaluate Factor code from other apps :: do-service ( pboard error quot -- ) 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/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 9e13e5ad7c..1c2055156e 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -36,8 +36,9 @@ TUPLE: slider < frame elevator thumb saved line ; #! A scaling factor such that if x is a slider co-ordinate, #! x*n is the screen position of the thumb, and conversely #! for x/n. The '1 max' calls avoid division by zero. - dup elevator-length over thumb-dim - 1 max - swap slider-max* 1 max / ; + [ [ elevator-length ] [ thumb-dim ] bi - 1 max ] + [ slider-max* 1 max ] + bi / ; : slider>screen ( m scale -- n ) slider-scale * ; : screen>slider ( m scale -- n ) slider-scale / ; 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 74bc57e9db..4a998a1ebb 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -12,11 +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: array like drop dup array? [ >array ] unless ; +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/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a4cee5c7b9..f90ba23999 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -109,9 +109,6 @@ bootstrapping? on } [ create-vocab drop ] each ! Builtin classes -: define-builtin-predicate ( class -- ) - dup class>type [ builtin-instance? ] curry define-predicate ; - : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -192,6 +189,10 @@ define-union-class ] [ ] make define-predicate-class +"array-capacity" "sequences.private" lookup +[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append +"coercer" set-word-prop + ! Catch-all class for providing a default method. "object" "kernel" create [ f f { } intersection-class define-class ] @@ -499,7 +500,8 @@ tuple { "alien-address" "alien" } { "set-slot" "slots.private" } { "string-nth" "strings.private" } - { "set-string-nth" "strings.private" } + { "set-string-nth-fast" "strings.private" } + { "set-string-nth-slow" "strings.private" } { "resize-array" "arrays" } { "resize-string" "strings" } { "" "arrays" } diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 50ea4b32ba..f981e758d7 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -9,7 +9,6 @@ M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline -M: byte-array like drop dup byte-array? [ >byte-array ] unless ; M: byte-array new-sequence drop ; M: byte-array equal? diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 5d337cb028..6938d02b2f 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable byte-arrays ; +sequences.private growable byte-arrays accessors ; IN: byte-vectors TUPLE: byte-vector @@ -26,6 +26,19 @@ M: byte-vector new-sequence M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; +M: byte-array like + #! If we have an byte-array, we're done. + #! If we have a byte-vector, and it's at full capacity, + #! we're done. Otherwise, call resize-byte-array, which is a + #! relatively fast primitive. + drop dup byte-array? [ + dup byte-vector? [ + [ length ] [ underlying>> ] bi + 2dup length eq? + [ nip ] [ resize-byte-array ] if + ] [ >byte-array ] if + ] unless ; + M: byte-array new-resizable drop ; INSTANCE: byte-vector growable diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index ee687c2939..0e4a3b56fd 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes classes.algebra words kernel kernel.private namespaces sequences math math.private -combinators assocs ; +combinators assocs quotations ; IN: classes.builtin SYMBOL: builtins @@ -10,10 +10,14 @@ SYMBOL: builtins PREDICATE: builtin-class < class "metaclass" word-prop builtin-class eq? ; -: type>class ( n -- class ) builtins get-global nth ; - : class>type ( class -- n ) "type" word-prop ; foldable +PREDICATE: lo-tag-class < builtin-class class>type 7 <= ; + +PREDICATE: hi-tag-class < builtin-class class>type 7 > ; + +: type>class ( n -- class ) builtins get-global nth ; + : bootstrap-type>class ( n -- class ) builtins get nth ; M: hi-tag class hi-tag type>class ; @@ -22,16 +26,20 @@ M: object class tag type>class ; M: builtin-class rank-class drop 0 ; -: builtin-instance? ( object n -- ? ) - #! 7 == tag-mask get - #! 3 == hi-tag tag-number - dup 7 fixnum<= [ swap tag eq? ] [ - swap dup tag 3 eq? - [ hi-tag eq? ] [ 2drop f ] if - ] if ; inline +GENERIC: define-builtin-predicate ( class -- ) -M: builtin-class instance? - class>type builtin-instance? ; +M: lo-tag-class define-builtin-predicate + dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; + +M: hi-tag-class define-builtin-predicate + dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation + [ dup tag 3 eq? ] [ [ drop f ] if ] surround + define-predicate ; + +M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ; + +M: hi-tag-class instance? + over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; M: builtin-class (flatten-class) dup set ; 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/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6f8021f733..9d748d665d 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -90,10 +90,10 @@ ERROR: bad-superclass class ; 2drop f ] if ; inline -: tuple-instance-1? ( object class -- ? ) - swap dup tuple? [ - layout-of 7 slot eq? - ] [ 2drop f ] if ; inline +: tuple-predicate-quot/1 ( class -- quot ) + #! Fast path for tuples with no superclass + [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation + [ dup tuple? ] [ [ drop f ] if ] surround ; : tuple-instance? ( object class offset -- ? ) rot dup tuple? [ @@ -105,13 +105,16 @@ ERROR: bad-superclass class ; : layout-class-offset ( echelon -- n ) 2 * 5 + ; +: tuple-predicate-quot ( class echelon -- quot ) + layout-class-offset [ tuple-instance? ] 2curry ; + : echelon-of ( class -- n ) tuple-layout third ; : define-tuple-predicate ( class -- ) dup dup echelon-of { - { 1 [ [ tuple-instance-1? ] curry ] } - [ layout-class-offset [ tuple-instance? ] 2curry ] + { 1 [ tuple-predicate-quot/1 ] } + [ tuple-predicate-quot ] } case define-predicate ; : class-size ( class -- n ) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 3afc0a3c3d..8d1d9f0d2a 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -29,17 +29,9 @@ $nl $nl "A combinator which can help with implementing methods on " { $link hashcode* } ":" { $subsection recursive-hashcode } -{ $subsection "assertions" } { $subsection "combinators-quot" } { $see-also "quotations" "dataflow" } ; -ARTICLE: "assertions" "Assertions" -"Some words to make assertions easier to enforce:" -{ $subsection assert } -{ $subsection assert= } -"Runtime stack depth checking:" -{ $subsection assert-depth } ; - ABOUT: "combinators" HELP: cleave @@ -167,7 +159,3 @@ HELP: dispatch ( n array -- ) { $values { "n" "a fixnum" } { "array" "an array of quotations" } } { $description "Calls the " { $snippet "n" } "th quotation in the array." } { $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is an implementation detail used by the generic word system to accelerate method dispatch. It does not perform type or bounds checks, and user code should not need to call it directly." } ; - -HELP: assert-depth -{ $values { "quot" "a quotation" } } -{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 68eef23691..6edec815da 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -134,22 +134,6 @@ ERROR: no-case ; [ drop linear-case-quot ] } cond ; -! assert-depth -: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) - 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ; - -ERROR: relative-underflow stack ; - -ERROR: relative-overflow stack ; - -: assert-depth ( quot -- ) - [ datastack ] dip dip [ datastack ] dip - 2dup [ length ] compare { - { +lt+ [ trim-datastacks nip relative-underflow ] } - { +eq+ [ 2drop ] } - { +gt+ [ trim-datastacks drop relative-overflow ] } - } case ; inline - ! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index f57be71ca8..3632482162 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -83,6 +83,7 @@ $nl { $subsection with-return } "Reflecting the datastack:" { $subsection with-datastack } +{ $subsection assert-depth } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -216,6 +217,10 @@ HELP: with-datastack { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; +HELP: assert-depth +{ $values { "quot" "a quotation" } } +{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ; + HELP: { $description "Constructs a new continuation." } { $notes "User code should call " { $link continuation } " instead." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 0f55009608..c7056856b6 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -114,6 +114,9 @@ SYMBOL: return-continuation ] 3 (throw) ] callcc1 2nip ; +: assert-depth ( quot -- ) + { } swap with-datastack { } assert= ; inline + GENERIC: compute-restarts ( error -- seq ) ] most ; -: math-class-min ( class1 class2 -- class ) - [ swap math-class<=> ] most ; - : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; @@ -83,7 +80,7 @@ M: math-combination perform-combination drop dup [ - \ both-fixnums? , + [ 2dup both-fixnums? ] % dup fixnum bootstrap-word dup math-method , \ over [ dup math-class? [ diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index dbdc6e0742..5ed33009c0 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -3,7 +3,7 @@ USING: classes.private generic.standard.engines namespaces make arrays assocs sequences.private quotations kernel.private math slots.private math.private kernel accessors words -layouts sorting sequences ; +layouts sorting sequences combinators ; IN: generic.standard.engines.tag TUPLE: lo-tag-dispatch-engine methods ; @@ -24,15 +24,21 @@ C: lo-tag-dispatch-engine : sort-tags ( assoc -- alist ) >alist sort-keys reverse ; +: tag-dispatch-test ( tag# -- quot ) + picker [ tag ] append swap [ eq? ] curry append ; + +: tag-dispatch-quot ( alist -- quot ) + [ default get ] dip + [ [ tag-dispatch-test ] dip ] assoc-map + alist>quot ; + M: lo-tag-dispatch-engine engine>quot methods>> engines>quots* [ [ lo-tag-number ] dip ] assoc-map [ - picker % [ tag ] % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get direct-dispatch-quot - ] if-small? % + [ sort-tags tag-dispatch-quot ] + [ picker % [ tag ] % num-tags get direct-dispatch-quot ] + if-small? % ] [ ] make ; TUPLE: hi-tag-dispatch-engine methods ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 474cf4c9d6..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? [ @@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- ) : push-unsafe ( elt seq -- ) [ length ] keep [ underlying>> set-array-nth ] - [ [ 1+ ] dip (>>length) ] + [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ] 2bi ; inline PRIVATE> diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index 6c640bbdeb..a579153353 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -61,13 +61,13 @@ HELP: fread ( n alien -- str/f ) { $errors "Throws an error if the input operation failed." } ; HELP: stdin-handle -{ $values { "in" "a C FILE* handle" } } +{ $values { "alien" "a C FILE* handle" } } { $description "Outputs the console standard input file handle." } ; HELP: stdout-handle -{ $values { "out" "a C FILE* handle" } } +{ $values { "alien" "a C FILE* handle" } } { $description "Outputs the console standard output file handle." } ; HELP: stderr-handle -{ $values { "out" "a C FILE* handle" } } +{ $values { "alien" "a C FILE* handle" } } { $description "Outputs the console standard error file handle." } ; diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 47e19d2c40..71c9ffd7d9 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -56,9 +56,9 @@ M: c-reader dispose* M: c-io-backend init-io ; -: stdin-handle 11 getenv ; -: stdout-handle 12 getenv ; -: stderr-handle 61 getenv ; +: stdin-handle ( -- alien ) 11 getenv ; +: stdout-handle ( -- alien ) 12 getenv ; +: stderr-handle ( -- alien ) 61 getenv ; : init-c-stdio ( -- stdin stdout stderr ) stdin-handle diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 5ee12ddedc..01ef8d480d 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -887,6 +887,11 @@ $nl "An object can be cloned; the clone has distinct identity but equal value:" { $subsection clone } ; +ARTICLE: "assertions" "Assertions" +"Some words to make assertions easier to enforce:" +{ $subsection assert } +{ $subsection assert= } ; + ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } { $subsection "words" } @@ -902,6 +907,7 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "compositional-combinators" } { $subsection "combinators" } "Advanced topics:" +{ $subsection "assertions" } { $subsection "implementing-combinators" } { $subsection "errors" } { $subsection "continuations" } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 98dc0e50fa..564600d322 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -154,8 +154,11 @@ TUPLE: identity-tuple ; M: identity-tuple equal? 2drop f ; +USE: math.private : = ( obj1 obj2 -- ? ) - 2dup eq? [ 2drop t ] [ equal? ] if ; inline + 2dup eq? [ 2drop t ] [ + 2dup both-fixnums? [ 2drop f ] [ equal? ] if + ] if ; inline GENERIC: clone ( obj -- cloned ) 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-docs.factor b/core/math/math-docs.factor index aca43add5c..3c2b7f67e2 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -166,15 +166,17 @@ HELP: log2 HELP: 1+ { $values { "x" number } { "y" number } } { $description - "Increments a number by 1. The following two lines are equivalent, but the first is more efficient:" + "Increments a number by 1. The following two lines are equivalent:" { $code "1+" "1 +" } + "There is no difference in behavior or efficiency." } ; HELP: 1- { $values { "x" number } { "y" number } } { $description - "Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:" + "Decrements a number by 1. The following two lines are equivalent:" { $code "1-" "1 -" } + "There is no difference in behavior or efficiency." } ; HELP: ?1+ 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-tests.factor b/core/parser/parser-tests.factor index 1e93a762f2..cc97b78eb6 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -5,6 +5,8 @@ sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer ; IN: parser.tests +\ run-file must-infer + [ [ 1 [ 2 [ 3 ] 4 ] 5 ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] @@ -400,7 +402,7 @@ IN: parser.tests ] times [ "resource:core/parser/test/assert-depth.factor" run-file ] -[ stack>> { 1 2 3 } sequence= ] +[ got>> { 1 2 3 } sequence= ] must-fail-with 2 [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 49ab0eb7d4..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 ) [ @@ -307,7 +307,7 @@ print-use-hook global [ [ ] or ] change-at ] recover ; : run-file ( file -- ) - [ dup parse-file call ] assert-depth drop ; + [ parse-file call ] curry assert-depth ; : ?run-file ( path -- ) dup exists? [ run-file ] [ drop ] if ; diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 5a30654f03..5590432ef4 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -31,16 +31,16 @@ M: sbuf equal? M: string new-resizable drop ; M: string like + #! If we have a string, we're done. + #! If we have an sbuf, and it's at full capacity, we're done. + #! Otherwise, call resize-string, which is a relatively + #! fast primitive. drop dup string? [ dup sbuf? [ - dup length over underlying>> length eq? [ - underlying>> dup reset-string-hashcode - ] [ - >string - ] if - ] [ - >string - ] if + [ length ] [ underlying>> ] bi + 2dup length eq? + [ nip dup reset-string-hashcode ] [ resize-string ] if + ] [ >string ] if ] unless ; INSTANCE: sbuf growable 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 3461266081..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 @@ -835,12 +828,35 @@ PRIVATE> : supremum ( seq -- n ) dup first [ max ] reduce ; -: flip ( matrix -- newmatrix ) - dup empty? [ - dup [ length ] map infimum - swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as - ] unless ; - : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline + +! We hand-optimize flip to such a degree because type hints +! cannot express that an array is an array of arrays yet, and +! this word happens to be performance-critical since the compiler +! itself uses it. Optimizing it like this reduced compile time. +> ; + +: array-flip ( matrix -- newmatrix ) + [ dup first array-length [ array-length min ] reduce ] keep + [ [ array-nth ] with { } map-as ] curry { } map-as ; + +PRIVATE> + +: flip ( matrix -- newmatrix ) + dup empty? [ + dup array? [ + dup [ array? ] all? + [ array-flip ] [ generic-flip ] if + ] [ generic-flip ] if + ] unless ; 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/strings/strings.factor b/core/strings/strings.factor index 39628ede98..0c3f918fdc 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -16,6 +16,10 @@ IN: strings : rehash-string ( str -- ) 1 over sequence-hashcode swap set-string-hashcode ; inline +: set-string-nth ( ch n str -- ) + pick HEX: 7f fixnum<= + [ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline + PRIVATE> M: string equal? @@ -27,8 +31,9 @@ M: string equal? ] if ; M: string hashcode* - nip dup string-hashcode [ ] - [ dup rehash-string string-hashcode ] ?if ; + nip + dup string-hashcode + [ ] [ dup rehash-string string-hashcode ] ?if ; M: string length length>> ; @@ -38,7 +43,7 @@ M: string nth-unsafe M: string set-nth-unsafe dup reset-string-hashcode - [ [ >fixnum ] dip >fixnum ] dip set-string-nth ; + [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; M: string clone (clone) [ clone ] change-aux ; diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index dab30f306f..a6bfef71d0 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences sequences.private growable ; +USING: arrays kernel math sequences sequences.private growable +accessors ; IN: vectors 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 ; @@ -22,6 +23,19 @@ M: vector new-sequence M: vector equal? over vector? [ sequence= ] [ 2drop f ] if ; +M: array like + #! If we have an array, we're done. + #! If we have a vector, and it's at full capacity, we're done. + #! Otherwise, call resize-array, which is a relatively + #! fast primitive. + drop dup array? [ + dup vector? [ + [ length ] [ underlying>> ] bi + 2dup length eq? + [ nip ] [ resize-array ] if + ] [ >array ] if + ] unless ; + M: sequence new-resizable drop ; INSTANCE: vector growable diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 7b53e98df1..e5bd74a981 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -154,9 +154,6 @@ forget-junk [ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test -[ "vocabs.loader.test.e" require ] -[ relative-overflow? ] must-fail-with - 0 "vocabs.loader.test.g" set-global [ 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/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/fuel/authors.txt b/extra/fuel/authors.txt new file mode 100644 index 0000000000..ecfb757fd2 --- /dev/null +++ b/extra/fuel/authors.txt @@ -0,0 +1,2 @@ +Jose Antonio Ortega Ruiz +Eduardo Cavazos diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..74bc5d4d45 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test fuel ; +IN: fuel.tests diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor new file mode 100644 index 0000000000..d8a363ca71 --- /dev/null +++ b/extra/fuel/fuel.factor @@ -0,0 +1,121 @@ +! Copyright (C) 2008 Jose Antonio Ortega Ruiz. +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors arrays classes.tuple compiler.units continuations debugger +definitions eval io io.files io.streams.string kernel listener listener.private +make math namespaces parser prettyprint quotations sequences strings +vectors vocabs.loader ; + +IN: fuel + +! > in set ] + [ use>> clone use set ] + [ ds?>> display-stacks? swap [ on ] [ off ] if ] tri + ] unless ; + +SYMBOL: fuel-eval-result +f clone fuel-eval-result set-global + +SYMBOL: fuel-eval-output +f clone fuel-eval-result set-global + +! PRIVATE> + +GENERIC: fuel-pprint ( obj -- ) + +M: object fuel-pprint pprint ; + +M: f fuel-pprint drop "nil" write ; + +M: integer fuel-pprint pprint ; + +M: string fuel-pprint pprint ; + +M: sequence fuel-pprint + dup empty? [ drop f fuel-pprint ] [ + "(" write + [ " " write ] [ fuel-pprint ] interleave + ")" write + ] if ; + +M: tuple fuel-pprint tuple>array fuel-pprint ; + +M: continuation fuel-pprint drop "~continuation~" write ; + +: fuel-eval-set-result ( obj -- ) + clone fuel-eval-result set-global ; + +: fuel-retort ( -- ) + error get + fuel-eval-result get-global + fuel-eval-output get-global + 3array fuel-pprint ; + +: fuel-forget-error ( -- ) + f error set-global ; + +: (fuel-begin-eval) ( -- ) + push-fuel-status + display-stacks? off + fuel-forget-error + f fuel-eval-result set-global + f fuel-eval-output set-global ; + +: (fuel-end-eval) ( quot -- ) + with-string-writer fuel-eval-output set-global + fuel-retort + pop-fuel-status ; + +: (fuel-eval) ( lines -- ) + [ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ; + +: (fuel-eval-each) ( lines -- ) + [ 1vector (fuel-eval) ] each ; + +: (fuel-eval-usings) ( usings -- ) + [ "USING: " prepend " ;" append ] map + (fuel-eval-each) fuel-forget-error ; + +: (fuel-eval-in) ( in -- ) + [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; + +: fuel-eval-in-context ( lines in usings -- ) + (fuel-begin-eval) [ + (fuel-eval-usings) + (fuel-eval-in) + (fuel-eval) + ] (fuel-end-eval) ; + +: fuel-begin-eval ( in -- ) + (fuel-begin-eval) + (fuel-eval-in) + fuel-retort ; + +: fuel-eval ( lines -- ) + (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; + +: fuel-end-eval ( -- ) + [ ] (fuel-end-eval) ; + +: fuel-get-edit-location ( defspec -- ) + where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; + +: fuel-startup ( -- ) + "listener" run ; + +MAIN: fuel-startup 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/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 ] [ ] 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/misc/fuel/README b/misc/fuel/README new file mode 100644 index 0000000000..078490abfd --- /dev/null +++ b/misc/fuel/README @@ -0,0 +1,64 @@ +FUEL, Factor's Ultimate Emacs Library +------------------------------------- + +FUEL provides a complete environment for your Factor coding pleasure +inside Emacs, including source code edition and interaction with a +Factor listener instance running within Emacs. + +FUEL was started by Jose A Ortega as an extension to Ed Cavazos' +original factor.el code. + +Installation +------------ + +FUEL comes bundled with Factor's distribution. The folder misc/fuel +contains Elisp code, and there's a fuel vocabulary in extras/fuel. + +To install FUEL, either add this line to your Emacs initialisation: + + (load-file "/misc/fuel/fu.el") + +or + + (add-to-list load-path "/fuel") + (require 'fuel) + +If all you want is a major mode for editing Factor code with pretty +font colors and indentation, without running the factor listener +inside Emacs, you can use instead: + + (add-to-list load-path "/fuel") + (setq factor-mode-use-fuel nil) + (require 'factor-mode) + +Basic usage +----------- + +If you're using the default factor binary and images locations inside +the Factor's source tree, that should be enough to start using FUEL. +Editing any file with the extension .factor will put you in +factor-mode; try C-hm for a summary of available commands. + +To start the listener, try M-x run-factor. + +Many aspects of the environment can be customized: +M-x customize-group fuel will show you how many. + +Quick key reference +------------------- + + - C-cz : switch to listener + - C-co : cycle between code, tests and docs factor files + + - M-. : edit word at point in Emacs + + - C-cr, C-cC-er : eval region + - C-M-r, C-cC-ee : eval region, extending it to definition boundaries + - C-M-x, C-cC-ex : eval definition around point + + - C-cC-da : toggle autodoc mode + - C-cC-dd : help for word at point + - C-cC-ds : short help word at point + +Chords ending in a single letter accept also C- (e.g. C-cC-z is +the same as C-cz). diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el new file mode 100644 index 0000000000..d79930bb22 --- /dev/null +++ b/misc/fuel/factor-mode.el @@ -0,0 +1,239 @@ +;;; factor-mode.el -- mode for editing Factor source + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Tue Dec 02, 2008 21:32 + +;;; Comentary: + +;; Definition of factor-mode, a major Emacs for editing Factor source +;; code. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) +(require 'fuel-font-lock) + +(require 'ring) + + +;;; Customization: + +(defgroup factor-mode nil + "Major mode for Factor source code" + :group 'fuel) + +(defcustom factor-mode-use-fuel t + "Whether to use the full FUEL facilities in factor mode. + +Set this variable to nil if you just want to use Emacs as the +external editor of your Factor environment, e.g., by putting +these lines in your .emacs: + + (add-to-list 'load-path \"/path/to/factor/misc/fuel\") + (setq factor-mode-use-fuel nil) + (require 'factor-mode) +" + :type 'boolean + :group 'factor-mode) + +(defcustom factor-mode-default-indent-width 4 + "Default indentation width for factor-mode. + +This value will be used for the local variable +`factor-mode-indent-width' in new factor buffers. For existing +code, we first check if `factor-mode-indent-width' is set +explicitly in a local variable section or line (e.g. +'! -*- factor-mode-indent-witdth: 2 -*-'). If that's not the case, +`factor-mode' tries to infer its correct value from the existing +code in the buffer." + :type 'integer + :group 'fuel) + +(defcustom factor-mode-hook nil + "Hook run when entering Factor mode." + :type 'hook + :group 'factor-mode) + + +;;; Syntax table: + +(defun factor-mode--syntax-setup () + (set-syntax-table fuel-syntax--syntax-table) + (set (make-local-variable 'beginning-of-defun-function) + 'fuel-syntax--beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun) + (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil) + (fuel-syntax--enable-usings)) + + +;;; Indentation: + +(make-variable-buffer-local + (defvar factor-mode-indent-width factor-mode-default-indent-width + "Indentation width in factor buffers. A local variable.")) + +(defun factor-mode--guess-indent-width () + "Chooses an indentation value from existing code." + (let ((word-cont "^ +[^ ]") + (iw)) + (save-excursion + (beginning-of-buffer) + (while (not iw) + (if (not (re-search-forward fuel-syntax--definition-start-regex nil t)) + (setq iw factor-mode-default-indent-width) + (forward-line) + (when (looking-at word-cont) + (setq iw (current-indentation)))))) + iw)) + +(defun factor-mode--indent-in-brackets () + (save-excursion + (beginning-of-line) + (when (> (fuel-syntax--brackets-depth) 0) + (let ((op (fuel-syntax--brackets-start)) + (cl (fuel-syntax--brackets-end)) + (ln (line-number-at-pos))) + (when (> ln (line-number-at-pos op)) + (if (and (> cl 0) (= ln (line-number-at-pos cl))) + (fuel-syntax--indentation-at op) + (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op)))))))) + +(defun factor-mode--indent-definition () + (save-excursion + (beginning-of-line) + (when (fuel-syntax--at-begin-of-def) 0))) + +(defun factor-mode--indent-setter-line () + (when (fuel-syntax--at-setter-line) + (save-excursion + (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation)))) + (while (not (or indent + (bobp) + (fuel-syntax--at-begin-of-def) + (fuel-syntax--at-end-of-def))) + (if (fuel-syntax--at-constructor-line) + (setq indent (fuel-syntax--increased-indentation)) + (forward-line -1))) + indent)))) + +(defun factor-mode--indent-continuation () + (save-excursion + (forward-line -1) + (while (and (not (bobp)) + (fuel-syntax--looking-at-emptiness)) + (forward-line -1)) + (cond ((or (fuel-syntax--at-end-of-def) + (fuel-syntax--at-setter-line)) + (fuel-syntax--decreased-indentation)) + ((and (fuel-syntax--at-begin-of-def) + (not (fuel-syntax--at-using))) + (fuel-syntax--increased-indentation)) + (t (current-indentation))))) + +(defun factor-mode--calculate-indentation () + "Calculate Factor indentation for line at point." + (or (and (bobp) 0) + (factor-mode--indent-definition) + (factor-mode--indent-in-brackets) + (factor-mode--indent-setter-line) + (factor-mode--indent-continuation) + 0)) + +(defun factor-mode--indent-line () + "Indent current line as Factor code" + (let ((target (factor-mode--calculate-indentation)) + (pos (- (point-max) (point)))) + (if (= target (current-indentation)) + (if (< (current-column) (current-indentation)) + (back-to-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to target) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) + +(defun factor-mode--indentation-setup () + (set (make-local-variable 'indent-line-function) 'factor-mode--indent-line) + (setq factor-indent-width (factor-mode--guess-indent-width)) + (setq indent-tabs-mode nil)) + + +;;; Buffer cycling: + +(defconst factor-mode--cycle-endings + '(".factor" "-tests.factor" "-docs.factor")) + +(defconst factor-mode--regex-cycle-endings + (format "\\(.*?\\)\\(%s\\)$" + (regexp-opt factor-mode--cycle-endings))) + +(defconst factor-mode--cycle-endings-ring + (let ((ring (make-ring (length factor-mode--cycle-endings)))) + (dolist (e factor-mode--cycle-endings ring) + (ring-insert ring e)))) + +(defun factor-mode--cycle-next (file) + (let* ((match (string-match factor-mode--regex-cycle-endings file)) + (base (and match (match-string-no-properties 1 file))) + (ending (and match (match-string-no-properties 2 file))) + (idx (and ending (ring-member factor-mode--cycle-endings-ring ending))) + (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i))))) + (if (not idx) file + (let ((l (length factor-mode--cycle-endings)) (i 1) next) + (while (and (not next) (< i l)) + (when (file-exists-p (funcall gfl (+ idx i))) + (setq next (+ idx i))) + (setq i (1+ i))) + (funcall gfl (or next idx)))))) + +(defun factor-mode-visit-other-file (&optional file) + "Cycle between code, tests and docs factor files." + (interactive) + (find-file (factor-mode--cycle-next (or file (buffer-file-name))))) + + +;;; Keymap: + +(defun factor-mode-insert-and-indent (n) + (interactive "p") + (self-insert-command n) + (indent-for-tab-command)) + +(defvar factor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?\]] 'factor-mode-insert-and-indent) + (define-key map [?}] 'factor-mode-insert-and-indent) + (define-key map "\C-m" 'newline-and-indent) + (define-key map "\C-co" 'factor-mode-visit-other-file) + (define-key map "\C-c\C-o" 'factor-mode-visit-other-file) + map)) + +(defun factor-mode--keymap-setup () + (use-local-map factor-mode-map)) + + +;;; Factor mode: + +;;;###autoload +(defun factor-mode () + "A mode for editing programs written in the Factor programming language. +\\{factor-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'factor-mode) + (setq mode-name "Factor") + (fuel-font-lock--font-lock-setup) + (factor-mode--keymap-setup) + (factor-mode--indentation-setup) + (factor-mode--syntax-setup) + (when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode)) + (run-hooks 'factor-mode-hook)) + + +(provide 'factor-mode) +;;; factor-mode.el ends here diff --git a/misc/fuel/fu.el b/misc/fuel/fu.el new file mode 100644 index 0000000000..508d7ef3a4 --- /dev/null +++ b/misc/fuel/fu.el @@ -0,0 +1,26 @@ +;;; fu.el --- Startup file for FUEL + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Code: + +(add-to-list 'load-path (file-name-directory load-file-name)) + +(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) +(autoload 'factor-mode "factor-mode.el" + "Major mode for editing Factor source." t) + +(autoload 'run-factor "fuel-listener.el" + "Start a Factor listener, or switch to a running one." t) + +(autoload 'fuel-autodoc-mode "fuel-help.el" + "Minor mode showing in the minibuffer a synopsis of Factor word at point." + t) + + + +;;; fu.el ends here diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el new file mode 100644 index 0000000000..a62d16cb32 --- /dev/null +++ b/misc/fuel/fuel-base.el @@ -0,0 +1,63 @@ +;;; fuel-base.el --- Basic FUEL support code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Basic definitions likely to be used by all FUEL modules. + +;;; Code: + +(defconst fuel-version "1.0") + +;;;###autoload +(defsubst fuel-version () + "Echoes FUEL's version." + (interactive) + (message "FUEL %s" fuel-version)) + + +;;; Customization: + +;;;###autoload +(defgroup fuel nil + "Factor's Ultimate Emacs Library" + :group 'language) + + +;;; Emacs compatibility: + +(eval-after-load "ring" + '(when (not (fboundp 'ring-member)) + (defun ring-member (ring item) + (catch 'found + (dotimes (ind (ring-length ring) nil) + (when (equal item (ring-ref ring ind)) + (throw 'found ind))))))) + + +;;; Utilities + +(defun fuel--shorten-str (str len) + (let ((sl (length str))) + (if (<= sl len) str + (let* ((sep " ... ") + (sepl (length sep)) + (segl (/ (- len sepl) 2))) + (format "%s%s%s" + (substring str 0 segl) + sep + (substring str (- sl segl))))))) + +(defun fuel--shorten-region (begin end len) + (fuel--shorten-str (mapconcat 'identity + (split-string (buffer-substring begin end) nil t) + " ") + len)) + +(provide 'fuel-base) +;;; fuel-base.el ends here diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el new file mode 100644 index 0000000000..bef7171f6f --- /dev/null +++ b/misc/fuel/fuel-eval.el @@ -0,0 +1,112 @@ +;;; fuel-eval.el --- utilities for communication with fuel-listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages +;; Start date: Tue Dec 02, 2008 + +;;; Commentary: + +;; Protocols for handling communications via a comint buffer running a +;; factor listener. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) + + +;;; Syncronous string sending: + +(defvar fuel-eval-log-max-length 16000) + +(defvar fuel-eval--default-proc-function nil) +(defsubst fuel-eval--default-proc () + (and fuel-eval--default-proc-function + (funcall fuel-eval--default-proc-function))) + +(defvar fuel-eval--proc nil) +(defvar fuel-eval--log t) + +(defun fuel-eval--send-string (str) + (let ((proc (or fuel-eval--proc (fuel-eval--default-proc)))) + (when proc + (with-current-buffer (get-buffer-create "*factor messages*") + (goto-char (point-max)) + (when (and (> fuel-eval-log-max-length 0) + (> (point) fuel-eval-log-max-length)) + (erase-buffer)) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n")) + (let ((beg (point))) + (comint-redirect-send-command-to-process str (current-buffer) proc nil t) + (with-current-buffer (process-buffer proc) + (while (not comint-redirect-completed) (sleep-for 0 1))) + (goto-char beg) + (current-buffer)))))) + + +;;; Evaluation protocol + +(defsubst fuel-eval--retort-make (err result &optional output) + (list err result output)) + +(defsubst fuel-eval--retort-error (ret) (nth 0 ret)) +(defsubst fuel-eval--retort-result (ret) (nth 1 ret)) +(defsubst fuel-eval--retort-output (ret) (nth 2 ret)) + +(defsubst fuel-eval--retort-p (ret) (listp ret)) + +(defsubst fuel-eval--error-name (err) (car err)) + +(defsubst fuel-eval--make-parse-error-retort (str) + (fuel-eval--retort-make 'parse-retort-error nil str)) + +(defun fuel-eval--parse-retort (buffer) + (save-current-buffer + (set-buffer buffer) + (condition-case nil + (read (current-buffer)) + (error (fuel-eval--make-parse-error-retort + (buffer-substring-no-properties (point) (point-max))))))) + +(defsubst fuel-eval--send/retort (str) + (fuel-eval--parse-retort (fuel-eval--send-string str))) + +(defsubst fuel-eval--eval-begin () + (fuel-eval--send/retort "fuel-begin-eval")) + +(defsubst fuel-eval--eval-end () + (fuel-eval--send/retort "fuel-begin-eval")) + +(defsubst fuel-eval--factor-array (strs) + (format "V{ %S }" (mapconcat 'identity strs " "))) + +(defsubst fuel-eval--eval-strings (strs) + (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) + (fuel-eval--send/retort str))) + +(defsubst fuel-eval--eval-string (str) + (fuel-eval--eval-strings (list str))) + +(defun fuel-eval--eval-strings/context (strs) + (let ((usings (fuel-syntax--usings-update))) + (fuel-eval--send/retort + (format "%s %S %s fuel-eval-in-context" + (fuel-eval--factor-array strs) + (or fuel-syntax--current-vocab "f") + (if usings (fuel-eval--factor-array usings) "f"))))) + +(defsubst fuel-eval--eval-string/context (str) + (fuel-eval--eval-strings/context (list str))) + +(defun fuel-eval--eval-region/context (begin end) + (let ((lines (split-string (buffer-substring-no-properties begin end) + "[\f\n\r\v]+" t))) + (when (> (length lines) 0) + (fuel-eval--eval-strings/context lines)))) + + +(provide 'fuel-eval) +;;; fuel-eval.el ends here diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el new file mode 100644 index 0000000000..c8673f742b --- /dev/null +++ b/misc/fuel/fuel-font-lock.el @@ -0,0 +1,88 @@ +;;; fuel-font-lock.el -- font lock for factor code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Wed Dec 03, 2008 21:40 + +;;; Comentary: + +;; Font lock setup for highlighting Factor code. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) + +(require 'font-lock) + + +;;; Faces: + +(defmacro fuel-font-lock--face (face def doc) + (let ((face (intern (format "factor-font-lock-%s" (symbol-name face)))) + (def (intern (format "font-lock-%s-face" (symbol-name def))))) + `(defface ,face (face-default-spec ,def) + ,(format "Face for %s." doc) + :group 'factor-mode + :group 'faces))) + +(defmacro fuel-font-lock--faces-setup () + (cons 'progn + (mapcar (lambda (f) (cons 'fuel-font-lock--face f)) + '((comment comment "comments") + (constructor type "constructors ()") + (declaration keyword "declaration words") + (parsing-word keyword "parsing words") + (setter-word function-name "setter words (>>foo)") + (stack-effect comment "stack effect specifications") + (string string "strings") + (symbol variable-name "name of symbol being defined") + (type-name type "type names") + (vocabulary-name constant "vocabulary names") + (word function-name "word, generic or method being defined"))))) + +(fuel-font-lock--faces-setup) + + +;;; Font lock: + +(defconst fuel-font-lock--parsing-lock-keywords + (cons '("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) + (mapcar (lambda (w) `(,(format "\\(^\\| \\)\\(%s\\)\\($\\| \\)" w) + 2 'factor-font-lock-parsing-word)) + fuel-syntax--parsing-words))) + +(defconst fuel-font-lock--font-lock-keywords + `(,@fuel-font-lock--parsing-lock-keywords + (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) + (,fuel-syntax--parsing-words-ext-regex . 'factor-font-lock-parsing-word) + (,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration) + (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word) + (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name) + (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name) + (2 'factor-font-lock-word)) + (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type) + (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor) + (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word) + (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol) + (,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name)) + "Font lock keywords definition for Factor mode.") + +(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax) + (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment) + (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string) + (set (make-local-variable 'font-lock-defaults) + `(,(or keywords 'fuel-font-lock--font-lock-keywords) + nil nil nil nil + ,@(if no-syntax nil + (list (cons 'font-lock-syntactic-keywords + fuel-syntax--syntactic-keywords)))))) + + +(provide 'fuel-font-lock) +;;; fuel-font-lock.el ends here diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el new file mode 100644 index 0000000000..dcf17d2716 --- /dev/null +++ b/misc/fuel/fuel-help.el @@ -0,0 +1,208 @@ +;;; fuel-help.el -- accessing Factor's help system + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Wed Dec 03, 2008 21:41 + +;;; Comentary: + +;; Modes and functions interfacing Factor's 'see' and 'help' +;; utilities, as well as an ElDoc-based autodoc mode. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-font-lock) +(require 'fuel-eval) + + +;;; Customization: + +(defgroup fuel-help nil + "Options controlling FUEL's help system" + :group 'fuel) + +(defcustom fuel-help-minibuffer-font-lock t + "Whether to use font lock for info messages in the minibuffer." + :group 'fuel-help + :type 'boolean) + +(defcustom fuel-help-always-ask t + "When enabled, always ask for confirmation in help prompts." + :type 'boolean + :group 'fuel-help) + +(defcustom fuel-help-use-minibuffer t + "When enabled, use the minibuffer for short help messages." + :type 'boolean + :group 'fuel-help) + +(defcustom fuel-help-mode-hook nil + "Hook run by `factor-help-mode'." + :type 'hook + :group 'fuel-help) + +(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold))) + "Face for headlines in help buffers." + :group 'fuel-help + :group 'faces) + + +;;; Autodoc mode: + +(defvar fuel-help--font-lock-buffer + (let ((buffer (get-buffer-create " *fuel help minibuffer messages*"))) + (set-buffer buffer) + (fuel-font-lock--font-lock-setup) + buffer)) + +(defun fuel-help--font-lock-str (str) + (set-buffer fuel-help--font-lock-buffer) + (erase-buffer) + (insert str) + (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) + (buffer-string)) + +(defun fuel-help--word-synopsis (&optional word) + (let ((word (or word (fuel-syntax-symbol-at-point))) + (fuel-eval--log nil)) + (when word + (let ((ret (fuel-eval--eval-string/context + (format "\\ %s synopsis fuel-eval-set-result" word)))) + (when (not (fuel-eval--retort-error ret)) + (if fuel-help-minibuffer-font-lock + (fuel-help--font-lock-str (fuel-eval--retort-result ret)) + (fuel-eval--retort-result ret))))))) + +(make-variable-buffer-local + (defvar fuel-autodoc-mode-string " A" + "Modeline indicator for fuel-autodoc-mode")) + +(define-minor-mode fuel-autodoc-mode + "Toggle Fuel's Autodoc mode. +With no argument, this command toggles the mode. +Non-null prefix argument turns on the mode. +Null prefix argument turns off the mode. + +When Autodoc mode is enabled, a synopsis of the word at point is +displayed in the minibuffer." + :init-value nil + :lighter fuel-autodoc-mode-string + :group 'fuel + + (set (make-local-variable 'eldoc-documentation-function) + (when fuel-autodoc-mode 'fuel-help--word-synopsis)) + (set (make-local-variable 'eldoc-minor-mode-string) nil) + (eldoc-mode fuel-autodoc-mode) + (message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled"))) + + +;;;; Factor help mode: + +(defvar fuel-help-mode-map (make-sparse-keymap) + "Keymap for Factor help mode.") + +(define-key fuel-help-mode-map [(return)] 'fuel-help) + +(defconst fuel-help--headlines + (regexp-opt '("Class description" + "Definition" + "Examples" + "Generic word contract" + "Inputs and outputs" + "Methods" + "Notes" + "Parent topics:" + "See also" + "Syntax" + "Vocabulary" + "Warning" + "Word description") + t)) + +(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines)) + +(defconst fuel-help--font-lock-keywords + `(,@fuel-font-lock--font-lock-keywords + (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines))) + +(defun fuel-help-mode () + "Major mode for displaying Factor documentation. +\\{fuel-help-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map fuel-help-mode-map) + (setq mode-name "Factor Help") + (setq major-mode 'fuel-help-mode) + + (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t) + + (set (make-local-variable 'view-no-disable-on-exit) t) + (view-mode) + (setq view-exit-action + (lambda (buffer) + ;; Use `with-current-buffer' to make sure that `bury-buffer' + ;; also removes BUFFER from the selected window. + (with-current-buffer buffer + (bury-buffer)))) + + (setq fuel-autodoc-mode-string "") + (fuel-autodoc-mode) + (run-mode-hooks 'fuel-help-mode-hook)) + +(defun fuel-help--help-buffer () + (with-current-buffer (get-buffer-create "*fuel-help*") + (fuel-help-mode) + (current-buffer))) + +(defvar fuel-help--history nil) + +(defun fuel-help--show-help (&optional see) + (let* ((def (fuel-syntax-symbol-at-point)) + (prompt (format "See%s help on%s: " (if see " short" "") + (if def (format " (%s)" def) ""))) + (ask (or (not (memq major-mode '(factor-mode fuel-help-mode))) + (not def) + fuel-help-always-ask)) + (def (if ask (read-string prompt nil 'fuel-help--history def) def)) + (cmd (format "\\ %s %s" def (if see "see" "help"))) + (fuel-eval--log nil) + (ret (fuel-eval--eval-string/context cmd)) + (out (fuel-eval--retort-output ret))) + (if (or (fuel-eval--retort-error ret) (empty-string-p out)) + (message "No help for '%s'" def) + (let ((hb (fuel-help--help-buffer)) + (inhibit-read-only t) + (font-lock-verbose nil)) + (set-buffer hb) + (erase-buffer) + (insert out) + (set-buffer-modified-p nil) + (pop-to-buffer hb) + (goto-char (point-min)))))) + + +;;; Interface: see/help commands + +(defun fuel-help-short (&optional arg) + "See a help summary of symbol at point. +By default, the information is shown in the minibuffer. When +called with a prefix argument, the information is displayed in a +separate help buffer." + (interactive "P") + (if (if fuel-help-use-minibuffer (not arg) arg) + (fuel-help--word-synopsis) + (fuel-help--show-help t))) + +(defun fuel-help () + "Show extended help about the symbol at point, using a help +buffer." + (interactive) + (fuel-help--show-help)) + + +(provide 'fuel-help) +;;; fuel-help.el ends here diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el new file mode 100644 index 0000000000..c741a77a5d --- /dev/null +++ b/misc/fuel/fuel-listener.el @@ -0,0 +1,124 @@ +;;; fuel-listener.el --- starting the fuel listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Utilities to maintain and switch to a factor listener comint +;; buffer, with an accompanying major fuel-listener-mode. + +;;; Code: + +(require 'fuel-eval) +(require 'fuel-base) +(require 'comint) + + +;;; Customization: + +(defgroup fuel-listener nil + "Interacting with a Factor listener inside Emacs" + :group 'fuel) + +(defcustom fuel-listener-factor-binary "~/factor/factor" + "Full path to the factor executable to use when starting a listener." + :type '(file :must-match t) + :group 'fuel-listener) + +(defcustom fuel-listener-factor-image "~/factor/factor.image" + "Full path to the factor image to use when starting a listener." + :type '(file :must-match t) + :group 'fuel-listener) + +(defcustom fuel-listener-use-other-window t + "Use a window other than the current buffer's when switching to +the factor-listener buffer." + :type 'boolean + :group 'fuel-listener) + +(defcustom fuel-listener-window-allow-split t + "Allow window splitting when switching to the fuel listener +buffer." + :type 'boolean + :group 'fuel-listener) + + +;;; Fuel listener buffer/process: + +(defvar fuel-listener-buffer nil + "The buffer in which the Factor listener is running.") + +(defun fuel-listener--start-process () + (let ((factor (expand-file-name fuel-listener-factor-binary)) + (image (expand-file-name fuel-listener-factor-image))) + (unless (file-executable-p factor) + (error "Could not run factor: %s is not executable" factor)) + (unless (file-readable-p image) + (error "Could not run factor: image file %s not readable" image)) + (setq fuel-listener-buffer + (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image))) + (with-current-buffer fuel-listener-buffer + (fuel-listener-mode)))) + +(defun fuel-listener--process (&optional start) + (or (and (buffer-live-p fuel-listener-buffer) + (get-buffer-process fuel-listener-buffer)) + (if (not start) + (error "No running factor listener (try M-x run-factor)") + (fuel-listener--start-process) + (fuel-listener--process)))) + +(setq fuel-eval--default-proc-function 'fuel-listener--process) + + +;;; Interface: starting fuel listener + +(defalias 'switch-to-factor 'run-factor) +(defalias 'switch-to-fuel-listener 'run-factor) +;;;###autoload +(defun run-factor (&optional arg) + "Show the fuel-listener buffer, starting the process if needed." + (interactive) + (let ((buf (process-buffer (fuel-listener--process t))) + (pop-up-windows fuel-listener-window-allow-split)) + (if fuel-listener-use-other-window + (pop-to-buffer buf) + (switch-to-buffer buf)))) + + +;;; Fuel listener mode: + +(defconst fuel-listener--prompt-regex "( [^)]* ) ") + +(defun fuel-listener--wait-for-prompt (&optional timeout) + (let ((proc (fuel-listener--process))) + (with-current-buffer fuel-listener-buffer + (goto-char comint-last-input-end) + (while (not (or (re-search-forward comint-prompt-regexp nil t) + (not (accept-process-output proc timeout)))) + (goto-char comint-last-input-end)) + (goto-char (point-max))))) + +(defun fuel-listener--startup () + (fuel-listener--wait-for-prompt) + (fuel-eval--send-string "USE: fuel") + (message "FUEL listener up and running!")) + +(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener" + "Major mode for interacting with an inferior Factor listener process. +\\{fuel-listener-mode-map}" + (set (make-local-variable 'comint-prompt-regexp) + fuel-listener--prompt-regex) + (set (make-local-variable 'comint-prompt-read-only) t) + (fuel-listener--startup)) + +;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region) +;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line) + + +(provide 'fuel-listener) +;;; fuel-listener.el ends here diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el new file mode 100644 index 0000000000..bd9b127c7d --- /dev/null +++ b/misc/fuel/fuel-mode.el @@ -0,0 +1,148 @@ +;;; fuel-mode.el -- Minor mode enabling FUEL niceties + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sat Dec 06, 2008 00:52 + +;;; Comentary: + +;; Enhancements to vanilla factor-mode (notably, listener interaction) +;; enabled by means of a minor mode. + +;;; Code: + +(require 'factor-mode) +(require 'fuel-base) +(require 'fuel-syntax) +(require 'fuel-font-lock) +(require 'fuel-help) +(require 'fuel-eval) +(require 'fuel-listener) + + +;;; Customization: + +(defgroup fuel-mode nil + "Mode enabling FUEL's ultimate abilities." + :group 'fuel) + +(defcustom fuel-mode-autodoc-p t + "Whether `fuel-autodoc-mode' gets enable by default in fuel buffers." + :group 'fuel-mode + :type 'boolean) + + +;;; User commands + +(defun fuel-eval-region (begin end &optional arg) + "Sends region to Fuel's listener for evaluation. +With prefix, switchs to the listener's buffer afterwards." + (interactive "r\nP") + (let* ((ret (fuel-eval--eval-region/context begin end)) + (err (fuel-eval--retort-error ret))) + (message "%s" (or err (fuel--shorten-region begin end 70)))) + (when arg (pop-to-buffer fuel-listener-buffer))) + +(defun fuel-eval-extended-region (begin end &optional arg) + "Sends region extended outwards to nearest definitions, +to Fuel's listener for evaluation. With prefix, switchs to the +listener's buffer afterwards." + (interactive "r\nP") + (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point)) + (save-excursion (goto-char end) (mark-defun) (mark)))) + +(defun fuel-eval-definition (&optional arg) + "Sends definition around point to Fuel's listener for evaluation. +With prefix, switchs to the listener's buffer afterwards." + (interactive "P") + (save-excursion + (mark-defun) + (let* ((begin (point)) + (end (mark))) + (unless (< begin end) (error "No evaluable definition around point")) + (fuel-eval-region begin end)))) + +(defun fuel-edit-word-at-point (&optional arg) + "Opens a new window visiting the definition of the word at point. +With prefix, asks for the word to edit." + (interactive "P") + (let* ((word (fuel-syntax-symbol-at-point)) + (ask (or arg (not word))) + (word (if ask + (read-string nil + (format "Edit word%s: " + (if word (format " (%s)" word) "")) + word) + word))) + (let* ((ret (fuel-eval--eval-string/context + (format "\\ %s fuel-get-edit-location" word))) + (err (fuel-eval--retort-error ret)) + (loc (fuel-eval--retort-result ret))) + (when (or err (not loc) (not (listp loc)) (not (stringp (car loc)))) + (error "Couldn't find edit location for '%s'" word)) + (unless (file-readable-p (car loc)) + (error "Couldn't open '%s' for read" (car loc))) + (find-file-other-window (car loc)) + (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))) + + +;;; Minor mode definition: + +(make-variable-buffer-local + (defvar fuel-mode-string " F" + "Modeline indicator for fuel-mode")) + +(defvar fuel-mode-map (make-sparse-keymap) + "Key map for fuel-mode") + +(define-minor-mode fuel-mode + "Toggle Fuel's mode. +With no argument, this command toggles the mode. +Non-null prefix argument turns on the mode. +Null prefix argument turns off the mode. + +When Fuel mode is enabled, a host of nice utilities for +interacting with a factor listener is at your disposal. +\\{fuel-mode-map}" + :init-value nil + :lighter fuel-mode-string + :group 'fuel + :keymap fuel-mode-map + + (setq fuel-autodoc-mode-string "/A") + (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))) + + +;;; Keys: + +(defun fuel-mode--key-1 (k c) + (define-key fuel-mode-map (vector '(control ?c) k) c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,k)) c)) + +(defun fuel-mode--key (p k c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c)) + +(fuel-mode--key-1 ?z 'run-factor) + +(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) +(fuel-mode--key ?e ?x 'fuel-eval-definition) + +(fuel-mode--key-1 ?r 'fuel-eval-region) +(fuel-mode--key ?e ?r 'fuel-eval-region) + +(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region) +(fuel-mode--key ?e ?e 'fuel-eval-extended-region) + +(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point) + +(fuel-mode--key ?d ?a 'fuel-autodoc-mode) +(fuel-mode--key ?d ?d 'fuel-help) +(fuel-mode--key ?d ?s 'fuel-help-short) + + +(provide 'fuel-mode) +;;; fuel-mode.el ends here diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el new file mode 100644 index 0000000000..a0485f9183 --- /dev/null +++ b/misc/fuel/fuel-syntax.el @@ -0,0 +1,281 @@ +;;; fuel-syntax.el --- auxiliar definitions for factor code navigation. + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Auxiliar constants and functions to parse factor code. + +;;; Code: + +(require 'thingatpt) + + +;;; Thing-at-point support for factor symbols: + +(defun fuel-syntax--beginning-of-symbol () + "Move point to the beginning of the current symbol." + (while (eq (char-before) ?:) (backward-char)) + (skip-syntax-backward "w_")) + +(defun fuel-syntax--end-of-symbol () + "Move point to the end of the current symbol." + (skip-syntax-forward "w_") + (while (looking-at ":") (forward-char))) + +(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol) +(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol) + +(defsubst fuel-syntax-symbol-at-point () + (let ((s (substring-no-properties (thing-at-point 'factor-symbol)))) + (and (> (length s) 0) s))) + + +;;; Regexps galore: + +(defconst fuel-syntax--parsing-words + '("{" "}" "^:" "^::" ";" "<<" ">" + "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" + "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" + "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" + "IN:" "INSTANCE:" "INTERSECTION:" + "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" + "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" + "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" + "TUPLE:" "T{" "t\\??" "TYPEDEF:" + "UNION:" "USE:" "USING:" "V{" "VARS:" "W{")) + +(defconst fuel-syntax--parsing-words-ext-regex + (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only") + 'words)) + +(defconst fuel-syntax--declaration-words + '("flushable" "foldable" "inline" "parsing" "recursive")) + +(defconst fuel-syntax--declaration-words-regex + (regexp-opt fuel-syntax--declaration-words 'words)) + +(defsubst fuel-syntax--second-word-regex (prefixes) + (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) + +(defconst fuel-syntax--method-definition-regex + "^M: +\\([^ ]+\\) +\\([^ ]+\\)") + +(defconst fuel-syntax--word-definition-regex + (fuel-syntax--second-word-regex '(":" "::" "GENERIC:"))) + +(defconst fuel-syntax--type-definition-regex + (fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:"))) + +(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)") + +(defconst fuel-syntax--constructor-regex "<[^ >]+>") + +(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b") + +(defconst fuel-syntax--symbol-definition-regex + (fuel-syntax--second-word-regex '("SYMBOL:" "VAR:"))) + +(defconst fuel-syntax--stack-effect-regex " ( .* )") + +(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);") + +(defconst fuel-syntax--use-line-regex "^USE: +\\(.*\\)$") + +(defconst fuel-syntax--current-vocab-regex "^IN: +\\([^ \r\n\f]+\\)") + +(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") + +(defconst fuel-syntax--definition-starters-regex + (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" ""))) + +(defconst fuel-syntax--definition-start-regex + (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex)) + +(defconst fuel-syntax--definition-end-regex + (format "\\(\\(^\\| +\\);\\( +%s\\)*\\($\\| +\\)\\)" + fuel-syntax--declaration-words-regex)) + +(defconst fuel-syntax--single-liner-regex + (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" + "PRIVATE>" "" table) + + ;; Parenthesis + (modify-syntax-entry ?\[ "(] " table) + (modify-syntax-entry ?\] ")[ " table) + (modify-syntax-entry ?{ "(} " table) + (modify-syntax-entry ?} "){ " table) + + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + + ;; Strings + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?\\ "/" table) + table) + "Syntax table used while in Factor mode.") + +(defconst fuel-syntax--syntactic-keywords + `(("\\(#!\\)" (1 "<")) + (" \\(!\\)" (1 "<")) + ("^\\(!\\)" (1 "<")) + ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) + ("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_")) + ("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_")))) + + +;;; Source code analysis: + +(defsubst fuel-syntax--brackets-depth () + (nth 0 (syntax-ppss))) + +(defsubst fuel-syntax--brackets-start () + (nth 1 (syntax-ppss))) + +(defun fuel-syntax--brackets-end () + (save-excursion + (goto-char (fuel-syntax--brackets-start)) + (condition-case nil + (progn (forward-sexp) + (1- (point))) + (error -1)))) + +(defsubst fuel-syntax--indentation-at (pos) + (save-excursion (goto-char pos) (current-indentation))) + +(defsubst fuel-syntax--increased-indentation (&optional i) + (+ (or i (current-indentation)) factor-indent-width)) +(defsubst fuel-syntax--decreased-indentation (&optional i) + (- (or i (current-indentation)) factor-indent-width)) + +(defsubst fuel-syntax--at-begin-of-def () + (looking-at fuel-syntax--begin-of-def-regex)) + +(defsubst fuel-syntax--at-end-of-def () + (looking-at fuel-syntax--end-of-def-regex)) + +(defsubst fuel-syntax--looking-at-emptiness () + (looking-at "^[ \t]*$")) + +(defun fuel-syntax--at-setter-line () + (save-excursion + (beginning-of-line) + (if (not (fuel-syntax--looking-at-emptiness)) + (re-search-forward fuel-syntax--setter-regex (line-end-position) t) + (forward-line -1) + (or (fuel-syntax--at-constructor-line) + (fuel-syntax--at-setter-line))))) + +(defun fuel-syntax--at-constructor-line () + (save-excursion + (beginning-of-line) + (re-search-forward fuel-syntax--constructor-regex (line-end-position) t))) + +(defsubst fuel-syntax--at-using () + (looking-at fuel-syntax--using-lines-regex)) + +(defsubst fuel-syntax--beginning-of-defun (&optional times) + (re-search-backward fuel-syntax--begin-of-def-regex nil t times)) + +(defsubst fuel-syntax--end-of-defun () + (re-search-forward fuel-syntax--end-of-def-regex nil t)) + + +;;; USING/IN: + +(make-variable-buffer-local + (defvar fuel-syntax--current-vocab nil)) + +(make-variable-buffer-local + (defvar fuel-syntax--usings nil)) + +(defun fuel-syntax--current-vocab () + (let ((ip + (save-excursion + (when (re-search-backward fuel-syntax--current-vocab-regex nil t) + (setq fuel-syntax--current-vocab (match-string-no-properties 1)) + (point))))) + (when ip + (let ((pp (save-excursion + (when (re-search-backward fuel-syntax--sub-vocab-regex ip t) + (point))))) + (when (and pp (> pp ip)) + (let ((sub (match-string-no-properties 1))) + (unless (save-excursion (search-backward (format "%s>" sub) pp t)) + (setq fuel-syntax--current-vocab + (format "%s.%s" fuel-syntax--current-vocab (downcase sub))))))))) + fuel-syntax--current-vocab) + +(defun fuel-syntax--usings-update () + (save-excursion + (setq fuel-syntax--usings (list (fuel-syntax--current-vocab))) + (while (re-search-backward fuel-syntax--using-lines-regex nil t) + (dolist (u (split-string (match-string-no-properties 1) nil t)) + (push u fuel-syntax--usings))) + fuel-syntax--usings)) + +(defsubst fuel-syntax--usings-update-hook () + (fuel-syntax--usings-update) + nil) + +(defun fuel-syntax--enable-usings () + (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t) + (fuel-syntax--usings-update)) + +(defsubst fuel-syntax--usings () + (or fuel-syntax--usings (fuel-syntax--usings-update))) + + +(provide 'fuel-syntax) +;;; fuel-syntax.el ends here 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/primitives.c b/vm/primitives.c index 135d5478ea..a01a8653b7 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -105,7 +105,8 @@ void *primitives[] = { primitive_alien_address, primitive_set_slot, primitive_string_nth, - primitive_set_string_nth, + primitive_set_string_nth_fast, + primitive_set_string_nth_slow, primitive_resize_array, primitive_resize_string, primitive_array, diff --git a/vm/types.c b/vm/types.c index d6e78013cb..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); @@ -328,43 +318,62 @@ void primitive_tuple_boa(void) /* Strings */ CELL string_nth(F_STRING* string, CELL index) { + /* If high bit is set, the most significant 16 bits of the char + come from the aux vector. The least significant bit of the + corresponding aux vector entry is negated, so that we can + XOR the two components together and get the original code point + back. */ CELL ch = bget(SREF(string,index)); - if(string->aux == F) + if((ch & 0x80) == 0) return ch; else { F_BYTE_ARRAY *aux = untag_object(string->aux); - return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch; + return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch; } } -/* allocates memory */ -void set_string_nth(F_STRING* string, CELL index, CELL value) +void set_string_nth_fast(F_STRING* string, CELL index, CELL ch) { - bput(SREF(string,index),value & 0xff); + bput(SREF(string,index),ch); +} +void set_string_nth_slow(F_STRING* string, CELL index, CELL ch) +{ F_BYTE_ARRAY *aux; + bput(SREF(string,index),(ch & 0x7f) | 0x80); + if(string->aux == F) { - if(value <= 0xff) - return; - else - { - REGISTER_UNTAGGED(string); - aux = allot_byte_array( - untag_fixnum_fast(string->length) - * sizeof(u16)); - UNREGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(string); + /* We don't need to pre-initialize the + byte array with any data, since we + only ever read from the aux vector + if the most significant bit of a + character is set. Initially all of + the bits are clear. */ + aux = allot_byte_array_internal( + untag_fixnum_fast(string->length) + * sizeof(u16)); + UNREGISTER_UNTAGGED(string); - write_barrier((CELL)string); - string->aux = tag_object(aux); - } + write_barrier((CELL)string); + string->aux = tag_object(aux); } else aux = untag_object(string->aux); - cput(BREF(aux,index * sizeof(u16)),value >> 8); + cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1); +} + +/* allocates memory */ +void set_string_nth(F_STRING* string, CELL index, CELL ch) +{ + if(ch <= 0x7f) + set_string_nth_fast(string,index,ch); + else + set_string_nth_slow(string,index,ch); } /* untagged */ @@ -382,17 +391,8 @@ F_STRING* allot_string_internal(CELL capacity) /* allocates memory */ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { - if(fill == 0) - { - memset((void *)SREF(string,start),'\0',capacity - start); - - if(string->aux != F) - { - F_BYTE_ARRAY *aux = untag_object(string->aux); - memset((void *)BREF(aux,start * sizeof(u16)),'\0', - (capacity - start) * sizeof(u16)); - } - } + if(fill <= 0x7f) + memset((void *)SREF(string,start),fill,capacity - start); else { CELL i; @@ -423,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) @@ -452,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); @@ -463,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 */ @@ -572,3 +572,19 @@ void primitive_set_string_nth(void) CELL value = untag_fixnum_fast(dpop()); set_string_nth(string,index,value); } + +void primitive_set_string_nth_fast(void) +{ + F_STRING *string = untag_object(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth_fast(string,index,value); +} + +void primitive_set_string_nth_slow(void) +{ + F_STRING *string = untag_object(dpop()); + CELL index = untag_fixnum_fast(dpop()); + CELL value = untag_fixnum_fast(dpop()); + set_string_nth_slow(string,index,value); +} diff --git a/vm/types.h b/vm/types.h index 47747547db..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); @@ -152,7 +152,8 @@ CELL string_nth(F_STRING* string, CELL index); void set_string_nth(F_STRING* string, CELL index, CELL value); void primitive_string_nth(void); -void primitive_set_string_nth(void); +void primitive_set_string_nth_slow(void); +void primitive_set_string_nth_fast(void); F_WORD *allot_word(CELL vocab, CELL name); void primitive_word(void); @@ -176,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) \