diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index cf60d40bf6..e3e5338820 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -5,10 +5,10 @@ math.order ; IN: calendar HELP: duration -{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ; +{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ; { timestamp duration } related-words @@ -135,35 +135,37 @@ HELP: instant HELP: years { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of years." } ; HELP: months { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of months." } ; HELP: days { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of days." } ; HELP: weeks { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of weeks." } ; HELP: hours { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of hours." } ; HELP: minutes { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of minutes." } ; HELP: seconds { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of seconds." } ; HELP: milliseconds { $values { "x" number } { "duration" duration } } -{ $description } ; +{ $description "Creates a duration object with the specified number of milliseconds." } ; + +{ years months days hours minutes seconds milliseconds } related-words HELP: leap-year? { $values { "obj" object } { "?" "a boolean" } } @@ -193,75 +195,75 @@ HELP: time+ } } ; -HELP: dt>years +HELP: duration>years { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in years." } { $examples { $example "USING: calendar prettyprint ;" - "6 months dt>years ." + "6 months duration>years ." "1/2" } } ; -HELP: dt>months +HELP: duration>months { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in months." } { $examples { $example "USING: calendar prettyprint ;" - "30 days dt>months ." + "30 days duration>months ." "16000/16233" } } ; -HELP: dt>days +HELP: duration>days { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in days." } { $examples { $example "USING: calendar prettyprint ;" - "6 hours dt>days ." + "6 hours duration>days ." "1/4" } } ; -HELP: dt>hours +HELP: duration>hours { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in hours." } { $examples { $example "USING: calendar prettyprint ;" - "3/4 days dt>hours ." + "3/4 days duration>hours ." "18" } } ; -HELP: dt>minutes +HELP: duration>minutes { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in minutes." } { $examples { $example "USING: calendar prettyprint ;" - "6 hours dt>minutes ." + "6 hours duration>minutes ." "360" } } ; -HELP: dt>seconds +HELP: duration>seconds { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in seconds." } { $examples { $example "USING: calendar prettyprint ;" - "6 minutes dt>seconds ." + "6 minutes duration>seconds ." "360" } } ; -HELP: dt>milliseconds +HELP: duration>milliseconds { $values { "duration" duration } { "x" number } } { $description "Calculates the length of a duration in milliseconds." } { $examples { $example "USING: calendar prettyprint ;" - "6 seconds dt>milliseconds ." + "6 seconds duration>milliseconds ." "6000" } } ; -{ dt>years dt>months dt>days dt>hours dt>minutes dt>seconds dt>milliseconds } related-words +{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words HELP: time- @@ -428,16 +430,6 @@ HELP: day-of-year } } ; -HELP: day-this-week -{ $values { "timestamp" timestamp } { "n" integer } { "timestamp" timestamp } } -{ $description "Implementation word to calculate the day of the week relative to the timestamp. Sunday is the first day of the week, so the resulting " { $snippet "timestamp" } " will be Sunday or after, and before Saturday." } -{ $examples - { $example "USING: calendar kernel prettyprint ;" - "now 0 day-this-week now sunday = ." - "t" - } -} ; - HELP: sunday { $values { "timestamp" timestamp } { "new-timestamp" timestamp } } { $description "Returns the Sunday from the current week, which starts on a Sunday." } ; @@ -491,3 +483,124 @@ HELP: beginning-of-year HELP: time-since-midnight { $values { "timestamp" timestamp } { "duration" duration } } { $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ; + +ARTICLE: "calendar" "Calendar" +"The two data types used throughout the calendar library:" +{ $subsection timestamp } +{ $subsection duration } +"Durations represent spans of time:" +{ $subsection "using-durations" } +"Arithmetic on timestamps and durations:" +{ $subsection "timestamp-arithmetic" } +"Getting the current timestamp:" +{ $subsection now } +{ $subsection gmt } +"Converting between timestamps:" +{ $subsection >local-time } +{ $subsection >gmt } +"Converting between timezones:" +{ $subsection convert-timezone } +"Timestamps relative to each other:" +{ $subsection "relative-timestamps" } +"Operations on units of time:" +{ $subsection "years" } +{ $subsection "months" } +{ $subsection "days" } +"Meta-data about the calendar:" +{ $subsection "calendar-facts" } +; + +ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic" +"Adding timestamps and durations, or durations and durations:" +{ $subsection time+ } +"Subtracting:" +{ $subsection time- } +"Element-wise multiplication:" +{ $subsection time* } ; + +ARTICLE: "using-durations" "Using durations" +"Creating a duration object:" +{ $subsection years } +{ $subsection months } +{ $subsection weeks } +{ $subsection days } +{ $subsection hours } +{ $subsection minutes } +{ $subsection seconds } +{ $subsection milliseconds } +{ $subsection instant } +"Converting a duration to a number:" +{ $subsection duration>years } +{ $subsection duration>months } +{ $subsection duration>days } +{ $subsection duration>hours } +{ $subsection duration>minutes } +{ $subsection duration>seconds } +{ $subsection duration>milliseconds } ; + +ARTICLE: "relative-timestamps" "Relative timestamps" +"In the future:" +{ $subsection hence } +"In the past:" +{ $subsection ago } +"Invert a duration:" +{ $subsection before } +"Days of the week relative to " { $link now } ":" +{ $subsection sunday } +{ $subsection monday } +{ $subsection tuesday } +{ $subsection wednesday } +{ $subsection thursday } +{ $subsection friday } +{ $subsection saturday } +"New timestamps relative to calendar events:" +{ $subsection beginning-of-year } +{ $subsection beginning-of-month } +{ $subsection beginning-of-week } +{ $subsection midnight } +{ $subsection noon } +; + +ARTICLE: "days" "Day operations" +"Naming days:" +{ $subsection day-abbreviation2 } +{ $subsection day-abbreviations2 } +{ $subsection day-abbreviation3 } +{ $subsection day-abbreviations3 } +{ $subsection day-name } +{ $subsection day-names } +"Calculating a Julian day number:" +{ $subsection julian-day-number } +"Calculate a timestamp:" +{ $subsection julian-day-number>date } +; + +ARTICLE: "calendar-facts" "Calendar facts" +"Calendar facts:" +{ $subsection average-month } +{ $subsection months-per-year } +{ $subsection days-per-year } +{ $subsection hours-per-year } +{ $subsection minutes-per-year } +{ $subsection seconds-per-year } +{ $subsection days-in-month } +{ $subsection day-of-year } +{ $subsection day-of-week } +; + +ARTICLE: "years" "Year operations" +"Leap year predicate:" +{ $subsection leap-year? } +"Find the number of days in a year:" +{ $subsection days-in-year } +; + +ARTICLE: "months" "Month operations" +"Naming months:" +{ $subsection month-name } +{ $subsection month-names } +{ $subsection month-abbreviation } +{ $subsection month-abbreviations } +; + +ABOUT: "calendar" diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 7d9716ae1a..995bd23c09 100755 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -33,8 +33,8 @@ IN: calendar.tests [ t ] [ 2006 10 10 0 0 0 instant 10 minutes time+ 2006 10 10 0 10 0 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ - 2006 10 10 0 10 30 instant = ] unit-test +[ +eq+ ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ + 2006 10 10 0 10 30 instant <=> ] unit-test [ t ] [ 2006 10 10 0 0 0 instant 3/4 minutes time+ 2006 10 10 0 0 45 instant = ] unit-test [ t ] [ 2006 10 10 0 0 0 instant -3/4 minutes time+ diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 096546349d..c2c386a790 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -240,7 +240,7 @@ M: duration time+ 2drop ] if ; -: dt>years ( duration -- x ) +: duration>years ( duration -- x ) #! Uses average month/year length since duration loses calendar #! data 0 swap @@ -253,14 +253,14 @@ M: duration time+ [ second>> seconds-per-year / + ] } cleave ; -M: duration <=> [ dt>years ] compare ; +M: duration <=> [ duration>years ] compare ; -: dt>months ( duration -- x ) dt>years months-per-year * ; -: dt>days ( duration -- x ) dt>years days-per-year * ; -: dt>hours ( duration -- x ) dt>years hours-per-year * ; -: dt>minutes ( duration -- x ) dt>years minutes-per-year * ; -: dt>seconds ( duration -- x ) dt>years seconds-per-year * ; -: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ; +: duration>months ( duration -- x ) duration>years months-per-year * ; +: duration>days ( duration -- x ) duration>years days-per-year * ; +: duration>hours ( duration -- x ) duration>years hours-per-year * ; +: duration>minutes ( duration -- x ) duration>years minutes-per-year * ; +: duration>seconds ( duration -- x ) duration>years seconds-per-year * ; +: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ; GENERIC: time- ( time1 time2 -- time3 ) @@ -364,11 +364,13 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; : day-of-year ( timestamp -- n ) >date< (day-of-year) ; + : sunday ( timestamp -- new-timestamp ) 0 day-this-week ; : monday ( timestamp -- new-timestamp ) 1 day-this-week ; diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 3efe33e265..c433a118c2 100755 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -3,23 +3,23 @@ io.streams.string accessors io math.order ; IN: calendar.format.tests [ 0 ] [ - "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ 1 ] [ - "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ -1 ] [ - "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ -1-1/2 ] [ - "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ 1+1/2 ] [ - "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ ] [ now timestamp>rfc3339 drop ] unit-test @@ -58,7 +58,7 @@ IN: calendar.format.tests 26 0 37 - 42.12345 + 42+2469/20000 T{ duration f 0 0 0 -5 0 0 } } ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index c9cfc83d27..9c1878e14d 100755 --- a/basis/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -4,7 +4,7 @@ ! Remote Channels USING: kernel init namespaces assocs arrays random sequences channels match concurrency.messaging -concurrency.distributed threads ; +concurrency.distributed threads accessors ; IN: channels.remote remote-channel M: remote-channel to ( value remote-channel -- ) - [ [ \ to , remote-channel-id , , ] { } make ] keep - remote-channel-node "remote-channels" + [ [ \ to , id>> , , ] { } make ] keep + node>> "remote-channels" send-synchronous no-channel = [ no-channel throw ] when ; M: remote-channel from ( remote-channel -- value ) - [ [ \ from , remote-channel-id , ] { } make ] keep - remote-channel-node "remote-channels" + [ [ \ from , id>> , ] { } make ] keep + node>> "remote-channels" send-synchronous dup no-channel = [ no-channel throw ] when* ; [ diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index 4b56d81626..e1d6672872 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -20,10 +20,10 @@ CLASS: { test-foo -[ 1 ] [ "x" get NSRect-x ] unit-test -[ 2 ] [ "x" get NSRect-y ] unit-test -[ 101 ] [ "x" get NSRect-w ] unit-test -[ 102 ] [ "x" get NSRect-h ] unit-test +[ 1.0 ] [ "x" get NSRect-x ] unit-test +[ 2.0 ] [ "x" get NSRect-y ] unit-test +[ 101.0 ] [ "x" get NSRect-w ] unit-test +[ 102.0 ] [ "x" get NSRect-h ] unit-test CLASS: { { +superclass+ "NSObject" } @@ -41,7 +41,7 @@ Bar [ -> release ] compile-call -[ 1 ] [ "x" get NSRect-x ] unit-test -[ 2 ] [ "x" get NSRect-y ] unit-test -[ 101 ] [ "x" get NSRect-w ] unit-test -[ 102 ] [ "x" get NSRect-h ] unit-test +[ 1.0 ] [ "x" get NSRect-x ] unit-test +[ 2.0 ] [ "x" get NSRect-y ] unit-test +[ 101.0 ] [ "x" get NSRect-w ] unit-test +[ 102.0 ] [ "x" get NSRect-h ] unit-test diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 418aac6560..1f941a0f88 100755 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -27,7 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler" "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." { $subsection "compiler-usage" } { $subsection "compiler-errors" } -{ $subsection "optimizer" } +{ $subsection "hints" } { $subsection "generator" } ; ABOUT: "compiler" diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index f2a2255949..18f7f67787 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -109,7 +109,7 @@ unit-test << "f-stdcall" f "stdcall" add-library >> [ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test +[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test : ffi_test_18 ( w x y z -- int ) "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 9f42ad201f..4c39da0479 100755 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -210,10 +210,10 @@ USE: binary-search.private : old-binsearch ( elt quot seq -- elt quot i ) dup length 1 <= [ - slice-from + from>> ] [ [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] + [ drop dup from>> swap midpoint@ + ] [ dup midpoint@ cut-slice old-binsearch ] if ] if ; inline diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index 1085feb0c6..c6cbb79ce5 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -1,10 +1,10 @@ IN: compiler.tests USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private -words splitting grouping sorting ; +words splitting grouping sorting accessors ; : symbolic-stack-trace ( -- newseq ) - error-continuation get continuation-call callstack>array + error-continuation get call>> callstack>array 2 group flip first ; : foo ( -- * ) 3 throw 7 ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 8072a4229e..bb30cda685 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -229,10 +229,6 @@ M: float detect-float ; \ detect-float inlined? ] unit-test -[ t ] [ - [ 3 + = ] \ equal? inlined? -] unit-test - [ f ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] \ fixnum-shift-fast inlined? diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 08734ec095..f08116b936 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,7 +1,15 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences -compiler.tree compiler.tree.combinators ; +USING: kernel accessors sequences words namespaces +classes.builtin +compiler.tree +compiler.tree.builder +compiler.tree.normalization +compiler.tree.propagation +compiler.tree.cleanup +compiler.tree.def-use +compiler.tree.dead-code +compiler.tree.combinators ; IN: compiler.tree.finalization GENERIC: finalize* ( node -- nodes ) @@ -13,6 +21,25 @@ M: #shuffle finalize* [ in>> ] [ out>> ] bi sequence= [ drop f ] when ; +: builtin-predicate? ( word -- ? ) + "predicating" word-prop builtin-class? ; + +: splice-quot ( quot -- nodes ) + [ + build-tree + normalize + propagate + cleanup + compute-def-use + remove-dead-code + but-last + ] with-scope ; + +M: #call finalize* + dup word>> builtin-predicate? [ + word>> def>> splice-quot + ] when ; + M: node finalize* ; : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 2281c140a4..d0f418f3c9 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -59,10 +59,38 @@ slots ; : ( -- info ) \ value-info new ; +: read-only-slots ( values class -- slots ) + #! Delegation. + all-slots rest-slice + [ read-only>> [ drop f ] unless ] 2map + { f f } prepend ; + +DEFER: + +: init-literal-info ( info -- info ) + #! Delegation. + dup literal>> class >>class + dup literal>> dup real? [ [a,a] >>interval ] [ + [ [-inf,inf] >>interval ] dip + { + { [ dup complex? ] [ + [ real-part ] + [ imaginary-part ] bi + 2array >>slots + ] } + { [ dup tuple? ] [ + [ + tuple-slots rest-slice + [ ] map + ] [ class ] bi read-only-slots >>slots + ] } + [ drop ] + } cond + ] if ; inline + : init-value-info ( info -- info ) dup literal?>> [ - dup literal>> class >>class - dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval + init-literal-info ] [ dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [ null >>class @@ -73,7 +101,7 @@ slots ; dup [ class>> ] [ interval>> ] bi interval>literal [ >>literal ] [ >>literal? ] bi* ] if - ] if ; + ] if ; inline : ( class interval -- info ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index c07c5a5cb5..4d3d2c781c 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -211,7 +211,7 @@ generic-comparison-ops [ \ eq? [ [ info-intervals-intersect? ] [ info-classes-intersect? ] - 2bi or maybe-or-never + 2bi and maybe-or-never ] "outputs" set-word-prop { diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 503c633077..f04460f32a 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] final-classes ] unit-test +[ V{ integer array } ] [ + [ + [ 2drop T{ mixed-mutable-immutable f 3 { } } ] + [ { array } declare mixed-mutable-immutable boa ] if + [ x>> ] [ y>> ] bi + ] final-classes +] unit-test + ! Recursive propagation : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive @@ -573,6 +581,18 @@ MIXIN: empty-mixin [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test +[ V{ float } ] [ + [ + [ { float float } declare ] + [ 2drop C{ 0.0 0.0 } ] + if real-part + ] final-classes +] unit-test + +[ V{ POSTPONE: f } ] [ + [ { float } declare 0 eq? ] final-classes +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 5e3480be2f..a4bd48ecc0 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -31,12 +31,6 @@ UNION: fixed-length-sequence array byte-array string ; : tuple-constructor? ( word -- ? ) { } memq? ; -: read-only-slots ( values class -- slots ) - #! Delegation. - all-slots rest-slice - [ read-only>> [ drop f ] unless ] 2map - { f f } prepend ; - : fold- ( values class -- info ) [ , f , [ literal>> ] map % ] { } make >tuple ; diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index 4da079e812..5e2f1bb6d1 100755 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -37,7 +37,7 @@ M: remote-process send ( message thread -- ) send-remote-message ; M: thread (serialize) ( obj -- ) - thread-id local-node get-global + id>> local-node get-global (serialize) ; : stop-node ( node -- ) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 00bdb4b7c9..0aee836cf1 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -18,13 +18,13 @@ IN: cpu.ppc.architecture : ds-reg 14 ; inline : rs-reg 15 ; inline -: reserved-area-size +: reserved-area-size ( -- n ) os { { linux [ 2 ] } { macosx [ 6 ] } } case cells ; foldable -: lr-save +: lr-save ( -- n ) os { { linux [ 1 ] } { macosx [ 2 ] } @@ -32,12 +32,12 @@ IN: cpu.ppc.architecture : param@ ( n -- x ) reserved-area-size + ; inline -: param-save-size 8 cells ; foldable +: param-save-size ( -- n ) 8 cells ; foldable : local@ ( n -- x ) reserved-area-size param-save-size + + ; inline -: factor-area-size 2 cells ; +: factor-area-size ( -- n ) 2 cells ; foldable : next-save ( n -- i ) cell - ; @@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- ) 1 1 rot ADDI 0 MTLR ; -: (%call) 11 MTLR BLRL ; +: (%call) ( -- ) 11 MTLR BLRL ; -: (%jump) 11 MTCTR BCTR ; +: (%jump) ( -- ) 11 MTCTR BCTR ; : %load-dlsym ( symbol dll register -- ) 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; @@ -218,7 +218,7 @@ M: ppc %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: temp@ stack-frame* factor-area-size - swap - ; +: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ; : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index 6413cf839c..191baf1e0a 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/basis/cpu/ppc/intrinsics/intrinsics.factor @@ -11,17 +11,17 @@ math.floats.private classes slots.private combinators compiler.constants ; IN: cpu.ppc.intrinsics -: %slot-literal-known-tag +: %slot-literal-known-tag ( -- out value offset ) "val" operand "obj" operand "n" get cells "obj" get operand-tag - ; -: %slot-literal-any-tag +: %slot-literal-any-tag ( -- out value offset ) "obj" operand "scratch1" operand %untag "val" operand "scratch1" operand "n" get cells ; -: %slot-any +: %slot-any ( -- out value offset ) "obj" operand "scratch1" operand %untag "offset" operand "n" operand 1 SRAWI "scratch1" operand "val" operand "offset" operand ; @@ -188,7 +188,7 @@ IN: cpu.ppc.intrinsics } } define-intrinsics -: generate-fixnum-mod +: generate-fixnum-mod ( -- ) #! PowerPC doesn't have a MOD instruction; so we compute #! x-(x/y)*y. Puts the result in "s" operand. "s" operand "r" operand "y" operand MULLW @@ -259,7 +259,7 @@ IN: cpu.ppc.intrinsics \ fixnum+ \ ADD \ ADDO. overflow-template \ fixnum- \ SUBF \ SUBFO. overflow-template -: generate-fixnum/i +: generate-fixnum/i ( -- ) #! This VOP is funny. If there is an overflow, it falls #! through to the end, and the result is in "x" operand. #! Otherwise it jumps to the "no-overflow" label and the @@ -514,8 +514,8 @@ IN: cpu.ppc.intrinsics ! Alien intrinsics : %alien-accessor ( quot -- ) "offset" operand dup %untag-fixnum - "offset" operand dup "alien" operand ADD - "value" operand "offset" operand 0 roll call ; inline + "scratch" operand "offset" operand "alien" operand ADD + "value" operand "scratch" operand 0 roll call ; inline : alien-integer-get-template H{ @@ -539,6 +539,7 @@ IN: cpu.ppc.intrinsics { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } + { +scratch+ { { f "scratch" } } } { +clobber+ { "value" "offset" } } } ; diff --git a/extra/db/authors.txt b/basis/db/authors.txt similarity index 100% rename from extra/db/authors.txt rename to basis/db/authors.txt diff --git a/extra/db/db-tests.factor b/basis/db/db-tests.factor similarity index 96% rename from extra/db/db-tests.factor rename to basis/db/db-tests.factor index 0d95e3aea7..3f1dab2c37 100755 --- a/extra/db/db-tests.factor +++ b/basis/db/db-tests.factor @@ -1,5 +1,5 @@ -IN: db.tests USING: tools.test db kernel ; +IN: db.tests { 1 0 } [ [ drop ] query-each ] must-infer-as { 1 1 } [ [ ] query-map ] must-infer-as diff --git a/extra/db/db.factor b/basis/db/db.factor similarity index 86% rename from extra/db/db.factor rename to basis/db/db.factor index c52d1db148..c269341240 100755 --- a/extra/db/db.factor +++ b/basis/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations destructors kernel math namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors combinators.lib ; +tools.walker accessors combinators.lib combinators ; IN: db TUPLE: db @@ -15,24 +15,25 @@ TUPLE: db new H{ } clone >>insert-statements H{ } clone >>update-statements - H{ } clone >>delete-statements ; + H{ } clone >>delete-statements ; inline -GENERIC: make-db* ( seq class -- db ) +GENERIC: make-db* ( seq db -- db ) -: make-db ( seq class -- db ) - new-db make-db* ; +: make-db ( seq class -- db ) new-db make-db* ; GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) : dispose-statements ( assoc -- ) values dispose-each ; -: dispose-db ( db -- ) +: db-dispose ( db -- ) dup db [ - dup insert-statements>> dispose-statements - dup update-statements>> dispose-statements - dup delete-statements>> dispose-statements - handle>> db-close + { + [ insert-statements>> dispose-statements ] + [ update-statements>> dispose-statements ] + [ delete-statements>> dispose-statements ] + [ handle>> db-close ] + } cleave ] with-variable ; TUPLE: statement handle sql in-params out-params bind-params bound? type retries ; @@ -47,8 +48,8 @@ TUPLE: result-set sql in-params out-params handle n max ; swap >>in-params swap >>sql ; -HOOK: db ( str in out -- statement ) -HOOK: db ( str in out -- statement ) +HOOK: db ( string in out -- statement ) +HOOK: db ( string in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( statement -- ) GENERIC: low-level-bind ( statement -- ) diff --git a/extra/db/errors/errors.factor b/basis/db/errors/errors.factor similarity index 99% rename from extra/db/errors/errors.factor rename to basis/db/errors/errors.factor index 1e0d1e7fb4..da6301639f 100644 --- a/extra/db/errors/errors.factor +++ b/basis/db/errors/errors.factor @@ -6,6 +6,5 @@ IN: db.errors ERROR: db-error ; ERROR: sql-error ; - ERROR: table-exists ; ERROR: bad-schema ; diff --git a/extra/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor similarity index 100% rename from extra/db/pools/pools-tests.factor rename to basis/db/pools/pools-tests.factor diff --git a/extra/db/pools/pools.factor b/basis/db/pools/pools.factor similarity index 100% rename from extra/db/pools/pools.factor rename to basis/db/pools/pools.factor diff --git a/extra/db/postgresql/authors.txt b/basis/db/postgresql/authors.txt similarity index 100% rename from extra/db/postgresql/authors.txt rename to basis/db/postgresql/authors.txt diff --git a/extra/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor similarity index 100% rename from extra/db/postgresql/ffi/ffi.factor rename to basis/db/postgresql/ffi/ffi.factor diff --git a/extra/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor similarity index 100% rename from extra/db/postgresql/lib/lib.factor rename to basis/db/postgresql/lib/lib.factor diff --git a/extra/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor similarity index 100% rename from extra/db/postgresql/postgresql-tests.factor rename to basis/db/postgresql/postgresql-tests.factor diff --git a/extra/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor similarity index 99% rename from extra/db/postgresql/postgresql.factor rename to basis/db/postgresql/postgresql.factor index e57efbc360..692241fab0 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -16,7 +16,7 @@ TUPLE: postgresql-statement < statement ; TUPLE: postgresql-result-set < result-set ; -M: postgresql-db make-db* ( seq tuple -- db ) +M: postgresql-db make-db* ( seq db -- db ) >r first4 r> swap >>db swap >>pass diff --git a/extra/db/queries/queries.factor b/basis/db/queries/queries.factor similarity index 97% rename from extra/db/queries/queries.factor rename to basis/db/queries/queries.factor index 3a751a9736..e5334703f6 100644 --- a/extra/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -43,13 +43,6 @@ M: random-id-generator eval-generator ( singleton -- obj ) : interval-comparison ( ? str -- str ) "from" = " >" " <" ? swap [ "= " append ] when ; -: fp-infinity? ( float -- ? ) - dup float? [ - double>bits -52 shift 11 2^ 1- [ bitand ] keep = - ] [ - drop f - ] if ; - : (infinite-interval?) ( interval -- ?1 ?2 ) [ from>> ] [ to>> ] bi [ first fp-infinity? ] bi@ ; diff --git a/extra/db/sql/sql-tests.factor b/basis/db/sql/sql-tests.factor similarity index 100% rename from extra/db/sql/sql-tests.factor rename to basis/db/sql/sql-tests.factor diff --git a/extra/db/sql/sql.factor b/basis/db/sql/sql.factor similarity index 100% rename from extra/db/sql/sql.factor rename to basis/db/sql/sql.factor diff --git a/extra/db/sqlite/authors.txt b/basis/db/sqlite/authors.txt similarity index 100% rename from extra/db/sqlite/authors.txt rename to basis/db/sqlite/authors.txt diff --git a/extra/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor similarity index 98% rename from extra/db/sqlite/ffi/ffi.factor rename to basis/db/sqlite/ffi/ffi.factor index b443f53e78..9f033a1d3c 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -118,6 +118,7 @@ FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +! Bind the same function as above, but for unsigned 64bit integers : sqlite3-bind-uint64 ( pStmt index in64 -- int ) "int" "sqlite" "sqlite3_bind_int64" { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; @@ -131,6 +132,7 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +! Bind the same function as above, but for unsigned 64bit integers : sqlite3-column-uint64 ( pStmt col -- uint64 ) "sqlite3_uint64" "sqlite" "sqlite3_column_int64" { "sqlite3_stmt*" "int" } alien-invoke ; diff --git a/extra/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor similarity index 100% rename from extra/db/sqlite/lib/lib.factor rename to basis/db/sqlite/lib/lib.factor diff --git a/extra/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor similarity index 99% rename from extra/db/sqlite/sqlite-tests.factor rename to basis/db/sqlite/sqlite-tests.factor index b30cb4ba80..67eac2702b 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -57,8 +57,7 @@ IN: db.sqlite.tests ] with-db ] unit-test -[ -] [ +[ ] [ test.db [ [ "insert into person(name, country) values('Jose', 'Mexico')" diff --git a/extra/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor similarity index 97% rename from extra/db/sqlite/sqlite.factor rename to basis/db/sqlite/sqlite.factor index 794ff5bacd..49d79b1b8c 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -19,7 +19,7 @@ M: sqlite-db db-open ( db -- db ) dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; -M: sqlite-db dispose ( db -- ) dispose-db ; +M: sqlite-db dispose ( db -- ) db-dispose ; TUPLE: sqlite-statement < statement ; @@ -52,12 +52,12 @@ M: sqlite-result-set dispose ( result-set -- ) handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ; M: sqlite-statement low-level-bind ( statement -- ) - [ statement-bind-params ] [ statement-handle ] bi + [ bind-params>> ] [ handle>> ] bi [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ; M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare - dup statement-bound? [ dup reset-bindings ] when + dup bound?>> [ dup reset-bindings ] when low-level-bind ; GENERIC: sqlite-bind-conversion ( tuple obj -- array ) diff --git a/extra/db/sqlite/test.txt b/basis/db/sqlite/test.txt similarity index 100% rename from extra/db/sqlite/test.txt rename to basis/db/sqlite/test.txt diff --git a/extra/db/summary.txt b/basis/db/summary.txt similarity index 100% rename from extra/db/summary.txt rename to basis/db/summary.txt diff --git a/extra/db/tags.txt b/basis/db/tags.txt similarity index 100% rename from extra/db/tags.txt rename to basis/db/tags.txt diff --git a/extra/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor similarity index 99% rename from extra/db/tuples/tuples-tests.factor rename to basis/db/tuples/tuples-tests.factor index f5b74b51c8..5dd3ec8ae0 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -41,9 +41,9 @@ SYMBOL: person4 [ ] [ person1 get insert-tuple ] unit-test - [ 1 ] [ person1 get person-the-id ] unit-test + [ 1 ] [ person1 get the-id>> ] unit-test - [ ] [ 200 person1 get set-person-the-number ] unit-test + [ ] [ person1 get 200 >>the-number drop ] unit-test [ ] [ person1 get update-tuple ] unit-test diff --git a/extra/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor similarity index 100% rename from extra/db/tuples/tuples.factor rename to basis/db/tuples/tuples.factor diff --git a/extra/db/types/types.factor b/basis/db/types/types.factor similarity index 89% rename from extra/db/types/types.factor rename to basis/db/types/types.factor index c3480093c5..2efa41c401 100755 --- a/extra/db/types/types.factor +++ b/basis/db/types/types.factor @@ -8,7 +8,7 @@ classes.singleton accessors quotations random ; IN: db.types HOOK: persistent-table db ( -- hash ) -HOOK: compound db ( str obj -- hash ) +HOOK: compound db ( string obj -- hash ) TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; @@ -78,7 +78,7 @@ FACTOR-BLOB NULL URL ; swap >>class dup normalize-spec ; -: number>string* ( n/str -- str ) +: number>string* ( n/string -- string ) dup number? [ number>string ] when ; : remove-db-assigned-id ( specs -- obj ) @@ -97,7 +97,7 @@ FACTOR-BLOB NULL URL ; ERROR: unknown-modifier ; -: lookup-modifier ( obj -- str ) +: lookup-modifier ( obj -- string ) { { [ dup array? ] [ unclip lookup-modifier swap compound ] } [ persistent-table at* [ unknown-modifier ] unless third ] @@ -105,43 +105,43 @@ ERROR: unknown-modifier ; ERROR: no-sql-type ; -: (lookup-type) ( obj -- str ) +: (lookup-type) ( obj -- string ) persistent-table at* [ no-sql-type ] unless ; -: lookup-type ( obj -- str ) +: lookup-type ( obj -- string ) dup array? [ unclip (lookup-type) first nip ] [ (lookup-type) first ] if ; -: lookup-create-type ( obj -- str ) +: lookup-create-type ( obj -- string ) dup array? [ unclip (lookup-type) second swap compound ] [ (lookup-type) second ] if ; -: single-quote ( str -- newstr ) +: single-quote ( string -- new-string ) "'" swap "'" 3append ; -: double-quote ( str -- newstr ) +: double-quote ( string -- new-string ) "\"" swap "\"" 3append ; -: paren ( str -- newstr ) +: paren ( string -- new-string ) "(" swap ")" 3append ; -: join-space ( str1 str2 -- newstr ) +: join-space ( string1 string2 -- new-string ) " " swap 3append ; -: modifiers ( spec -- str ) +: modifiers ( spec -- string ) modifiers>> [ lookup-modifier ] map " " join dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) -: offset-of-slot ( str obj -- n ) +: offset-of-slot ( string obj -- n ) class superclasses [ "slots" word-prop ] map concat slot-named offset>> ; diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 72463caf26..f8897712e7 100755 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -1,7 +1,7 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system debugger.private -io.files.private listener ; +help generic.standard continuations system io.files.private +listener ; IN: debugger ARTICLE: "debugger" "The debugger" @@ -22,8 +22,6 @@ ARTICLE: "debugger" "The debugger" { $subsection :2 } { $subsection :3 } { $subsection :res } -"Assertions:" -{ $subsection "errors-assert" } "You can read more about error handling in " { $link "errors" } "." ; ABOUT: "debugger" diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 09a90121bd..d1e7d31656 100755 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -15,7 +15,7 @@ GENERIC# whoa 1 ( s t -- w ) PROTOCOL: baz foo { bar 0 } { whoa 1 } ; : hello-test ( hello/goodbye -- array ) - [ hello? ] [ hello-this ] [ hello-that ] tri 3array ; + [ hello? ] [ this>> ] [ that>> ] tri 3array ; CONSULT: baz goodbye these>> ; M: hello foo this>> ; @@ -34,8 +34,8 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 2 whoa ] unit-test -[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test -[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test +[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test +[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test diff --git a/basis/float-vectors/float-vectors-tests.factor b/basis/float-vectors/float-vectors-tests.factor index 383dd4bcf2..1483b269e0 100755 --- a/basis/float-vectors/float-vectors-tests.factor +++ b/basis/float-vectors/float-vectors-tests.factor @@ -1,10 +1,10 @@ +USING: tools.test float-vectors vectors sequences kernel math ; IN: float-vectors.tests -USING: tools.test float-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test : do-it - 12345 [ over push ] each ; + 12345 [ >float over push ] each ; [ t ] [ 3 do-it diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 2c894c3812..1b8bcccce7 100755 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -1,6 +1,6 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files -assocs namespaces words io sequences eval ; +assocs namespaces words io sequences eval accessors ; IN: help.definitions.tests [ ] [ \ + >link see ] unit-test @@ -10,7 +10,7 @@ IN: help.definitions.tests "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop - "foo" source-file source-file-definitions first assoc-size + "foo" source-file definitions>> first assoc-size ] unit-test [ t ] [ "hello" articles get key? ] unit-test @@ -23,7 +23,7 @@ IN: help.definitions.tests "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop - "foo" source-file source-file-definitions first assoc-size + "foo" source-file definitions>> first assoc-size ] unit-test [ t ] [ "hello" articles get key? ] unit-test diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index d329fa5d42..47cc2987d7 100755 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -399,5 +399,5 @@ HELP: ABOUT: { $description "Defines the main documentation article for the current vocabulary." } ; HELP: vocab-help -{ $values { "vocab" "a vocabulary specifier" } { "help" "a help article" } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "help" "a help article" } } { $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT: } "." } ; diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 6b138a18ab..222c4e7d3f 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -1,13 +1,13 @@ USING: definitions help help.markup kernel sequences tools.test -words parser namespaces assocs generic io.streams.string ; +words parser namespaces assocs generic io.streams.string accessors ; IN: help.markup.tests TUPLE: blahblah quux ; [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test -[ ] [ \ blahblah-quux help ] unit-test -[ ] [ \ set-blahblah-quux help ] unit-test +[ ] [ \ quux>> help ] unit-test +[ ] [ \ >>quux help ] unit-test [ ] [ \ blahblah? help ] unit-test : fooey "fooey" throw ; diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor index 68306263a5..e7438edd4d 100755 --- a/basis/help/syntax/syntax-tests.factor +++ b/basis/help/syntax/syntax-tests.factor @@ -1,5 +1,6 @@ +USING: kernel tools.test parser vocabs help.syntax namespaces +eval accessors ; IN: help.syntax.tests -USING: tools.test parser vocabs help.syntax namespaces eval ; [ [ "foobar" ] [ @@ -12,5 +13,5 @@ USING: tools.test parser vocabs help.syntax namespaces eval ; "help.syntax.tests" vocab vocab-help ] unit-test - [ ] [ f "help.syntax.tests" vocab set-vocab-help ] unit-test + [ ] [ "help.syntax.tests" vocab f >>help drop ] unit-test ] with-file-vocabs diff --git a/basis/help/topics/topics-docs.factor b/basis/help/topics/topics-docs.factor index f2f3e8e82f..08195ee07d 100644 --- a/basis/help/topics/topics-docs.factor +++ b/basis/help/topics/topics-docs.factor @@ -1,5 +1,6 @@ -USING: help.markup help.syntax help.topics help.crossref help io -io.styles hashtables ; +USING: help.markup help.syntax help.crossref help io io.styles +hashtables strings ; +IN: help.topics HELP: articles { $var-description "Hashtable mapping article names to " { $link article } " instances." } ; @@ -14,11 +15,11 @@ HELP: article { $description "Outputs a named " { $link article } " object." } ; HELP: article-title -{ $values { "article" "an article name or a word" } { "title" "a string" } } +{ $values { "topic" "an article name or a word" } { "string" string } } { $description "Outputs the title of a specific help article." } ; HELP: article-content -{ $values { "article" "an article name or a word" } { "content" "a markup element" } } +{ $values { "topic" "an article name or a word" } { "content" "a markup element" } } { $description "Outputs the content of a specific help article." } ; HELP: all-articles diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index e6ca1ff26b..99c4a2ddfc 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -12,7 +12,6 @@ $nl $nl "Type hints are declared with a parsing word:" { $subsection POSTPONE: HINTS: } -$nl "The specialized version of a word which will be compiled by the compiler can be inspected:" { $subsection specialized-def } ; diff --git a/basis/io/encodings/ascii/ascii-docs.factor b/basis/io/encodings/ascii/ascii-docs.factor index 9c9c3a5234..fa496a3526 100644 --- a/basis/io/encodings/ascii/ascii-docs.factor +++ b/basis/io/encodings/ascii/ascii-docs.factor @@ -2,5 +2,10 @@ USING: help.markup help.syntax ; IN: io.encodings.ascii HELP: ascii -{ $class-description "This is the encoding descriptor which denotes an ASCII encoding. By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." } -{ $see-also "encodings-introduction" } ; +{ $class-description "ASCII encoding descriptor." } ; + +ARTICLE: "ascii" "ASCII encoding" +"By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." +{ $subsection ascii } ; + +ABOUT: "ascii" diff --git a/basis/io/encodings/utf16/utf16-docs.factor b/basis/io/encodings/utf16/utf16-docs.factor index f37a9d1d58..dc499b5ed4 100644 --- a/basis/io/encodings/utf16/utf16-docs.factor +++ b/basis/io/encodings/utf16/utf16-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax io.encodings strings ; IN: io.encodings.utf16 -ARTICLE: "io.encodings.utf16" "UTF-16" +ARTICLE: "io.encodings.utf16" "UTF-16 encoding" "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" { $subsection utf16 } { $subsection utf16le } diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 9968014993..0e49ca86ec 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -72,8 +72,8 @@ M: inet4 sockaddr-type drop "sockaddr-in" c-type ; M: inet4 make-sockaddr ( inet -- sockaddr ) "sockaddr-in" AF_INET over set-sockaddr-in-family - over inet4-port htons over set-sockaddr-in-port - over inet4-host + over port>> htons over set-sockaddr-in-port + over host>> "0.0.0.0" or rot inet-pton *uint over set-sockaddr-in-addr ; @@ -134,8 +134,8 @@ M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; M: inet6 make-sockaddr ( inet -- sockaddr ) "sockaddr-in6" AF_INET6 over set-sockaddr-in6-family - over inet6-port htons over set-sockaddr-in6-port - over inet6-host "::" or + over port>> htons over set-sockaddr-in6-port + over host>> "::" or rot inet-pton over set-sockaddr-in6-addr ; M: inet6 parse-sockaddr diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index ed9b53675b..eabd044bb4 100755 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -151,13 +151,13 @@ M: windows kill-process* ( handle -- ) swap win32-error=0/f ; : process-exited ( process -- ) - dup process-handle exit-code - over process-handle dispose-process + dup handle>> exit-code + over handle>> dispose-process notify-exit ; M: windows wait-for-processes ( -- ? ) processes get keys dup - [ process-handle PROCESS_INFORMATION-hProcess ] map + [ handle>> PROCESS_INFORMATION-hProcess ] map dup length swap >c-void*-array 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index d723d55cb3..bed3a655b1 100755 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -2,18 +2,24 @@ USING: help.markup help.syntax math math.private math.functions math.complex.private ; IN: math.complex +ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers" +"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:" +{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" } +"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:" +{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" } +"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ; + ARTICLE: "complex-numbers" "Complex numbers" { $subsection complex } "Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "syntax-complex-numbers" } "." $nl -"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." -$nl "Complex numbers can be taken apart:" { $subsection real-part } { $subsection imaginary-part } { $subsection >rect } "Complex numbers can be constructed from real numbers:" { $subsection rect> } +{ $subsection "complex-numbers-zero" } { $see-also "syntax-complex-numbers" } ; HELP: complex { $class-description "The class of complex numbers with non-zero imaginary part." } ; diff --git a/basis/math/complex/complex-tests.factor b/basis/math/complex/complex-tests.factor index 063871ce5b..4b0481eca1 100755 --- a/basis/math/complex/complex-tests.factor +++ b/basis/math/complex/complex-tests.factor @@ -5,9 +5,14 @@ IN: math.complex.tests [ 1 C{ 0 1 } rect> ] must-fail [ C{ 0 1 } 1 rect> ] must-fail -[ f ] [ C{ 5 12.5 } 5 = ] unit-test -[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test -[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test +[ f ] [ C{ 5 12.5 } 5 = ] unit-test +[ f ] [ C{ 5 12.5 } 5 number= ] unit-test + +[ f ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test +[ t ] [ C{ 1.0 2.0 } C{ 1 2 } number= ] unit-test + +[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test +[ f ] [ C{ 1.0 2.3 } C{ 1 2 } number= ] unit-test [ C{ 2 5 } ] [ 2 5 rect> ] unit-test [ 2 5 ] [ C{ 2 5 } >rect ] unit-test @@ -30,7 +35,7 @@ IN: math.complex.tests [ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test [ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test -[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test +[ C{ 0.0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test [ -1 ] [ C{ 0 1 } C{ 0 1 } * ] unit-test [ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test [ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test @@ -45,18 +50,18 @@ IN: math.complex.tests [ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test -[ 5 ] [ C{ 3 4 } abs ] unit-test -[ 5 ] [ -5.0 abs ] unit-test +[ 5.0 ] [ C{ 3 4 } abs ] unit-test +[ 5.0 ] [ -5.0 abs ] unit-test ! Make sure arguments are sane -[ 0 ] [ 0 arg ] unit-test -[ 0 ] [ 1 arg ] unit-test +[ 0.0 ] [ 0 arg ] unit-test +[ 0.0 ] [ 1 arg ] unit-test [ t ] [ -1 arg 3.14 3.15 between? ] unit-test [ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test [ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test -[ 1 0 ] [ 1 >polar ] unit-test -[ 1 ] [ -1 >polar drop ] unit-test +[ 1.0 0.0 ] [ 1 >polar ] unit-test +[ 1.0 ] [ -1 >polar drop ] unit-test [ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test ! I broke something diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index cef0676d12..ff5c0feb78 100755 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -17,6 +17,14 @@ M: complex absq >rect [ sq ] bi@ + ; [ [ real-part ] bi@ ] 2keep [ imaginary-part ] bi@ ; inline +M: complex hashcode* + nip >rect [ hashcode ] bi@ bitxor ; + +M: complex equal? + over complex? [ + 2>rect = [ = ] [ 2drop f ] if + ] [ 2drop f ] if ; + M: complex number= 2>rect number= [ number= ] [ 2drop f ] if ; @@ -36,8 +44,6 @@ M: complex abs absq >float fsqrt ; M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ; -M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ; - IN: syntax : C{ \ } [ first2 rect> ] parse-literal ; parsing diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index c023258105..bbfd8f41be 100755 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -106,7 +106,7 @@ HELP: (rect>) HELP: rect> { $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } ; +{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ; HELP: >rect { $values { "z" number } { "x" real } { "y" real } } diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index f2d26e330d..d5bdac761f 100755 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -12,10 +12,11 @@ IN: math.functions.tests [ 0.25 ] [ 2.0 -2.0 fpow ] unit-test [ 4.0 ] [ 16 sqrt ] unit-test -[ C{ 0 4.0 } ] [ -16 sqrt ] unit-test +[ 2.0 ] [ 4.0 0.5 ^ ] unit-test +[ C{ 0.0 4.0 } ] [ -16 sqrt ] unit-test -[ 4.0 ] [ 2 2 ^ ] unit-test -[ 0.25 ] [ 2 -2 ^ ] unit-test +[ 4 ] [ 2 2 ^ ] unit-test +[ 1/4 ] [ 2 -2 ^ ] unit-test [ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test [ t ] [ e pi i* ^ real-part -1.0 = ] unit-test [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test @@ -27,6 +28,8 @@ IN: math.functions.tests [ 0 ] [ 0 3.0 ^ ] unit-test [ 0 ] [ 0 3 ^ ] unit-test +[ 0.0 ] [ 1 log ] unit-test + [ 1.0 ] [ 0 cosh ] unit-test [ 0.0 ] [ 1 acosh ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 4d71b25174..8516292e9d 100755 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -7,7 +7,7 @@ IN: math.functions ) ( x y -- z ) - dup zero? [ drop ] [ ] if ; inline + dup 0 = [ drop ] [ ] if ; inline PRIVATE> @@ -24,29 +24,57 @@ M: real sqrt >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; : each-bit ( n quot: ( ? -- ) -- ) - over 0 number= pick -1 number= or [ + over 0 = pick -1 = or [ 2drop ] [ 2dup >r >r >r odd? r> call r> 2/ r> each-bit ] if ; inline recursive -GENERIC: (^) ( x y -- z ) foldable - : ^n ( z w -- z^w ) 1 swap [ [ dupd * ] when >r sq r> ] each-bit nip ; inline -M: integer (^) - dup 0 < [ neg ^n recip ] [ ^n ] if ; +: integer^ ( x y -- z ) + dup 0 > [ ^n ] [ neg ^n recip ] if ; inline + +: >rect ( z -- x y ) + [ real-part ] [ imaginary-part ] bi ; inline + +: >float-rect ( z -- x y ) + >rect [ >float ] bi@ ; inline + +: >polar ( z -- abs arg ) + >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; + inline + +: cis ( arg -- z ) dup fcos swap fsin rect> ; inline + +: polar> ( abs arg -- z ) cis * ; inline + +: ^mag ( w abs arg -- magnitude ) + >r >r >float-rect swap r> swap fpow r> rot * fexp /f ; + inline + +: ^theta ( w abs arg -- theta ) + >r >r >float-rect r> flog * swap r> * + ; inline + +: ^complex ( x y -- z ) + swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline + +: real^? ( x y -- ? ) + 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline + +: 0^ ( x -- z ) + dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline : ^ ( x y -- z ) - over zero? [ - dup zero? - [ 2drop 0.0 0.0 / ] [ 0 < [ drop 1.0 0.0 / ] when ] if - ] [ - (^) - ] if ; inline + { + { [ over zero? ] [ nip 0^ ] } + { [ dup integer? ] [ integer^ ] } + { [ 2dup real^? ] [ fpow ] } + [ ^complex ] + } cond ; : (^mod) ( n x y -- z ) 1 swap [ @@ -98,42 +126,27 @@ M: real absq sq ; [ ~abs ] } cond ; -: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline - : conjugate ( z -- z* ) >rect neg rect> ; inline -: >float-rect ( z -- x y ) - >rect swap >float swap >float ; inline - : arg ( z -- arg ) >float-rect swap fatan2 ; inline -: >polar ( z -- abs arg ) - >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ; - inline - -: cis ( arg -- z ) dup fcos swap fsin rect> ; inline - -: polar> ( abs arg -- z ) cis * ; inline - -: ^mag ( w abs arg -- magnitude ) - >r >r >float-rect swap r> swap fpow r> rot * fexp /f ; - inline - -: ^theta ( w abs arg -- theta ) - >r >r >float-rect r> flog * swap r> * + ; inline - -M: number (^) - swap >polar 3dup ^theta >r ^mag r> polar> ; - : [-1,1]? ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline : >=1? ( x -- ? ) dup complex? [ drop f ] [ 1 >= ] if ; inline -: exp ( x -- y ) >rect swap fexp swap polar> ; inline +GENERIC: exp ( x -- y ) -: log ( x -- y ) >polar swap flog swap rect> ; inline +M: real exp fexp ; + +M: complex exp >rect swap fexp swap polar> ; + +GENERIC: log ( x -- y ) + +M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; + +M: complex log >polar swap flog swap rect> ; : cos ( x -- y ) dup complex? [ diff --git a/basis/math/geometry/rect/rect-docs.factor b/basis/math/geometry/rect/rect-docs.factor index 3e21dfe307..a892940363 100644 --- a/basis/math/geometry/rect/rect-docs.factor +++ b/basis/math/geometry/rect/rect-docs.factor @@ -17,11 +17,6 @@ HELP: ( loc dim -- rect ) { } related-words -HELP: set-rect-dim ( dim rect -- ) -{ $values { "dim" "a pair of integers" } { "rect" rect } } -{ $description "Modifies the dimensions of a rectangle." } -{ $side-effects "rect" } ; - HELP: rect-bounds { $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } } { $description "Outputs the location and dimensions of a rectangle." } ; diff --git a/basis/math/geometry/rect/rect.factor b/basis/math/geometry/rect/rect.factor index 7f0bb94092..dd634f4a3b 100644 --- a/basis/math/geometry/rect/rect.factor +++ b/basis/math/geometry/rect/rect.factor @@ -7,6 +7,9 @@ IN: math.geometry.rect TUPLE: rect loc dim ; +GENERIC: rect-loc ( obj -- loc ) +GENERIC: rect-dim ( obj -- dim ) + : init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ; : ( loc dim -- rect ) rect boa ; @@ -17,6 +20,10 @@ M: array rect-loc ; M: array rect-dim drop { 0 0 } ; +M: rect rect-loc loc>> ; + +M: rect rect-dim dim>> ; + : rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; : rect-extent ( rect -- loc ext ) rect-bounds over v+ ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 806b0961ca..7d8d496737 100755 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -60,11 +60,11 @@ IN: math.intervals.tests ] unit-test [ t ] [ - 1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] = + 1 2 [a,b] -0.5 0.5 [a,b] interval* -1.0 1.0 [a,b] = ] unit-test [ t ] [ - 1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] = + 1 2 [a,b] -0.5 0.5 (a,b] interval* -1.0 1.0 (a,b] = ] unit-test [ t ] [ @@ -131,7 +131,7 @@ IN: math.intervals.tests "math.ratios.private" vocab [ [ t ] [ - -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) = + -1 1 (a,b) 0.5 1 (a,b) interval/ -2.0 2.0 (a,b) = ] unit-test ] when diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor index 28801fa2e9..c01e7377b2 100755 --- a/basis/math/ratios/ratios-tests.factor +++ b/basis/math/ratios/ratios-tests.factor @@ -81,8 +81,8 @@ unit-test [ -1/2 ] [ 1/2 1- ] unit-test [ 3/2 ] [ 1/2 1+ ] unit-test -[ 1 ] [ 0.5 1/2 + ] unit-test -[ 1 ] [ 1/2 0.5 + ] unit-test +[ 1.0 ] [ 0.5 1/2 + ] unit-test +[ 1.0 ] [ 1/2 0.5 + ] unit-test [ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test [ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 6569ee9540..5dde4fbb99 100755 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -30,6 +30,14 @@ M: integer / 2dup gcd nip tuck /i >r /i r> fraction> ] if ; +M: ratio hashcode* + nip >fraction [ hashcode ] bi@ bitxor ; + +M: ratio equal? + over ratio? [ + 2>fraction = [ = ] [ 2drop f ] if + ] [ 2drop f ] if ; + M: ratio number= 2>fraction number= [ number= ] [ 2drop f ] if ; diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index 2eda136ae5..9c8065e062 100755 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -15,7 +15,7 @@ C: foo [ f f ] [ "hi" 1 2 at* ] unit-test [ 3 ] [ - 3 "baz" 1 2 [ set-at ] keep foo-baz + 3 "baz" 1 2 [ set-at ] keep baz>> ] unit-test [ 3 "hi" 1 2 set-at ] must-fail diff --git a/basis/models/compose/compose-tests.factor b/basis/models/compose/compose-tests.factor index 25ba001d5d..16a5ab339c 100755 --- a/basis/models/compose/compose-tests.factor +++ b/basis/models/compose/compose-tests.factor @@ -1,6 +1,6 @@ -IN: models.compose.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.compose ; +tools.test models.compose accessors ; +IN: models.compose.tests ! Test compose [ ] [ @@ -11,14 +11,14 @@ tools.test models.compose ; [ ] [ "c" get activate-model ] unit-test -[ { 1 2 } ] [ "c" get model-value ] unit-test +[ { 1 2 } ] [ "c" get value>> ] unit-test [ ] [ 3 "b" get set-model ] unit-test -[ { 1 3 } ] [ "c" get model-value ] unit-test +[ { 1 3 } ] [ "c" get value>> ] unit-test [ ] [ { 4 5 } "c" get set-model ] unit-test -[ { 4 5 } ] [ "c" get model-value ] unit-test +[ { 4 5 } ] [ "c" get value>> ] unit-test [ ] [ "c" get deactivate-model ] unit-test diff --git a/basis/models/compose/compose.factor b/basis/models/compose/compose.factor index 015986fad0..a2c3385248 100755 --- a/basis/models/compose/compose.factor +++ b/basis/models/compose/compose.factor @@ -18,12 +18,12 @@ TUPLE: compose < model ; M: compose model-changed nip - [ [ model-value ] composed-value ] keep set-model ; + [ [ value>> ] composed-value ] keep set-model ; M: compose model-activated dup model-changed ; M: compose update-model - dup model-value swap [ set-model ] set-composed-value ; + dup value>> swap [ set-model ] set-composed-value ; M: compose range-value [ range-value ] composed-value ; diff --git a/basis/models/filter/filter-tests.factor b/basis/models/filter/filter-tests.factor index bdf3273fae..ad43568e06 100755 --- a/basis/models/filter/filter-tests.factor +++ b/basis/models/filter/filter-tests.factor @@ -1,18 +1,18 @@ -IN: models.filter.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.filter ; +tools.test models.filter accessors ; +IN: models.filter.tests ! Test multiple filters 3 "x" set "x" get [ 2 * ] dup "z" set [ 1+ ] "y" set [ ] [ "y" get activate-model ] unit-test -[ t ] [ "z" get "x" get model-connections memq? ] unit-test -[ 7 ] [ "y" get model-value ] unit-test +[ t ] [ "z" get "x" get connections>> memq? ] unit-test +[ 7 ] [ "y" get value>> ] unit-test [ ] [ 4 "x" get set-model ] unit-test -[ 9 ] [ "y" get model-value ] unit-test +[ 9 ] [ "y" get value>> ] unit-test [ ] [ "y" get deactivate-model ] unit-test -[ f ] [ "z" get "x" get model-connections memq? ] unit-test +[ f ] [ "z" get "x" get connections>> memq? ] unit-test 3 "x" set "x" get [ sq ] "y" set @@ -20,5 +20,5 @@ tools.test models.filter ; 4 "x" get set-model "y" get activate-model -[ 16 ] [ "y" get model-value ] unit-test +[ 16 ] [ "y" get value>> ] unit-test "y" get deactivate-model diff --git a/basis/models/history/history-tests.factor b/basis/models/history/history-tests.factor index 40d1176667..c89dd5c5b3 100755 --- a/basis/models/history/history-tests.factor +++ b/basis/models/history/history-tests.factor @@ -1,37 +1,37 @@ -IN: models.history.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.history ; +tools.test models.history accessors ; +IN: models.history.tests f "history" set "history" get add-history -[ t ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test "history" get add-history 3 "history" get set-model -[ t ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test "history" get add-history 4 "history" get set-model -[ f ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test "history" get go-back -[ 3 ] [ "history" get model-value ] unit-test +[ 3 ] [ "history" get value>> ] unit-test -[ t ] [ "history" get history-back empty? ] unit-test -[ f ] [ "history" get history-forward empty? ] unit-test +[ t ] [ "history" get back>> empty? ] unit-test +[ f ] [ "history" get forward>> empty? ] unit-test "history" get go-forward -[ 4 ] [ "history" get model-value ] unit-test +[ 4 ] [ "history" get value>> ] unit-test -[ f ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test diff --git a/basis/models/mapping/mapping-tests.factor b/basis/models/mapping/mapping-tests.factor index 43c1883bb1..6e1a1dc8d0 100755 --- a/basis/models/mapping/mapping-tests.factor +++ b/basis/models/mapping/mapping-tests.factor @@ -1,6 +1,6 @@ -IN: models.mapping.tests USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.mapping ; +tools.test models.mapping accessors ; +IN: models.mapping.tests ! Test mapping [ ] [ @@ -14,7 +14,7 @@ tools.test models.mapping ; [ ] [ "m" get activate-model ] unit-test [ H{ { "one" 1 } { "two" 2 } } ] [ - "m" get model-value + "m" get value>> ] unit-test [ ] [ @@ -23,12 +23,12 @@ tools.test models.mapping ; ] unit-test [ H{ { "one" 3 } { "two" 4 } } ] [ - "m" get model-value + "m" get value>> ] unit-test [ H{ { "one" 5 } { "two" 4 } } ] [ - 5 "one" "m" get mapping-assoc at set-model - "m" get model-value + 5 "one" "m" get assoc>> at set-model + "m" get value>> ] unit-test [ ] [ "m" get deactivate-model ] unit-test diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index ee1bb542f0..fe10d3ab8e 100755 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -1,13 +1,12 @@ -IN: models.tests USING: arrays generic kernel math models models.compose -namespaces sequences assocs -tools.test ; +namespaces sequences assocs accessors tools.test ; +IN: models.tests TUPLE: model-tester hit? ; : model-tester new ; -M: model-tester model-changed nip t swap set-model-tester-hit? ; +M: model-tester model-changed nip t >>hit? drop ; [ T{ model-tester f t } ] [ @@ -20,7 +19,7 @@ M: model-tester model-changed nip t swap set-model-tester-hit? ; "model-a" get "model-b" get 2array "model-c" set "model-c" get activate-model -[ { 3 4 } ] [ "model-c" get model-value ] unit-test +[ { 3 4 } ] [ "model-c" get value>> ] unit-test "model-c" get deactivate-model T{ model-tester f f } "tester" set @@ -30,5 +29,5 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get add-connection 6 "model-a" get set-model "tester" get - "model-c" get model-value + "model-c" get value>> ] unit-test diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index d658235cf6..806935d5c9 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -5,9 +5,9 @@ continuations math.parser math arrays sets math.order ; IN: opengl.capabilities : (require-gl) ( thing require-quot make-error-quot -- ) - >r dupd call - [ r> 2drop ] - [ r> " " make throw ] + -rot dupd call + [ 2drop ] + [ swap " " make throw ] if ; inline : gl-extensions ( -- seq ) diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index dc049ee1a4..9bf8ed62f0 100755 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -148,7 +148,7 @@ M: fixnum potential-hang dup [ potential-hang ] when ; TUPLE: funny-cons car cdr ; GENERIC: iterate ( obj -- ) -M: funny-cons iterate funny-cons-cdr iterate ; +M: funny-cons iterate cdr>> iterate ; M: f iterate drop ; M: real iterate drop ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 36fe015611..833528018b 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -246,7 +246,7 @@ IN: tools.deploy.shaker word } % - { } { "optimizer.math.partial" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % ] when strip-prettyprint? [ diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 4c288b1c9e..b4b7a76497 100755 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -1,4 +1,5 @@ -USING: tuple-arrays sequences tools.test namespaces kernel math accessors ; +USING: tuple-arrays sequences tools.test namespaces kernel +math accessors ; IN: tuple-arrays.tests SYMBOL: mat @@ -9,7 +10,7 @@ C: foo [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ T{ foo f 3 } t ] -[ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test +[ mat get [ bar>> 2 + ] map [ first ] keep tuple-array? ] unit-test [ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 8d176b9c63..1a05d23aa0 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -24,10 +24,10 @@ TUPLE: pasteboard handle ; C: pasteboard M: pasteboard clipboard-contents - pasteboard-handle pasteboard-string ; + handle>> pasteboard-string ; M: pasteboard set-clipboard-contents - pasteboard-handle set-pasteboard-string ; + handle>> set-pasteboard-string ; : init-clipboard ( -- ) NSPasteboard -> generalPasteboard @@ -44,29 +44,29 @@ M: pasteboard set-clipboard-contents dup install-window-delegate over -> release - ] keep set-world-handle ; + ] keep (>>handle) ; M: cocoa-ui-backend set-title ( string world -- ) - world-handle handle-window swap -> setTitle: ; + handle>> window>> swap -> setTitle: ; : enter-fullscreen ( world -- ) - world-handle handle-view + handle>> view>> NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; : exit-fullscreen ( world -- ) - world-handle handle-view f -> exitFullScreenModeWithOptions: ; + handle>> view>> f -> exitFullScreenModeWithOptions: ; M: cocoa-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; M: cocoa-ui-backend fullscreen* ( world -- ? ) - world-handle handle-view -> isInFullScreenMode zero? not ; + handle>> view>> -> isInFullScreenMode zero? not ; : auto-position ( world -- ) dup window-loc>> { 0 0 } = [ - world-handle handle-window -> center + handle>> window>> -> center ] [ drop ] if ; @@ -74,29 +74,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) M: cocoa-ui-backend (open-window) ( world -- ) dup gadget-window dup auto-position - world-handle handle-window f -> makeKeyAndOrderFront: ; + handle>> window>> f -> makeKeyAndOrderFront: ; M: cocoa-ui-backend (close-window) ( handle -- ) - handle-window -> release ; + window>> -> release ; M: cocoa-ui-backend close-window ( gadget -- ) find-world [ - world-handle [ - handle-window f -> performClose: + handle>> [ + window>> f -> performClose: ] when* ] when* ; M: cocoa-ui-backend raise-window* ( world -- ) - world-handle [ - handle-window dup f -> orderFront: -> makeKeyWindow + handle>> [ + window>> dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: ] when* ; M: cocoa-ui-backend select-gl-context ( handle -- ) - handle-view -> openGLContext -> makeCurrentContext ; + view>> -> openGLContext -> makeCurrentContext ; M: cocoa-ui-backend flush-gl-context ( handle -- ) - handle-view -> openGLContext -> flushBuffer ; + view>> -> openGLContext -> flushBuffer ; M: cocoa-ui-backend beep ( -- ) NSBeep ; diff --git a/basis/ui/gadgets/borders/borders.factor b/basis/ui/gadgets/borders/borders.factor index da21c06a1b..4609562af4 100644 --- a/basis/ui/gadgets/borders/borders.factor +++ b/basis/ui/gadgets/borders/borders.factor @@ -41,7 +41,7 @@ M: border pref-dim* M: border layout* dup border-child-rect swap gadget-child - over loc>> over set-rect-loc + over loc>> >>loc swap dim>> swap (>>dim) ; M: border focusable-child* diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 6c5d757dd4..bdd9ebaf13 100755 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -1,6 +1,7 @@ -IN: ui.gadgets.buttons.tests USING: ui.commands ui.gadgets.buttons ui.gadgets.labels -ui.gadgets tools.test namespaces sequences kernel models ; +ui.gadgets tools.test namespaces sequences kernel models +accessors ; +IN: ui.gadgets.buttons.tests TUPLE: foo-gadget ; @@ -15,7 +16,7 @@ TUPLE: foo-gadget ; T{ foo-gadget } "t" set -[ 2 ] [ "t" get gadget-children length ] unit-test +[ 2 ] [ "t" get children>> length ] unit-test [ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test [ ] [ @@ -34,7 +35,7 @@ T{ foo-gadget } "t" set \ must-infer [ 0 ] [ - "religion" get gadget-child radio-control-value + "religion" get gadget-child value>> ] unit-test [ 2 ] [ diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index a079781d69..e04e385a23 100755 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -148,7 +148,7 @@ TUPLE: checkbox < button ; align-left ; M: checkbox model-changed - swap model-value over (>>selected?) relayout-1 ; + swap value>> over (>>selected?) relayout-1 ; TUPLE: radio-paint color ; @@ -187,7 +187,7 @@ TUPLE: radio-control < button value ; align-left ; inline M: radio-control model-changed - swap model-value + swap value>> over value>> = over (>>selected?) relayout-1 ; diff --git a/basis/ui/gadgets/canvas/canvas-tests.factor b/basis/ui/gadgets/canvas/canvas-tests.factor new file mode 100755 index 0000000000..bc87064c92 --- /dev/null +++ b/basis/ui/gadgets/canvas/canvas-tests.factor @@ -0,0 +1,4 @@ +IN: ui.gadgets.canvas.tests +USING: ui.gadgets.canvas tools.test kernel ; + +{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor old mode 100644 new mode 100755 index ba5aeaf95b..85149f4551 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces -classes.tuple colors ; +classes.tuple colors accessors ; IN: ui.gadgets.canvas TUPLE: canvas < gadget dlist ; @@ -11,16 +11,16 @@ TUPLE: canvas < gadget dlist ; new-gadget black solid-interior ; inline : delete-canvas-dlist ( canvas -- ) - dup find-gl-context - dup canvas-dlist [ delete-dlist ] when* - f swap set-canvas-dlist ; + [ find-gl-context ] + [ dlist>> [ delete-dlist ] when* ] + [ f >>dlist drop ] tri ; : make-canvas-dlist ( canvas quot -- dlist ) - over >r GL_COMPILE swap make-dlist dup r> - set-canvas-dlist ; + [ drop ] [ GL_COMPILE swap make-dlist ] 2bi + [ >>dlist drop ] keep ; inline : cache-canvas-dlist ( canvas quot -- dlist ) - over canvas-dlist dup + over dlist>> dup [ 2nip ] [ drop make-canvas-dlist ] if ; inline : draw-canvas ( canvas quot -- ) diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index 166e6c264b..274d62ea46 100755 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -2,6 +2,7 @@ USING: accessors ui.gadgets.editors tools.test kernel io io.streams.plain definitions namespaces ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui models ; +IN: ui.gadgets.editors.tests [ "foo bar" ] [ "editor" set @@ -34,7 +35,7 @@ models ; "editor" set "editor" get [ "bar\nbaz quux" "editor" get set-editor-string - { 0 3 } "editor" get editor-caret set-model + { 0 3 } "editor" get caret>> set-model "editor" get select-word "editor" get gadget-selection ] with-grafted-gadget @@ -45,5 +46,5 @@ models ; "hello" "field" set "field" get [ - [ "hello" ] [ "field" get field-model>> model-value ] unit-test + [ "hello" ] [ "field" get field-model>> value>> ] unit-test ] with-grafted-gadget diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 0bce366fcc..a1602effe9 100755 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -1,8 +1,8 @@ -IN: ui.gadgets.tests USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists deques math sets math.parser ui sequences hashtables assocs io arrays prettyprint io.streams.string math.geometry.rect ; +IN: ui.gadgets.tests [ { 300 300 } ] [ @@ -14,24 +14,24 @@ io.streams.string math.geometry.rect ; "b" get "c" get swap add-gadget drop ! position a and b - { 100 200 } "a" get set-rect-loc - { 200 100 } "b" get set-rect-loc + "a" get { 100 200 } >>loc drop + "b" get { 200 100 } >>loc drop ! give c a loc, it doesn't matter - { -1000 23 } "c" get set-rect-loc + "c" get { -1000 23 } >>loc drop ! what is the location of a inside c? "a" get "c" get relative-loc ] unit-test "g1" set -{ 10 10 } "g1" get set-rect-loc -{ 30 30 } "g1" get set-rect-dim +"g1" get { 10 10 } >>loc + { 30 30 } >>dim drop "g2" set -{ 20 20 } "g2" get set-rect-loc -{ 50 500 } "g2" get set-rect-dim +"g2" get { 20 20 } >>loc + { 50 500 } >>dim drop "g3" set -{ 100 200 } "g3" get set-rect-dim +"g3" get { 100 200 } >>dim drop "g1" get "g2" get swap add-gadget drop "g2" get "g3" get swap add-gadget drop @@ -47,15 +47,15 @@ io.streams.string math.geometry.rect ; [ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test "g1" set -{ 300 300 } "g1" get set-rect-dim +"g1" get { 300 300 } >>dim drop "g2" set "g2" get "g1" get swap add-gadget drop -{ 20 20 } "g2" get set-rect-loc -{ 20 20 } "g2" get set-rect-dim +"g2" get { 20 20 } >>loc + { 20 20 } >>dim drop "g3" set "g3" get "g1" get swap add-gadget drop -{ 100 100 } "g3" get set-rect-loc -{ 20 20 } "g3" get set-rect-dim +"g3" get { 100 100 } >>loc + { 20 20 } >>dim drop [ t ] [ { 30 30 } "g2" get inside? ] unit-test @@ -67,8 +67,8 @@ io.streams.string math.geometry.rect ; "g4" set "g4" get "g2" get swap add-gadget drop -{ 5 5 } "g4" get set-rect-loc -{ 1 1 } "g4" get set-rect-dim +"g4" get { 5 5 } >>loc + { 1 1 } >>dim drop [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test @@ -78,12 +78,10 @@ TUPLE: mock-gadget < gadget graft-called ungraft-called ; mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ; M: mock-gadget graft* - dup mock-gadget-graft-called 1+ - swap set-mock-gadget-graft-called ; + [ 1+ ] change-graft-called drop ; M: mock-gadget ungraft* - dup mock-gadget-ungraft-called 1+ - swap set-mock-gadget-ungraft-called ; + [ 1+ ] change-ungraft-called drop ; ! We can't print to output-stream here because that might be a pane ! stream, and our graft-queue rebinding here would be captured @@ -100,35 +98,35 @@ M: mock-gadget ungraft* "g" set [ ] [ "g" get queue-graft ] unit-test [ f ] [ graft-queue deque-empty? ] unit-test - [ { f t } ] [ "g" get gadget-graft-state ] unit-test + [ { f t } ] [ "g" get graft-state>> ] unit-test [ ] [ "g" get graft-later ] unit-test - [ { f t } ] [ "g" get gadget-graft-state ] unit-test + [ { f t } ] [ "g" get graft-state>> ] unit-test [ ] [ "g" get ungraft-later ] unit-test - [ { f f } ] [ "g" get gadget-graft-state ] unit-test + [ { f f } ] [ "g" get graft-state>> ] unit-test [ t ] [ graft-queue deque-empty? ] unit-test [ ] [ "g" get ungraft-later ] unit-test [ ] [ "g" get graft-later ] unit-test [ ] [ notify-queued ] unit-test - [ { t t } ] [ "g" get gadget-graft-state ] unit-test + [ { t t } ] [ "g" get graft-state>> ] unit-test [ t ] [ graft-queue deque-empty? ] unit-test [ ] [ "g" get graft-later ] unit-test - [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test + [ 1 ] [ "g" get graft-called>> ] unit-test [ ] [ "g" get ungraft-later ] unit-test - [ { t f } ] [ "g" get gadget-graft-state ] unit-test + [ { t f } ] [ "g" get graft-state>> ] unit-test [ ] [ notify-queued ] unit-test - [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test - [ { f f } ] [ "g" get gadget-graft-state ] unit-test + [ 1 ] [ "g" get ungraft-called>> ] unit-test + [ { f f } ] [ "g" get graft-state>> ] unit-test ] with-variable : add-some-children 3 [ - over over set-gadget-model + over >>model dup "g" get swap add-gadget drop swap 1+ number>string set ] each ; : status-flags - { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ; + { "g" "1" "2" "3" } [ get graft-state>> ] map prune ; : notify-combo ( ? ? -- ) nl "===== Combo: " write 2dup 2array . nl @@ -140,12 +138,12 @@ M: mock-gadget ungraft* [ V{ { f t } } ] [ status-flags ] unit-test dup [ [ ] [ notify-queued ] unit-test ] when [ ] [ "g" get clear-gadget ] unit-test - [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless + [ [ 1 ] [ graft-queue length>> ] unit-test ] unless [ [ ] [ notify-queued ] unit-test ] when [ ] [ add-some-children ] unit-test - [ { f t } ] [ "1" get gadget-graft-state ] unit-test - [ { f t } ] [ "2" get gadget-graft-state ] unit-test - [ { f t } ] [ "3" get gadget-graft-state ] unit-test + [ { f t } ] [ "1" get graft-state>> ] unit-test + [ { f t } ] [ "2" get graft-state>> ] unit-test + [ { f t } ] [ "3" get graft-state>> ] unit-test [ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test [ ] [ notify-queued ] unit-test [ V{ { t t } } ] [ status-flags ] unit-test diff --git a/basis/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor index cfca5d5a93..9015b7ec1b 100644 --- a/basis/ui/gadgets/grids/grids-tests.factor +++ b/basis/ui/gadgets/grids/grids-tests.factor @@ -1,10 +1,10 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays -namespaces math.geometry.rect ; +namespaces math.geometry.rect accessors ; IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test -: 100x100 { 100 100 } over set-rect-dim ; +: 100x100 { 100 100 } >>dim ; [ { 100 100 } ] [ 100x100 @@ -38,7 +38,7 @@ IN: ui.gadgets.grids.tests 100x100 dup "a" set 100x100 dup "b" set 2array 1array - { 10 10 } over set-grid-gap + { 10 10 } >>gap dup prefer dup layout rect-dim diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 83e5e73662..42e8cfdfdf 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -62,7 +62,7 @@ M: grid pref-dim* : position-grid ( grid horiz vert -- ) pick >r >r over r> grid-positions >r grid-positions r> - pair-up r> [ set-rect-loc ] do-grid ; + pair-up r> [ (>>loc) ] do-grid ; : resize-grid ( grid horiz vert -- ) pick fill?>> [ diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index 3291a1c42a..4d67080775 100755 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -37,8 +37,8 @@ M: incremental pref-dim* [ next-cursor ] keep (>>cursor) ; : incremental-loc ( gadget incremental -- ) - dup cursor>> swap orientation>> v* - swap set-rect-loc ; + [ cursor>> ] [ orientation>> ] bi v* + >>loc drop ; : prefer-incremental ( gadget -- ) dup forget-pref-dim dup pref-dim >>dim drop ; diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index af7dff0039..ed951824b8 100755 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -43,7 +43,7 @@ M: label gadget-text* label-string % ; TUPLE: label-control < label ; M: label-control model-changed - swap model-value over set-label-string relayout ; + swap value>> over set-label-string relayout ; : ( model -- gadget ) "" label-control new-label diff --git a/basis/ui/gadgets/lib/lib.factor b/basis/ui/gadgets/lib/lib.factor index 12385f0808..866369b0af 100644 --- a/basis/ui/gadgets/lib/lib.factor +++ b/basis/ui/gadgets/lib/lib.factor @@ -1,6 +1,8 @@ -USING: ui.backend ui.gadgets.worlds ; +USING: accessors kernel ui.backend ui.gadgets.worlds ; IN: ui.gadgets.lib -: find-gl-context ( gadget -- ) find-world world-handle select-gl-context ; +ERROR: no-world-found ; +: find-gl-context ( gadget -- ) + find-world dup [ handle>> select-gl-context ] [ no-world-found ] if ; diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 932353e428..26e405f6db 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -14,7 +14,7 @@ TUPLE: menu-glass < gadget ; : ( menu world -- glass ) menu-glass new-gadget - >r over menu-loc over set-rect-loc r> + >r over menu-loc >>loc r> [ swap add-gadget drop ] keep ; M: menu-glass layout* gadget-child prefer ; diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index ed64c1e990..207708afdf 100755 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -32,7 +32,7 @@ TUPLE: pack < gadget : pack-layout ( pack sizes -- ) round-dims over children>> >r dupd packed-dims r> 2dup [ (>>dim) ] 2each - >r packed-locs r> [ set-rect-loc ] 2each ; + >r packed-locs r> [ (>>loc) ] 2each ; : ( orientation -- pack ) pack new-gadget diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index fd1ee0f573..64a72fe523 100755 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -1,11 +1,11 @@ -IN: ui.gadgets.panes.tests USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.styles io.streams.string tools.test prettyprint definitions help help.syntax help.markup help.stylesheet splitting tools.test.ui models math summary -inspector ; +inspector accessors ; +IN: ui.gadgets.panes.tests -: #children "pane" get gadget-children length ; +: #children "pane" get children>> length ; [ ] [ "pane" set ] unit-test diff --git a/basis/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor index 5e87484b2d..fed1fb97f1 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs.factor @@ -69,4 +69,4 @@ M: paragraph pref-dim* [ 2drop ] do-wrap ; M: paragraph layout* - [ swap dup prefer set-rect-loc ] do-wrap drop ; + [ swap dup prefer (>>loc) ] do-wrap drop ; diff --git a/basis/ui/gadgets/presentations/presentations-tests.factor b/basis/ui/gadgets/presentations/presentations-tests.factor index fcbc65725a..358bf2b791 100644 --- a/basis/ui/gadgets/presentations/presentations-tests.factor +++ b/basis/ui/gadgets/presentations/presentations-tests.factor @@ -1,7 +1,7 @@ -IN: ui.gadgets.presentations.tests USING: math ui.gadgets.presentations ui.gadgets tools.test prettyprint ui.gadgets.buttons io io.streams.string kernel -classes.tuple ; +classes.tuple accessors ; +IN: ui.gadgets.presentations.tests [ t ] [ "Hi" \ + gadget? @@ -9,6 +9,6 @@ classes.tuple ; [ "+" ] [ [ - \ + f \ pprint dup button-quot call + \ + f \ pprint dup quot>> call ] with-string-writer ] unit-test diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index fb3e6cec23..48251c4927 100755 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -1,9 +1,9 @@ -IN: ui.gadgets.scrollers.tests USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models models.compose models.range ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences -tools.test.ui math.geometry.rect ; +tools.test.ui math.geometry.rect accessors ; +IN: ui.gadgets.scrollers.tests [ ] [ "g" set @@ -12,11 +12,11 @@ tools.test.ui math.geometry.rect ; [ { 100 200 } ] [ { 100 200 } "g" get scroll>rect - "s" get scroller-follows rect-loc + "s" get follows>> rect-loc ] unit-test [ ] [ "s" get scroll>bottom ] unit-test -[ t ] [ "s" get scroller-follows ] unit-test +[ t ] [ "s" get follows>> ] unit-test [ ] [ dup "g" set @@ -25,46 +25,46 @@ tools.test.ui math.geometry.rect ; ] unit-test "v" get [ - [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test + [ { 10 20 } ] [ "v" get model>> range-value ] unit-test [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test ] with-grafted-gadget [ ] [ - { 100 100 } over set-rect-dim + { 100 100 } >>dim dup "g" set "s" set ] unit-test -[ ] [ { 50 50 } "s" get set-rect-dim ] unit-test +[ ] [ "s" get { 50 50 } >>dim drop ] unit-test [ ] [ "s" get layout ] unit-test "s" get [ - [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test + [ { 34 34 } ] [ "s" get viewport>> rect-dim ] unit-test - [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test + [ { 106 106 } ] [ "s" get viewport>> viewport-dim ] unit-test [ ] [ { 0 0 } "s" get scroll ] unit-test - [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test + [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test - [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test + [ { 106 106 } ] [ "s" get model>> range-max-value ] unit-test [ ] [ { 10 20 } "s" get scroll ] unit-test - [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test + [ { 10 20 } ] [ "s" get model>> range-value ] unit-test - [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test + [ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test ] with-grafted-gadget - { 600 400 } over set-rect-dim "g1" set - { 600 10 } over set-rect-dim "g2" set + { 600 400 } >>dim "g1" set + { 600 10 } >>dim "g2" set "g2" get "g1" get swap add-gadget drop "g1" get -{ 300 300 } over set-rect-dim +{ 300 300 } >>dim dup layout "s" set @@ -80,9 +80,9 @@ dup layout [ ] [ "Hi"