From 90409502e31277a9d80c6ed0d82ec29f11f33d9e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 06:13:05 -0600 Subject: [PATCH 01/32] Fix [wlet after recent locals refactoring broke it --- basis/locals/locals.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 903519fe1f..b78b95bc24 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -346,7 +346,7 @@ SYMBOL: in-lambda? : (parse-wbindings) ( end -- ) dup parse-binding dup [ - first2 [ make-local-word ] dip 2array , + first2 [ make-local-word ] keep 2array , (parse-wbindings) ] [ 2drop ] if ; From 1944fe54c0a145575eab345a91cd4cc654726621 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 06:16:17 -0600 Subject: [PATCH 02/32] Fix compile error in nibble-arrays and add some unit tests --- basis/nibble-arrays/nibble-arrays-tests.factor | 6 ++++++ basis/nibble-arrays/nibble-arrays.factor | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) create mode 100644 basis/nibble-arrays/nibble-arrays-tests.factor diff --git a/basis/nibble-arrays/nibble-arrays-tests.factor b/basis/nibble-arrays/nibble-arrays-tests.factor new file mode 100644 index 0000000000..2a0eef7227 --- /dev/null +++ b/basis/nibble-arrays/nibble-arrays-tests.factor @@ -0,0 +1,6 @@ +USING: nibble-arrays tools.test sequences kernel math ; +IN: nibble-arrays.tests + +[ t ] [ 16 dup >nibble-array sequence= ] unit-test +[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test +[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test diff --git a/basis/nibble-arrays/nibble-arrays.factor b/basis/nibble-arrays/nibble-arrays.factor index 170f41a2d9..c753d0fb78 100644 --- a/basis/nibble-arrays/nibble-arrays.factor +++ b/basis/nibble-arrays/nibble-arrays.factor @@ -17,10 +17,10 @@ TUPLE: nibble-array : byte/nibble ( n -- shift n' ) [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline -: get-nibble ( shift n byte -- nibble ) +: get-nibble ( n byte -- nibble ) swap neg shift nibble bitand ; inline -: set-nibble ( value shift n byte -- byte' ) +: set-nibble ( value n byte -- byte' ) nibble pick shift bitnot bitand -rot shift bitor ; inline : nibble@ ( n nibble-array -- shift n' byte-array ) From 54e1dd333833a6fa13ea8d0e21a483f7d4dffdfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 06:17:38 -0600 Subject: [PATCH 03/32] Fix help-lint failures in alien.c-types --- basis/alien/c-types/c-types-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 1ec9a82169..a2b555b057 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -105,12 +105,12 @@ HELP: unbox-return { $notes "This is an internal word used by the compiler when compiling callbacks." } ; HELP: define-deref -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } +{ $values { "name" "a word name" } } { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; HELP: define-out -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } +{ $values { "name" "a word name" } } { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; From e9abdef5c516e1b4285bc4d628960f36c417624a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 06:18:18 -0600 Subject: [PATCH 04/32] Fix io.mmap help lint failures --- basis/io/mmap/mmap-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index a613c4711f..bd971656d4 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -17,7 +17,7 @@ HELP: { $errors "Throws an error if a memory mapping could not be established." } ; HELP: with-mapped-file -{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } } +{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $errors "Throws an error if a memory mapping could not be established." } ; From 9e9b2e389e279087f4fb9e458547462b9db9fa3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 06:21:02 -0600 Subject: [PATCH 05/32] Fix dawes benchmark --- extra/benchmark/dawes/dawes.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/benchmark/dawes/dawes.factor b/extra/benchmark/dawes/dawes.factor index 9ece8465ab..5cd40bc098 100644 --- a/extra/benchmark/dawes/dawes.factor +++ b/extra/benchmark/dawes/dawes.factor @@ -1,16 +1,16 @@ -USING: sequences hints kernel math specialized-arrays.int ; +USING: sequences hints kernel math specialized-arrays.int fry ; IN: benchmark.dawes ! Phil Dawes's performance problem -: count-ones ( byte-array -- n ) [ 1 = ] sigma ; +: count-ones ( int-array -- n ) [ 1 = ] count ; inline HINTS: count-ones int-array ; -: make-byte-array ( -- byte-array ) +: make-int-array ( -- int-array ) 120000 [ 255 bitand ] int-array{ } map-as ; : dawes-benchmark ( -- ) - make-byte-array 200 swap [ count-ones ] curry replicate drop ; + make-int-array 200 swap '[ _ count-ones ] replicate drop ; MAIN: dawes-benchmark From 90cc92353a0de4c3249c32bd752b8f516a468f3a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 06:21:17 -0600 Subject: [PATCH 06/32] Don't throw in benchmark. if some benchmarks failed --- extra/benchmark/benchmark.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index a8c6e2a2ac..a1e892229a 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -22,7 +22,7 @@ IN: benchmark [ [ [ [ 1array $vocab-link ] with-cell ] - [ 1000000 /f pprint-cell ] bi* + [ [ 1000000 /f pprint-cell ] [ "failed" write ] if* ] bi* ] with-row ] assoc-each ] tabular-output ; From 7b380c526e5dc086df721bc88a8ef9f5076f1590 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 06:38:44 -0600 Subject: [PATCH 07/32] Clean up windows.ole3 and fix it for specialized-arrays change --- basis/windows/ole32/ole32.factor | 80 ++++++++++++++++++-------------- 1 file changed, 44 insertions(+), 36 deletions(-) mode change 100644 => 100755 basis/windows/ole32/ole32.factor diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor old mode 100644 new mode 100755 index 6256211266..05bc140bd7 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,7 +1,7 @@ USING: alien alien.syntax alien.c-types alien.strings math kernel sequences windows windows.types debugger io accessors math.order namespaces make math.parser windows.kernel32 -combinators ; +combinators locals specialized-arrays.uchar ; IN: windows.ole32 LIBRARY: ole32 @@ -134,49 +134,57 @@ M: ole32-error error. : GUID-STRING-LENGTH "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline -: (guid-section>guid) ( guid string start end quot -- ) - [ roll subseq hex> swap ] dip call ; inline -: (guid-byte>guid) ( guid string start end byte -- ) - [ roll subseq hex> ] dip - rot GUID-Data4 set-uchar-nth ; inline +:: (guid-section>guid) ( string guid start end quot -- ) + start end string subseq hex> guid quot call ; inline + +: (guid-byte>guid) ( string guid start end byte -- ) + start end string subseq hex> guid byte set-nth ; inline : string>guid ( string -- guid ) - "GUID" [ { - [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ] + "GUID" [ + { + [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ] + [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ] + [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ] + [ ] + } 2cleave - [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ] + GUID-Data4 8 { + [ 20 22 0 (guid-byte>guid) ] + [ 22 24 1 (guid-byte>guid) ] - [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ] - - [ 20 22 0 (guid-byte>guid) ] - [ 22 24 1 (guid-byte>guid) ] - - [ 25 27 2 (guid-byte>guid) ] - [ 27 29 3 (guid-byte>guid) ] - [ 29 31 4 (guid-byte>guid) ] - [ 31 33 5 (guid-byte>guid) ] - [ 33 35 6 (guid-byte>guid) ] - [ 35 37 7 (guid-byte>guid) ] - } 2cleave ] keep ; + [ 25 27 2 (guid-byte>guid) ] + [ 27 29 3 (guid-byte>guid) ] + [ 29 31 4 (guid-byte>guid) ] + [ 31 33 5 (guid-byte>guid) ] + [ 33 35 6 (guid-byte>guid) ] + [ 35 37 7 (guid-byte>guid) ] + } 2cleave + ] keep ; : (guid-section%) ( guid quot len -- ) [ call >hex ] dip CHAR: 0 pad-left % ; inline + : (guid-byte%) ( guid byte -- ) - swap GUID-Data4 uchar-nth >hex 2 - CHAR: 0 pad-left % ; inline + swap nth >hex 2 CHAR: 0 pad-left % ; inline : guid>string ( guid -- string ) - [ "{" % { - [ [ GUID-Data1 ] 8 (guid-section%) "-" % ] - [ [ GUID-Data2 ] 4 (guid-section%) "-" % ] - [ [ GUID-Data3 ] 4 (guid-section%) "-" % ] - [ 0 (guid-byte%) ] - [ 1 (guid-byte%) "-" % ] - [ 2 (guid-byte%) ] - [ 3 (guid-byte%) ] - [ 4 (guid-byte%) ] - [ 5 (guid-byte%) ] - [ 6 (guid-byte%) ] - [ 7 (guid-byte%) "}" % ] - } cleave ] "" make ; + [ + "{" % { + [ [ GUID-Data1 ] 8 (guid-section%) "-" % ] + [ [ GUID-Data2 ] 4 (guid-section%) "-" % ] + [ [ GUID-Data3 ] 4 (guid-section%) "-" % ] + [ ] + } cleave + GUID-Data4 8 { + [ 0 (guid-byte%) ] + [ 1 (guid-byte%) "-" % ] + [ 2 (guid-byte%) ] + [ 3 (guid-byte%) ] + [ 4 (guid-byte%) ] + [ 5 (guid-byte%) ] + [ 6 (guid-byte%) ] + [ 7 (guid-byte%) "}" % ] + } cleave + ] "" make ; From da9b38caae788eb3af91befa6709e1b57b0e6ba4 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 06:52:16 -0600 Subject: [PATCH 08/32] Fix Windows bootstrap --- basis/io/windows/nt/monitors/monitors.factor | 13 +++++++------ basis/windows/com/syntax/syntax.factor | 12 ++++++------ basis/windows/ole32/ole32.factor | 6 +++--- 3 files changed, 16 insertions(+), 15 deletions(-) mode change 100644 => 100755 basis/io/windows/nt/monitors/monitors.factor mode change 100644 => 100755 basis/windows/com/syntax/syntax.factor diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor old mode 100644 new mode 100755 index 3db726e06a..30345c8c69 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types libc destructors locals kernel math -assocs namespaces make continuations sequences hashtables -sorting arrays combinators math.bitwise strings system accessors -threads splitting io.backend io.windows io.windows.nt.backend -io.windows.nt.files io.monitors io.ports io.buffers io.files -io.timeouts io windows windows.kernel32 windows.types ; +USING: alien alien.c-types alien.strings libc destructors locals +kernel math assocs namespaces make continuations sequences +hashtables sorting arrays combinators math.bitwise strings +system accessors threads splitting io.backend io.windows +io.windows.nt.backend io.windows.nt.files io.monitors io.ports +io.buffers io.files io.timeouts io.encodings.string io +windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor old mode 100644 new mode 100755 index c56293babe..620b608afc --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -1,7 +1,7 @@ -USING: alien alien.c-types effects kernel windows.ole32 -parser lexer splitting grouping sequences namespaces -assocs quotations generalizations accessors words macros alien.syntax -fry arrays ; +USING: alien alien.c-types alien.accessors effects kernel +windows.ole32 parser lexer splitting grouping sequences +namespaces assocs quotations generalizations accessors words +macros alien.syntax fry arrays layouts math ; IN: windows.com.syntax guid) ( string guid start end quot -- ) start end string subseq hex> guid quot call ; inline -: (guid-byte>guid) ( string guid start end byte -- ) - start end string subseq hex> guid byte set-nth ; inline +:: (guid-byte>guid) ( string guid start end byte -- ) + start end string subseq hex> byte guid set-nth ; inline : string>guid ( string -- guid ) "GUID" [ From 8834f8e041d22967ac6e7ad48badc597b61ca8c4 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 06:52:31 -0600 Subject: [PATCH 09/32] Loosen type on direct arrays since we want to use them on displaced aliens too --- basis/specialized-arrays/direct/functor/functor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/specialized-arrays/direct/functor/functor.factor diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor old mode 100644 new mode 100755 index ed8b28c8a3..2cde26b731 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ] WHERE TUPLE: A -{ underlying simple-alien read-only } +{ underlying alien read-only } { length fixnum read-only } ; : ( alien len -- direct-array ) A boa ; inline From d60c79c9bfb01c7c0f1a5396c3a2577f44cc0618 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 08:11:51 -0600 Subject: [PATCH 10/32] Expand instance? with literal class --- .../tree/propagation/inlining/inlining.factor | 22 +++++++++++++------ 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0beff42f4d..83a4a7aef7 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations +words namespaces continuations classes fry compiler.tree compiler.tree.builder compiler.tree.recursive @@ -26,7 +26,7 @@ GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; -M: quotation splicing-nodes +M: callable splicing-nodes build-sub-tree analyze-recursive normalize ; : propagate-body ( #call -- ) @@ -140,18 +140,21 @@ SYMBOL: history : remember-inlining ( word -- ) history [ swap suffix ] change ; -: inline-word ( #call word -- ? ) - dup history get memq? [ - 2drop f +: inline-word-def ( #call word quot -- ? ) + over history get memq? [ + 3drop f ] [ [ - dup remember-inlining - dupd def>> splicing-nodes >>body + swap remember-inlining + dupd splicing-nodes >>body propagate-body ] with-scope t ] if ; +: inline-word ( #call word -- ? ) + dup def>> inline-word-def ; + : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -165,6 +168,10 @@ SYMBOL: history [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack first object swap eliminate-dispatch ; +: inline-instance-check ( #call word -- ? ) + over in-d>> second value-info literal>> dup class? + [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; + : do-inlining ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition @@ -177,6 +184,7 @@ SYMBOL: history { { [ dup deferred? ] [ 2drop f ] } { [ dup custom-inlining? ] [ inline-custom ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } From 410285769489f97e28cfa5df2573ea246abe4fbe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 08:12:28 -0600 Subject: [PATCH 11/32] Tree shaker now strips out some more PEG stuff --- basis/tools/deploy/shaker/shaker.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 53f147ccce..15fd2a37d7 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -109,6 +109,7 @@ IN: tools.deploy.shaker "default-method" "default-output-classes" "derived-from" + "ebnf-parser" "engines" "forgotten" "identities" @@ -269,8 +270,8 @@ IN: tools.deploy.shaker } % { } { "math.partial-dispatch" } strip-vocab-globals % - - "peg-cache" "peg" lookup , + + { } { "peg" } strip-vocab-globals % ] when strip-prettyprint? [ @@ -346,7 +347,7 @@ IN: tools.deploy.shaker : finish-deploy ( final-image -- ) "Finishing up" show - >r { } set-datastack r> + [ { } set-datastack ] dip { } set-retainstack V{ } set-namestack V{ } set-catchstack @@ -387,9 +388,9 @@ SYMBOL: deploy-vocab strip-c-io f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main set-boot-quot* - stripped-word-props >r + stripped-word-props stripped-globals strip-globals - r> strip-words + strip-words compress-byte-arrays compress-quotations compress-strings From 33c3972f2051330578c03ca86dbcfceb8c24a9bc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 3 Dec 2008 08:22:55 -0600 Subject: [PATCH 12/32] Move processing.* and boids back to extra --- {unmaintained => extra}/boids/authors.txt | 0 {unmaintained => extra}/boids/boids.factor | 0 {unmaintained => extra}/boids/summary.txt | 0 {unmaintained => extra}/processing/gadget/gadget.factor | 0 {unmaintained => extra}/processing/gallery/trails/trails.factor | 0 {unmaintained => extra}/processing/processing.factor | 0 {unmaintained => extra}/processing/shapes/shapes.factor | 0 7 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/boids/authors.txt (100%) rename {unmaintained => extra}/boids/boids.factor (100%) rename {unmaintained => extra}/boids/summary.txt (100%) rename {unmaintained => extra}/processing/gadget/gadget.factor (100%) rename {unmaintained => extra}/processing/gallery/trails/trails.factor (100%) rename {unmaintained => extra}/processing/processing.factor (100%) rename {unmaintained => extra}/processing/shapes/shapes.factor (100%) diff --git a/unmaintained/boids/authors.txt b/extra/boids/authors.txt similarity index 100% rename from unmaintained/boids/authors.txt rename to extra/boids/authors.txt diff --git a/unmaintained/boids/boids.factor b/extra/boids/boids.factor similarity index 100% rename from unmaintained/boids/boids.factor rename to extra/boids/boids.factor diff --git a/unmaintained/boids/summary.txt b/extra/boids/summary.txt similarity index 100% rename from unmaintained/boids/summary.txt rename to extra/boids/summary.txt diff --git a/unmaintained/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor similarity index 100% rename from unmaintained/processing/gadget/gadget.factor rename to extra/processing/gadget/gadget.factor diff --git a/unmaintained/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor similarity index 100% rename from unmaintained/processing/gallery/trails/trails.factor rename to extra/processing/gallery/trails/trails.factor diff --git a/unmaintained/processing/processing.factor b/extra/processing/processing.factor similarity index 100% rename from unmaintained/processing/processing.factor rename to extra/processing/processing.factor diff --git a/unmaintained/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor similarity index 100% rename from unmaintained/processing/shapes/shapes.factor rename to extra/processing/shapes/shapes.factor From 6b3b2d78c4d7e65abfda2786d34052aee4e7ee9a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 3 Dec 2008 08:24:08 -0600 Subject: [PATCH 13/32] processing.shapes: Remove dependency on 'opengl.demo-support' --- extra/processing/shapes/shapes.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor index a530be64fa..51979dc96a 100644 --- a/extra/processing/shapes/shapes.factor +++ b/extra/processing/shapes/shapes.factor @@ -2,13 +2,17 @@ USING: kernel namespaces arrays sequences grouping alien.c-types math math.vectors math.geometry.rect - opengl.gl opengl.glu opengl.demo-support opengl generalizations vars + opengl.gl opengl.glu opengl generalizations vars combinators.cleave colors ; IN: processing.shapes ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: do-state ( mode quot -- ) swap glBegin call glEnd ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color From e24cc8bd62247ba1de3c9cbb45769f63fd57f592 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 3 Dec 2008 08:28:19 -0600 Subject: [PATCH 14/32] Move bubble-chamber back to extra --- {unmaintained => extra}/bubble-chamber/bubble-chamber-docs.factor | 0 {unmaintained => extra}/bubble-chamber/bubble-chamber.factor | 0 {unmaintained => extra}/bubble-chamber/common/common.factor | 0 .../bubble-chamber/particle/axion/axion.factor | 0 .../bubble-chamber/particle/hadron/hadron.factor | 0 .../bubble-chamber/particle/muon/colors/colors.factor | 0 {unmaintained => extra}/bubble-chamber/particle/muon/muon.factor | 0 {unmaintained => extra}/bubble-chamber/particle/particle.factor | 0 .../bubble-chamber/particle/quark/quark.factor | 0 {unmaintained => extra}/bubble-chamber/tags.txt | 0 10 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/bubble-chamber/bubble-chamber-docs.factor (100%) rename {unmaintained => extra}/bubble-chamber/bubble-chamber.factor (100%) rename {unmaintained => extra}/bubble-chamber/common/common.factor (100%) rename {unmaintained => extra}/bubble-chamber/particle/axion/axion.factor (100%) rename {unmaintained => extra}/bubble-chamber/particle/hadron/hadron.factor (100%) rename {unmaintained => extra}/bubble-chamber/particle/muon/colors/colors.factor (100%) rename {unmaintained => extra}/bubble-chamber/particle/muon/muon.factor (100%) rename {unmaintained => extra}/bubble-chamber/particle/particle.factor (100%) rename {unmaintained => extra}/bubble-chamber/particle/quark/quark.factor (100%) rename {unmaintained => extra}/bubble-chamber/tags.txt (100%) diff --git a/unmaintained/bubble-chamber/bubble-chamber-docs.factor b/extra/bubble-chamber/bubble-chamber-docs.factor similarity index 100% rename from unmaintained/bubble-chamber/bubble-chamber-docs.factor rename to extra/bubble-chamber/bubble-chamber-docs.factor diff --git a/unmaintained/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor similarity index 100% rename from unmaintained/bubble-chamber/bubble-chamber.factor rename to extra/bubble-chamber/bubble-chamber.factor diff --git a/unmaintained/bubble-chamber/common/common.factor b/extra/bubble-chamber/common/common.factor similarity index 100% rename from unmaintained/bubble-chamber/common/common.factor rename to extra/bubble-chamber/common/common.factor diff --git a/unmaintained/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor similarity index 100% rename from unmaintained/bubble-chamber/particle/axion/axion.factor rename to extra/bubble-chamber/particle/axion/axion.factor diff --git a/unmaintained/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor similarity index 100% rename from unmaintained/bubble-chamber/particle/hadron/hadron.factor rename to extra/bubble-chamber/particle/hadron/hadron.factor diff --git a/unmaintained/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor similarity index 100% rename from unmaintained/bubble-chamber/particle/muon/colors/colors.factor rename to extra/bubble-chamber/particle/muon/colors/colors.factor diff --git a/unmaintained/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor similarity index 100% rename from unmaintained/bubble-chamber/particle/muon/muon.factor rename to extra/bubble-chamber/particle/muon/muon.factor diff --git a/unmaintained/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor similarity index 100% rename from unmaintained/bubble-chamber/particle/particle.factor rename to extra/bubble-chamber/particle/particle.factor diff --git a/unmaintained/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor similarity index 100% rename from unmaintained/bubble-chamber/particle/quark/quark.factor rename to extra/bubble-chamber/particle/quark/quark.factor diff --git a/unmaintained/bubble-chamber/tags.txt b/extra/bubble-chamber/tags.txt similarity index 100% rename from unmaintained/bubble-chamber/tags.txt rename to extra/bubble-chamber/tags.txt From e5ed7447eddd6e33e7537ed12ebec50207b37870 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 08:46:16 -0600 Subject: [PATCH 15/32] Removing more >r/r> usages --- .../tree/cleanup/cleanup-tests.factor | 14 ++++----- .../tree/dead-code/dead-code-tests.factor | 4 +-- .../normalization/normalization-tests.factor | 4 +-- .../tree/propagation/propagation-tests.factor | 2 +- basis/cpu/x86/x86.factor | 6 ++-- basis/debugger/debugger-docs.factor | 4 +-- basis/help/markup/markup.factor | 2 +- basis/help/syntax/syntax.factor | 7 +++-- basis/html/elements/elements.factor | 2 +- basis/html/streams/streams.factor | 8 ++--- basis/interval-maps/interval-maps.factor | 2 +- basis/logging/analysis/analysis.factor | 8 ++--- basis/match/match.factor | 2 +- basis/math/geometry/rect/rect.factor | 4 +-- basis/models/history/history.factor | 2 +- basis/models/models.factor | 2 +- basis/multiline/multiline.factor | 2 +- basis/openssl/libssl/libssl.factor | 6 ++-- basis/peg/parsers/parsers.factor | 6 ++-- basis/peg/peg.factor | 10 +++---- basis/prettyprint/backend/backend.factor | 23 +++++++------- basis/prettyprint/prettyprint-tests.factor | 30 +------------------ basis/prettyprint/sections/sections.factor | 4 +-- basis/sequences/next/next.factor | 16 +++++----- basis/shuffle/shuffle-tests.factor | 1 + basis/shuffle/shuffle.factor | 2 +- basis/stack-checker/errors/errors-docs.factor | 3 +- basis/stack-checker/errors/errors.factor | 2 +- basis/threads/threads.factor | 18 +++++------ basis/tools/completion/completion.factor | 6 ++-- basis/tools/deploy/config/config.factor | 2 +- basis/tools/deploy/deploy-tests.factor | 7 ++--- basis/tools/memory/memory.factor | 11 +++---- basis/tools/profiler/profiler.factor | 2 +- basis/tools/test/test.factor | 16 +++++----- basis/tools/time/time.factor | 4 +-- basis/tools/vocabs/browser/browser.factor | 6 ++-- basis/tools/vocabs/vocabs.factor | 2 +- basis/unicode/case/case.factor | 2 +- basis/unicode/data/data.factor | 2 +- basis/unicode/normalize/normalize.factor | 15 ++++++---- 41 files changed, 120 insertions(+), 151 deletions(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4a6198db37..71c6fb5675 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -71,7 +71,7 @@ M: object xyz ; 2over fixnum>= [ 3drop ] [ - [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat) + [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat) ] if ; inline recursive : fx-repeat ( n quot -- ) @@ -87,10 +87,10 @@ M: object xyz ; 2over dup xyz drop >= [ 3drop ] [ - [ swap >r call 1+ r> ] keep (i-repeat) + [ swap [ call 1+ ] dip ] keep (i-repeat) ] if ; inline recursive -: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline +: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline [ t ] [ [ [ dup xyz drop ] i-repeat ] \ xyz inlined? @@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ; 2dup >= [ 2drop ] [ - >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2) + [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) ] if ; inline recursive : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline @@ -448,7 +448,7 @@ cell-bits 32 = [ ] unit-test [ ] [ - [ [ >r "A" throw r> ] [ "B" throw ] if ] + [ [ [ "A" throw ] dip ] [ "B" throw ] if ] cleaned-up-tree drop ] unit-test @@ -463,7 +463,7 @@ cell-bits 32 = [ : buffalo-wings ( i seq -- ) 2dup < [ 2dup chicken-fingers - >r 1+ r> buffalo-wings + [ 1+ ] dip buffalo-wings ] [ 2drop ] if ; inline recursive @@ -482,7 +482,7 @@ cell-bits 32 = [ : ribs ( i seq -- ) 2dup < [ steak - >r 1+ r> ribs + [ 1+ ] dip ribs ] [ 2drop ] if ; inline recursive diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7b15fdf856..b64e30d8f9 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests remove-dead-code "no-check" get [ dup check-nodes ] unless nodes>quot ; -[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test +[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test -[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test +[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test [ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index c4a97fcc92..5ac3c57abe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ; [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test DEFER: bbb -: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive -: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive +: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive +: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive [ ] [ [ bbb ] test-normalization ] unit-test diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 06412209ca..2c4769abe0 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -435,7 +435,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test : recursive-test-4 ( i n -- ) - 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive + 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive [ ] [ [ recursive-test-4 ] final-info drop ] unit-test diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index b7dffb849e..3dbcd2eabf 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -561,7 +561,7 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; -M: int-regs %save-param-reg drop >r param@ r> MOV ; +M: int-regs %save-param-reg drop [ param@ ] dip MOV ; M: int-regs %load-param-reg drop swap param@ MOV ; GENERIC: MOVSS/D ( dst src reg-class -- ) @@ -569,8 +569,8 @@ GENERIC: MOVSS/D ( dst src reg-class -- ) M: single-float-regs MOVSS/D drop MOVSS ; M: double-float-regs MOVSS/D drop MOVSD ; -M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ; -M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ; +M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ; +M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ; GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( n reg-class -- ) diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index fe00d011c3..30c9fd37ab 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -131,11 +131,11 @@ HELP: datastack-overflow. { $notes "This error usually indicates a run-away recursion, however if you legitimately need a data stack larger than the default, see " { $link "runtime-cli-args" } "." } ; HELP: retainstack-underflow. -{ $error-description "Thrown by the Factor VM if " { $link r> } " is called while the retain stack is empty." } +{ $error-description "Thrown by the Factor VM if an attempt is made to access the retain stack in an invalid manner. This bug should never come up in practice and indicates a bug in Factor." } { $notes "You can use the stack effect tool to statically check stack effects of quotations. See " { $link "inference" } "." } ; HELP: retainstack-overflow. -{ $error-description "Thrown by the Factor VM if " { $link >r } " is called when the retain stack is full." } +{ $error-description "Thrown by the Factor VM if " { $link dip } " is called when the retain stack is full." } { $notes "This error usually indicates a run-away recursion, however if you legitimately need a retain stack larger than the default, see " { $link "runtime-cli-args" } "." } ; HELP: memory-error. diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 318169c0a0..a7501dc242 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -97,7 +97,7 @@ ALIAS: $slot $snippet [ snippet-style get [ last-element off - >r ($code-style) r> with-nesting + [ ($code-style) ] dip with-nesting ] with-style ] ($block) ; inline diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 42d5ba1781..9a372174ba 100644 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -11,9 +11,10 @@ IN: help.syntax \ ; parse-until >array swap set-word-help ; parsing : ARTICLE: - location >r - \ ; parse-until >array [ first2 ] keep 2 tail
- over add-article >link r> remember-definition ; parsing + location [ + \ ; parse-until >array [ first2 ] keep 2 tail
+ over add-article >link + ] dip remember-definition ; parsing : ABOUT: in get vocab diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 0ee6955e29..fa92f18d34 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -24,7 +24,7 @@ SYMBOL: html : html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. - >r >r elements-vocab create r> r> define-declared ; + [ elements-vocab create ] 2dip define-declared ; : ( str -- ) "<" swap ">" 3append ; diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index fa81a69bb4..709b65761e 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -77,7 +77,7 @@ TUPLE: html-sub-stream < html-stream style parent ; "font-family: " % % "; " % ; : apply-style ( style key quot -- style gadget ) - >r over at r> when* ; inline + [ over at ] dip when* ; inline : make-css ( style quot -- str ) "" make nip ; inline @@ -163,13 +163,13 @@ M: html-stream stream-flush stream>> stream-flush ; M: html-stream stream-write1 - >r 1string r> stream-write ; + [ 1string ] dip stream-write ; M: html-stream stream-write - not-a-div >r escape-string r> stream>> stream-write ; + not-a-div [ escape-string ] dip stream>> stream-write ; M: html-stream stream-format - >r html over at [ >r escape-string r> ] unless r> + [ html over at [ [ escape-string ] dip ] unless ] dip format-html-span ; M: html-stream stream-nl diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 99da00ceab..34e43ddc75 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -15,7 +15,7 @@ TUPLE: interval-map array ; first2 between? ; : all-intervals ( sequence -- intervals ) - [ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ; + [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ; : disjoint? ( node1 node2 -- ? ) [ second ] [ first ] bi* < ; diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index 1e1e31c501..d84e49f784 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -38,8 +38,8 @@ SYMBOL: message-histogram : histogram. ( assoc quot -- ) standard-table-style [ - >r >alist sort-values r> [ - [ >r swap r> with-cell pprint-cell ] with-row + [ >alist sort-values ] dip [ + [ swapd with-cell pprint-cell ] with-row ] curry assoc-each ] tabular-output ; @@ -69,7 +69,7 @@ SYMBOL: message-histogram errors. ; : analyze-log ( lines word-names -- ) - >r parse-log r> analyze-entries analysis. ; + [ parse-log ] dip analyze-entries analysis. ; : analyze-log-file ( service word-names -- ) - >r parse-log-file r> analyze-entries analysis. ; + [ parse-log-file ] dip analyze-entries analysis. ; diff --git a/basis/match/match.factor b/basis/match/match.factor index c546555d07..7d393dadc9 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -73,7 +73,7 @@ MACRO: match-cond ( assoc -- ) 2dup [ length ] bi@ < [ 2drop f f ] [ 2dup length head over match - [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if* + [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if* ] if ; : match-first ( seq pattern-seq -- bindings ) diff --git a/basis/math/geometry/rect/rect.factor b/basis/math/geometry/rect/rect.factor index dd634f4a3b..a7cefceae8 100644 --- a/basis/math/geometry/rect/rect.factor +++ b/basis/math/geometry/rect/rect.factor @@ -37,7 +37,7 @@ M: rect rect-dim dim>> ; over rect-loc v+ swap rect-dim ; : (rect-intersect) ( rect rect -- array array ) - 2rect-extent vmin >r vmax r> ; + 2rect-extent [ vmax ] [ vmin ] 2bi* ; : rect-intersect ( rect1 rect2 -- newrect ) (rect-intersect) ; @@ -46,7 +46,7 @@ M: rect rect-dim dim>> ; (rect-intersect) [v-] { 0 0 } = ; : (rect-union) ( rect rect -- array array ) - 2rect-extent vmax >r vmin r> ; + 2rect-extent [ vmin ] [ vmax ] 2bi* ; : rect-union ( rect1 rect2 -- newrect ) (rect-union) ; diff --git a/basis/models/history/history.factor b/basis/models/history/history.factor index caf6f39d5c..90d6b594ff 100644 --- a/basis/models/history/history.factor +++ b/basis/models/history/history.factor @@ -18,7 +18,7 @@ TUPLE: history < model back forward ; : go-back/forward ( history to from -- ) [ 2drop ] - [ >r dupd (add-history) r> pop swap set-model ] if-empty ; + [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ; : go-back ( history -- ) dup [ forward>> ] [ back>> ] bi go-back/forward ; diff --git a/basis/models/models.factor b/basis/models/models.factor index 45519f7021..5da564b9d0 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -91,7 +91,7 @@ M: model update-model drop ; ] if ; : ((change-model)) ( model quot -- newvalue model ) - over >r >r value>> r> call r> ; inline + over [ [ value>> ] dip call ] dip ; inline : change-model ( model quot -- ) ((change-model)) set-model ; inline diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index ecbe9e668f..64d4b1a041 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -28,7 +28,7 @@ PRIVATE> : (parse-multiline-string) ( start-index end-text -- end-index ) lexer get line-text>> [ 2dup start - [ rot dupd >r >r swap subseq % r> r> length + ] [ + [ rot dupd [ swap subseq % ] 2dip length + ] [ rot tail % "\n" % 0 lexer get next-line swap (parse-multiline-string) ] if* diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index f1dc21f993..30501a6105 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -234,13 +234,13 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ; FUNCTION: void* BIO_f_ssl ( ) ; : SSL_CTX_set_tmp_rsa ( ctx rsa -- n ) - >r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ; + [ SSL_CTRL_SET_TMP_RSA 0 ] dip SSL_CTX_ctrl ; : SSL_CTX_set_tmp_dh ( ctx dh -- n ) - >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ; + [ SSL_CTRL_SET_TMP_DH 0 ] dip SSL_CTX_ctrl ; : SSL_CTX_set_session_cache_mode ( ctx mode -- n ) - >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ; + [ SSL_CTRL_SET_SESS_CACHE_MODE ] dip f SSL_CTX_ctrl ; : SSL_SESS_CACHE_OFF HEX: 0000 ; inline : SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index af1b4aec04..7434ca6a7a 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -24,7 +24,7 @@ M: just-parser (compile) ( parser -- quot ) : 1token ( ch -- parser ) 1string token ; : (list-of) ( items separator repeat1? -- parser ) - >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq + [ over 2seq ] dip [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq [ unclip 1vector swap first append ] action ; : list-of ( items separator -- parser ) @@ -60,11 +60,11 @@ PRIVATE> [ flatten-vectors ] action ; : from-m-to-n ( parser m n -- parser' ) - >r [ exactly-n ] 2keep r> swap - at-most-n 2seq + [ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq [ flatten-vectors ] action ; : pack ( begin body end -- parser ) - >r >r hide r> r> hide 3seq [ first ] action ; + [ hide ] 2dip hide 3seq [ first ] action ; : surrounded-by ( parser begin end -- parser' ) [ token ] bi@ swapd pack ; diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 2dabf1edf7..1fb5909bcf 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -146,8 +146,8 @@ TUPLE: peg-head rule-id involved-set eval-set ; pos set dup involved-set>> clone >>eval-set drop ; : (grow-lr) ( h p r: ( -- result ) m -- ) - >r >r [ setup-growth ] 2keep r> r> - >r dup eval-rule r> swap + [ [ setup-growth ] 2keep ] 2dip + [ dup eval-rule ] dip swap dup pick stop-growth? [ 5 ndrop ] [ @@ -156,8 +156,8 @@ TUPLE: peg-head rule-id involved-set eval-set ; ] if ; inline recursive : grow-lr ( h p r m -- ast ) - >r >r [ heads set-at ] 2keep r> r> - pick over >r >r (grow-lr) r> r> + [ [ heads set-at ] 2keep ] 2dip + pick over [ (grow-lr) ] 2dip swap heads delete-at dup pos>> pos set ans>> ; inline @@ -352,7 +352,7 @@ TUPLE: token-parser symbol ; [ ?head-slice ] keep swap [ f f add-error ] [ - >r drop pos get "token '" r> append "'" append 1vector add-error f + [ drop pos get "token '" ] dip append "'" append 1vector add-error f ] if ; M: token-parser (compile) ( peg -- quot ) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index f1fd749666..7a5b16a3c2 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -21,9 +21,6 @@ M: effect pprint* effect>string "(" swap ")" 3append text ; : ?end-group ( word -- ) ?effect-height 0 < [ end-group ] when ; -\ >r hard "break-before" set-word-prop -\ r> hard "break-after" set-word-prop - ! Atoms : word-style ( word -- style ) dup "word-style" word-prop >hashtable [ @@ -93,7 +90,7 @@ M: f pprint* drop \ f pprint-word ; ] H{ } make-assoc ; : unparse-string ( str prefix suffix -- str ) - [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ; + [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ; : pprint-string ( obj str prefix suffix -- ) unparse-string swap string-style styled-text ; @@ -156,13 +153,13 @@ M: tuple pprint* : do-length-limit ( seq -- trimmed n/f ) length-limit get dup [ over length over [-] - dup zero? [ 2drop f ] [ >r head r> ] if + dup zero? [ 2drop f ] [ [ head ] dip ] if ] when ; : pprint-elements ( seq -- ) - do-length-limit >r - [ pprint* ] each - r> [ "~" swap number>string " more~" 3append text ] when* ; + do-length-limit + [ [ pprint* ] each ] dip + [ "~" swap number>string " more~" 3append text ] when* ; GENERIC: pprint-delims ( obj -- start end ) @@ -206,10 +203,12 @@ M: tuple pprint-narrow? drop t ; : pprint-object ( obj -- ) [ r pprint-word - dup pprint-narrow? pprint-sequence pprint-elements - block> r> pprint-word block> + dup pprint-delims [ + pprint-word + dup pprint-narrow? pprint-sequence pprint-elements + block> + ] dip pprint-word block> ] check-recursion ; M: object pprint* pprint-object ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 96698fc18f..648c707967 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -135,20 +135,6 @@ M: object method-layout ; [ \ method-layout see-methods ] with-string-writer "\n" split ] unit-test -: retain-stack-test - { - "USING: io kernel sequences words ;" - "IN: prettyprint.tests" - ": retain-stack-layout ( x -- )" - " dup stream-readln stream-readln" - " >r [ define ] map r>" - " define ;" - } ; - -[ t ] [ - "retain-stack-layout" retain-stack-test check-see -] unit-test - : soft-break-test { "USING: kernel math sequences strings ;" @@ -164,19 +150,6 @@ M: object method-layout ; "soft-break-layout" soft-break-test check-see ] unit-test -: another-retain-layout-test - { - "USING: kernel sequences ;" - "IN: prettyprint.tests" - ": another-retain-layout ( seq1 seq2 quot -- newseq )" - " -rot 2dup dupd min-length [ each drop roll ] map" - " >r 3drop r> ; inline" - } ; - -[ t ] [ - "another-retain-layout" another-retain-layout-test check-see -] unit-test - DEFER: parse-error-file : another-soft-break-test @@ -219,8 +192,7 @@ DEFER: parse-error-file "USING: kernel sequences ;" "IN: prettyprint.tests" ": final-soft-break-layout ( class dim -- view )" - " >r \"alloc\" send 0 0 r>" - " first2 " + " [ \"alloc\" send 0 0 ] dip first2 " " \"initWithFrame:pixelFormat:\" send" " dup 1 \"setPostsBoundsChangedNotifications:\" send" " dup 1 \"setPostsFrameChangedNotifications:\" send ;" diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index a629ca6fff..102d005f39 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -42,7 +42,7 @@ TUPLE: pprinter last-newline line-count indent ; : text-fits? ( len -- ? ) margin get dup zero? - [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ; + [ 2drop t ] [ [ pprinter get indent>> + ] dip <= ] if ; ! break only if position margin 2 / > SYMBOL: soft @@ -189,7 +189,7 @@ M: block short-section ( block -- ) : empty-block? ( block -- ? ) sections>> empty? ; : if-nonempty ( block quot -- ) - >r dup empty-block? [ drop ] r> if ; inline + [ dup empty-block? [ drop ] ] dip if ; inline : (r dup length swap r> ; inline +: iterate-seq [ dup length swap ] dip ; inline : (map-next) ( i seq quot -- ) ! this uses O(n) more bounds checks than is really necessary - >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline + [ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline PRIVATE> -: each-next ( seq quot -- ) - ! quot: next-elt elt -- +: each-next ( seq quot: ( next-elt elt -- ) -- ) iterate-seq [ (map-next) ] 2curry each-integer ; inline -: map-next ( seq quot -- newseq ) - ! quot: next-elt elt -- newelt - over dup length swap new-sequence >r - iterate-seq [ (map-next) ] 2curry - r> [ collect ] keep ; inline +: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq ) + over dup length swap new-sequence [ + iterate-seq [ (map-next) ] 2curry + ] dip [ collect ] keep ; inline diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index b5168b903c..f190544e19 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -2,3 +2,4 @@ USING: shuffle tools.test ; [ 8 ] [ 5 6 7 8 3nip ] unit-test [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test +[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 9a0dfe0e88..b195e4abf9 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -4,7 +4,7 @@ USING: kernel generalizations ; IN: shuffle -: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline +: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : nipd ( a b c -- b c ) rot drop ; inline diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index f4d7c80e13..d4a074031d 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -115,7 +115,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors" { $subsection inconsistent-recursive-call-error } "Retain stack usage errors:" { $subsection too-many->r } -{ $subsection too-many-r> } -"See " { $link "shuffle-words" } " for retain stack usage conventions. This error can only occur if your code calls " { $link >r } " and " { $link r> } " directly. The " { $link dip } " combinator is safer to use because there is no way to leave the retain stack in an unbalanced state." ; +{ $subsection too-many-r> } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 31ae0a6789..5b6b3c0893 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -13,7 +13,7 @@ M: inference-error compiler-error-type type>> ; M: inference-error error-help error>> error-help ; : (inference-error) ( ... class type -- * ) - >r boa r> + [ boa ] dip recursive-state get word>> \ inference-error boa throw ; inline diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 4332bbbcf5..1e04ad88c2 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -4,7 +4,7 @@ USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private dlists assocs system combinators init boxes accessors -math.order deques strings quotations ; +math.order deques strings quotations fry ; IN: threads SYMBOL: initial-thread @@ -101,7 +101,7 @@ DEFER: stop r check-registered dup r> sleep-queue heap-push* + [ check-registered dup ] dip sleep-queue heap-push* >>sleep-entry drop ; : expire-sleep? ( heap -- ? ) @@ -164,10 +164,8 @@ PRIVATE> : suspend ( quot state -- obj ) [ - >r - >r self swap call - r> self (>>state) - r> self continuation>> >box + [ [ self swap call ] dip self (>>state) ] dip + self continuation>> >box next ] callcc1 2nip ; inline @@ -176,7 +174,7 @@ PRIVATE> GENERIC: sleep-until ( time/f -- ) M: integer sleep-until - [ schedule-sleep ] curry "sleep" suspend drop ; + '[ _ schedule-sleep ] "sleep" suspend drop ; M: f sleep-until drop [ drop ] "interrupt" suspend drop ; @@ -200,11 +198,11 @@ M: real sleep [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) - >r [ loop ] curry r> spawn ; + [ '[ _ loop ] ] dip spawn ; : in-thread ( quot -- ) - >r datastack r> - [ >r set-datastack r> call ] 2curry + [ datastack ] dip + '[ _ set-datastack _ call ] "Thread" spawn drop ; GENERIC: error-in-thread ( error thread -- ) diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 2306ff53a8..084b97970d 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -33,8 +33,8 @@ IN: tools.completion { { [ over zero? ] [ 2drop 10 ] } { [ 2dup length 1- number= ] [ 2drop 4 ] } - { [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] } - { [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] } + { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] } + { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] } [ 2drop 1 ] } cond ; @@ -67,7 +67,7 @@ IN: tools.completion over empty? [ nip [ first ] map ] [ - >r >lower r> [ completion ] with map + [ >lower ] dip [ completion ] with map rank-completions ] if ; diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index c78e0a32ba..84bfab682b 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -76,7 +76,7 @@ SYMBOL: deploy-image parse-fresh [ first assoc-union ] unless-empty ; : set-deploy-config ( assoc vocab -- ) - >r unparse-use string-lines r> + [ unparse-use string-lines ] dip dup deploy-config-path set-vocab-file-contents ; : set-deploy-flag ( value key vocab -- ) diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index a44f7e1f89..e3fd9b9a7c 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -7,13 +7,12 @@ urls math.parser ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors "resource:" [ - >r vm - "test.image" temp-file - r> dup deploy-config make-deploy-image + [ vm "test.image" temp-file ] dip + dup deploy-config make-deploy-image ] with-directory ; : small-enough? ( n -- ? ) - >r "test.image" temp-file file-info size>> r> cell 4 / * <= ; + [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; [ ] [ "hello-world" shake-and-bake ] unit-test diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index f61694da78..70f9a10a51 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -3,7 +3,7 @@ USING: kernel sequences vectors arrays generic assocs io math namespaces parser prettyprint strings io.styles vectors words system sorting splitting grouping math.parser classes memory -combinators ; +combinators fry ; IN: tools.memory @@ -71,7 +72,7 @@ PRIVATE> : heap-stats ( -- counts sizes ) H{ } clone H{ } clone - [ >r 2dup r> heap-stat-step ] each-object ; + 2dup '[ _ _ heap-stat-step ] each-object ; : heap-stats. ( -- ) heap-stats dup keys natural-sort standard-table-style [ diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index b7f7ae97a6..f21e8498eb 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -34,7 +34,7 @@ M: method-body (profile.) : counter. ( obj n -- ) [ - >r [ (profile.) ] with-cell r> + [ [ (profile.) ] with-cell ] dip [ number>string write ] with-cell ] with-row ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 73b261bf13..080db86338 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -3,7 +3,7 @@ USING: accessors namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.styles io.files vocabs vocabs.loader source-files -compiler.units summary stack-checker effects tools.vocabs ; +compiler.units summary stack-checker effects tools.vocabs fry ; IN: tools.test SYMBOL: failures @@ -26,24 +26,22 @@ SYMBOL: this-test ] if ; : unit-test ( output input -- ) - [ 2array ] 2keep [ - { } swap with-datastack swap >array assert= - ] 2curry (unit-test) ; + [ 2array ] 2keep '[ + _ { } _ with-datastack swap >array assert= + ] (unit-test) ; : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; : must-infer-as ( effect quot -- ) - >r 1quotation r> [ infer short-effect ] curry unit-test ; + [ 1quotation ] dip '[ _ infer short-effect ] unit-test ; : must-infer ( word/quot -- ) dup word? [ 1quotation ] when - [ infer drop ] curry [ ] swap unit-test ; + '[ _ infer drop ] [ ] swap unit-test ; : must-fail-with ( quot pred -- ) - >r [ f ] compose r> - [ recover ] 2curry - [ t ] swap unit-test ; + [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ; : must-fail ( quot -- ) [ drop t ] must-fail-with ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 1672017fc4..58fc531623 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -5,7 +5,7 @@ namespaces system sequences splitting grouping assocs strings ; IN: tools.time : benchmark ( quot -- runtime ) - micros >r call micros r> - ; inline + micros [ call micros ] dip - ; inline : time. ( data -- ) unclip @@ -37,4 +37,4 @@ IN: tools.time ] bi* ; : time ( quot -- ) - gc-reset micros >r call gc-stats micros r> - prefix time. ; inline + gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index cfc541d9bc..4cd5653ab4 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -250,9 +250,9 @@ C: vocab-author : keyed-vocabs ( str quot -- seq ) all-vocabs [ - swap >r - [ >r 2dup r> swap call member? ] filter - r> swap + swap [ + [ [ 2dup ] dip swap call member? ] filter + ] dip swap ] assoc-map 2nip ; inline : tagged ( tag -- assoc ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index d926b67078..ef0c74d7c8 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -203,7 +203,7 @@ M: vocab summary M: vocab-link summary vocab-summary ; : set-vocab-summary ( string vocab -- ) - >r 1array r> + [ 1array ] dip dup vocab-summary-path set-vocab-file-contents ; diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 3def7b5f48..932f72960a 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -5,7 +5,7 @@ unicode.normalize math unicode.categories combinators assocs strings splitting kernel accessors ; IN: unicode.case -: at-default ( key assoc -- value/key ) over >r at r> or ; +: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; : ch>lower ( ch -- lower ) simple-lower at-default ; : ch>upper ( ch -- upper ) simple-upper at-default ; diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 31d0be799f..80cf40fbf1 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -49,7 +49,7 @@ VALUE: properties : (process-data) ( index data -- newdata ) filter-comments [ [ nth ] keep first swap ] with { } map>assoc - [ >r hex> r> ] assoc-map ; + [ [ hex> ] dip ] assoc-map ; : process-data ( index data -- hash ) (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ; diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 8d6f6e888a..35bdda67f0 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -27,14 +27,17 @@ IN: unicode.normalize : hangul>jamo ( hangul -- jamo-string ) hangul-base - final-count /mod final-base + - >r medial-count /mod medial-base + - >r initial-base + r> r> + [ + medial-count /mod medial-base + + [ initial-base + ] dip + ] dip dup final-base = [ drop 2array ] [ 3array ] if ; : jamo>hangul ( initial medial final -- hangul ) - >r >r initial-base - medial-count * - r> medial-base - + final-count * - r> final-base - + hangul-base + ; + [ + [ initial-base - medial-count * ] dip + medial-base - + final-count * + ] dip final-base - + hangul-base + ; ! Normalization -- Decomposition @@ -45,7 +48,7 @@ IN: unicode.normalize : reorder-next ( string i -- new-i done? ) over [ non-starter? ] find-from drop [ reorder-slice - >r dup [ combining-class ] insertion-sort to>> r> + [ dup [ combining-class ] insertion-sort to>> ] dip ] [ length t ] if* ; : reorder-loop ( string start -- ) From 2521f05910e3c67f4808914bf18ac720ba83ca72 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 3 Dec 2008 08:53:28 -0600 Subject: [PATCH 16/32] Move cfdg.* back to extra --- {unmaintained => extra}/cfdg/authors.txt | 0 {unmaintained => extra}/cfdg/cfdg.factor | 0 {unmaintained => extra}/cfdg/gl/authors.txt | 0 {unmaintained => extra}/cfdg/gl/gl.factor | 0 {unmaintained => extra}/cfdg/models/aqua-star/aqua-star.factor | 0 {unmaintained => extra}/cfdg/models/aqua-star/authors.txt | 0 {unmaintained => extra}/cfdg/models/aqua-star/tags.txt | 0 {unmaintained => extra}/cfdg/models/chiaroscuro/authors.txt | 0 .../cfdg/models/chiaroscuro/chiaroscuro.factor | 0 {unmaintained => extra}/cfdg/models/chiaroscuro/tags.txt | 0 {unmaintained => extra}/cfdg/models/flower6/authors.txt | 0 {unmaintained => extra}/cfdg/models/flower6/deploy.factor | 0 {unmaintained => extra}/cfdg/models/flower6/flower6.factor | 0 {unmaintained => extra}/cfdg/models/flower6/tags.txt | 0 {unmaintained => extra}/cfdg/models/game1-turn6/authors.txt | 0 .../cfdg/models/game1-turn6/game1-turn6.factor | 0 {unmaintained => extra}/cfdg/models/game1-turn6/tags.txt | 0 {unmaintained => extra}/cfdg/models/lesson/authors.txt | 0 {unmaintained => extra}/cfdg/models/lesson/lesson.factor | 0 {unmaintained => extra}/cfdg/models/lesson/tags.txt | 0 {unmaintained => extra}/cfdg/models/rules08/rules08.factor | 0 {unmaintained => extra}/cfdg/models/rules08/tags.txt | 0 {unmaintained => extra}/cfdg/models/sierpinski/authors.txt | 0 {unmaintained => extra}/cfdg/models/sierpinski/sierpinski.factor | 0 {unmaintained => extra}/cfdg/models/sierpinski/tags.txt | 0 {unmaintained => extra}/cfdg/models/snowflake/authors.txt | 0 {unmaintained => extra}/cfdg/models/snowflake/snowflake.factor | 0 {unmaintained => extra}/cfdg/models/snowflake/tags.txt | 0 {unmaintained => extra}/cfdg/models/spirales/spirales.factor | 0 {unmaintained => extra}/cfdg/models/spirales/tags.txt | 0 {unmaintained => extra}/cfdg/summary.txt | 0 31 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/cfdg/authors.txt (100%) rename {unmaintained => extra}/cfdg/cfdg.factor (100%) rename {unmaintained => extra}/cfdg/gl/authors.txt (100%) rename {unmaintained => extra}/cfdg/gl/gl.factor (100%) rename {unmaintained => extra}/cfdg/models/aqua-star/aqua-star.factor (100%) rename {unmaintained => extra}/cfdg/models/aqua-star/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/aqua-star/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/chiaroscuro/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/chiaroscuro/chiaroscuro.factor (100%) rename {unmaintained => extra}/cfdg/models/chiaroscuro/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/flower6/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/flower6/deploy.factor (100%) rename {unmaintained => extra}/cfdg/models/flower6/flower6.factor (100%) rename {unmaintained => extra}/cfdg/models/flower6/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/game1-turn6/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/game1-turn6/game1-turn6.factor (100%) rename {unmaintained => extra}/cfdg/models/game1-turn6/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/lesson/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/lesson/lesson.factor (100%) rename {unmaintained => extra}/cfdg/models/lesson/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/rules08/rules08.factor (100%) rename {unmaintained => extra}/cfdg/models/rules08/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/sierpinski/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/sierpinski/sierpinski.factor (100%) rename {unmaintained => extra}/cfdg/models/sierpinski/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/snowflake/authors.txt (100%) rename {unmaintained => extra}/cfdg/models/snowflake/snowflake.factor (100%) rename {unmaintained => extra}/cfdg/models/snowflake/tags.txt (100%) rename {unmaintained => extra}/cfdg/models/spirales/spirales.factor (100%) rename {unmaintained => extra}/cfdg/models/spirales/tags.txt (100%) rename {unmaintained => extra}/cfdg/summary.txt (100%) diff --git a/unmaintained/cfdg/authors.txt b/extra/cfdg/authors.txt similarity index 100% rename from unmaintained/cfdg/authors.txt rename to extra/cfdg/authors.txt diff --git a/unmaintained/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor similarity index 100% rename from unmaintained/cfdg/cfdg.factor rename to extra/cfdg/cfdg.factor diff --git a/unmaintained/cfdg/gl/authors.txt b/extra/cfdg/gl/authors.txt similarity index 100% rename from unmaintained/cfdg/gl/authors.txt rename to extra/cfdg/gl/authors.txt diff --git a/unmaintained/cfdg/gl/gl.factor b/extra/cfdg/gl/gl.factor similarity index 100% rename from unmaintained/cfdg/gl/gl.factor rename to extra/cfdg/gl/gl.factor diff --git a/unmaintained/cfdg/models/aqua-star/aqua-star.factor b/extra/cfdg/models/aqua-star/aqua-star.factor similarity index 100% rename from unmaintained/cfdg/models/aqua-star/aqua-star.factor rename to extra/cfdg/models/aqua-star/aqua-star.factor diff --git a/unmaintained/cfdg/models/aqua-star/authors.txt b/extra/cfdg/models/aqua-star/authors.txt similarity index 100% rename from unmaintained/cfdg/models/aqua-star/authors.txt rename to extra/cfdg/models/aqua-star/authors.txt diff --git a/unmaintained/cfdg/models/aqua-star/tags.txt b/extra/cfdg/models/aqua-star/tags.txt similarity index 100% rename from unmaintained/cfdg/models/aqua-star/tags.txt rename to extra/cfdg/models/aqua-star/tags.txt diff --git a/unmaintained/cfdg/models/chiaroscuro/authors.txt b/extra/cfdg/models/chiaroscuro/authors.txt similarity index 100% rename from unmaintained/cfdg/models/chiaroscuro/authors.txt rename to extra/cfdg/models/chiaroscuro/authors.txt diff --git a/unmaintained/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor similarity index 100% rename from unmaintained/cfdg/models/chiaroscuro/chiaroscuro.factor rename to extra/cfdg/models/chiaroscuro/chiaroscuro.factor diff --git a/unmaintained/cfdg/models/chiaroscuro/tags.txt b/extra/cfdg/models/chiaroscuro/tags.txt similarity index 100% rename from unmaintained/cfdg/models/chiaroscuro/tags.txt rename to extra/cfdg/models/chiaroscuro/tags.txt diff --git a/unmaintained/cfdg/models/flower6/authors.txt b/extra/cfdg/models/flower6/authors.txt similarity index 100% rename from unmaintained/cfdg/models/flower6/authors.txt rename to extra/cfdg/models/flower6/authors.txt diff --git a/unmaintained/cfdg/models/flower6/deploy.factor b/extra/cfdg/models/flower6/deploy.factor similarity index 100% rename from unmaintained/cfdg/models/flower6/deploy.factor rename to extra/cfdg/models/flower6/deploy.factor diff --git a/unmaintained/cfdg/models/flower6/flower6.factor b/extra/cfdg/models/flower6/flower6.factor similarity index 100% rename from unmaintained/cfdg/models/flower6/flower6.factor rename to extra/cfdg/models/flower6/flower6.factor diff --git a/unmaintained/cfdg/models/flower6/tags.txt b/extra/cfdg/models/flower6/tags.txt similarity index 100% rename from unmaintained/cfdg/models/flower6/tags.txt rename to extra/cfdg/models/flower6/tags.txt diff --git a/unmaintained/cfdg/models/game1-turn6/authors.txt b/extra/cfdg/models/game1-turn6/authors.txt similarity index 100% rename from unmaintained/cfdg/models/game1-turn6/authors.txt rename to extra/cfdg/models/game1-turn6/authors.txt diff --git a/unmaintained/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor similarity index 100% rename from unmaintained/cfdg/models/game1-turn6/game1-turn6.factor rename to extra/cfdg/models/game1-turn6/game1-turn6.factor diff --git a/unmaintained/cfdg/models/game1-turn6/tags.txt b/extra/cfdg/models/game1-turn6/tags.txt similarity index 100% rename from unmaintained/cfdg/models/game1-turn6/tags.txt rename to extra/cfdg/models/game1-turn6/tags.txt diff --git a/unmaintained/cfdg/models/lesson/authors.txt b/extra/cfdg/models/lesson/authors.txt similarity index 100% rename from unmaintained/cfdg/models/lesson/authors.txt rename to extra/cfdg/models/lesson/authors.txt diff --git a/unmaintained/cfdg/models/lesson/lesson.factor b/extra/cfdg/models/lesson/lesson.factor similarity index 100% rename from unmaintained/cfdg/models/lesson/lesson.factor rename to extra/cfdg/models/lesson/lesson.factor diff --git a/unmaintained/cfdg/models/lesson/tags.txt b/extra/cfdg/models/lesson/tags.txt similarity index 100% rename from unmaintained/cfdg/models/lesson/tags.txt rename to extra/cfdg/models/lesson/tags.txt diff --git a/unmaintained/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor similarity index 100% rename from unmaintained/cfdg/models/rules08/rules08.factor rename to extra/cfdg/models/rules08/rules08.factor diff --git a/unmaintained/cfdg/models/rules08/tags.txt b/extra/cfdg/models/rules08/tags.txt similarity index 100% rename from unmaintained/cfdg/models/rules08/tags.txt rename to extra/cfdg/models/rules08/tags.txt diff --git a/unmaintained/cfdg/models/sierpinski/authors.txt b/extra/cfdg/models/sierpinski/authors.txt similarity index 100% rename from unmaintained/cfdg/models/sierpinski/authors.txt rename to extra/cfdg/models/sierpinski/authors.txt diff --git a/unmaintained/cfdg/models/sierpinski/sierpinski.factor b/extra/cfdg/models/sierpinski/sierpinski.factor similarity index 100% rename from unmaintained/cfdg/models/sierpinski/sierpinski.factor rename to extra/cfdg/models/sierpinski/sierpinski.factor diff --git a/unmaintained/cfdg/models/sierpinski/tags.txt b/extra/cfdg/models/sierpinski/tags.txt similarity index 100% rename from unmaintained/cfdg/models/sierpinski/tags.txt rename to extra/cfdg/models/sierpinski/tags.txt diff --git a/unmaintained/cfdg/models/snowflake/authors.txt b/extra/cfdg/models/snowflake/authors.txt similarity index 100% rename from unmaintained/cfdg/models/snowflake/authors.txt rename to extra/cfdg/models/snowflake/authors.txt diff --git a/unmaintained/cfdg/models/snowflake/snowflake.factor b/extra/cfdg/models/snowflake/snowflake.factor similarity index 100% rename from unmaintained/cfdg/models/snowflake/snowflake.factor rename to extra/cfdg/models/snowflake/snowflake.factor diff --git a/unmaintained/cfdg/models/snowflake/tags.txt b/extra/cfdg/models/snowflake/tags.txt similarity index 100% rename from unmaintained/cfdg/models/snowflake/tags.txt rename to extra/cfdg/models/snowflake/tags.txt diff --git a/unmaintained/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor similarity index 100% rename from unmaintained/cfdg/models/spirales/spirales.factor rename to extra/cfdg/models/spirales/spirales.factor diff --git a/unmaintained/cfdg/models/spirales/tags.txt b/extra/cfdg/models/spirales/tags.txt similarity index 100% rename from unmaintained/cfdg/models/spirales/tags.txt rename to extra/cfdg/models/spirales/tags.txt diff --git a/unmaintained/cfdg/summary.txt b/extra/cfdg/summary.txt similarity index 100% rename from unmaintained/cfdg/summary.txt rename to extra/cfdg/summary.txt From 83965c8564a0d89e896242b18acb4b9744a23592 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 3 Dec 2008 08:53:43 -0600 Subject: [PATCH 17/32] cfdg: Use 'specialized-arrays.double' --- extra/cfdg/cfdg.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 58772e23e0..e1c89374fd 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -6,8 +6,10 @@ USING: kernel alien.c-types combinators namespaces make arrays vars colors self self.slots random-weighted colors.hsv cfdg.gl accessors ui.gadgets.handler ui.gestures assocs ui.gadgets macros - qualified speicalized-arrays.double ; + qualified specialized-arrays.double ; + QUALIFIED: syntax + IN: cfdg ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -53,7 +55,10 @@ VAR: color-stack ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ; +! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ; + +: double-nth* ( c-array indices -- seq ) + swap byte-array>double-array [ nth ] curry map ; : check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ; From 3254b1c103b025d2da8e7fcbd726d7eba3b6737a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 3 Dec 2008 08:56:25 -0600 Subject: [PATCH 18/32] Move pong back to extra --- {unmaintained => extra}/pong/pong.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/pong/pong.factor (100%) diff --git a/unmaintained/pong/pong.factor b/extra/pong/pong.factor similarity index 100% rename from unmaintained/pong/pong.factor rename to extra/pong/pong.factor From cb5dd5c2355ee939da6c3a8c8dcacbedada0b90e Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 08:58:20 -0600 Subject: [PATCH 19/32] Get io.mmap to load on Windows again --- basis/io/windows/nt/privileges/privileges.factor | 1 - 1 file changed, 1 deletion(-) mode change 100644 => 100755 basis/io/windows/nt/privileges/privileges.factor diff --git a/basis/io/windows/nt/privileges/privileges.factor b/basis/io/windows/nt/privileges/privileges.factor old mode 100644 new mode 100755 index 106cf06b77..264f337eaf --- a/basis/io/windows/nt/privileges/privileges.factor +++ b/basis/io/windows/nt/privileges/privileges.factor @@ -42,7 +42,6 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES [ lookup-privilege ] dip [ TOKEN_PRIVILEGES-Privileges - [ 0 ] dip LUID_AND_ATTRIBUTES-nth set-LUID_AND_ATTRIBUTES-Luid ] keep ; From cc34ead7541b3d567ee62380c324bbf0f4f37c8a Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 09:12:57 -0600 Subject: [PATCH 20/32] Update windows.com.wrapper for specialized-arrays changes --- basis/windows/com/wrapper/wrapper.factor | 33 +++++++++++++----------- 1 file changed, 18 insertions(+), 15 deletions(-) mode change 100644 => 100755 basis/windows/com/wrapper/wrapper.factor diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor old mode 100644 new mode 100755 index 5cb830bc66..710feeec4d --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -1,8 +1,9 @@ -USING: alien alien.c-types windows.com.syntax init -windows.com.syntax.private windows.com continuations kernel +USING: alien alien.c-types alien.accessors windows.com.syntax +init windows.com.syntax.private windows.com continuations kernel namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units -destructors fry math.parser generalizations sets ; +destructors fry math.parser generalizations sets +specialized-arrays.alien specialized-arrays.direct.alien ; IN: windows.com.wrapper TUPLE: com-wrapper callbacks vtbls disposed ; @@ -51,23 +52,26 @@ unless _ case [ "void*" heap-size * rot com-add-ref - 0 rot set-void*-nth S_OK - ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if* + swap 0 set-alien-cell S_OK + ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if* ] ; : (make-add-ref) ( interfaces -- quot ) length "void*" heap-size * '[ - _ swap - 0 over ulong-nth - 1+ [ 0 rot set-ulong-nth ] keep + _ + [ alien-unsigned-4 1+ dup ] + [ set-alien-unsigned-4 ] + 2bi ] ; : (make-release) ( interfaces -- quot ) length "void*" heap-size * '[ - _ over - 0 over ulong-nth - 1- [ 0 rot set-ulong-nth ] keep - dup zero? [ swap (free-wrapped-object) ] [ nip ] if + _ + [ drop ] + [ alien-unsigned-4 1- dup ] + [ set-alien-unsigned-4 ] + 2tri + dup 0 = [ swap (free-wrapped-object) ] [ nip ] if ] ; : (make-iunknown-methods) ( interfaces -- quots ) @@ -125,8 +129,7 @@ unless : (malloc-wrapped-object) ( wrapper -- wrapped-object ) vtbls>> length "void*" heap-size * [ "ulong" heap-size + malloc ] keep - over - 1 0 rot set-ulong-nth ; + [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; @@ -159,5 +162,5 @@ M: com-wrapper dispose* : com-wrap ( object wrapper -- wrapped-object ) [ vtbls>> ] [ (malloc-wrapped-object) ] bi - [ [ set-void*-nth ] curry each-index ] keep + [ over length 0 swap copy ] keep [ +wrapped-objects+ get-global set-at ] keep ; From 8e6936251238b33fe84f76c404fe053d64781bef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 09:33:32 -0600 Subject: [PATCH 21/32] Better error message for INSTANCE: if second arg is not a mixin --- basis/debugger/debugger.factor | 16 +++++++++------- core/classes/mixin/mixin.factor | 2 +- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 0e7a56ee5f..94ceff8a23 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -3,13 +3,13 @@ USING: slots arrays definitions generic hashtables summary io kernel math namespaces make prettyprint prettyprint.config sequences assocs sequences.private strings io.styles io.files -vectors words system splitting math.parser classes.tuple -continuations continuations.private combinators generic.math -classes.builtin classes compiler.units generic.standard vocabs -init kernel.private io.encodings accessors math.order -destructors source-files parser classes.tuple.parser -effects.parser lexer compiler.errors generic.parser -strings.parser ; +vectors words system splitting math.parser classes.mixin +classes.tuple continuations continuations.private combinators +generic.math classes.builtin classes compiler.units +generic.standard vocabs init kernel.private io.encodings +accessors math.order destructors source-files parser +classes.tuple.parser effects.parser lexer compiler.errors +generic.parser strings.parser ; IN: debugger GENERIC: error. ( error -- ) @@ -327,3 +327,5 @@ M: bad-effect summary M: bad-escape summary drop "Bad escape code" ; M: bad-literal-tuple summary drop "Bad literal tuple" ; + +M: check-mixin-class summary drop "Not a mixin class" ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 65726cf6e8..2470c00875 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -25,7 +25,7 @@ M: mixin-class rank-class drop 3 ; bi ] if ; -TUPLE: check-mixin-class mixin ; +TUPLE: check-mixin-class class ; : check-mixin-class ( mixin -- mixin ) dup mixin-class? [ From c6f214f60df2fcae1d9b6cda73ad24b593e1c37d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 09:41:48 -0600 Subject: [PATCH 22/32] Add struct-arrays --- basis/struct-arrays/authors.txt | 1 + .../struct-arrays/struct-arrays-tests.factor | 19 ++++++++++ basis/struct-arrays/struct-arrays.factor | 37 +++++++++++++++++++ basis/struct-arrays/summary.txt | 1 + basis/struct-arrays/tags.txt | 1 + 5 files changed, 59 insertions(+) create mode 100644 basis/struct-arrays/authors.txt create mode 100644 basis/struct-arrays/struct-arrays-tests.factor create mode 100644 basis/struct-arrays/struct-arrays.factor create mode 100644 basis/struct-arrays/summary.txt create mode 100644 basis/struct-arrays/tags.txt diff --git a/basis/struct-arrays/authors.txt b/basis/struct-arrays/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/struct-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor new file mode 100644 index 0000000000..160abfe90a --- /dev/null +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -0,0 +1,19 @@ +IN: struct-arrays.tests +USING: struct-arrays tools.test kernel math sequences +alien.syntax alien.c-types ; + +C-STRUCT: test-struct +{ "int" "x" } +{ "int" "y" } ; + +: make-point ( x y -- struct ) + "test-struct" + [ set-test-struct-y ] keep + [ set-test-struct-x ] keep ; + +[ 5/4 ] [ + 2 "test-struct" + 1 2 make-point over set-first + 3 4 make-point over set-second + 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce +] unit-test diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor new file mode 100644 index 0000000000..0b31845fc7 --- /dev/null +++ b/basis/struct-arrays/struct-arrays.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types byte-arrays kernel libc +math sequences sequences.private ; +IN: struct-arrays + +TUPLE: struct-array +{ underlying c-ptr read-only } +{ length array-capacity read-only } +{ element-size array-capacity read-only } ; + +M: struct-array length length>> ; + +M: struct-array nth-unsafe + [ element-size>> * ] [ underlying>> ] bi ; + +M: struct-array set-nth-unsafe + [ nth-unsafe swap ] [ element-size>> ] bi memcpy ; + +M: struct-array new-sequence + element-size>> [ * ] 2keep struct-array boa ; inline + +: ( length c-type -- struct-array ) + heap-size [ * ] 2keep struct-array boa ; inline + +ERROR: bad-byte-array-length byte-array ; + +: byte-array>struct-array ( byte-array c-type -- struct-array ) + heap-size [ + [ dup length ] dip /mod 0 = + [ drop bad-byte-array-length ] unless + ] keep struct-array boa ; inline + +: ( alien length c-type -- struct-array ) + struct-array boa ; inline + +INSTANCE: struct-array sequence diff --git a/basis/struct-arrays/summary.txt b/basis/struct-arrays/summary.txt new file mode 100644 index 0000000000..0458b5a806 --- /dev/null +++ b/basis/struct-arrays/summary.txt @@ -0,0 +1 @@ +Arrays of C structs and unions diff --git a/basis/struct-arrays/tags.txt b/basis/struct-arrays/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/basis/struct-arrays/tags.txt @@ -0,0 +1 @@ +collections From fdbf623bd4a2d4a64a3b472f6cc09514b0755abf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 09:45:42 -0600 Subject: [PATCH 23/32] Document struct arrays --- basis/struct-arrays/struct-arrays-docs.factor | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 basis/struct-arrays/struct-arrays-docs.factor diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor new file mode 100644 index 0000000000..4a198e723c --- /dev/null +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -0,0 +1,23 @@ +IN: struct-arrays +USING: help.markup help.syntax alien strings math ; + +HELP: struct-array +{ $class-description "The class of C struct and union arrays." +$nl +"The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ; + +HELP: +{ $values { "length" integer } { "c-type" string } } +{ $description "Creates a new array for holding values of the specified C type." } ; + +HELP: +{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } } +{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; + +ARTICLE: "struct-arrays" "C struct and union arrays" +"The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values." +{ $subsection struct-array } +{ $subsection } +{ $subsection } ; + +ABOUT: "struct-arrays" From 85c79bb41ea185a6f073c9965a2ba7e7cbaa2228 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 09:54:02 -0600 Subject: [PATCH 24/32] Fix malloc-struct-array --- basis/struct-arrays/struct-arrays.factor | 3 +++ 1 file changed, 3 insertions(+) mode change 100644 => 100755 basis/struct-arrays/struct-arrays.factor diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor old mode 100644 new mode 100755 index 0b31845fc7..33a469d0c8 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -34,4 +34,7 @@ ERROR: bad-byte-array-length byte-array ; : ( alien length c-type -- struct-array ) struct-array boa ; inline +: malloc-struct-array ( length c-type -- struct-array ) + heap-size [ calloc ] 2keep ; + INSTANCE: struct-array sequence From 35df2fd480bb9ec12ec797ec71d18746b1c8e6cc Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 09:54:59 -0600 Subject: [PATCH 25/32] Add test for malloc-struct-array --- basis/struct-arrays/struct-arrays-tests.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) mode change 100644 => 100755 basis/struct-arrays/struct-arrays-tests.factor diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor old mode 100644 new mode 100755 index 160abfe90a..d2bf583b5a --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -1,6 +1,6 @@ IN: struct-arrays.tests USING: struct-arrays tools.test kernel math sequences -alien.syntax alien.c-types ; +alien.syntax alien.c-types destructors libc accessors ; C-STRUCT: test-struct { "int" "x" } @@ -17,3 +17,13 @@ C-STRUCT: test-struct 3 4 make-point over set-second 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce ] unit-test + +[ 5/4 ] [ + [ + 2 "test-struct" malloc-struct-array + dup underlying>> &free drop + 1 2 make-point over set-first + 3 4 make-point over set-second + 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce + ] with-destructors +] unit-test From 852e00c57ad221bf1f55a895454264c7f22d8165 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 3 Dec 2008 09:55:11 -0600 Subject: [PATCH 26/32] Update windows.dinput for specialized-arrays --- basis/windows/dinput/constants/constants.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) mode change 100644 => 100755 basis/windows/dinput/constants/constants.factor diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor old mode 100644 new mode 100755 index 182c17430f..e3bec6d7ac --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -1,7 +1,8 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces combinators sequences symbols fry math accessors macros words quotations -libc continuations generalizations splitting locals assocs init ; +libc continuations generalizations splitting locals assocs init +struct-arrays ; IN: windows.dinput.constants ! Some global variables aren't provided by the DirectInput DLL (they're in the @@ -52,14 +53,14 @@ SYMBOLS: } cleave "DIOBJECTDATAFORMAT" (DIOBJECTDATAFORMAT) ; -: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien ) - [ nip length "DIOBJECTDATAFORMAT" malloc-array dup ] - [ - -rot [| args i alien struct | +:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien ) + [let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] | + array [| args i | struct args - i alien set-DIOBJECTDATAFORMAT-nth - ] 2curry each-index - ] 2bi ; + i alien set-nth + ] each-index + alien underlying>> + ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) [ { From bea4d80a33fb213692fbfe61add0046d862891d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 10:11:02 -0600 Subject: [PATCH 27/32] Add specialization hints from old float-arrays. These will be replaced with a better facility soon --- basis/specialized-arrays/double/double.factor | 68 ++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor index b7fc3a8143..0501458532 100644 --- a/basis/specialized-arrays/double/double.factor +++ b/basis/specialized-arrays/double/double.factor @@ -1,4 +1,70 @@ USE: specialized-arrays.functor IN: specialized-arrays.double -<< "double" define-array >> \ No newline at end of file +<< "double" define-array >> + +! Specializer hints. These should really be generalized, and placed +! somewhere else +USING: hints math.vectors arrays kernel math accessors sequences ; + +HINTS: { 2 } { 3 } ; + +HINTS: vneg { array } { double-array } ; +HINTS: v*n { array object } { double-array float } ; +HINTS: n*v { array object } { float double-array } ; +HINTS: v/n { array object } { double-array float } ; +HINTS: n/v { object array } { float double-array } ; +HINTS: v+ { array array } { double-array double-array } ; +HINTS: v- { array array } { double-array double-array } ; +HINTS: v* { array array } { double-array double-array } ; +HINTS: v/ { array array } { double-array double-array } ; +HINTS: vmax { array array } { double-array double-array } ; +HINTS: vmin { array array } { double-array double-array } ; +HINTS: v. { array array } { double-array double-array } ; +HINTS: norm-sq { array } { double-array } ; +HINTS: norm { array } { double-array } ; +HINTS: normalize { array } { double-array } ; +HINTS: distance { array array } { double-array double-array } ; + +! Type functions +USING: words classes.algebra compiler.tree.propagation.info +math.intervals ; + +{ v+ v- v* v/ vmax vmin } [ + [ + [ class>> double-array class<= ] both? + double-array object ? + ] "outputs" set-word-prop +] each + +{ n*v n/v } [ + [ + nip class>> double-array class<= double-array object ? + ] "outputs" set-word-prop +] each + +{ v*n v/n } [ + [ + drop class>> double-array class<= double-array object ? + ] "outputs" set-word-prop +] each + +{ vneg normalize } [ + [ + class>> double-array class<= double-array object ? + ] "outputs" set-word-prop +] each + +\ norm-sq [ + class>> double-array class<= [ float 0. 1/0. [a,b] ] [ object-info ] if +] "outputs" set-word-prop + +\ v. [ + [ class>> double-array class<= ] both? + float object ? +] "outputs" set-word-prop + +\ distance [ + [ class>> double-array class<= ] both? + [ float 0. 1/0. [a,b] ] [ object-info ] if +] "outputs" set-word-prop From e6cb449b1980f5d8770e2707b964e24bcab487bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 10:44:21 -0600 Subject: [PATCH 28/32] optimized. now accepts method-specs --- basis/compiler/tree/debugger/debugger.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index e9bf77b188..8d764a2833 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -125,9 +125,13 @@ M: node node>quot drop ; : nodes>quot ( node -- quot ) [ [ node>quot ] each ] [ ] make ; -: optimized. ( quot/word -- ) - dup word? [ specialized-def ] when - build-tree optimize-tree nodes>quot . ; +GENERIC: optimized. ( quot/word -- ) + +M: method-spec optimized. first2 method optimized. ; + +M: word optimized. specialized-def optimized. ; + +M: callable optimized. build-tree optimize-tree nodes>quot . ; SYMBOL: words-called SYMBOL: generics-called From 378bedd1e037a872c13415cad4ad89635eec7cf3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 10:44:41 -0600 Subject: [PATCH 29/32] Faster mersenne-twister with specialized-arrays --- .../mersenne-twister/mersenne-twister.factor | 42 +++++++++++-------- 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 5610ef18c2..90abec68a5 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -2,48 +2,54 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: kernel math namespaces sequences system init -accessors math.ranges random circular math.bitwise -combinators specialized-arrays.uint ; +USING: kernel math namespaces sequences sequences.private system +init accessors math.ranges random math.bitwise combinators +specialized-arrays.uint fry ; IN: random.mersenne-twister > [ - [ (mt-generate) ] [ set-nth ] 2bi - ] curry each - ] [ 0 >>i drop ] bi ; + mt-n swap seq>> '[ + _ [ (mt-generate) ] [ set-wrap-nth ] 2bi + ] each + ] [ 0 >>i drop ] bi ; inline : init-mt-formula ( i seq -- f(seq[i]) ) - dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; + dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline : init-mt-rest ( seq -- ) mt-n 1- swap [ - [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi - ] curry each ; + [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi + ] curry each ; inline : init-mt-seq ( seed -- seq ) - 32 bits mt-n + 32 bits mt-n [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) @@ -53,7 +59,7 @@ TUPLE: mersenne-twister seq i ; dup -18 shift bitxor ; inline : next-index ( mt -- i ) - dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; + dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline PRIVATE> @@ -66,7 +72,7 @@ M: mersenne-twister seed-random ( mt seed -- ) M: mersenne-twister random-32* ( mt -- r ) [ next-index ] - [ seq>> nth mt-temper ] + [ seq>> wrap-nth mt-temper ] [ [ 1+ ] change-i drop ] tri ; USE: init From 4c6af1cc9f370ffc65fe2323b84ca16b8bc3800d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 10:45:06 -0600 Subject: [PATCH 30/32] Use fry instead of curry --- basis/random/mersenne-twister/mersenne-twister.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 90abec68a5..3097eafd15 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -44,9 +44,9 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline : init-mt-rest ( seq -- ) - mt-n 1- swap [ - [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi - ] curry each ; inline + mt-n 1- swap '[ + _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi + ] each ; inline : init-mt-seq ( seed -- seq ) 32 bits mt-n From 8956ee0cc55a41d4a880fcefde29a2d4cccbe7a0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 12:06:16 -0600 Subject: [PATCH 31/32] Fix struct-arrays help lint --- basis/struct-arrays/struct-arrays-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor index 4a198e723c..0a627f7538 100644 --- a/basis/struct-arrays/struct-arrays-docs.factor +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -7,11 +7,11 @@ $nl "The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ; HELP: -{ $values { "length" integer } { "c-type" string } } +{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } } { $description "Creates a new array for holding values of the specified C type." } ; HELP: -{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } } +{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } } { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; ARTICLE: "struct-arrays" "C struct and union arrays" From 9354207a5f29f2a7f13a715ad812a7ee4cbf7aff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 12:51:26 -0600 Subject: [PATCH 32/32] Fix io.mmap.ushort --- basis/io/mmap/ushort/ushort.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/mmap/ushort/ushort.factor b/basis/io/mmap/ushort/ushort.factor index e0989aa9d4..6d5ac016cf 100644 --- a/basis/io/mmap/ushort/ushort.factor +++ b/basis/io/mmap/ushort/ushort.factor @@ -1,4 +1,4 @@ -USE: specialized-arrays.functor -IN: specialized-arrays.ushort +USING: io.mmap.functor specialized-arrays.direct.ushort ; +IN: io.mmap.ushort -<< "ushort" define-array >> \ No newline at end of file +<< "ushort" define-mapped-array >> \ No newline at end of file