From ee6443053bbdac17785f6c074a5de446365cd3bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 6 Jul 2008 19:39:53 -0700 Subject: [PATCH 001/120] Remove useless bitand from integer>bit-array; set-alien-unsigned-1 does that for us! --- extra/bit-arrays/bit-arrays.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor index 3d699a2623..4e6f7428b0 100755 --- a/extra/bit-arrays/bit-arrays.factor +++ b/extra/bit-arrays/bit-arrays.factor @@ -76,7 +76,7 @@ M: bit-array byte-length length 7 + -3 shift ; n zero? [ 0 ] [ [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | [ n' zero? not ] [ - n' out underlying>> i 255 bitand set-alien-unsigned-1 + n' out underlying>> i set-alien-unsigned-1 n' -8 shift n'! i 1+ i! ] [ ] while From 2f560ffbe0ac1dc1eaad61774698b7b80ba91c0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 17:46:57 -0500 Subject: [PATCH 002/120] Fix typo --- core/classes/tuple/tuple-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 114146e450..51c175a282 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -298,16 +298,16 @@ $nl "For example, compare the definitions of the " { $link sbuf } " class," { $code "TUPLE: sbuf" - "{ \"underlying\" string }" - "{ \"length\" array-capacity } ;" + "{ underlying string }" + "{ length array-capacity } ;" "" "INSTANCE: sbuf growable" } "with that of the " { $link vector } " class:" { $code "TUPLE: vector" - "{ \"underlying\" array }" - "{ \"length\" array-capacity } ;" + "{ underlying array }" + "{ length array-capacity } ;" "" "INSTANCE: vector growable" } ; From 610d38720ab1d9fa8ff9c565131e50ddb75299d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 20:05:32 -0500 Subject: [PATCH 003/120] Improve optimized-quot. --- extra/optimizer/debugger/debugger.factor | 30 ++++++++++++++---------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index e3740f9cba..c20685cf70 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -47,24 +47,28 @@ MATCH-VARS: ?a ?b ?c ; : pretty-shuffle ( in out -- word/f ) 2array { - { { { ?a } { } } drop } - { { { ?a ?b } { } } 2drop } - { { { ?a ?b ?c } { } } 3drop } - { { { ?a } { ?a ?a } } dup } - { { { ?a ?b } { ?a ?b ?a ?b } } 2dup } - { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup } - { { { ?a ?b } { ?a ?b ?a } } over } - { { { ?b ?a } { ?a ?b } } swap } - { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick } - { { { ?a ?b ?c } { ?c ?a ?b } } -rot } - { { { ?a ?b ?c } { ?b ?c ?a } } rot } - { { { ?a ?b } { ?b } } nip } + { { { ?a } { ?a } } [ ] } + { { { ?a ?b } { ?a ?b } } [ ] } + { { { ?a ?b ?c } { ?a ?b ?c } } [ ] } + { { { ?a } { } } [ drop ] } + { { { ?a ?b } { } } [ 2drop ] } + { { { ?a ?b ?c } { } } [ 3drop ] } + { { { ?a } { ?a ?a } } [ dup ] } + { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] } + { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } + { { { ?a ?b } { ?a ?b ?a } } [ over ] } + { { { ?b ?a } { ?a ?b } } [ swap ] } + { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } + { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } + { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } + { { { ?a ?b } { ?b } } [ nip ] } + { { { ?a ?b ?c } { ?c } } [ 2nip ] } { _ f } } match-choose ; M: #shuffle node>quot dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle - [ , ] [ >r drop t r> ] if* + [ % ] [ >r drop t r> ] if* dup effect-str "#shuffle: " prepend comment, ; : pushed-literals ( node -- seq ) From d278025a39fe01d6c6f4e3bb5991ca93d8a1cba0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 20:33:08 -0500 Subject: [PATCH 004/120] Fix kernel tests --- core/kernel/kernel-tests.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c5bd0615a7..195e9becae 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -114,10 +114,6 @@ IN: kernel.tests [ total-failure-1 ] must-fail -: total-failure-2 [ ] (call) unimplemented ; - -[ total-failure-2 ] must-fail - ! From combinators.lib [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test From 466a3fecd16166834e5a2bd254a14772c3a592fe Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:47:07 -0500 Subject: [PATCH 005/120] ui.cocoa.views: math.geometry.rect --- extra/ui/cocoa/views/views.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 68db5954d5..3bacad20b4 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -core-foundation threads combinators ; +core-foundation threads combinators math.geometry.rect ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) From 7e24f26b4d5baf5db0084ea2716adac3e288ca5d Mon Sep 17 00:00:00 2001 From: "U-VICTORIA\\Administrator" Date: Fri, 11 Jul 2008 18:49:11 -0700 Subject: [PATCH 006/120] Add missing import to ui.windows --- extra/ui/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 231dd7f8a5..a210287439 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii -math.bitfields locals symbols accessors ; +math.bitfields locals symbols accessors math.geometry.rect ; IN: ui.windows SINGLETON: windows-ui-backend From f3d63e34acb79bb5558735cbc16f56f104352d92 Mon Sep 17 00:00:00 2001 From: "U-VICTORIA\\Administrator" Date: Fri, 11 Jul 2008 18:50:26 -0700 Subject: [PATCH 007/120] Add LPGUID typedef to windows.ole32 --- extra/windows/ole32/ole32.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor index 7daba37063..0e74dcfca3 100755 --- a/extra/windows/ole32/ole32.factor +++ b/extra/windows/ole32/ole32.factor @@ -10,6 +10,7 @@ TYPEDEF: void* LPUNKNOWN TYPEDEF: wchar_t* LPOLESTR TYPEDEF: wchar_t* LPCOLESTR +TYPEDEF: REFGUID LPGUID TYPEDEF: REFGUID REFIID TYPEDEF: REFGUID REFCLSID From 8d311fbf76e991c96542ff94da988b3f49cc382e Mon Sep 17 00:00:00 2001 From: "U-VICTORIA\\Administrator" Date: Fri, 11 Jul 2008 18:51:25 -0700 Subject: [PATCH 008/120] Update bunny, spheres, demo-support to use delegation --- extra/bunny/bunny.factor | 20 +++++++------------ extra/opengl/demo-support/demo-support.factor | 14 ++++++------- extra/spheres/spheres.factor | 5 ++--- 3 files changed, 16 insertions(+), 23 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index b4cefbc5bd..06959c91c2 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -7,28 +7,23 @@ opengl.demo-support multiline ui.gestures bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; IN: bunny -TUPLE: bunny-gadget model geom draw-seq draw-n ; +TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; : ( -- bunny-gadget ) - 0.0 0.0 0.375 - maybe-download read-model { - set-delegate - (>>model) - } bunny-gadget construct ; + 0.0 0.0 0.375 bunny-gadget new-demo-gadget + maybe-download read-model >>model-triangles ; : bunny-gadget-draw ( gadget -- draw ) - { draw-n>> draw-seq>> } - get-slots nth ; + [ draw-n>> ] [ draw-seq>> ] bi nth ; : bunny-gadget-next-draw ( gadget -- ) - dup { draw-seq>> draw-n>> } - get-slots + dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - dup model>> >>geom + dup model-triangles>> >>geom dup [ ] [ ] @@ -48,8 +43,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - { geom>> bunny-gadget-draw } get-slots - draw-bunny + [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny ] if ; M: bunny-gadget pref-dim* ( gadget -- dim ) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 5dcbd526f2..2bf2abae95 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -9,10 +9,10 @@ IN: opengl.demo-support SYMBOL: last-drag-loc -TUPLE: demo-gadget yaw pitch distance ; +TUPLE: demo-gadget < gadget yaw pitch distance ; -: ( yaw pitch distance -- gadget ) - demo-gadget construct-gadget +: new-demo-gadget ( yaw pitch distance class -- gadget ) + new-gadget swap >>distance swap >>pitch swap >>yaw ; @@ -31,19 +31,19 @@ M: demo-gadget distance-step ( gadget -- dz ) : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; : yaw-demo-gadget ( yaw gadget -- ) - [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; + [ + ] with change-yaw relayout-1 ; : pitch-demo-gadget ( pitch gadget -- ) - [ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ; + [ + ] with change-pitch relayout-1 ; : zoom-demo-gadget ( distance gadget -- ) - [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ; + [ + ] with change-distance relayout-1 ; M: demo-gadget pref-dim* ( gadget -- dim ) drop { 640 480 } ; : -+ ( x -- -x x ) - dup neg swap ; + [ neg ] keep ; : demo-gadget-frustum ( gadget -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index dff7313eec..9607f6d201 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -99,14 +99,13 @@ main() } ; -TUPLE: spheres-gadget +TUPLE: spheres-gadget < demo-gadget plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer reflection-texture ; : ( -- gadget ) - 20.0 10.0 20.0 - { set-delegate } spheres-gadget construct ; + 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; M: spheres-gadget near-plane ( gadget -- z ) drop 1.0 ; From e08a04a03d532bd0948ecf1dfb6e805be488d79a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:58:09 -0500 Subject: [PATCH 009/120] automata.ui: math.geometry.rect --- extra/automata/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 467db53366..cfec6597c2 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -15,7 +15,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.grids ui.gadgets.theme namespaces.lib assocs.lib vars - rewrite-closures automata ; + rewrite-closures automata math.geometry.rect ; IN: automata.ui From b668936d9fa63bbf12deb37a0b1e17999c60a979 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 21:06:31 -0500 Subject: [PATCH 010/120] more rect updates --- extra/color-picker/color-picker.factor | 2 +- extra/jamshred/jamshred.factor | 5 ++++- extra/maze/maze.factor | 2 +- extra/processing/processing.factor | 2 +- extra/springies/springies.factor | 2 ++ extra/tetris/tetris.factor | 3 ++- extra/ui/gadgets/frame-buffer/frame-buffer.factor | 2 +- 7 files changed, 12 insertions(+), 6 deletions(-) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 99968ca3c3..6fcf3c21cd 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -3,7 +3,7 @@ USING: kernel math math.functions math.parser models models.filter models.range models.compose sequences ui ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs -ui.gadgets.sliders ui.render ; +ui.gadgets.sliders ui.render math.geometry.rect ; IN: color-picker ! Simple example demonstrating the use of models. diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index b7764894d1..d9a0f84b53 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl +jamshred.player jamshred.log kernel math math.constants namespaces +sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds +ui.gestures ui.render math.vectors math.geometry.rect ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index dbf983be62..389dabc0f6 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -1,7 +1,7 @@ ! From http://www.ffconsultancy.com/ocaml/maze/index.html USING: sequences namespaces math math.vectors opengl opengl.gl arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render -math.order ; +math.order math.geometry.rect ; IN: maze : line-width 8 ; diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index fb9f321f47..4c9dd787e5 100755 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -10,7 +10,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators.cleave rewrite-closures fry accessors newfx processing.color - processing.gadget ; + processing.gadget math.geometry.rect ; IN: processing diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 2640423eb4..fb69783975 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -38,6 +38,8 @@ C: node ! : >>vel ( node vel -- node ) over set-node-vel ; +: node-vel ( node -- vel ) vel>> ; + : set-node-vel ( vel node -- ) swap >>vel drop ; : pos-x ( node -- x ) pos>> first ; diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index c2f874598c..d01cec3790 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui -tetris.game tetris.gl sequences system math math.parser namespaces ; +tetris.game tetris.gl sequences system math math.parser namespaces +math.geometry.rect ; IN: tetris TUPLE: tetris-gadget tetris alarm ; diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor index a288f74f64..7d77db24cc 100644 --- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -1,7 +1,7 @@ USING: kernel alien.c-types combinators sequences splitting grouping opengl.gl ui.gadgets ui.render - math math.vectors accessors ; + math math.vectors accessors math.geometry.rect ; IN: ui.gadgets.frame-buffer From b19c3ee65e7655fbb9ce71692751bfe31a4e8ada Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 11 Jul 2008 19:34:42 -0700 Subject: [PATCH 011/120] use single-precision floats in bunny vertex buffers for much better performance --- extra/bunny/model/model.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index fce73785b5..6723f94353 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting system combinators -float-arrays continuations destructors namespaces sequences.lib +continuations destructors namespaces sequences.lib accessors ; IN: bunny.model @@ -66,7 +66,7 @@ TUPLE: bunny-buffers array element-array nv ni ; { [ [ first concat ] [ second concat ] bi - append >c-double-array + append >c-float-array GL_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ @@ -86,10 +86,10 @@ M: bunny-dlist bunny-geom M: bunny-buffers bunny-geom dup { array>> element-array>> } get-slots [ { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [ - GL_DOUBLE 0 0 buffer-offset glNormalPointer + GL_FLOAT 0 0 buffer-offset glNormalPointer [ - nv>> "double" heap-size * buffer-offset - 3 GL_DOUBLE 0 roll glVertexPointer + nv>> "float" heap-size * buffer-offset + 3 GL_FLOAT 0 roll glVertexPointer ] [ ni>> GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements From 5b0fbf9abf092fac48da24353ba1632c6e703adc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 11 Jul 2008 19:48:41 -0700 Subject: [PATCH 012/120] Whip the out-of-control USING: lines in bunny into shape --- extra/bunny/bunny.factor | 10 +++------- extra/bunny/model/model.factor | 10 ++++------ 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 06959c91c2..ed89f2a809 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,10 +1,6 @@ -USING: alien alien.c-types arrays sequences math math.vectors -math.matrices math.parser io io.files kernel opengl opengl.gl -opengl.glu shuffle http.client vectors namespaces ui.gadgets -ui.gadgets.canvas ui.render ui splitting combinators -system combinators.lib float-arrays continuations -opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; +USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline +bunny.model bunny.outlined destructors kernel math opengl.demo-support +opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ; IN: bunny TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 6723f94353..f64030ff70 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,9 +1,7 @@ -USING: alien alien.c-types arrays sequences math math.vectors -math.matrices math.parser io io.files kernel opengl opengl.gl -opengl.glu io.encodings.ascii opengl.capabilities shuffle -http.client vectors splitting system combinators -continuations destructors namespaces sequences.lib -accessors ; +USING: accessors alien.c-types arrays combinators destructors http.client +io io.encodings.ascii io.files kernel math math.matrices math.parser +math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib +splitting vectors words ; IN: bunny.model : numbers ( str -- seq ) From 7608afbf4c445f1a6da613019fa9a67e86473c1a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 11 Jul 2008 20:16:22 -0700 Subject: [PATCH 013/120] duh... bunny.outlined needs to update the framebuffer size after it builds it! --- extra/bunny/outlined/outlined.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index f3ee4594c7..fcba98a0e9 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -181,10 +181,9 @@ TUPLE: bunny-outlined ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) - dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi - over = - [ 2drop ] [ - [ dup dispose-framebuffer dup ] dip { + dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi = + [ drop ] [ + [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri { [ GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) [ >>color-texture drop ] keep @@ -196,7 +195,8 @@ TUPLE: bunny-outlined [ >>depth-texture drop ] keep ] } 2cleave - (make-framebuffer) >>framebuffer drop + [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi + drop ] if ; : clear-framebuffer ( -- ) From 9232f16732d354cc502a218bb40b29644f418727 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 23:54:53 -0500 Subject: [PATCH 014/120] math.geometry.rect.tests --- extra/math/geometry/rect/rect-tests.factor | 37 ++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 extra/math/geometry/rect/rect-tests.factor diff --git a/extra/math/geometry/rect/rect-tests.factor b/extra/math/geometry/rect/rect-tests.factor new file mode 100644 index 0000000000..0d2a8bc1ea --- /dev/null +++ b/extra/math/geometry/rect/rect-tests.factor @@ -0,0 +1,37 @@ + +USING: tools.test math.geometry.rect ; + +IN: math.geometry.rect.tests + +[ T{ rect f { 10 10 } { 20 20 } } ] +[ + T{ rect f { 10 10 } { 50 50 } } + T{ rect f { -10 -10 } { 40 40 } } + rect-intersect +] unit-test + +[ T{ rect f { 200 200 } { 0 0 } } ] +[ + T{ rect f { 100 100 } { 50 50 } } + T{ rect f { 200 200 } { 40 40 } } + rect-intersect +] unit-test + +[ f ] [ + T{ rect f { 100 100 } { 50 50 } } + T{ rect f { 200 200 } { 40 40 } } + intersects? +] unit-test + +[ t ] [ + T{ rect f { 100 100 } { 50 50 } } + T{ rect f { 120 120 } { 40 40 } } + intersects? +] unit-test + +[ f ] [ + T{ rect f { 1000 100 } { 50 50 } } + T{ rect f { 120 120 } { 40 40 } } + intersects? +] unit-test + From 9043ad0e4a70b53b2874d346598a307eea7c46a0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 23:57:27 -0500 Subject: [PATCH 015/120] update tests for math.geometry.rect --- extra/ui/gadgets/borders/borders-tests.factor | 2 +- extra/ui/gadgets/gadgets-tests.factor | 34 +------------------ extra/ui/gadgets/grids/grids-tests.factor | 2 +- extra/ui/gadgets/packs/packs-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/gadgets/tracks/tracks-tests.factor | 2 +- 6 files changed, 6 insertions(+), 38 deletions(-) diff --git a/extra/ui/gadgets/borders/borders-tests.factor b/extra/ui/gadgets/borders/borders-tests.factor index 268d1ab0a3..0151996c02 100644 --- a/extra/ui/gadgets/borders/borders-tests.factor +++ b/extra/ui/gadgets/borders/borders-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.borders.tests USING: tools.test accessors namespaces kernel -ui.gadgets ui.gadgets.borders ; +ui.gadgets ui.gadgets.borders math.geometry.rect ; [ { 110 210 } ] [ { 100 200 } >>dim 5 pref-dim ] unit-test diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index dbb2919277..1bea304f15 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -2,39 +2,7 @@ IN: ui.gadgets.tests USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists dequeues math sets math.parser ui sequences hashtables assocs io arrays prettyprint -io.streams.string ; - -[ T{ rect f { 10 10 } { 20 20 } } ] -[ - T{ rect f { 10 10 } { 50 50 } } - T{ rect f { -10 -10 } { 40 40 } } - rect-intersect -] unit-test - -[ T{ rect f { 200 200 } { 0 0 } } ] -[ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } - rect-intersect -] unit-test - -[ f ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } - intersects? -] unit-test - -[ t ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } - intersects? -] unit-test - -[ f ] [ - T{ rect f { 1000 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } - intersects? -] unit-test +io.streams.string math.geometry.rect ; [ { 300 300 } ] [ diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index f20275ff25..cfca5d5a93 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -1,5 +1,5 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays -namespaces ; +namespaces math.geometry.rect ; IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index 28a656e2ad..4ae84f83df 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render -kernel namespaces tools.test math.parser sequences ; +kernel namespaces tools.test math.parser sequences math.geometry.rect ; [ t ] [ { 0 0 } { 100 100 } clip set diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 4df92141ba..cfbb1fdca5 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -3,7 +3,7 @@ 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 ; +tools.test.ui math.geometry.rect ; [ ] [ "g" set diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor index e2db914089..d3264b2470 100644 --- a/extra/ui/gadgets/tracks/tracks-tests.factor +++ b/extra/ui/gadgets/tracks/tracks-tests.factor @@ -1,4 +1,4 @@ -USING: kernel ui.gadgets ui.gadgets.tracks tools.test ; +USING: kernel ui.gadgets ui.gadgets.tracks tools.test math.geometry.rect ; IN: ui.gadgets.tracks.tests [ { 100 100 } ] [ From 4812c95db68a2097e7aba4174ee1bbc48f0de100 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 00:49:02 -0500 Subject: [PATCH 016/120] automata: use --- extra/automata/automata.factor | 21 ++++----------------- 1 file changed, 4 insertions(+), 17 deletions(-) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index b6d4152d0e..a70eaa063d 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser random arrays hashtables assocs sequences - vars ; + grouping vars ; IN: automata @@ -32,29 +32,16 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; ! step-wrapped-line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 3nth ( n seq -- slice ) >r dup 3 + r> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: map3-i ( seq -- i ) length 2 - ; - -: map3-quot ( seq quot -- quot ) >r [ 3nth ] curry r> compose ; inline - -: map3 ( seq quot -- seq ) >r dup map3-i swap r> map3-quot map ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: pattern>state ( {_a_b_c_} -- state ) rule> at ; +: pattern>state ( {_a_b_c_} -- state ) >array rule> at ; : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; : wrap-line ( a-line-z -- za-line-za ) dup peek 1array swap dup first 1array append append ; -: step-line ( line -- new-line ) [ >array pattern>state ] map3 ; - -: step-capped-line ( line -- new-line ) cap-line step-line ; +: step-line ( line -- new-line ) 3 [ pattern>state ] map ; +: step-capped-line ( line -- new-line ) cap-line step-line ; : step-wrapped-line ( line -- new-line ) wrap-line step-line ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 7ca3c2a878a8772c228f14888ef1259bf6e25bd4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:08:30 -0500 Subject: [PATCH 017/120] Various minor compiler tweaks --- core/alien/c-types/c-types-tests.factor | 2 + core/alien/c-types/c-types.factor | 6 +- core/classes/algebra/algebra-tests.factor | 6 ++ core/classes/singleton/singleton.factor | 6 +- core/classes/tuple/tuple.factor | 2 + core/growable/growable.factor | 7 ++ core/inference/class/class-tests.factor | 38 ++++++-- core/inference/class/class.factor | 19 +++- core/inference/known-words/known-words.factor | 6 +- core/io/encodings/encodings.factor | 21 +++-- core/io/encodings/utf8/utf8.factor | 14 +-- core/optimizer/inlining/inlining-tests.factor | 11 --- core/optimizer/inlining/inlining.factor | 89 +++++++++++++------ core/optimizer/math/math.factor | 67 ++++++++++++-- core/optimizer/math/partial/partial.factor | 3 + core/optimizer/optimizer-tests.factor | 9 ++ core/sequences/sequences.factor | 7 +- core/slots/slots.factor | 6 +- extra/benchmark/stack/stack.factor | 19 ++++ extra/float-arrays/float-arrays.factor | 17 ++++ extra/hints/hints.factor | 10 ++- extra/io/buffers/buffers.factor | 2 +- extra/io/ports/ports.factor | 18 ++-- extra/tools/deploy/shaker/shaker.factor | 1 + 24 files changed, 296 insertions(+), 90 deletions(-) create mode 100644 extra/benchmark/stack/stack.factor diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 5f57068bab..276dd581c5 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } ] must-fail + +[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 602b22881f..e576b87f52 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -348,7 +348,7 @@ M: long-long-type box-return ( type -- ) [ alien-unsigned-4 zero? not ] >>getter - [ 1 0 ? set-alien-unsigned-4 ] >>setter + [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter 4 >>size 4 >>align "box_boolean" >>boxer @@ -357,7 +357,7 @@ M: long-long-type box-return ( type -- ) [ alien-float ] >>getter - [ >r >r >float r> r> set-alien-float ] >>setter + [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size 4 >>align "box_float" >>boxer @@ -368,7 +368,7 @@ M: long-long-type box-return ( type -- ) [ alien-double ] >>getter - [ >r >r >float r> r> set-alien-double ] >>setter + [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size 8 >>align "box_double" >>boxer diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 444cf50e58..665fc86ebb 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -306,3 +306,9 @@ INTERSECTION: empty-intersection ; [ t ] [ object \ f class-not \ f class-or class<= ] unit-test [ ] [ object flatten-builtin-class drop ] unit-test + +SINGLETON: sa +SINGLETON: sb +SINGLETON: sc + +[ sa ] [ sa { sa sb sc } min-class ] unit-test diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index a72c9f1333..1d370c1859 100755 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.predicate kernel sequences words ; +USING: classes classes.algebra classes.predicate kernel +sequences words ; IN: classes.singleton PREDICATE: singleton-class < predicate-class @@ -11,3 +12,6 @@ PREDICATE: singleton-class < predicate-class \ word over [ eq? ] curry define-predicate-class ; M: singleton-class instance? eq? ; + +M: singleton-class (classes-intersect?) + over singleton-class? [ eq? ] [ call-next-method ] if ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6cf6a9897a..71c5f3efe6 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -336,6 +336,8 @@ M: tuple-class boa [ tuple-layout ] bi ; +M: tuple-class initial-value* new ; + ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 57919671c8..336f1da91a 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -59,4 +59,11 @@ M: growable lengthen ( n seq -- ) 2dup (>>length) ] when 2drop ; +M: growable shorten ( n seq -- ) + growable-check + 2dup length < [ + 2dup contract + 2dup (>>length) + ] when 2drop ; + INSTANCE: growable sequence diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 591baf1287..7be70f1ad4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -5,8 +5,9 @@ sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units system layouts vectors optimizer.math.partial -optimizer.inlining optimizer.backend math.order -accessors hashtables classes assocs ; +optimizer.inlining optimizer.backend math.order math.functions +accessors hashtables classes assocs io.encodings.utf8 +io.encodings.ascii io.encodings ; [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test @@ -193,19 +194,15 @@ M: fixnum detect-fx ; [ t ] [ - [ { string sbuf } declare push-all ] \ push-all inlined? + [ { string sbuf } declare ] \ push-all def>> append \ + inlined? ] unit-test [ t ] [ - [ { string sbuf } declare push-all ] \ + inlined? + [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? ] unit-test [ t ] [ - [ { string sbuf } declare push-all ] \ fixnum+ inlined? -] unit-test - -[ t ] [ - [ { string sbuf } declare push-all ] \ >fixnum inlined? + [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? ] unit-test [ t ] [ @@ -600,6 +597,29 @@ TUPLE: declared-fixnum { x fixnum } ; { slot } inlined? ] unit-test +[ t ] [ + [ + { array } declare length + 1 + dup 100 fixnum> [ 1 fixnum+ ] when + ] \ fixnum+ inlined? +] unit-test + +[ t ] [ + [ [ resize-array ] keep length ] \ length inlined? +] unit-test + +[ t ] [ + [ dup 0 > [ sqrt ] when ] \ sqrt inlined? +] unit-test + +[ t ] [ + [ { utf8 } declare decode-char ] \ decode-char inlined? +] unit-test + +[ t ] [ + [ { ascii } declare decode-char ] \ decode-char inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 2f7058ba96..7cd0c1d540 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -129,8 +129,12 @@ GENERIC: infer-classes-before ( node -- ) GENERIC: infer-classes-around ( node -- ) +GENERIC: infer-classes-after ( node -- ) + M: node infer-classes-before drop ; +M: node infer-classes-after drop ; + M: node child-constraints children>> length dup zero? [ drop f ] [ f ] if ; @@ -203,11 +207,19 @@ M: pair constraint-satisfied? [ ] [ param>> "default-output-classes" word-prop ] ?if r> ; -M: #call infer-classes-before - [ compute-constraints ] keep - [ output-classes ] [ out-d>> ] bi +: intersect-values ( classes intervals values -- ) tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ; +M: #call infer-classes-before + [ compute-constraints ] + [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ; + +: input-classes ( #call -- classes ) + param>> "input-classes" word-prop ; + +M: #call infer-classes-after + [ input-classes ] [ in-d>> ] bi intersect-classes ; + M: #push infer-classes-before out-d>> [ [ value-literal ] keep set-value-literal* ] each ; @@ -340,6 +352,7 @@ M: object infer-classes-around { [ infer-classes-before ] [ annotate-node ] + [ infer-classes-after ] [ infer-children ] [ merge-children ] } cleave ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6f5277bc35..1c9138fe0b 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -153,8 +153,10 @@ M: object infer-call ] "infer" set-word-prop : set-primitive-effect ( word effect -- ) - 2dup effect-out "default-output-classes" set-word-prop - dupd [ make-call-node ] 2curry "infer" set-word-prop ; + [ in>> "input-classes" set-word-prop ] + [ out>> "default-output-classes" set-word-prop ] + [ dupd [ make-call-node ] 2curry "infer" set-word-prop ] + 2tri ; ! Stack effects for all primitives \ fixnum< { fixnum fixnum } { object } set-primitive-effect diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 942476616f..0181f80af4 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -99,14 +99,20 @@ M: decoder stream-read-partial stream-read ; [ >r drop "" like r> ] [ pick push ((read-until)) ] if ; inline -: (read-until) ( seps stream -- string/f sep/f ) - SBUF" " clone -rot >decoder< +: (read-until) ( quot -- string/f sep/f ) + 100 swap ((read-until)) ; inline + +: decoder-read-until ( seps stream encoding -- string/f sep/f ) [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry - ((read-until)) ; inline + (read-until) ; -M: decoder stream-read-until (read-until) ; +M: decoder stream-read-until >decoder< decoder-read-until ; -M: decoder stream-readln "\r\n" over (read-until) handle-readln ; +: decoder-readln ( stream encoding -- string/f sep/f ) + [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry + (read-until) ; + +M: decoder stream-readln dup >decoder< decoder-readln handle-readln ; M: decoder dispose stream>> dispose ; @@ -119,8 +125,11 @@ M: object encoder boa ; M: encoder stream-write1 >encoder< encode-char ; +: decoder-write ( string stream encoding -- ) + [ encode-char ] 2curry each ; + M: encoder stream-write - >encoder< [ encode-char ] 2curry each ; + >encoder< decoder-write ; M: encoder dispose encoder-stream dispose ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 09524802e0..ae8a455c71 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -11,21 +11,21 @@ SINGLETON: utf8 >length) method should-inline? ] unit-test diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 618a2c746d..30acdb1b48 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes classes.algebra generic.math -optimizer.math.partial continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private definitions sets ; +math math.order namespaces sequences vectors words quotations +hashtables combinators effects classes classes.union +classes.algebra generic.math optimizer.math.partial +continuations optimizer.def-use optimizer.backend +generic.standard optimizer.specializers optimizer.def-use +optimizer.pattern-match generic.standard optimizer.control +kernel.private definitions sets summary ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -31,9 +32,9 @@ DEFER: (flat-length) : word-flat-length ( word -- n ) { ! not inline - { [ dup inline? not ] [ drop 0 ] } + { [ dup inline? not ] [ drop 1 ] } ! recursive and inline - { [ dup recursive-calls get key? ] [ drop 4 ] } + { [ dup recursive-calls get key? ] [ drop 10 ] } ! inline [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] } cond ; @@ -41,7 +42,7 @@ DEFER: (flat-length) : (flat-length) ( seq -- n ) [ { - { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup quotation? ] [ (flat-length) 2 + ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } [ drop 0 ] @@ -51,7 +52,7 @@ DEFER: (flat-length) : flat-length ( word -- n ) H{ } clone recursive-calls [ [ recursive-calls get conjoin ] - [ def>> (flat-length) ] + [ def>> (flat-length) 5 /i ] bi ] with-variable ; @@ -102,7 +103,7 @@ DEFER: (flat-length) [ f splice-quot ] [ 2drop t ] if ; : inline-method ( #call -- node ) - dup node-param { + dup param>> { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup math-partial? ] [ inline-math-partial ] } @@ -155,15 +156,35 @@ DEFER: (flat-length) (optimize-predicate) optimize-check ; : flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; + dup node-param "flushable" word-prop + [ node-out-d [ unused? ] all? ] [ drop f ] if ; + +ERROR: flushed-eval-error word ; + +M: flushed-eval-error summary + drop "Flushed evaluation of word would have thrown an error" ; + +: flushed-eval-quot ( #call -- quot ) + #! A quotation to replace flushed evaluations with. We can't + #! just remove the code altogether, because if the optimizer + #! knows the input types of a word, it assumes the inputs are + #! of this type after the word returns, since presumably + #! the word would have checked input types itself. However, + #! if the word gets flushed, then it won't do this checking; + #! so we have to do it here. + [ + dup param>> "input-classes" word-prop [ + make-specializer % + [ dup param>> literalize , \ flushed-eval-error , ] [ ] make , + \ unless , + ] when* + dup in-d>> length [ \ drop , ] times + out-d>> length [ f , ] times + ] [ ] make ; : flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; + dup param>> +inlined+ depends-on + dup flushed-eval-quot f splice-quot ; : partial-eval? ( #call -- ? ) dup node-param "foldable" word-prop [ @@ -195,13 +216,28 @@ DEFER: (flat-length) [ drop +inlined+ depends-on ] [ swap 1array ] 2bi splice-quot ; +: classes-known? ( #call -- ? ) + node-input-classes [ + [ class-types length 1 = ] + [ union-class? not ] + bi and + ] contains? ; + +: inlining-rank ( #call -- n ) + { + [ param>> flat-length 24 swap [-] 4 /i ] + [ param>> "default" word-prop -4 0 ? ] + [ param>> "specializer" word-prop 1 0 ? ] + [ param>> method-body? 1 0 ? ] + [ classes-known? 2 0 ? ] + } cleave + + + + ; + +: should-inline? ( #call -- ? ) + inlining-rank 5 >= ; + : optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ class-types length 1 = ] all? - ] [ - 2drop f - ] if ; + dup param>> "specializer" word-prop + [ should-inline? ] [ drop f ] if ; : already-inlined? ( #call -- ? ) [ param>> ] [ history>> ] bi memq? ; @@ -211,11 +247,8 @@ DEFER: (flat-length) dup param>> dup def>> splice-word-def ] if ; -: should-inline? ( word -- ? ) - flat-length 11 <= ; - : method-body-inline? ( #call -- ? ) - param>> dup [ method-body? ] [ "default" word-prop not ] bi and + dup param>> method-body? [ should-inline? ] [ drop f ] if ; M: #call optimize-node* diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 27ef4042e2..799f4d80cf 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: effects alien alien.accessors arrays generic hashtables +kernel assocs math math.libm math.private kernel.private +sequences words parser inference.class inference.dataflow +vectors strings sbufs io namespaces assocs quotations +math.intervals sequences.private combinators splitting layouts +math.parser classes classes.algebra generic.math +optimizer.pattern-match optimizer.backend optimizer.def-use +optimizer.inlining optimizer.math.partial generic.standard +system accessors ; IN: optimizer.math -USING: alien alien.accessors arrays generic hashtables kernel -assocs math math.private kernel.private sequences words parser -inference.class inference.dataflow vectors strings sbufs io -namespaces assocs quotations math.intervals sequences.private -combinators splitting layouts math.parser classes -classes.algebra generic.math optimizer.pattern-match -optimizer.backend optimizer.def-use optimizer.inlining -optimizer.math.partial generic.standard system accessors ; : define-math-identities ( word identities -- ) >r all-derived-ops r> define-identities ; @@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ; ] 2curry each-derived-op ] each +: math-output-class/interval-2-fast ( node word -- classes intervals ) + math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline + +[ + { + interval+ } + { - interval- } + { * interval* } + { shift interval-shift-safe } +] [ + first2 [ + [ + math-output-class/interval-2-fast + ] curry "output-classes" set-word-prop + ] curry each-fast-derived-op +] each + : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -420,3 +437,37 @@ most-negative-fixnum most-positive-fixnum [a,b] [ fixnumify-bitand ] } } define-optimizers + +{ + - * / } +[ { number number } "input-classes" set-word-prop ] each + +{ /f < > <= >= } +[ { real real } "input-classes" set-word-prop ] each + +{ /i bitand bitor bitxor bitnot shift } +[ { integer integer } "input-classes" set-word-prop ] each + +{ + fcosh + flog + fsinh + fexp + fasin + facosh + fasinh + ftanh + fatanh + facos + fpow + fatan + fatan2 + fcos + ftan + fsin + fsqrt +} [ + dup stack-effect + [ in>> length real "input-classes" set-word-prop ] + [ out>> length float "default-output-classes" set-word-prop ] + 2bi +] each diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 4f9bfaef12..ad9feeed4a 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/core/optimizer/math/partial/partial.factor @@ -170,3 +170,6 @@ SYMBOL: fast-math-ops : each-derived-op ( word quot -- ) >r derived-ops r> each ; inline + +: each-fast-derived-op ( word quot -- ) + >r fast-derived-ops r> each ; inline diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 655b54ea96..0a3439c65c 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -375,3 +375,12 @@ PREDICATE: list < improper-list [ 2 3 ] [ 2 interval-inference-bug ] unit-test [ 1 4 ] [ 1 interval-inference-bug ] unit-test [ 0 5 ] [ 0 interval-inference-bug ] unit-test + +: aggressive-flush-regression ( a -- b ) + f over >r drop r> 1 + ; + +[ 1.0 aggressive-flush-regression drop ] must-fail + +[ 1 [ "hi" + drop ] compile-call ] must-fail + +[ "hi" f [ drop ] compile-call ] must-fail diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index bc92055338..c433ce4426 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable M: sequence like drop ; GENERIC: lengthen ( n seq -- ) +GENERIC: shorten ( n seq -- ) M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; +M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; + : empty? ( seq -- ? ) length zero? ; inline : delete-all ( seq -- ) 0 swap set-length ; @@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; -: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ; +: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; : move-backward ( shift from to seq -- ) 2over number= [ @@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; copy ; : pop ( seq -- elt ) - [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ; + [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; : all-equal? ( seq -- ? ) [ = ] monotonic? ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 1453393a27..a5b2e4b3d8 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -125,6 +125,10 @@ ERROR: bad-slot-value value class ; ERROR: no-initial-value class ; +GENERIC: initial-value* ( class -- object ) + +M: class initial-value* no-initial-value ; + : initial-value ( class -- object ) { { [ \ f bootstrap-word over class<= ] [ f ] } @@ -134,7 +138,7 @@ ERROR: no-initial-value class ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } - [ no-initial-value ] + [ dup initial-value* ] } cond nip ; GENERIC: make-slot ( desc -- slot-spec ) diff --git a/extra/benchmark/stack/stack.factor b/extra/benchmark/stack/stack.factor new file mode 100644 index 0000000000..d4dc18e80f --- /dev/null +++ b/extra/benchmark/stack/stack.factor @@ -0,0 +1,19 @@ +USING: kernel sequences math math.functions vectors ; +IN: benchmark.stack + +: stack-loop ( vec -- ) + 1000 [ + 10000 [ + dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if + pick push + over push + ] times + 10000 [ dup pop* ] times + ] times + drop ; + +: stack-benchmark ( -- ) + V{ 123456 } clone stack-loop + 20000 123456 over set-first stack-loop ; + +MAIN: stack-benchmark diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor index 025a580633..668bb7de41 100755 --- a/extra/float-arrays/float-arrays.factor +++ b/extra/float-arrays/float-arrays.factor @@ -72,3 +72,20 @@ INSTANCE: float-array sequence M: float-array pprint-delims drop \ F{ \ } ; M: float-array >pprint-sequence ; + +USING: hints math.vectors arrays ; + +HINTS: vneg { float-array } { array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: v/n { float-array object } { array object } ; +HINTS: n/v { object float-array } { object array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; diff --git a/extra/hints/hints.factor b/extra/hints/hints.factor index 266e635867..82941a69de 100644 --- a/extra/hints/hints.factor +++ b/extra/hints/hints.factor @@ -1,6 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser words definitions kernel ; IN: hints -USING: parser words ; -: HINTS: - scan-word parse-definition "specializer" set-word-prop ; +: HINTS: + scan-word + [ +inlined+ changed-definition ] + [ parse-definition "specializer" set-word-prop ] bi ; parsing diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index f08082c4ee..e6a0070ee0 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -25,7 +25,7 @@ M: buffer dispose* ptr>> free ; [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) - fill>> zero? ; + fill>> zero? ; inline : buffer-consume ( n buffer -- ) [ + ] change-pos diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 77e984e6e5..26b06dba8b 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ; : ( handle class -- port ) new swap >>handle ; inline -TUPLE: buffered-port < port buffer ; +TUPLE: buffered-port < port { buffer buffer } ; : ( handle class -- port ) @@ -35,7 +35,7 @@ HOOK: (wait-to-read) io-backend ( port -- ) : wait-to-read ( port -- eof? ) dup buffer>> buffer-empty? [ dup (wait-to-read) buffer>> buffer-empty? - ] [ drop f ] if ; + ] [ drop f ] if ; inline M: input-port stream-read1 dup check-disposed @@ -140,9 +140,7 @@ M: output-port dispose* ] with-destructors ; M: buffered-port dispose* - [ call-next-method ] - [ [ [ dispose ] when* f ] change-buffer drop ] - bi ; + [ call-next-method ] [ buffer>> dispose ] bi ; M: port cancel-operation handle>> cancel-operation ; @@ -152,3 +150,13 @@ M: port dispose* [ handle>> shutdown ] bi ] with-destructors ; + +! Fast-path optimization +USING: hints strings io.encodings.utf8 io.encodings.ascii +io.encodings.private ; + +HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ; + +HINTS: decoder-readln { input-port utf8 } { input-port ascii } ; + +HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 2dd334d024..0e20384839 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -101,6 +101,7 @@ IN: tools.deploy.shaker "if-intrinsics" "infer" "inferred-effect" + "input-classes" "interval" "intrinsics" "loc" From 1253aed5cd4ebc6d29d651fc79dab8037eba6c1f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:24:10 -0500 Subject: [PATCH 018/120] Doc update --- core/slots/slots-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 39a501c7f8..acca168a4c 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -77,6 +77,7 @@ $nl "All other classes are handled with one of two cases:" { $list { "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." } + { "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." } { "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." } } "A word can be used to check if a class has an initial value or not:" From 41adbaf6bec27b5339a34fcddb35ec7c7ed86023 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:29:12 -0500 Subject: [PATCH 019/120] Fix display regression --- extra/ui/gadgets/borders/borders.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 2c232392ce..7d6a24fed1 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -33,7 +33,8 @@ M: border pref-dim* [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ; : border-loc ( border dim -- loc ) - [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ; + [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip + v- v* v+ [ >fixnum ] map ; : border-child-rect ( border -- rect ) dup border-dim [ border-loc ] keep ; From 3e082f21e37c0ff5f83a1d05e99110fa61d32e32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 01:29:25 -0500 Subject: [PATCH 020/120] Update minor demos for inheritance --- extra/gesture-logger/gesture-logger.factor | 4 ++-- extra/nehe/2/2.factor | 4 ++-- extra/nehe/3/3.factor | 4 ++-- extra/nehe/4/4.factor | 4 ++-- extra/nehe/5/5.factor | 4 ++-- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index ba0ff5bedd..d79593c337 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -5,10 +5,10 @@ ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors accessors ; IN: gesture-logger -TUPLE: gesture-logger stream ; +TUPLE: gesture-logger < gadget stream ; : ( stream -- gadget ) - \ gesture-logger construct-gadget + \ gesture-logger new-gadget swap >>stream { 100 100 } >>dim black solid-interior ; diff --git a/extra/nehe/2/2.factor b/extra/nehe/2/2.factor index 1084a3303e..d9560c92f6 100644 --- a/extra/nehe/2/2.factor +++ b/extra/nehe/2/2.factor @@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render ; IN: nehe.2 -TUPLE: nehe2-gadget ; +TUPLE: nehe2-gadget < gadget ; : width 256 ; : height 256 ; : ( -- gadget ) - nehe2-gadget construct-gadget ; + nehe2-gadget new-gadget ; M: nehe2-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; diff --git a/extra/nehe/3/3.factor b/extra/nehe/3/3.factor index fff58380d6..8a2149e370 100644 --- a/extra/nehe/3/3.factor +++ b/extra/nehe/3/3.factor @@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render ; IN: nehe.3 -TUPLE: nehe3-gadget ; +TUPLE: nehe3-gadget < gadget ; : width 256 ; : height 256 ; : ( -- gadget ) - nehe3-gadget construct-gadget ; + nehe3-gadget new-gadget ; M: nehe3-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index b87b4a2308..fc2727159b 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -2,14 +2,14 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render threads ; IN: nehe.4 -TUPLE: nehe4-gadget rtri rquad thread quit? ; +TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; : redraw-interval 10 ; : ( -- gadget ) - nehe4-gadget construct-gadget + nehe4-gadget new-gadget 0.0 over set-nehe4-gadget-rtri 0.0 over set-nehe4-gadget-rquad ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index 31a7d059ae..f399a116ed 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui ui.gadgets ui.render threads ; IN: nehe.5 -TUPLE: nehe5-gadget rtri rquad thread quit? ; +TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; : redraw-interval 10 ; : ( -- gadget ) - nehe5-gadget construct-gadget + nehe5-gadget new-gadget 0.0 over set-nehe5-gadget-rtri 0.0 over set-nehe5-gadget-rquad ; From c1328ac08e0500dcce7bba0c600d13cd386da884 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 12:22:27 -0500 Subject: [PATCH 021/120] math.physics.pos: distance method --- extra/math/physics/pos/pos.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/math/physics/pos/pos.factor b/extra/math/physics/pos/pos.factor index 1582c42108..69155686c8 100644 --- a/extra/math/physics/pos/pos.factor +++ b/extra/math/physics/pos/pos.factor @@ -1,5 +1,17 @@ +USING: kernel sequences multi-methods accessors math.vectors ; + IN: math.physics.pos TUPLE: pos pos ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: distance ( a b -- c ) + +METHOD: distance { sequence sequence } v- norm ; + +METHOD: distance { pos pos } [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 3bb6d9e57256fb17ee63ab7022bf2645f22f1233 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 12:29:51 -0500 Subject: [PATCH 022/120] boids: use 'distance' method --- extra/boids/boids.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index cff33c9d19..ab624a606b 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -73,10 +73,6 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : constrain ( n a b -- n ) rot min max ; : angle-between ( vec vec -- angle ) From 4a9363091ec9bfae869eb3ba2fe2a9243d295998 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 13:05:51 -0500 Subject: [PATCH 023/120] springies: use new accessors --- extra/springies/springies.factor | 46 ++++++++++++++------------------ 1 file changed, 20 insertions(+), 26 deletions(-) diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index fb69783975..818aa675e2 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -28,16 +28,10 @@ VAR: gravity ! node ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! TUPLE: node mass elas pos vel force ; - TUPLE: node < vel mass elas force ; C: node -! : >>pos ( node pos -- node ) over set-node-pos ; - -! : >>vel ( node vel -- node ) over set-node-vel ; - : node-vel ( node -- vel ) vel>> ; : set-node-vel ( vel node -- ) swap >>vel drop ; @@ -52,9 +46,9 @@ C: node : >>vel-x ( node x -- node ) over vel>> set-first ; : >>vel-y ( node y -- node ) over vel>> set-second ; -: apply-force ( node vec -- ) over node-force v+ swap set-node-force ; +: apply-force ( node vec -- ) over force>> v+ >>force drop ; -: reset-force ( node -- ) 0 0 2array swap set-node-force ; +: reset-force ( node -- node ) 0 0 2array >>force ; : node-id ( id -- node ) 1- nodes> nth ; @@ -67,12 +61,12 @@ TUPLE: spring rest-length k damp node-a node-b ; C: spring : end-points ( spring -- b-pos a-pos ) - [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ; + [ node-b>> pos>> ] [ node-a>> pos>> ] bi ; : spring-length ( spring -- length ) end-points v- norm ; : stretch-length ( spring -- length ) - [ spring-length ] [ spring-rest-length ] bi - ; + [ spring-length ] [ rest-length>> ] bi - ; : dir ( spring -- vec ) end-points v- normalize ; @@ -87,14 +81,14 @@ C: spring ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ; +: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ; : hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ; : hooke-forces ( spring -- a b ) hooke-force dup vneg ; : act-on-nodes-hooke ( spring -- ) - [ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd + [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd apply-force apply-force ; @@ -118,37 +112,37 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-a ( spring -- vel ) - [ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ; + [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ; : unit-vec-b->a ( spring -- vec ) - [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ; + [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ; : relative-velocity-along-spring-a ( spring -- vel ) [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; : damping-force-a ( spring -- vec ) - [ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ; + [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-b ( spring -- vel ) - [ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ; + [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ; : unit-vec-a->b ( spring -- vec ) - [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ; + [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ; : relative-velocity-along-spring-b ( spring -- vel ) [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; : damping-force-b ( spring -- vec ) - [ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ; + [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : act-on-nodes-damping ( spring -- ) dup - [ spring-node-a ] [ damping-force-a ] bi apply-force - [ spring-node-b ] [ damping-force-b ] bi apply-force ; + [ node-a>> ] [ damping-force-a ] bi apply-force + [ node-b>> ] [ damping-force-b ] bi apply-force ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -164,22 +158,22 @@ C: spring : bounce-top ( node -- ) world-height 1- >>pos-y - dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + dup [ vel-y ] [ elas>> ] bi * neg >>vel-y drop ; : bounce-bottom ( node -- ) 0 >>pos-y - dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + dup [ vel-y ] [ elas>> ] bi * neg >>vel-y drop ; : bounce-left ( node -- ) 0 >>pos-x - dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + dup [ vel-x ] [ elas>> ] bi * neg >>vel-x drop ; : bounce-right ( node -- ) world-width 1- >>pos-x - dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + dup [ vel-x ] [ elas>> ] bi * neg >>vel-x drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -213,7 +207,7 @@ C: spring ! F = ma -: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; +: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ; : new-vel ( node -- vel ) [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ; @@ -223,7 +217,7 @@ C: spring : iterate-node ( node -- ) dup new-pos >>pos dup new-vel >>vel - dup reset-force + reset-force handle-bounce ; : iterate-nodes ( -- ) nodes> [ iterate-node ] each ; From 8160859c8b61cb63bb0308a959d1920b3f0ad21f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 13:12:45 -0500 Subject: [PATCH 024/120] Fixes --- core/classes/tuple/parser/parser-tests.factor | 2 +- core/optimizer/math/math.factor | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 10cbe268da..d40b71b477 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -51,7 +51,7 @@ must-fail-with [ error>> unexpected-eof? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ error>> no-initial-value? ] must-fail-with diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 799f4d80cf..b208a9f894 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -444,7 +444,10 @@ most-negative-fixnum most-positive-fixnum [a,b] { /f < > <= >= } [ { real real } "input-classes" set-word-prop ] each -{ /i bitand bitor bitxor bitnot shift } +{ /i mod /mod } +[ { rational rational } "input-classes" set-word-prop ] each + +{ bitand bitor bitxor bitnot shift } [ { integer integer } "input-classes" set-word-prop ] each { From 80a38f8990d473fa5bc63709ce44357c8df0413b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:48:20 -0500 Subject: [PATCH 025/120] boids.ui: use newfx --- extra/boids/ui/ui.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index ab1f8e5f80..b1f594b8c2 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -20,7 +20,8 @@ USING: combinators.short-circuit kernel namespaces ui.gadgets.grids ui.gestures assocs.lib vars rewrite-closures boids accessors - math.geometry.rect ; + math.geometry.rect + newfx ; IN: boids.ui @@ -145,20 +146,20 @@ VARS: population-label cohesion-label alignment-label separation-label ; slate> over @center grid-add H{ } clone - T{ key-down f f "1" } C[ drop randomize ] put-at - T{ key-down f f "2" } C[ drop sub-10-boids ] put-at - T{ key-down f f "3" } C[ drop add-10-boids ] put-at + T{ key-down f f "1" } C[ drop randomize ] is + T{ key-down f f "2" } C[ drop sub-10-boids ] is + T{ key-down f f "3" } C[ drop add-10-boids ] is - T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at - T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at + T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is + T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at - T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at + T{ key-down f f "w" } C[ drop inc-alignment-weight ] is + T{ key-down f f "s" } C[ drop dec-alignment-weight ] is - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at - T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at + T{ key-down f f "e" } C[ drop inc-separation-weight ] is + T{ key-down f f "d" } C[ drop dec-separation-weight ] is - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at + T{ key-down f f "ESC" } C[ drop toggle-loop ] is tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; From 44c2b9823de331a9ab3e97cf63704693d0108904 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:49:14 -0500 Subject: [PATCH 026/120] assocs.lib: remove old code --- extra/assocs/lib/lib.factor | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 14632df771..5036a13d78 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,13 +1,8 @@ USING: arrays assocs kernel vectors sequences namespaces -random math.parser math fry ; + random math.parser math fry ; + IN: assocs.lib -: ref-at ( table key -- value ) swap at ; - -: put-at* ( table key value -- ) swap rot set-at ; - -: put-at ( table key value -- table ) swap pick set-at ; - : set-assoc-stack ( value key seq -- ) dupd [ key? ] with find-last nip set-at ; From 2374b4293d0c35cad3137a5ac086f781fd5ae2ca Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 15:53:20 -0500 Subject: [PATCH 027/120] automata: no need for >array when using --- extra/automata/automata.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index a70eaa063d..979a733692 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -32,7 +32,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; ! step-wrapped-line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: pattern>state ( {_a_b_c_} -- state ) >array rule> at ; +: pattern>state ( {_a_b_c_} -- state ) rule> at ; : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; From 5decac30d2861c4649c8c08ca131cd9c32f206ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 16:46:50 -0500 Subject: [PATCH 028/120] automata.ui: new automata-window* --- extra/automata/ui/ui.factor | 65 +++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 21 deletions(-) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index cfec6597c2..5678a6f06b 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -14,13 +14,25 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.packs ui.gadgets.grids ui.gadgets.theme + accessors + qualified namespaces.lib assocs.lib vars - rewrite-closures automata math.geometry.rect ; + rewrite-closures automata math.geometry.rect newfx ; IN: automata.ui ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +QUALIFIED: ui.gadgets +QUALIFIED: ui.gadgets.grids + +: add-gadget ( parent child -- parent ) over ui.gadgets:add-gadget ; + +: grid-add ( grid child i j -- grid ) + >r >r dupd swap r> r> ui.gadgets.grids:grid-add ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ; : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ; @@ -57,29 +69,40 @@ slate> relayout-1 ; DEFER: automata-window -: automata-window* ( -- ) init-rule set-interesting +: automata-window* ( -- ) + init-rule + set-interesting -{ -[ "1 - Center" [ start-center ] view-button ] -[ "2 - Random" [ start-random ] view-button ] -[ "3 - Continue" [ run-rule ] view-button ] -[ "5 - Random Rule" [ random-rule ] view-button ] -[ "n - New" [ automata-window ] view-button ] -} make* -[ [ gadget, ] curry ] map concat ! Hack -make-shelf over @top grid-add + -[ display ] closed-quot { 400 400 } over set-slate-dim dup >slate -over @center grid-add + -{ -{ T{ key-down f f "1" } [ [ start-center ] view-action ] } -{ T{ key-down f f "2" } [ [ start-random ] view-action ] } -{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } -{ T{ key-down f f "5" } [ [ random-rule ] view-action ] } -{ T{ key-down f f "n" } [ [ automata-window ] view-action ] } -} [ make* ] map >hashtable tuck set-gadget-delegate -"Automata" open-window ; + "1 - Center" [ start-center ] view-button add-gadget + "2 - Random" [ start-random ] view-button add-gadget + "3 - Continue" [ run-rule ] view-button add-gadget + "5 - Random Rule" [ random-rule ] view-button add-gadget + "n - New" [ automata-window ] view-button add-gadget + + @top grid-add + + C[ display ] + { 400 400 } >>dim + dup >slate + + @center grid-add + + H{ } + T{ key-down f f "1" } [ start-center ] view-action is + T{ key-down f f "2" } [ start-random ] view-action is + T{ key-down f f "3" } [ run-rule ] view-action is + T{ key-down f f "5" } [ random-rule ] view-action is + T{ key-down f f "n" } [ automata-window ] view-action is + + + + tuck set-gadget-delegate + + "Automata" open-window ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From e16aa9ead3c2873e3def98f8904d0f5f8238af18 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:45:57 -0500 Subject: [PATCH 029/120] ui.gadgets: update parent accessors --- extra/ui/gadgets/gadgets.factor | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index a274dc2392..fcb6c765a3 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -12,10 +12,10 @@ SYMBOL: ui-notify-flag : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; TUPLE: gadget < rect -pref-dim parent children orientation focus -visible? root? clipped? layout-state graft-state graft-node -interior boundary -model ; + pref-dim parent children orientation focus + visible? root? clipped? layout-state graft-state graft-node + interior boundary + model ; M: gadget equal? 2drop f ; @@ -58,7 +58,7 @@ M: gadget model-changed 2drop ; 2drop { 0 0 } ] [ over rect-loc >r - >r gadget-parent r> relative-loc + >r parent>> r> relative-loc r> v+ ] if ; @@ -150,7 +150,7 @@ DEFER: relayout \ invalidate* over set-gadget-layout-state dup forget-pref-dim dup gadget-root? - [ layout-later ] [ gadget-parent [ relayout ] when* ] if ; + [ layout-later ] [ parent>> [ relayout ] when* ] if ; : relayout ( gadget -- ) dup gadget-layout-state \ invalidate* eq? @@ -255,7 +255,7 @@ M: gadget ungraft* drop ; : (unparent) ( gadget -- ) dup ungraft dup forget-pref-dim - f swap set-gadget-parent ; + f swap (>>parent) ; : unfocus-gadget ( child gadget -- ) tuck gadget-focus eq? @@ -270,7 +270,7 @@ SYMBOL: in-layout? : unparent ( gadget -- ) not-in-layout [ - dup gadget-parent dup [ + dup parent>> dup [ over (unparent) [ unfocus-gadget ] 2keep [ gadget-children delete ] keep @@ -294,7 +294,7 @@ SYMBOL: in-layout? : (add-gadget) ( gadget box -- ) over unparent - dup pick set-gadget-parent + dup pick (>>parent) [ ((add-gadget)) ] 2keep gadget-graft-state second [ graft ] [ drop ] if ; @@ -307,7 +307,7 @@ SYMBOL: in-layout? swap [ over (add-gadget) ] each relayout ; : parents ( gadget -- seq ) - [ gadget-parent ] follow ; + [ parent>> ] follow ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -319,7 +319,7 @@ SYMBOL: in-layout? parents { 0 0 } [ rect-loc v+ ] reduce ; : (screen-rect) ( gadget -- loc ext ) - dup gadget-parent [ + dup parent>> [ >r rect-extent r> (screen-rect) >r tuck v+ r> vmin >r v+ r> ] [ @@ -333,7 +333,7 @@ SYMBOL: in-layout? { { [ 2dup eq? ] [ 2drop t ] } { [ dup not ] [ 2drop f ] } - [ gadget-parent child? ] + [ parent>> child? ] } cond ; GENERIC: focusable-child* ( gadget -- child/t ) @@ -346,7 +346,7 @@ M: gadget focusable-child* drop t ; GENERIC: request-focus-on ( child gadget -- ) -M: gadget request-focus-on gadget-parent request-focus-on ; +M: gadget request-focus-on parent>> request-focus-on ; M: f request-focus-on 2drop ; @@ -371,7 +371,7 @@ M: f request-focus-on 2drop ; ! Deprecated : set-gadget-delegate ( gadget tuple -- ) over [ - dup pick [ set-gadget-parent ] with each-child + dup pick [ (>>parent) ] with each-child ] when set-delegate ; : construct-gadget ( class -- tuple ) From a4678cc758d0813e4502badedaad9a20755230f1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:48:08 -0500 Subject: [PATCH 030/120] ui.gadgets: update children accessors --- extra/ui/gadgets/gadgets.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index fcb6c765a3..62d01d844b 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -23,9 +23,9 @@ M: gadget hashcode* drop gadget hashcode* ; M: gadget model-changed 2drop ; -: gadget-child ( gadget -- child ) gadget-children first ; +: gadget-child ( gadget -- child ) children>> first ; -: nth-gadget ( n gadget -- child ) gadget-children nth ; +: nth-gadget ( n gadget -- child ) children>> nth ; : new-gadget ( class -- gadget ) new @@ -68,7 +68,7 @@ M: gadget user-input* 2drop t ; GENERIC: children-on ( rect/point gadget -- seq ) -M: gadget children-on nip gadget-children ; +M: gadget children-on nip children>> ; : (fast-children-on) ( dim axis gadgets -- i ) swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; @@ -100,7 +100,7 @@ M: gadget children-on nip gadget-children ; >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ; : each-child ( gadget quot -- ) - >r gadget-children r> each ; inline + >r children>> r> each ; inline ! Selection protocol GENERIC: gadget-selection? ( gadget -- ? ) @@ -124,7 +124,7 @@ M: gadget gadget-text-separator [ dup % ] [ gadget-text* ] interleave drop ; M: gadget gadget-text* - dup gadget-children swap gadget-seq-text ; + dup children>> swap gadget-seq-text ; M: array gadget-text* [ gadget-text* ] each ; @@ -273,7 +273,7 @@ SYMBOL: in-layout? dup parent>> dup [ over (unparent) [ unfocus-gadget ] 2keep - [ gadget-children delete ] keep + [ children>> delete ] keep relayout ] [ 2drop @@ -283,14 +283,14 @@ SYMBOL: in-layout? : (clear-gadget) ( gadget -- ) dup [ (unparent) ] each-child f over set-gadget-focus - f swap set-gadget-children ; + f swap (>>children) ; : clear-gadget ( gadget -- ) not-in-layout dup (clear-gadget) relayout ; : ((add-gadget)) ( gadget box -- ) - [ gadget-children ?push ] keep set-gadget-children ; + [ children>> ?push ] keep (>>children) ; : (add-gadget) ( gadget box -- ) over unparent From 33da43aa907b7d392bab6551d31137b552dd8010 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:54:57 -0500 Subject: [PATCH 031/120] ui.gadgets: more accessor updates --- extra/ui/gadgets/gadgets.factor | 46 ++++++++++++++++----------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 62d01d844b..6f49791164 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -37,7 +37,7 @@ M: gadget model-changed 2drop ; gadget new-gadget ; : activate-control ( gadget -- ) - dup gadget-model dup [ + dup model>> dup [ 2dup add-connection swap model-changed ] [ @@ -45,13 +45,13 @@ M: gadget model-changed 2drop ; ] if ; : deactivate-control ( gadget -- ) - dup gadget-model dup [ 2dup remove-connection ] when 2drop ; + dup model>> dup [ 2dup remove-connection ] when 2drop ; : control-value ( control -- value ) - gadget-model model-value ; + model>> model-value ; : set-control-value ( value control -- ) - gadget-model set-model ; + model>> set-model ; : relative-loc ( fromgadget togadget -- loc ) 2dup eq? [ @@ -83,7 +83,7 @@ M: gadget children-on nip children>> ; r> ; : inside? ( bounds gadget -- ? ) - dup gadget-visible? [ intersects? ] [ 2drop f ] if ; + dup visible?>> [ intersects? ] [ 2drop f ] if ; : (pick-up) ( point gadget -- gadget ) dupd children-on [ inside? ] with find-last nip ; @@ -97,7 +97,7 @@ M: gadget children-on nip children>> ; : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ; : orient ( gadget seq1 seq2 -- seq ) - >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ; + >r >r orientation>> r> r> [ pick set-axis ] 2map nip ; : each-child ( gadget quot -- ) >r children>> r> each ; inline @@ -117,7 +117,7 @@ GENERIC: gadget-text* ( gadget -- ) GENERIC: gadget-text-separator ( gadget -- str ) M: gadget gadget-text-separator - gadget-orientation { 0 1 } = "\n" "" ? ; + orientation>> { 0 1 } = "\n" "" ? ; : gadget-seq-text ( seq gadget -- ) gadget-text-separator swap @@ -132,9 +132,9 @@ M: array gadget-text* : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : invalidate ( gadget -- ) - \ invalidate swap set-gadget-layout-state ; + \ invalidate swap (>>layout-state) ; -: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; +: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ; : layout-queue ( -- queue ) \ layout-queue get ; @@ -147,22 +147,22 @@ M: array gadget-text* DEFER: relayout : invalidate* ( gadget -- ) - \ invalidate* over set-gadget-layout-state + \ invalidate* over (>>layout-state) dup forget-pref-dim dup gadget-root? [ layout-later ] [ parent>> [ relayout ] when* ] if ; : relayout ( gadget -- ) - dup gadget-layout-state \ invalidate* eq? + dup layout-state>> \ invalidate* eq? [ drop ] [ invalidate* ] if ; : relayout-1 ( gadget -- ) - dup gadget-layout-state + dup layout-state>> [ drop ] [ dup invalidate layout-later ] if ; -: show-gadget ( gadget -- ) t swap set-gadget-visible? ; +: show-gadget ( gadget -- ) t swap (>>visible?) ; -: hide-gadget ( gadget -- ) f swap set-gadget-visible? ; +: hide-gadget ( gadget -- ) f swap (>>visible?) ; : (set-rect-dim) ( dim gadget quot -- ) >r 2dup rect-dim = @@ -178,11 +178,11 @@ DEFER: relayout GENERIC: pref-dim* ( gadget -- dim ) : ?set-gadget-pref-dim ( dim gadget -- ) - dup gadget-layout-state - [ 2drop ] [ set-gadget-pref-dim ] if ; + dup layout-state>> + [ 2drop ] [ (>>pref-dim) ] if ; : pref-dim ( gadget -- dim ) - dup gadget-pref-dim [ ] [ + dup pref-dim>> [ ] [ [ pref-dim* dup ] keep ?set-gadget-pref-dim ] ?if ; @@ -196,10 +196,10 @@ M: gadget layout* drop ; : prefer ( gadget -- ) dup pref-dim swap set-layout-dim ; -: validate ( gadget -- ) f swap set-gadget-layout-state ; +: validate ( gadget -- ) f swap (>>layout-state) ; : layout ( gadget -- ) - dup gadget-layout-state [ + dup layout-state>> [ dup validate dup layout* dup [ layout ] each-child @@ -258,8 +258,8 @@ M: gadget ungraft* drop ; f swap (>>parent) ; : unfocus-gadget ( child gadget -- ) - tuck gadget-focus eq? - [ f swap set-gadget-focus ] [ drop ] if ; + tuck focus>> eq? + [ f swap (>>focus) ] [ drop ] if ; SYMBOL: in-layout? @@ -282,7 +282,7 @@ SYMBOL: in-layout? : (clear-gadget) ( gadget -- ) dup [ (unparent) ] each-child - f over set-gadget-focus + f over (>>focus) f swap (>>children) ; : clear-gadget ( gadget -- ) @@ -354,7 +354,7 @@ M: f request-focus-on 2drop ; [ focusable-child ] keep request-focus-on ; : focus-path ( world -- seq ) - [ gadget-focus ] follow ; + [ focus>> ] follow ; : gadget, ( gadget -- ) gadget get add-gadget ; From 80783019c2773a0416d304baac7b4ce32b11a3cd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:57:57 -0500 Subject: [PATCH 032/120] ui.gadgets: cleaner fast-children-on --- extra/ui/gadgets/gadgets.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 6f49791164..f5e1f35081 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -74,13 +74,9 @@ M: gadget children-on nip children>> ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; : fast-children-on ( rect axis children -- from to ) - 3dup - >r >r dup rect-loc swap rect-dim v+ - r> r> (fast-children-on) ?1+ - >r - >r >r rect-loc - r> r> (fast-children-on) 0 or - r> ; + [ >r >r rect-loc r> r> (fast-children-on) 0 or ] + [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] + 3bi ; : inside? ( bounds gadget -- ? ) dup visible?>> [ intersects? ] [ 2drop f ] if ; From 49f58ce15b30a06c5cc6eda1a67f40bdd2b1fed5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 17:58:44 -0500 Subject: [PATCH 033/120] ui.gadgets: proper indentation --- extra/ui/gadgets/gadgets.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index f5e1f35081..59041c6115 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -74,9 +74,9 @@ M: gadget children-on nip children>> ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; : fast-children-on ( rect axis children -- from to ) - [ >r >r rect-loc r> r> (fast-children-on) 0 or ] - [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] - 3bi ; + [ >r >r rect-loc r> r> (fast-children-on) 0 or ] + [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ] + 3bi ; : inside? ( bounds gadget -- ? ) dup visible?>> [ intersects? ] [ 2drop f ] if ; From 32ca39ce8580590003da788d5f35c49d8d0d0e9e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Jul 2008 18:02:32 -0500 Subject: [PATCH 034/120] ui.gadgets: more accessors updates --- extra/ui/gadgets/gadgets.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 59041c6115..3fc185a10e 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -219,7 +219,7 @@ M: gadget layout* drop ; { t f } (queue-graft) ; : graft-later ( gadget -- ) - dup gadget-graft-state { + dup graft-state>> { { { f t } [ drop ] } { { t t } [ drop ] } { { t f } [ unqueue-graft ] } @@ -227,7 +227,7 @@ M: gadget layout* drop ; } case ; : ungraft-later ( gadget -- ) - dup gadget-graft-state { + dup graft-state>> { { { f f } [ drop ] } { { t f } [ drop ] } { { f t } [ unqueue-graft ] } @@ -292,7 +292,7 @@ SYMBOL: in-layout? over unparent dup pick (>>parent) [ ((add-gadget)) ] 2keep - gadget-graft-state second [ graft ] [ drop ] if ; + graft-state>> second [ graft ] [ drop ] if ; : add-gadget ( gadget parent -- ) not-in-layout From 0770d50d7b67c810c571dfbe049faba0c7d53cc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 18:52:31 -0500 Subject: [PATCH 035/120] Bi-assocs: fast at and value-at --- core/assocs/assocs.factor | 9 ++++--- extra/biassocs/biassocs-tests.factor | 22 +++++++++++++++++ extra/biassocs/biassocs.factor | 35 ++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+), 3 deletions(-) create mode 100644 extra/biassocs/biassocs-tests.factor create mode 100644 extra/biassocs/biassocs.factor diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index f56ac810d9..6cb8958298 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; -! M: assoc >alist [ 2array ] { } assoc>map ; +GENERIC: value-at* ( value assoc -- key/f ? ) -: value-at ( value assoc -- key/f ) - swap [ = nip ] curry assoc-find 2drop ; +M: assoc value-at* swap [ = nip ] curry assoc-find nip ; + +: value-at ( value assoc -- key/f ) value-at* drop ; + +: value? ( value assoc -- ? ) value-at* nip ; : push-at ( value key assoc -- ) [ ?push ] change-at ; diff --git a/extra/biassocs/biassocs-tests.factor b/extra/biassocs/biassocs-tests.factor new file mode 100644 index 0000000000..4cd7f00f80 --- /dev/null +++ b/extra/biassocs/biassocs-tests.factor @@ -0,0 +1,22 @@ +IN: biassocs.tests +USING: biassocs assocs namespaces tools.test ; + + "h" set + +[ 0 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 2 "h" get set-at ] unit-test + +[ 1 ] [ 2 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 1 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 3 "h" get set-at ] unit-test + +[ 1 ] [ 3 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 2 ] [ "h" get assoc-size ] unit-test diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor new file mode 100644 index 0000000000..9f12d04fc4 --- /dev/null +++ b/extra/biassocs/biassocs.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs accessors ; +IN: biassocs + +TUPLE: biassoc from to ; + +: ( exemplar -- biassoc ) + [ clone ] [ clone ] bi biassoc boa ; + +: ( -- bihashtable ) + H{ } ; + +M: biassoc assoc-size from>> assoc-size ; + +M: biassoc at* from>> at* ; + +M: biassoc value-at* to>> at* ; + +: once-at ( value key assoc -- ) + 2dup key? [ 3drop ] [ set-at ] if ; + +M: biassoc set-at + [ from>> set-at ] [ swapd to>> once-at ] 3bi ; + +M: biassoc delete-at + "biassocs do not support deletion" throw ; + +M: biassoc >alist + from>> >alist ; + +M: biassoc clear-assoc + [ from>> clear-assoc ] [ to>> clear-assoc ] bi ; + +INSTANCE: biassoc assoc From eda828169465529cb2bb05b21dbc1d237ad8470d Mon Sep 17 00:00:00 2001 From: erg Date: Sat, 12 Jul 2008 20:56:44 -0500 Subject: [PATCH 036/120] document conjoin --- core/sets/sets-docs.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 205d4d34bf..57d62f6480 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -38,6 +38,18 @@ HELP: adjoin } { $side-effects "seq" } ; +HELP: conjoin +{ $values { "elt" object } { "assoc" "an assoc" } } +{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." } +{ $examples + { $example + "USING: kernel prettyprint sets ;" + "H{ } clone 1 over conjoin ." + "H{ { 1 1 } }" + } +} +{ $side-effects "assoc" } ; + HELP: unique { $values { "seq" "a sequence" } { "assoc" "an assoc" } } { $description "Outputs a new assoc where the keys and values are equal." } From a700ec70418a6801f4bc364d2f3d48f8f9ea665e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 21:15:11 -0500 Subject: [PATCH 037/120] More efficient float arrayss; 15% improvement on spectral-norm --- core/alien/c-types/c-types.factor | 3 ++- extra/float-arrays/float-arrays.factor | 24 ++++++++---------------- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index e576b87f52..405d679f4a 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -151,7 +151,8 @@ M: byte-array byte-length length ; swap dup length memcpy ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap prefix r> append define-inline ; + >r heap-size [ rot * >fixnum ] swap prefix + r> append define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor index 668bb7de41..0aa7fa5056 100755 --- a/extra/float-arrays/float-arrays.factor +++ b/extra/float-arrays/float-arrays.factor @@ -9,16 +9,8 @@ TUPLE: float-array { length array-capacity read-only } { underlying byte-array read-only } ; -bytes 8 * ; inline - -: float-array@ underlying>> swap >fixnum floats>bytes ; inline - -PRIVATE> - : ( n -- float-array ) - dup floats>bytes float-array boa ; inline + dup "double" float-array boa ; inline M: float-array clone [ length>> ] [ underlying>> clone ] bi float-array boa ; @@ -26,13 +18,13 @@ M: float-array clone M: float-array length length>> ; M: float-array nth-unsafe - float-array@ alien-double ; + underlying>> double-nth ; M: float-array set-nth-unsafe - [ >float ] 2dip float-array@ set-alien-double ; + [ >float ] 2dip underlying>> set-double-nth ; : >float-array ( seq -- float-array ) - T{ float-array f 0 B{ } } clone-like ; inline + T{ float-array } clone-like ; inline M: float-array like drop dup float-array? [ >float-array ] unless ; @@ -45,7 +37,7 @@ M: float-array equal? M: float-array resize [ drop ] [ - [ floats>bytes ] [ underlying>> ] bi* + [ "double" heap-size * ] [ underlying>> ] bi* resize-byte-array ] 2bi float-array boa ; @@ -58,13 +50,13 @@ INSTANCE: float-array sequence 1 [ set-first ] keep ; flushable : 2float-array ( x y -- array ) - T{ float-array f 0 B{ } } 2sequence ; flushable + T{ float-array } 2sequence ; flushable : 3float-array ( x y z -- array ) - T{ float-array f 0 B{ } } 3sequence ; flushable + T{ float-array } 3sequence ; flushable : 4float-array ( w x y z -- array ) - T{ float-array f 0 B{ } } 4sequence ; flushable + T{ float-array } 4sequence ; flushable : F{ ( parsed -- parsed ) \ } [ >float-array ] parse-literal ; parsing From f1879cb33788a91479ebb421d4f1fc8219a8447b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 21:28:43 -0500 Subject: [PATCH 038/120] Doc updates --- core/assocs/assocs-docs.factor | 20 +++++++++++++++++--- core/grouping/grouping-docs.factor | 4 ++++ extra/biassocs/authors.txt | 1 + extra/biassocs/biassocs-docs.factor | 28 ++++++++++++++++++++++++++++ extra/biassocs/biassocs.factor | 2 +- extra/biassocs/summary.txt | 1 + extra/biassocs/tags.txt | 1 + extra/bitfields/tags.txt | 1 - extra/lists/tags.txt | 4 +--- 9 files changed, 54 insertions(+), 8 deletions(-) create mode 100644 extra/biassocs/authors.txt create mode 100644 extra/biassocs/biassocs-docs.factor create mode 100644 extra/biassocs/summary.txt create mode 100644 extra/biassocs/tags.txt diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 0e1042391c..51293955d5 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -57,13 +57,19 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" { $subsection key? } { $subsection at } -{ $subsection value-at } { $subsection assoc-empty? } { $subsection keys } { $subsection values } { $subsection assoc-stack } { $see-also at* assoc-size } ; +ARTICLE: "assocs-values" "Transposed assoc operations" +"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:" +{ $subsection value-at } +{ $subsection value-at* } +{ $subsection value? } +"With most assoc implementations, these words runs in linear time, proportional to the number of entries in the assoc. For fast value lookups, use " { $vocab-link "biassocs" } "." ; + ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." { $subsection assoc-subset? } @@ -111,6 +117,7 @@ $nl { $subsection "assocs-protocol" } "A large set of utility words work on any object whose class implements the associative mapping protocol." { $subsection "assocs-lookup" } +{ $subsection "assocs-values" } { $subsection "assocs-mutation" } { $subsection "assocs-combinators" } { $subsection "assocs-sets" } ; @@ -231,10 +238,17 @@ HELP: assoc-stack { $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." } { $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ; +HELP: value-at* +{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } { "?" "a boolean" } } +{ $description "Looks up the key associated with a value. The boolean flag can decide beteen the case of a missing key, and a key of " { $link f } "." } ; + HELP: value-at { $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } } -{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } -{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ; +{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } ; + +HELP: value? +{ $values { "value" "an object" } { "assoc" assoc } { "?" "a boolean" } } +{ $description "Tests if an assoc contains at least one key with the given value." } ; HELP: delete-at* { $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } } diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index f7a37691a6..3b3a98eabd 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -2,10 +2,14 @@ USING: help.markup help.syntax sequences strings ; IN: grouping ARTICLE: "grouping" "Groups and clumps" +"Splitting a sequence into disjoint, fixed-length subsequences:" +{ $subsection group } "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" { $subsection groups } { $subsection } { $subsection } +"Splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clump } "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" { $subsection clumps } { $subsection } diff --git a/extra/biassocs/authors.txt b/extra/biassocs/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/biassocs/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/biassocs/biassocs-docs.factor b/extra/biassocs/biassocs-docs.factor new file mode 100644 index 0000000000..1fde3d05b3 --- /dev/null +++ b/extra/biassocs/biassocs-docs.factor @@ -0,0 +1,28 @@ +IN: biassocs +USING: help.markup help.syntax assocs kernel ; + +HELP: biassoc +{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ; + +HELP: +{ $values { "exemplar" assoc } { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ; + +HELP: +{ $values { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ; + +HELP: once-at +{ $values { "value" object } { "key" object } { "assoc" assoc } } +{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ; + +ARTICLE: "biassocs" "Bidirectional assocs" +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +$nl +"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." +{ $subsection biassoc } +{ $subsection biassoc? } +{ $subsection } +{ $subsection } ; + +ABOUT: "biassocs" diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor index 9f12d04fc4..cd1e57f6ec 100644 --- a/extra/biassocs/biassocs.factor +++ b/extra/biassocs/biassocs.factor @@ -8,7 +8,7 @@ TUPLE: biassoc from to ; : ( exemplar -- biassoc ) [ clone ] [ clone ] bi biassoc boa ; -: ( -- bihashtable ) +: ( -- biassoc ) H{ } ; M: biassoc assoc-size from>> assoc-size ; diff --git a/extra/biassocs/summary.txt b/extra/biassocs/summary.txt new file mode 100644 index 0000000000..84c5b15afc --- /dev/null +++ b/extra/biassocs/summary.txt @@ -0,0 +1 @@ +Bidirectional assocs diff --git a/extra/biassocs/tags.txt b/extra/biassocs/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/biassocs/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/bitfields/tags.txt b/extra/bitfields/tags.txt index 9ffc038dbd..f4274299b1 100644 --- a/extra/bitfields/tags.txt +++ b/extra/bitfields/tags.txt @@ -1,2 +1 @@ -collections extensions diff --git a/extra/lists/tags.txt b/extra/lists/tags.txt index e44334b2b5..42d711b32b 100644 --- a/extra/lists/tags.txt +++ b/extra/lists/tags.txt @@ -1,3 +1 @@ -cons -lists -sequences +collections From 16b85df5db54c427c036db81614dd49d836b52d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Jul 2008 22:27:28 -0500 Subject: [PATCH 039/120] Fixes and a small optiimization --- core/bootstrap/image/image.factor | 3 +++ core/cpu/x86/bootstrap.factor | 6 +++++ core/generator/fixup/fixup.factor | 1 + core/inference/errors/errors.factor | 6 ++--- core/optimizer/def-use/def-use.factor | 5 ++-- core/optimizer/known-words/known-words.factor | 18 ++++++------- core/optimizer/math/math.factor | 8 +++--- .../pattern-match/pattern-match.factor | 5 ++-- extra/optimizer/debugger/debugger.factor | 10 +++---- vm/code_heap.c | 2 ++ vm/code_heap.h | 4 ++- vm/quotations.c | 5 ++-- vm/run.h | 26 +++---------------- 13 files changed, 46 insertions(+), 53 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 632938bb2d..97a95f98b8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -119,6 +119,7 @@ SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-literal +SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-jump SYMBOL: jit-dispatch-word @@ -149,6 +150,7 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } + { jit-push-immediate 36 } { jit-declare-word 42 } { undefined-quot 60 } } at header-size + ; @@ -438,6 +440,7 @@ M: quotation ' jit-word-jump jit-word-call jit-push-literal + jit-push-immediate jit-if-word jit-if-jump jit-dispatch-word diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bd90ca65f0..76a42b3f2d 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -40,6 +40,12 @@ big-endian off ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define +[ + arg0 0 MOV ! load literal + ds-reg bootstrap-cell ADD ! increment datastack pointer + ds-reg [] arg0 MOV ! store literal on datastack +] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define + [ arg0 0 MOV ! load XT arg1 stack-reg MOV ! pass callstack pointer as arg 2 diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 058822bf2f..9be8151bee 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -72,6 +72,7 @@ SYMBOL: label-table : rt-xt 4 ; : rt-here 5 ; : rt-label 6 ; +: rt-immediate 7 ; TUPLE: label-fixup label class ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index e1d5bd434c..9e01492529 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel generic sequences prettyprint io words arrays +summary effects debugger assocs accessors inference.backend +inference.dataflow ; IN: inference.errors -USING: inference.backend inference.dataflow kernel generic -sequences prettyprint io words arrays summary effects debugger -assocs accessors ; M: inference-error error-help error>> error-help ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index d4905a1718..55088fd7e2 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences inference.dataflow -inference.backend kernel generic assocs classes vectors -accessors combinators ; +USING: namespaces assocs sequences kernel generic assocs classes +vectors accessors combinators inference.dataflow inference.backend ; IN: optimizer.def-use SYMBOL: def-use diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 76ad0009cb..7527199fe9 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays generic hashtables definitions -inference.dataflow inference.state inference.class kernel assocs -math math.order math.private kernel.private sequences words -parser vectors strings sbufs io namespaces assocs quotations -sequences.private io.binary io.streams.string layouts splitting -math.intervals math.floats.private classes.tuple classes.predicate -classes.tuple.private classes classes.algebra optimizer.def-use -optimizer.backend optimizer.pattern-match optimizer.inlining -sequences.private combinators byte-arrays byte-vectors -slots.private ; +kernel assocs math math.order math.private kernel.private +sequences words parser vectors strings sbufs io namespaces +assocs quotations sequences.private io.binary io.streams.string +layouts splitting math.intervals math.floats.private +classes.tuple classes.predicate classes.tuple.private classes +classes.algebra sequences.private combinators byte-arrays +byte-vectors slots.private inference.dataflow inference.state +inference.class optimizer.def-use optimizer.backend +optimizer.pattern-match optimizer.inlining ; IN: optimizer.known-words { (tuple) } [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b208a9f894..c20cba99cb 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: effects alien alien.accessors arrays generic hashtables kernel assocs math math.libm math.private kernel.private -sequences words parser inference.class inference.dataflow -vectors strings sbufs io namespaces assocs quotations -math.intervals sequences.private combinators splitting layouts -math.parser classes classes.algebra generic.math +sequences words parser vectors strings sbufs io namespaces +assocs quotations math.intervals sequences.private combinators +splitting layouts math.parser classes classes.algebra +generic.math inference.class inference.dataflow optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining optimizer.math.partial generic.standard system accessors ; diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 51fa254a25..647dda368f 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces generic +combinators classes classes.algebra +inference inference.dataflow ; IN: optimizer.pattern-match -USING: kernel sequences inference namespaces generic -combinators classes classes.algebra inference.dataflow ; ! Funny pattern matching SYMBOL: @ diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index c20685cf70..2a79d8977f 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes inference inference.dataflow io kernel -kernel.private math.parser namespaces optimizer prettyprint -prettyprint.backend sequences words arrays match macros -assocs sequences.private optimizer.specializers generic -combinators sorting math quotations accessors ; +USING: classes io kernel kernel.private math.parser namespaces +optimizer prettyprint prettyprint.backend sequences words arrays +match macros assocs sequences.private generic combinators +sorting math quotations accessors inference inference.dataflow +optimizer.specializers ; IN: optimizer.debugger ! A simple tool for turning dataflow IR into quotations, for diff --git a/vm/code_heap.c b/vm/code_heap.c index 69ffdeb2aa..1435caa9d2 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -63,6 +63,8 @@ INLINE CELL compute_code_rel(F_REL *rel, return (CELL)get_rel_symbol(rel,literals_start); case RT_LITERAL: return CREF(literals_start,REL_ARGUMENT(rel)); + case RT_IMMEDIATE: + return get(CREF(literals_start,REL_ARGUMENT(rel))); case RT_XT: return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; case RT_HERE: diff --git a/vm/code_heap.h b/vm/code_heap.h index 80605b1d28..c3b476c4b5 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -12,7 +12,9 @@ typedef enum { /* current offset */ RT_HERE, /* a local label */ - RT_LABEL + RT_LABEL, + /* immeditae literal */ + RT_IMMEDIATE } F_RELTYPE; typedef enum { diff --git a/vm/quotations.c b/vm/quotations.c index 2d54f23a6f..a1555136db 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -30,9 +30,8 @@ push the array and immediately drop it after. in the VM. They are open-coded and no subroutine call is generated. This includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) -so this results in a big speedup for relatively little effort. +so this results in a big speedup for relatively little effort. */ -*/ bool jit_primitive_call_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) @@ -253,7 +252,7 @@ void jit_compile(CELL quot, bool relocate) } default: GROWABLE_ARRAY_ADD(literals,obj); - EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); + EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1); break; } } diff --git a/vm/run.h b/vm/run.h index 8a03049b93..96e606e38c 100755 --- a/vm/run.h +++ b/vm/run.h @@ -47,29 +47,9 @@ typedef enum { JIT_EPILOG, JIT_RETURN, JIT_PROFILING, - JIT_TAG, - JIT_TAG_WORD, - JIT_EQP, - JIT_EQP_WORD, - JIT_SLOT, - JIT_SLOT_WORD, - JIT_DECLARE_WORD, - JIT_DROP, - JIT_DROP_WORD, - JIT_DUP, - JIT_DUP_WORD, - JIT_TO_R, - JIT_TO_R_WORD, - JIT_FROM_R, - JIT_FROM_R_WORD, - JIT_SWAP, - JIT_SWAP_WORD, - JIT_OVER, - JIT_OVER_WORD, - JIT_FIXNUM_MINUS, - JIT_FIXNUM_MINUS_WORD, - JIT_FIXNUM_GE, - JIT_FIXNUM_GE_WORD, + JIT_PUSH_IMMEDIATE, + + JIT_DECLARE_WORD = 42, STACK_TRACES_ENV = 59, From 77d45d654ab664282c6ea70e359d4525a9c8b7f0 Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 8 Jul 2008 20:01:28 +0100 Subject: [PATCH 040/120] Wordtimer vocab for time-profiling words and vocabs --- extra/wordtimer/authors.txt | 1 + extra/wordtimer/summary.txt | 1 + extra/wordtimer/wordtimer-docs.factor | 34 +++++++++++ extra/wordtimer/wordtimer-tests.factor | 10 ++++ extra/wordtimer/wordtimer.factor | 81 ++++++++++++++++++++++++++ 5 files changed, 127 insertions(+) create mode 100644 extra/wordtimer/authors.txt create mode 100644 extra/wordtimer/summary.txt create mode 100644 extra/wordtimer/wordtimer-docs.factor create mode 100644 extra/wordtimer/wordtimer-tests.factor create mode 100644 extra/wordtimer/wordtimer.factor diff --git a/extra/wordtimer/authors.txt b/extra/wordtimer/authors.txt new file mode 100644 index 0000000000..0be42b2faa --- /dev/null +++ b/extra/wordtimer/authors.txt @@ -0,0 +1 @@ +Phil Dawes diff --git a/extra/wordtimer/summary.txt b/extra/wordtimer/summary.txt new file mode 100644 index 0000000000..efe591da27 --- /dev/null +++ b/extra/wordtimer/summary.txt @@ -0,0 +1 @@ +Microsecond precision code timer/profiler. diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor new file mode 100644 index 0000000000..7d9de34252 --- /dev/null +++ b/extra/wordtimer/wordtimer-docs.factor @@ -0,0 +1,34 @@ +USING: help.syntax help.markup kernel prettyprint sequences ; +IN: wordtimer + +HELP: reset-word-timer +{ $description "resets the global wordtimes datastructure. Must be called before calling any word-timer annotated code" +} ; + +HELP: add-timer +{ $values { "word" "a word" } } +{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings" +} ; + +HELP: add-timers +{ $values { "vocab" "a string" } } +{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab" +} ; + + +HELP: reset-vocab +{ $values { "vocab" "a string" } } +{ $description "removes the annotations from all the words in the vocab" +} ; + +HELP: print-word-timings +{ $description "Displays the timing information for each word-timer annotated word. Columns are: total time taken in microseconds, number of invocations, wordname" +} ; + +HELP: correct-for-timing-overhead +{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; + +ARTICLE: "wordtimer" "Word Timer" +"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. You first annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then you reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } "." ; + +ABOUT: "wordtimer" diff --git a/extra/wordtimer/wordtimer-tests.factor b/extra/wordtimer/wordtimer-tests.factor new file mode 100644 index 0000000000..47287179ce --- /dev/null +++ b/extra/wordtimer/wordtimer-tests.factor @@ -0,0 +1,10 @@ +USING: tools.test wordtimer math kernel tools.annotations prettyprint ; +IN: wordtimer.tests + +: testfn ( a b c d -- a+b c+d ) + + [ + ] dip ; + +[ 3 7 ] +[ reset-word-timer + \ testfn [ reset ] [ add-timer ] bi + 1 2 3 4 testfn ] unit-test \ No newline at end of file diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor new file mode 100644 index 0000000000..1ce5f13a81 --- /dev/null +++ b/extra/wordtimer/wordtimer.factor @@ -0,0 +1,81 @@ +USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics ; +IN: wordtimer + +SYMBOL: *wordtimes* +SYMBOL: *calling* + +: reset-word-timer ( -- ) + H{ } clone *wordtimes* set-global + H{ } clone *calling* set-global ; + +: lookup-word-time ( wordname -- utime n ) + *wordtimes* get-global [ drop { 0 0 } ] cache first2 ; + +: update-times ( utime current-utime current-numinvokes -- utime' invokes' ) + rot [ + ] curry [ 1+ ] bi* ; + +: register-time ( utime word -- ) + word-name + [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; + +: calling ( word -- ) + dup *calling* get-global set-at ; inline + +: finished ( word -- ) + *calling* get-global delete-at ; inline + +: called-recursively? ( word -- t/f ) + *calling* get-global at ; inline + +: timed-call ( quot word -- ) + [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline + +: time-unless-recursing ( quot word -- ) + dup called-recursively? not + [ timed-call ] [ drop call ] if ; inline + +: (add-timer) ( word quot -- quot' ) + [ swap time-unless-recursing ] 2curry ; + +: add-timer ( word -- ) + dup [ (add-timer) ] annotate ; + +: add-timers ( vocabspec -- ) + words [ add-timer ] each ; + +: reset-vocab ( vocabspec -- ) + words [ reset ] each ; + +: dummy-word ( -- ) ; + +: time-dummy-word ( -- n ) + [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ; + +: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} ) + [ first2 ] dip + swap [ * - ] keep 2array ; + +: change-global ( variable quot -- ) + global swap change-at ; + +: (correct-for-timing-overhead) ( timingshash -- timingshash ) + time-dummy-word [ subtract-overhead ] curry assoc-map ; + +: correct-for-timing-overhead ( -- ) + *wordtimes* [ (correct-for-timing-overhead) ] change-global ; + +: print-word-timings ( -- ) + *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ; + + +: profile-vocab ( vocabspec quot -- ) + "annotating vocab..." print flush + over [ reset-vocab ] [ add-timers ] bi + reset-word-timer + "executing quotation..." print flush + [ call ] micro-time >r + "resetting annotations..." print flush + swap reset-vocab + correct-for-timing-overhead + "total time:" write r> pprint + print-word-timings ; \ No newline at end of file From cf342b9a86df0f8e8f69bc5e2ee71472867282f0 Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 8 Jul 2008 20:32:34 +0100 Subject: [PATCH 041/120] fixed to use new-style accessor for word-name --- extra/wordtimer/wordtimer.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index 1ce5f13a81..e9ed0c8cf0 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -1,4 +1,4 @@ -USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics ; +USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ; IN: wordtimer SYMBOL: *wordtimes* @@ -15,7 +15,7 @@ SYMBOL: *calling* rot [ + ] curry [ 1+ ] bi* ; : register-time ( utime word -- ) - word-name + name>> [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; : calling ( word -- ) From 7b5529a290da1fdf4756db8fca58b41dc2bd5abc Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 8 Jul 2008 20:50:49 +0100 Subject: [PATCH 042/120] Added doc for profile-vocab --- extra/wordtimer/wordtimer-docs.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor index 7d9de34252..47b85bb007 100644 --- a/extra/wordtimer/wordtimer-docs.factor +++ b/extra/wordtimer/wordtimer-docs.factor @@ -27,8 +27,15 @@ HELP: print-word-timings HELP: correct-for-timing-overhead { $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; + +HELP: profile-vocab +{ $values { "vocabspec" "string name of a vocab" } + { "quot" "a quotation to run" } } +{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information." +} ; + ARTICLE: "wordtimer" "Word Timer" -"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. You first annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then you reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } "." ; +"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ; ABOUT: "wordtimer" From de59a24380f747e116901695a6251a30083247e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Jul 2008 13:11:43 -0500 Subject: [PATCH 043/120] Rename incorrectly named file --- extra/backtrack/{description.txt => summary.txt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename extra/backtrack/{description.txt => summary.txt} (100%) diff --git a/extra/backtrack/description.txt b/extra/backtrack/summary.txt similarity index 100% rename from extra/backtrack/description.txt rename to extra/backtrack/summary.txt From b93342298f2d043815df41dd404a27d34793e047 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Thu, 10 Jul 2008 23:59:43 +0200 Subject: [PATCH 044/120] Initial import of etags vocab, that generates an word index in Emacs etags format --- extra/ctags/etags/etags-tests.factor | 47 +++++++++++++++++++ extra/ctags/etags/etags.factor | 68 ++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+) create mode 100644 extra/ctags/etags/etags-tests.factor create mode 100644 extra/ctags/etags/etags.factor diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor new file mode 100644 index 0000000000..fbd9a65186 --- /dev/null +++ b/extra/ctags/etags/etags-tests.factor @@ -0,0 +1,47 @@ +USING: kernel ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ; +IN: ctags.etags.tests + + +[ H{ { "path" V{ if { "path" 1 } } } } ] +[ H{ } clone dup V{ if { "path" 1 } } "path" rot set-at ] unit-test + +[ { "path" V{ if { "path" 1 } } } ] +[ H{ } clone dup { "path" V{ if { "path" 1 } } } "path" rot set-at "path" swap at ] unit-test + + +[ V{ if { "path" 1 } } ] +[ "path" H{ { "path" V{ if { "path" 1 } } } } at ] unit-test + +[ "path" ] [ { if { "path" 1 } } ctag-path ] unit-test + +[ V{ } ] +[ "path" H{ } clone ctag-at ] unit-test + +[ V{ if { "path" 1 } } ] +[ "path" H{ { "path" V{ if { "path" 1 } } } } ctag-at ] unit-test + +[ { if 28 } ] +[ { if { "resource:core/kernel/kernel.factor" 28 } } ctag-value ] unit-test + +[ V{ } ] [ { if { "path" 1 } } H{ } clone ctag-hashvalue ] unit-test + +[ V{ if { "path" 1 } } ] +[ { if { "path" 1 } } + { { "path" V{ if { "path" 1 } } } } >hashtable + ctag-hashvalue +] unit-test + +[ H{ { "path" V{ { if 1 } } } } ] +[ { if { "path" 1 } } H{ } clone ctag-add ] unit-test + +[ H{ { "path" V{ { if 1 } } } } ] +[ { { if { "path" 1 } } } ctag-hash ] unit-test + +[ "if28,704" ] +[ "resource:core/kernel/kernel.factor" { if 28 } etag ] unit-test + +! [ V{ " " "resource:core/kernel/kernel.factor,22" "if28,704" "unless31,755" } ] +! [ { { "resource:core/kernel/kernel.factor" +! V{ { if 28 } +! { unless 31 } } } } etag-strings ] unit-test + diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor new file mode 100644 index 0000000000..227f146307 --- /dev/null +++ b/extra/ctags/etags/etags.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2008 Alfredo Beaumont +! See http://factorcode.org/license.txt for BSD license. + +! Emacs Etags generator +! Alfredo Beaumont +USING: kernel sequences sorting assocs words prettyprint ctags +io.encodings.ascii io.files math math.parser namespaces strings locals +shuffle io.backend memoize ; +IN: ctags.etags + +: ctag-path ( alist -- path ) + second first ; + +: ctag-at ( key hash -- vector ) + at [ V{ } clone ] unless* ; + +: ctag-hashvalue ( alist hash -- vector ) + [ ctag-path ] dip ctag-at ; + +: ctag-value ( ctag -- seq ) + dup [ first , second second , ] { } make ; + +: ctag-add ( ctag hash -- hash ) + [ ctag-hashvalue ] 2keep [ dup ctag-path [ ctag-value suffix ] dip ] dip [ set-at ] keep ; + +: ctag-hash ( seq -- hash ) + H{ } clone swap [ swap ctag-add ] each ; + +: line>bytes ( n seq -- bytes ) + nth length 1+ ; + +: lines>bytes ( n seq -- bytes ) + over zero? [ line>bytes ] [ [ [ 1 - ] dip lines>bytes ] 2keep line>bytes + ] if ; + +: file>bytes ( n path -- bytes ) + ascii file-lines lines>bytes ; + +SYMBOL: resource +: etag ( path seq -- str ) + [ + dup first ?word-name % + 1 HEX: 7f % + second dup number>string % + 1 CHAR: , % + 2 - swap file>bytes number>string % + ] "" make ; + +: etag-entry ( alist -- alist path ) + [ first ] keep swap ; + +: vector-length ( vector -- n ) + 0 [ length + ] reduce ; + +: etag-header ( n path -- str ) + [ + % + 1 CHAR: , % + number>string % + ] "" make ; + +: etag-strings ( alist -- seq ) + { } swap [ etag-entry resource [ second [ resource get swap etag ] map dup vector-length resource get normalize-path etag-header prefix 1 HEX: 0c prefix ] with-variable append ] each ; + +: etags-write ( alist path -- ) + [ etag-strings ] dip ascii set-file-lines ; + +: etags ( path -- ) + (ctags) sort-values ctag-hash >alist swap etags-write ; \ No newline at end of file From cec5291ed420e98ed8c344e10b91f5e44cef7287 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Fri, 11 Jul 2008 10:32:15 +0200 Subject: [PATCH 045/120] Style improvements --- extra/ctags/etags/etags.factor | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 227f146307..75fe249538 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -21,7 +21,9 @@ IN: ctags.etags dup [ first , second second , ] { } make ; : ctag-add ( ctag hash -- hash ) - [ ctag-hashvalue ] 2keep [ dup ctag-path [ ctag-value suffix ] dip ] dip [ set-at ] keep ; + [ ctag-hashvalue ] 2keep [ + dup ctag-path [ ctag-value suffix ] dip + ] dip [ set-at ] keep ; : ctag-hash ( seq -- hash ) H{ } clone swap [ swap ctag-add ] each ; @@ -30,12 +32,16 @@ IN: ctags.etags nth length 1+ ; : lines>bytes ( n seq -- bytes ) - over zero? [ line>bytes ] [ [ [ 1 - ] dip lines>bytes ] 2keep line>bytes + ] if ; + over zero? [ + line>bytes ] [ + [ + [ 1- ] dip lines>bytes + ] 2keep line>bytes + + ] if ; : file>bytes ( n path -- bytes ) ascii file-lines lines>bytes ; -SYMBOL: resource : etag ( path seq -- str ) [ dup first ?word-name % @@ -51,15 +57,28 @@ SYMBOL: resource : vector-length ( vector -- n ) 0 [ length + ] reduce ; -: etag-header ( n path -- str ) +:
( n path -- str ) [ % 1 CHAR: , % number>string % ] "" make ; +: etag-header ( vec1 n resource -- vec2 ) + normalize-path
prefix + 1 HEX: 0c prefix ; + +SYMBOL: resource : etag-strings ( alist -- seq ) - { } swap [ etag-entry resource [ second [ resource get swap etag ] map dup vector-length resource get normalize-path etag-header prefix 1 HEX: 0c prefix ] with-variable append ] each ; + { } swap [ + etag-entry resource [ + second [ + resource get swap etag + ] map dup vector-length + resource get + ] with-variable + etag-header append + ] each ; : etags-write ( alist path -- ) [ etag-strings ] dip ascii set-file-lines ; From 4cb68c4a4df5a3150cfffaff9bb4324af2091780 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Fri, 11 Jul 2008 10:53:51 +0200 Subject: [PATCH 046/120] Open every source file just once. This make code work ~20x faster --- extra/ctags/etags/etags.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 75fe249538..94928a263e 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -5,7 +5,7 @@ ! Alfredo Beaumont USING: kernel sequences sorting assocs words prettyprint ctags io.encodings.ascii io.files math math.parser namespaces strings locals -shuffle io.backend memoize ; +shuffle io.backend arrays ; IN: ctags.etags : ctag-path ( alist -- path ) @@ -39,20 +39,20 @@ IN: ctags.etags ] 2keep line>bytes + ] if ; -: file>bytes ( n path -- bytes ) - ascii file-lines lines>bytes ; +: file>lines ( resource -- lines ) + ascii file-lines ; -: etag ( path seq -- str ) +: etag ( lines seq -- str ) [ dup first ?word-name % 1 HEX: 7f % second dup number>string % 1 CHAR: , % - 2 - swap file>bytes number>string % + 2 - swap lines>bytes number>string % ] "" make ; -: etag-entry ( alist -- alist path ) - [ first ] keep swap ; +: etag-entry ( alist -- alist array ) + [ first ] keep swap [ file>lines ] keep 2array ; : vector-length ( vector -- n ) 0 [ length + ] reduce ; @@ -73,9 +73,9 @@ SYMBOL: resource { } swap [ etag-entry resource [ second [ - resource get swap etag + resource get first swap etag ] map dup vector-length - resource get + resource get second ] with-variable etag-header append ] each ; From 5a1ab1edaed1e93b9d6f436970772579c90c8b22 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Fri, 11 Jul 2008 16:16:01 +0200 Subject: [PATCH 047/120] Some improvements both in elegance and performance in ctags vocab --- extra/ctags/ctags.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 23d9aeb90c..2ec1208df9 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -19,19 +19,17 @@ IN: ctags ] "" make ; : ctag-strings ( seq1 -- seq2 ) - { } swap [ ctag suffix ] each ; + [ ctag ] map ; : ctags-write ( seq path -- ) [ ctag-strings ] dip ascii set-file-lines ; : (ctags) ( -- seq ) - { } all-words [ + all-words [ dup where [ - 2array suffix - ] [ - drop - ] if* - ] each ; + 2array + ] when* + ] map [ sequence? ] filter ; : ctags ( path -- ) (ctags) sort-keys swap ctags-write ; \ No newline at end of file From dd759b1e1356d5de8ad28419a90fdd5d7f507997 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sat, 12 Jul 2008 02:47:48 +0200 Subject: [PATCH 048/120] Fix testsuite --- extra/ctags/etags/etags-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor index fbd9a65186..53e8f99aaf 100644 --- a/extra/ctags/etags/etags-tests.factor +++ b/extra/ctags/etags/etags-tests.factor @@ -38,7 +38,7 @@ IN: ctags.etags.tests [ { { if { "path" 1 } } } ctag-hash ] unit-test [ "if28,704" ] -[ "resource:core/kernel/kernel.factor" { if 28 } etag ] unit-test +[ "resource:core/kernel/kernel.factor" file>lines { if 28 } etag ] unit-test ! [ V{ " " "resource:core/kernel/kernel.factor,22" "if28,704" "unless31,755" } ] ! [ { { "resource:core/kernel/kernel.factor" From ca781ea739dd7426d07d283a7331040f37424aa7 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sat, 12 Jul 2008 02:48:09 +0200 Subject: [PATCH 049/120] Simplify using iteration --- extra/ctags/etags/etags.factor | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 94928a263e..f2d7d7e174 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -28,16 +28,8 @@ IN: ctags.etags : ctag-hash ( seq -- hash ) H{ } clone swap [ swap ctag-add ] each ; -: line>bytes ( n seq -- bytes ) - nth length 1+ ; - -: lines>bytes ( n seq -- bytes ) - over zero? [ - line>bytes ] [ - [ - [ 1- ] dip lines>bytes - ] 2keep line>bytes + - ] if ; +: lines>bytes ( seq n -- bytes ) + head 0 [ length 1+ + ] reduce ; : file>lines ( resource -- lines ) ascii file-lines ; @@ -48,7 +40,7 @@ IN: ctags.etags 1 HEX: 7f % second dup number>string % 1 CHAR: , % - 2 - swap lines>bytes number>string % + 1- lines>bytes number>string % ] "" make ; : etag-entry ( alist -- alist array ) From 54b24fd8b1060c80362898744e797b5d285935d7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 01:24:43 -0500 Subject: [PATCH 050/120] ui.gadgets: new effects for add-gadget, add-gadgets, and (add-gadget) --- extra/ui/gadgets/gadgets.factor | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3fc185a10e..ebe3773ce9 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -285,22 +285,27 @@ SYMBOL: in-layout? not-in-layout dup (clear-gadget) relayout ; -: ((add-gadget)) ( gadget box -- ) - [ children>> ?push ] keep (>>children) ; +: ((add-gadget)) ( parent child -- parent ) + over children>> ?push >>children ; -: (add-gadget) ( gadget box -- ) - over unparent - dup pick (>>parent) - [ ((add-gadget)) ] 2keep - graft-state>> second [ graft ] [ drop ] if ; +: (add-gadget) ( parent child -- parent ) + dup unparent + over >>parent + tuck ((add-gadget)) + tuck graft-state>> second + [ graft ] + [ drop ] + if ; -: add-gadget ( gadget parent -- ) +: add-gadget ( parent child -- parent ) not-in-layout - [ (add-gadget) ] keep relayout ; - -: add-gadgets ( seq parent -- ) + (add-gadget) + dup relayout ; + +: add-gadgets ( parent children -- parent ) not-in-layout - swap [ over (add-gadget) ] each relayout ; + [ (add-gadget) ] each + dup relayout ; : parents ( gadget -- seq ) [ parent>> ] follow ; @@ -352,7 +357,7 @@ M: f request-focus-on 2drop ; : focus-path ( world -- seq ) [ focus>> ] follow ; -: gadget, ( gadget -- ) gadget get add-gadget ; +: gadget, ( gadget -- ) gadget get swap add-gadget drop ; : g ( -- gadget ) gadget get ; From 73e30123f52ae037b11f1977933c04e6e98f61fd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 01:25:44 -0500 Subject: [PATCH 051/120] ui.gadgets.*: updates for new effects --- extra/ui/gadgets/books/books.factor | 2 +- extra/ui/gadgets/borders/borders.factor | 2 +- extra/ui/gadgets/grids/grids.factor | 4 ++-- extra/ui/gadgets/incremental/incremental.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/menus/menus.factor | 4 ++-- extra/ui/gadgets/panes/panes.factor | 12 ++++++------ extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/tabs/tabs.factor | 4 ++-- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/gadgets/viewports/viewports.factor | 2 +- extra/ui/gadgets/wrappers/wrappers.factor | 2 +- 12 files changed, 20 insertions(+), 20 deletions(-) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 93a8d271af..ce15bd9e6c 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -19,7 +19,7 @@ M: book model-changed : new-book ( pages model class -- book ) new-gadget swap >>model - [ add-gadgets ] keep ; inline + [ swap add-gadgets drop ] keep ; inline : ( pages model -- book ) book new-book ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 7d6a24fed1..d1cf7cfb29 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -10,7 +10,7 @@ TUPLE: border < gadget { align initial: { 1/2 1/2 } } ; : new-border ( child class -- border ) - new-gadget [ add-gadget ] keep ; inline + new-gadget [ swap add-gadget drop ] keep ; inline : ( child gap -- border ) swap border new-border diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index b539934771..474e6b95c0 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -12,7 +12,7 @@ grid : new-grid ( children class -- grid ) new-gadget - [ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ; + [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ; inline : ( children -- grid ) @@ -21,7 +21,7 @@ grid : grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-add ( gadget grid i j -- ) - >r >r 2dup add-gadget r> r> + >r >r 2dup swap add-gadget drop r> r> 3dup grid-child unparent rot grid>> nth set-nth ; : grid-remove ( grid i j -- ) diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index c74f6676ad..8c227d76ce 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -45,7 +45,7 @@ M: incremental pref-dim* : add-incremental ( gadget incremental -- ) not-in-layout - 2dup (add-gadget) + 2dup swap (add-gadget) drop over prefer-incremental over layout-later 2dup incremental-loc diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 776814853f..c2539e146a 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ; M: list model-changed nip dup clear-gadget - dup over add-gadgets + dup over swap add-gadgets drop bound-index ; : selected-rect ( list -- rect ) diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor index 3e1145a8b6..4f815bc33d 100644 --- a/extra/ui/gadgets/menus/menus.factor +++ b/extra/ui/gadgets/menus/menus.factor @@ -15,7 +15,7 @@ TUPLE: menu-glass < gadget ; : ( menu world -- glass ) menu-glass new-gadget >r over menu-loc over set-rect-loc r> - [ add-gadget ] keep ; + [ swap add-gadget drop ] keep ; M: menu-glass layout* gadget-child prefer ; @@ -26,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ; : show-glass ( gadget world -- ) over hand-clicked set-global [ hide-glass ] keep - [ add-gadget ] 2keep + [ swap add-gadget drop ] 2keep set-world-glass ; : show-menu ( gadget owner -- ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 973c8c5725..9b547ce544 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -22,10 +22,10 @@ selection-color caret mark selecting? ; drop ; : add-output ( current pane -- ) - [ set-pane-output ] [ add-gadget ] 2bi ; + [ set-pane-output ] [ swap add-gadget drop ] 2bi ; : add-current ( current pane -- ) - [ set-pane-current ] [ add-gadget ] 2bi ; + [ set-pane-current ] [ swap add-gadget drop ] 2bi ; : prepare-line ( pane -- ) [ clear-selection ] @@ -120,7 +120,7 @@ C: pane-stream GENERIC: write-gadget ( gadget stream -- ) M: pane-stream write-gadget - pane-stream-pane pane-current add-gadget ; + pane-stream-pane pane-current swap add-gadget drop ; M: style-stream write-gadget stream>> write-gadget ; @@ -299,12 +299,12 @@ M: paragraph dispose drop ; : gadget-write ( string gadget -- ) over empty? - [ 2drop ] [ >r