From 15a8ff071cb9d5708fd48a1177cb2194d271cdde Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 31 Aug 2008 11:00:26 -0700 Subject: [PATCH 001/121] Load game-input backend at compile time --- extra/game-input/backend/backend.factor | 6 ++++-- extra/game-input/backend/dinput/dinput.factor | 3 ++- extra/game-input/backend/iokit/iokit.factor | 5 +++-- extra/game-input/game-input.factor | 4 +++- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor index cfba0a52f5..df61179da7 100644 --- a/extra/game-input/backend/backend.factor +++ b/extra/game-input/backend/backend.factor @@ -2,12 +2,14 @@ USING: eval multiline system combinators ; IN: game-input.backend STRING: set-backend-for-macosx -USING: namespaces game-input.backend.iokit game-input ; +USING: namespaces parser game-input.backend.iokit ; +<< "game-input" (use+) >> iokit-game-input-backend game-input-backend set-global ; STRING: set-backend-for-windows -USING: namespaces game-input.backend.dinput game-input ; +USING: namespaces parser game-input.backend.dinput ; +<< "game-input" (use+) >> dinput-game-input-backend game-input-backend set-global ; diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor index 73c9f511a1..116faf60cd 100755 --- a/extra/game-input/backend/dinput/dinput.factor +++ b/extra/game-input/backend/dinput/dinput.factor @@ -1,10 +1,11 @@ -USING: windows.dinput windows.dinput.constants game-input +USING: windows.dinput windows.dinput.constants parser symbols alien.c-types windows.ole32 namespaces assocs kernel arrays vectors windows.kernel32 windows.com windows.dinput shuffle windows.user32 windows.messages sequences combinators math.geometry.rect ui.windows accessors math windows alien alien.strings io.encodings.utf16 continuations byte-arrays locals game-input.backend.dinput.keys-array ; +<< "game-input" (use+) >> IN: game-input.backend.dinput SINGLETON: dinput-game-input-backend diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor index dcdfa6d192..4a7d251425 100755 --- a/extra/game-input/backend/iokit/iokit.factor +++ b/extra/game-input/backend/iokit/iokit.factor @@ -1,9 +1,10 @@ USING: cocoa cocoa.plists core-foundation iokit iokit.hid kernel cocoa.enumeration destructors math.parser cocoa.application -sequences locals combinators.short-circuit game-input threads +sequences locals combinators.short-circuit threads symbols namespaces assocs vectors arrays combinators core-foundation.run-loop accessors sequences.private -alien.c-types math ; +alien.c-types math parser ; +<< "game-input" (use+) >> IN: game-input.backend.iokit SINGLETON: iokit-game-input-backend diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 208c8476fc..18ec04df1f 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -28,7 +28,6 @@ M: f (reset-game-input) ; PRIVATE> : open-game-input ( -- ) - load-game-input-backend game-input-opened? [ (open-game-input) game-input-opened on @@ -76,3 +75,6 @@ M: keyboard-state clone call-next-method dup keys>> clone >>keys ; HOOK: read-keyboard game-input-backend ( -- keyboard-state ) + +load-game-input-backend + From 2a8c9bb56f0d879d533455415d5a7ebe6f997674 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Sep 2008 08:12:08 -0700 Subject: [PATCH 002/121] deploy.factor for joystick-demo --- extra/joystick-demo/deploy.factor | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 extra/joystick-demo/deploy.factor diff --git a/extra/joystick-demo/deploy.factor b/extra/joystick-demo/deploy.factor new file mode 100644 index 0000000000..8843ae66f3 --- /dev/null +++ b/extra/joystick-demo/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-name "joystick-demo" } + { deploy-io 2 } + { deploy-word-defs? f } + { deploy-c-types? t } + { deploy-random? t } + { deploy-word-props? f } + { deploy-reflection 1 } + { deploy-threads? t } + { deploy-math? t } + { "stop-after-last-window?" t } + { deploy-ui? t } + { deploy-compiler? t } +} From 9dbe18e07d77ca702309cf2c90f5760a1ef57aff Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 1 Sep 2008 08:53:32 -0700 Subject: [PATCH 003/121] remove obsolete reference to "construct" in bunny.outlined. clean up >r imbalance in opengl.capabilities --- basis/opengl/capabilities/capabilities.factor | 6 +++--- {unmaintained => extra}/bunny/authors.txt | 0 {unmaintained => extra}/bunny/bun_zipper.ply | 0 {unmaintained => extra}/bunny/bunny.factor | 0 {unmaintained => extra}/bunny/cel-shaded/cel-shaded.factor | 0 {unmaintained => extra}/bunny/deploy.factor | 0 .../bunny/fixed-pipeline/fixed-pipeline.factor | 0 {unmaintained => extra}/bunny/model/model.factor | 0 {unmaintained => extra}/bunny/outlined/outlined.factor | 6 +----- {unmaintained => extra}/bunny/summary.txt | 0 {unmaintained => extra}/bunny/tags.txt | 0 11 files changed, 4 insertions(+), 8 deletions(-) rename {unmaintained => extra}/bunny/authors.txt (100%) rename {unmaintained => extra}/bunny/bun_zipper.ply (100%) rename {unmaintained => extra}/bunny/bunny.factor (100%) rename {unmaintained => extra}/bunny/cel-shaded/cel-shaded.factor (100%) rename {unmaintained => extra}/bunny/deploy.factor (100%) rename {unmaintained => extra}/bunny/fixed-pipeline/fixed-pipeline.factor (100%) rename {unmaintained => extra}/bunny/model/model.factor (100%) rename {unmaintained => extra}/bunny/outlined/outlined.factor (97%) rename {unmaintained => extra}/bunny/summary.txt (100%) rename {unmaintained => extra}/bunny/tags.txt (100%) 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/unmaintained/bunny/authors.txt b/extra/bunny/authors.txt similarity index 100% rename from unmaintained/bunny/authors.txt rename to extra/bunny/authors.txt diff --git a/unmaintained/bunny/bun_zipper.ply b/extra/bunny/bun_zipper.ply similarity index 100% rename from unmaintained/bunny/bun_zipper.ply rename to extra/bunny/bun_zipper.ply diff --git a/unmaintained/bunny/bunny.factor b/extra/bunny/bunny.factor similarity index 100% rename from unmaintained/bunny/bunny.factor rename to extra/bunny/bunny.factor diff --git a/unmaintained/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor similarity index 100% rename from unmaintained/bunny/cel-shaded/cel-shaded.factor rename to extra/bunny/cel-shaded/cel-shaded.factor diff --git a/unmaintained/bunny/deploy.factor b/extra/bunny/deploy.factor similarity index 100% rename from unmaintained/bunny/deploy.factor rename to extra/bunny/deploy.factor diff --git a/unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor similarity index 100% rename from unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor rename to extra/bunny/fixed-pipeline/fixed-pipeline.factor diff --git a/unmaintained/bunny/model/model.factor b/extra/bunny/model/model.factor similarity index 100% rename from unmaintained/bunny/model/model.factor rename to extra/bunny/model/model.factor diff --git a/unmaintained/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor similarity index 97% rename from unmaintained/bunny/outlined/outlined.factor rename to extra/bunny/outlined/outlined.factor index bf757c4fb3..cd67b8b33e 100755 --- a/unmaintained/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -139,11 +139,7 @@ TUPLE: bunny-outlined : ( gadget -- draw ) outlining-supported? [ - pass1-program pass2-program { - (>>gadget) - (>>pass1-program) - (>>pass2-program) - } bunny-outlined construct + pass1-program pass2-program f f f f f bunny-outlined boa ] [ drop f ] if ; : (framebuffer-texture) ( dim iformat xformat -- texture ) diff --git a/unmaintained/bunny/summary.txt b/extra/bunny/summary.txt similarity index 100% rename from unmaintained/bunny/summary.txt rename to extra/bunny/summary.txt diff --git a/unmaintained/bunny/tags.txt b/extra/bunny/tags.txt similarity index 100% rename from unmaintained/bunny/tags.txt rename to extra/bunny/tags.txt From 669e0f8f0a9cf69b39b99916e74422ca4e6bdcb9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Sep 2008 18:25:21 -0500 Subject: [PATCH 004/121] Propagate slot types of literals --- .../tree/propagation/info/info.factor | 34 +++++++++++++++++-- .../tree/propagation/propagation-tests.factor | 16 +++++++++ .../tree/propagation/slots/slots.factor | 6 ---- 3 files changed, 47 insertions(+), 9 deletions(-) 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/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 503c633077..559a9bf60b 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,14 @@ 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{ 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 ; From 9ca908e5a907d6dcc0996839c88f18bab068a1ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Sep 2008 18:26:10 -0500 Subject: [PATCH 005/121] Add some new byte array constructors --- core/byte-arrays/byte-arrays.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 5461da2b84..0bcea2651a 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -19,3 +19,11 @@ M: byte-array resize resize-byte-array ; INSTANCE: byte-array sequence + +: 1byte-array ( x -- array ) 1 [ set-first ] keep ; inline + +: 2byte-array ( x y -- array ) B{ } 2sequence ; inline + +: 3byte-array ( x y z -- array ) B{ } 3sequence ; inline + +: 4byte-array ( w x y z -- array ) B{ } 4sequence ; inline From c26d2fb34515a5a1c8e309f3093c0c32ad47bb56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Sep 2008 18:28:24 -0500 Subject: [PATCH 006/121] Clean up mandelbrot a bit --- extra/benchmark/mandel/colors/colors.factor | 19 ++++++ extra/benchmark/mandel/mandel.factor | 74 +++++++-------------- extra/benchmark/mandel/params/params.factor | 8 +++ 3 files changed, 52 insertions(+), 49 deletions(-) create mode 100644 extra/benchmark/mandel/colors/colors.factor create mode 100644 extra/benchmark/mandel/params/params.factor diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor new file mode 100644 index 0000000000..848fbae01e --- /dev/null +++ b/extra/benchmark/mandel/colors/colors.factor @@ -0,0 +1,19 @@ +USING: math math.order kernel arrays byte-arrays sequences +colors.hsv benchmark.mandel.params ; +IN: benchmark.mandel.colors + +: scale 255 * >fixnum ; inline + +: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ; + +: sat 0.85 ; inline +: val 0.85 ; inline + +: ( nb-cols -- map ) + dup [ + 360 * swap 1+ / sat val + 3array hsv>rgb first3 scale-rgb + ] with map ; + +: color-map ( -- map ) + nb-iter max-color min ; foldable diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 2685ff28b7..a40b123ed3 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,69 +1,45 @@ -USING: arrays io kernel math math.order namespaces sequences - byte-arrays byte-vectors math.functions math.parser io.files - colors.hsv io.encodings.binary ; - +USING: arrays io kernel math math.functions math.order +math.parser sequences locals byte-arrays byte-vectors io.files +io.encodings.binary benchmark.mandel.params +benchmark.mandel.colors ; IN: benchmark.mandel -: max-color 360 ; inline -: zoom-fact 0.8 ; inline -: width 640 ; inline -: height 480 ; inline -: nb-iter 40 ; inline -: center -0.65 ; inline - -: scale 255 * >fixnum ; inline - -: scale-rgb ( r g b -- n ) [ scale ] tri@ 3array ; - -: sat 0.85 ; inline -: val 0.85 ; inline - -: ( nb-cols -- map ) - dup [ - 360 * swap 1+ / sat val - 3array hsv>rgb first3 scale-rgb - ] with map ; - : iter ( c z nb-iter -- x ) - over absq 4.0 >= over zero? or - [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline recursive - -SYMBOL: cols + dup 0 <= [ 2nip ] [ + over absq 4.0 >= [ 2nip ] [ + >r sq dupd + r> 1- iter + ] if + ] if ; inline recursive : x-inc width 200000 zoom-fact * / ; inline : y-inc height 150000 zoom-fact * / ; inline : c ( i j -- c ) - >r - x-inc * center real-part x-inc width 2 / * - + >float - r> - y-inc * center imaginary-part y-inc height 2 / * - + >float + [ x-inc * center real-part x-inc width 2 / * - + >float ] + [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi* rect> ; inline -: render ( -- ) +:: render ( accum -- ) height [ width swap [ - c 0 nb-iter iter dup zero? [ - drop "\0\0\0" - ] [ - cols get [ length mod ] keep nth - ] if % + c C{ 0.0 0.0 } nb-iter iter dup zero? + [ drop B{ 0 0 0 } ] [ color-map [ length mod ] keep nth ] if + accum push-all ] curry each - ] each ; + ] each ; inline -: ppm-header ( w h -- ) - "P6\n" % swap # " " % # "\n255\n" % ; +:: ppm-header ( accum -- ) + "P6\n" accum push-all + width number>string accum push-all + " " accum push-all + height number>string accum push-all + "\n255\n" accum push-all ; inline -: buf-size ( -- n ) width height * 3 * 100 + ; +: buf-size ( -- n ) width height * 3 * 100 + ; inline : mandel ( -- data ) - [ - buf-size building set - width height ppm-header - nb-iter max-color min cols set - render - building get >byte-array - ] with-scope ; + buf-size + [ ppm-header ] [ render ] [ B{ } like ] tri ; : mandel-main ( -- ) mandel "mandel.ppm" temp-file binary set-file-contents ; diff --git a/extra/benchmark/mandel/params/params.factor b/extra/benchmark/mandel/params/params.factor new file mode 100644 index 0000000000..3fcfe1d3ef --- /dev/null +++ b/extra/benchmark/mandel/params/params.factor @@ -0,0 +1,8 @@ +IN: benchmark.mandel.params + +: max-color 360 ; inline +: zoom-fact 0.8 ; inline +: width 640 ; inline +: height 480 ; inline +: nb-iter 40 ; inline +: center -0.65 ; inline From 4be346cd9c563edac3b4198c0a4420421c666e80 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Sep 2008 18:34:16 -0500 Subject: [PATCH 007/121] Fixing PowerPC intrinsics --- basis/cpu/ppc/intrinsics/intrinsics.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index 6413cf839c..0109bbb26a 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/basis/cpu/ppc/intrinsics/intrinsics.factor @@ -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+ { "scratch" } } { +clobber+ { "value" "offset" } } } ; From 79970222ddba9b98698389cbff8bd11be5ef7b52 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:43:52 -0500 Subject: [PATCH 008/121] xml new accessors --- basis/xml/errors/errors.factor | 2 +- basis/xml/tokenize/tokenize.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/xml/errors/errors.factor b/basis/xml/errors/errors.factor index 1ef26883e3..9b5b5d6568 100644 --- a/basis/xml/errors/errors.factor +++ b/basis/xml/errors/errors.factor @@ -53,7 +53,7 @@ M: mismatched summary ( obj -- str ) TUPLE: unclosed < parsing-error tags ; : ( -- unclosed ) unclosed parsing-error - xml-stack get rest-slice [ first opener-name ] map >>tags ; + xml-stack get rest-slice [ first name>> ] map >>tags ; M: unclosed summary ( obj -- str ) [ dup call-next-method write diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index 284f53023d..2e91c23f60 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -49,7 +49,7 @@ SYMBOL: ns-stack ! Parsing names : version=1.0? ( -- ? ) - prolog-data get prolog-version "1.0" = ; + prolog-data get version>> "1.0" = ; ! version=1.0? is calculated once and passed around for efficiency @@ -69,7 +69,7 @@ SYMBOL: ns-stack : (parse-entity) ( string -- ) dup entities at [ , ] [ - prolog-data get prolog-standalone + prolog-data get standalone>> [ throw ] [ dup extra-entities get at [ , ] [ throw ] ?if From 2a6e71735dd0accf01b9199e2490e5c1cbad8013 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:44:07 -0500 Subject: [PATCH 009/121] new accessors --- extra/faq/faq.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 47d3727703..525cef68ed 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -18,15 +18,15 @@ C: q/a : li>q/a ( li -- q/a ) [ "br" tag-named*? not ] filter [ "strong" tag-named*? ] find-after - >r tag-children r> ; + >r children>> r> ; : q/a>li ( q/a -- li ) [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep answer>> append "li" build-tag* ; : xml>q/a ( xml -- q/a ) - [ "question" tag-named tag-children ] keep - "answer" tag-named tag-children ; + [ "question" tag-named children>> ] keep + "answer" tag-named children>> ; : q/a>xml ( q/a -- xml ) [ question>> "question" build-tag* ] keep @@ -39,7 +39,7 @@ C: question-list : xml>question-list ( list -- question-list ) [ "title" swap at ] keep - tag-children [ tag? ] filter [ xml>q/a ] map + children>> [ tag? ] filter [ xml>q/a ] map ; : question-list>xml ( question-list -- list ) From e60dce86f65e40405252462330b5ec6f2e45409e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:44:14 -0500 Subject: [PATCH 010/121] new accessors --- extra/furnace/furnace.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 45aa55f050..11250ba644 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -176,7 +176,7 @@ CHLOE: a [ link-attrs ] [ "method" optional-attr "post" or =method ] [ "action" required-attr resolve-base-path =action ] - [ tag-attrs non-chloe-attrs-only print-attrs ] + [ attrs>> non-chloe-attrs-only print-attrs ] } cleave form> ] @@ -196,13 +196,13 @@ STRING: button-tag-markup ; : add-tag-attrs ( attrs tag -- ) - tag-attrs swap update ; + attrs>> swap update ; CHLOE: button button-tag-markup string>xml delegate { - [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ] - [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] + [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] [ [ children>string 1array ] dip "button" tag-named set-tag-children ] [ nip ] } 2cleave process-chloe-tag ; From 85bd1ef666f083863efc7e9f14dd877c864c1905 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:44:20 -0500 Subject: [PATCH 011/121] new accessors --- extra/html/templates/chloe/chloe.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 67a7dc2045..afbd82fed4 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -22,10 +22,10 @@ C: chloe DEFER: process-template : chloe-attrs-only ( assoc -- assoc' ) - [ drop name-url chloe-ns = ] assoc-filter ; + [ drop url>> chloe-ns = ] assoc-filter ; : non-chloe-attrs-only ( assoc -- assoc' ) - [ drop name-url chloe-ns = not ] assoc-filter ; + [ drop url>> chloe-ns = not ] assoc-filter ; : chloe-tag? ( tag -- ? ) dup xml? [ body>> ] when @@ -148,10 +148,10 @@ CHLOE-TUPLE: code process-template ] [ { - [ xml-prolog write-prolog ] - [ xml-before write-chunk ] + [ prolog>> write-prolog ] + [ before>> write-chunk ] [ process-template ] - [ xml-after write-chunk ] + [ after>> write-chunk ] } cleave ] if ] with-scope ; From 58487c07e149126df30981caa72b1c8e1d3a5461 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:44:27 -0500 Subject: [PATCH 012/121] new accessors --- extra/springies/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 75d3087fe5..f9a97ba945 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -10,7 +10,7 @@ IN: springies.ui : draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; : draw-spring ( spring -- ) - [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ; + [ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ; : draw-nodes ( -- ) nodes> [ draw-node ] each ; From 99391719771e6bd79375b859ae01083847dfed69 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:44:35 -0500 Subject: [PATCH 013/121] new accessors --- extra/x/widgets/wm/workspace/workspace.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/x/widgets/wm/workspace/workspace.factor b/extra/x/widgets/wm/workspace/workspace.factor index 104021706f..c11ad7e04d 100644 --- a/extra/x/widgets/wm/workspace/workspace.factor +++ b/extra/x/widgets/wm/workspace/workspace.factor @@ -1,5 +1,6 @@ -USING: kernel namespaces namespaces.lib math sequences vars mortar slot-accessors x ; +USING: kernel namespaces namespaces.lib math sequences vars mortar +accessors slot-accessors x ; IN: x.widgets.wm.workspace @@ -23,9 +24,9 @@ dpy get $default-root <- children [ <- mapped? ] filter ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : switch-to-workspace ( n -- ) -mapped-windows current-workspace> workspaces> nth set-workspace-windows +mapped-windows current-workspace> workspaces> nth (>>windows) mapped-windows [ <- unmap drop ] each -dup workspaces> nth workspace-windows [ <- map drop ] each +dup workspaces> nth windows>> [ <- map drop ] each current-workspace set* ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 99dcd73901eb634ee390ca0005b53cf72886d1af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 18:51:05 -0500 Subject: [PATCH 014/121] fix teh windows --- basis/windows/time/time.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor index 63b12de1ff..5e23f8cc01 100644 --- a/basis/windows/time/time.factor +++ b/basis/windows/time/time.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types kernel math windows windows.kernel32 -namespaces calendar calendar.backend ; +namespaces calendar ; IN: windows.time : >64bit ( lo hi -- n ) From f958bf4ebcccc6bf0ac88028a9eb519c978f792e Mon Sep 17 00:00:00 2001 From: dharmatech Date: Mon, 1 Sep 2008 18:57:12 -0500 Subject: [PATCH 015/121] Update old accessors from 'ui.cocoa' --- basis/ui/cocoa/cocoa.factor | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 8d176b9c63..40592cad30 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 @@ -47,26 +47,26 @@ M: pasteboard set-clipboard-contents ] keep set-world-handle ; M: cocoa-ui-backend set-title ( string world -- ) - world-handle handle-window swap -> setTitle: ; + world-handle window>> swap -> setTitle: ; : enter-fullscreen ( world -- ) - world-handle handle-view + world-handle view>> NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; : exit-fullscreen ( world -- ) - world-handle handle-view f -> exitFullScreenModeWithOptions: ; + world-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 ; + world-handle view>> -> isInFullScreenMode zero? not ; : auto-position ( world -- ) dup window-loc>> { 0 0 } = [ - world-handle handle-window -> center + world-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: ; + world-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: + window>> f -> performClose: ] when* ] when* ; M: cocoa-ui-backend raise-window* ( world -- ) world-handle [ - handle-window dup f -> orderFront: -> makeKeyWindow + 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 ; From 36151938b381279628537fc92a36b2091618d97e Mon Sep 17 00:00:00 2001 From: dharmatech Date: Mon, 1 Sep 2008 19:02:44 -0500 Subject: [PATCH 016/121] Update old accessors from 'ui.cocoa' --- basis/ui/cocoa/cocoa.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 40592cad30..1a05d23aa0 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -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 window>> swap -> setTitle: ; + handle>> window>> swap -> setTitle: ; : enter-fullscreen ( world -- ) - world-handle view>> + handle>> view>> NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; : exit-fullscreen ( world -- ) - world-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 view>> -> isInFullScreenMode zero? not ; + handle>> view>> -> isInFullScreenMode zero? not ; : auto-position ( world -- ) dup window-loc>> { 0 0 } = [ - world-handle window>> -> center + handle>> window>> -> center ] [ drop ] if ; @@ -74,20 +74,20 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) M: cocoa-ui-backend (open-window) ( world -- ) dup gadget-window dup auto-position - world-handle window>> f -> makeKeyAndOrderFront: ; + handle>> window>> f -> makeKeyAndOrderFront: ; M: cocoa-ui-backend (close-window) ( handle -- ) window>> -> release ; M: cocoa-ui-backend close-window ( gadget -- ) find-world [ - world-handle [ + handle>> [ window>> f -> performClose: ] when* ] when* ; M: cocoa-ui-backend raise-window* ( world -- ) - world-handle [ + handle>> [ window>> dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: ] when* ; From c8cecf87687bb0d038deb2b24e41e2f8ed0d939f Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 1 Sep 2008 19:06:00 -0500 Subject: [PATCH 017/121] Fix stack effect declarations --- basis/cpu/ppc/architecture/architecture.factor | 14 +++++++------- basis/cpu/ppc/intrinsics/intrinsics.factor | 10 +++++----- 2 files changed, 12 insertions(+), 12 deletions(-) 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..7b77ce98de 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 From 6cff5eb76fcda8187f75d8d3398ae39a2319f262 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 19:10:34 -0500 Subject: [PATCH 018/121] write-item writes parts of xml, so add a method on xml objects to make it write their bodies without the prolog --- basis/xml/writer/writer.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 13f0be431c..8bda10102d 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -110,6 +110,9 @@ M: instruction write-item [ after>> write-chunk ] } cleave ; +M: xml write-item + body>> write-item ; + : print-xml ( xml -- ) write-xml nl ; From c0098e6a52482135b493134f56cbfb592e0301fe Mon Sep 17 00:00:00 2001 From: "U-CUTLER\\dharmatech" Date: Mon, 1 Sep 2008 19:55:21 -0500 Subject: [PATCH 019/121] Update old accessors from 'ui.windows' --- basis/ui/windows/windows.factor | 34 ++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 44bfbf3877..5f67ed4a4b 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -208,7 +208,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; hWnd window-focus send-gesture drop ; :: set-window-active ( hwnd uMsg wParam lParam ? -- n ) - ? hwnd window set-world-active? + ? hwnd window (>>active?) hwnd uMsg wParam lParam DefWindowProc ; : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) @@ -221,14 +221,14 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; } cond ; : cleanup-window ( handle -- ) - dup win-title [ free ] when* - dup win-hRC wglDeleteContext win32-error=0/f - dup win-hWnd swap win-hDC ReleaseDC win32-error=0/f ; + dup title>> [ free ] when* + dup hRC>> wglDeleteContext win32-error=0/f + dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ; M: windows-ui-backend (close-window) - dup win-hWnd unregister-window + dup hWnd>> unregister-window dup cleanup-window - win-hWnd DestroyWindow win32-error=0/f ; + hWnd>> DestroyWindow win32-error=0/f ; : handle-wm-close ( hWnd uMsg wParam lParam -- ) 3drop window ungraft ; @@ -472,28 +472,28 @@ M: windows-ui-backend do-events M: windows-ui-backend (open-window) ( world -- ) [ create-window dup setup-gl ] keep [ f ] keep - [ swap win-hWnd register-window ] 2keep - dupd set-world-handle - win-hWnd show-window ; + [ swap hWnd>> register-window ] 2keep + dupd (>>handle) + hWnd>> show-window ; M: windows-ui-backend select-gl-context ( handle -- ) - [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ; + [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ; M: windows-ui-backend flush-gl-context ( handle -- ) - win-hDC SwapBuffers win32-error=0/f ; + hDC>> SwapBuffers win32-error=0/f ; ! Move window to front M: windows-ui-backend raise-window* ( world -- ) - world-handle [ - win-hWnd SetFocus drop + handle>> [ + hWnd>> SetFocus drop ] when* ; M: windows-ui-backend set-title ( string world -- ) - world-handle - dup win-title [ free ] when* + handle>> + dup title>> [ free ] when* >r utf16n malloc-string r> - 2dup set-win-title - win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ; + 2dup (>>title) + hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ; M: windows-ui-backend ui [ From f4dfa63452657ceabdce8ddc01ba2b26ed44518d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 20:09:51 -0500 Subject: [PATCH 020/121] dt>seconds -> duration>seconds --- extra/animations/animations.factor | 2 +- extra/http/http.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index 803536a51c..8ac4abe1fa 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -11,7 +11,7 @@ SYMBOL: sleep-period ! : my-progress ( -- progress ) millis : progress ( -- progress ) millis last-loop get - reset-progress ; : progress-peek ( -- progress ) millis last-loop get - ; -: set-end ( duration -- end-time ) dt>milliseconds millis + ; +: set-end ( duration -- end-time ) duration>milliseconds millis + ; : loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline : animate ( quot duration -- ) reset-progress set-end loop ; inline : sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline \ No newline at end of file diff --git a/extra/http/http.factor b/extra/http/http.factor index 70848ed9f6..2a5a19036f 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -106,7 +106,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s [ { { [ dup timestamp? ] [ timestamp>cookie-string ] } - { [ dup duration? ] [ dt>seconds number>string ] } + { [ dup duration? ] [ duration>seconds number>string ] } { [ dup real? ] [ number>string ] } [ ] } cond From 38b868616149e8c94d4a40f0c176f0c9e54cf07f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 20:10:10 -0500 Subject: [PATCH 021/121] dt -> duration, lots of docs --- basis/calendar/calendar-docs.factor | 108 +++++++++++++++++----- basis/calendar/calendar.factor | 16 ++-- basis/calendar/format/format-tests.factor | 10 +- 3 files changed, 96 insertions(+), 38 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index cf60d40bf6..81e9bdff28 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- @@ -491,3 +493,59 @@ 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 time+ } +{ $subsection time- } +{ $subsection time* } +"Getting the current timestamp:" +{ $subsection now } +{ $subsection gmt } +"Converting between timestamps:" +{ $subsection >local-time } +{ $subsection >gmt } +"Timestamps relative to each other:" +{ $subsection "relative-timestamps" } +; + +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 } +"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" +"Getting a relative timestamp:" +{ $subsection hence } +{ $subsection ago } +{ $subsection before } +"Days of the week relative to " { $link now } ":" +{ $subsection sunday } +{ $subsection monday } +{ $subsection tuesday } +{ $subsection wednesday } +{ $subsection thursday } +{ $subsection friday } +{ $subsection saturday } +; + +ABOUT: "calendar" diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 096546349d..57f57f04a9 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 ) diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 3efe33e265..978a4dca7f 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 From 4f08a2caf6adb3dd142ed143ff3c42cab790abc6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 21:36:34 -0500 Subject: [PATCH 022/121] new accessor --- basis/xml/tests/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 2dd2b848be..f2bd5ce1e3 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -21,7 +21,7 @@ SYMBOL: xml-file [ t ] [ xml-file get children>> second contained-tag? ] unit-test [ "" string>xml ] [ xml-parse-error? ] must-fail-with [ T{ comment f "This is where the fun begins!" } ] [ - xml-file get xml-before [ comment? ] find nip + xml-file get before>> [ comment? ] find nip ] unit-test [ "xsl stylesheet=\"that-one.xsl\"" ] [ xml-file get after>> [ instruction? ] find nip text>> From 82d0b71b493f55f3a0efe0c4d1174616547e19ab Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:16:51 -0500 Subject: [PATCH 023/121] move words to private, more docs --- basis/calendar/calendar-docs.factor | 83 ++++++++++++++++++++++++----- basis/calendar/calendar.factor | 6 +++ 2 files changed, 75 insertions(+), 14 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 81e9bdff28..e3e5338820 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -430,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." } ; @@ -501,19 +491,33 @@ ARTICLE: "calendar" "Calendar" "Durations represent spans of time:" { $subsection "using-durations" } "Arithmetic on timestamps and durations:" -{ $subsection time+ } -{ $subsection time- } -{ $subsection time* } +{ $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 } @@ -524,6 +528,7 @@ ARTICLE: "using-durations" "Using durations" { $subsection minutes } { $subsection seconds } { $subsection milliseconds } +{ $subsection instant } "Converting a duration to a number:" { $subsection duration>years } { $subsection duration>months } @@ -534,9 +539,11 @@ ARTICLE: "using-durations" "Using durations" { $subsection duration>milliseconds } ; ARTICLE: "relative-timestamps" "Relative timestamps" -"Getting a relative timestamp:" +"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 } @@ -546,6 +553,54 @@ ARTICLE: "relative-timestamps" "Relative timestamps" { $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.factor b/basis/calendar/calendar.factor index 57f57f04a9..a904999316 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -278,10 +278,12 @@ GENERIC: time- ( time1 time2 -- time3 ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; +gmt ] bi@ [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ; +PRIVATE> M: timestamp time- #! Exact calendar-time difference @@ -344,8 +346,10 @@ GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; + : days-in-month ( timestamp -- n ) >date< drop (days-in-month) ; @@ -364,11 +368,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 ; From 99a0f0f1357530bfe00628475ae61f2d8fe33dc0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:43:02 -0500 Subject: [PATCH 024/121] new accessors --- basis/ui/gadgets/borders/borders.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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* From 191a8b3206a0ee071222742dae26a4ff22c723fe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:43:23 -0500 Subject: [PATCH 025/121] new accessors --- basis/ui/gadgets/buttons/buttons.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 ; From 5d1da809b6e8b38d48f17eb710831e1d235d2253 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:43:40 -0500 Subject: [PATCH 026/121] new accessors --- basis/ui/gadgets/grids/grids.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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?>> [ From 04d2f955361e2fb0c7fc381edec608218a7f10c5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:43:56 -0500 Subject: [PATCH 027/121] new accessors --- basis/ui/gadgets/incremental/incremental.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 ; From e060a103b22dbace0acdfe57a389f54fa453d233 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:44:10 -0500 Subject: [PATCH 028/121] new accessors --- basis/ui/gadgets/labels/labels.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From c99ac86a3fb3d561643db61221d840a393ad59f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:44:29 -0500 Subject: [PATCH 029/121] new accessors --- basis/ui/gadgets/menus/menus.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ; From fbe6dd9b63106583f00aeab6fc65d6ef462f2251 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:44:43 -0500 Subject: [PATCH 030/121] new accessors --- basis/ui/gadgets/packs/packs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 065c9eb93ef500c76375bc120fffa4301f2cc99f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:44:54 -0500 Subject: [PATCH 031/121] new accessors --- basis/ui/gadgets/paragraphs/paragraphs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ; From 5798940ee94670005c16dfb224073d40751db919 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:45:04 -0500 Subject: [PATCH 032/121] new accessors --- basis/ui/gadgets/sliders/sliders.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 08551f3834..8d673e66ad 100755 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -104,7 +104,7 @@ elevator H{ : layout-thumb-loc ( slider -- ) dup thumb-loc (layout-thumb) - >r [ floor ] map r> set-rect-loc ; + >r [ floor ] map r> (>>loc) ; : layout-thumb-dim ( slider -- ) dup dup thumb-dim (layout-thumb) >r From fc848a4e6d171546de1f3a0b46cf4a6f87682bbd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:45:13 -0500 Subject: [PATCH 033/121] new accessors --- basis/ui/gadgets/status-bar/status-bar-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 3f08c04e95..6203cd474e 100755 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -5,4 +5,4 @@ IN: ui.gadgets.status-bar HELP: { $values { "model" model } { "gadget" "a new " { $link gadget } } } { $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." } -{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ; +{ $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ; From 60a3cf862be182167cc4081d92e5b642e1708ca2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:45:23 -0500 Subject: [PATCH 034/121] new accessors --- basis/ui/gadgets/viewports/viewports.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor index 79aca6bd35..c6e4b044cd 100755 --- a/basis/ui/gadgets/viewports/viewports.factor +++ b/basis/ui/gadgets/viewports/viewports.factor @@ -38,7 +38,7 @@ M: viewport model-changed dup relayout-1 dup scroller-value vneg viewport-gap v+ - swap gadget-child set-rect-loc ; + swap gadget-child (>>loc) ; : visible-dim ( gadget -- dim ) dup parent>> viewport? From e1935484899a712d93d69a0d6b6b86498f1580f8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:45:40 -0500 Subject: [PATCH 035/121] new accessors --- basis/ui/gadgets/worlds/worlds.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 80228691ec..23237af668 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -13,12 +13,10 @@ title status fonts handle window-loc ; -: find-world ( gadget -- world ) [ world? ] find-parent ; - -M: f world-status ; +: find-world ( gadget -- world/f ) [ world? ] find-parent ; : show-status ( string/f gadget -- ) - find-world world-status [ set-model ] [ drop ] if* ; + find-world dup [ status>> set-model ] [ 2drop ] if ; : hide-status ( gadget -- ) f swap show-status ; From 46e9481cb6e23c384dd5f4be94594e8fee3728e1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:46:00 -0500 Subject: [PATCH 036/121] new accessors --- basis/ui/tools/interactor/interactor.factor | 2 +- basis/ui/tools/profiler/profiler.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 39f10f42ae..a36610a7f5 100755 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -61,7 +61,7 @@ M: interactor ungraft* M: interactor model-changed 2dup help>> eq? [ - swap model-value over word-at-loc swap show-summary + swap value>> over word-at-loc swap show-summary ] [ call-next-method ] if ; diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 462af87574..98717fc7bc 100755 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -39,10 +39,10 @@ profiler-gadget "toolbar" f { GENERIC: profiler-presentation ( obj -- quot ) M: usage-profile profiler-presentation - usage-profile-word [ usage-profile. ] curry ; + word>> [ usage-profile. ] curry ; M: vocab-profile profiler-presentation - vocab-profile-vocab [ vocab-profile. ] curry ; + vocab>> [ vocab-profile. ] curry ; M: f profiler-presentation drop [ vocabs-profile. ] ; From f9c4cd963e0046e53b67d9cf67671df1ebf451e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:46:18 -0500 Subject: [PATCH 037/121] new accessors --- basis/ui/ui-docs.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 344b9caa76..e086b7ebae 100755 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -237,14 +237,12 @@ $nl ; ARTICLE: "ui-null-layout" "Manual layouts" -"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:" -{ $subsection set-rect-loc } ; +"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ; ARTICLE: "ui-layout-impl" "Implementing layout gadgets" "The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:" { $subsection layout* } -"When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized with a pair of words:" -{ $subsection set-rect-loc } +"When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized by setting a pair of slots, " { $snippet "loc" } " and " { $snippet "dim" } "." $nl "Some assorted utility words which are useful for implementing layout logic:" { $subsection pref-dim } { $subsection pref-dims } From eb209a723abb80d70c1faddb2c7a407308df2dfb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:46:34 -0500 Subject: [PATCH 038/121] new accessors --- basis/io/sockets/sockets.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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 From 0e80ac5460624ae5f79c092e95cee7b190dcaf55 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:46:49 -0500 Subject: [PATCH 039/121] new accessors --- basis/math/geometry/rect/rect-docs.factor | 5 ----- basis/math/geometry/rect/rect.factor | 7 +++++++ 2 files changed, 7 insertions(+), 5 deletions(-) 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+ ; From 52acaa47e725ec0679b6a5750e65074c17c5bd28 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 1 Sep 2008 22:47:07 -0500 Subject: [PATCH 040/121] new accessors --- basis/models/compose/compose.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 ; From 046b8b9cbe37c1a8a751d0f1958c3eba94ffa8f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 00:45:40 -0500 Subject: [PATCH 041/121] fix xml for new accessors --- basis/xml/data/data.factor | 8 ++++---- basis/xml/errors/errors.factor | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 1bab8d0374..0af2ec4700 100755 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private assocs arrays delegate.protocols delegate vectors accessors multiline -macros words quotations combinators ; +macros words quotations combinators slots ; IN: xml.data TUPLE: name space main url ; @@ -89,7 +89,7 @@ TUPLE: tag name attrs children ; tag boa ; ! For convenience, tags follow the assoc protocol too (for attrs) -CONSULT: assoc-protocol tag tag-attrs ; +CONSULT: assoc-protocol tag attrs>> ; INSTANCE: tag assoc ! They also follow the sequence protocol (for children) @@ -100,14 +100,14 @@ CONSULT: name tag name>> ; M: tag like over tag? [ drop ] [ - [ name>> ] keep tag-attrs + [ name>> ] keep attrs>> rot dup [ V{ } like ] when ] if ; MACRO: clone-slots ( class -- tuple ) [ "slots" word-prop - [ reader>> 1quotation [ clone ] compose ] map + [ name>> reader-word 1quotation [ clone ] compose ] map [ cleave ] curry ] [ [ boa ] curry ] bi compose ; diff --git a/basis/xml/errors/errors.factor b/basis/xml/errors/errors.factor index 9b5b5d6568..bafa325e89 100644 --- a/basis/xml/errors/errors.factor +++ b/basis/xml/errors/errors.factor @@ -171,7 +171,7 @@ M: bad-directive summary ( obj -- str ) [ dup call-next-method write "Misplaced directive:" print - bad-directive-dir write-item nl + dir>> write-item nl ] with-string-writer ; UNION: xml-parse-error multitags notags extra-attrs nonexist-ns From 731bd1c88a0efa6d6c7408a8c22a28d4c0b82e90 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 01:52:22 -0500 Subject: [PATCH 042/121] fix ui unit tests for new accessors --- basis/ui/gadgets/buttons/buttons-tests.factor | 9 +-- basis/ui/gadgets/editors/editors-tests.factor | 5 +- basis/ui/gadgets/gadgets-tests.factor | 66 +++++++++---------- basis/ui/gadgets/grids/grids-tests.factor | 6 +- basis/ui/gadgets/panes/panes-tests.factor | 6 +- .../presentations/presentations-tests.factor | 6 +- .../gadgets/scrollers/scrollers-tests.factor | 36 +++++----- basis/ui/gadgets/worlds/worlds-tests.factor | 16 ++--- basis/ui/operations/operations-tests.factor | 4 +- basis/ui/tools/listener/listener-tests.factor | 2 +- basis/ui/tools/search/search-tests.factor | 6 +- basis/ui/tools/tools-tests.factor | 8 +-- basis/ui/traverse/traverse-tests.factor | 6 +- 13 files changed, 87 insertions(+), 89 deletions(-) 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/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/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/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" <" ] [ [ From 4dc89ae42785cc2f700adb2dff036171ec4d9e44 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 13:07:37 -0500 Subject: [PATCH 085/121] fix tests --- extra/math/statistics/statistics-tests.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/math/statistics/statistics-tests.factor b/extra/math/statistics/statistics-tests.factor index 0884e1aed2..b6ff421956 100644 --- a/extra/math/statistics/statistics-tests.factor +++ b/extra/math/statistics/statistics-tests.factor @@ -5,7 +5,7 @@ IN: math.statistics.tests [ 3/2 ] [ { 1 2 } mean ] unit-test [ 0 ] [ { 0 0 0 } geometric-mean ] unit-test [ t ] [ { 2 2 2 2 } geometric-mean 2.0 .0001 ~ ] unit-test -[ 1 ] [ { 1 1 1 } geometric-mean ] unit-test +[ 1.0 ] [ { 1 1 1 } geometric-mean ] unit-test [ 1/3 ] [ { 1 1 1 } harmonic-mean ] unit-test [ 0 ] [ { 1 } range ] unit-test @@ -14,12 +14,11 @@ IN: math.statistics.tests [ 5/2 ] [ { 1 2 3 4 } median ] unit-test [ 1 ] [ { 1 2 3 } var ] unit-test -[ 1 ] [ { 1 2 3 } std ] unit-test +[ 1.0 ] [ { 1 2 3 } std ] unit-test [ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test [ t ] [ { 23.2 33.4 22.5 66.3 44.5 } std 18.1906 - .0001 < ] unit-test [ 0 ] [ { 1 } var ] unit-test -[ 0 ] [ { 1 } std ] unit-test -[ 0 ] [ { 1 } ste ] unit-test - +[ 0.0 ] [ { 1 } std ] unit-test +[ 0.0 ] [ { 1 } ste ] unit-test From b7c83ff83eefa5a83da70b77d0e5cf1e31fe25cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 13:42:05 -0500 Subject: [PATCH 086/121] new accessors --- basis/io/windows/launcher/launcher.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From a5660aa55d7e1aa33ebeff76a7f49f0fb4bb7dc4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:08:23 -0500 Subject: [PATCH 087/121] new accessors --- extra/db/tuples/tuples-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index f5b74b51c8..5dd3ec8ae0 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/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 From 1b88074853f9a7a3be1227b1cf14687c74d347a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:09:14 -0500 Subject: [PATCH 088/121] floating point test fix --- extra/json/reader/reader-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor index 4b7bd56f01..995ae0e0b8 100644 --- a/extra/json/reader/reader-tests.factor +++ b/extra/json/reader/reader-tests.factor @@ -11,9 +11,9 @@ IN: json.reader.tests { 102.0 } [ "102.0" json> ] unit-test { 102.5 } [ "102.5" json> ] unit-test { 102.5 } [ "102.50" json> ] unit-test -{ -10250 } [ "-102.5e2" json> ] unit-test -{ -10250 } [ "-102.5E+2" json> ] unit-test -{ 10.25 } [ "1025e-2" json> ] unit-test +{ -10250.0 } [ "-102.5e2" json> ] unit-test +{ -10250.0 } [ "-102.5E+2" json> ] unit-test +{ 10+1/4 } [ "1025e-2" json> ] unit-test { 0.125 } [ "0.125" json> ] unit-test { -0.125 } [ "-0.125" json> ] unit-test From 8d260bb01ba462987f429a263cdf421b2713c039 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:10:02 -0500 Subject: [PATCH 089/121] fix test --- extra/math/polynomials/polynomials-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/polynomials/polynomials-tests.factor b/extra/math/polynomials/polynomials-tests.factor index 73215f9167..cccf24fbff 100644 --- a/extra/math/polynomials/polynomials-tests.factor +++ b/extra/math/polynomials/polynomials-tests.factor @@ -22,7 +22,7 @@ USING: kernel math math.polynomials tools.test ; [ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 } p/mod ] unit-test [ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 0 0 0 0 0 0 } p/mod ] unit-test [ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 0 0 0 0 } { 1 1 0 0 } p/mod ] unit-test -[ V{ 5.0 } V{ 0.0 } ] [ { 10.0 } { 2.0 } p/mod ] unit-test +[ V{ 5.0 } V{ 0 } ] [ { 10.0 } { 2.0 } p/mod ] unit-test [ V{ 15/16 } V{ 0 } ] [ { 3/4 } { 4/5 } p/mod ] unit-test [ t ] [ { 0 1 } { 0 1 0 } p= ] unit-test [ f ] [ { 0 0 1 } { 0 1 0 } p= ] unit-test From 591839db9cac26134f9ee15458228a213f43cf40 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:10:37 -0500 Subject: [PATCH 090/121] fix tests --- extra/math/quaternions/quaternions-tests.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/math/quaternions/quaternions-tests.factor b/extra/math/quaternions/quaternions-tests.factor index b30a1bc271..a6d255e421 100644 --- a/extra/math/quaternions/quaternions-tests.factor +++ b/extra/math/quaternions/quaternions-tests.factor @@ -2,11 +2,11 @@ IN: math.quaternions.tests USING: tools.test math.quaternions kernel math.vectors math.constants ; -[ 1 ] [ qi norm ] unit-test -[ 1 ] [ qj norm ] unit-test -[ 1 ] [ qk norm ] unit-test -[ 1 ] [ q1 norm ] unit-test -[ 0 ] [ q0 norm ] unit-test +[ 1.0 ] [ qi norm ] unit-test +[ 1.0 ] [ qj norm ] unit-test +[ 1.0 ] [ qk norm ] unit-test +[ 1.0 ] [ q1 norm ] unit-test +[ 0.0 ] [ q0 norm ] unit-test [ t ] [ qi qj q* qk = ] unit-test [ t ] [ qj qk q* qi = ] unit-test [ t ] [ qk qi q* qj = ] unit-test From 3dc4de438976385dd03dececa35608facb87175a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:13:01 -0500 Subject: [PATCH 091/121] new accessors --- extra/peg/ebnf/ebnf-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 47f19920c7..a6d3cf0b21 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -105,11 +105,11 @@ IN: peg.ebnf.tests ] unit-test { "foo" } [ - "foo" 'non-terminal' parse ebnf-non-terminal-symbol + "foo" 'non-terminal' parse symbol>> ] unit-test { "foo" } [ - "foo]" 'non-terminal' parse ebnf-non-terminal-symbol + "foo]" 'non-terminal' parse symbol>> ] unit-test { V{ "a" "b" } } [ From bb8fcf245f5bc660b8b03e5d8ab64100b7f9d278 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:17:18 -0500 Subject: [PATCH 092/121] fix math docs --- core/math/math-docs.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 07e2de2f8f..cc59094529 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -66,7 +66,7 @@ HELP: number= { $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." } { $examples { $example "USING: math prettyprint ;" "3.0 3 number= ." "t" } - { $example "USING: math prettyprint ;" "3.0 3 = ." "f" } + { $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" } } ; HELP: < @@ -294,7 +294,7 @@ HELP: times { $description "Calls the quotation " { $snippet "n" } " times." } { $notes "If you need to pass the current index to the quotation, use " { $link each } "." } { $examples - { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi\n" } + { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" } } ; HELP: fp-nan? @@ -304,14 +304,14 @@ HELP: fp-nan? HELP: real-part { $values { "z" number } { "x" real } } { $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } -{ $examples { $example "C{ 1 2 } real-part ." "1" } } ; +{ $examples { $example "USING: math prettyprint ; C{ 1 2 } real-part ." "1" } } ; HELP: imaginary-part { $values { "z" number } { "y" real } } { $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } { $examples - { $example "C{ 1 2 } imaginary-part ." "2" } - { $example "3 imaginary-part ." "0" } + { $example "USING: math prettyprint ; C{ 1 2 } imaginary-part ." "2" } + { $example "USING: math prettyprint ; 3 imaginary-part ." "0" } } ; HELP: real From eb48b92711a9732280b15190567c7621f4710db5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:19:23 -0500 Subject: [PATCH 093/121] fix docs --- basis/ui/gadgets/worlds/worlds-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index f3b85a2861..122d14eed7 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -46,7 +46,7 @@ HELP: { $description "Creates a new " { $link world } " delegating to the given gadget." } ; HELP: find-world -{ $values { "gadget" gadget } { "world" "a " { $link world } " or " { $link f } } } +{ $values { "gadget" gadget } { "world/f" "a " { $link world } " or " { $link f } } } { $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ; HELP: draw-world From 99f442c2c7e797608ef3f4b3c52dd71104d62ee8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:19:32 -0500 Subject: [PATCH 094/121] fix docs --- core/syntax/syntax-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index df0c1b67e8..57dec876a5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -390,7 +390,7 @@ HELP: P" { $syntax "P\" pathname\"" } { $values { "pathname" "a pathname string" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", creates a new " { $link pathname } ", and appends it to the parse tree." } -{ $examples { $example "USING: io io.files ;" "P\" foo.txt\" pathname-string print" "foo.txt" } } ; +{ $examples { $example "USING: accessors io io.files ;" "P\" foo.txt\" string>> print" "foo.txt" } } ; HELP: ( { $syntax "( inputs -- outputs )" } From bbcba1a7f64ff0f2b1cbc19f5bfa7de4efc29f6e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:22:56 -0500 Subject: [PATCH 095/121] fix docs --- core/vocabs/vocabs-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index 0d55499620..328dce9b03 100755 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -46,19 +46,19 @@ HELP: vocab { $class-description "Instances represent vocabularies." } ; HELP: vocab-name -{ $values { "vocab" "a vocabulary specifier" } { "name" string } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "name" string } } { $description "Outputs the name of a vocabulary." } ; HELP: vocab-words -{ $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } } { $description "Outputs the words defined in a vocabulary." } ; HELP: vocab-source-loaded? -{ $values { "vocab" "a vocabulary specifier" } { "source-loaded?" "a boolean" } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "?" "a boolean" } } { $description "Outputs if the source for this vocubulary has been loaded." } ; HELP: vocab-docs-loaded? -{ $values { "vocab" "a vocabulary specifier" } { "docs-loaded?" "a boolean" } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "?" "a boolean" } } { $description "Outputs if the documentation for this vocubulary has been loaded." } ; HELP: words From 13722dd4a888e2116de70eb28515cfd4fff12c2e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 15:34:40 -0500 Subject: [PATCH 096/121] fix help --- extra/math/derivatives/derivatives-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index 8e561f38ae..bbb793fe92 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -71,8 +71,8 @@ HELP: derivative-func { $examples { $example "USING: kernel math.derivatives math.functions math.trig prettyprint ;" - "60 deg>rad [ sin ] derivative-func call ." - "0.5000000000000173" + "60 deg>rad [ sin ] derivative-func call 0.5 .001 ~ ." + "t" } { $notes "Without a heavy algebraic system, derivatives must be " From 56a1e8d0447eef00a67c8be7cb7d219132ccd9ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:01:19 -0500 Subject: [PATCH 097/121] fix readers>>, fix tests --- extra/inverse/inverse-tests.factor | 2 +- extra/inverse/inverse.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 3206636ea9..d106b1068a 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -32,7 +32,7 @@ C: foo : f>c ( *fahrenheit -- *celsius ) 32 - 1.8 / ; -[ { 212 32 } ] [ { 100 0 } [ [ f>c ] map ] undo ] unit-test +[ { 212.0 32.0 } ] [ { 100 0 } [ [ f>c ] map ] undo ] unit-test [ { t t f } ] [ { t f 1 } [ [ >boolean ] matches? ] map ] unit-test [ { t f } ] [ { { 1 2 3 } 4 } [ [ >array ] matches? ] map ] unit-test [ 9 9 ] [ 3 [ 1/2 ^ ] undo 3 [ sqrt ] undo ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 2340442d5b..1e71abf76d 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -208,7 +208,7 @@ DEFER: _ : slot-readers ( class -- quot ) all-slots rest ! tail gets rid of delegate - [ reader>> 1quotation [ keep ] curry ] map concat + [ name>> reader-word 1quotation [ keep ] curry ] map concat [ ] like [ drop ] compose ; : ?wrapped ( object -- wrapped ) From edd50715564bc628389429f3f0766c528920ab5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:03:38 -0500 Subject: [PATCH 098/121] fix test --- basis/float-vectors/float-vectors-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From 74a2e75c64820359ac5a6fd946e7af411c47d7ca Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:07:17 -0500 Subject: [PATCH 099/121] fix docs --- core/vocabs/loader/loader-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index e4cc6ac11f..ebaf8b3c8f 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -50,7 +50,7 @@ HELP: load-vocab { $error-description "Thrown by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " when a given vocabulary does not exist. Vocabularies must be created by " { $link POSTPONE: IN: } " before being used." } ; HELP: vocab-main -{ $values { "vocab" "a vocabulary specifier" } { "main" word } } +{ $values { "vocab-spec" "a vocabulary specifier" } { "main" word } } { $description "Outputs the main entry point for a vocabulary. The entry point can be executed with " { $link run } " and set with " { $link POSTPONE: MAIN: } "." } ; HELP: vocab-roots From f85e70a6ceb0400f70958d075356753df5091891 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:07:25 -0500 Subject: [PATCH 100/121] fix docs --- basis/help/help-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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: } "." } ; From cb45241fd72aee75a521a1b2e18b80e3e2921488 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:13:43 -0500 Subject: [PATCH 101/121] new accessors --- extra/springies/ui/ui.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index f9a97ba945..423a68cf0d 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -52,16 +52,14 @@ DEFER: maybe-loop : springies-window* ( -- ) - C[ display ] >slate - { 800 600 } slate> set-slate-pdim - C[ { 500 500 } >world-size loop on [ run ] in-thread ] - slate> set-slate-graft - C[ loop off ] slate> set-slate-ungraft - - slate> "Springies" open-window ; + C[ display ] + { 800 600 } >>pdim + C[ { 500 500 } >world-size loop on [ run ] in-thread ] >>graft + C[ loop off ] >>ungraft + [ >slate ] [ "Springies" open-window ] bi ; : springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ; \ No newline at end of file +: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ; From 5dbf68f3852192e708c245c123a3f084c371d463 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:49:21 -0500 Subject: [PATCH 102/121] update the docs --- basis/io/encodings/ascii/ascii-docs.factor | 9 +++++++-- basis/io/encodings/utf16/utf16-docs.factor | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) 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 } From 8df32ea9e4f041328645a3cedc25312aee44705e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:49:45 -0500 Subject: [PATCH 103/121] update the docs --- core/io/encodings/binary/binary-docs.factor | 9 +++++++-- core/io/encodings/utf8/utf8-docs.factor | 9 +++++++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor index 85045d8984..4da1e0811f 100644 --- a/core/io/encodings/binary/binary-docs.factor +++ b/core/io/encodings/binary/binary-docs.factor @@ -2,5 +2,10 @@ USING: help.syntax help.markup ; IN: io.encodings.binary HELP: binary -{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } -{ $see-also "encodings-introduction" } ; +{ $class-description "Encoding descriptor for binary I/O." } ; + +ARTICLE: "io.encodings.binary" "Binary encoding" +"Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." +{ $subsection binary } ; + +ABOUT: "io.encodings.binary" diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 1ac0252dbb..7e185fff69 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -2,5 +2,10 @@ USING: help.markup help.syntax ; IN: io.encodings.utf8 HELP: utf8 -{ $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." } -{ $see-also "encodings-introduction" } ; +{ $class-description "Encoding descriptor for UTF-8 encoding." } ; + +ARTICLE: "io.encodings.utf8" "UTF-8 encoding" +"UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." +{ $subsection utf8 } ; + +ABOUT: "io.encodings.utf8" From 0910d858c515cde10d74cd54a674a52e238dc7ca Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:49:57 -0500 Subject: [PATCH 104/121] fix docs --- core/quotations/quotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 74c296d94c..1a16d0f92a 100755 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -17,7 +17,7 @@ $nl "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" { $subsection wrapper } { $subsection literalize } -{ $see-also "basic-combinators" "combinators" } ; +{ $see-also "dataflow" "combinators" } ; ABOUT: "quotations" From d3089375466e26831eca31d92258a95b062e3e12 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:52:58 -0500 Subject: [PATCH 105/121] fix docs --- basis/hints/hints-docs.factor | 1 - 1 file changed, 1 deletion(-) 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 } ; From dbd16b49785f48e0c5c4319f93d960147e0d60b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 16:53:20 -0500 Subject: [PATCH 106/121] fix docs --- basis/compiler/compiler-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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" From 1ef49b1a00f6a93e37d44d648b499f437169f166 Mon Sep 17 00:00:00 2001 From: sheeple Date: Tue, 2 Sep 2008 17:02:15 -0500 Subject: [PATCH 107/121] fix intrinsic --- basis/cpu/ppc/intrinsics/intrinsics.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index bf4711f998..191baf1e0a 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/basis/cpu/ppc/intrinsics/intrinsics.factor @@ -539,7 +539,7 @@ IN: cpu.ppc.intrinsics { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { "scratch" } } + { +scratch+ { { f "scratch" } } } { +clobber+ { "value" "offset" } } } ; From 4b8636463769ff0e861cfe2e2a76a03369d41054 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 17:04:05 -0500 Subject: [PATCH 108/121] fix docs --- basis/debugger/debugger-docs.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) 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" From 8773d544e75f4a4d1c27410b7d58341fad947456 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 17:04:13 -0500 Subject: [PATCH 109/121] document assert= --- core/kernel/kernel-docs.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index af4038c575..8483293274 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -920,3 +920,7 @@ HELP: assert { $values { "got" "the obtained value" } { "expect" "the expected value" } } { $description "Throws an " { $link assert } " error." } { $error-description "Thrown when a unit test or other assertion fails." } ; + +HELP: assert= +{ $values { "a" object } { "b" object } } +{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ; From f8b46802baeef94057f07d03ca9063877a31fbfe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 18:04:28 -0500 Subject: [PATCH 110/121] fix teh bunny --- extra/bunny/model/model.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 376cd3feae..32312aed89 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -79,7 +79,7 @@ GENERIC: bunny-geom ( geom -- ) GENERIC: draw-bunny ( geom draw -- ) M: bunny-dlist bunny-geom - bunny-dlist-list glCallList ; + list>> glCallList ; M: bunny-buffers bunny-geom dup [ array>> ] [ element-array>> ] bi [ From c30a6511d102c9ee0691b0bd72f90f1e709c36a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 18:26:31 -0500 Subject: [PATCH 111/121] move db to basis --- {extra => basis}/db/authors.txt | 0 {extra => basis}/db/db-tests.factor | 0 {extra => basis}/db/db.factor | 0 {extra => basis}/db/errors/errors.factor | 0 {extra => basis}/db/pools/pools-tests.factor | 0 {extra => basis}/db/pools/pools.factor | 0 {extra => basis}/db/postgresql/authors.txt | 0 {extra => basis}/db/postgresql/ffi/ffi.factor | 0 {extra => basis}/db/postgresql/lib/lib.factor | 0 {extra => basis}/db/postgresql/postgresql-tests.factor | 0 {extra => basis}/db/postgresql/postgresql.factor | 0 {extra => basis}/db/queries/queries.factor | 0 {extra => basis}/db/sql/sql-tests.factor | 0 {extra => basis}/db/sql/sql.factor | 0 {extra => basis}/db/sqlite/authors.txt | 0 {extra => basis}/db/sqlite/ffi/ffi.factor | 0 {extra => basis}/db/sqlite/lib/lib.factor | 0 {extra => basis}/db/sqlite/sqlite-tests.factor | 0 {extra => basis}/db/sqlite/sqlite.factor | 0 {extra => basis}/db/sqlite/test.txt | 0 {extra => basis}/db/summary.txt | 0 {extra => basis}/db/tags.txt | 0 {extra => basis}/db/tuples/tuples-tests.factor | 0 {extra => basis}/db/tuples/tuples.factor | 0 {extra => basis}/db/types/types.factor | 0 25 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/db/authors.txt (100%) rename {extra => basis}/db/db-tests.factor (100%) rename {extra => basis}/db/db.factor (100%) rename {extra => basis}/db/errors/errors.factor (100%) rename {extra => basis}/db/pools/pools-tests.factor (100%) rename {extra => basis}/db/pools/pools.factor (100%) rename {extra => basis}/db/postgresql/authors.txt (100%) rename {extra => basis}/db/postgresql/ffi/ffi.factor (100%) rename {extra => basis}/db/postgresql/lib/lib.factor (100%) rename {extra => basis}/db/postgresql/postgresql-tests.factor (100%) rename {extra => basis}/db/postgresql/postgresql.factor (100%) rename {extra => basis}/db/queries/queries.factor (100%) rename {extra => basis}/db/sql/sql-tests.factor (100%) rename {extra => basis}/db/sql/sql.factor (100%) rename {extra => basis}/db/sqlite/authors.txt (100%) rename {extra => basis}/db/sqlite/ffi/ffi.factor (100%) rename {extra => basis}/db/sqlite/lib/lib.factor (100%) rename {extra => basis}/db/sqlite/sqlite-tests.factor (100%) rename {extra => basis}/db/sqlite/sqlite.factor (100%) rename {extra => basis}/db/sqlite/test.txt (100%) rename {extra => basis}/db/summary.txt (100%) rename {extra => basis}/db/tags.txt (100%) rename {extra => basis}/db/tuples/tuples-tests.factor (100%) rename {extra => basis}/db/tuples/tuples.factor (100%) rename {extra => basis}/db/types/types.factor (100%) 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 100% rename from extra/db/db-tests.factor rename to basis/db/db-tests.factor diff --git a/extra/db/db.factor b/basis/db/db.factor similarity index 100% rename from extra/db/db.factor rename to basis/db/db.factor diff --git a/extra/db/errors/errors.factor b/basis/db/errors/errors.factor similarity index 100% rename from extra/db/errors/errors.factor rename to basis/db/errors/errors.factor 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 100% rename from extra/db/postgresql/postgresql.factor rename to basis/db/postgresql/postgresql.factor diff --git a/extra/db/queries/queries.factor b/basis/db/queries/queries.factor similarity index 100% rename from extra/db/queries/queries.factor rename to basis/db/queries/queries.factor 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 100% rename from extra/db/sqlite/ffi/ffi.factor rename to basis/db/sqlite/ffi/ffi.factor 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 100% rename from extra/db/sqlite/sqlite-tests.factor rename to basis/db/sqlite/sqlite-tests.factor diff --git a/extra/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor similarity index 100% rename from extra/db/sqlite/sqlite.factor rename to basis/db/sqlite/sqlite.factor 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 100% rename from extra/db/tuples/tuples-tests.factor rename to basis/db/tuples/tuples-tests.factor 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 100% rename from extra/db/types/types.factor rename to basis/db/types/types.factor From 99b28156cab7603276b8da9b695751d1154ad575 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 19:04:14 -0500 Subject: [PATCH 112/121] fix docs --- extra/24-game/24-game-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor index 996d0a1240..fb1f5c057b 100644 --- a/extra/24-game/24-game-docs.factor +++ b/extra/24-game/24-game-docs.factor @@ -35,8 +35,8 @@ HELP: 24-able ( -- vector ) } { $examples { $example - "USING: 24-game prettyprint ;" - "24-able 24-able? ." + "USING: 24-game kernel sequences prettyprint ;" + "24-able length 4 = ." "t" } { $notes { $link 24-able? } " is used in " { $link 24-able } "." } From 1c176fbdfefe6d9d90d61b8f6eaf47db12cfb018 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 19:12:29 -0500 Subject: [PATCH 113/121] fix docs --- basis/help/topics/topics-docs.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/help/topics/topics-docs.factor b/basis/help/topics/topics-docs.factor index f2f3e8e82f..e0f817ee3d 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 ; +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" } { "title" "a 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 From 5a2c47bb44f8f530b005706407690e8c562157b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 19:14:15 -0500 Subject: [PATCH 114/121] fix docs --- basis/help/topics/topics-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/help/topics/topics-docs.factor b/basis/help/topics/topics-docs.factor index e0f817ee3d..08195ee07d 100644 --- a/basis/help/topics/topics-docs.factor +++ b/basis/help/topics/topics-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax help.crossref help io io.styles -hashtables ; +hashtables strings ; IN: help.topics HELP: articles @@ -15,7 +15,7 @@ HELP: article { $description "Outputs a named " { $link article } " object." } ; HELP: article-title -{ $values { "topic" "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 From e5dbb99f6ee6cc1fc64211b65fbc75c1c1f156d0 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Tue, 2 Sep 2008 21:21:37 -0500 Subject: [PATCH 115/121] Fix canvas gadget --- basis/ui/gadgets/canvas/canvas-tests.factor | 4 ++++ basis/ui/gadgets/canvas/canvas.factor | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) create mode 100755 basis/ui/gadgets/canvas/canvas-tests.factor mode change 100644 => 100755 basis/ui/gadgets/canvas/canvas.factor 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 b137fd888d..85149f4551 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -16,8 +16,8 @@ TUPLE: canvas < gadget dlist ; [ f >>dlist drop ] tri ; : make-canvas-dlist ( canvas quot -- dlist ) - [ GL_COMPILE ] dip make-dlist - [ >>dlist drop ] keep ; + [ drop ] [ GL_COMPILE swap make-dlist ] 2bi + [ >>dlist drop ] keep ; inline : cache-canvas-dlist ( canvas quot -- dlist ) over dlist>> dup From 7062d33dd72b3fe99e399afc1648669c290e1515 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Tue, 2 Sep 2008 22:40:18 -0500 Subject: [PATCH 116/121] Minor improvement --- basis/tools/deploy/shaker/shaker.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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? [ From 9dedd5698fa107e0c805c76d301416d96c77ea57 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 22:50:25 -0500 Subject: [PATCH 117/121] fix docs --- core/system/system-docs.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 5aac0a8e8c..49886492ec 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -14,8 +14,7 @@ ARTICLE: "system" "System interface" "Getting the current time:" { $subsection millis } "Exiting the Factor VM:" -{ $subsection exit } -{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; +{ $subsection exit } ; ARTICLE: "environment-variables" "Environment variables" "Reading environment variables:" From b23ac6f13738a048c165538d68b4c25f97c478d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 2 Sep 2008 22:50:46 -0500 Subject: [PATCH 118/121] fix stack effects, remove two redundant sqlite ffi words, minor cleanups --- basis/db/db-tests.factor | 2 +- basis/db/db.factor | 25 +++++++++++++------------ basis/db/errors/errors.factor | 1 - basis/db/postgresql/postgresql.factor | 2 +- basis/db/sqlite/ffi/ffi.factor | 6 ------ basis/db/sqlite/sqlite-tests.factor | 3 +-- basis/db/sqlite/sqlite.factor | 2 +- basis/db/types/types.factor | 24 ++++++++++++------------ 8 files changed, 29 insertions(+), 36 deletions(-) diff --git a/basis/db/db-tests.factor b/basis/db/db-tests.factor index 0d95e3aea7..3f1dab2c37 100755 --- a/basis/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/basis/db/db.factor b/basis/db/db.factor index c52d1db148..c269341240 100755 --- a/basis/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/basis/db/errors/errors.factor b/basis/db/errors/errors.factor index 1e0d1e7fb4..da6301639f 100644 --- a/basis/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/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index e57efbc360..692241fab0 100755 --- a/basis/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/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index b443f53e78..8de0226e52 100755 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -118,9 +118,6 @@ 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 ) ; -: sqlite3-bind-uint64 ( pStmt index in64 -- int ) - "int" "sqlite" "sqlite3_bind_int64" - { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; @@ -131,9 +128,6 @@ 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 ) ; -: sqlite3-column-uint64 ( pStmt col -- uint64 ) - "sqlite3_uint64" "sqlite" "sqlite3_column_int64" - { "sqlite3_stmt*" "int" } alien-invoke ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index b30cb4ba80..67eac2702b 100755 --- a/basis/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/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 231b60e083..49d79b1b8c 100755 --- a/basis/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 ; diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index c3480093c5..2efa41c401 100755 --- a/basis/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>> ; From 732bfc0bf60dc0a10be8f8843193f0b7e7e08a42 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 01:07:48 -0500 Subject: [PATCH 119/121] re-add alien calls with a comment --- basis/db/sqlite/ffi/ffi.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 8de0226e52..9f033a1d3c 100755 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -118,6 +118,10 @@ 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 ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; @@ -128,6 +132,10 @@ 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 ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; From 73086e1a614792bc3a51000971b7454d2f9b39d3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 01:35:03 -0500 Subject: [PATCH 120/121] add fp-infinity?, docs, and tests --- core/math/math-docs.factor | 10 ++++++++++ core/math/math-tests.factor | 7 +++++++ core/math/math.factor | 16 ++++++++++++++-- 3 files changed, 31 insertions(+), 2 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index cc59094529..b38baa5cc9 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -301,6 +301,16 @@ HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; +HELP: fp-infinity? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } +{ $examples + { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" } + { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" } +} ; + +{ fp-nan? fp-infinity? } related-words + HELP: real-part { $values { "z" number } { "x" real } } { $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index fcd3b929ea..d72bb67970 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -9,3 +9,10 @@ IN: math.tests [ [ 0 1 2 3 4 ] ] [ [ 5 [ , ] each-integer ] [ ] make ] unit-test [ [ ] ] [ [ -1 [ , ] each-integer ] [ ] make ] unit-test +[ f ] [ 1/0. fp-nan? ] unit-test +[ f ] [ -1/0. fp-nan? ] unit-test +[ t ] [ -0/0. fp-nan? ] unit-test + +[ t ] [ 1/0. fp-infinity? ] unit-test +[ t ] [ -1/0. fp-infinity? ] unit-test +[ f ] [ -0/0. fp-infinity? ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 024a32087e..6efdd53825 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -88,8 +88,20 @@ M: object fp-nan? drop f ; M: float fp-nan? - double>bits -51 shift BIN: 111111111111 [ bitand ] keep - number= ; + double>bits -51 shift HEX: fff [ bitand ] keep = ; + +GENERIC: fp-infinity? ( x -- ? ) + +M: object fp-infinity? + drop f ; + +M: float fp-infinity? ( float -- ? ) + double>bits + dup -52 shift HEX: 7ff [ bitand ] keep = [ + HEX: fffffffffffff bitand 0 = + ] [ + drop f + ] if ; : (next-power-of-2) ( i n -- n ) 2dup >= [ From 3b3435acb5f9fa3a951f0ac094cf43cc9f410e95 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Sep 2008 01:37:50 -0500 Subject: [PATCH 121/121] remove old fp-infinity? --- basis/db/queries/queries.factor | 7 ------- 1 file changed, 7 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 3a751a9736..e5334703f6 100644 --- a/basis/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@ ;