From 2fe364a7bbb198e70b816ccd7f49945c9dedf9fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Nov 2008 20:18:16 -0600 Subject: [PATCH 001/441] Specialized arrays work in progress --- basis/alien/arrays/arrays-docs.factor | 64 +-------- basis/alien/c-types/c-types-tests.factor | 2 - basis/alien/c-types/c-types.factor | 102 +++++---------- basis/alien/structs/structs.factor | 4 +- basis/cocoa/views/views.factor | 10 +- basis/compiler/tests/alien.factor | 9 +- basis/compiler/tests/codegen.factor | 2 +- basis/compiler/tests/spilling.factor | 2 +- .../tree/propagation/propagation-tests.factor | 4 +- basis/db/postgresql/lib/lib.factor | 9 +- basis/float-arrays/float-arrays-docs.factor | 62 --------- basis/float-arrays/float-arrays-tests.factor | 12 -- basis/float-arrays/float-arrays.factor | 123 ------------------ basis/float-arrays/summary.txt | 1 - basis/float-vectors/float-vectors-docs.factor | 37 ------ .../float-vectors/float-vectors-tests.factor | 14 -- basis/float-vectors/float-vectors.factor | 38 ------ basis/float-vectors/summary.txt | 1 - basis/{float-arrays => functors}/authors.txt | 0 basis/functors/functors-tests.factor | 47 +++++++ basis/functors/functors.factor | 98 ++++++++++++++ basis/functors/summary.txt | 1 + basis/functors/tags.txt | 1 + basis/io/mmap/functor/functor.factor | 22 ++++ basis/io/mmap/mmap.factor | 6 +- basis/io/unix/pipes/pipes.factor | 10 +- basis/io/windows/launcher/launcher.factor | 9 +- basis/io/windows/nt/monitors/monitors.factor | 2 +- basis/locals/locals-tests.factor | 1 - basis/locals/locals.factor | 37 +++--- basis/opengl/opengl.factor | 20 ++- basis/serialize/serialize-tests.factor | 8 +- basis/specialized-arrays/alien/alien.factor | 4 + basis/specialized-arrays/authors.txt | 1 + basis/specialized-arrays/bool/bool.factor | 4 + basis/specialized-arrays/char/char.factor | 4 + .../direct/alien/alien.factor | 4 + .../direct/bool/bool.factor | 4 + .../direct/char/char.factor | 4 + basis/specialized-arrays/direct/direct.factor | 3 + .../direct/double/double.factor | 4 + .../direct/float/float.factor | 4 + .../direct/functor/functor.factor | 35 +++++ .../specialized-arrays/direct/int/int.factor | 4 + .../direct/long/long.factor | 4 + .../direct/longlong/longlong.factor | 4 + .../direct/short/short.factor | 4 + .../direct/uchar/uchar.factor | 4 + .../direct/uint/uint.factor | 4 + .../direct/ulong/ulong.factor | 4 + .../direct/ulonglong/ulonglong.factor | 4 + .../direct/ushort/ushort.factor | 4 + basis/specialized-arrays/double/double.factor | 4 + basis/specialized-arrays/float/float.factor | 4 + .../specialized-arrays/functor/functor.factor | 61 +++++++++ basis/specialized-arrays/int/int.factor | 4 + basis/specialized-arrays/long/long.factor | 4 + .../longlong/longlong.factor | 4 + basis/specialized-arrays/short/short.factor | 4 + .../specialized-arrays-docs.factor | 37 ++++++ .../specialized-arrays-tests.factor | 11 ++ .../specialized-arrays.factor | 3 + basis/specialized-arrays/summary.txt | 1 + .../tags.txt | 0 basis/specialized-arrays/uchar/uchar.factor | 4 + basis/specialized-arrays/uint/uint.factor | 4 + basis/specialized-arrays/ulong/ulong.factor | 4 + .../ulonglong/ulonglong.factor | 4 + basis/specialized-arrays/ushort/ushort.factor | 4 + basis/specialized-vectors/alien/alien.factor | 4 + basis/specialized-vectors/authors.txt | 1 + basis/specialized-vectors/bool/bool.factor | 4 + basis/specialized-vectors/char/char.factor | 4 + .../specialized-vectors/double/double.factor | 4 + basis/specialized-vectors/float/float.factor | 4 + .../functor/functor.factor | 46 +++++++ basis/specialized-vectors/int/int.factor | 4 + basis/specialized-vectors/long/long.factor | 4 + .../longlong/longlong.factor | 4 + basis/specialized-vectors/short/short.factor | 4 + .../specialized-vectors-docs.factor | 35 +++++ .../specialized-vectors.factor | 3 + basis/specialized-vectors/summary.txt | 1 + .../tags.txt | 0 basis/specialized-vectors/uchar/uchar.factor | 4 + basis/specialized-vectors/uint/uint.factor | 4 + basis/specialized-vectors/ulong/ulong.factor | 4 + .../ulonglong/ulonglong.factor | 4 + .../specialized-vectors/ushort/ushort.factor | 4 + basis/ui/gadgets/buttons/buttons.factor | 5 +- basis/ui/render/render.factor | 9 +- basis/unix/utilities/utilities.factor | 5 +- basis/windows/com/wrapper/wrapper.factor | 5 +- basis/x11/clipboard/clipboard.factor | 7 +- basis/x11/glx/glx.factor | 4 +- basis/x11/xim/xim.factor | 6 +- core/syntax/syntax.factor | 4 +- core/words/words.factor | 2 + extra/benchmark/dawes/dawes.factor | 13 +- .../fixed-pipeline/fixed-pipeline.factor | 4 +- extra/bunny/model/model.factor | 7 +- extra/cairo/samples/samples.factor | 4 +- extra/cfdg/cfdg.factor | 4 +- extra/hello-world/deploy.factor | 17 +-- extra/jamshred/gl/gl.factor | 10 +- extra/math/blas/matrices/matrices.factor | 10 +- extra/math/blas/vectors/vectors.factor | 20 +-- extra/openal/openal.factor | 8 +- extra/opengl/shaders/shaders.factor | 5 +- extra/synth/buffers/buffers.factor | 4 +- 110 files changed, 757 insertions(+), 560 deletions(-) delete mode 100644 basis/float-arrays/float-arrays-docs.factor delete mode 100644 basis/float-arrays/float-arrays-tests.factor delete mode 100644 basis/float-arrays/float-arrays.factor delete mode 100644 basis/float-arrays/summary.txt delete mode 100644 basis/float-vectors/float-vectors-docs.factor delete mode 100644 basis/float-vectors/float-vectors-tests.factor delete mode 100644 basis/float-vectors/float-vectors.factor delete mode 100644 basis/float-vectors/summary.txt rename basis/{float-arrays => functors}/authors.txt (100%) mode change 100755 => 100644 create mode 100644 basis/functors/functors-tests.factor create mode 100644 basis/functors/functors.factor create mode 100644 basis/functors/summary.txt create mode 100644 basis/functors/tags.txt create mode 100644 basis/io/mmap/functor/functor.factor create mode 100644 basis/specialized-arrays/alien/alien.factor create mode 100644 basis/specialized-arrays/authors.txt create mode 100644 basis/specialized-arrays/bool/bool.factor create mode 100644 basis/specialized-arrays/char/char.factor create mode 100644 basis/specialized-arrays/direct/alien/alien.factor create mode 100644 basis/specialized-arrays/direct/bool/bool.factor create mode 100644 basis/specialized-arrays/direct/char/char.factor create mode 100644 basis/specialized-arrays/direct/direct.factor create mode 100644 basis/specialized-arrays/direct/double/double.factor create mode 100644 basis/specialized-arrays/direct/float/float.factor create mode 100644 basis/specialized-arrays/direct/functor/functor.factor create mode 100644 basis/specialized-arrays/direct/int/int.factor create mode 100644 basis/specialized-arrays/direct/long/long.factor create mode 100644 basis/specialized-arrays/direct/longlong/longlong.factor create mode 100644 basis/specialized-arrays/direct/short/short.factor create mode 100644 basis/specialized-arrays/direct/uchar/uchar.factor create mode 100644 basis/specialized-arrays/direct/uint/uint.factor create mode 100644 basis/specialized-arrays/direct/ulong/ulong.factor create mode 100644 basis/specialized-arrays/direct/ulonglong/ulonglong.factor create mode 100644 basis/specialized-arrays/direct/ushort/ushort.factor create mode 100644 basis/specialized-arrays/double/double.factor create mode 100644 basis/specialized-arrays/float/float.factor create mode 100644 basis/specialized-arrays/functor/functor.factor create mode 100644 basis/specialized-arrays/int/int.factor create mode 100644 basis/specialized-arrays/long/long.factor create mode 100644 basis/specialized-arrays/longlong/longlong.factor create mode 100644 basis/specialized-arrays/short/short.factor create mode 100644 basis/specialized-arrays/specialized-arrays-docs.factor create mode 100644 basis/specialized-arrays/specialized-arrays-tests.factor create mode 100644 basis/specialized-arrays/specialized-arrays.factor create mode 100644 basis/specialized-arrays/summary.txt rename basis/{float-arrays => specialized-arrays}/tags.txt (100%) create mode 100644 basis/specialized-arrays/uchar/uchar.factor create mode 100644 basis/specialized-arrays/uint/uint.factor create mode 100644 basis/specialized-arrays/ulong/ulong.factor create mode 100644 basis/specialized-arrays/ulonglong/ulonglong.factor create mode 100644 basis/specialized-arrays/ushort/ushort.factor create mode 100644 basis/specialized-vectors/alien/alien.factor create mode 100644 basis/specialized-vectors/authors.txt create mode 100644 basis/specialized-vectors/bool/bool.factor create mode 100644 basis/specialized-vectors/char/char.factor create mode 100644 basis/specialized-vectors/double/double.factor create mode 100644 basis/specialized-vectors/float/float.factor create mode 100644 basis/specialized-vectors/functor/functor.factor create mode 100644 basis/specialized-vectors/int/int.factor create mode 100644 basis/specialized-vectors/long/long.factor create mode 100644 basis/specialized-vectors/longlong/longlong.factor create mode 100644 basis/specialized-vectors/short/short.factor create mode 100644 basis/specialized-vectors/specialized-vectors-docs.factor create mode 100644 basis/specialized-vectors/specialized-vectors.factor create mode 100644 basis/specialized-vectors/summary.txt rename basis/{float-vectors => specialized-vectors}/tags.txt (100%) create mode 100644 basis/specialized-vectors/uchar/uchar.factor create mode 100644 basis/specialized-vectors/uint/uint.factor create mode 100644 basis/specialized-vectors/ulong/ulong.factor create mode 100644 basis/specialized-vectors/ulonglong/ulonglong.factor create mode 100644 basis/specialized-vectors/ushort/ushort.factor diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index 09a09cdc6f..c5efe1e030 100644 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -1,69 +1,7 @@ IN: alien.arrays USING: help.syntax help.markup byte-arrays alien.c-types ; -ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" -"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:" -{ $subsection >c-bool-array } -{ $subsection >c-char-array } -{ $subsection >c-double-array } -{ $subsection >c-float-array } -{ $subsection >c-int-array } -{ $subsection >c-long-array } -{ $subsection >c-longlong-array } -{ $subsection >c-short-array } -{ $subsection >c-uchar-array } -{ $subsection >c-uint-array } -{ $subsection >c-ulong-array } -{ $subsection >c-ulonglong-array } -{ $subsection >c-ushort-array } -{ $subsection >c-void*-array } -{ $subsection c-bool-array> } -{ $subsection c-char-array> } -{ $subsection c-double-array> } -{ $subsection c-float-array> } -{ $subsection c-int-array> } -{ $subsection c-long-array> } -{ $subsection c-longlong-array> } -{ $subsection c-short-array> } -{ $subsection c-uchar-array> } -{ $subsection c-uint-array> } -{ $subsection c-ulong-array> } -{ $subsection c-ulonglong-array> } -{ $subsection c-ushort-array> } -{ $subsection c-void*-array> } ; - -ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays" -"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:" -{ $subsection char-nth } -{ $subsection set-char-nth } -{ $subsection uchar-nth } -{ $subsection set-uchar-nth } -{ $subsection short-nth } -{ $subsection set-short-nth } -{ $subsection ushort-nth } -{ $subsection set-ushort-nth } -{ $subsection int-nth } -{ $subsection set-int-nth } -{ $subsection uint-nth } -{ $subsection set-uint-nth } -{ $subsection long-nth } -{ $subsection set-long-nth } -{ $subsection ulong-nth } -{ $subsection set-ulong-nth } -{ $subsection longlong-nth } -{ $subsection set-longlong-nth } -{ $subsection ulonglong-nth } -{ $subsection set-ulonglong-nth } -{ $subsection float-nth } -{ $subsection set-float-nth } -{ $subsection double-nth } -{ $subsection set-double-nth } -{ $subsection void*-nth } -{ $subsection set-void*-nth } ; - ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." $nl -"C type specifiers for array types are documented in " { $link "c-types-specs" } "." -{ $subsection "c-arrays-factor" } -{ $subsection "c-arrays-get/set" } ; +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ; diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index edda9e7fdb..13ea115089 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -54,5 +54,3 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } ] must-fail - -[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a93c87611d..a81296f24d 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -19,7 +19,7 @@ reg-class size align stack-align? ; : new-c-type ( class -- type ) new - int-regs >>reg-class ; + int-regs >>reg-class ; inline : ( -- type ) \ c-type new-c-type ; @@ -172,12 +172,12 @@ M: byte-array byte-length length ; : c-getter ( name -- quot ) c-type-getter [ - [ "Cannot read struct fields with type" throw ] + [ "Cannot read struct fields with this type" throw ] ] unless* ; : c-setter ( name -- quot ) c-type-setter [ - [ "Cannot write struct fields with type" throw ] + [ "Cannot write struct fields with this type" throw ] ] unless* ; : ( n type -- array ) @@ -201,28 +201,13 @@ M: byte-array byte-length length ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -: (define-nth) ( word type quot -- ) +: array-accessor ( type quot -- def ) [ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* - ] [ ] make define-inline ; - -: nth-word ( name vocab -- word ) - >r "-nth" append r> create ; - -: define-nth ( name vocab -- ) - dupd nth-word swap dup c-getter (define-nth) ; - -: set-nth-word ( name vocab -- word ) - >r "set-" swap "-nth" 3append r> create ; - -: define-set-nth ( name vocab -- ) - dupd set-nth-word swap dup c-setter (define-nth) ; + ] [ ] make ; : typedef ( old new -- ) c-types get set-at ; -: define-c-type ( type name vocab -- ) - >r tuck typedef r> [ define-nth ] 2keep define-set-nth ; - TUPLE: long-long-type < c-type ; : ( -- type ) @@ -240,62 +225,34 @@ M: long-long-type box-parameter ( n type -- ) M: long-long-type box-return ( type -- ) f swap box-parameter ; -: define-deref ( name vocab -- ) - >r dup CHAR: * prefix r> create - swap c-getter 0 prefix define-inline ; +: define-deref ( name -- ) + [ CHAR: * prefix "alien.c-types" create ] + [ c-getter 0 prefix ] bi + define-inline ; -: define-out ( name vocab -- ) - over [ tuck 0 ] over c-setter append swap - >r >r constructor-word r> r> prefix define-inline ; +: define-out ( name -- ) + [ "alien.c-types" constructor-word ] + [ [ [ ] curry ] [ c-setter ] bi append ] bi + define-inline ; : c-bool> ( int -- ? ) zero? not ; -: >c-array ( seq type word -- byte-array ) - [ [ dup length ] dip ] dip - [ [ execute ] 2curry each-index ] 2keep drop ; inline - -: >c-array-quot ( type vocab -- quot ) - dupd set-nth-word [ >c-array ] 2curry ; - -: to-array-word ( name vocab -- word ) - >r ">c-" swap "-array" 3append r> create ; - -: define-to-array ( type vocab -- ) - [ to-array-word ] 2keep >c-array-quot - (( array -- byte-array )) define-declared ; - -: c-array>quot ( type vocab -- quot ) - [ - \ swap , - nth-word 1quotation , - [ curry map ] % - ] [ ] make ; - -: from-array-word ( name vocab -- word ) - >r "c-" swap "-array>" 3append r> create ; - -: define-from-array ( type vocab -- ) - [ from-array-word ] 2keep c-array>quot - (( c-ptr n -- array )) define-declared ; - : define-primitive-type ( type name -- ) - "alien.c-types" - { - [ define-c-type ] - [ define-deref ] - [ define-to-array ] - [ define-from-array ] - [ define-out ] - } 2cleave ; + [ typedef ] + [ define-deref ] + [ define-out ] + tri ; : expand-constants ( c-type -- c-type' ) dup array? [ - unclip >r [ - dup word? [ - def>> { } swap with-datastack first - ] when - ] map r> prefix + unclip [ + [ + dup word? [ + def>> { } swap with-datastack first + ] when + ] map + ] dip prefix ] when ; : malloc-file-contents ( path -- alien len ) @@ -304,6 +261,17 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: primitive-types + { + "char" "uchar" + "short" "ushort" + "int" "uint" + "long" "ulong" + "longlong" "ulonglong" + "float" "double" + "void*" "bool" + } ; + [ [ alien-cell ] >>getter diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index ce30a2ee25..181ff98e62 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -34,10 +34,10 @@ M: struct-type stack-size : c-struct? ( type -- ? ) (c-type) struct-type? ; -: (define-struct) ( name vocab size align fields -- ) +: (define-struct) ( name size align fields -- ) >r [ align ] keep r> struct-type boa - -rot define-c-type ; + swap typedef ; : define-struct-early ( name vocab fields -- fields ) -rot [ rot first2 ] 2curry map ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index d03688b2be..3e7bd26965 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays kernel math namespaces make cocoa -cocoa.messages cocoa.classes cocoa.types sequences -continuations ; +USING: specialized-arrays.int arrays kernel math namespaces make +cocoa cocoa.messages cocoa.classes cocoa.types sequences +continuations accessors ; IN: cocoa.views : NSOpenGLPFAAllRenderers 1 ; @@ -69,7 +69,7 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] { } make >c-int-array + ] int-array{ } make underlying>> -> initWithAttributes: -> autorelease ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index d7e82402d5..114d3cdda2 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences stack-checker stack-checker.errors words arrays parser quotations continuations effects namespaces.private io io.streams.string -memory system threads tools.test math accessors combinators ; +memory system threads tools.test math accessors combinators +specialized-arrays.float ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -188,7 +189,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test +[ 32.0 ] [ + { 1.0 2.0 3.0 } >float-array underlying>> + { 4.0 5.0 6.0 } >float-array underlying>> + ffi_test_23 +] unit-test ! Test odd-size structs C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index a56ee55c82..2375e3da35 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io -combinators vectors float-arrays ; +combinators vectors ; IN: compiler.tests ! Originally, this file did black box testing of templating diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 156fdfff02..ee8c2f056a 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,5 +1,5 @@ USING: math.private kernel combinators accessors arrays -generalizations float-arrays tools.test ; +generalizations tools.test ; IN: compiler.tests : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 760ff167aa..865852e99f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -8,7 +8,7 @@ math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals -float-arrays system sorting ; +specialized-arrays.double system sorting ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -588,7 +588,7 @@ MIXIN: empty-mixin [ { fixnum integer } declare bitand ] final-classes ] unit-test -[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test +[ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 63284b28a3..0a12f4374a 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -5,7 +5,8 @@ quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 -alien.strings io.streams.byte-array summary present urls ; +alien.strings io.streams.byte-array summary present urls +specialized-arrays.uint specialized-arrays.alien ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -64,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - in-params>> [ type>> type>oid ] map >c-uint-array ; + in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ; : malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; @@ -90,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str ) ] 2map flip [ f f ] [ - first2 [ >c-void*-array ] [ >c-uint-array ] bi* + first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi* ] if-empty ; : param-formats ( statement -- seq ) - in-params>> [ type>> type>param-format ] map >c-uint-array ; + in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ; : do-postgresql-bound-statement ( statement -- res ) [ diff --git a/basis/float-arrays/float-arrays-docs.factor b/basis/float-arrays/float-arrays-docs.factor deleted file mode 100644 index 6c775dbd78..0000000000 --- a/basis/float-arrays/float-arrays-docs.factor +++ /dev/null @@ -1,62 +0,0 @@ -USING: arrays bit-arrays vectors strings sbufs -kernel help.markup help.syntax math ; -IN: float-arrays - -ARTICLE: "float-arrays" "Float arrays" -"Float arrays are fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are instances of " { $link float } ". Elements are unboxed, hence the memory usage is lower than an equivalent " { $link array } " of floats." -$nl -"Float array words are in the " { $vocab-link "float-arrays" } " vocabulary." -$nl -"Float arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "." -$nl -"Float arrays form a class of objects." -{ $subsection float-array } -{ $subsection float-array? } -"There are several ways to construct float arrays." -{ $subsection >float-array } -{ $subsection } -"Creating a float array from several elements on the stack:" -{ $subsection 1float-array } -{ $subsection 2float-array } -{ $subsection 3float-array } -{ $subsection 4float-array } -"Float array literal syntax:" -{ $subsection POSTPONE: F{ } ; - -ABOUT: "float-arrays" - -HELP: F{ -{ $syntax "F{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float array. Literal float arrays are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "F{ 1.0 2.0 3.0 }" } } ; - -HELP: float-array -{ $description "The class of float arrays." } ; - -HELP: ( n -- float-array ) -{ $values { "n" "a non-negative integer" } { "float-array" "a new float array" } } -{ $description "Creates a new float array holding " { $snippet "n" } " floats with all elements initially set to " { $snippet "0.0" } "." } ; - -HELP: >float-array -{ $values { "seq" "a sequence" } { "float-array" float-array } } -{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; - -HELP: 1float-array -{ $values { "x" object } { "array" float-array } } -{ $description "Create a new float array with one element." } ; - -{ 1array 2array 3array 4array } related-words - -HELP: 2float-array -{ $values { "x" object } { "y" object } { "array" float-array } } -{ $description "Create a new float array with two elements, with " { $snippet "x" } " appearing first." } ; - -HELP: 3float-array -{ $values { "x" object } { "y" object } { "z" object } { "array" float-array } } -{ $description "Create a new float array with three elements, with " { $snippet "x" } " appearing first." } ; - -HELP: 4float-array -{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" float-array } } -{ $description "Create a new float array with four elements, with " { $snippet "w" } " appearing first." } ; diff --git a/basis/float-arrays/float-arrays-tests.factor b/basis/float-arrays/float-arrays-tests.factor deleted file mode 100644 index 64070b99b7..0000000000 --- a/basis/float-arrays/float-arrays-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -IN: float-arrays.tests -USING: float-arrays tools.test sequences.private ; - -[ F{ 0.0 0.0 0.0 } ] [ 3 ] unit-test - -[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize ] unit-test - -[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize ] unit-test - -[ -10 F{ } resize ] must-fail - -[ F{ 1.3 } ] [ 1.3 1float-array ] unit-test diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor deleted file mode 100644 index ab3eef62a5..0000000000 --- a/basis/float-arrays/float-arrays.factor +++ /dev/null @@ -1,123 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien.accessors sequences -sequences.private math math.private byte-arrays accessors -alien.c-types parser prettyprint.backend ; -IN: float-arrays - -TUPLE: float-array -{ length array-capacity read-only } -{ underlying byte-array read-only } ; - -: ( n -- float-array ) - dup "double" float-array boa ; inline - -M: float-array clone - [ length>> ] [ underlying>> clone ] bi float-array boa ; - -M: float-array length length>> ; - -M: float-array nth-unsafe - underlying>> double-nth ; - -M: float-array set-nth-unsafe - [ >float ] 2dip underlying>> set-double-nth ; - -: >float-array ( seq -- float-array ) - T{ float-array } clone-like ; inline - -M: float-array like - drop dup float-array? [ >float-array ] unless ; - -M: float-array new-sequence - drop ; - -M: float-array equal? - over float-array? [ sequence= ] [ 2drop f ] if ; - -M: float-array resize - [ drop ] [ - [ "double" heap-size * ] [ underlying>> ] bi* - resize-byte-array - ] 2bi - float-array boa ; - -M: float-array byte-length length "double" heap-size * ; - -INSTANCE: float-array sequence - -: 1float-array ( x -- array ) - 1 [ set-first ] keep ; inline - -: 2float-array ( x y -- array ) - T{ float-array } 2sequence ; inline - -: 3float-array ( x y z -- array ) - T{ float-array } 3sequence ; inline - -: 4float-array ( w x y z -- array ) - T{ float-array } 4sequence ; inline - -: F{ \ } [ >float-array ] parse-literal ; parsing - -M: float-array pprint-delims drop \ F{ \ } ; -M: float-array >pprint-sequence ; -M: float-array pprint* pprint-object ; - -! Rice -USING: hints math.vectors arrays ; - -HINTS: vneg { float-array } { array } ; -HINTS: v*n { float-array float } { array object } ; -HINTS: n*v { float float-array } { array object } ; -HINTS: v/n { float-array float } { array object } ; -HINTS: n/v { float float-array } { object array } ; -HINTS: v+ { float-array float-array } { array array } ; -HINTS: v- { float-array float-array } { array array } ; -HINTS: v* { float-array float-array } { array array } ; -HINTS: v/ { float-array float-array } { array array } ; -HINTS: vmax { float-array float-array } { array array } ; -HINTS: vmin { float-array float-array } { array array } ; -HINTS: v. { float-array float-array } { array array } ; -HINTS: norm-sq { float-array } { array } ; -HINTS: norm { float-array } { array } ; -HINTS: normalize { float-array } { array } ; - -! More rice. Experimental, currently causes a slowdown in raytracer -! for some odd reason. - -USING: words classes.algebra compiler.tree.propagation.info ; - -{ v+ v- v* v/ vmax vmin } [ - [ - [ class>> float-array class<= ] both? - float-array object ? - ] "outputs" set-word-prop -] each - -{ n*v n/v } [ - [ - nip class>> float-array class<= float-array object ? - ] "outputs" set-word-prop -] each - -{ v*n v/n } [ - [ - drop class>> float-array class<= float-array object ? - ] "outputs" set-word-prop -] each - -{ vneg normalize } [ - [ - class>> float-array class<= float-array object ? - ] "outputs" set-word-prop -] each - -\ norm-sq [ - class>> float-array class<= float object ? -] "outputs" set-word-prop - -\ v. [ - [ class>> float-array class<= ] both? - float object ? -] "outputs" set-word-prop diff --git a/basis/float-arrays/summary.txt b/basis/float-arrays/summary.txt deleted file mode 100644 index 0eac3b0b1a..0000000000 --- a/basis/float-arrays/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Efficient fixed-length floating point number arrays diff --git a/basis/float-vectors/float-vectors-docs.factor b/basis/float-vectors/float-vectors-docs.factor deleted file mode 100644 index 714c8512c1..0000000000 --- a/basis/float-vectors/float-vectors-docs.factor +++ /dev/null @@ -1,37 +0,0 @@ -USING: arrays float-arrays help.markup help.syntax kernel -combinators ; -IN: float-vectors - -ARTICLE: "float-vectors" "Float vectors" -"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." -$nl -"Float vectors form a class:" -{ $subsection float-vector } -{ $subsection float-vector? } -"Creating float vectors:" -{ $subsection >float-vector } -{ $subsection } -"Literal syntax:" -{ $subsection POSTPONE: FV{ } -"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" -{ $code "FV{ } clone" } ; - -ABOUT: "float-vectors" - -HELP: float-vector -{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ; - -HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } -{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ; - -HELP: >float-vector -{ $values { "seq" "a sequence" } { "float-vector" float-vector } } -{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; - -HELP: FV{ -{ $syntax "FV{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; diff --git a/basis/float-vectors/float-vectors-tests.factor b/basis/float-vectors/float-vectors-tests.factor deleted file mode 100644 index 1483b269e0..0000000000 --- a/basis/float-vectors/float-vectors-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: tools.test float-vectors vectors sequences kernel math ; -IN: float-vectors.tests - -[ 0 ] [ 123 length ] unit-test - -: do-it - 12345 [ >float over push ] each ; - -[ t ] [ - 3 do-it - 3 do-it sequence= -] unit-test - -[ t ] [ FV{ } float-vector? ] unit-test diff --git a/basis/float-vectors/float-vectors.factor b/basis/float-vectors/float-vectors.factor deleted file mode 100644 index 8e93582f04..0000000000 --- a/basis/float-vectors/float-vectors.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math sequences -sequences.private growable float-arrays prettyprint.backend -parser accessors ; -IN: float-vectors - -TUPLE: float-vector -{ underlying float-array initial: F{ } } -{ length array-capacity } ; - -: ( n -- float-vector ) - 0 float-vector boa ; inline - -: >float-vector ( seq -- float-vector ) - T{ float-vector f F{ } 0 } clone-like ; - -M: float-vector like - drop dup float-vector? [ - dup float-array? - [ dup length float-vector boa ] [ >float-vector ] if - ] unless ; - -M: float-vector new-sequence - drop [ ] [ >fixnum ] bi float-vector boa ; - -M: float-vector equal? - over float-vector? [ sequence= ] [ 2drop f ] if ; - -M: float-array new-resizable drop ; - -INSTANCE: float-vector growable - -: FV{ \ } [ >float-vector ] parse-literal ; parsing - -M: float-vector >pprint-sequence ; -M: float-vector pprint-delims drop \ FV{ \ } ; -M: float-vector pprint* pprint-object ; diff --git a/basis/float-vectors/summary.txt b/basis/float-vectors/summary.txt deleted file mode 100644 index c476f41a6e..0000000000 --- a/basis/float-vectors/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Growable float arrays diff --git a/basis/float-arrays/authors.txt b/basis/functors/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/float-arrays/authors.txt rename to basis/functors/authors.txt diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor new file mode 100644 index 0000000000..39923afee7 --- /dev/null +++ b/basis/functors/functors-tests.factor @@ -0,0 +1,47 @@ +IN: functors.tests +USING: functors tools.test math words kernel ; + +<< + +FUNCTOR: define-box ( T -- ) + +B DEFINES ${T}-box + DEFINES <${B}> + +WHERE + +TUPLE: B { value T } ; + +C: B + +;FUNCTOR + +\ float define-box + +>> + +{ 1 0 } [ define-box ] must-infer-as + +[ T{ float-box f 5.0 } ] [ 5.0 ] unit-test + +: twice ( word -- ) + [ execute ] [ execute ] bi ; inline +<< + +FUNCTOR: wrapper-test ( W -- ) + +WW DEFINES ${W}${W} + +WHERE + +: WW W twice ; inline + +;FUNCTOR + +\ sq wrapper-test + +>> + +\ sqsq must-infer + +[ 16 ] [ 2 sqsq ] unit-test diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor new file mode 100644 index 0000000000..16f6f073f5 --- /dev/null +++ b/basis/functors/functors.factor @@ -0,0 +1,98 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel locals.private quotations classes.tuple +classes.tuple.parser make lexer combinators generic words +interpolate namespaces sequences io.streams.string fry +classes.mixin ; +IN: functors + +: scan-param ( -- obj ) + scan-object dup special? [ literalize ] unless ; + +: define* ( word def -- ) over set-word define ; + +: `TUPLE: + scan-param parsed + scan { + { ";" [ tuple parsed f parsed ] } + { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] } + [ + [ tuple parsed ] dip + [ parse-slot-name [ parse-tuple-slots ] when ] { } + make parsed + ] + } case + \ define-tuple-class parsed ; parsing + +: `M: + scan-param parsed + scan-param parsed + \ create-method parsed + parse-definition parsed + \ define* parsed ; parsing + +: `C: + scan-param parsed + scan-param parsed + [ [ boa ] curry define* ] over push-all ; parsing + +: `: + scan-param parsed + parse-definition parsed + \ define* parsed ; parsing + +: `INSTANCE: + scan-param parsed + scan-param parsed + \ add-mixin-instance parsed ; parsing + +: `inline \ inline parsed ; parsing + +: `parsing \ parsing parsed ; parsing + +: (INTERPOLATE) ( accum quot -- accum ) + [ scan interpolate-locals ] dip + '[ _ with-string-writer @ ] parsed ; + +: IS [ search ] (INTERPOLATE) ; parsing + +: DEFINES [ in get create ] (INTERPOLATE) ; parsing + +DEFER: ;FUNCTOR delimiter + +: functor-words ( -- assoc ) + H{ + { "TUPLE:" POSTPONE: `TUPLE: } + { "M:" POSTPONE: `M: } + { "C:" POSTPONE: `C: } + { ":" POSTPONE: `: } + { "INSTANCE:" POSTPONE: `INSTANCE: } + { "inline" POSTPONE: `inline } + { "parsing" POSTPONE: `parsing } + } ; + +: push-functor-words ( -- ) + functor-words use get push ; + +: pop-functor-words ( -- ) + functor-words use get delq ; + +: parse-functor-body ( -- form ) + t in-lambda? [ + V{ } clone + push-functor-words + "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda) + parsed-lambda + pop-functor-words + >quotation + ] with-variable ; + +: (FUNCTOR:) ( -- word def ) + CREATE + parse-locals + parse-functor-body swap pop-locals + lambda-rewrite first ; + +: FUNCTOR: (FUNCTOR:) define ; parsing + +: APPLY: scan-word scan-word execute swap '[ _ execute ] each ; parsing diff --git a/basis/functors/summary.txt b/basis/functors/summary.txt new file mode 100644 index 0000000000..d95b366bc1 --- /dev/null +++ b/basis/functors/summary.txt @@ -0,0 +1 @@ +First-class syntax diff --git a/basis/functors/tags.txt b/basis/functors/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/functors/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor new file mode 100644 index 0000000000..b60a1c0bf2 --- /dev/null +++ b/basis/io/mmap/functor/functor.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors accessors alien.c-types math kernel words ; +IN: io.mmap.functor + +SLOT: address +SLOT: length + +: mapped-file>direct ( mapped-file type -- alien length ) + [ [ address>> ] [ length>> ] bi ] dip + heap-size [ 1- + ] keep /i ; + +FUNCTOR: mapped-array-functor ( T -- ) + +C DEFINES + IS + +WHERE + +: C mapped-file>direct execute ; inline + +;FUNCTOR diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 01e7054ef1..aea6d80636 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations destructors io.backend kernel quotations sequences system alien alien.accessors accessors -sequences.private system vocabs.loader combinators ; +sequences.private system vocabs.loader combinators +specialized-arrays.direct functors alien.c-types +io.mmap.functor ; IN: io.mmap TUPLE: mapped-file address handle length disposed ; @@ -30,6 +32,8 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path length quot -- ) >r r> with-disposal ; inline +APPLY: mapped-array-functor primitive-types + { { [ os unix? ] [ "io.unix.mmap" require ] } { [ os winnt? ] [ "io.windows.mmap" require ] } diff --git a/basis/io/unix/pipes/pipes.factor b/basis/io/unix/pipes/pipes.factor index 53c336c555..5a1f2849d4 100644 --- a/basis/io/unix/pipes/pipes.factor +++ b/basis/io/unix/pipes/pipes.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system alien.c-types kernel unix math sequences -qualified io.unix.backend io.ports ; +USING: system kernel unix math sequences qualified +io.unix.backend io.ports specialized-arrays.int ; IN: io.unix.pipes QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) - 2 "int" - dup pipe io-error - 2 c-int-array> first2 [ init-fd ] bi@ io.pipes:pipe boa ; + 2 + dup underlying>> pipe io-error + first2 [ init-fd ] bi@ io.pipes:pipe boa ; diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index d1ad309dd5..fc8e4a7bc0 100644 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -6,7 +6,8 @@ windows.types math windows.kernel32 namespaces make io.launcher kernel sequences windows.errors splitting system threads init strings combinators io.backend accessors concurrency.flags io.files assocs -io.files.private windows destructors ; +io.files.private windows destructors specialized-arrays.ushort +specialized-arrays.alien ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -103,7 +104,7 @@ TUPLE: CreateProcess-args over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] "" make >c-ushort-array + ] ushort-array{ } make underlying>> >>lpEnvironment ] when ; @@ -157,8 +158,8 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup - [ handle>> PROCESS_INFORMATION-hProcess ] map - dup length swap >c-void*-array 0 0 + [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as + [ length ] [ underlying>> ] bi 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor index 2680b40089..3db726e06a 100644 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -50,7 +50,7 @@ TUPLE: win32-monitor < monitor port ; } case 1array ; : memory>u16-string ( alien len -- string ) - [ memory>byte-array ] keep 2/ c-ushort-array> >string ; + memory>byte-array utf16n decode ; : parse-notify-record ( buffer -- path changed ) [ diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 003ef459e3..4bb4b9e052 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -346,7 +346,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as - :: literal-identity-test ( -- a b ) { } V{ } ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index e74ecf3dc9..e06f714b56 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -274,29 +274,26 @@ SYMBOL: in-lambda? "|" parse-tokens make-locals dup push-locals \ ] (parse-lambda) ; -: parse-binding ( -- pair/f ) - scan dup "|" = [ +: parse-binding ( end -- pair/f ) + scan tuck = [ drop f ] [ - scan { - { "[" [ \ ] parse-until >quotation ] } - { "[|" [ parse-lambda ] } - } case 2array + scan-object 2array ] if ; -: (parse-bindings) ( -- ) - parse-binding [ +: (parse-bindings) ( end -- ) + dup parse-binding dup [ first2 >r make-local r> 2array , (parse-bindings) - ] when* ; + ] [ 2drop ] if ; -: parse-bindings ( -- bindings vars ) +: parse-bindings ( end -- bindings vars ) [ [ (parse-bindings) ] H{ } make-assoc dup push-locals ] { } make swap ; -: parse-bindings* ( -- words assoc ) +: parse-bindings* ( end -- words assoc ) [ [ namespace push-locals @@ -305,13 +302,13 @@ SYMBOL: in-lambda? ] { } make-assoc ] { } make swap ; -: (parse-wbindings) ( -- ) - parse-binding [ +: (parse-wbindings) ( end -- ) + dup parse-binding dup [ first2 >r make-local-word r> 2array , (parse-wbindings) - ] when* ; + ] [ 2drop ] if ; -: parse-wbindings ( -- bindings vars ) +: parse-wbindings ( end -- bindings vars ) [ [ (parse-wbindings) ] H{ } make-assoc dup push-locals @@ -334,12 +331,12 @@ M: wlet local-rewrite* let-rewrite ; : parse-locals ( -- vars assoc ) - ")" parse-effect + scan "(" assert= ")" parse-effect word [ over "declared-effect" set-word-prop ] when* in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; : parse-locals-definition ( word -- word quot ) - scan "(" assert= parse-locals \ ; (parse-lambda) + parse-locals \ ; (parse-lambda) 2dup "lambda" set-word-prop lambda-rewrite first ; @@ -357,15 +354,15 @@ PRIVATE> : [| parse-lambda parsed-lambda ; parsing : [let - scan "|" assert= parse-bindings + scan "|" assert= "|" parse-bindings \ ] (parse-lambda) parsed-lambda ; parsing : [let* - scan "|" assert= parse-bindings* + scan "|" assert= "|" parse-bindings* \ ] (parse-lambda) parsed-lambda ; parsing : [wlet - scan "|" assert= parse-wbindings + scan "|" assert= "|" parse-wbindings \ ] (parse-lambda) parsed-lambda ; parsing : :: (::) define ; parsing diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 64326f340e..300e4f0a71 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -6,7 +6,8 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences splitting words byte-arrays assocs colors accessors -generalizations locals memoize ; +generalizations locals specialized-arrays.float +specialized-arrays.uint ; IN: opengl : color>raw ( object -- r g b a ) @@ -52,7 +53,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - >c-float-array glMaterialfv ; + >float-array underlying>> glMaterialfv ; : gl-vertex-pointer ( seq -- ) [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline @@ -64,7 +65,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) - append >c-float-array gl-vertex-pointer ; + append >float-array underlying>> gl-vertex-pointer ; : gl-line ( a b -- ) line-vertices GL_LINES 0 2 glDrawArrays ; @@ -75,7 +76,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ first 1- 1 ] [ [ first 1- ] [ second ] bi ] [ second 0 swap ] - } cleave 8 narray >c-float-array ; + } cleave 8 float-array{ } nsequence underlying>> ; : rect-vertices ( dim -- ) (rect-vertices) gl-vertex-pointer ; @@ -92,7 +93,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ first 0 ] [ first2 ] [ second 0 swap ] - } cleave 8 narray >c-float-array ; + } cleave 8 float-array{ } nsequence underlying>> ; : fill-rect-vertices ( dim -- ) (fill-rect-vertices) gl-vertex-pointer ; @@ -119,7 +120,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) circle-steps unit-circle adjust-points scale-points ; : circle-vertices ( loc dim steps -- vertices ) - circle-points concat >c-float-array ; + circle-points concat >float-array underlying>> ; : (gen-gl-object) ( quot -- id ) >r 1 0 r> keep *uint ; inline @@ -160,7 +161,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glActiveTexture swap glBindTexture gl-error ; : (set-draw-buffers) ( buffers -- ) - dup length swap >c-uint-array glDrawBuffers ; + [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) words>values [ (set-draw-buffers) ] curry ; @@ -203,11 +204,8 @@ TUPLE: sprite loc dim dim2 dlist texture ; : gl-translate ( point -- ) first2 0.0 glTranslated ; -MEMO: (rect-texture-coords) ( -- seq ) - { 0 0 1 0 1 1 0 1 } >c-float-array ; - : rect-texture-coords ( -- ) - (rect-texture-coords) gl-texture-coord-pointer ; + float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ; : draw-sprite ( sprite -- ) GL_TEXTURE_COORD_ARRAY [ diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 3a75ad65b6..c02fbe2b0b 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: tools.test kernel serialize io io.streams.byte-array math -alien arrays byte-arrays bit-arrays float-arrays sequences math -prettyprint parser classes math.constants io.encodings.binary -random assocs ; +alien arrays byte-arrays bit-arrays specialized-arrays.double +sequences math prettyprint parser classes math.constants +io.encodings.binary random assocs ; IN: serialize.tests : test-serialize-cell @@ -48,7 +48,7 @@ C: serialize-test T{ serialize-test f "a" 2 } B{ 50 13 55 64 1 } ?{ t f t f f t f } - F{ 1.0 3.0 4.0 1.0 2.35 0.33 } + double-array{ 1.0 3.0 4.0 1.0 2.35 0.33 } << 1 [ 2 ] curry parsed >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } diff --git a/basis/specialized-arrays/alien/alien.factor b/basis/specialized-arrays/alien/alien.factor new file mode 100644 index 0000000000..465d1665f9 --- /dev/null +++ b/basis/specialized-arrays/alien/alien.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.alien + +<< "void*" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/authors.txt b/basis/specialized-arrays/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/specialized-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/specialized-arrays/bool/bool.factor b/basis/specialized-arrays/bool/bool.factor new file mode 100644 index 0000000000..759ee91abc --- /dev/null +++ b/basis/specialized-arrays/bool/bool.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.bool + +<< "bool" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/char/char.factor b/basis/specialized-arrays/char/char.factor new file mode 100644 index 0000000000..cdf78eeef8 --- /dev/null +++ b/basis/specialized-arrays/char/char.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.char + +<< "char" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/alien/alien.factor b/basis/specialized-arrays/direct/alien/alien.factor new file mode 100644 index 0000000000..b1dee2e1d1 --- /dev/null +++ b/basis/specialized-arrays/direct/alien/alien.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.alien + +<< "void*" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/bool/bool.factor b/basis/specialized-arrays/direct/bool/bool.factor new file mode 100644 index 0000000000..139723d39a --- /dev/null +++ b/basis/specialized-arrays/direct/bool/bool.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.bool + +<< "bool" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/char/char.factor b/basis/specialized-arrays/direct/char/char.factor new file mode 100644 index 0000000000..cf4e3617ed --- /dev/null +++ b/basis/specialized-arrays/direct/char/char.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.char + +<< "char" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/direct.factor b/basis/specialized-arrays/direct/direct.factor new file mode 100644 index 0000000000..7c15c66415 --- /dev/null +++ b/basis/specialized-arrays/direct/direct.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: specialized-arrays.direct diff --git a/basis/specialized-arrays/direct/double/double.factor b/basis/specialized-arrays/direct/double/double.factor new file mode 100644 index 0000000000..423ceba688 --- /dev/null +++ b/basis/specialized-arrays/direct/double/double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.double + +<< "double" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/float/float.factor b/basis/specialized-arrays/direct/float/float.factor new file mode 100644 index 0000000000..91a117ada5 --- /dev/null +++ b/basis/specialized-arrays/direct/float/float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.float + +<< "float" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor new file mode 100644 index 0000000000..dd5164b8b4 --- /dev/null +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private kernel words classes +math alien alien.c-types byte-arrays accessors +specialized-arrays ; +IN: specialized-arrays.direct.functor + +FUNCTOR: define-direct-array ( T -- ) + +A' IS ${T}-array +>A' IS >${T}-array + IS <${A'}> + +A DEFINES direct-${T}-array + DEFINES <${A}> + +NTH [ T dup c-getter array-accessor ] +SET-NTH [ T dup c-setter array-accessor ] + +WHERE + +TUPLE: A +{ underlying alien read-only } +{ length fixnum read-only } ; + +: A boa ; inline +M: A length length>> ; +M: A nth-unsafe underlying>> NTH call ; +M: A set-nth-unsafe underlying>> SET-NTH call ; +M: A like drop dup A instance? [ >A' execute ] unless ; +M: A new-sequence drop execute ; + +INSTANCE: A sequence + +;FUNCTOR diff --git a/basis/specialized-arrays/direct/int/int.factor b/basis/specialized-arrays/direct/int/int.factor new file mode 100644 index 0000000000..33410a7ad8 --- /dev/null +++ b/basis/specialized-arrays/direct/int/int.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.int + +<< "int" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/long/long.factor b/basis/specialized-arrays/direct/long/long.factor new file mode 100644 index 0000000000..ee2ed7188a --- /dev/null +++ b/basis/specialized-arrays/direct/long/long.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.long + +<< "long" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/longlong/longlong.factor b/basis/specialized-arrays/direct/longlong/longlong.factor new file mode 100644 index 0000000000..12306ff884 --- /dev/null +++ b/basis/specialized-arrays/direct/longlong/longlong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.longlong + +<< "longlong" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/short/short.factor b/basis/specialized-arrays/direct/short/short.factor new file mode 100644 index 0000000000..375696ccda --- /dev/null +++ b/basis/specialized-arrays/direct/short/short.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.short + +<< "short" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/uchar/uchar.factor b/basis/specialized-arrays/direct/uchar/uchar.factor new file mode 100644 index 0000000000..d0a8f0ddd1 --- /dev/null +++ b/basis/specialized-arrays/direct/uchar/uchar.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.uchar + +<< "uchar" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/uint/uint.factor b/basis/specialized-arrays/direct/uint/uint.factor new file mode 100644 index 0000000000..18b3b630bb --- /dev/null +++ b/basis/specialized-arrays/direct/uint/uint.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.uint + +<< "uint" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/ulong/ulong.factor b/basis/specialized-arrays/direct/ulong/ulong.factor new file mode 100644 index 0000000000..89e6f29e74 --- /dev/null +++ b/basis/specialized-arrays/direct/ulong/ulong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.ulong + +<< "ulong" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/ulonglong/ulonglong.factor b/basis/specialized-arrays/direct/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..8cb6af20e5 --- /dev/null +++ b/basis/specialized-arrays/direct/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.ulonglong + +<< "ulonglong" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/ushort/ushort.factor b/basis/specialized-arrays/direct/ushort/ushort.factor new file mode 100644 index 0000000000..09f66b989d --- /dev/null +++ b/basis/specialized-arrays/direct/ushort/ushort.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.direct.functor +IN: specialized-arrays.direct.ushort + +<< "ushort" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor new file mode 100644 index 0000000000..b7fc3a8143 --- /dev/null +++ b/basis/specialized-arrays/double/double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.double + +<< "double" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/float/float.factor b/basis/specialized-arrays/float/float.factor new file mode 100644 index 0000000000..5d9da66739 --- /dev/null +++ b/basis/specialized-arrays/float/float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.float + +<< "float" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor new file mode 100644 index 0000000000..8536e6f81a --- /dev/null +++ b/basis/specialized-arrays/functor/functor.factor @@ -0,0 +1,61 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private +prettyprint.backend kernel words classes math parser +alien.c-types byte-arrays accessors ; +IN: specialized-arrays.functor + +FUNCTOR: define-array ( T -- ) + +A DEFINES ${T}-array + DEFINES <${A}> +>A DEFINES >${A} +A{ DEFINES ${A}{ + +NTH [ T dup c-getter array-accessor ] +SET-NTH [ T dup c-setter array-accessor ] + +WHERE + +TUPLE: A +{ length array-capacity read-only } +{ underlying byte-array read-only } ; + +: dup T A boa ; inline + +M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; + +M: A length length>> ; + +M: A nth-unsafe underlying>> NTH call ; + +M: A set-nth-unsafe underlying>> SET-NTH call ; + +: >A A new clone-like ; inline + +M: A like drop dup A instance? [ >A execute ] unless ; + +M: A new-sequence drop execute ; + +M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; + +M: A resize + [ drop ] [ + [ T heap-size * ] [ underlying>> ] bi* + resize-byte-array + ] 2bi + A boa ; + +M: A byte-length underlying>> length ; + +M: A pprint-delims drop A{ \ } ; + +M: A >pprint-sequence ; + +M: A pprint* pprint-object ; + +: A{ \ } [ >A execute ] parse-literal ; parsing + +INSTANCE: A sequence + +;FUNCTOR diff --git a/basis/specialized-arrays/int/int.factor b/basis/specialized-arrays/int/int.factor new file mode 100644 index 0000000000..37f4b59c80 --- /dev/null +++ b/basis/specialized-arrays/int/int.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.int + +<< "int" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/long/long.factor b/basis/specialized-arrays/long/long.factor new file mode 100644 index 0000000000..2cba6424eb --- /dev/null +++ b/basis/specialized-arrays/long/long.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.long + +<< "long" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/longlong/longlong.factor b/basis/specialized-arrays/longlong/longlong.factor new file mode 100644 index 0000000000..195dd78f7b --- /dev/null +++ b/basis/specialized-arrays/longlong/longlong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.longlong + +<< "longlong" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/short/short.factor b/basis/specialized-arrays/short/short.factor new file mode 100644 index 0000000000..3891462159 --- /dev/null +++ b/basis/specialized-arrays/short/short.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.short + +<< "short" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor new file mode 100644 index 0000000000..54cb5d1cf5 --- /dev/null +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -0,0 +1,37 @@ +USING: help.markup help.syntax byte-arrays ; +IN: specialized-arrays + +ARTICLE: "specialized-arrays" "Specialized arrays" +"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing." +$nl +"For each primitive C type " { $snippet "T" } ", a set of words are defined:" +{ $table + { { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } } + { { $snippet "" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } } + { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } } + { { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } } +} +"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. This data can be passed to C functions." +$nl +"The primitive C types for which specialized arrays exist:" +{ $list + { $snippet "char" } + { $snippet "uchar" } + { $snippet "short" } + { $snippet "ushort" } + { $snippet "int" } + { $snippet "uint" } + { $snippet "long" } + { $snippet "ulong" } + { $snippet "longlong" } + { $snippet "ulonglong" } + { $snippet "float" } + { $snippet "double" } + { $snippet "void*" } + { $snippet "bool" } +} +"Specialized arrays are generated with a functor in the " { $vocab-link "specialized-arrays.functor" } " vocabulary." +$nl +"The " { $vocab-link "specialized-vectors" } " vocabulary provides resizable versions of the above." ; + +ABOUT: "specialized-arrays" diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor new file mode 100644 index 0000000000..5810085d47 --- /dev/null +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -0,0 +1,11 @@ +IN: specialized-arrays.tests +USING: tools.test specialized-arrays sequences +specialized-arrays.int speicalized-arrays.bool ; + +[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test + +[ t ] [ int-array{ 1 2 3 } int-array? ] unit-test + +[ 2 ] [ int-array{ 1 2 3 } second ] unit-test + +[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor new file mode 100644 index 0000000000..631d28ddd9 --- /dev/null +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: specialized-arrays diff --git a/basis/specialized-arrays/summary.txt b/basis/specialized-arrays/summary.txt new file mode 100644 index 0000000000..6191766134 --- /dev/null +++ b/basis/specialized-arrays/summary.txt @@ -0,0 +1 @@ +Arrays of unboxed primitive C types diff --git a/basis/float-arrays/tags.txt b/basis/specialized-arrays/tags.txt similarity index 100% rename from basis/float-arrays/tags.txt rename to basis/specialized-arrays/tags.txt diff --git a/basis/specialized-arrays/uchar/uchar.factor b/basis/specialized-arrays/uchar/uchar.factor new file mode 100644 index 0000000000..c6ed4f3ab6 --- /dev/null +++ b/basis/specialized-arrays/uchar/uchar.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.uchar + +<< "uchar" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/uint/uint.factor b/basis/specialized-arrays/uint/uint.factor new file mode 100644 index 0000000000..1534a3d158 --- /dev/null +++ b/basis/specialized-arrays/uint/uint.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.uint + +<< "uint" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/ulong/ulong.factor b/basis/specialized-arrays/ulong/ulong.factor new file mode 100644 index 0000000000..27dc1295b3 --- /dev/null +++ b/basis/specialized-arrays/ulong/ulong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ulong + +<< "ulong" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/ulonglong/ulonglong.factor b/basis/specialized-arrays/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..cbb2b3cf9d --- /dev/null +++ b/basis/specialized-arrays/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ulonglong + +<< "ulonglong" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/ushort/ushort.factor b/basis/specialized-arrays/ushort/ushort.factor new file mode 100644 index 0000000000..e0989aa9d4 --- /dev/null +++ b/basis/specialized-arrays/ushort/ushort.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ushort + +<< "ushort" define-array >> \ No newline at end of file diff --git a/basis/specialized-vectors/alien/alien.factor b/basis/specialized-vectors/alien/alien.factor new file mode 100644 index 0000000000..e86f9f670f --- /dev/null +++ b/basis/specialized-vectors/alien/alien.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.alien + +<< "void*" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/authors.txt b/basis/specialized-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/specialized-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/specialized-vectors/bool/bool.factor b/basis/specialized-vectors/bool/bool.factor new file mode 100644 index 0000000000..3270c1d987 --- /dev/null +++ b/basis/specialized-vectors/bool/bool.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.bool + +<< "bool" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/char/char.factor b/basis/specialized-vectors/char/char.factor new file mode 100644 index 0000000000..2f0e2f0f3f --- /dev/null +++ b/basis/specialized-vectors/char/char.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.char + +<< "char" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/double/double.factor b/basis/specialized-vectors/double/double.factor new file mode 100644 index 0000000000..b2ca65b4be --- /dev/null +++ b/basis/specialized-vectors/double/double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.double + +<< "double" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/float/float.factor b/basis/specialized-vectors/float/float.factor new file mode 100644 index 0000000000..aab6b7c048 --- /dev/null +++ b/basis/specialized-vectors/float/float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.float + +<< "float" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor new file mode 100644 index 0000000000..cf82f0dc30 --- /dev/null +++ b/basis/specialized-vectors/functor/functor.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private growable +prettyprint.backend kernel words classes math parser ; +IN: specialized-vectors.functor + +FUNCTOR: define-vector ( T -- ) + +A IS ${T}-array + IS + +V DEFINES ${T}-vector + DEFINES <${V}> +>V DEFINES >${V} +V{ DEFINES ${V}{ + +WHERE + +TUPLE: V { underlying A } { length array-capacity } ; + +: execute 0 V boa ; inline + +M: V like + drop dup V instance? [ + dup A instance? [ dup length V boa ] [ >V execute ] if + ] unless ; + +M: V new-sequence drop [ execute ] [ >fixnum ] bi V boa ; + +M: A new-resizable drop execute ; + +M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; + +: >V V new clone-like ; inline + +M: V pprint-delims drop V{ \ } ; + +M: V >pprint-sequence ; + +M: V pprint* pprint-object ; + +: V{ [ >V execute ] parse-literal ; parsing + +INSTANCE: V growable + +;FUNCTOR diff --git a/basis/specialized-vectors/int/int.factor b/basis/specialized-vectors/int/int.factor new file mode 100644 index 0000000000..b02ec25073 --- /dev/null +++ b/basis/specialized-vectors/int/int.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.int + +<< "int" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/long/long.factor b/basis/specialized-vectors/long/long.factor new file mode 100644 index 0000000000..0f80bc3890 --- /dev/null +++ b/basis/specialized-vectors/long/long.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.long + +<< "long" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/longlong/longlong.factor b/basis/specialized-vectors/longlong/longlong.factor new file mode 100644 index 0000000000..78c86eb375 --- /dev/null +++ b/basis/specialized-vectors/longlong/longlong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.longlong + +<< "longlong" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/short/short.factor b/basis/specialized-vectors/short/short.factor new file mode 100644 index 0000000000..b6d150b91b --- /dev/null +++ b/basis/specialized-vectors/short/short.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.short + +<< "short" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/specialized-vectors-docs.factor b/basis/specialized-vectors/specialized-vectors-docs.factor new file mode 100644 index 0000000000..5c0a15cb75 --- /dev/null +++ b/basis/specialized-vectors/specialized-vectors-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax byte-vectors ; +IN: specialized-vectors + +ARTICLE: "specialized-vectors" "Specialized vectors" +"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing." +$nl +"For each primitive C type " { $snippet "T" } ", a set of words are defined:" +{ $table + { { $snippet "T-vector" } { "The class of vectors with elements of type " { $snippet "T" } } } + { { $snippet "" } { "Constructor for vectors with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- vector )" } } } + { { $snippet ">T-vector" } { "Converts a sequence into a specialized vector of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- vector )" } } } + { { $snippet "T-vector{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } } +} +"The primitive C types for which specialized vectors exist:" +{ $list + { $snippet "char" } + { $snippet "uchar" } + { $snippet "short" } + { $snippet "ushort" } + { $snippet "int" } + { $snippet "uint" } + { $snippet "long" } + { $snippet "ulong" } + { $snippet "longlong" } + { $snippet "ulonglong" } + { $snippet "float" } + { $snippet "double" } + { $snippet "void*" } + { $snippet "bool" } +} +"Specialized vectors are generated with a functor in the " { $vocab-link "specialized-vectors.functor" } " vocabulary." +$nl +"The " { $vocab-link "specialized-arrays" } " vocabulary provides fixed-length versions of the above." ; + +ABOUT: "specialized-vectors" diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor new file mode 100644 index 0000000000..5df602c78d --- /dev/null +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: specialized-vectors diff --git a/basis/specialized-vectors/summary.txt b/basis/specialized-vectors/summary.txt new file mode 100644 index 0000000000..9df7115d02 --- /dev/null +++ b/basis/specialized-vectors/summary.txt @@ -0,0 +1 @@ +Vectors of unboxed primitive C types diff --git a/basis/float-vectors/tags.txt b/basis/specialized-vectors/tags.txt similarity index 100% rename from basis/float-vectors/tags.txt rename to basis/specialized-vectors/tags.txt diff --git a/basis/specialized-vectors/uchar/uchar.factor b/basis/specialized-vectors/uchar/uchar.factor new file mode 100644 index 0000000000..245d4b3e45 --- /dev/null +++ b/basis/specialized-vectors/uchar/uchar.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.uchar + +<< "uchar" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/uint/uint.factor b/basis/specialized-vectors/uint/uint.factor new file mode 100644 index 0000000000..cb00880aff --- /dev/null +++ b/basis/specialized-vectors/uint/uint.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.uint + +<< "uint" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/ulong/ulong.factor b/basis/specialized-vectors/ulong/ulong.factor new file mode 100644 index 0000000000..0c0e0d3cda --- /dev/null +++ b/basis/specialized-vectors/ulong/ulong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.ulong + +<< "ulong" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/ulonglong/ulonglong.factor b/basis/specialized-vectors/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..f3cd2cd9dd --- /dev/null +++ b/basis/specialized-vectors/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.ulonglong + +<< "ulonglong" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/ushort/ushort.factor b/basis/specialized-vectors/ushort/ushort.factor new file mode 100644 index 0000000000..78386ffa94 --- /dev/null +++ b/basis/specialized-vectors/ushort/ushort.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-vector.ushort + +<< "ushort" define-vector >> \ No newline at end of file diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 11fb69fc7d..c2fe483d35 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -5,7 +5,8 @@ strings quotations assocs combinators classes colors classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render math.geometry.rect locals alien.c-types ; +ui.render math.geometry.rect locals alien.c-types +specialized-arrays.float ; IN: ui.gadgets.buttons @@ -118,7 +119,7 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ; } cleave 4array ; : checkmark-vertices ( dim -- vertices ) - checkmark-points concat >c-float-array ; + checkmark-points concat >float-array underlying>> ; PRIVATE> diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 71304aca0b..9529e34c70 100644 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays hashtables io kernel math namespaces opengl opengl.gl opengl.glu sequences strings io.styles vectors combinators math.vectors ui.gadgets colors -math.order math.geometry.rect locals ; +math.order math.geometry.rect locals specialized-arrays.float ; IN: ui.render SYMBOL: clip @@ -140,10 +140,11 @@ TUPLE: gradient < caching-pen colors last-vertices last-colors ; direction dim v* dim over v- swap colors length dup 1- v/n [ v*n ] with map [ dup rot v+ 2array ] with map - concat concat >c-float-array ; + concat concat >float-array underlying>> ; : gradient-colors ( colors -- seq ) - [ color>raw 4array dup 2array ] map concat concat >c-float-array ; + [ color>raw 4array dup 2array ] map concat concat + >float-array underlying>> ; M: gradient recompute-pen ( gadget gradient -- ) tuck @@ -171,7 +172,7 @@ M: gradient draw-interior TUPLE: polygon color vertex-array count ; : ( color points -- polygon ) - [ concat >c-float-array ] [ length ] bi polygon boa ; + [ concat >float-array underlying>> ] [ length ] bi polygon boa ; : draw-polygon ( polygon mode -- ) swap diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index 1f3a6bf78a..67acd3737a 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings -combinators.short-circuit fry kernel layouts sequences ; +combinators.short-circuit fry kernel layouts sequences +specialized-arrays.alien ; IN: unix.utilities : more? ( alien -- ? ) @@ -16,4 +17,4 @@ IN: unix.utilities [ ] produce nip ; : strings>alien ( strings encoding -- alien ) - '[ _ malloc-string ] map f suffix >c-void*-array ; + '[ _ malloc-string ] void*-array{ } map f suffix underlying>> ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index d376cccae2..5cb830bc66 100644 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -92,9 +92,6 @@ unless [ [ (( -- alien )) define-declared ] pick slip ] with-compilation-unit ; -: byte-array>malloc ( byte-array -- alien ) - [ byte-length malloc ] [ over byte-array>memory ] bi ; - : (callback-word) ( function-name interface-name counter -- word ) [ "::" rot 3append "-callback-" ] dip number>string 3append "windows.com.wrapper.callbacks" create ; @@ -132,7 +129,7 @@ unless 1 0 rot set-ulong-nth ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] map >c-void*-array byte-array>malloc ; + [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 1007b47a5b..2a0a889bb9 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays kernel math namespaces sequences io.encodings.string -io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ; +io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants +specialized-arrays.int ; IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp @@ -50,7 +51,7 @@ TUPLE: x-clipboard atom contents ; "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" - } [ x-atom ] map >c-int-array + } [ x-atom ] int-array{ } map-as underlying>> 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) @@ -58,7 +59,7 @@ TUPLE: x-clipboard atom contents ; [ XSelectionRequestEvent-requestor ] keep [ XSelectionRequestEvent-property ] keep >r "TIMESTAMP" x-atom 32 PropModeReplace r> - XSelectionRequestEvent-time 1array >c-int-array + XSelectionRequestEvent-time 1 XChangeProperty drop ; : send-notify ( evt prop -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index eefb93772a..99bae97b14 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -3,7 +3,7 @@ ! ! based on glx.h from xfree86, and some of glxtokens.h USING: alien alien.c-types alien.syntax alien.syntax.private x11.xlib -namespaces make kernel sequences parser words ; +namespaces make kernel sequences parser words specialized-arrays.int ; IN: x11.glx LIBRARY: glx @@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; GLX_DOUBLEBUFFER , GLX_DEPTH_SIZE , 16 , 0 , - ] { } make >c-int-array + ] int-array{ } make underlying>> glXChooseVisual [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 35e1906b2b..c91ff83493 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -38,17 +38,17 @@ SYMBOL: keybuf SYMBOL: keysym : prepare-lookup ( -- ) - buf-size "uint" keybuf set + buf-size keybuf set 0 keysym set ; : finish-lookup ( len -- string keysym ) - keybuf get swap c-uint-array> >string + keybuf get swap 2 * head utf16n decode keysym get *KeySym ; : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get buf-size keysym get 0 + swap keybuf get underlying>> buf-size keysym get 0 XwcLookupString finish-lookup ] with-scope ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 105bdc325f..b27bab9b25 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -23,7 +23,7 @@ IN: bootstrap.syntax "syntax" lookup t "delimiter" set-word-prop ; : define-syntax ( name quot -- ) - >r "syntax" lookup dup r> define t "parsing" set-word-prop ; + >r "syntax" lookup dup r> define make-parsing ; [ { "]" "}" ";" ">>" } [ define-delimiter ] each @@ -93,7 +93,7 @@ IN: bootstrap.syntax "foldable" [ word make-foldable ] define-syntax "flushable" [ word make-flushable ] define-syntax "delimiter" [ word t "delimiter" set-word-prop ] define-syntax - "parsing" [ word t "parsing" set-word-prop ] define-syntax + "parsing" [ word make-parsing ] define-syntax "SYMBOL:" [ CREATE-WORD define-symbol diff --git a/core/words/words.factor b/core/words/words.factor index 66c60dc06e..f8cbaf0a22 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -243,6 +243,8 @@ ERROR: bad-create name vocab ; PREDICATE: parsing-word < word "parsing" word-prop ; +: make-parsing ( word -- ) t "parsing" set-word-prop ; + : delimiter? ( obj -- ? ) dup word? [ "delimiter" word-prop ] [ drop f ] if ; diff --git a/extra/benchmark/dawes/dawes.factor b/extra/benchmark/dawes/dawes.factor index 7cff06d1bc..9ece8465ab 100644 --- a/extra/benchmark/dawes/dawes.factor +++ b/extra/benchmark/dawes/dawes.factor @@ -1,19 +1,14 @@ -USING: sequences alien.c-types math hints kernel byte-arrays ; +USING: sequences hints kernel math specialized-arrays.int ; IN: benchmark.dawes ! Phil Dawes's performance problem -: int-length ( byte-array -- n ) length "int" heap-size /i ; inline +: count-ones ( byte-array -- n ) [ 1 = ] sigma ; -: count-ones ( byte-array -- n ) - 0 swap [ int-length ] keep [ - int-nth 1 = [ 1 + ] when - ] curry each-integer ; - -HINTS: count-ones byte-array ; +HINTS: count-ones int-array ; : make-byte-array ( -- byte-array ) - 120000 [ 255 bitand ] map >c-int-array ; + 120000 [ 255 bitand ] int-array{ } map-as ; : dawes-benchmark ( -- ) make-byte-array 200 swap [ count-ones ] curry replicate drop ; diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor index 0bad9cc943..fd420d0b7d 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -1,5 +1,5 @@ USING: alien.c-types continuations destructors kernel -opengl opengl.gl bunny.model ; +opengl opengl.gl bunny.model specialized-arrays.float ; IN: bunny.fixed-pipeline TUPLE: bunny-fixed-pipeline ; @@ -13,7 +13,7 @@ M: bunny-fixed-pipeline draw-bunny GL_LIGHTING glEnable GL_LIGHT0 glEnable GL_COLOR_MATERIAL glEnable - GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_POSITION float-array{ 1.0 -1.0 1.0 1.0 } underlying>> glLightfv GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 1bbaf796ad..c9d109cb71 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,7 +2,8 @@ USING: accessors alien.c-types arrays combinators destructors http.client io io.encodings.ascii io.files kernel math math.matrices math.parser math.vectors opengl opengl.capabilities opengl.gl opengl.demo-support sequences -sequences.lib splitting vectors words ; +sequences.lib splitting vectors words +specialized-arrays.double specialized-arrays.uint ; IN: bunny.model : numbers ( str -- seq ) @@ -65,11 +66,11 @@ TUPLE: bunny-buffers array element-array nv ni ; { [ [ first concat ] [ second concat ] bi - append >c-float-array + append >double-array underlying>> GL_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ - third concat >c-uint-array + third concat >uint-array underlying>> GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ first length 3 * ] diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 0f21142f2a..bdd02c9e13 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -5,7 +5,7 @@ ! http://cairographics.org/samples/ USING: cairo cairo.ffi locals math.constants math io.backend kernel alien.c-types libc namespaces -cairo.gadgets ui.gadgets accessors ; +cairo.gadgets ui.gadgets accessors specialized-arrays.double ; IN: cairo.samples @@ -69,7 +69,7 @@ M:: clip-image-gadget render-cairo* ( gadget -- ) TUPLE: dash-gadget < cairo-gadget ; M:: dash-gadget render-cairo* ( gadget -- ) - [let | dashes [ { 50 10 10 10 } >c-double-array ] + [let | dashes [ double-array{ 50 10 10 10 } underlying>> ] ndash [ 4 ] | cr dashes ndash -50 cairo_set_dash cr 10 cairo_set_line_width diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 102de8fd22..8110251fb7 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -6,7 +6,7 @@ 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 ; + qualified speicalized-arrays.double ; QUALIFIED: syntax IN: cfdg @@ -75,7 +75,7 @@ VAR: threshold 2 * sin , 2 * cos neg , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 1 , ] - { } make >c-double-array glMultMatrixd ; + double-array{ } make underlying>> glMultMatrixd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 219fe0ca05..a7d6620fff 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-name "Hello world (console)" } - { deploy-threads? f } + { deploy-unicode? f } + { deploy-reflection 1 } { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-io 2 } { deploy-math? f } - { deploy-ui? f } - { deploy-compiler? f } - { "stop-after-last-window?" t } + { deploy-name "Hello world (console)" } { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-compiler? t } + { deploy-ui? f } + { deploy-threads? f } + { deploy-io 2 } + { deploy-c-types? f } } diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 7bd6eb7fbc..b78e7de88e 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu -opengl.demo-support sequences float-arrays ; +opengl.demo-support sequences specialized-arrays.float ; IN: jamshred.gl : min-vertices 6 ; inline @@ -84,10 +84,10 @@ IN: jamshred.gl GL_FOG_DENSITY 0.09 glFogf GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial GL_COLOR_MATERIAL glEnable - GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; + GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ; : player-view ( player -- ) [ location>> ] diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index 4f50543e73..0899e2d079 100755 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -3,7 +3,7 @@ combinators.lib combinators.short-circuit fry kernel locals macros math math.blas.cblas math.blas.vectors math.blas.vectors.private math.complex math.functions math.order multi-methods qualified sequences sequences.merged sequences.private generalizations -shuffle symbols ; +shuffle symbols speicalized-arrays.float specialized-arrays.double ; QUALIFIED: syntax IN: math.blas.matrices @@ -143,14 +143,14 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } PRIVATE> : >float-blas-matrix ( arrays -- matrix ) - [ >c-float-array ] (>matrix) ; + [ >float-array underlying>> ] (>matrix) ; : >double-blas-matrix ( arrays -- matrix ) - [ >c-double-array ] (>matrix) ; + [ >double-array underlying>> ] (>matrix) ; : >float-complex-blas-matrix ( arrays -- matrix ) - [ (flatten-complex-sequence) >c-float-array ] (>matrix) + [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix) ; : >double-complex-blas-matrix ( arrays -- matrix ) - [ (flatten-complex-sequence) >c-double-array ] (>matrix) + [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix) ; GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y ) diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index a135f08f28..f29ef30ab7 100755 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -1,7 +1,9 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel macros math math.blas.cblas math.complex math.functions math.order multi-methods qualified -sequences sequences.private generalizations ; +sequences sequences.private generalizations +specialized-arrays.float specialized-arrays.double +specialized-arrays.direct.float specialized-arrays.direct.double ; QUALIFIED: syntax IN: math.blas.vectors @@ -90,14 +92,14 @@ MACRO: (do-copy) ( copy make-vector -- ) [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ; : (>c-complex) ( complex -- alien ) - [ real-part ] [ imaginary-part ] bi 2array >c-float-array ; + [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ; : (>z-complex) ( complex -- alien ) - [ real-part ] [ imaginary-part ] bi 2array >c-double-array ; + [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ; : (c-complex>) ( alien -- complex ) - 2 c-float-array> first2 rect> ; + 2 first2 rect> ; : (z-complex>) ( alien -- complex ) - 2 c-double-array> first2 rect> ; + 2 first2 rect> ; : (prepare-nth) ( n v -- n*inc v-data ) [ inc>> ] [ data>> ] bi [ * ] dip ; @@ -170,14 +172,14 @@ syntax:M: blas-vector-base equal? } 2&& ; : >float-blas-vector ( seq -- v ) - [ >c-float-array ] [ length ] bi 1 ; + [ >float-array underlying>> ] [ length ] bi 1 ; : >double-blas-vector ( seq -- v ) - [ >c-double-array ] [ length ] bi 1 ; + [ >double-array underlying>> ] [ length ] bi 1 ; : >float-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >c-float-array ] [ length ] bi + [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi 1 ; : >double-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >c-double-array ] [ length ] bi + [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi 1 ; syntax:M: float-blas-vector clone diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index 2a8959b4a0..40593d1e8d 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle combinators.lib - openal.backend ; + openal.backend specialized-arrays.uint ; IN: openal << "alut" { @@ -248,10 +248,10 @@ SYMBOL: init : ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) - dup 2dup alGenSources swap c-uint-array> ; + dup 2dup underlying>> alGenSources swap ; : gen-buffers ( size -- seq ) - dup 2dup alGenBuffers swap c-uint-array> ; + dup 2dup underlying>> alGenBuffers swap ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; @@ -267,7 +267,7 @@ os macosx? "openal.macosx" "openal.other" ? require [ alBufferData ] 4keep alutUnloadWAV ; : queue-buffers ( source buffers -- ) - [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ; + [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; : queue-buffer ( source buffer -- ) 1array queue-buffers ; diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor index d52e55417f..93ca6b32cc 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -91,10 +91,9 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : gl-program-shaders ( program -- shaders ) dup gl-program-shaders-length - dup "GLuint" + dup 0 swap - [ glGetAttachedShaders ] { 3 1 } multikeep - c-uint-array> ; + [ underlying>> glGetAttachedShaders ] { 3 1 } multikeep ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/extra/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor index faff19d8fd..b0128ca52a 100644 --- a/extra/synth/buffers/buffers.factor +++ b/extra/synth/buffers/buffers.factor @@ -38,10 +38,10 @@ M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ; M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ; : 8bit-buffer-data ( seq -- data size ) - [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi ; + [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ; : 16bit-buffer-data ( seq -- data size ) - [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi ; + [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ; : stereo-data ( stereo-buffer -- left right ) [ left-data>> ] [ right-data>> ] bi@ ; From f59071189c478a2d211f3bbf083fd45ab8b5cbe1 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:19:29 -0500 Subject: [PATCH 002/441] Moved math.polynomials to extra --- {extra => basis}/math/polynomials/authors.txt | 0 {extra => basis}/math/polynomials/polynomials-docs.factor | 0 {extra => basis}/math/polynomials/polynomials-tests.factor | 0 {extra => basis}/math/polynomials/polynomials.factor | 0 {extra => basis}/math/polynomials/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/polynomials/authors.txt (100%) rename {extra => basis}/math/polynomials/polynomials-docs.factor (100%) rename {extra => basis}/math/polynomials/polynomials-tests.factor (100%) rename {extra => basis}/math/polynomials/polynomials.factor (100%) rename {extra => basis}/math/polynomials/summary.txt (100%) diff --git a/extra/math/polynomials/authors.txt b/basis/math/polynomials/authors.txt similarity index 100% rename from extra/math/polynomials/authors.txt rename to basis/math/polynomials/authors.txt diff --git a/extra/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor similarity index 100% rename from extra/math/polynomials/polynomials-docs.factor rename to basis/math/polynomials/polynomials-docs.factor diff --git a/extra/math/polynomials/polynomials-tests.factor b/basis/math/polynomials/polynomials-tests.factor similarity index 100% rename from extra/math/polynomials/polynomials-tests.factor rename to basis/math/polynomials/polynomials-tests.factor diff --git a/extra/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor similarity index 100% rename from extra/math/polynomials/polynomials.factor rename to basis/math/polynomials/polynomials.factor diff --git a/extra/math/polynomials/summary.txt b/basis/math/polynomials/summary.txt similarity index 100% rename from extra/math/polynomials/summary.txt rename to basis/math/polynomials/summary.txt From 5869a1aab48fa5cb6afef8000658aba963587f63 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:20:44 -0500 Subject: [PATCH 003/441] Move math.combinatorics to basis --- {extra => basis}/math/combinatorics/authors.txt | 0 {extra => basis}/math/combinatorics/combinatorics-docs.factor | 0 {extra => basis}/math/combinatorics/combinatorics-tests.factor | 0 {extra => basis}/math/combinatorics/combinatorics.factor | 0 {extra => basis}/math/combinatorics/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/combinatorics/authors.txt (100%) rename {extra => basis}/math/combinatorics/combinatorics-docs.factor (100%) rename {extra => basis}/math/combinatorics/combinatorics-tests.factor (100%) rename {extra => basis}/math/combinatorics/combinatorics.factor (100%) rename {extra => basis}/math/combinatorics/summary.txt (100%) diff --git a/extra/math/combinatorics/authors.txt b/basis/math/combinatorics/authors.txt similarity index 100% rename from extra/math/combinatorics/authors.txt rename to basis/math/combinatorics/authors.txt diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor similarity index 100% rename from extra/math/combinatorics/combinatorics-docs.factor rename to basis/math/combinatorics/combinatorics-docs.factor diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor similarity index 100% rename from extra/math/combinatorics/combinatorics-tests.factor rename to basis/math/combinatorics/combinatorics-tests.factor diff --git a/extra/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor similarity index 100% rename from extra/math/combinatorics/combinatorics.factor rename to basis/math/combinatorics/combinatorics.factor diff --git a/extra/math/combinatorics/summary.txt b/basis/math/combinatorics/summary.txt similarity index 100% rename from extra/math/combinatorics/summary.txt rename to basis/math/combinatorics/summary.txt From 1ffc6051cdad982b99bfbdda312beb5251a5732b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:22:16 -0500 Subject: [PATCH 004/441] Move math.blas to basis --- {extra => basis}/math/blas/cblas/authors.txt | 0 {extra => basis}/math/blas/cblas/cblas.factor | 0 {extra => basis}/math/blas/cblas/summary.txt | 0 {extra => basis}/math/blas/cblas/tags.txt | 0 {extra => basis}/math/blas/matrices/authors.txt | 0 {extra => basis}/math/blas/matrices/matrices-docs.factor | 0 {extra => basis}/math/blas/matrices/matrices-tests.factor | 0 {extra => basis}/math/blas/matrices/matrices.factor | 0 {extra => basis}/math/blas/matrices/summary.txt | 0 {extra => basis}/math/blas/matrices/tags.txt | 0 {extra => basis}/math/blas/syntax/authors.txt | 0 {extra => basis}/math/blas/syntax/summary.txt | 0 {extra => basis}/math/blas/syntax/syntax-docs.factor | 0 {extra => basis}/math/blas/syntax/syntax.factor | 0 {extra => basis}/math/blas/syntax/tags.txt | 0 {extra => basis}/math/blas/vectors/authors.txt | 0 {extra => basis}/math/blas/vectors/summary.txt | 0 {extra => basis}/math/blas/vectors/tags.txt | 0 {extra => basis}/math/blas/vectors/vectors-docs.factor | 0 {extra => basis}/math/blas/vectors/vectors-tests.factor | 0 {extra => basis}/math/blas/vectors/vectors.factor | 0 21 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/blas/cblas/authors.txt (100%) rename {extra => basis}/math/blas/cblas/cblas.factor (100%) rename {extra => basis}/math/blas/cblas/summary.txt (100%) rename {extra => basis}/math/blas/cblas/tags.txt (100%) rename {extra => basis}/math/blas/matrices/authors.txt (100%) rename {extra => basis}/math/blas/matrices/matrices-docs.factor (100%) rename {extra => basis}/math/blas/matrices/matrices-tests.factor (100%) rename {extra => basis}/math/blas/matrices/matrices.factor (100%) rename {extra => basis}/math/blas/matrices/summary.txt (100%) rename {extra => basis}/math/blas/matrices/tags.txt (100%) rename {extra => basis}/math/blas/syntax/authors.txt (100%) rename {extra => basis}/math/blas/syntax/summary.txt (100%) rename {extra => basis}/math/blas/syntax/syntax-docs.factor (100%) rename {extra => basis}/math/blas/syntax/syntax.factor (100%) rename {extra => basis}/math/blas/syntax/tags.txt (100%) rename {extra => basis}/math/blas/vectors/authors.txt (100%) rename {extra => basis}/math/blas/vectors/summary.txt (100%) rename {extra => basis}/math/blas/vectors/tags.txt (100%) rename {extra => basis}/math/blas/vectors/vectors-docs.factor (100%) rename {extra => basis}/math/blas/vectors/vectors-tests.factor (100%) rename {extra => basis}/math/blas/vectors/vectors.factor (100%) diff --git a/extra/math/blas/cblas/authors.txt b/basis/math/blas/cblas/authors.txt similarity index 100% rename from extra/math/blas/cblas/authors.txt rename to basis/math/blas/cblas/authors.txt diff --git a/extra/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor similarity index 100% rename from extra/math/blas/cblas/cblas.factor rename to basis/math/blas/cblas/cblas.factor diff --git a/extra/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt similarity index 100% rename from extra/math/blas/cblas/summary.txt rename to basis/math/blas/cblas/summary.txt diff --git a/extra/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt similarity index 100% rename from extra/math/blas/cblas/tags.txt rename to basis/math/blas/cblas/tags.txt diff --git a/extra/math/blas/matrices/authors.txt b/basis/math/blas/matrices/authors.txt similarity index 100% rename from extra/math/blas/matrices/authors.txt rename to basis/math/blas/matrices/authors.txt diff --git a/extra/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor similarity index 100% rename from extra/math/blas/matrices/matrices-docs.factor rename to basis/math/blas/matrices/matrices-docs.factor diff --git a/extra/math/blas/matrices/matrices-tests.factor b/basis/math/blas/matrices/matrices-tests.factor similarity index 100% rename from extra/math/blas/matrices/matrices-tests.factor rename to basis/math/blas/matrices/matrices-tests.factor diff --git a/extra/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor similarity index 100% rename from extra/math/blas/matrices/matrices.factor rename to basis/math/blas/matrices/matrices.factor diff --git a/extra/math/blas/matrices/summary.txt b/basis/math/blas/matrices/summary.txt similarity index 100% rename from extra/math/blas/matrices/summary.txt rename to basis/math/blas/matrices/summary.txt diff --git a/extra/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt similarity index 100% rename from extra/math/blas/matrices/tags.txt rename to basis/math/blas/matrices/tags.txt diff --git a/extra/math/blas/syntax/authors.txt b/basis/math/blas/syntax/authors.txt similarity index 100% rename from extra/math/blas/syntax/authors.txt rename to basis/math/blas/syntax/authors.txt diff --git a/extra/math/blas/syntax/summary.txt b/basis/math/blas/syntax/summary.txt similarity index 100% rename from extra/math/blas/syntax/summary.txt rename to basis/math/blas/syntax/summary.txt diff --git a/extra/math/blas/syntax/syntax-docs.factor b/basis/math/blas/syntax/syntax-docs.factor similarity index 100% rename from extra/math/blas/syntax/syntax-docs.factor rename to basis/math/blas/syntax/syntax-docs.factor diff --git a/extra/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor similarity index 100% rename from extra/math/blas/syntax/syntax.factor rename to basis/math/blas/syntax/syntax.factor diff --git a/extra/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt similarity index 100% rename from extra/math/blas/syntax/tags.txt rename to basis/math/blas/syntax/tags.txt diff --git a/extra/math/blas/vectors/authors.txt b/basis/math/blas/vectors/authors.txt similarity index 100% rename from extra/math/blas/vectors/authors.txt rename to basis/math/blas/vectors/authors.txt diff --git a/extra/math/blas/vectors/summary.txt b/basis/math/blas/vectors/summary.txt similarity index 100% rename from extra/math/blas/vectors/summary.txt rename to basis/math/blas/vectors/summary.txt diff --git a/extra/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt similarity index 100% rename from extra/math/blas/vectors/tags.txt rename to basis/math/blas/vectors/tags.txt diff --git a/extra/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor similarity index 100% rename from extra/math/blas/vectors/vectors-docs.factor rename to basis/math/blas/vectors/vectors-docs.factor diff --git a/extra/math/blas/vectors/vectors-tests.factor b/basis/math/blas/vectors/vectors-tests.factor similarity index 100% rename from extra/math/blas/vectors/vectors-tests.factor rename to basis/math/blas/vectors/vectors-tests.factor diff --git a/extra/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor similarity index 100% rename from extra/math/blas/vectors/vectors.factor rename to basis/math/blas/vectors/vectors.factor From c3f05eaaa141440c3f0cd77b787ced32108df924 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:22:48 -0500 Subject: [PATCH 005/441] Move math.quaternions to extra --- {extra => basis}/math/quaternions/authors.txt | 0 {extra => basis}/math/quaternions/quaternions-docs.factor | 0 {extra => basis}/math/quaternions/quaternions-tests.factor | 0 {extra => basis}/math/quaternions/quaternions.factor | 0 {extra => basis}/math/quaternions/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/quaternions/authors.txt (100%) rename {extra => basis}/math/quaternions/quaternions-docs.factor (100%) rename {extra => basis}/math/quaternions/quaternions-tests.factor (100%) rename {extra => basis}/math/quaternions/quaternions.factor (100%) rename {extra => basis}/math/quaternions/summary.txt (100%) diff --git a/extra/math/quaternions/authors.txt b/basis/math/quaternions/authors.txt similarity index 100% rename from extra/math/quaternions/authors.txt rename to basis/math/quaternions/authors.txt diff --git a/extra/math/quaternions/quaternions-docs.factor b/basis/math/quaternions/quaternions-docs.factor similarity index 100% rename from extra/math/quaternions/quaternions-docs.factor rename to basis/math/quaternions/quaternions-docs.factor diff --git a/extra/math/quaternions/quaternions-tests.factor b/basis/math/quaternions/quaternions-tests.factor similarity index 100% rename from extra/math/quaternions/quaternions-tests.factor rename to basis/math/quaternions/quaternions-tests.factor diff --git a/extra/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor similarity index 100% rename from extra/math/quaternions/quaternions.factor rename to basis/math/quaternions/quaternions.factor diff --git a/extra/math/quaternions/summary.txt b/basis/math/quaternions/summary.txt similarity index 100% rename from extra/math/quaternions/summary.txt rename to basis/math/quaternions/summary.txt From 47d268d8947f27011dc3b52e4a153a17191f7d55 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:30:11 -0500 Subject: [PATCH 006/441] Remove documentation duplication in math.statistics --- extra/math/statistics/statistics-docs.factor | 11 ++++++----- extra/math/statistics/statistics.factor | 10 +--------- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/extra/math/statistics/statistics-docs.factor b/extra/math/statistics/statistics-docs.factor index 695834b554..7a7eb70dd2 100644 --- a/extra/math/statistics/statistics-docs.factor +++ b/extra/math/statistics/statistics-docs.factor @@ -3,13 +3,14 @@ IN: math.statistics HELP: geometric-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } -{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } +{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } -{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } +{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } +{ $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; @@ -36,21 +37,21 @@ HELP: range HELP: std { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." } +{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; HELP: ste { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } - { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } + { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; HELP: var { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } +{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" } diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor index 7568af5294..d2494ee32a 100644 --- a/extra/math/statistics/statistics.factor +++ b/extra/math/statistics/statistics.factor @@ -5,20 +5,15 @@ USING: arrays combinators kernel math math.analysis math.functions sequences IN: math.statistics : mean ( seq -- n ) - #! arithmetic mean, sum divided by length [ sum ] [ length ] bi / ; : geometric-mean ( seq -- n ) - #! geometric mean, nth root of product [ length ] [ product ] bi nth-root ; : harmonic-mean ( seq -- n ) - #! harmonic mean, reciprocal of sum of reciprocals. - #! positive reals only [ recip ] sigma recip ; : median ( seq -- n ) - #! middle number if odd, avg of two middle numbers if even natural-sort dup length even? [ [ midpoint@ dup 1- 2array ] keep nths mean ] [ @@ -26,11 +21,10 @@ IN: math.statistics ] if ; : range ( seq -- n ) - #! max - min minmax swap - ; : var ( seq -- x ) - #! variance, normalize by N-1 + #! normalize by N-1 dup length 1 <= [ drop 0 ] [ @@ -39,11 +33,9 @@ IN: math.statistics ] if ; : std ( seq -- x ) - #! standard deviation, sqrt of variance var sqrt ; : ste ( seq -- x ) - #! standard error, standard deviation / sqrt ( length of sequence ) [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) From 197bb708934f6ab2b4c4f3960d9e284e73832bf4 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:31:07 -0500 Subject: [PATCH 007/441] Move math.statistics to extra --- {extra => basis}/math/statistics/authors.txt | 0 {extra => basis}/math/statistics/statistics-docs.factor | 0 {extra => basis}/math/statistics/statistics-tests.factor | 0 {extra => basis}/math/statistics/statistics.factor | 0 {extra => basis}/math/statistics/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/statistics/authors.txt (100%) rename {extra => basis}/math/statistics/statistics-docs.factor (100%) rename {extra => basis}/math/statistics/statistics-tests.factor (100%) rename {extra => basis}/math/statistics/statistics.factor (100%) rename {extra => basis}/math/statistics/summary.txt (100%) diff --git a/extra/math/statistics/authors.txt b/basis/math/statistics/authors.txt similarity index 100% rename from extra/math/statistics/authors.txt rename to basis/math/statistics/authors.txt diff --git a/extra/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor similarity index 100% rename from extra/math/statistics/statistics-docs.factor rename to basis/math/statistics/statistics-docs.factor diff --git a/extra/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor similarity index 100% rename from extra/math/statistics/statistics-tests.factor rename to basis/math/statistics/statistics-tests.factor diff --git a/extra/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor similarity index 100% rename from extra/math/statistics/statistics.factor rename to basis/math/statistics/statistics.factor diff --git a/extra/math/statistics/summary.txt b/basis/math/statistics/summary.txt similarity index 100% rename from extra/math/statistics/summary.txt rename to basis/math/statistics/summary.txt From 1b47e809942c5c45b2094c81287c6d6fb47ba9f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 22:18:35 -0600 Subject: [PATCH 008/441] Clean up some specialized array usage --- basis/opengl/opengl.factor | 16 ++++++++-------- basis/ui/gadgets/buttons/buttons.factor | 2 +- basis/ui/render/render.factor | 6 +++--- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 5497229b6c..5fd0f56bbf 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -53,20 +53,20 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - >float-array underlying>> glMaterialfv ; + float-array{ } like underlying>> glMaterialfv ; : gl-vertex-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline + [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline : gl-color-pointer ( seq -- ) - [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline + [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline : gl-texture-coord-pointer ( seq -- ) [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) - [ first2 [ 0.5 + ] bi@ ] bi@ 4 narray - >float-array underlying>> gl-vertex-pointer ; + [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence + gl-vertex-pointer ; : gl-line ( a b -- ) line-vertices GL_LINES 0 2 glDrawArrays ; @@ -77,7 +77,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ first 0.3 - 0.5 ] [ [ first 0.3 - ] [ second 0.3 - ] bi ] [ second 0.3 - 0.5 swap ] - } cleave 8 float-array{ } nsequence underlying>> ; + } cleave 8 float-array{ } nsequence ; : rect-vertices ( dim -- ) (rect-vertices) gl-vertex-pointer ; @@ -94,7 +94,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ first 0 ] [ first2 ] [ second 0 swap ] - } cleave 8 float-array{ } nsequence underlying>> ; + } cleave 8 float-array{ } nsequence ; : fill-rect-vertices ( dim -- ) (fill-rect-vertices) gl-vertex-pointer ; @@ -121,7 +121,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) circle-steps unit-circle adjust-points scale-points ; : circle-vertices ( loc dim steps -- vertices ) - circle-points concat >float-array underlying>> ; + circle-points concat >float-array ; : (gen-gl-object) ( quot -- id ) >r 1 0 r> keep *uint ; inline diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index ffc0aa63c4..f89407ba8b 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -118,7 +118,7 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ; } cleave 4array ; : checkmark-vertices ( dim -- vertices ) - checkmark-points concat >float-array underlying>> ; + checkmark-points concat >float-array ; PRIVATE> diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 94efd1bf22..ec400abe8c 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -140,11 +140,11 @@ TUPLE: gradient < caching-pen colors last-vertices last-colors ; direction dim v* dim over v- swap colors length dup 1- v/n [ v*n ] with map [ dup rot v+ 2array ] with map - concat concat >float-array underlying>> ; + concat concat >float-array ; : gradient-colors ( colors -- seq ) [ color>raw 4array dup 2array ] map concat concat - >float-array underlying>> ; + >float-array ; M: gradient recompute-pen ( gadget gradient -- ) tuck @@ -172,7 +172,7 @@ M: gradient draw-interior TUPLE: polygon color vertex-array count ; : ( color points -- polygon ) - [ concat >float-array underlying>> ] [ length ] bi polygon boa ; + [ concat >float-array ] [ length ] bi polygon boa ; : draw-polygon ( polygon mode -- ) swap From b86681e2d5468f1154186266bb02fc1ac3e59c9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Nov 2008 22:18:43 -0600 Subject: [PATCH 009/441] Adding nibble-arrays --- basis/nibble-arrays/nibble-arrays.factor | 71 ++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 basis/nibble-arrays/nibble-arrays.factor diff --git a/basis/nibble-arrays/nibble-arrays.factor b/basis/nibble-arrays/nibble-arrays.factor new file mode 100644 index 0000000000..170f41a2d9 --- /dev/null +++ b/basis/nibble-arrays/nibble-arrays.factor @@ -0,0 +1,71 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math kernel sequences sequences.private byte-arrays +alien.c-types prettyprint.backend parser accessors ; +IN: nibble-arrays + +TUPLE: nibble-array +{ length array-capacity read-only } +{ underlying byte-array read-only } ; + +bytes 1 + 2/ ; inline + +: byte/nibble ( n -- shift n' ) + [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline + +: get-nibble ( shift n byte -- nibble ) + swap neg shift nibble bitand ; inline + +: set-nibble ( value shift n byte -- byte' ) + nibble pick shift bitnot bitand -rot shift bitor ; inline + +: nibble@ ( n nibble-array -- shift n' byte-array ) + [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline + +PRIVATE> + +: ( n -- nibble-array ) + dup nibbles>bytes nibble-array boa ; inline + +M: nibble-array length length>> ; + +M: nibble-array nth-unsafe + nibble@ nth-unsafe get-nibble ; + +M: nibble-array set-nth-unsafe + nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ; + +M: nibble-array clone + [ length>> ] [ underlying>> clone ] bi nibble-array boa ; + +: >nibble-array ( seq -- nibble-array ) + T{ nibble-array } clone-like ; inline + +M: nibble-array like + drop dup nibble-array? [ >nibble-array ] unless ; + +M: nibble-array new-sequence drop ; + +M: nibble-array equal? + over nibble-array? [ sequence= ] [ 2drop f ] if ; + +M: nibble-array resize + [ drop ] [ + [ nibbles>bytes ] [ underlying>> ] bi* + resize-byte-array + ] 2bi + nibble-array boa ; + +M: nibble-array byte-length length nibbles>bytes ; + +: N{ \ } [ >nibble-array ] parse-literal ; parsing + +INSTANCE: nibble-array sequence + +M: nibble-array pprint-delims drop \ N{ \ } ; +M: nibble-array >pprint-sequence ; +M: nibble-array pprint* pprint-object ; From 9a870b7760e0d8e042a0aba678844fe0abdcf75a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 20 Nov 2008 01:48:43 -0500 Subject: [PATCH 010/441] Solution to Project Euler problem 50 --- extra/project-euler/050/050-tests.factor | 6 ++ extra/project-euler/050/050.factor | 90 ++++++++++++++++++++++++ 2 files changed, 96 insertions(+) create mode 100644 extra/project-euler/050/050-tests.factor create mode 100644 extra/project-euler/050/050.factor diff --git a/extra/project-euler/050/050-tests.factor b/extra/project-euler/050/050-tests.factor new file mode 100644 index 0000000000..2bd5482f7e --- /dev/null +++ b/extra/project-euler/050/050-tests.factor @@ -0,0 +1,6 @@ +USING: project-euler.050 project-euler.050.private tools.test ; +IN: project-euler.050.tests + +[ 41 ] [ 100 solve ] unit-test +[ 953 ] [ 1000 solve ] unit-test +[ 997651 ] [ euler050 ] unit-test diff --git a/extra/project-euler/050/050.factor b/extra/project-euler/050/050.factor new file mode 100644 index 0000000000..f8ce68d173 --- /dev/null +++ b/extra/project-euler/050/050.factor @@ -0,0 +1,90 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel locals math math.primes sequences ; +IN: project-euler.050 + +! http://projecteuler.net/index.php?section=problems&id=50 + +! DESCRIPTION +! ----------- + +! The prime 41, can be written as the sum of six consecutive primes: + +! 41 = 2 + 3 + 5 + 7 + 11 + 13 + +! This is the longest sum of consecutive primes that adds to a prime below +! one-hundred. + +! The longest sum of consecutive primes below one-thousand that adds to a +! prime, contains 21 terms, and is equal to 953. + +! Which prime, below one-million, can be written as the sum of the most +! consecutive primes? + + +! SOLUTION +! -------- + +! 1) Create an sequence of all primes under 1000000. +! 2) Start summing elements in the sequence until the next number would put you +! over 1000000. +! 3) Check if that sum is prime, if not, subtract the last number added. +! 4) Repeat step 3 until you get a prime number, and store it along with the +! how many consecutive numbers from the original sequence it took to get there. +! 5) Drop the first number from the sequence of primes, and do steps 2-4 again +! 6) Compare the longest chain from the first run with the second run, and store +! the longer of the two. +! 7) If the sequence of primes is still longer than the longest chain, then +! repeat steps 5-7...otherwise, you've found the longest sum of consecutive +! primes! + + ] find + [ swapd - ] [ drop seq length swap ] if* ; + +: pop-until-prime ( seq sum -- seq prime ) + over length 0 > [ + [ unclip-last-slice ] dip swap - + dup prime? [ pop-until-prime ] unless + ] [ + 2drop { } 0 + ] if ; + +! a pair is { length of chain, prime the chain sums to } + +: longest-prime ( seq limit -- pair ) + dupd sum-upto dup prime? [ + 2array nip + ] [ + [ head-slice ] dip pop-until-prime + [ length ] dip 2array + ] if ; + +: longest ( pair pair -- longest ) + 2dup [ first ] bi@ > [ drop ] [ nip ] if ; + +: continue? ( pair seq -- ? ) + [ first ] [ length 1- ] bi* < ; + +: (find-longest) ( best seq limit -- best ) + [ longest-prime longest ] 2keep 2over continue? [ + [ rest-slice ] dip (find-longest) + ] [ 2drop ] if ; + +: find-longest ( seq limit -- best ) + { 1 2 } -rot (find-longest) ; + +: solve ( n -- answer ) + [ primes-upto ] keep find-longest second ; + +PRIVATE> + +: euler050 ( -- answer ) + 1000000 solve ; + +! [ euler050 ] 100 ave-time +! 291 ms run / 20.6 ms GC ave time - 100 trials + +MAIN: euler050 From 14c096dd822b0dd859218030369f5e6e692ca56e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 20 Nov 2008 15:23:02 -0600 Subject: [PATCH 011/441] fix mouse scrolling on windows --- basis/ui/windows/windows.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 3805cf7e1f..6e1ce8f77f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -285,7 +285,7 @@ SYMBOL: nc-buttons swap [ push ] [ delete ] if ; : >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ; -: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ; +: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ; : mouse-absolute>relative ( lparam handle -- array ) [ >lo-hi ] dip @@ -338,8 +338,8 @@ SYMBOL: nc-buttons >lo-hi swap window move-hand fire-motion ; :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- ) - lParam mouse-wheel - hWnd mouse-absolute>relative + wParam mouse-wheel + lParam hWnd mouse-absolute>relative hWnd window send-wheel ; : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- ) From 6c5f7615037b5220bc6156595c42dc9d9d239d63 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 22 Nov 2008 21:09:31 -0600 Subject: [PATCH 012/441] re-enable a unit test --- basis/regexp/regexp-tests.factor | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 777d0985e4..0647c4b36f 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -253,7 +253,7 @@ IN: regexp-tests [ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" drop ] unit-test -! Comment +! Comment inside a regular expression [ t ] [ "ac" "a(?#boo)c" matches? ] unit-test [ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test @@ -291,6 +291,12 @@ IN: regexp-tests [ "a" ] [ "ba" "a(?<=b)(?<=b)" first-match >string ] unit-test [ "a" ] [ "cab" "a(?=b)(?<=c)" first-match >string ] unit-test +[ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test +[ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test + +! Bug in parsing word +[ t ] [ "a" R' a' matches? ] unit-test + ! [ "{Lower}" ] [ invalid-range? ] must-fail-with ! [ 1 ] [ "aaacb" "a+?" match-head ] unit-test @@ -303,9 +309,6 @@ IN: regexp-tests ! [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test ! [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test -[ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test -[ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test - ! [ f ] [ "foobxr" "foo\\z" match-head ] unit-test ! [ 3 ] [ "foo" "foo\\z" match-head ] unit-test @@ -323,10 +326,6 @@ IN: regexp-tests ! [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test ! [ f ] [ "foo" "foo\\Bbar" matches? ] unit-test - -! Bug in parsing word -! [ t ] [ "a" R' a' matches? ] unit-test - ! clear "a(?=b*)" "ab" over match ! clear "a(?=b*c)" "abbbbbc" over match ! clear "a(?=b*)" "ab" over match @@ -356,7 +355,6 @@ IN: regexp-tests ! "a(?<=b)" "caba" over first-match - ! capture group 1: "aaaa" 2: "" ! "aaaa" "(a*)(a*)" match* ! "aaaa" "(a*)(a+)" match* From b00156bc85040f1f675e434a3d3c2535ee2c1f61 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 22 Nov 2008 21:10:53 -0600 Subject: [PATCH 013/441] fix count-matches and add unit test for it --- basis/regexp/regexp-tests.factor | 6 ++++++ basis/regexp/regexp.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0647c4b36f..291287f8c2 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -283,6 +283,12 @@ IN: regexp-tests [ { "ABC" "DEF" "GHI" } ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test +[ 3 ] +[ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test + +[ 0 ] +[ "123" R/ [A-Z]+/ count-matches ] unit-test + [ "1.2.3.4" ] [ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 66bc39415b..652d943090 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -73,7 +73,7 @@ IN: regexp [ dup ] swap '[ _ next-match ] [ ] produce nip harvest ; : count-matches ( string regexp -- n ) - all-matches length 1- ; + all-matches length ; : initial-option ( regexp option -- regexp' ) over options>> conjoin ; From afc97627f9876b40848b89864048787e569256f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 22 Nov 2008 23:01:24 -0600 Subject: [PATCH 014/441] remove >r r> from regexp --- basis/regexp/dfa/dfa.factor | 3 ++- basis/regexp/parser/parser.factor | 2 +- basis/regexp/transition-tables/transition-tables.factor | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index ef985258fd..0abd1c2edc 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -43,7 +43,8 @@ IN: regexp.dfa dupd pop dup pick find-transitions rot [ [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep - >r swapd transition make-transition r> dfa-table>> add-transition + [ swapd transition make-transition ] dip + dfa-table>> add-transition ] curry with each new-transitions ] if-empty ; diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 7f1d92a1ab..1feba62f68 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -225,7 +225,7 @@ ERROR: invalid-range a b ; : handle-left-brace ( -- ) parse-repetition - >r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r> + [ 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ ] dip [ 2dup and [ from-m-to-n ] [ [ nip at-most-n ] [ at-least-n ] if* ] if diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 1c9a3e3001..3050be14fa 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -40,7 +40,7 @@ TUPLE: transition-table transitions start-state final-states ; 2dup [ to>> ] dip maybe-initialize-key [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip 2dup at* [ 2nip insert-at ] - [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ; + [ drop [ H{ } clone [ insert-at ] keep ] 2dip set-at ] if ; : add-transition ( transition transition-table -- ) transitions>> set-transition ; From a18f6b5a5eddfdcfadc868ef5384f74c473d6066 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:55:43 -0600 Subject: [PATCH 015/441] help.html doesn't depend on html.components, reduces mason.test load time --- basis/help/html/html.factor | 6 +----- extra/webapps/help/help.factor | 6 +++++- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 6b90ba6937..a9df0bea81 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary -io.files html.streams html.elements html.components help kernel +io.files html.streams html.elements help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order @@ -104,10 +104,6 @@ MEMO: load-index ( name -- index ) TUPLE: result title href ; -M: result link-title title>> ; - -M: result link-href href>> ; - : offline-apropos ( string index -- results ) load-index swap >lower '[ [ drop _ ] dip >lower subseq? ] assoc-filter diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 6f2c4f0042..96401b6afd 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -2,11 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors http.server.dispatchers http.server.static furnace.actions furnace.redirection urls -validators locals io.files html.forms help.html ; +validators locals io.files html.forms html.components help.html ; IN: webapps.help TUPLE: help-webapp < dispatcher ; +M: result link-title title>> ; + +M: result link-href href>> ; + :: ( help-dir -- action ) { help-webapp "search" } >>template From af55aeaba50b05066721cd0001187719e8059393 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:57:36 -0600 Subject: [PATCH 016/441] Fix circularity issue in logging --- basis/logging/logging-docs.factor | 1 - basis/logging/logging.factor | 1 - 2 files changed, 2 deletions(-) diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 7c14cae78e..275d900f3d 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -117,7 +117,6 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.rotation" } { $subsection "logging.parser" } { $subsection "logging.analysis" } -{ $subsection "logging.insomniac" } { $subsection "logging.server" } ; ABOUT: "logging" diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index ae9ef877dd..47de880559 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -123,4 +123,3 @@ USE: vocabs.loader "logging.parser" require "logging.analysis" require -"logging.insomniac" require From 35e9eb25086b3f95e104f3dda839c5ae691892f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:57:48 -0600 Subject: [PATCH 017/441] Fix load error --- extra/mason/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 3de1fa643f..e4390d25a6 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -3,7 +3,7 @@ USING: kernel namespaces assocs io.files io.encodings.utf8 prettyprint help.lint benchmark tools.time bootstrap.stage2 tools.test tools.vocabs help.html mason.common words generic -accessors compiler.errors sequences sets sorting ; +accessors compiler.errors sequences sets sorting math ; IN: mason.test : do-load ( -- ) From 60964487e01b8953b4aad9feba8224e924c2f548 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 04:14:17 -0600 Subject: [PATCH 018/441] Fix PowerPC dip/2dip/3dip --- basis/cpu/ppc/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 56ef89884c..c0fbfaa21b 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -79,7 +79,7 @@ big-endian on : jit-call-quot ( -- ) 4 3 quot-xt-offset LWZ 4 MTLR - BLR ; + BLRL ; [ 0 3 LOAD32 From f520823d5c76e9be5105c3787c19702b4032f426 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 04:22:38 -0600 Subject: [PATCH 019/441] Minor speedup --- core/bootstrap/primitives.factor | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8f280cb53a..962e562be5 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic hashtables -hashtables.private io kernel math math.order namespaces make -parser sequences strings vectors words quotations assocs layouts -classes classes.builtin classes.tuple classes.tuple.private -kernel.private vocabs vocabs.loader source-files definitions -slots classes.union classes.intersection classes.predicate -compiler.units bootstrap.image.private io.files accessors -combinators ; +hashtables.private io kernel math math.private math.order +namespaces make parser sequences strings vectors words +quotations assocs layouts classes classes.builtin classes.tuple +classes.tuple.private kernel.private vocabs vocabs.loader +source-files definitions slots classes.union +classes.intersection classes.predicate compiler.units +bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -185,7 +185,11 @@ define-union-class ! A predicate class used for declarations "array-capacity" "sequences.private" create "fixnum" "math" lookup -0 bootstrap-max-array-capacity [ between? ] 2curry +[ + [ dup 0 fixnum>= ] % + bootstrap-max-array-capacity [ fixnum<= ] curry , + [ [ drop f ] if ] % +] [ ] make define-predicate-class ! Catch-all class for providing a default method. From 65b89eea9e479da3e202b36f87b324745462be43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 04:46:15 -0600 Subject: [PATCH 020/441] Fix compile error --- vm/os-windows.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-windows.c b/vm/os-windows.c index 0aeb77741b..ee2c721111 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -168,5 +168,5 @@ long getpagesize(void) void sleep_micros(DWORD usec) { - Sleep(msec / 1000); + Sleep(usec); } From adce0bf5f390c157378f9558887f434cdc86c361 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 17:41:11 -0600 Subject: [PATCH 021/441] Better docs for sequences.deep --- basis/sequences/deep/deep-docs.factor | 47 +++++++++++++++++++-------- basis/sequences/deep/deep.factor | 19 +++++------ 2 files changed, 42 insertions(+), 24 deletions(-) diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor index 3dc560f46d..f067e6ecdd 100644 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -1,30 +1,49 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup kernel sequences ; IN: sequences.deep HELP: deep-each -{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } } -{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ; +{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } } +{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } +{ $see-also each } ; HELP: deep-map -{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } } -{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ; +{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "newobj" "the mapped object" } } +{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } +{ $see-also map } ; HELP: deep-filter -{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } } -{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ; +{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a sequence" } } +{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } +{ $see-also filter } ; HELP: deep-find -{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "elt" "an element" } } -{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } ; +{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "elt" "an element" } } +{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } +{ $see-also find } ; HELP: deep-contains? -{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "?" "a boolean" } } -{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ; +{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } +{ $description "Tests whether the given object or any subnode satisfies the given quotation." } +{ $see-also contains? } ; HELP: flatten -{ $values { "obj" "an object" } { "seq" "a sequence" } } +{ $values { "obj" object } { "seq" "a sequence" } } { $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ; HELP: deep-change-each -{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } } -{ $description "Modifies each sub-node of an object in place, in preorder." } ; +{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } } +{ $description "Modifies each sub-node of an object in place, in preorder." } +{ $see-also change-each } ; + +ARTICLE: "sequences.deep" "Deep sequence combinators" +"The combinators in the " { $vocab-link "sequences.deep" } " vocabulary are variants of standard sequence combinators which traverse nested subsequences." +{ $subsection deep-each } +{ $subsection deep-map } +{ $subsection deep-filter } +{ $subsection deep-find } +{ $subsection deep-contains? } +{ $subsection deep-change-each } +"A utility word to collapse nested subsequences:" +{ $subsection flatten } ; + +ABOUT: "sequences.deep" diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index 2e50fa5411..db572681a1 100644 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -21,28 +21,27 @@ M: object branch? drop f ; [ [ deep-map ] curry map ] [ drop ] if ; inline recursive : deep-filter ( obj quot: ( elt -- ? ) -- seq ) - over >r - pusher >r deep-each r> - r> dup branch? [ like ] [ drop ] if ; inline recursive + over [ pusher [ deep-each ] dip ] dip + dup branch? [ like ] [ drop ] if ; inline recursive -: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? ) +: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? ) [ call ] 2keep rot [ drop t ] [ over branch? [ - f -rot [ >r nip r> deep-find-from ] curry find drop >boolean + f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean ] [ 2drop f f ] if ] if ; inline recursive -: deep-find ( obj quot -- elt ) deep-find-from drop ; inline +: deep-find ( obj quot -- elt ) (deep-find) drop ; inline -: deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline +: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline : deep-all? ( obj quot -- ? ) [ not ] compose deep-contains? not ; inline : deep-change-each ( obj quot: ( elt -- elt' ) -- ) - over branch? [ [ - [ call ] keep over >r deep-change-each r> - ] curry change-each ] [ 2drop ] if ; inline recursive + over branch? [ + [ [ call ] keep over [ deep-change-each ] dip ] curry change-each + ] [ 2drop ] if ; inline recursive : flatten ( obj -- seq ) [ branch? not ] deep-filter ; From 892aad7d0b55b7749ae3670842ce40c0485888b6 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 24 Nov 2008 00:45:48 +0100 Subject: [PATCH 022/441] Emacs factor mode: More correct treatment of strings and comments in font-lock. --- misc/factor.el | 66 ++++++++++++++++++++++++++++++++------------------ 1 file changed, 43 insertions(+), 23 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 351b0e97d1..3c5b6bb544 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -162,6 +162,10 @@ buffer." ;;; Factor mode font lock: +(defconst factor--regexp-word-start + (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) + (format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|")))) + (defconst factor--parsing-words '("{" "}" "^:" "^::" ";" "<<" ">" "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" @@ -201,12 +205,7 @@ buffer." (defconst factor--regex-use-line "^USE: +\\(.*\\)$") (defconst factor-font-lock-keywords - `(("#!.*$" . 'factor-font-lock-comment) - ("!( .* )" . 'factor-font-lock-comment) - ("^!.*$" . 'factor-font-lock-comment) - (" !.*$" . 'factor-font-lock-comment) - ("( .* )" . 'factor-font-lock-stack-effect) - ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string) + `(("( .* )" . 'factor-font-lock-stack-effect) ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") '(2 'factor-font-lock-parsing-word))) @@ -225,6 +224,14 @@ buffer." ;;; Factor mode syntax: +(defconst factor--font-lock-syntactic-keywords + `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;")) + (,factor--regexp-word-start (2 "(;")) + ("\\(;\\)" (1 "):")) + ("\\(#!\\)" (1 "<")) + ("\\(!\\)" (1 "<")) + ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">")))) + (defvar factor-mode-syntax-table nil "Syntax table used while in Factor mode.") @@ -254,11 +261,14 @@ buffer." ;; Whitespace (modify-syntax-entry ?\t " " factor-mode-syntax-table) - (modify-syntax-entry ?\n ">" factor-mode-syntax-table) (modify-syntax-entry ?\f " " factor-mode-syntax-table) (modify-syntax-entry ?\r " " factor-mode-syntax-table) (modify-syntax-entry ? " " factor-mode-syntax-table) + ;; (end of) Comments + (modify-syntax-entry ?\n ">" factor-mode-syntax-table) + + ;; Parenthesis (modify-syntax-entry ?\[ "(] " factor-mode-syntax-table) (modify-syntax-entry ?\] ")[ " factor-mode-syntax-table) (modify-syntax-entry ?{ "(} " factor-mode-syntax-table) @@ -266,7 +276,10 @@ buffer." (modify-syntax-entry ?\( "()" factor-mode-syntax-table) (modify-syntax-entry ?\) ")(" factor-mode-syntax-table) - (modify-syntax-entry ?\" "\" " factor-mode-syntax-table))) + + ;; Strings + (modify-syntax-entry ?\" "\"" factor-mode-syntax-table) + (modify-syntax-entry ?\\ "/" factor-mode-syntax-table))) ;;; Factor mode indentation: @@ -275,10 +288,6 @@ buffer." (defvar factor-indent-width factor-default-indent-width "Indentation width in factor buffers. A local variable.")) -(defconst factor--regexp-word-start - (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) - (format "^\\(%s\\): " (mapconcat 'identity sws "\\|")))) - (defun factor--guess-indent-width () "Chooses an indentation value from existing code." (let ((word-cont "^ +[^ ]") @@ -494,8 +503,12 @@ buffer." (setq major-mode 'factor-mode) (setq mode-name "Factor") (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment) + (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string) (set (make-local-variable 'font-lock-defaults) - '(factor-font-lock-keywords t nil nil nil)) + `(factor-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords))) (set-syntax-table factor-mode-syntax-table) (set (make-local-variable 'indent-line-function) 'factor--indent-line) (setq factor-indent-width (factor--guess-indent-width)) @@ -550,12 +563,15 @@ buffer." "Keymap for Factor help mode.") (defconst factor--help-headlines - (regexp-opt '("Parent topics:" - "Inputs and outputs" - "Word description" + (regexp-opt '("Definition" + "Examples" "Generic word contract" + "Inputs and outputs" + "Parent topics:" + "Syntax" "Vocabulary" - "Definition") + "Warning" + "Word description") t)) (defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines)) @@ -627,20 +643,24 @@ vocabularies which have been modified on disk." ;;; Key bindings: -(defmacro factor--define-key (key cmd) - `(progn - (define-key factor-mode-map [(control ?c) ,key] ,cmd) - (define-key factor-mode-map [(control ?c) (control ,key)] ,cmd))) +(defmacro factor--define-key (key cmd &optional both) + (let ((m (gensym)) + (ms '(factor-mode-map))) + (when both (push 'factor-help-mode-map ms)) + `(dolist (,m (list ,@ms)) + (define-key ,m [(control ?c) ,key] ,cmd) + (define-key ,m [(control ?c) (control ,key)] ,cmd)))) (factor--define-key ?f 'factor-run-file) (factor--define-key ?r 'factor-send-region) (factor--define-key ?d 'factor-send-definition) -(factor--define-key ?s 'factor-see) +(factor--define-key ?s 'factor-see t) (factor--define-key ?e 'factor-edit) -(factor--define-key ?z 'switch-to-factor) +(factor--define-key ?z 'switch-to-factor t) (factor--define-key ?c 'comment-region) (define-key factor-mode-map "\C-ch" 'factor-help) +(define-key factor-help-mode-map "\C-ch" 'factor-help) (define-key factor-mode-map "\C-m" 'newline-and-indent) (define-key factor-mode-map [tab] 'indent-for-tab-command) From 0745f10068977ef3be50e14c1264dd31d0839d4e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 17:54:32 -0600 Subject: [PATCH 023/441] Fix load error --- extra/wordtimer/wordtimer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index 15a9c10071..803f0c2a66 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -1,6 +1,6 @@ USING: kernel sequences namespaces make math assocs words arrays tools.annotations vocabs sorting prettyprint io system -math.statistics accessors ; +math.statistics accessors tools.time ; IN: wordtimer SYMBOL: *wordtimes* From eeb2133ba2d680c2088ddc8d435c004a15017027 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 21:40:10 -0600 Subject: [PATCH 024/441] Fix compiler test --- basis/compiler/tests/optimizer.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index f1b3e32eed..41df6e7ae5 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ; HINTS: recursive-inline-hang-3 array ; ! Regression -USE: sequences.private - -[ ] [ { (3append) } compile ] unit-test +[ ] [ { 3append-as } compile ] unit-test ! Wow : counter-example ( a b c d -- a' b' c' d' ) From 1d6e389d18aa4c400d9dde126e35fe5eb88bf70e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 21:40:54 -0600 Subject: [PATCH 025/441] Fixing walker, adding traceback tests --- basis/tools/walker/walker-tests.factor | 6 +++- basis/tools/walker/walker.factor | 26 +++++++++++----- core/kernel/kernel-tests.factor | 41 +++++++++++++++++++++++++- vm/quotations.c | 13 ++++---- 4 files changed, 71 insertions(+), 15 deletions(-) diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index e002af8f6d..f802676583 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -17,7 +17,11 @@ IN: tools.walker.tests ] unit-test [ { "Yo" 2 } ] [ - [ 2 >r "Yo" r> ] test-walker + [ 2 [ "Yo" ] dip ] test-walker +] unit-test + +[ { "Yo" 2 3 } ] [ + [ 2 [ "Yo" ] dip 3 ] test-walker ] unit-test [ { 2 } ] [ diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 1d26567952..9b2f5e4705 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -64,6 +64,12 @@ M: object add-breakpoint ; : (step-into-quot) ( quot -- ) add-breakpoint call ; +: (step-into-dip) ( quot -- ) add-breakpoint dip ; + +: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ; + +: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ; + : (step-into-if) ( true false ? -- ) ? (step-into-quot) ; : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ; @@ -130,6 +136,9 @@ SYMBOL: +stopped+ { { call [ (step-into-quot) ] } + { dip [ (step-into-dip) ] } + { 2dip [ (step-into-2dip) ] } + { 3dip [ (step-into-3dip) ] } { (throw) [ drop (step-into-quot) ] } { execute [ (step-into-execute) ] } { if [ (step-into-if) ] } @@ -152,13 +161,16 @@ SYMBOL: +stopped+ : step-into-msg ( continuation -- continuation' ) [ swap cut [ - swap % unclip { - { [ dup \ break eq? ] [ , ] } - { [ dup quotation? ] [ add-breakpoint , \ break , ] } - { [ dup array? ] [ add-breakpoint , \ break , ] } - { [ dup word? ] [ literalize , \ (step-into-execute) , ] } - [ , \ break , ] - } cond % + swap % + [ \ break , ] [ + unclip { + { [ dup \ break eq? ] [ , ] } + { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup array? ] [ add-breakpoint , \ break , ] } + { [ dup word? ] [ literalize , \ (step-into-execute) , ] } + [ , \ break , ] + } cond % + ] if-empty ] [ ] make ] change-frame ; diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 6619d331f1..320025b124 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private ; +sequences.private accessors ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -124,3 +124,42 @@ IN: kernel.tests [ [ sq ] tri@ ] must-infer [ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test + +! Test traceback accuracy +: last-frame ( -- pair ) + error-continuation get call>> callstack>array 4 head* 2 tail* ; + +[ + { [ 1 2 [ 3 throw ] call 4 ] 3 } +] [ + [ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors + last-frame +] unit-test + +[ + { [ 1 2 [ 3 throw ] dip 4 ] 3 } +] [ + [ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors + last-frame +] unit-test + +[ + { [ 1 2 3 throw [ ] call 4 ] 3 } +] [ + [ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors + last-frame +] unit-test + +[ + { [ 1 2 3 throw [ ] dip 4 ] 3 } +] [ + [ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors + last-frame +] unit-test + +[ + { [ 1 2 3 throw [ ] [ ] if 4 ] 3 } +] [ + [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors + last-frame +] unit-test diff --git a/vm/quotations.c b/vm/quotations.c index 179224f798..4a8845239b 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -348,8 +348,10 @@ worse than the duplication itself (eg, putting all state in some global struct.) */ #define COUNT(name,scan) \ { \ + CELL size = array_capacity(code_to_emit(name)) * code_format; \ if(offset == 0) return scan - 1; \ - offset -= array_capacity(code_to_emit(name)) * code_format; \ + if(offset < size) return scan + 1; \ + offset -= size; \ } F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) @@ -411,29 +413,28 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(stack_frame) COUNT(userenv[JIT_EPILOG],i) - i += 2; - COUNT(userenv[JIT_IF_JUMP],i) + i += 2; tail_call = true; break; } else if(jit_fast_dip_p(untag_object(array),i)) { - i++; COUNT(userenv[JIT_DIP],i) + i++; break; } else if(jit_fast_2dip_p(untag_object(array),i)) { - i++; COUNT(userenv[JIT_2DIP],i) + i++; break; } else if(jit_fast_3dip_p(untag_object(array),i)) { - i++; COUNT(userenv[JIT_3DIP],i) + i++; break; } case ARRAY_TYPE: From c9abd2f8683a3a54a98610f1ed2362f36f5562b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 22:05:04 -0600 Subject: [PATCH 026/441] Fix typo --- extra/mason/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index e4390d25a6..b23ad19e5e 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -47,7 +47,7 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; ".." [ bootstrap-time get boot-time-file to-file [ do-load do-compile-errors ] benchmark-ms load-time-file to-file - [ generate-help ] html-help-time-file to-file + [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file [ do-help-lint ] benchmark-ms help-lint-time-file to-file [ do-benchmarks ] benchmark-ms benchmark-time-file to-file From 915bf0c449f83bc39747d687306295b1ac41ce18 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 22:28:39 -0600 Subject: [PATCH 027/441] Fix walker with dip --- basis/tools/walker/walker.factor | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 9b2f5e4705..f1a1e3c873 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -109,25 +109,25 @@ SYMBOL: +stopped+ : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the #! continuation. - >r clone r> [ - >r clone r> + [ clone ] dip [ + [ clone ] dip [ - >r - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi - r> call + [ + [ innermost-frame-scan 1+ ] + [ innermost-frame-quot ] bi + ] dip call ] [ drop set-innermost-frame-quot ] [ drop ] 2tri ] curry change-call ; inline -: step-msg ( continuation -- continuation' ) +: step-msg ( continuation -- continuation' ) USE: io [ - 2dup nth \ break = [ - nip - ] [ - swap 1+ cut [ break ] swap 3append + 2dup length = [ nip [ break ] append ] [ + 2dup nth \ break = [ nip ] [ + swap 1+ cut [ break ] swap 3append + ] if ] if ] change-frame ; From db3c21663eec4d1b30df504caf25a5b40ecb6440 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 00:18:27 -0600 Subject: [PATCH 028/441] better literal syntax for regexps. support ^ and $ (not in multiline mode yet) but not yet in multiline mode. support for \A and \Z \z is next. removed some crud from the parser, and added more commented out unit tests... --- basis/regexp/classes/classes.factor | 10 ++ basis/regexp/nfa/nfa.factor | 19 +++- basis/regexp/parser/parser.factor | 80 ++++++++------ basis/regexp/regexp-tests.factor | 141 ++++++++++++++++-------- basis/regexp/regexp.factor | 103 ++++++++++------- basis/regexp/traversal/traversal.factor | 68 +++++++++--- 6 files changed, 283 insertions(+), 138 deletions(-) diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 7b729b2e50..f143bebdf7 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -7,6 +7,7 @@ IN: regexp.classes GENERIC: class-member? ( obj class -- ? ) M: word class-member? ( obj class -- ? ) 2drop f ; + M: integer class-member? ( obj class -- ? ) 2drop f ; M: character-class-range class-member? ( obj class -- ? ) @@ -60,3 +61,12 @@ M: java-blank-class class-member? ( obj class -- ? ) M: unmatchable-class class-member? ( obj class -- ? ) 2drop f ; + +M: terminator-class class-member? ( obj class -- ? ) + drop { + [ CHAR: \r = ] + [ CHAR: \n = ] + [ CHAR: \u000085 = ] + [ CHAR: \u002028 = ] + [ CHAR: \u002029 = ] + } 1|| ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 72d0fe970b..50847d6ff9 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -18,6 +18,9 @@ SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag +SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag +SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag +SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag : next-state ( regexp -- state ) [ state>> ] [ [ 1+ ] change-state drop ] bi ; @@ -135,7 +138,21 @@ M: non-capture-group nfa-node ( node -- ) M: reluctant-kleene-star nfa-node ( node -- ) term>> nfa-node ; -! + +: add-epsilon-flag ( flag -- ) + eps literal-transition add-simple-entry add-traversal-flag ; + +M: beginning-of-line nfa-node ( node -- ) + drop beginning-of-line add-epsilon-flag ; + +M: end-of-line nfa-node ( node -- ) + drop end-of-line add-epsilon-flag ; + +M: beginning-of-input nfa-node ( node -- ) + drop beginning-of-input add-epsilon-flag ; + +M: end-of-input nfa-node ( node -- ) + drop end-of-input add-epsilon-flag ; M: negation nfa-node ( node -- ) negation-mode inc diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 1feba62f68..ea8aaffcd5 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs combinators io io.streams.string kernel math math.parser namespaces qualified sets quotations sequences splitting symbols vectors math.order unicode.categories strings regexp.backend regexp.utils -unicode.case words ; +unicode.case words locals ; IN: regexp.parser FROM: math.ranges => [a,b] ; @@ -44,18 +44,21 @@ TUPLE: character-class-range from to ; INSTANCE: character-class-range node SINGLETON: epsilon INSTANCE: epsilon node SINGLETON: any-char INSTANCE: any-char node SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node -SINGLETON: front-anchor INSTANCE: front-anchor node -SINGLETON: back-anchor INSTANCE: back-anchor node +SINGLETON: beginning-of-input INSTANCE: beginning-of-input node +SINGLETON: end-of-input INSTANCE: end-of-input node +SINGLETON: beginning-of-line INSTANCE: beginning-of-line node +SINGLETON: end-of-line INSTANCE: end-of-line node TUPLE: option-on option ; INSTANCE: option-on node TUPLE: option-off option ; INSTANCE: option-off node -SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case reversed-regexp ; +SINGLETONS: unix-lines dotall multiline comments case-insensitive +unicode-case reversed-regexp ; SINGLETONS: letter-class LETTER-class Letter-class digit-class alpha-class non-newline-blank-class ascii-class punctuation-class java-printable-class blank-class control-character-class hex-digit-class java-blank-class c-identifier-class -unmatchable-class ; +terminator-class unmatchable-class word-boundary-class ; SINGLETONS: beginning-of-group end-of-group beginning-of-character-class end-of-character-class @@ -231,20 +234,6 @@ ERROR: invalid-range a b ; [ [ nip at-most-n ] [ at-least-n ] if* ] if ] [ drop 0 max exactly-n ] if ; -SINGLETON: beginning-of-input -SINGLETON: end-of-input - -: newlines ( -- obj1 obj2 obj3 ) - CHAR: \r - CHAR: \n - 2dup 2array ; - -: beginning-of-line ( -- obj ) - beginning-of-input newlines 4array lookbehind boa ; - -: end-of-line ( -- obj ) - end-of-input newlines 4array lookahead boa ; - : handle-front-anchor ( -- ) get-multiline beginning-of-line beginning-of-input ? push-stack ; @@ -281,13 +270,26 @@ ERROR: expected-posix-class ; : parse-control-character ( -- n ) read1 ; ERROR: bad-escaped-literals seq ; -: parse-escaped-literals ( -- obj ) - "\\E" read-until [ bad-escaped-literals ] unless + +: parse-til-E ( -- obj ) + "\\E" read-until [ bad-escaped-literals ] unless ; + +:: (parse-escaped-literals) ( quot: ( obj -- obj' ) -- obj ) + parse-til-E drop1 [ epsilon ] [ - [ ] V{ } map-as + [ quot call ] V{ } map-as first|concatenation - ] if-empty ; + ] if-empty ; inline + +: parse-escaped-literals ( -- obj ) + [ ] (parse-escaped-literals) ; + +: lower-case-literals ( -- obj ) + [ ch>lower ] (parse-escaped-literals) ; + +: upper-case-literals ( -- obj ) + [ ch>upper ] (parse-escaped-literals) ; : parse-escaped ( -- obj ) read1 @@ -299,12 +301,12 @@ ERROR: bad-escaped-literals seq ; { CHAR: a [ HEX: 7 ] } { CHAR: e [ HEX: 1b ] } - { CHAR: d [ digit-class ] } - { CHAR: D [ digit-class ] } - { CHAR: s [ java-blank-class ] } - { CHAR: S [ java-blank-class ] } { CHAR: w [ c-identifier-class ] } { CHAR: W [ c-identifier-class ] } + { CHAR: s [ java-blank-class ] } + { CHAR: S [ java-blank-class ] } + { CHAR: d [ digit-class ] } + { CHAR: D [ digit-class ] } { CHAR: p [ parse-posix-class ] } { CHAR: P [ parse-posix-class ] } @@ -313,13 +315,19 @@ ERROR: bad-escaped-literals seq ; { CHAR: 0 [ parse-octal ] } { CHAR: c [ parse-control-character ] } - ! { CHAR: b [ handle-word-boundary ] } - ! { CHAR: B [ handle-word-boundary ] } - ! { CHAR: A [ handle-beginning-of-input ] } - ! { CHAR: G [ end of previous match ] } - ! { CHAR: Z [ handle-end-of-input ] } - ! { CHAR: z [ handle-end-of-input ] } ! except for terminator + { CHAR: Q [ parse-escaped-literals ] } + ! { CHAR: b [ word-boundary-class ] } + ! { CHAR: B [ word-boundary-class ] } + ! { CHAR: A [ handle-beginning-of-input ] } + ! { CHAR: z [ handle-end-of-input ] } + + ! { CHAR: Z [ handle-end-of-input ] } ! plus a final terminator + + ! m//g mode + ! { CHAR: G [ end of previous match ] } + + ! Group capture ! { CHAR: 1 [ CHAR: 1 ] } ! { CHAR: 2 [ CHAR: 2 ] } ! { CHAR: 3 [ CHAR: 3 ] } @@ -330,7 +338,11 @@ ERROR: bad-escaped-literals seq ; ! { CHAR: 8 [ CHAR: 8 ] } ! { CHAR: 9 [ CHAR: 9 ] } - { CHAR: Q [ parse-escaped-literals ] } + ! Perl extensions + ! can't do \l and \u because \u is already a 4-hex + { CHAR: L [ lower-case-literals ] } + { CHAR: U [ upper-case-literals ] } + [ ] } case ; diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 291287f8c2..e4bab990a4 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -45,6 +45,7 @@ IN: regexp-tests ! Off by default. [ f ] [ "\n" "." matches? ] unit-test [ t ] [ "\n" "(?s)." matches? ] unit-test +[ t ] [ "\n" R/ ./s matches? ] unit-test [ f ] [ "\n\n" "(?s).(?-s)." matches? ] unit-test [ f ] [ "" ".+" matches? ] unit-test @@ -210,34 +211,34 @@ IN: regexp-tests [ 3 ] [ "aaacb" "a*" match-head ] unit-test [ 2 ] [ "aaacb" "aa?" match-head ] unit-test -[ t ] [ "aaa" "AAA" matches? ] unit-test -[ f ] [ "aax" "AAA" matches? ] unit-test -[ t ] [ "aaa" "A*" matches? ] unit-test -[ f ] [ "aaba" "A*" matches? ] unit-test -[ t ] [ "b" "[AB]" matches? ] unit-test -[ f ] [ "c" "[AB]" matches? ] unit-test -[ t ] [ "c" "[A-Z]" matches? ] unit-test -[ f ] [ "3" "[A-Z]" matches? ] unit-test +[ t ] [ "aaa" R/ AAA/i matches? ] unit-test +[ f ] [ "aax" R/ AAA/i matches? ] unit-test +[ t ] [ "aaa" R/ A*/i matches? ] unit-test +[ f ] [ "aaba" R/ A*/i matches? ] unit-test +[ t ] [ "b" R/ [AB]/i matches? ] unit-test +[ f ] [ "c" R/ [AB]/i matches? ] unit-test +[ t ] [ "c" R/ [A-Z]/i matches? ] unit-test +[ f ] [ "3" R/ [A-Z]/i matches? ] unit-test [ t ] [ "a" "(?i)a" matches? ] unit-test [ t ] [ "a" "(?i)a" matches? ] unit-test [ t ] [ "A" "(?i)a" matches? ] unit-test [ t ] [ "A" "(?i)a" matches? ] unit-test -[ t ] [ "a" "(?-i)a" matches? ] unit-test -[ t ] [ "a" "(?-i)a" matches? ] unit-test -[ f ] [ "A" "(?-i)a" matches? ] unit-test -[ f ] [ "A" "(?-i)a" matches? ] unit-test +[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test +[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test +[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test +[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test [ f ] [ "A" "[a-z]" matches? ] unit-test -[ t ] [ "A" "[a-z]" matches? ] unit-test +[ t ] [ "A" R/ [a-z]/i matches? ] unit-test [ f ] [ "A" "\\p{Lower}" matches? ] unit-test -[ t ] [ "A" "\\p{Lower}" matches? ] unit-test +[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test -[ t ] [ "abc" "abc" matches? ] unit-test -[ t ] [ "abc" "a[bB][cC]" matches? ] unit-test -[ t ] [ "adcbe" "a(?r)(bcd)(?-r)e" matches? ] unit-test +[ t ] [ "abc" R/ abc/r matches? ] unit-test +[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test +[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/r matches? ] unit-test [ t ] [ "s@f" "[a-z.-]@[a-z]" matches? ] unit-test [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test @@ -293,6 +294,9 @@ IN: regexp-tests [ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test [ f ] [ "ab" "a(?!b)" first-match ] unit-test +[ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test +[ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test +[ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test [ "a" ] [ "ab" "a(?=b)(?=b)" first-match >string ] unit-test [ "a" ] [ "ba" "a(?<=b)(?<=b)" first-match >string ] unit-test [ "a" ] [ "cab" "a(?=b)(?<=c)" first-match >string ] unit-test @@ -305,19 +309,65 @@ IN: regexp-tests ! [ "{Lower}" ] [ invalid-range? ] must-fail-with -! [ 1 ] [ "aaacb" "a+?" match-head ] unit-test -! [ 1 ] [ "aaacb" "aa??" match-head ] unit-test -! [ f ] [ "aaaab" "a++ab" matches? ] unit-test -! [ t ] [ "aaacb" "a++cb" matches? ] unit-test -! [ 3 ] [ "aacb" "aa?c" match-head ] unit-test -! [ 3 ] [ "aacb" "aa??c" match-head ] unit-test +[ t ] [ "a" R/ ^a/ matches? ] unit-test +[ f ] [ "\na" R/ ^a/ matches? ] unit-test +[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test +[ f ] [ "\ra" R/ ^a/ matches? ] unit-test -! [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test -! [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test +[ t ] [ "a" R/ a$/ matches? ] unit-test +[ f ] [ "a\n" R/ a$/ matches? ] unit-test +[ f ] [ "a\r" R/ a$/ matches? ] unit-test +[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test + +! [ t ] [ "a" R/ \Aa/ matches? ] unit-test +! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test +! [ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test +! [ f ] [ "\ra" R/ \Aa/ matches? ] unit-test + +! [ t ] [ "a" R/ \Aa/m matches? ] unit-test +! [ f ] [ "\na" R/ \Aaa/m matches? ] unit-test +! [ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test +! [ f ] [ "\ra" R/ \Aa/m matches? ] unit-test + +! [ t ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test + +! [ t ] [ "a" R/ \Aa\z/m matches? ] unit-test +! [ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test + +! [ t ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test +! [ t ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test + +! [ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test +! [ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test +! [ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test +! [ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test + +! [ t ] [ "a" R/ ^a/m matches? ] unit-test +! [ t ] [ "\na" R/ ^a/m matches? ] unit-test +! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test +! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test + +! Convert to lowercase until E +[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test +[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test + +! Convert to uppercase until E +[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test +[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test + +! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test +! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test +! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test +! [ t ] [ "a\r\n" "a$" R/ a$/m matches? ] unit-test ! [ f ] [ "foobxr" "foo\\z" match-head ] unit-test ! [ 3 ] [ "foo" "foo\\z" match-head ] unit-test +! [ t ] [ "foo" "\\bfoo\\b" matches? ] unit-test +! [ t ] [ "afoob" "\\Bfoo\\B" matches? ] unit-test +! [ t ] [ "afoob" "\\bfoo\\b" matches? ] unit-test +! [ f ] [ "foo" "\\Bfoo\\B" matches? ] unit-test + ! [ 3 ] [ "foo bar" "foo\\b" match-head ] unit-test ! [ f ] [ "fooxbar" "foo\\b" matches? ] unit-test ! [ t ] [ "foo" "foo\\b" matches? ] unit-test @@ -332,34 +382,29 @@ IN: regexp-tests ! [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test ! [ f ] [ "foo" "foo\\Bbar" matches? ] unit-test -! clear "a(?=b*)" "ab" over match -! clear "a(?=b*c)" "abbbbbc" over match -! clear "a(?=b*)" "ab" over match +! [ 1 ] [ "aaacb" "a+?" match-head ] unit-test +! [ 1 ] [ "aaacb" "aa??" match-head ] unit-test +! [ f ] [ "aaaab" "a++ab" matches? ] unit-test +! [ t ] [ "aaacb" "a++cb" matches? ] unit-test +! [ 3 ] [ "aacb" "aa?c" match-head ] unit-test +! [ 3 ] [ "aacb" "aa??c" match-head ] unit-test -! clear "^a" "a" over match -! clear "^a" "\na" over match -! clear "^a" "\r\na" over match -! clear "^a" "\ra" over match +! "ab" "a(?=b*)" match +! "abbbbbc" "a(?=b*c)" match +! "ab" "a(?=b*)" match -! clear "a$" "a" over match -! clear "a$" "a\n" over match -! clear "a$" "a\r" over match -! clear "a$" "a\r\n" over match +! "baz" "(az)(?<=b)" first-match +! "cbaz" "a(?<=b*)" first-match +! "baz" "a(?<=b)" first-match -! "(az)(?<=b)" "baz" over first-match -! "a(?<=b*)" "cbaz" over first-match -! "a(?<=b)" "baz" over first-match +! "baz" "a(? first-match +! "caz" "a(? first-match -! "a(? "baz" over first-match -! "a(? "caz" over first-match +! "abcdefg" "a(?=bcdefg)bcd" first-match +! "abcdefg" "a(?#bcdefg)bcd" first-match +! "abcdefg" "a(?:bcdefg)" first-match -! "a(?=bcdefg)bcd" "abcdefg" over first-match -! "a(?#bcdefg)bcd" "abcdefg" over first-match -! "a(?:bcdefg)" "abcdefg" over first-match - -[ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test - -! "a(?<=b)" "caba" over first-match +! "caba" "a(?<=b)" first-match ! capture group 1: "aaaa" 2: "" ! "aaaa" "(a*)(a*)" match* diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 652d943090..e61d5692f4 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel math sequences +USING: accessors combinators kernel math sequences strings sets assocs prettyprint.backend make lexer namespaces parser arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa -regexp.dfa regexp.traversal regexp.transition-tables splitting ; +regexp.dfa regexp.traversal regexp.transition-tables splitting +sorting ; IN: regexp : default-regexp ( string -- regexp ) @@ -75,40 +76,7 @@ IN: regexp : count-matches ( string regexp -- n ) all-matches length ; -: initial-option ( regexp option -- regexp' ) - over options>> conjoin ; - -: ( string -- regexp ) - default-regexp construct-regexp ; - -: ( string -- regexp ) - default-regexp - case-insensitive initial-option - construct-regexp ; - -: ( string -- regexp ) - default-regexp - reversed-regexp initial-option - construct-regexp ; - -: parsing-regexp ( accum end -- accum ) - lexer get dup skip-blank - [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column - lexer get dup still-parsing-line? - [ (parse-token) ] [ drop f ] if - "i" = [ ] [ ] if parsed ; - -: R! CHAR: ! parsing-regexp ; parsing -: R" CHAR: " parsing-regexp ; parsing -: R# CHAR: # parsing-regexp ; parsing -: R' CHAR: ' parsing-regexp ; parsing -: R( CHAR: ) parsing-regexp ; parsing -: R/ CHAR: / parsing-regexp ; parsing -: R@ CHAR: @ parsing-regexp ; parsing -: R[ CHAR: ] parsing-regexp ; parsing -: R` CHAR: ` parsing-regexp ; parsing -: R{ CHAR: } parsing-regexp ; parsing -: R| CHAR: | parsing-regexp ; parsing +> key? ; +ERROR: unknown-regexp-option option ; + +: option>ch ( option -- string ) + { + { case-insensitive [ CHAR: i ] } + { multiline [ CHAR: m ] } + { reversed-regexp [ CHAR: r ] } + { dotall [ CHAR: s ] } + [ unknown-regexp-option ] + } case ; + +: ch>option ( ch -- option ) + { + { CHAR: i [ case-insensitive ] } + { CHAR: m [ multiline ] } + { CHAR: r [ reversed-regexp ] } + { CHAR: s [ dotall ] } + [ unknown-regexp-option ] + } case ; + +: string>options ( string -- options ) + [ ch>option dup ] H{ } map>assoc ; + +: options>string ( options -- string ) + keys [ option>ch ] map natural-sort >string ; + +PRIVATE> + +: ( string option-string -- regexp ) + [ default-regexp ] [ string>options ] bi* >>options + construct-regexp ; + +: ( string -- regexp ) "" ; + + parsed ; + +PRIVATE> + +: R! CHAR: ! parsing-regexp ; parsing +: R" CHAR: " parsing-regexp ; parsing +: R# CHAR: # parsing-regexp ; parsing +: R' CHAR: ' parsing-regexp ; parsing +: R( CHAR: ) parsing-regexp ; parsing +: R/ CHAR: / parsing-regexp ; parsing +: R@ CHAR: @ parsing-regexp ; parsing +: R[ CHAR: ] parsing-regexp ; parsing +: R` CHAR: ` parsing-regexp ; parsing +: R{ CHAR: } parsing-regexp ; parsing +: R| CHAR: | parsing-regexp ; parsing M: regexp pprint* [ [ - dup raw>> - dup find-regexp-syntax swap % swap % % - case-insensitive swap option? [ "i" % ] when + [ raw>> dup find-regexp-syntax swap % swap % % ] + [ options>> options>string % ] bi ] "" make ] keep present-text ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index 86d315ee2f..c880c11c53 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -17,6 +17,7 @@ TUPLE: dfa-traverser capture-group-index last-state current-state text + match-failed? start-index current-index matches ; @@ -37,14 +38,20 @@ TUPLE: dfa-traverser H{ } clone >>captured-groups ; : final-state? ( dfa-traverser -- ? ) - [ current-state>> ] [ dfa-table>> final-states>> ] bi - key? ; + [ current-state>> ] + [ dfa-table>> final-states>> ] bi key? ; + +: beginning-of-text? ( dfa-traverser -- ? ) + current-index>> 0 <= ; inline + +: end-of-text? ( dfa-traverser -- ? ) + [ current-index>> ] [ text>> length ] bi >= ; inline : text-finished? ( dfa-traverser -- ? ) { [ current-state>> empty? ] - [ [ current-index>> ] [ text>> length ] bi >= ] - ! [ current-index>> 0 < ] + [ end-of-text? ] + [ match-failed?>> ] } 1|| ; : save-final-state ( dfa-straverser -- ) @@ -55,8 +62,47 @@ TUPLE: dfa-traverser dup save-final-state ] when text-finished? ; +: previous-text-character ( dfa-traverser -- ch ) + [ text>> ] [ current-index>> 1- ] bi nth ; + +: current-text-character ( dfa-traverser -- ch ) + [ text>> ] [ current-index>> ] bi nth ; + +: next-text-character ( dfa-traverser -- ch ) + [ text>> ] [ current-index>> 1+ ] bi nth ; + GENERIC: flag-action ( dfa-traverser flag -- ) + +M: beginning-of-input flag-action ( dfa-traverser flag -- ) + drop + dup beginning-of-text? [ t >>match-failed? ] unless drop ; + +M: end-of-input flag-action ( dfa-traverser flag -- ) + drop + dup end-of-text? [ t >>match-failed? ] unless drop ; + +M: beginning-of-line flag-action ( dfa-traverser flag -- ) + drop + dup { + [ beginning-of-text? ] + [ previous-text-character terminator-class class-member? ] + } 1|| [ t >>match-failed? ] unless drop ; + +M: end-of-line flag-action ( dfa-traverser flag -- ) + drop + dup { + [ end-of-text? ] + [ next-text-character terminator-class class-member? ] + } 1|| [ t >>match-failed? ] unless drop ; + +M: word-boundary flag-action ( dfa-traverser flag -- ) + drop + dup { + [ end-of-text? ] + [ current-text-character terminator-class class-member? ] + } 1|| [ t >>match-failed? ] unless drop ; + M: lookahead-on flag-action ( dfa-traverser flag -- ) drop lookahead-counters>> 0 swap push ; @@ -110,11 +156,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) [ [ 1+ ] change-current-index ] [ [ 1- ] change-current-index ] if dup current-state>> >>last-state - ] dip - first >>current-state ; - -: match-failed ( dfa-traverser -- dfa-traverser ) - V{ } clone >>matches ; + ] [ first ] bi* >>current-state ; : match-literal ( transition from-state table -- to-state/f ) transitions>> at at ; @@ -131,11 +173,9 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; : setup-match ( match -- obj state dfa-table ) - { - [ current-index>> ] [ text>> ] - [ current-state>> ] [ dfa-table>> ] - } cleave - [ nth ] 2dip ; + [ [ current-index>> ] [ text>> ] bi nth ] + [ current-state>> ] + [ dfa-table>> ] tri ; : do-match ( dfa-traverser -- dfa-traverser ) dup process-flags From 7c42a9ce6b5f9c6d8e06ef875efcd88efb575f56 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 00:20:38 -0600 Subject: [PATCH 029/441] improved regexp literals caught some typos --- extra/benchmark/regex-dna/regex-dna.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/benchmark/regex-dna/regex-dna.factor b/extra/benchmark/regex-dna/regex-dna.factor index 0c21de0363..8c0aee596d 100644 --- a/extra/benchmark/regex-dna/regex-dna.factor +++ b/extra/benchmark/regex-dna/regex-dna.factor @@ -11,14 +11,14 @@ IN: benchmark.regex-dna : count-patterns ( string -- ) { - R/ agggtaaa|tttaccct/i, - R/ [cgt]gggtaaa|tttaccc[acg]/i, - R/ a[act]ggtaaa|tttacc[agt]t/i, - R/ ag[act]gtaaa|tttac[agt]ct/i, - R/ agg[act]taaa|ttta[agt]cct/i, - R/ aggg[acg]aaa|ttt[cgt]ccct/i, - R/ agggt[cgt]aa|tt[acg]accct/i, - R/ agggta[cgt]a|t[acg]taccct/i, + R/ agggtaaa|tttaccct/i + R/ [cgt]gggtaaa|tttaccc[acg]/i + R/ a[act]ggtaaa|tttacc[agt]t/i + R/ ag[act]gtaaa|tttac[agt]ct/i + R/ agg[act]taaa|ttta[agt]cct/i + R/ aggg[acg]aaa|ttt[cgt]ccct/i + R/ agggt[cgt]aa|tt[acg]accct/i + R/ agggta[cgt]a|t[acg]taccct/i R/ agggtaa[cgt]|[acg]ttaccct/i } [ [ raw>> write bl ] From d86524f4bc019af43d23b1219cfcfe431cabe00d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 00:23:17 -0600 Subject: [PATCH 030/441] Non-optimizing compiler now compiles dip, 2dip, 3dip, if, with direct branches instead of indirect branches. 8% bootstrap time improvement on Core Duo 2 --- basis/bootstrap/image/image.factor | 9 ++-- basis/bootstrap/stage2.factor | 10 ++-- basis/cpu/x86/assembler/assembler.factor | 3 ++ basis/cpu/x86/bootstrap.factor | 61 +++++++++++------------- vm/code_heap.c | 8 +++- vm/image.c | 18 ------- vm/quotations.c | 15 +++++- vm/run.h | 3 +- 8 files changed, 63 insertions(+), 64 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index d5f36db776..3adebbcd44 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -127,7 +127,8 @@ SYMBOL: jit-word-call SYMBOL: jit-push-literal SYMBOL: jit-push-immediate SYMBOL: jit-if-word -SYMBOL: jit-if-jump +SYMBOL: jit-if-1 +SYMBOL: jit-if-2 SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch SYMBOL: jit-dip-word @@ -157,7 +158,7 @@ SYMBOL: undefined-quot { jit-word-call 27 } { jit-push-literal 28 } { jit-if-word 29 } - { jit-if-jump 30 } + { jit-if-1 30 } { jit-dispatch-word 31 } { jit-dispatch 32 } { jit-epilog 33 } @@ -172,6 +173,7 @@ SYMBOL: undefined-quot { jit-2dip 47 } { jit-3dip-word 48 } { jit-3dip 49 } + { jit-if-2 50 } { undefined-quot 60 } } ; inline @@ -472,7 +474,8 @@ M: quotation ' jit-push-literal jit-push-immediate jit-if-word - jit-if-jump + jit-if-1 + jit-if-2 jit-dispatch-word jit-dispatch jit-dip-word diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index ac8e5343e1..f310944d02 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -32,8 +32,8 @@ SYMBOL: bootstrap-time : count-words ( pred -- ) all-words swap count number>string write ; -: print-time ( us -- ) - 1000000 /i +: print-time ( ms -- ) + 1000 /i 60 /mod swap number>string write " minutes and " write number>string write " seconds." print ; @@ -52,7 +52,7 @@ SYMBOL: bootstrap-time [ ! We time bootstrap - micros + millis default-image-name "output-image" set-global @@ -77,7 +77,7 @@ SYMBOL: bootstrap-time [ load-components - micros over - core-bootstrap-time set-global + millis over - core-bootstrap-time set-global run-bootstrap-init ] with-compiler-errors @@ -100,7 +100,7 @@ SYMBOL: bootstrap-time ] [ print-error 1 exit ] recover ] set-boot-quot - micros swap - bootstrap-time set-global + millis swap - bootstrap-time set-global print-report "output-image" get save-image-and-exit diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 5c6fff2348..c51c3783d4 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -308,18 +308,21 @@ M: operand MOV HEX: 88 2-operand ; ! Control flow GENERIC: JMP ( op -- ) : (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; +M: f JMP (JMP) 2drop ; M: callable JMP (JMP) rel-word ; M: label JMP (JMP) label-fixup ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; +M: f CALL (CALL) 2drop ; M: callable CALL (CALL) rel-word ; M: label CALL (CALL) label-fixup ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) : (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ; +M: f JUMPcc nip (JUMPcc) drop ; M: callable JUMPcc (JUMPcc) rel-word ; M: label JUMPcc (JUMPcc) label-fixup ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index af7c9e2f0f..1a54131435 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -45,22 +45,23 @@ big-endian off ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define [ - (JMP) drop + f JMP ] rc-relative rt-xt 1 jit-word-jump jit-define [ - (CALL) drop + f CALL ] rc-relative rt-xt 1 jit-word-call jit-define [ - arg1 0 MOV ! load addr of true quotation arg0 ds-reg [] MOV ! load boolean ds-reg bootstrap-cell SUB ! pop boolean - arg0 \ f tag-number CMP ! compare it with f - arg0 arg1 [] CMOVNE ! load true branch if not equal - arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal - arg0 quot-xt-offset [+] JMP ! jump to quotation-xt -] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define + arg0 \ f tag-number CMP ! compare boolean with f + f JNE ! jump to true branch if not equal +] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define + +[ + f JMP ! jump to false branch if equal +] rc-relative rt-xt 1 jit-if-2 jit-define [ arg1 0 MOV ! load dispatch table @@ -73,79 +74,71 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define -! The jit->r words cannot clobber arg0 - : jit->r ( -- ) rs-reg bootstrap-cell ADD - temp-reg ds-reg [] MOV + arg0 ds-reg [] MOV ds-reg bootstrap-cell SUB - rs-reg [] temp-reg MOV ; + rs-reg [] arg0 MOV ; : jit-2>r ( -- ) rs-reg 2 bootstrap-cells ADD - temp-reg ds-reg [] MOV + arg0 ds-reg [] MOV arg1 ds-reg -1 bootstrap-cells [+] MOV ds-reg 2 bootstrap-cells SUB - rs-reg [] temp-reg MOV + rs-reg [] arg0 MOV rs-reg -1 bootstrap-cells [+] arg1 MOV ; : jit-3>r ( -- ) rs-reg 3 bootstrap-cells ADD - temp-reg ds-reg [] MOV + arg0 ds-reg [] MOV arg1 ds-reg -1 bootstrap-cells [+] MOV arg2 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells SUB - rs-reg [] temp-reg MOV + rs-reg [] arg0 MOV rs-reg -1 bootstrap-cells [+] arg1 MOV rs-reg -2 bootstrap-cells [+] arg2 MOV ; : jit-r> ( -- ) ds-reg bootstrap-cell ADD - temp-reg rs-reg [] MOV + arg0 rs-reg [] MOV rs-reg bootstrap-cell SUB - ds-reg [] temp-reg MOV ; + ds-reg [] arg0 MOV ; : jit-2r> ( -- ) ds-reg 2 bootstrap-cells ADD - temp-reg rs-reg [] MOV + arg0 rs-reg [] MOV arg1 rs-reg -1 bootstrap-cells [+] MOV rs-reg 2 bootstrap-cells SUB - ds-reg [] temp-reg MOV + ds-reg [] arg0 MOV ds-reg -1 bootstrap-cells [+] arg1 MOV ; : jit-3r> ( -- ) ds-reg 3 bootstrap-cells ADD - temp-reg rs-reg [] MOV + arg0 rs-reg [] MOV arg1 rs-reg -1 bootstrap-cells [+] MOV arg2 rs-reg -2 bootstrap-cells [+] MOV rs-reg 3 bootstrap-cells SUB - ds-reg [] temp-reg MOV + ds-reg [] arg0 MOV ds-reg -1 bootstrap-cells [+] arg1 MOV ds-reg -2 bootstrap-cells [+] arg2 MOV ; [ - arg0 0 MOV ! load quotation addr - arg0 arg0 [] MOV ! load quotation jit->r - arg0 quot-xt-offset [+] CALL ! call quotation + f CALL jit-r> -] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define +] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define [ - arg0 0 MOV ! load quotation addr - arg0 arg0 [] MOV ! load quotation jit-2>r - arg0 quot-xt-offset [+] CALL ! call quotation + f CALL jit-2r> -] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define +] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define [ - arg0 0 MOV ! load quotation addr - arg0 arg0 [] MOV ! load quotation jit-3>r - arg0 quot-xt-offset [+] CALL ! call quotation + f CALL jit-3r> -] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define +] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame diff --git a/vm/code_heap.c b/vm/code_heap.c index f3a4071e98..a4577aeb9a 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -55,6 +55,8 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) INLINE CELL compute_code_rel(F_REL *rel, CELL code_start, CELL literals_start) { + CELL obj; + switch(REL_TYPE(rel)) { case RT_PRIMITIVE: @@ -66,7 +68,11 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_IMMEDIATE: return get(CREF(literals_start,REL_ARGUMENT(rel))); case RT_XT: - return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; + obj = get(CREF(literals_start,REL_ARGUMENT(rel))); + if(type_of(obj) == WORD_TYPE) + return (CELL)untag_word(obj)->xt; + else + return (CELL)untag_quotation(obj)->xt; case RT_HERE: return rel->offset + code_start + (short)REL_ARGUMENT(rel); case RT_LABEL: diff --git a/vm/image.c b/vm/image.c index 0e6591f8d8..6fb5910392 100755 --- a/vm/image.c +++ b/vm/image.c @@ -174,21 +174,6 @@ void primitive_save_image(void) save_image(unbox_native_string()); } -void strip_compiled_quotations(void) -{ - begin_scan(); - CELL obj; - while((obj = next_object()) != F) - { - if(type_of(obj) == QUOTATION_TYPE) - { - F_QUOTATION *quot = untag_object(obj); - quot->compiledp = F; - } - } - gc_off = false; -} - void primitive_save_image_and_exit(void) { /* We unbox this before doing anything else. This is the only point @@ -198,9 +183,6 @@ void primitive_save_image_and_exit(void) REGISTER_C_STRING(path); - /* This reduces deployed image size */ - strip_compiled_quotations(); - /* strip out userenv data which is set on startup anyway */ CELL i; for(i = 0; i < FIRST_SAVE_ENV; i++) diff --git a/vm/quotations.c b/vm/quotations.c index 4a8845239b..6524bf9d0b 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -251,9 +251,13 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) EMIT(userenv[JIT_EPILOG],0); + jit_compile(array_nth(untag_object(array),i),true); + jit_compile(array_nth(untag_object(array),i + 1),true); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + EMIT(userenv[JIT_IF_1],literals_count - 1); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); - EMIT(userenv[JIT_IF_JUMP],literals_count - 2); + EMIT(userenv[JIT_IF_2],literals_count - 1); i += 2; @@ -262,6 +266,8 @@ void jit_compile(CELL quot, bool relocate) } else if(jit_fast_dip_p(untag_object(array),i)) { + jit_compile(obj,true); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_DIP],literals_count - 1); @@ -270,6 +276,8 @@ void jit_compile(CELL quot, bool relocate) } else if(jit_fast_2dip_p(untag_object(array),i)) { + jit_compile(obj,true); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_2DIP],literals_count - 1); @@ -278,6 +286,8 @@ void jit_compile(CELL quot, bool relocate) } else if(jit_fast_3dip_p(untag_object(array),i)) { + jit_compile(obj,true); + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_3DIP],literals_count - 1); @@ -413,7 +423,8 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(stack_frame) COUNT(userenv[JIT_EPILOG],i) - COUNT(userenv[JIT_IF_JUMP],i) + COUNT(userenv[JIT_IF_1],i) + COUNT(userenv[JIT_IF_2],i) i += 2; tail_call = true; diff --git a/vm/run.h b/vm/run.h index eae0146298..b4118b09d8 100755 --- a/vm/run.h +++ b/vm/run.h @@ -41,7 +41,7 @@ typedef enum { JIT_WORD_CALL, JIT_PUSH_LITERAL, JIT_IF_WORD, - JIT_IF_JUMP, + JIT_IF_1, JIT_DISPATCH_WORD, JIT_DISPATCH, JIT_EPILOG, @@ -56,6 +56,7 @@ typedef enum { JIT_2DIP, JIT_3DIP_WORD, JIT_3DIP, + JIT_IF_2, STACK_TRACES_ENV = 59, From 87bc7d8c8b6c530de1b826d5a8442cc9cd966166 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 00:29:34 -0600 Subject: [PATCH 031/441] Update PPC non-optimizing compiler backend --- basis/cpu/ppc/bootstrap.factor | 39 +++++++++++++--------------------- 1 file changed, 15 insertions(+), 24 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index c0fbfaa21b..9003757b78 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -82,15 +82,16 @@ big-endian on BLRL ; [ - 0 3 LOAD32 - 6 ds-reg 0 LWZ - 0 6 \ f tag-number CMPI - 2 BNE - 3 3 4 ADDI - 3 3 0 LWZ + 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - jit-jump-quot -] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define + 0 3 \ f tag-number CMPI + 2 BNE + 0 B +] rc-relative-ppc-3 rt-xt 3 jit-if-1 jit-define + +[ + 0 B +] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define [ 0 3 LOAD32 @@ -103,9 +104,6 @@ big-endian on jit-jump-quot ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define -! These should not clobber r3 since we store a quotation in there -! in jit-dip - : jit->r ( -- ) 4 ds-reg 0 LWZ ds-reg dup 4 SUBI @@ -152,30 +150,23 @@ big-endian on 5 ds-reg -4 STW 6 ds-reg -8 STW ; -: prepare-dip ( -- ) - 0 3 LOAD32 - 3 3 0 LWZ ; - [ - prepare-dip jit->r - jit-call-quot + 0 BL jit-r> -] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define +] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define [ - prepare-dip jit-2>r - jit-call-quot + 0 BL jit-2r> -] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define +] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define [ - prepare-dip jit-3>r - jit-call-quot + 0 BL jit-3r> -] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define +] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define [ 0 1 lr-save stack-frame + LWZ From b48c051b1b0f6b519cf7404fc33aba454419fa56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 00:51:29 -0600 Subject: [PATCH 032/441] Fix Windows overlapped timeout code for microseconds --- basis/io/windows/nt/backend/backend.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor index 73b77508b7..1431ff3d30 100644 --- a/basis/io/windows/nt/backend/backend.factor +++ b/basis/io/windows/nt/backend/backend.factor @@ -48,12 +48,12 @@ M: winnt add-completion ( win32-handle -- ) } cond ] with-timeout ; -:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? ) +:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) master-completion-port get-global 0 [ ! bytes f ! key f [ ! overlapped - ms INFINITE or ! timeout + us 1000 /i INFINITE or ! timeout GetQueuedCompletionStatus zero? ] keep *void* ] keep *int spin ; @@ -61,7 +61,7 @@ M: winnt add-completion ( win32-handle -- ) : resume-callback ( result overlapped -- ) pending-overlapped get-global delete-at* drop resume-with ; -: handle-overlapped ( timeout -- ? ) +: handle-overlapped ( us -- ? ) wait-for-overlapped [ dup [ >r drop GetLastError 1array r> resume-callback t @@ -75,7 +75,7 @@ M: winnt add-completion ( win32-handle -- ) M: win32-handle cancel-operation [ check-disposed ] [ handle>> CancelIo drop ] bi ; -M: winnt io-multiplex ( ms -- ) +M: winnt io-multiplex ( us -- ) handle-overlapped [ 0 io-multiplex ] when ; M: winnt init-io ( -- ) From fb511f4fe8c754add77be5cf697318e6b9976037 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 00:51:46 -0600 Subject: [PATCH 033/441] Fix help lint --- basis/present/present-docs.factor | 2 +- basis/threads/threads.factor | 2 +- core/io/backend/backend.factor | 4 ++-- core/system/system-docs.factor | 3 ++- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/present/present-docs.factor b/basis/present/present-docs.factor index bda7723173..0428235c2a 100644 --- a/basis/present/present-docs.factor +++ b/basis/present/present-docs.factor @@ -8,6 +8,6 @@ ARTICLE: "present" "Converting objects to human-readable strings" HELP: present { $values { "object" object } { "string" string } } { $contract "Outputs a human-readable string from an object." } -{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ; +{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $vocab-link "urls" } " vocabularies." } ; ABOUT: "present" diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 5dca7be633..4332bbbcf5 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -89,7 +89,7 @@ PRIVATE> f >>state check-registered 2array run-queue push-front ; -: sleep-time ( -- ms/f ) +: sleep-time ( -- us/f ) { { [ run-queue deque-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 0c13277106..5456f2251c 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -8,7 +8,7 @@ SYMBOL: io-backend SINGLETON: c-io-backend -c-io-backend io-backend set-global +io-backend global [ c-io-backend or ] change-at HOOK: init-io io-backend ( -- ) @@ -20,7 +20,7 @@ HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) [ utf8 output-stream set-global ] [ utf8 error-stream set-global ] tri* ; -HOOK: io-multiplex io-backend ( ms -- ) +HOOK: io-multiplex io-backend ( us -- ) HOOK: normalize-directory io-backend ( str -- newstr ) diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 3adf82af7f..ab17ce2be9 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -12,6 +12,7 @@ ARTICLE: "system" "System interface" { $subsection image } "Getting the current time:" { $subsection micros } +{ $subsection millis } "Exiting the Factor VM:" { $subsection exit } ; @@ -70,7 +71,7 @@ HELP: micros ( -- us ) { $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ; HELP: millis ( -- ms ) -{ $values { "us" integer } } +{ $values { "ms" integer } } { $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." } { $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ; From 3c378d46ef1e9f202c51ec3eda15be08622678c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 00:52:40 -0600 Subject: [PATCH 034/441] Fix sequences.deep tests --- basis/sequences/deep/deep-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/sequences/deep/deep-tests.factor b/basis/sequences/deep/deep-tests.factor index a88634aa8a..522b5ecdf9 100644 --- a/basis/sequences/deep/deep-tests.factor +++ b/basis/sequences/deep/deep-tests.factor @@ -4,11 +4,11 @@ IN: sequences.deep.tests [ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test -[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find-from ] unit-test +[ "foo" t ] [ { { "foo" } "bar" } [ string? ] (deep-find) ] unit-test -[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find-from ] unit-test +[ f f ] [ { { "foo" } "bar" } [ number? ] (deep-find) ] unit-test -[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find-from ] unit-test +[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] (deep-find) ] unit-test : change-something ( seq -- newseq ) dup array? [ "hi" suffix ] [ "hello" append ] if ; From 10238715f0be94935022448ba581fb5a282370d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 00:57:31 -0600 Subject: [PATCH 035/441] Fix load error in irc.ui --- extra/irc/ui/commandparser/commandparser.factor | 2 -- extra/irc/ui/ui.factor | 4 +++- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/irc/ui/commandparser/commandparser.factor b/extra/irc/ui/commandparser/commandparser.factor index 163517698a..5179997b0d 100755 --- a/extra/irc/ui/commandparser/commandparser.factor +++ b/extra/irc/ui/commandparser/commandparser.factor @@ -5,8 +5,6 @@ USING: kernel vocabs.loader sequences strings splitting words irc.messages ; IN: irc.ui.commandparser -"irc.ui.commands" require - : command ( string string -- string command ) [ "say" ] when-empty dup "irc.ui.commands" lookup diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index e854d285b7..b96d3e1bdc 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages - irc.ui.commandparser irc.ui.load ; + irc.ui.commandparser irc.ui.load vocabs.loader ; RENAME: join sequences => sjoin @@ -245,3 +245,5 @@ M: irc-tab pref-dim* : main-run ( -- ) run-ircui ; MAIN: main-run + +"irc.ui.commands" require From 23ac947162497de706d3e7f70eb3b3f8d7bfda8d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 01:21:18 -0600 Subject: [PATCH 036/441] remove --- basis/regexp/regexp-docs.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index f6a1fe1876..378ae503ce 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -6,9 +6,3 @@ IN: regexp HELP: { $values { "string" string } { "regexp" regexp } } { $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ; - -HELP: -{ $values { "string" string } { "regexp" regexp } } -{ $description "Compiles a case-insensitive regular expression into a DFA and returns this object. Otherwise, exactly the same as " { $link } } ; - -{ } related-words From dbf52c6176b6b4831898e7fc5c46e23624a2e2b2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 01:45:36 -0600 Subject: [PATCH 037/441] Fix PowerPC bootstrap --- basis/cpu/ppc/bootstrap.factor | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 9003757b78..512fff798b 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -71,28 +71,23 @@ big-endian on [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define -: jit-jump-quot ( -- ) - 4 3 quot-xt-offset LWZ - 4 MTCTR - BCTR ; - -: jit-call-quot ( -- ) - 4 3 quot-xt-offset LWZ - 4 MTLR - BLRL ; - [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI 0 3 \ f tag-number CMPI - 2 BNE + 2 BEQ 0 B -] rc-relative-ppc-3 rt-xt 3 jit-if-1 jit-define +] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define +: jit-jump-quot ( -- ) + 4 3 quot-xt-offset LWZ + 4 MTCTR + BCTR ; + [ 0 3 LOAD32 3 3 0 LWZ @@ -128,9 +123,9 @@ big-endian on 6 rs-reg -8 STW ; : jit-r> ( -- ) - 4 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 rs-reg 4 STWU ; + 4 rs-reg 0 LWZ + rs-reg dup 4 SUBI + 4 ds-reg 4 STWU ; : jit-2r> ( -- ) 4 rs-reg 0 LWZ From 8663ca2982081331ba6bc3140ffccd19b0e5d277 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 02:03:01 -0600 Subject: [PATCH 038/441] Fix VM for PowerPC --- vm/quotations.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/vm/quotations.c b/vm/quotations.c index 6524bf9d0b..44404c10f0 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -251,8 +251,8 @@ void jit_compile(CELL quot, bool relocate) if(stack_frame) EMIT(userenv[JIT_EPILOG],0); - jit_compile(array_nth(untag_object(array),i),true); - jit_compile(array_nth(untag_object(array),i + 1),true); + jit_compile(array_nth(untag_object(array),i),relocate); + jit_compile(array_nth(untag_object(array),i + 1),relocate); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_IF_1],literals_count - 1); @@ -266,7 +266,7 @@ void jit_compile(CELL quot, bool relocate) } else if(jit_fast_dip_p(untag_object(array),i)) { - jit_compile(obj,true); + jit_compile(obj,relocate); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_DIP],literals_count - 1); @@ -276,7 +276,7 @@ void jit_compile(CELL quot, bool relocate) } else if(jit_fast_2dip_p(untag_object(array),i)) { - jit_compile(obj,true); + jit_compile(obj,relocate); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_2DIP],literals_count - 1); @@ -286,7 +286,7 @@ void jit_compile(CELL quot, bool relocate) } else if(jit_fast_3dip_p(untag_object(array),i)) { - jit_compile(obj,true); + jit_compile(obj,relocate); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); EMIT(userenv[JIT_3DIP],literals_count - 1); From 1fc2d4afbd2bf712f90d63382b0cac41e268e202 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 02:03:08 -0600 Subject: [PATCH 039/441] Fix compile errors in nehe demos --- extra/nehe/4/4.factor | 2 +- extra/nehe/5/5.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index 10217c93cb..fda22d2f1e 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -7,7 +7,7 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; -: redraw-interval 10 milliseconds ; +: redraw-interval ( -- dt ) 10 milliseconds ; : ( -- gadget ) nehe4-gadget new-gadget diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index 2c9b51c63f..30d0991fd8 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -6,7 +6,7 @@ IN: nehe.5 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; -: redraw-interval 10 milliseconds ; +: redraw-interval ( -- dt ) 10 milliseconds ; : ( -- gadget ) nehe5-gadget new-gadget From 47ef542e92c1faffa536c4680e97e19a506184ae Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 24 Nov 2008 10:18:47 +0100 Subject: [PATCH 040/441] Emacs factor mode: defun and sexp navigation are aware of word definition syntax. --- misc/factor.el | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 3c5b6bb544..c8e637f268 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -204,7 +204,7 @@ buffer." (defconst factor--regex-using-line "^USING: +\\([^;]*\\);") (defconst factor--regex-use-line "^USE: +\\(.*\\)$") -(defconst factor-font-lock-keywords +(defconst factor--font-lock-keywords `(("( .* )" . 'factor-font-lock-stack-effect) ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") @@ -502,17 +502,25 @@ buffer." (use-local-map factor-mode-map) (setq major-mode 'factor-mode) (setq mode-name "Factor") + ;; Font locking (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'parse-sexp-lookup-properties) t) (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment) (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string) (set (make-local-variable 'font-lock-defaults) - `(factor-font-lock-keywords + `(factor--font-lock-keywords nil nil nil nil (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords))) + (set-syntax-table factor-mode-syntax-table) + ;; Defun navigation + (setq defun-prompt-regexp "[^ :]+") + (set (make-local-variable 'open-paren-in-column-0-is-defun-start) t) + ;; Indentation (set (make-local-variable 'indent-line-function) 'factor--indent-line) (setq factor-indent-width (factor--guess-indent-width)) (setq indent-tabs-mode nil) + (run-hooks 'factor-mode-hook)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) @@ -568,6 +576,7 @@ buffer." "Generic word contract" "Inputs and outputs" "Parent topics:" + "See also" "Syntax" "Vocabulary" "Warning" @@ -578,7 +587,7 @@ buffer." (defconst factor--help-font-lock-keywords `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines) - ,@factor-font-lock-keywords)) + ,@factor--font-lock-keywords)) (defun factor-help-mode () "Major mode for displaying Factor help messages. @@ -591,6 +600,7 @@ buffer." (set (make-local-variable 'font-lock-defaults) '(factor--help-font-lock-keywords t nil nil nil)) (set (make-local-variable 'comint-redirect-subvert-readonly) t) + (set (make-local-variable 'comint-redirect-echo-input) nil) (set (make-local-variable 'view-no-disable-on-exit) t) (view-mode) (setq view-exit-action @@ -602,11 +612,11 @@ buffer." (run-mode-hooks 'factor-help-mode-hook)) (defun factor--listener-help-buffer () - (set-buffer (get-buffer-create "*factor-help*")) - (let ((inhibit-read-only t)) - (delete-region (point-min) (point-max))) - (factor-help-mode) - (current-buffer)) + (with-current-buffer (get-buffer-create "*factor-help*") + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max))) + (factor-help-mode) + (current-buffer))) (defvar factor--help-history nil) @@ -622,7 +632,8 @@ buffer." (hb (factor--listener-help-buffer)) (proc (factor--listener-process))) (comint-redirect-send-command-to-process cmd hb proc nil) - (pop-to-buffer hb))) + (pop-to-buffer hb) + (beginning-of-buffer hb))) (defun factor-see () (interactive) From a264adc74cef24ffcca158177981d8d9e1be6175 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 05:45:57 -0600 Subject: [PATCH 041/441] Forgot that us parameter might be f --- basis/io/windows/nt/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor index 1431ff3d30..4e335da749 100644 --- a/basis/io/windows/nt/backend/backend.factor +++ b/basis/io/windows/nt/backend/backend.factor @@ -53,7 +53,7 @@ M: winnt add-completion ( win32-handle -- ) 0 [ ! bytes f ! key f [ ! overlapped - us 1000 /i INFINITE or ! timeout + us [ 1000 /i ] [ INFINITE ] if* ! timeout GetQueuedCompletionStatus zero? ] keep *void* ] keep *int spin ; From 1fa819191d68140acb8abe537151045a0c0effe1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 05:46:26 -0600 Subject: [PATCH 042/441] Change inlining heuristic so that it behaves the same with dip and >r/r> --- basis/compiler/tree/propagation/inlining/inlining.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 8397a5fdbb..0beff42f4d 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -85,6 +85,8 @@ DEFER: (flat-length) : word-flat-length ( word -- n ) { + ! special-case + { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] } ! not inline { [ dup inline? not ] [ drop 1 ] } ! recursive and inline From 94902076152c7acec92f8926bfa7d1360b2748a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 05:46:43 -0600 Subject: [PATCH 043/441] Print benchmark runtimes in seconds --- extra/benchmark/benchmark.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 5a8e7595b5..a8c6e2a2ac 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel vocabs vocabs.loader tools.time tools.vocabs arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger ; +continuations debugger math ; IN: benchmark : run-benchmark ( vocab -- result ) @@ -17,12 +17,12 @@ IN: benchmark standard-table-style [ [ [ "Benchmark" write ] with-cell - [ "Time (ms)" write ] with-cell + [ "Time (seconds)" write ] with-cell ] with-row [ [ [ [ 1array $vocab-link ] with-cell ] - [ pprint-cell ] bi* + [ 1000000 /f pprint-cell ] bi* ] with-row ] assoc-each ] tabular-output ; From 2aaf860f479e45dffb0d1893b3f61641107347b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 06:40:51 -0600 Subject: [PATCH 044/441] Experimental optimizations --- basis/compiler/codegen/fixup/fixup.factor | 3 ++ basis/cpu/x86/bootstrap.factor | 6 ++-- basis/cpu/x86/x86.factor | 2 +- vm/code_gc.c | 40 ++++++++++++++++++++--- vm/code_heap.c | 3 +- vm/code_heap.h | 4 +++ vm/data_gc.c | 18 +++------- vm/layouts.h | 3 +- vm/quotations.c | 2 +- 9 files changed, 54 insertions(+), 27 deletions(-) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index b25f1fa8fe..a7f83941fd 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -69,6 +69,9 @@ SYMBOL: literal-table : rel-literal ( literal class -- ) >r add-literal r> rt-literal rel-fixup ; +: rel-immediate ( literal class -- ) + >r add-literal r> rt-immediate rel-fixup ; + : rel-this ( class -- ) 0 swap rt-label rel-fixup ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 1a54131435..6377578ea0 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -13,7 +13,6 @@ big-endian off [ ! Load word temp-reg 0 MOV - temp-reg dup [] MOV ! Bump profiling counter temp-reg profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code @@ -22,7 +21,7 @@ big-endian off temp-reg compiled-header-size ADD ! Jump to XT temp-reg JMP -] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define +] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define [ temp-reg 0 MOV ! load XT @@ -65,14 +64,13 @@ big-endian off [ arg1 0 MOV ! load dispatch table - arg1 dup [] MOV arg0 ds-reg [] MOV ! load index fixnum>slot@ ! turn it into an array offset ds-reg bootstrap-cell SUB ! pop index arg0 arg1 ADD ! compute quotation location arg0 arg0 array-start-offset [+] MOV ! load quotation arg0 quot-xt-offset [+] JMP ! execute branch -] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define +] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 58d95ffcde..e3f73dd203 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -18,7 +18,7 @@ M: x86 %load-immediate MOV ; HOOK: rel-literal-x86 cpu ( literal -- ) -M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ; +M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ; HOOK: ds-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg ) diff --git a/vm/code_gc.c b/vm/code_gc.c index 59e99b0260..c15185944a 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -259,13 +259,43 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter) /* Copy all literals referenced from a code block to newspace */ void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start) { - CELL scan; - CELL literal_end = literals_start + compiled->literals_length; + if(collecting_gen >= compiled->last_scan) + { + CELL scan; + CELL literal_end = literals_start + compiled->literals_length; - copy_handle(&compiled->relocation); + if(collecting_accumulation_gen_p()) + compiled->last_scan = collecting_gen; + else + compiled->last_scan = collecting_gen + 1; - for(scan = literals_start; scan < literal_end; scan += CELLS) - copy_handle((CELL*)scan); + for(scan = literals_start; scan < literal_end; scan += CELLS) + copy_handle((CELL*)scan); + + if(compiled->relocation != F) + { + copy_handle(&compiled->relocation); + + F_BYTE_ARRAY *relocation = untag_object(compiled->relocation); + + F_REL *rel = (F_REL *)(relocation + 1); + F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation)); + + while(rel < rel_end) + { + if(REL_TYPE(rel) == RT_IMMEDIATE) + { + CELL offset = rel->offset + code_start; + F_FIXNUM absolute_value = get(CREF(literals_start,REL_ARGUMENT(rel))); + apply_relocation(REL_CLASS(rel),offset,absolute_value); + } + + rel++; + } + } + + flush_icache(code_start,literals_start - code_start); + } } /* Copy literals referenced from all code blocks to newspace */ diff --git a/vm/code_heap.c b/vm/code_heap.c index a4577aeb9a..d742f48d1d 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -7,8 +7,6 @@ void undefined_symbol(void) general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); } -#define CREF(array,i) ((CELL)(array) + CELLS * (i)) - INLINE CELL get_literal(CELL literals_start, CELL num) { return get(CREF(literals_start,num)); @@ -283,6 +281,7 @@ F_COMPILED *add_compiled_block( /* compiled header */ F_COMPILED *header = (void *)here; header->type = type; + header->last_scan = NURSERY; header->code_length = code_length; header->literals_length = literals_length; header->relocation = relocation; diff --git a/vm/code_heap.h b/vm/code_heap.h index 7b1545ddf5..867d733ba0 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -57,6 +57,10 @@ typedef struct { unsigned int offset; } F_REL; +#define CREF(array,i) ((CELL)(array) + CELLS * (i)) + +void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value); + void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start); void default_word_code(F_WORD *word, bool relocate); diff --git a/vm/data_gc.c b/vm/data_gc.c index 23836c560c..08fb89600c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -303,21 +303,13 @@ void primitive_end_scan(void) /* Scan all the objects in the card */ void collect_card(F_CARD *ptr, CELL gen, CELL here) { - CELL offset = CARD_OFFSET(ptr); + CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr); + CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); - if(offset != INVALID_ALLOT_MARKER) - { - if(offset & TAG_MASK) - critical_error("Bad card",(CELL)ptr); + while(card_scan < card_end && card_scan < here) + card_scan = collect_next(card_scan); - CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset; - CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); - - while(card_scan < card_end && card_scan < here) - card_scan = collect_next(card_scan); - - cards_scanned++; - } + cards_scanned++; } void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask) diff --git a/vm/layouts.h b/vm/layouts.h index e55a5e9fd3..74a4c0475e 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -104,7 +104,8 @@ typedef struct { /* The compiled code heap is structured into blocks. */ typedef struct { - CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */ + char type; /* this is WORD_TYPE or QUOTATION_TYPE */ + char last_scan; /* the youngest generation in which this block's literals may live */ CELL code_length; /* # bytes */ CELL literals_length; /* # bytes */ CELL relocation; /* tagged pointer to byte-array or f */ diff --git a/vm/quotations.c b/vm/quotations.c index 44404c10f0..ef24c072d3 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -315,7 +315,7 @@ void jit_compile(CELL quot, bool relocate) } default: GROWABLE_ARRAY_ADD(literals,obj); - EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1); + EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1); break; } } From 030501d6ef02ec38011188d1c6f9a9805f9a0376 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 06:49:14 -0600 Subject: [PATCH 045/441] GC speedup --- vm/data_gc.c | 122 +++++++++++++++++++++++++++++++++++++-------------- vm/data_gc.h | 2 +- 2 files changed, 90 insertions(+), 34 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index 08fb89600c..643747f777 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -111,8 +111,7 @@ void clear_cards(CELL from, CELL to) /* NOTE: reverse order due to heap layout. */ F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start); F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end); - F_CARD *ptr; - for(ptr = first_card; ptr < last_card; ptr++) *ptr = 0; + memset(first_card,0,last_card - first_card); } void clear_decks(CELL from, CELL to) @@ -120,8 +119,7 @@ void clear_decks(CELL from, CELL to) /* NOTE: reverse order due to heap layout. */ F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start); F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end); - F_DECK *ptr; - for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0; + memset(first_deck,0,last_deck - first_deck); } void clear_allot_markers(CELL from, CELL to) @@ -129,8 +127,7 @@ void clear_allot_markers(CELL from, CELL to) /* NOTE: reverse order due to heap layout. */ F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start); F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end); - F_CARD *ptr; - for(ptr = first_card; ptr < last_card; ptr++) *ptr = INVALID_ALLOT_MARKER; + memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card); } void set_data_heap(F_DATA_HEAP *data_heap_) @@ -306,8 +303,10 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here) CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr); CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); - while(card_scan < card_end && card_scan < here) - card_scan = collect_next(card_scan); + if(here < card_end) + card_end = here; + + collect_next_loop(card_scan,&card_end); cards_scanned++; } @@ -489,11 +488,10 @@ void collect_roots(void) /* Given a pointer to oldspace, copy it to newspace */ INLINE void *copy_untagged_object(void *pointer, CELL size) { - void *newpointer; if(newspace->here + size >= newspace->end) longjmp(gc_jmp,1); allot_barrier(newspace->here); - newpointer = allot_zone(newspace,size); + void *newpointer = allot_zone(newspace,size); F_GC_STATS *s = &gc_stats[collecting_gen]; s->object_count++; @@ -563,6 +561,9 @@ the GC. Some types have a binary payload at the end (string, word, DLL) which we ignore. */ CELL binary_payload_start(CELL pointer) { + F_TUPLE *tuple; + F_TUPLE_LAYOUT *layout; + switch(untag_header(get(pointer))) { /* these objects do not refer to other objects at all */ @@ -583,8 +584,21 @@ CELL binary_payload_start(CELL pointer) case STRING_TYPE: return sizeof(F_STRING); /* everything else consists entirely of pointers */ + case ARRAY_TYPE: + return array_size(array_capacity((F_ARRAY*)pointer)); + case TUPLE_TYPE: + tuple = untag_object(pointer); + layout = untag_object(tuple->layout); + return tuple_size(layout); + case RATIO_TYPE: + return sizeof(F_RATIO); + case COMPLEX_TYPE: + return sizeof(F_COMPLEX); + case WRAPPER_TYPE: + return sizeof(F_WRAPPER); default: - return unaligned_object_size(pointer); + critical_error("Invalid header",pointer); + return -1; /* can't happen */ } } @@ -614,19 +628,15 @@ void do_code_slots(CELL scan) } } -/* This function is performance-critical */ -CELL collect_next(CELL scan) +CELL collect_next_nursery(CELL scan) { CELL *obj = (CELL *)scan; CELL *end = (CELL *)(scan + binary_payload_start(scan)); - obj++; - - CELL newspace_start = newspace->start; - CELL newspace_end = newspace->end; - - if(HAVE_NURSERY_P && collecting_gen == NURSERY) + if(obj != end) { + obj++; + CELL nursery_start = nursery.start; CELL nursery_end = nursery.end; @@ -639,12 +649,24 @@ CELL collect_next(CELL scan) *obj = copy_object(pointer); } } - else if(HAVE_AGING_P && collecting_gen == AGING) - { - F_ZONE *tenured = &data_heap->generations[TENURED]; - CELL tenured_start = tenured->start; - CELL tenured_end = tenured->end; + return scan + untagged_object_size(scan); +} + +CELL collect_next_aging(CELL scan) +{ + CELL *obj = (CELL *)scan; + CELL *end = (CELL *)(scan + binary_payload_start(scan)); + + if(obj != end) + { + obj++; + + CELL tenured_start = data_heap->generations[TENURED].start; + CELL tenured_end = data_heap->generations[TENURED].end; + + CELL newspace_start = newspace->start; + CELL newspace_end = newspace->end; for(; obj < end; obj++) { @@ -656,25 +678,56 @@ CELL collect_next(CELL scan) *obj = copy_object(pointer); } } - else if(collecting_gen == TENURED) + + return scan + untagged_object_size(scan); +} + +/* This function is performance-critical */ +CELL collect_next_tenured(CELL scan) +{ + CELL *obj = (CELL *)scan; + CELL *end = (CELL *)(scan + binary_payload_start(scan)); + + if(obj != end) { + obj++; + + CELL newspace_start = newspace->start; + CELL newspace_end = newspace->end; + for(; obj < end; obj++) { CELL pointer = *obj; - if(!immediate_p(pointer) - && !(pointer >= newspace_start && pointer < newspace_end)) + if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end)) *obj = copy_object(pointer); } - - do_code_slots(scan); } - else - critical_error("Bug in collect_next",0); + + do_code_slots(scan); return scan + untagged_object_size(scan); } +void collect_next_loop(CELL scan, CELL *end) +{ + if(HAVE_NURSERY_P && collecting_gen == NURSERY) + { + while(scan < *end) + scan = collect_next_nursery(scan); + } + else if(HAVE_AGING_P && collecting_gen == AGING) + { + while(scan < *end) + scan = collect_next_aging(scan); + } + else if(collecting_gen == TENURED) + { + while(scan < *end) + scan = collect_next_tenured(scan); + } +} + INLINE void reset_generation(CELL i) { F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); @@ -755,6 +808,10 @@ void end_gc(CELL gc_elapsed) if(collecting_gen != NURSERY) reset_generations(NURSERY,collecting_gen - 1); } + else if(HAVE_NURSERY_P && collecting_gen == NURSERY) + { + nursery.here = nursery.start; + } else { /* all generations up to and including the one @@ -849,8 +906,7 @@ void garbage_collection(CELL gen, } } - while(scan < newspace->here) - scan = collect_next(scan); + collect_next_loop(scan,&newspace->here); CELL gc_elapsed = (current_micros() - start); diff --git a/vm/data_gc.h b/vm/data_gc.h index a407ed761c..4ec3fdd5f2 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -386,7 +386,7 @@ INLINE void* allot_object(CELL type, CELL a) return object; } -CELL collect_next(CELL scan); +void collect_next_loop(CELL scan, CELL *end); void primitive_gc(void); void primitive_gc_stats(void); From ab689c098b0db66e6980f43829ec5eb9c4b60e40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 08:16:14 -0600 Subject: [PATCH 046/441] Clean up direct literal code and make a first attempt at PowerPC support --- basis/bootstrap/image/image.factor | 9 +++---- basis/compiler/cfg/def-use/def-use.factor | 7 ++++-- basis/compiler/cfg/hats/hats.factor | 6 ++--- .../cfg/instructions/instructions.factor | 6 ++--- .../value-numbering/rewrite/rewrite.factor | 11 +++++---- .../value-numbering-tests.factor | 21 ++++++++++++---- basis/compiler/codegen/codegen.factor | 3 ++- basis/compiler/codegen/fixup/fixup.factor | 3 --- basis/compiler/constants/constants.factor | 13 +++++----- basis/cpu/architecture/architecture.factor | 6 ++--- basis/cpu/ppc/bootstrap.factor | 15 +++--------- basis/cpu/ppc/ppc.factor | 6 ++--- basis/cpu/x86/32/32.factor | 2 -- basis/cpu/x86/64/64.factor | 2 -- basis/cpu/x86/bootstrap.factor | 24 +++++++------------ basis/cpu/x86/x86.factor | 16 ++++++------- vm/code_heap.c | 2 -- vm/code_heap.h | 2 -- vm/quotations.c | 6 ++--- vm/run.h | 3 +-- 20 files changed, 71 insertions(+), 92 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 3adebbcd44..e2203031aa 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -124,7 +124,6 @@ SYMBOL: jit-primitive-word SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call -SYMBOL: jit-push-literal SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-1 @@ -156,9 +155,9 @@ SYMBOL: undefined-quot { jit-primitive 25 } { jit-word-jump 26 } { jit-word-call 27 } - { jit-push-literal 28 } - { jit-if-word 29 } - { jit-if-1 30 } + { jit-if-word 28 } + { jit-if-1 29 } + { jit-if-2 30 } { jit-dispatch-word 31 } { jit-dispatch 32 } { jit-epilog 33 } @@ -173,7 +172,6 @@ SYMBOL: undefined-quot { jit-2dip 47 } { jit-3dip-word 48 } { jit-3dip 49 } - { jit-if-2 50 } { undefined-quot 60 } } ; inline @@ -471,7 +469,6 @@ M: quotation ' jit-primitive jit-word-jump jit-word-call - jit-push-literal jit-push-immediate jit-if-word jit-if-1 diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 7553407e00..7584931cf7 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -12,9 +12,12 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##unary/temp defs-vregs dst/tmp-vregs ; M: ##allot defs-vregs dst/tmp-vregs ; M: ##dispatch defs-vregs temp>> 1array ; -M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ; +M: ##slot defs-vregs dst/tmp-vregs ; M: ##set-slot defs-vregs temp>> 1array ; -M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ; +M: ##string-nth defs-vregs dst/tmp-vregs ; +M: ##compare defs-vregs dst/tmp-vregs ; +M: ##compare-imm defs-vregs dst/tmp-vregs ; +M: ##compare-float defs-vregs dst/tmp-vregs ; M: insn defs-vregs drop f ; M: ##unary uses-vregs src>> 1array ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index e6e05abbd5..4b98ccb0ae 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -65,9 +65,9 @@ IN: compiler.cfg.hats : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline -: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline -: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline -: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline +: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline +: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline +: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b2c752e612..ce1f6b7e85 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -198,11 +198,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; INSN: ##compare-branch < ##conditional-branch ; INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ; -INSN: ##compare < ##binary cc ; -INSN: ##compare-imm < ##binary-imm cc ; +INSN: ##compare < ##binary cc temp ; +INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; -INSN: ##compare-float < ##binary cc ; +INSN: ##compare-float < ##binary cc temp ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 5f67f8097e..990543ed7a 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences layouts accessors combinators namespaces math fry +compiler.cfg.hats compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.simplify @@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison M: ##compare-imm rewrite-tagged-comparison [ dst>> ] [ (rewrite-tagged-comparison) ] bi - f \ ##compare-imm boa ; + i f \ ##compare-imm boa ; M: ##compare-imm-branch rewrite dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when @@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite [ dst>> ] [ src2>> ] [ src1>> vreg>vn vn>constant ] tri - cc= f \ ##compare-imm boa ; + cc= f i \ ##compare-imm boa ; M: ##compare rewrite dup flip-comparison? [ @@ -95,9 +96,9 @@ M: ##compare rewrite : rewrite-redundant-comparison ( insn -- insn' ) [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { - { \ ##compare [ >compare-expr< f \ ##compare boa ] } - { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] } - { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] } + { \ ##compare [ >compare-expr< i f \ ##compare boa ] } + { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] } + { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] } } case swap cc= eq? [ [ negate-cc ] change-cc ] when ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index b73736ed14..8adeaa21f4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,6 +1,17 @@ IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions -compiler.cfg.registers cpu.architecture tools.test kernel math ; +compiler.cfg.registers cpu.architecture tools.test kernel math +combinators.short-circuit accessors sequences ; + +: trim-temps ( insns -- insns ) + [ + dup { + [ ##compare? ] + [ ##compare-imm? ] + [ ##compare-float? ] + } 1|| [ f >>temp ] when + ] map ; + [ { T{ ##peek f V int-regs 45 D 1 } @@ -82,7 +93,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } T{ ##replace f V int-regs 6 D 0 } - } value-numbering + } value-numbering trim-temps ] unit-test [ @@ -100,7 +111,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } T{ ##replace f V int-regs 6 D 0 } - } value-numbering + } value-numbering trim-temps ] unit-test [ @@ -122,7 +133,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } T{ ##replace f V int-regs 14 D 0 } - } value-numbering + } value-numbering trim-temps ] unit-test [ @@ -138,5 +149,5 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; T{ ##peek f V int-regs 30 D -2 } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare-imm-branch f V int-regs 33 7 cc/= } - } value-numbering + } value-numbering trim-temps ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 9f6e8e9c9b..bfb47ba330 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -491,9 +491,10 @@ M: _label generate-insn M: _branch generate-insn label>> lookup-label %jump-label ; -: >compare< ( insn -- label cc src1 src2 ) +: >compare< ( insn -- dst temp cc src1 src2 ) { [ dst>> register ] + [ temp>> register ] [ cc>> ] [ src1>> register ] [ src2>> ?register ] diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index a7f83941fd..06abec5968 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -66,9 +66,6 @@ SYMBOL: literal-table : rel-primitive ( word class -- ) >r def>> first r> rt-primitive rel-fixup ; -: rel-literal ( literal class -- ) - >r add-literal r> rt-literal rel-fixup ; - : rel-immediate ( literal class -- ) >r add-literal r> rt-immediate rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 86c1f65049..48ea958818 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -39,13 +39,12 @@ IN: compiler.constants ! Relocation types : rt-primitive 0 ; inline : rt-dlsym 1 ; inline -: rt-literal 2 ; inline -: rt-dispatch 3 ; inline -: rt-xt 4 ; inline -: rt-here 5 ; inline -: rt-label 6 ; inline -: rt-immediate 7 ; inline -: rt-stack-chain 8 ; inline +: rt-dispatch 2 ; inline +: rt-xt 3 ; inline +: rt-here 4 ; inline +: rt-label 5 ; inline +: rt-immediate 6 ; inline +: rt-stack-chain 7 ; inline : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d26e7f6ff7..3d6195d9eb 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -119,9 +119,9 @@ HOOK: %gc cpu ( -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) -HOOK: %compare cpu ( dst cc src1 src2 -- ) -HOOK: %compare-imm cpu ( dst cc src1 src2 -- ) -HOOK: %compare-float cpu ( dst cc src1 src2 -- ) +HOOK: %compare cpu ( dst temp cc src1 src2 -- ) +HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- ) +HOOK: %compare-float cpu ( dst temp cc src1 src2 -- ) HOOK: %compare-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 512fff798b..c753050b8e 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -24,7 +24,6 @@ big-endian on [ 0 6 LOAD32 - 6 dup 0 LWZ 11 6 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI 11 6 profile-count-offset STW @@ -32,7 +31,7 @@ big-endian on 11 11 compiled-header-size ADDI 11 MTCTR BCTR -] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define +] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define [ 0 6 LOAD32 @@ -44,12 +43,6 @@ big-endian on 0 1 lr-save stack-frame + STW ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define -[ - 0 6 LOAD32 - 6 dup 0 LWZ - 6 ds-reg 4 STWU -] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define - [ 0 6 LOAD32 6 ds-reg 4 STWU @@ -90,14 +83,13 @@ big-endian on [ 0 3 LOAD32 - 3 3 0 LWZ 6 ds-reg 0 LWZ 6 6 1 SRAWI 3 3 6 ADD 3 3 array-start-offset LWZ ds-reg dup 4 SUBI jit-jump-quot -] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define +] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -317,7 +309,6 @@ big-endian on ! Comparisons : jit-compare ( insn -- ) 0 3 LOAD32 - 3 3 0 LWZ 4 ds-reg 0 LWZ 5 ds-reg -4 LWZU 5 0 4 CMP @@ -326,7 +317,7 @@ big-endian on 3 ds-reg 0 STW ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip + [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip define-sub-primitive ; \ BEQ \ eq? define-jit-compare diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index c656ae4d89..43663ffffd 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -34,10 +34,8 @@ M: ppc two-operand? f ; M: ppc %load-immediate ( reg n -- ) swap LOAD ; -M:: ppc %load-indirect ( reg obj -- ) - 0 reg LOAD32 - obj rc-absolute-ppc-2/2 rel-literal - reg reg 0 LWZ ; +M: ppc %load-indirect ( reg obj -- ) + [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ; : ds-reg 29 ; inline : rs-reg 30 ; inline diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index f892271fd5..217047e4b6 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -88,8 +88,6 @@ M: float-regs store-return-reg [ [ align-sub ] [ call ] bi* ] [ [ align-add ] [ drop ] bi* ] 2bi ; inline -M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ; - M: x86.32 %prologue ( n -- ) dup PUSH 0 PUSH rc-absolute-cell rel-this diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 75c808b50a..9ddad23004 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -44,8 +44,6 @@ M:: x86.64 %dispatch ( src temp offset -- ) M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; -M: x86.64 rel-literal-x86 rc-relative rel-literal ; - M: x86.64 %prologue ( n -- ) temp-reg-1 0 MOV rc-absolute-cell rel-this dup PUSH diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 6377578ea0..d5fc64de00 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -30,13 +30,6 @@ big-endian off stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define -[ - arg0 0 MOV ! load literal - arg0 dup [] MOV - ds-reg bootstrap-cell ADD ! increment datastack pointer - ds-reg [] arg0 MOV ! store literal on datastack -] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define - [ arg0 0 MOV ! load literal ds-reg bootstrap-cell ADD ! increment datastack pointer @@ -294,9 +287,8 @@ big-endian off ! Comparisons : jit-compare ( insn -- ) - arg1 0 MOV ! load t - arg1 dup [] MOV - temp-reg \ f tag-number MOV ! load f + temp-reg 0 MOV ! load t + arg1 \ f tag-number MOV ! load f arg0 ds-reg [] MOV ! load first value ds-reg bootstrap-cell SUB ! adjust stack pointer ds-reg [] arg0 CMP ! compare with second value @@ -305,14 +297,14 @@ big-endian off ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip + [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip define-sub-primitive ; -\ CMOVNE \ eq? define-jit-compare -\ CMOVL \ fixnum>= define-jit-compare -\ CMOVG \ fixnum<= define-jit-compare -\ CMOVLE \ fixnum> define-jit-compare -\ CMOVGE \ fixnum< define-jit-compare +\ CMOVE \ eq? define-jit-compare +\ CMOVGE \ fixnum>= define-jit-compare +\ CMOVLE \ fixnum<= define-jit-compare +\ CMOVG \ fixnum> define-jit-compare +\ CMOVL \ fixnum< define-jit-compare ! Math : jit-math ( insn -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index e3f73dd203..f0f156a57d 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -16,8 +16,6 @@ HOOK: temp-reg-2 cpu ( -- reg ) M: x86 %load-immediate MOV ; -HOOK: rel-literal-x86 cpu ( literal -- ) - M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ; HOOK: ds-reg cpu ( -- reg ) @@ -401,12 +399,12 @@ HOOK: stack-reg cpu ( -- reg ) M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; -: %boolean ( dst word -- ) - over \ f tag-number MOV - 0 [] swap execute - \ t rel-literal-x86 ; inline +:: %boolean ( dst temp word -- ) + dst \ f tag-number MOV + temp 0 MOV \ t rc-absolute-cell rel-immediate + dst temp word execute ; inline -M: x86 %compare ( dst cc src1 src2 -- ) +M: x86 %compare ( dst temp cc src1 src2 -- ) CMP { { cc< [ \ CMOVL %boolean ] } { cc<= [ \ CMOVLE %boolean ] } @@ -416,10 +414,10 @@ M: x86 %compare ( dst cc src1 src2 -- ) { cc/= [ \ CMOVNE %boolean ] } } case ; -M: x86 %compare-imm ( dst cc src1 src2 -- ) +M: x86 %compare-imm ( dst temp cc src1 src2 -- ) %compare ; -M: x86 %compare-float ( dst cc src1 src2 -- ) +M: x86 %compare-float ( dst temp cc src1 src2 -- ) UCOMISD { { cc< [ \ CMOVB %boolean ] } { cc<= [ \ CMOVBE %boolean ] } diff --git a/vm/code_heap.c b/vm/code_heap.c index d742f48d1d..6ed5ea4309 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -61,8 +61,6 @@ INLINE CELL compute_code_rel(F_REL *rel, return (CELL)primitives[REL_ARGUMENT(rel)]; case RT_DLSYM: return (CELL)get_rel_symbol(rel,literals_start); - case RT_LITERAL: - return CREF(literals_start,REL_ARGUMENT(rel)); case RT_IMMEDIATE: return get(CREF(literals_start,REL_ARGUMENT(rel))); case RT_XT: diff --git a/vm/code_heap.h b/vm/code_heap.h index 867d733ba0..d167ece7fa 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -3,8 +3,6 @@ typedef enum { RT_PRIMITIVE, /* arg is a literal table index, holding an array pair (symbol/dll) */ RT_DLSYM, - /* an indirect literal from the word's literal table */ - RT_LITERAL, /* a pointer to a compiled word reference */ RT_DISPATCH, /* a compiled word reference */ diff --git a/vm/quotations.c b/vm/quotations.c index ef24c072d3..e0c5a9af78 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -232,7 +232,7 @@ void jit_compile(CELL quot, bool relocate) case WRAPPER_TYPE: wrapper = untag_object(obj); GROWABLE_ARRAY_ADD(literals,wrapper->object); - EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); + EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1); break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) @@ -404,7 +404,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) COUNT(userenv[JIT_WORD_CALL],i) break; case WRAPPER_TYPE: - COUNT(userenv[JIT_PUSH_LITERAL],i) + COUNT(userenv[JIT_PUSH_IMMEDIATE],i) break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) @@ -470,7 +470,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) break; } default: - COUNT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],i) + COUNT(userenv[JIT_PUSH_IMMEDIATE],i) break; } } diff --git a/vm/run.h b/vm/run.h index b4118b09d8..f156ba3f03 100755 --- a/vm/run.h +++ b/vm/run.h @@ -39,9 +39,9 @@ typedef enum { JIT_PRIMITIVE, JIT_WORD_JUMP, JIT_WORD_CALL, - JIT_PUSH_LITERAL, JIT_IF_WORD, JIT_IF_1, + JIT_IF_2, JIT_DISPATCH_WORD, JIT_DISPATCH, JIT_EPILOG, @@ -56,7 +56,6 @@ typedef enum { JIT_2DIP, JIT_3DIP_WORD, JIT_3DIP, - JIT_IF_2, STACK_TRACES_ENV = 59, From a4282139dc594c701917b02bbd7c37bc21494e34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 09:27:15 -0600 Subject: [PATCH 047/441] Add comments explaining recent changes --- vm/quotations.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/vm/quotations.c b/vm/quotations.c index e0c5a9af78..d8f1a3f61b 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -9,6 +9,10 @@ The non-optimizing compiler compiles a quotation at a time by concatenating machine code chunks; prolog, epilog, call word, jump to word, etc. These machine code chunks are generated from Factor code in core/cpu/.../bootstrap.factor. +Calls to words and constant quotations (referenced by conditionals and dips) +are direct jumps to machine code blocks. Literals are also referenced directly +without going through the literal table. + It actually does do a little bit of very simple optimization: 1) Tail call optimization. @@ -21,12 +25,15 @@ generated. 'if' and 'dispatch' conditionals are generated inline, instead of as a call to the 'if' word. -4) When preceded by an array, calls to the 'declare' word are optimized out +4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are +open-coded as retain stack manipulation surrounding a subroutine call. + +5) When preceded by an array, calls to the 'declare' word are optimized out entirely. This word is only used by the optimizing compiler, and with the non-optimizing compiler it would otherwise just decrease performance to have to push the array and immediately drop it after. -5) Sub-primitives are primitive words which are implemented in assembly and not +6) Sub-primitives are primitive words which are implemented in assembly and not in the VM. They are open-coded and no subroutine call is generated. This includes stack shufflers, some fixnum arithmetic words, and words such as tag, slot and eq?. A primitive call is relatively expensive (two subroutine calls) From f2040c05296ccec59cd525022a9d31e613af5ded Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 11:12:36 -0600 Subject: [PATCH 048/441] Add some more tests --- basis/compiler/tests/codegen.factor | 15 ++++++++++++++- basis/compiler/tests/intrinsics.factor | 5 +++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index a56ee55c82..dd6f99ead1 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io -combinators vectors float-arrays ; +combinators vectors float-arrays grouping make ; IN: compiler.tests ! Originally, this file did black box testing of templating @@ -241,3 +241,16 @@ TUPLE: id obj ; [ "a" ] [ 1 test-2 ] unit-test [ "b" ] [ 2 test-2 ] unit-test + +! I accidentally fixnum/i-fast on PowerPC +[ { { 1 2 } { 3 4 } } ] [ + { 1 2 3 4 } + [ + [ { array } declare 2 [ , ] each ] compile-call + ] { } make +] unit-test + +[ 2 ] [ + { 1 2 3 4 } + [ { array } declare 2 length ] compile-call +] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index c90a31fc61..3c4741272d 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -160,6 +160,11 @@ IN: compiler.tests [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test +[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test +[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test +[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test +[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test + [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test From 6c568d5c3d2d19122cb72de341f42075715dd54e Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 24 Nov 2008 11:34:18 -0600 Subject: [PATCH 049/441] Fix PowerPC bootstrap --- basis/cpu/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 43663ffffd..6a42ffdf77 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -396,14 +396,14 @@ M: ppc %epilogue ( n -- ) 1 1 rot ADDI 0 MTLR ; -:: (%boolean) ( dst word -- ) +:: (%boolean) ( dst temp word -- ) "end" define-label dst \ f tag-number %load-immediate "end" get word execute dst \ t %load-indirect "end" get resolve-label ; inline -: %boolean ( dst cc -- ) +: %boolean ( dst temp cc -- ) negate-cc { { cc< [ \ BLT (%boolean) ] } { cc<= [ \ BLE (%boolean) ] } From d849287779bd95d886c4c733d14745f85985de37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 12:01:08 -0600 Subject: [PATCH 050/441] Fix fixnum/i-fast and fixnum/md-fast on PowerPC --- basis/cpu/ppc/bootstrap.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index c753050b8e..047d27c5f4 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -388,6 +388,7 @@ big-endian on ds-reg ds-reg 4 SUBI 4 ds-reg 0 LWZ 5 4 3 DIVW + 5 5 tag-bits get SLWI 5 ds-reg 0 STW ] f f f \ fixnum/i-fast define-sub-primitive @@ -397,6 +398,7 @@ big-endian on 5 4 3 DIVW 6 5 3 MULLW 7 6 4 SUBF + 5 5 tag-bits get SLWI 5 ds-reg -4 STW 7 ds-reg 0 STW ] f f f \ fixnum/mod-fast define-sub-primitive From 8678ff091f06ff18c54a953faf1df1ffbbb2e4ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 12:01:20 -0600 Subject: [PATCH 051/441] Fix docs for spread and apply combinators --- core/kernel/kernel-docs.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 31798c9295..e1fa0f6fa3 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -205,18 +205,18 @@ HELP: 3slip { $description "Calls a quotation while hiding the top three stack elements." } ; HELP: keep -{ $values { "quot" { $quotation "( x -- )" } } { "x" object } } +{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } { $examples { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" } } ; HELP: 2keep -{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } } +{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } } { $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ; HELP: 3keep -{ $values { "quot" { $quotation "( x y z -- )" } } { "x" object } { "y" object } { "z" object } } +{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } } { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ; HELP: bi @@ -371,7 +371,7 @@ HELP: tri* } ; HELP: bi@ -{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- )" } } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ... )" } } } { $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } { $examples "The following two lines are equivalent:" @@ -387,7 +387,7 @@ HELP: bi@ } ; HELP: 2bi@ -{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- )" } } } +{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } } { $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." } { $examples "The following two lines are equivalent:" @@ -403,7 +403,7 @@ HELP: 2bi@ } ; HELP: tri@ -{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- )" } } } +{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- ... )" } } } { $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." } { $examples "The following two lines are equivalent:" @@ -437,7 +437,7 @@ $nl "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; HELP: if* -{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" quotation } } +{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" quotation } } { $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true." $nl "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." @@ -446,7 +446,7 @@ $nl { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; HELP: when* -{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } } +{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } } { $description "Variant of " { $link if* } " with no false quotation." $nl "The following two lines are equivalent:" @@ -460,7 +460,7 @@ HELP: unless* { $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; HELP: ?if -{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" { $quotation "( default -- )" } } } +{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" { $quotation "( default -- ... )" } } } { $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." } { $notes "The following two lines are equivalent:" From 915bd51b20a1014c3a80a52a834946b3fff4ba04 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 12:29:24 -0600 Subject: [PATCH 052/441] Tweak debugger and traceback a bit --- basis/editors/editors.factor | 7 ++- basis/help/help.factor | 7 ++- basis/ui/tools/debugger/debugger.factor | 62 ++++++++++++++--------- basis/ui/tools/traceback/traceback.factor | 2 +- 4 files changed, 48 insertions(+), 30 deletions(-) diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 7dfceafe59..1e2bb8d85c 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -64,10 +64,13 @@ M: object error-file M: object error-line drop f ; -: :edit ( -- ) - error get [ error-file ] [ error-line ] bi +: (:edit) ( error -- ) + [ error-file ] [ error-line ] bi 2dup and [ edit-location ] [ 2drop ] if ; +: :edit ( -- ) + error get (:edit) ; + : edit-each ( seq -- ) [ [ "Editing " write . ] diff --git a/basis/help/help.factor b/basis/help/help.factor index a3e3890687..5d12438e0d 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -155,10 +155,13 @@ help-hook global [ [ print-topic ] or ] change-at ":get ( var -- value ) accesses variables at time of the error" print ":vars - list all variables at error time" print ; -: :help ( -- ) - error get error-help [ help ] [ "No help for this error. " print ] if* +: (:help) ( error -- ) + error-help [ help ] [ "No help for this error. " print ] if* :help-debugger ; +: :help ( -- ) + error get (:help) ; + : remove-article ( name -- ) dup articles get key? [ dup unxref-article diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 641763c0b1..cfe7baf0ae 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -1,35 +1,43 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays ui ui.commands ui.gestures ui.gadgets - ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons - ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations - ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks - ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math - models namespaces sequences sequences words continuations - debugger prettyprint ui.tools.traceback help editors ; - +USING: accessors arrays hashtables io kernel math models +namespaces sequences sequences words continuations debugger +prettyprint help editors ui ui.commands ui.gestures ui.gadgets +ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons +ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations +ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks +ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ; IN: ui.tools.debugger -: ( restarts restart-hook -- gadget ) - [ name>> ] rot ; +TUPLE: debugger < track error restarts restart-hook restart-list continuation ; -TUPLE: debugger < track restarts ; + ( restart-list error -- gadget ) +: ( debugger -- gadget ) + [ restart-hook>> ] [ restarts>> ] bi + [ name>> ] swap ; inline + +: ( error -- pane ) + [ [ print-error ] with-pane ] keep ; inline + +: ( debugger -- gadget ) - - swapd tuck [ print-error ] with-pane - add-gadget + over error>> add-gadget + swap restart-list>> add-gadget ; inline - swap add-gadget ; +PRIVATE> : ( error restarts restart-hook -- gadget ) { 0 1 } debugger new-track add-toolbar - -rot >>restarts - dup restarts>> rot 1 track-add ; + swap >>restart-hook + swap >>restarts + swap >>error + error-continuation get >>continuation + dup >>restart-list + dup 1 track-add ; -M: debugger focusable-child* restarts>> ; +M: debugger focusable-child* restart-list>> ; : debugger-window ( error -- ) #! No restarts for the debugger window @@ -55,16 +63,20 @@ debugger "gestures" f { { T{ button-down } request-focus } } define-command-map -: com-traceback ( -- ) error-continuation get traceback-window ; +: com-traceback ( debugger -- ) continuation>> traceback-window ; -\ com-traceback H{ { +nullary+ t } } define-command +\ com-traceback H{ } define-command -\ :help H{ { +nullary+ t } { +listener+ t } } define-command +: com-help ( debugger -- ) error>> (:help) ; -\ :edit H{ { +nullary+ t } { +listener+ t } } define-command +\ com-help H{ { +listener+ t } } define-command + +: com-edit ( debugger -- ) error>> (:edit) ; + +\ com-edit H{ { +listener+ t } } define-command debugger "toolbar" f { { T{ key-down f f "s" } com-traceback } - { T{ key-down f f "h" } :help } - { T{ key-down f f "e" } :edit } + { T{ key-down f f "h" } com-help } + { T{ key-down f f "e" } com-edit } } define-command-map diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 45f15b1ffc..90f1e601c7 100644 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -53,4 +53,4 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; "Dynamic variables" open-status-window ; : traceback-window ( continuation -- ) - "Traceback" open-window ; + "Traceback" open-status-window ; From 799f761befcf2ca3dac3d73a4dfa4996c59bc3c0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 12:31:40 -0600 Subject: [PATCH 053/441] state-tables vocab is no longer necessary --- basis/state-tables/authors.txt | 1 - basis/state-tables/state-tables-tests.factor | 56 --------- basis/state-tables/state-tables.factor | 123 ------------------- 3 files changed, 180 deletions(-) delete mode 100644 basis/state-tables/authors.txt delete mode 100644 basis/state-tables/state-tables-tests.factor delete mode 100644 basis/state-tables/state-tables.factor diff --git a/basis/state-tables/authors.txt b/basis/state-tables/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/basis/state-tables/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/state-tables/state-tables-tests.factor b/basis/state-tables/state-tables-tests.factor deleted file mode 100644 index b86c4f57d9..0000000000 --- a/basis/state-tables/state-tables-tests.factor +++ /dev/null @@ -1,56 +0,0 @@ -USING: kernel state-tables tools.test ; -IN: state-tables.tests - -: test-table - - "a" "c" "z" over set-entry - "a" "o" "y" over set-entry - "a" "l" "x" over set-entry - "b" "o" "y" over set-entry - "b" "l" "x" over set-entry - "b" "s" "u" over set-entry ; - -[ - T{ - table - f - H{ - { "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } } - { "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } } - } - H{ { "l" t } { "s" t } { "c" t } { "o" t } } - f - H{ } - } -] [ test-table ] unit-test - -[ "x" t ] [ "a" "l" test-table get-entry ] unit-test -[ "har" t ] [ - "a" "z" "har" test-table [ set-entry ] keep - >r "a" "z" r> get-entry -] unit-test - -: vector-test-table - - "a" "c" "z" over add-entry - "a" "c" "r" over add-entry - "a" "o" "y" over add-entry - "a" "l" "x" over add-entry - "b" "o" "y" over add-entry - "b" "l" "x" over add-entry - "b" "s" "u" over add-entry ; - -[ -T{ vector-table f - H{ - { "a" - H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } } - { "b" - H{ { "l" "x" } { "s" "u" } { "o" "y" } } } - } - H{ { "l" t } { "s" t } { "c" t } { "o" t } } - f - H{ } -} -] [ vector-test-table ] unit-test - diff --git a/basis/state-tables/state-tables.factor b/basis/state-tables/state-tables.factor deleted file mode 100644 index ecb258c163..0000000000 --- a/basis/state-tables/state-tables.factor +++ /dev/null @@ -1,123 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make sequences vectors assocs accessors ; -IN: state-tables - -TUPLE: table rows columns start-state final-states ; -TUPLE: entry row-key column-key value ; - -GENERIC: add-entry ( entry table -- ) - -: make-table ( class -- obj ) - new - H{ } clone >>rows - H{ } clone >>columns - H{ } clone >>final-states ; - -:
( -- obj ) - table make-table ; - -C: entry - -: (add-row) ( row-key table -- row ) - 2dup rows>> at* [ - 2nip - ] [ - drop H{ } clone [ -rot rows>> set-at ] keep - ] if ; - -: add-row ( row-key table -- ) - (add-row) drop ; - -: add-column ( column-key table -- ) - t -rot columns>> set-at ; - -: set-row ( row row-key table -- ) - rows>> set-at ; - -: lookup-row ( row-key table -- row/f ? ) - rows>> at* ; - -: row-exists? ( row-key table -- ? ) - lookup-row nip ; - -: lookup-column ( column-key table -- column/f ? ) - columns>> at* ; - -: column-exists? ( column-key table -- ? ) - lookup-column nip ; - -ERROR: no-row key ; -ERROR: no-column key ; - -: get-row ( row-key table -- row ) - dupd lookup-row [ - nip - ] [ - drop no-row - ] if ; - -: get-column ( column-key table -- column ) - dupd lookup-column [ - nip - ] [ - drop no-column - ] if ; - -: get-entry ( row-key column-key table -- obj ? ) - swapd lookup-row [ - at* - ] [ - 2drop f f - ] if ; - -: (set-entry) ( entry table -- value column-key row ) - [ >r column-key>> r> add-column ] 2keep - dupd >r row-key>> r> (add-row) - >r [ value>> ] keep column-key>> r> ; - -: set-entry ( entry table -- ) - (set-entry) set-at ; - -: delete-entry ( entry table -- ) - >r [ column-key>> ] [ row-key>> ] bi r> - lookup-row [ delete-at ] [ 2drop ] if ; - -: swap-rows ( row-key1 row-key2 table -- ) - [ tuck get-row >r get-row r> ] 3keep - >r >r rot r> r> [ set-row ] keep set-row ; - -: member?* ( obj obj -- bool ) - 2dup = [ 2drop t ] [ member? ] if ; - -: find-by-column ( column-key data table -- seq ) - swapd 2dup lookup-column 2drop - [ - rows>> [ - pick swap at* [ - >r pick r> member?* [ , ] [ drop ] if - ] [ - 2drop - ] if - ] assoc-each - ] { } make 2nip ; - - -TUPLE: vector-table < table ; -: ( -- obj ) - vector-table make-table ; - -: add-hash-vector ( value key hash -- ) - 2dup at* [ - dup vector? [ - 2nip push - ] [ - V{ } clone [ push ] keep - -rot >r >r [ push ] keep r> r> set-at - ] if - ] [ - drop set-at - ] if ; - -M: vector-table add-entry ( entry table -- ) - (set-entry) add-hash-vector ; From 87bdc0acd3a3a65dfb9b1802148355768ca8053a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 12:57:26 -0600 Subject: [PATCH 054/441] if we're on win64, don't run postgresql tests --- basis/db/postgresql/postgresql-tests.factor | 150 ++++++++++---------- basis/db/tuples/tuples-tests.factor | 6 +- 2 files changed, 80 insertions(+), 76 deletions(-) diff --git a/basis/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor index fe53e2416e..bc5ec2f0c5 100644 --- a/basis/db/postgresql/postgresql-tests.factor +++ b/basis/db/postgresql/postgresql-tests.factor @@ -1,6 +1,6 @@ USING: kernel db.postgresql alien continuations io classes prettyprint sequences namespaces tools.test db -db.tuples db.types unicode.case accessors ; +db.tuples db.types unicode.case accessors system ; IN: db.postgresql.tests : test-db ( -- postgresql-db ) @@ -10,86 +10,88 @@ IN: db.postgresql.tests "thepasswordistrust" >>password "factor-test" >>database ; -[ ] [ test-db [ ] with-db ] unit-test +os windows? cpu x86.64? and [ + [ ] [ test-db [ ] with-db ] unit-test -[ ] [ - test-db [ - [ "drop table person;" sql-command ] ignore-errors - "create table person (name varchar(30), country varchar(30));" + [ ] [ + test-db [ + [ "drop table person;" sql-command ] ignore-errors + "create table person (name varchar(30), country varchar(30));" + sql-command + + "insert into person values('John', 'America');" sql-command + "insert into person values('Jane', 'New Zealand');" sql-command + ] with-db + ] unit-test + + [ + { + { "John" "America" } + { "Jane" "New Zealand" } + } + ] [ + test-db [ + "select * from person" sql-query + ] with-db + ] unit-test + + [ + { + { "John" "America" } + { "Jane" "New Zealand" } + } + ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test + + [ + ] [ + test-db [ + "insert into person(name, country) values('Jimmy', 'Canada')" sql-command + ] with-db + ] unit-test - "insert into person values('John', 'America');" sql-command - "insert into person values('Jane', 'New Zealand');" sql-command - ] with-db -] unit-test + [ + { + { "John" "America" } + { "Jane" "New Zealand" } + { "Jimmy" "Canada" } + } + ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ - test-db [ - "select * from person" sql-query - ] with-db -] unit-test + [ + test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "oops" throw + ] with-transaction + ] with-db + ] must-fail -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ test-db [ "select * from person" sql-query ] with-db ] unit-test + [ 3 ] [ + test-db [ + "select * from person" sql-query length + ] with-db + ] unit-test -[ -] [ - test-db [ - "insert into person(name, country) values('Jimmy', 'Canada')" - sql-command - ] with-db -] unit-test + [ + ] [ + test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + ] with-transaction + ] with-db + ] unit-test -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - { "Jimmy" "Canada" } - } -] [ test-db [ "select * from person" sql-query ] with-db ] unit-test - -[ - test-db [ - [ - "insert into person(name, country) values('Jose', 'Mexico')" sql-command - "insert into person(name, country) values('Jose', 'Mexico')" sql-command - "oops" throw - ] with-transaction - ] with-db -] must-fail - -[ 3 ] [ - test-db [ - "select * from person" sql-query length - ] with-db -] unit-test - -[ -] [ - test-db [ - [ - "insert into person(name, country) values('Jose', 'Mexico')" - sql-command - "insert into person(name, country) values('Jose', 'Mexico')" - sql-command - ] with-transaction - ] with-db -] unit-test - -[ 5 ] [ - test-db [ - "select * from person" sql-query length - ] with-db -] unit-test + [ 5 ] [ + test-db [ + "select * from person" sql-query length + ] with-db + ] unit-test +] unless : with-dummy-db ( quot -- ) diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 192986484e..0432f38683 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitwise +db.postgresql accessors random math.bitwise system math.ranges strings urls fry db.tuples.private ; IN: db.tuples.tests @@ -26,7 +26,9 @@ IN: db.tuples.tests : test-postgresql ( quot -- ) '[ - [ ] [ postgresql-db _ with-db ] unit-test + os windows? cpu x86.64? and [ + [ ] [ postgresql-db _ with-db ] unit-test + ] unless ] call ; inline ! These words leak resources, but are useful for interactivel testing From f8a23c657bc10c03a9dd8489246f1593d1d31934 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 12:59:29 -0600 Subject: [PATCH 055/441] a bit of refactoring, preparing to take options out of the parsing stage --- basis/regexp/backend/backend.factor | 2 +- basis/regexp/nfa/nfa.factor | 29 ++++++++++++------- basis/regexp/parser/parser.factor | 22 +++++++------- .../transition-tables.factor | 5 ++-- basis/regexp/traversal/traversal.factor | 3 ++ 5 files changed, 37 insertions(+), 24 deletions(-) diff --git a/basis/regexp/backend/backend.factor b/basis/regexp/backend/backend.factor index 75a010b705..4c82876650 100644 --- a/basis/regexp/backend/backend.factor +++ b/basis/regexp/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors hashtables kernel math state-tables vectors ; +USING: accessors hashtables kernel math vectors ; IN: regexp.backend TUPLE: regexp diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 50847d6ff9..99d94b4bcb 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs grouping kernel regexp.backend -locals math namespaces regexp.parser sequences state-tables fry -quotations math.order math.ranges vectors unicode.categories -regexp.utils regexp.transition-tables words sets ; +locals math namespaces regexp.parser sequences fry quotations +math.order math.ranges vectors unicode.categories regexp.utils +regexp.transition-tables words sets ; IN: regexp.nfa SYMBOL: negation-mode @@ -22,6 +22,9 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag +: add-global-flag ( flag -- ) + current-regexp get nfa-table>> flags>> conjoin ; + : next-state ( regexp -- state ) [ state>> ] [ [ 1+ ] change-state drop ] bi ; @@ -138,21 +141,25 @@ M: non-capture-group nfa-node ( node -- ) M: reluctant-kleene-star nfa-node ( node -- ) term>> nfa-node ; - -: add-epsilon-flag ( flag -- ) - eps literal-transition add-simple-entry add-traversal-flag ; - M: beginning-of-line nfa-node ( node -- ) - drop beginning-of-line add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + beginning-of-line add-global-flag ; M: end-of-line nfa-node ( node -- ) - drop end-of-line add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + end-of-line add-global-flag ; M: beginning-of-input nfa-node ( node -- ) - drop beginning-of-input add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + beginning-of-input add-global-flag ; M: end-of-input nfa-node ( node -- ) - drop end-of-input add-epsilon-flag ; + drop + eps literal-transition add-simple-entry + end-of-input add-global-flag ; M: negation nfa-node ( node -- ) negation-mode inc diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index ea8aaffcd5..71a3e067f3 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -58,7 +58,7 @@ SINGLETONS: letter-class LETTER-class Letter-class digit-class alpha-class non-newline-blank-class ascii-class punctuation-class java-printable-class blank-class control-character-class hex-digit-class java-blank-class c-identifier-class -terminator-class unmatchable-class word-boundary-class ; +unmatchable-class terminator-class word-boundary-class ; SINGLETONS: beginning-of-group end-of-group beginning-of-character-class end-of-character-class @@ -87,8 +87,8 @@ left-parenthesis pipe caret dash ; : ( obj -- kleene-star ) kleene-star boa ; : ( obj -- constant ) dup Letter? get-case-insensitive and [ - [ ch>lower constant boa ] - [ ch>upper constant boa ] bi 2array + [ ch>lower ] [ ch>upper ] bi + [ constant boa ] bi@ 2array ] [ constant boa ] if ; @@ -384,20 +384,22 @@ DEFER: handle-left-bracket } case [ (parse-character-class) ] when ; +: push-constant ( ch -- ) push-stack ; + : parse-character-class-second ( -- ) read1 { - { CHAR: [ [ CHAR: [ push-stack ] } - { CHAR: ] [ CHAR: ] push-stack ] } - { CHAR: - [ CHAR: - push-stack ] } + { CHAR: [ [ CHAR: [ push-constant ] } + { CHAR: ] [ CHAR: ] push-constant ] } + { CHAR: - [ CHAR: - push-constant ] } [ push1 ] } case ; : parse-character-class-first ( -- ) read1 { { CHAR: ^ [ caret push-stack parse-character-class-second ] } - { CHAR: [ [ CHAR: [ push-stack ] } - { CHAR: ] [ CHAR: ] push-stack ] } - { CHAR: - [ CHAR: - push-stack ] } + { CHAR: [ [ CHAR: [ push-constant ] } + { CHAR: ] [ CHAR: ] push-constant ] } + { CHAR: - [ CHAR: - push-constant ] } [ push1 ] } case ; @@ -431,7 +433,7 @@ DEFER: handle-left-bracket drop handle-back-anchor f ] [ - push-stack t + push-constant t ] if ] } case ; diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 3050be14fa..80317a1b66 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -25,12 +25,13 @@ TUPLE: default ; : ( from to -- transition ) t default-transition make-transition ; -TUPLE: transition-table transitions start-state final-states ; +TUPLE: transition-table transitions start-state final-states flags ; : ( -- transition-table ) transition-table new H{ } clone >>transitions - H{ } clone >>final-states ; + H{ } clone >>final-states + H{ } clone >>flags ; : maybe-initialize-key ( key hashtable -- ) 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index c880c11c53..d8c25eda18 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -82,6 +82,7 @@ M: end-of-input flag-action ( dfa-traverser flag -- ) drop dup end-of-text? [ t >>match-failed? ] unless drop ; + M: beginning-of-line flag-action ( dfa-traverser flag -- ) drop dup { @@ -96,6 +97,7 @@ M: end-of-line flag-action ( dfa-traverser flag -- ) [ next-text-character terminator-class class-member? ] } 1|| [ t >>match-failed? ] unless drop ; + M: word-boundary flag-action ( dfa-traverser flag -- ) drop dup { @@ -103,6 +105,7 @@ M: word-boundary flag-action ( dfa-traverser flag -- ) [ current-text-character terminator-class class-member? ] } 1|| [ t >>match-failed? ] unless drop ; + M: lookahead-on flag-action ( dfa-traverser flag -- ) drop lookahead-counters>> 0 swap push ; From c4f8da0510390935d4debdcc038ce102335197c4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 24 Nov 2008 22:44:05 +0100 Subject: [PATCH 056/441] Emacs factor mode: better defaults for font-lock faces. --- misc/factor.el | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index c8e637f268..6c9faf50c9 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -109,49 +109,47 @@ buffer." :group 'factor :group 'faces) -(defsubst factor--face (face) `((t ,(face-attr-construct face)))) - -(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) +(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face) "Face for parsing words." :group 'factor-faces) -(defface factor-font-lock-comment (factor--face font-lock-comment-face) +(defface factor-font-lock-comment (face-default-spec font-lock-comment-face) "Face for comments." :group 'factor-faces) -(defface factor-font-lock-string (factor--face font-lock-string-face) +(defface factor-font-lock-string (face-default-spec font-lock-string-face) "Face for strings." :group 'factor-faces) -(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face) +(defface factor-font-lock-stack-effect (face-default-spec font-lock-comment-face) "Face for stack effect specifications." :group 'factor-faces) -(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face) +(defface factor-font-lock-word-definition (face-default-spec font-lock-function-name-face) "Face for word, generic or method being defined." :group 'factor-faces) -(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face) +(defface factor-font-lock-symbol-definition (face-default-spec font-lock-variable-name-face) "Face for name of symbol being defined." :group 'factor-faces) -(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face) +(defface factor-font-lock-vocabulary-name (face-default-spec font-lock-constant-face) "Face for names of vocabularies in USE or USING." :group 'factor-faces) -(defface factor-font-lock-type-definition (factor--face font-lock-type-face) +(defface factor-font-lock-type-definition (face-default-spec font-lock-type-face) "Face for type (tuple) names." :group 'factor-faces) -(defface factor-font-lock-constructor (factor--face font-lock-type-face) +(defface factor-font-lock-constructor (face-default-spec font-lock-type-face) "Face for constructors ()." :group 'factor-faces) -(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face) +(defface factor-font-lock-setter-word (face-default-spec font-lock-function-name-face) "Face for setter words (>>foo)." :group 'factor-faces) -(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) +(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face) "Face for parsing words." :group 'factor-faces) From fbc0f33c86119b29492dea7562a5453b2aa1c994 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 24 Nov 2008 15:59:27 -0600 Subject: [PATCH 057/441] The deploy tool would coalesce equal quotations into one. This created a problem for the non-optimizing compiler because if the new 'leader' quotation was not compiled but some of the ones that it replaces were, then calls to the quotation from contexts where they have to be compiled (eg, compiled if and dip) would no longer work. Add a `jit-compile' primitive to compile quotations, and call it as appropriate in `compress-quotations`. --- basis/tools/deploy/shaker/shaker.factor | 19 +++++++++++++------ core/bootstrap/primitives.factor | 1 + vm/cpu-arm.S | 2 +- vm/cpu-ppc.S | 2 +- vm/cpu-x86.S | 2 +- vm/primitives.c | 1 + vm/quotations.c | 7 ++++++- vm/quotations.h | 3 ++- 8 files changed, 26 insertions(+), 11 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 9cc5a66f70..a537d37d11 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -321,20 +321,27 @@ IN: tools.deploy.shaker ] with-compilation-unit ] unless ; -: compress ( pred string -- ) +: compress ( pred post-process string -- ) "Compressing " prepend show - instances - dup H{ } clone [ [ ] cache ] curry map + [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call become ; inline : compress-byte-arrays ( -- ) - [ byte-array? ] "byte arrays" compress ; + [ byte-array? ] [ ] "byte arrays" compress ; + +: remain-compiled ( old new -- old new ) + #! Quotations which were formerly compiled must remain + #! compiled. + 2dup [ + 2dup [ compiled>> ] [ compiled>> not ] bi* and + [ nip jit-compile ] [ 2drop ] if + ] 2each ; : compress-quotations ( -- ) - [ quotation? ] "quotations" compress ; + [ quotation? ] [ remain-compiled ] "quotations" compress ; : compress-strings ( -- ) - [ string? ] "strings" compress ; + [ string? ] [ ] "strings" compress ; : finish-deploy ( final-image -- ) "Finishing up" show diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 962e562be5..4624963aa6 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -533,6 +533,7 @@ tuple { "dll-valid?" "alien" } { "unimplemented" "kernel.private" } { "gc-reset" "memory" } + { "jit-compile" "quotations" } } [ [ first2 ] dip make-primitive ] each-index diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index d98c033a4f..09e3331b99 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -117,7 +117,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(void,lazy_jit_compile,(CELL quot)): mov r1,sp /* save stack pointer */ PROLOGUE - bl MANGLE(primitive_jit_compile) + bl MANGLE(lazy_jit_compile_impl) EPILOGUE JUMP_QUOT /* call the quotation */ diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 620bc9e991..e12707819a 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -165,7 +165,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(void,lazy_jit_compile,(CELL quot)): mr r4,r1 /* save stack pointer */ PROLOGUE - bl MANGLE(primitive_jit_compile) + bl MANGLE(lazy_jit_compile_impl) EPILOGUE JUMP_QUOT /* call the quotation */ diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 1857fb0ed8..4d6737baeb 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -27,7 +27,7 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): mov STACK_REG,ARG1 /* Save stack pointer */ sub $STACK_PADDING,STACK_REG - call MANGLE(primitive_jit_compile) + call MANGLE(lazy_jit_compile_impl) mov RETURN_REG,ARG0 /* No-op on 32-bit */ add $STACK_PADDING,STACK_REG jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ diff --git a/vm/primitives.c b/vm/primitives.c index 5adb135c82..a34d695bb8 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -140,4 +140,5 @@ void *primitives[] = { primitive_dll_validp, primitive_unimplemented, primitive_gc_reset, + primitive_jit_compile, }; diff --git a/vm/quotations.c b/vm/quotations.c index d8f1a3f61b..a187fecbbb 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -493,7 +493,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) return -1; } -F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) +F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack) { stack_chain->callstack_top = stack; REGISTER_ROOT(quot); @@ -502,6 +502,11 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) return quot; } +void primitive_jit_compile(void) +{ + jit_compile(dpop(),true); +} + /* push a new quotation on the stack */ void primitive_array_to_quotation(void) { diff --git a/vm/quotations.h b/vm/quotations.h index 45bf78d14f..ff84977fd9 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,6 +1,7 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot, bool relocate); -F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); +F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); void primitive_array_to_quotation(void); void primitive_quotation_xt(void); +void primitive_jit_compile(void); From e9aa13150f18d5b4c96f28ef531970b3a94aba7f Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 24 Nov 2008 16:01:53 -0600 Subject: [PATCH 058/441] gc-reset, gc-stats, jit-compile primitives didn't have static stack effects --- basis/stack-checker/known-words/known-words.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 986bbe4c72..6585698b23 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -614,3 +614,9 @@ M: object infer-call* \ modify-code-heap { array object } { } define-primitive \ unimplemented { } { } define-primitive + +\ gc-reset { } { } define-primitive + +\ gc-stats { } { array } define-primitive + +\ jit-compile { quotation } { } define-primitive From 0925bc7002c6d478a6251fde1b1d7c329a7a8760 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 24 Nov 2008 16:02:07 -0600 Subject: [PATCH 059/441] Tweak hello-world deploy descriptor to reduce sizse --- extra/hello-world/deploy.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 219fe0ca05..62b7c2f180 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-name "Hello world (console)" } { deploy-threads? f } + { deploy-name "Hello world (console)" } + { deploy-word-defs? f } { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-io 2 } - { deploy-math? f } { deploy-ui? f } { deploy-compiler? f } + { deploy-io 2 } + { deploy-math? f } + { deploy-reflection 1 } + { deploy-unicode? f } { "stop-after-last-window?" t } - { deploy-word-defs? f } + { deploy-c-types? f } } From b19e87ea7587b2842041f6b7fa1237a2fbe20cdd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 16:28:35 -0600 Subject: [PATCH 060/441] Fix corner case where auto-use didn't print using list --- core/generic/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index c6420164d2..0852459c34 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -16,7 +16,7 @@ ERROR: not-in-a-method-error ; SYMBOL: current-method : with-method-definition ( method quot -- ) - [ dup current-method ] dip with-variable ; inline + over current-method set call current-method off ; inline : (M:) ( method def -- ) CREATE-METHOD [ parse-definition ] with-method-definition ; From 12d4f684ec6dd314168efe13132518935e60c2fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 16:28:56 -0600 Subject: [PATCH 061/441] Fix , , *long, *ulong on win64 --- basis/alien/c-types/c-types-tests.factor | 4 ++++ basis/cpu/x86/64/winnt/winnt.factor | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index edda9e7fdb..5c4f022e93 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -56,3 +56,7 @@ TYPEDEF: uchar* MyLPBYTE ] must-fail [ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test + +os windows? cpu x86.64? and [ + [ -2147467259 ] [ 2147500037 *long ] unit-test +] when diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 9108c0e8f7..629ba23e06 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -23,6 +23,6 @@ M: x86.64 dummy-fp-params? t ; << "longlong" "ptrdiff_t" typedef "longlong" "intptr_t" typedef -"int" "long" typedef -"uint" "ulong" typedef +"int" c-type "long" define-primitive-type +"uint" c-type "ulong" define-primitive-type >> From 499cc882ac9c90b765a2c1451c2d7257e2c083c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 16:49:50 -0600 Subject: [PATCH 062/441] Make scp and ssh commands configurable --- extra/mason/common/common.factor | 8 +++++--- extra/mason/config/config.factor | 9 ++++++++- extra/mason/release/branch/branch-tests.factor | 1 + extra/mason/release/branch/branch.factor | 5 ++--- 4 files changed, 16 insertions(+), 7 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index fc7149e181..49f280fa84 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -15,9 +15,11 @@ IN: mason.common :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] - scp-remote [ { username "@" host ":" temp } concat ] | - { "scp" local scp-remote } short-running-process - { "ssh" host "-l" username "mv" temp remote } short-running-process + scp-remote [ { username "@" host ":" temp } concat ] + scp [ scp-command get ] + ssh [ ssh-command get ] | + { scp local scp-remote } short-running-process + { ssh host "-l" username "mv" temp remote } short-running-process ] ; : eval-file ( file -- obj ) diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index e4ef127413..9169fbf196 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system io.files namespaces kernel accessors ; +USING: system io.files namespaces kernel accessors assocs ; IN: mason.config ! (Optional) Location for build directories @@ -77,3 +77,10 @@ SYMBOL: upload-username ! Directory with binary packages. SYMBOL: upload-directory + +! Optional: override ssh and scp command names +SYMBOL: scp-command +scp-command global [ "scp" or ] change-at + +SYMBOL: ssh-command +ssh-command global [ "ssh" or ] change-at diff --git a/extra/mason/release/branch/branch-tests.factor b/extra/mason/release/branch/branch-tests.factor index ae3ddb61fc..463f8b13c1 100644 --- a/extra/mason/release/branch/branch-tests.factor +++ b/extra/mason/release/branch/branch-tests.factor @@ -14,6 +14,7 @@ USING: mason.release.branch mason.config tools.test namespaces ; [ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [ [ + "scp" scp-command set "joe" image-username set "blah.com" image-host set "/stuff/clean" image-directory set diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index ff2632a9b3..600b08c6b6 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences prettyprint io.files -io.launcher make -mason.common mason.platform mason.config ; +io.launcher make mason.common mason.platform mason.config ; IN: mason.release.branch : branch-name ( -- string ) "clean-" platform append ; @@ -25,7 +24,7 @@ IN: mason.release.branch : upload-clean-image-cmd ( -- args ) [ - "scp" , + scp-command get , boot-image-name , [ image-username get % "@" % From bb99523d39acbbf3f5ca314280fa36679bc1ff81 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 24 Nov 2008 18:55:45 -0600 Subject: [PATCH 063/441] Fix Windows UI --- basis/ui/windows/windows.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 512930d06d..99a7d5fe0f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -9,7 +9,7 @@ windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals symbols accessors -math.geometry.rect math.order ascii ; +math.geometry.rect math.order ascii calendar ; IN: ui.windows SINGLETON: windows-ui-backend @@ -472,7 +472,7 @@ M: windows-ui-backend do-events "MSG" malloc-object msg-obj set-global "Factor-window" utf16n malloc-string class-name-ptr set-global register-wndclassex drop - GetDoubleClickTime double-click-timeout set-global ; + GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) class-name-ptr get-global [ dup f UnregisterClass drop free ] when* From 6f0ec04310d7bfd47bacff62acefe549ab0ef1d0 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 24 Nov 2008 19:09:55 -0600 Subject: [PATCH 064/441] Fix stack effect of param-reg-[12] on x86.3C2 --- basis/cpu/x86/32/32.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/cpu/x86/32/32.factor diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor old mode 100644 new mode 100755 index ecf92b7ede..9fd1330757 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -39,8 +39,8 @@ M:: x86.32 %dispatch ( src temp offset -- ) bi ; ! Registers for fastcall -M: x86.32 param-reg-1 drop EAX ; -M: x86.32 param-reg-2 drop EDX ; +M: x86.32 param-reg-1 EAX ; +M: x86.32 param-reg-2 EDX ; M: x86.32 reserved-area-size 0 ; From b045a39333daa4ed7b315f31c1ee80ae9494f502 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 20:26:11 -0600 Subject: [PATCH 065/441] Re-arrange furnce to avoid circularity --- basis/furnace/actions/actions.factor | 2 +- basis/furnace/asides/asides.factor | 2 +- basis/furnace/auth/auth.factor | 2 +- .../recover-password/recover-password.factor | 9 +- .../features/registration/registration.factor | 2 +- basis/furnace/auth/login/login.factor | 1 - basis/furnace/boilerplate/boilerplate.factor | 5 +- basis/furnace/chloe-tags/chloe-tags.factor | 2 +- .../conversations/conversations.factor | 2 +- basis/furnace/furnace-docs.factor | 123 ----------------- basis/furnace/furnace-tests.factor | 4 +- basis/furnace/furnace.factor | 126 ----------------- basis/furnace/redirection/redirection.factor | 2 +- basis/furnace/referrer/referrer-docs.factor | 2 +- basis/furnace/referrer/referrer.factor | 2 +- basis/furnace/sessions/sessions-tests.factor | 3 +- basis/furnace/sessions/sessions.factor | 10 +- basis/furnace/syndication/syndication.factor | 7 +- basis/furnace/utilities/utilities-docs.factor | 126 +++++++++++++++++ basis/furnace/utilities/utilities.factor | 128 +++++++++++++++++- extra/webapps/wiki/wiki.factor | 2 +- 21 files changed, 280 insertions(+), 282 deletions(-) create mode 100644 basis/furnace/utilities/utilities-docs.factor diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 6c56a8ad7b..72a7b76d23 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -6,7 +6,7 @@ io arrays math boxes splitting urls xml.entities http.server http.server.responses -furnace +furnace.utilities furnace.redirection furnace.conversations html.forms diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 6d4196cf0b..7489d19f94 100644 --- a/basis/furnace/asides/asides.factor +++ b/basis/furnace/asides/asides.factor @@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables urls db.types db.tuples math.parser fry logging combinators html.templates.chloe.syntax http http.server http.server.filters http.server.redirection -furnace furnace.cache furnace.sessions +furnace.utilities furnace.redirection ; IN: furnace.asides diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 1b5c5f9e73..b9c961941c 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -8,8 +8,8 @@ html.forms http.server http.server.filters http.server.dispatchers -furnace furnace.actions +furnace.utilities furnace.redirection furnace.boilerplate furnace.auth.providers diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor index 5885aaef61..77be30a2d1 100644 --- a/basis/furnace/auth/features/recover-password/recover-password.factor +++ b/basis/furnace/auth/features/recover-password/recover-password.factor @@ -1,11 +1,10 @@ ! Copyright (c) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make accessors kernel assocs arrays io.sockets -threads fry urls smtp validators html.forms present -http http.server.responses http.server.redirection -http.server.dispatchers -furnace furnace.actions furnace.auth furnace.auth.providers -furnace.redirection ; +threads fry urls smtp validators html.forms present http +http.server.responses http.server.redirection +http.server.dispatchers furnace.actions furnace.auth +furnace.auth.providers furnace.redirection furnace.utilities ; IN: furnace.auth.features.recover-password SYMBOL: lost-password-from diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor index 0484c11727..7f73f0c404 100644 --- a/basis/furnace/auth/features/registration/registration.factor +++ b/basis/furnace/auth/features/registration/registration.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel namespaces validators html.forms urls http.server.dispatchers -furnace furnace.auth furnace.auth.providers furnace.actions +furnace.auth furnace.auth.providers furnace.actions furnace.redirection ; IN: furnace.auth.features.registration diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 4fc4e7e8be..fff301eb2f 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -3,7 +3,6 @@ USING: kernel accessors namespaces sequences math.parser calendar validators urls logging html.forms http http.server http.server.dispatchers -furnace furnace.auth furnace.asides furnace.actions diff --git a/basis/furnace/boilerplate/boilerplate.factor b/basis/furnace/boilerplate/boilerplate.factor index 946372e1f8..95e93f2ee8 100644 --- a/basis/furnace/boilerplate/boilerplate.factor +++ b/basis/furnace/boilerplate/boilerplate.factor @@ -1,12 +1,13 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.order namespaces furnace combinators.short-circuit +USING: accessors kernel math.order namespaces combinators.short-circuit html.forms html.templates html.templates.chloe locals http.server -http.server.filters ; +http.server.filters +furnace.utilities ; IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template init ; diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 697c885a01..8ab70ded7b 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -19,7 +19,7 @@ http http.server http.server.redirection http.server.responses -furnace ; +furnace.utilities ; QUALIFIED-WITH: assocs a IN: furnace.chloe-tags diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index 671296ce57..266958c8a4 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables urls db.types db.tuples math.parser fry logging combinators html.templates.chloe.syntax http http.server http.server.filters http.server.redirection -furnace furnace.cache furnace.scopes furnace.sessions +furnace.utilities furnace.redirection ; IN: furnace.conversations diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor index 911433d100..c6191b295e 100644 --- a/basis/furnace/furnace-docs.factor +++ b/basis/furnace/furnace-docs.factor @@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel quotations sequences strings urls xml.data http ; IN: furnace -HELP: adjust-redirect-url -{ $values { "url" url } { "url'" url } } -{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ; - -HELP: adjust-url -{ $values { "url" url } { "url'" url } } -{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ; - -HELP: client-state -{ $values { "key" string } { "value/f" { $maybe string } } } -{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } -{ $notes "This word is used by session management, conversation scope and asides." } ; - -HELP: each-responder -{ $values { "quot" { $quotation "( responder -- )" } } } -{ $description "Applies the quotation to each responder involved in processing the current request." } ; - -HELP: hidden-form-field -{ $values { "value" string } { "name" string } } -{ $description "Renders an HTML hidden form field tag." } -{ $notes "This word is used by session management, conversation scope and asides." } -{ $examples - { $example - "USING: furnace io ;" - "\"bar\" \"foo\" hidden-form-field nl" - "" - } -} ; - -HELP: link-attr -{ $values { "tag" tag } { "responder" "a responder" } } -{ $contract "Modifies an XHTML " { $snippet "a" } " tag." } -{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } -{ $examples "Conversation scope adds attributes to link tags." } ; - -HELP: modify-form -{ $values { "responder" "a responder" } } -{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." } -{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } -{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; - -HELP: modify-query -{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } -{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." } -{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } -{ $examples "Asides add query parameters to URLs." } ; - -HELP: modify-redirect-query -{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } -{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." } -{ $notes "This word is called by " { $link "furnace.redirection" } "." } -{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ; - -HELP: nested-responders -{ $values { "seq" "a sequence of responders" } } -{ $description "" } ; - -HELP: referrer -{ $values { "referrer/f" { $maybe string } } } -{ $description "Outputs the current request's referrer URL." } ; - -HELP: request-params -{ $values { "request" request } { "assoc" assoc } } -{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; - -HELP: resolve-base-path -{ $values { "string" string } { "string'" string } } -{ $description "" } ; - -HELP: resolve-template-path -{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } -{ $description "" } ; - -HELP: same-host? -{ $values { "url" url } { "?" "a boolean" } } -{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ; - -HELP: user-agent -{ $values { "user-agent" { $maybe string } } } -{ $description "Outputs the user agent reported by the client for the current request." } ; - -HELP: vocab-path -{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } -{ $description "" } ; - -HELP: exit-with -{ $values { "value" object } } -{ $description "Exits from an outer " { $link with-exit-continuation } "." } ; - -HELP: with-exit-continuation -{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } -{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." } -{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; - -ARTICLE: "furnace.extension-points" "Furnace extension points" -"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." -$nl -"Responders can implement methods on the following generic words:" -{ $subsection modify-query } -{ $subsection modify-redirect-query } -{ $subsection link-attr } -{ $subsection modify-form } -"Presentation-level code can call the following words:" -{ $subsection adjust-url } -{ $subsection adjust-redirect-url } ; - -ARTICLE: "furnace.misc" "Miscellaneous Furnace features" -"Inspecting the chain of responders handling the current request:" -{ $subsection nested-responders } -{ $subsection each-responder } -{ $subsection resolve-base-path } -"Vocabulary root-relative resources:" -{ $subsection vocab-path } -{ $subsection resolve-template-path } -"Early return from a responder:" -{ $subsection with-exit-continuation } -{ $subsection exit-with } -"Other useful words:" -{ $subsection hidden-form-field } -{ $subsection request-params } -{ $subsection client-state } -{ $subsection user-agent } ; - ARTICLE: "furnace.persistence" "Furnace persistence layer" { $subsection "furnace.db" } "Server-side state:" diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index 00e4f6f152..f6e5434997 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,7 @@ IN: furnace.tests USING: http http.server.dispatchers http.server.responses -http.server furnace tools.test kernel namespaces accessors -io.streams.string urls ; +http.server furnace furnace.utilities tools.test kernel +namespaces accessors io.streams.string urls ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index 29eb00a8f4..adafb21524 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -1,133 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make assocs sequences kernel classes splitting -vocabs.loader accessors strings combinators arrays -continuations present fry -urls html.elements -http http.server http.server.redirection http.server.remapping ; IN: furnace -: nested-responders ( -- seq ) - responder-nesting get values ; - -: each-responder ( quot -- ) - nested-responders swap each ; inline - -: base-path ( string -- pair ) - dup responder-nesting get - [ second class superclasses [ name>> = ] with contains? ] with find nip - [ first ] [ "No such responder: " swap append throw ] ?if ; - -: resolve-base-path ( string -- string' ) - "$" ?head [ - [ - "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % - ] "" make - ] when ; - -: vocab-path ( vocab -- path ) - dup vocab-dir vocab-append-path ; - -: resolve-template-path ( pair -- path ) - [ - first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi* - ] "" make ; - -GENERIC: modify-query ( query responder -- query' ) - -M: object modify-query drop ; - -GENERIC: modify-redirect-query ( query responder -- query' ) - -M: object modify-redirect-query drop ; - -GENERIC: adjust-url ( url -- url' ) - -M: url adjust-url - clone - [ [ modify-query ] each-responder ] change-query - [ resolve-base-path ] change-path - relative-to-request ; - -M: string adjust-url ; - -GENERIC: adjust-redirect-url ( url -- url' ) - -M: url adjust-redirect-url - adjust-url - [ [ modify-redirect-query ] each-responder ] change-query ; - -M: string adjust-redirect-url ; - -GENERIC: link-attr ( tag responder -- ) - -M: object link-attr 2drop ; - -GENERIC: modify-form ( responder -- ) - -M: object modify-form drop ; - -: hidden-form-field ( value name -- ) - over [ - - ] [ 2drop ] if ; - -: nested-forms-key "__n" ; - -: request-params ( request -- assoc ) - dup method>> { - { "GET" [ url>> query>> ] } - { "HEAD" [ url>> query>> ] } - { "POST" [ - post-data>> - dup content-type>> "application/x-www-form-urlencoded" = - [ content>> ] [ drop f ] if - ] } - } case ; - -: referrer ( -- referrer/f ) - #! Typo is intentional, it's in the HTTP spec! - "referer" request get header>> at - dup [ >url ensure-port [ remap-port ] change-port ] when ; - -: user-agent ( -- user-agent ) - "user-agent" request get header>> at "" or ; - -: same-host? ( url -- ? ) - dup [ - url get [ - [ protocol>> ] - [ host>> ] - [ port>> remap-port ] - tri 3array - ] bi@ = - ] when ; - -: cookie-client-state ( key request -- value/f ) - swap get-cookie dup [ value>> ] when ; - -: post-client-state ( key request -- value/f ) - request-params at ; - -: client-state ( key -- value/f ) - request get dup method>> { - { "GET" [ cookie-client-state ] } - { "HEAD" [ cookie-client-state ] } - { "POST" [ post-client-state ] } - } case ; - -SYMBOL: exit-continuation - -: exit-with ( value -- ) - exit-continuation get continue-with ; - -: with-exit-continuation ( quot -- value ) - '[ exit-continuation set @ ] callcc1 exit-continuation off ; - USE: vocabs.loader "furnace.actions" require "furnace.alloy" require diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor index c5a63a795c..01297288dc 100644 --- a/basis/furnace/redirection/redirection.factor +++ b/basis/furnace/redirection/redirection.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators namespaces fry urls http http.server http.server.redirection http.server.responses -http.server.remapping http.server.filters furnace ; +http.server.remapping http.server.filters furnace.utilities ; IN: furnace.redirection : ( url -- response ) diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor index 599461c37c..b57bcb262b 100644 --- a/basis/furnace/referrer/referrer-docs.factor +++ b/basis/furnace/referrer/referrer-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io.streams.string -furnace ; +furnace.utilities ; IN: furnace.referrer HELP: diff --git a/basis/furnace/referrer/referrer.factor b/basis/furnace/referrer/referrer.factor index 003028ab1e..e5666c2698 100644 --- a/basis/furnace/referrer/referrer.factor +++ b/basis/furnace/referrer/referrer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel http.server http.server.filters -http.server.responses furnace ; +http.server.responses furnace.utilities ; IN: furnace.referrer TUPLE: referrer-check < filter-responder quot ; diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 6bb3c1cd69..907e657125 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses math namespaces make kernel accessors io.sockets io.servers.connection prettyprint io.streams.string io.files splitting destructors sequences db -db.tuples db.sqlite continuations urls math.parser furnace ; +db.tuples db.sqlite continuations urls math.parser furnace +furnace.utilities ; : with-session [ diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index b7120aaf11..cde95f2831 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.intervals math.parser namespaces -strings random accessors quotations hashtables sequences continuations -fry calendar combinators combinators.short-circuit destructors alarms -io.servers.connection -db db.tuples db.types +strings random accessors quotations hashtables sequences +continuations fry calendar combinators combinators.short-circuit +destructors alarms io.servers.connection db db.tuples db.types http http.server http.server.dispatchers http.server.filters -html.elements -furnace furnace.cache furnace.scopes ; +html.elements furnace.cache furnace.scopes furnace.utilities ; IN: furnace.sessions TUPLE: session < scope user-agent client ; diff --git a/basis/furnace/syndication/syndication.factor b/basis/furnace/syndication/syndication.factor index a326e62f02..876aaf8c98 100644 --- a/basis/furnace/syndication/syndication.factor +++ b/basis/furnace/syndication/syndication.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences fry -combinators syndication -http.server.responses http.server.redirection -furnace furnace.actions ; +USING: accessors kernel sequences fry combinators syndication +http.server.responses http.server.redirection furnace.actions +furnace.utilities ; IN: furnace.syndication GENERIC: feed-entry-title ( object -- string ) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor new file mode 100644 index 0000000000..1402e9c0ca --- /dev/null +++ b/basis/furnace/utilities/utilities-docs.factor @@ -0,0 +1,126 @@ +USING: assocs help.markup help.syntax kernel +quotations sequences strings urls xml.data http ; +IN: furnace.utilities + +HELP: adjust-redirect-url +{ $values { "url" url } { "url'" url } } +{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ; + +HELP: adjust-url +{ $values { "url" url } { "url'" url } } +{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ; + +HELP: client-state +{ $values { "key" string } { "value/f" { $maybe string } } } +{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } +{ $notes "This word is used by session management, conversation scope and asides." } ; + +HELP: each-responder +{ $values { "quot" { $quotation "( responder -- )" } } } +{ $description "Applies the quotation to each responder involved in processing the current request." } ; + +HELP: hidden-form-field +{ $values { "value" string } { "name" string } } +{ $description "Renders an HTML hidden form field tag." } +{ $notes "This word is used by session management, conversation scope and asides." } +{ $examples + { $example + "USING: furnace.utilities io ;" + "\"bar\" \"foo\" hidden-form-field nl" + "" + } +} ; + +HELP: link-attr +{ $values { "tag" tag } { "responder" "a responder" } } +{ $contract "Modifies an XHTML " { $snippet "a" } " tag." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Conversation scope adds attributes to link tags." } ; + +HELP: modify-form +{ $values { "responder" "a responder" } } +{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; + +HELP: modify-query +{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } +{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Asides add query parameters to URLs." } ; + +HELP: modify-redirect-query +{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } +{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." } +{ $notes "This word is called by " { $link "furnace.redirection" } "." } +{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ; + +HELP: nested-responders +{ $values { "seq" "a sequence of responders" } } +{ $description "" } ; + +HELP: referrer +{ $values { "referrer/f" { $maybe string } } } +{ $description "Outputs the current request's referrer URL." } ; + +HELP: request-params +{ $values { "request" request } { "assoc" assoc } } +{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; + +HELP: resolve-base-path +{ $values { "string" string } { "string'" string } } +{ $description "" } ; + +HELP: resolve-template-path +{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } +{ $description "" } ; + +HELP: same-host? +{ $values { "url" url } { "?" "a boolean" } } +{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ; + +HELP: user-agent +{ $values { "user-agent" { $maybe string } } } +{ $description "Outputs the user agent reported by the client for the current request." } ; + +HELP: vocab-path +{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } +{ $description "" } ; + +HELP: exit-with +{ $values { "value" object } } +{ $description "Exits from an outer " { $link with-exit-continuation } "." } ; + +HELP: with-exit-continuation +{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } +{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." } +{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; + +ARTICLE: "furnace.extension-points" "Furnace extension points" +"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." +$nl +"Responders can implement methods on the following generic words:" +{ $subsection modify-query } +{ $subsection modify-redirect-query } +{ $subsection link-attr } +{ $subsection modify-form } +"Presentation-level code can call the following words:" +{ $subsection adjust-url } +{ $subsection adjust-redirect-url } ; + +ARTICLE: "furnace.misc" "Miscellaneous Furnace features" +"Inspecting the chain of responders handling the current request:" +{ $subsection nested-responders } +{ $subsection each-responder } +{ $subsection resolve-base-path } +"Vocabulary root-relative resources:" +{ $subsection vocab-path } +{ $subsection resolve-template-path } +"Early return from a responder:" +{ $subsection with-exit-continuation } +{ $subsection exit-with } +"Other useful words:" +{ $subsection hidden-form-field } +{ $subsection request-params } +{ $subsection client-state } +{ $subsection user-agent } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 4bfbdcd943..f2b71fb89f 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -1,6 +1,9 @@ -! Copyright (c) 2008 Slava Pestov +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors words kernel sequences splitting ; +USING: namespaces make assocs sequences kernel classes splitting +words vocabs.loader accessors strings combinators arrays +continuations present fry urls html.elements http http.server +http.server.redirection http.server.remapping ; IN: furnace.utilities : word>string ( word -- string ) @@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ; : strings>words ( seq -- seq' ) [ string>word ] map ; + +: nested-responders ( -- seq ) + responder-nesting get values ; + +: each-responder ( quot -- ) + nested-responders swap each ; inline + +: base-path ( string -- pair ) + dup responder-nesting get + [ second class superclasses [ name>> = ] with contains? ] with find nip + [ first ] [ "No such responder: " swap append throw ] ?if ; + +: resolve-base-path ( string -- string' ) + "$" ?head [ + [ + "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % + ] "" make + ] when ; + +: vocab-path ( vocab -- path ) + dup vocab-dir vocab-append-path ; + +: resolve-template-path ( pair -- path ) + [ + first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi* + ] "" make ; + +GENERIC: modify-query ( query responder -- query' ) + +M: object modify-query drop ; + +GENERIC: modify-redirect-query ( query responder -- query' ) + +M: object modify-redirect-query drop ; + +GENERIC: adjust-url ( url -- url' ) + +M: url adjust-url + clone + [ [ modify-query ] each-responder ] change-query + [ resolve-base-path ] change-path + relative-to-request ; + +M: string adjust-url ; + +GENERIC: adjust-redirect-url ( url -- url' ) + +M: url adjust-redirect-url + adjust-url + [ [ modify-redirect-query ] each-responder ] change-query ; + +M: string adjust-redirect-url ; + +GENERIC: link-attr ( tag responder -- ) + +M: object link-attr 2drop ; + +GENERIC: modify-form ( responder -- ) + +M: object modify-form drop ; + +: hidden-form-field ( value name -- ) + over [ + + ] [ 2drop ] if ; + +: nested-forms-key "__n" ; + +: request-params ( request -- assoc ) + dup method>> { + { "GET" [ url>> query>> ] } + { "HEAD" [ url>> query>> ] } + { "POST" [ + post-data>> + dup content-type>> "application/x-www-form-urlencoded" = + [ content>> ] [ drop f ] if + ] } + } case ; + +: referrer ( -- referrer/f ) + #! Typo is intentional, it's in the HTTP spec! + "referer" request get header>> at + dup [ >url ensure-port [ remap-port ] change-port ] when ; + +: user-agent ( -- user-agent ) + "user-agent" request get header>> at "" or ; + +: same-host? ( url -- ? ) + dup [ + url get [ + [ protocol>> ] + [ host>> ] + [ port>> remap-port ] + tri 3array + ] bi@ = + ] when ; + +: cookie-client-state ( key request -- value/f ) + swap get-cookie dup [ value>> ] when ; + +: post-client-state ( key request -- value/f ) + request-params at ; + +: client-state ( key -- value/f ) + request get dup method>> { + { "GET" [ cookie-client-state ] } + { "HEAD" [ cookie-client-state ] } + { "POST" [ post-client-state ] } + } case ; + +SYMBOL: exit-continuation + +: exit-with ( value -- ) + exit-continuation get continue-with ; + +: with-exit-continuation ( quot -- value ) + '[ exit-continuation set @ ] callcc1 exit-continuation off ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index b833cc8cc2..b78dc25d79 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -7,8 +7,8 @@ syndication farkup html.components html.forms http.server http.server.dispatchers -furnace furnace.actions +furnace.utilities furnace.redirection furnace.auth furnace.auth.login From 6297c4d2e4879faedb1144b9bf1d020d8dc0fcda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 20:26:29 -0600 Subject: [PATCH 066/441] Make cookie parsing more permissive --- basis/http/http-tests.factor | 9 ++++++++- basis/http/parsers/parsers.factor | 14 ++++++++------ 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 96320b7d12..6e93d5ee3a 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -2,7 +2,7 @@ USING: http http.server http.client tools.test multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls -hashtables accessors ; +hashtables accessors namespaces ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -11,6 +11,12 @@ IN: http.tests [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test +[ { } ] [ "" parse-cookie ] unit-test +[ { } ] [ "" parse-set-cookie ] unit-test + +! Make sure that totally invalid cookies don't confuse us +[ { } ] [ "hello world; how are you" parse-cookie ] unit-test + : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 @@ -126,6 +132,7 @@ content-type: text/html; charset=UTF-8 ; read-response-test-1' 1array [ + URL" http://localhost/" url set read-response-test-1 lf>crlf [ read-response ] with-string-reader [ write-response ] with-string-writer diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index 8e8e7358d1..d72147b381 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -142,16 +142,15 @@ PEG: parse-header-line ( string -- pair ) 'space' , 'attr' , 'space' , - [ "=" token , 'space' , 'value' , ] seq* [ peek ] action - epsilon [ drop f ] action - 2choice , + [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional , 'space' , ] seq* ; : 'av-pairs' ( -- parser ) 'av-pair' ";" token list-of optional ; -PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ; +PEG: (parse-set-cookie) ( string -- alist ) + 'av-pairs' just [ sift ] action ; : 'cookie-value' ( -- parser ) [ @@ -162,7 +161,10 @@ PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ; 'space' , 'value' , 'space' , - ] seq* ; + ] seq* + [ ";,=" member? not ] satisfy repeat1 [ drop f ] action + 2choice ; PEG: (parse-cookie) ( string -- alist ) - 'cookie-value' [ ";," member? ] satisfy list-of optional just ; + 'cookie-value' [ ";," member? ] satisfy list-of + optional just [ sift ] action ; From 6333710f7df99fdce78ec6854a6ccc94b6d96388 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Nov 2008 22:05:43 -0500 Subject: [PATCH 067/441] Fix ave-time considering switch to micro seconds --- extra/project-euler/ave-time/ave-time.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index f176bbc7d2..a7762836f1 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,21 +1,24 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: continuations fry io kernel make math math.functions math.parser math.statistics memory tools.time ; IN: project-euler.ave-time +: nth-place ( x n -- y ) + 10 swap ^ [ * round >integer ] keep /f ; + : collect-benchmarks ( quot n -- seq ) [ [ datastack ] - [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ] + [ + '[ _ gc benchmark 1000 / , ] tuck + '[ _ _ with-datastack drop ] + ] [ 1- ] tri* swap times call ] { } make ; inline -: nth-place ( x n -- y ) - 10 swap ^ [ * round ] keep / ; - : ave-time ( quot n -- ) [ collect-benchmarks ] keep swap - [ std 2 nth-place ] [ mean round ] bi [ + [ std 2 nth-place ] [ mean round >integer ] bi [ # " ms ave run time - " % # " SD (" % # " trials)" % ] "" make print flush ; inline From 37f991420b8242ac0516c8533ae0d205556f1a03 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 22:01:33 -0600 Subject: [PATCH 068/441] fix load error --- extra/webapps/wee-url/wee-url.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index e4a4a6a853..af7c8b61ce 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -4,7 +4,8 @@ USING: math.ranges sequences random accessors combinators.lib kernel namespaces fry db.types db.tuples urls validators html.components html.forms http http.server.dispatchers furnace -furnace.actions furnace.boilerplate furnace.redirection ; +furnace.actions furnace.boilerplate furnace.redirection +furnace.utilities ; IN: webapps.wee-url TUPLE: wee-url < dispatcher ; From e4a2b671d30beda698b120e35a3c440d2bd9ef84 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 22:16:29 -0600 Subject: [PATCH 069/441] remove flags from transition-tables --- basis/regexp/transition-tables/transition-tables.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 80317a1b66..5375d813e1 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -20,18 +20,19 @@ TUPLE: default ; : ( from to obj -- transition ) literal-transition make-transition ; + : ( from to obj -- transition ) class-transition make-transition ; + : ( from to -- transition ) t default-transition make-transition ; -TUPLE: transition-table transitions start-state final-states flags ; +TUPLE: transition-table transitions start-state final-states ; : ( -- transition-table ) transition-table new H{ } clone >>transitions - H{ } clone >>final-states - H{ } clone >>flags ; + H{ } clone >>final-states ; : maybe-initialize-key ( key hashtable -- ) 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ; From 384a11eceec67996d05c67e73aeea0ef459ca52a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 22:17:47 -0600 Subject: [PATCH 070/441] move things around. the parser no longer adjusts nodes based on options, instead opting for nfa to handle it (case-insensitive, multiline, dotall, reversed..) --- basis/regexp/backend/backend.factor | 5 +- basis/regexp/classes/classes.factor | 25 ++++- basis/regexp/nfa/nfa.factor | 85 +++++++++++------ basis/regexp/parser/parser-tests.factor | 4 +- basis/regexp/parser/parser.factor | 118 ++++++++++-------------- basis/regexp/regexp-tests.factor | 39 ++++---- basis/regexp/regexp.factor | 21 +---- basis/regexp/utils/utils.factor | 17 ---- 8 files changed, 158 insertions(+), 156 deletions(-) diff --git a/basis/regexp/backend/backend.factor b/basis/regexp/backend/backend.factor index 4c82876650..5eff0579c8 100644 --- a/basis/regexp/backend/backend.factor +++ b/basis/regexp/backend/backend.factor @@ -5,12 +5,13 @@ IN: regexp.backend TUPLE: regexp raw - { stack vector } - parse-tree { options hashtable } + stack + parse-tree nfa-table dfa-table minimized-table + matchers { nfa-traversal-flags hashtable } { dfa-traversal-flags hashtable } { state integer } diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index f143bebdf7..eec0d309b1 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -1,12 +1,25 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math math.order symbols regexp.parser +USING: accessors kernel math math.order symbols words regexp.utils unicode.categories combinators.short-circuit ; IN: regexp.classes +SINGLETONS: any-char any-char-no-nl +letter-class LETTER-class Letter-class digit-class +alpha-class non-newline-blank-class +ascii-class punctuation-class java-printable-class blank-class +control-character-class hex-digit-class java-blank-class c-identifier-class +unmatchable-class terminator-class word-boundary-class ; + +SINGLETONS: beginning-of-input beginning-of-line +end-of-input end-of-line ; + +MIXIN: node +TUPLE: character-class-range from to ; INSTANCE: character-class-range node + GENERIC: class-member? ( obj class -- ? ) -M: word class-member? ( obj class -- ? ) 2drop f ; +M: t class-member? ( obj class -- ? ) 2drop f ; M: integer class-member? ( obj class -- ? ) 2drop f ; @@ -18,7 +31,7 @@ M: any-char class-member? ( obj class -- ? ) M: any-char-no-nl class-member? ( obj class -- ? ) drop CHAR: \n = not ; - + M: letter-class class-member? ( obj class -- ? ) drop letter? ; @@ -70,3 +83,9 @@ M: terminator-class class-member? ( obj class -- ? ) [ CHAR: \u002028 = ] [ CHAR: \u002029 = ] } 1|| ; + +M: beginning-of-line class-member? ( obj class -- ? ) + 2drop f ; + +M: end-of-line class-member? ( obj class -- ? ) + 2drop f ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 99d94b4bcb..7620652948 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs grouping kernel regexp.backend locals math namespaces regexp.parser sequences fry quotations math.order math.ranges vectors unicode.categories regexp.utils -regexp.transition-tables words sets ; +regexp.transition-tables words sets regexp.classes unicode.case ; IN: regexp.nfa SYMBOL: negation-mode @@ -22,8 +22,13 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag -: add-global-flag ( flag -- ) - current-regexp get nfa-table>> flags>> conjoin ; +: options ( -- obj ) current-regexp get options>> ; + +: option? ( obj -- ? ) options key? ; + +: option-on ( obj -- ) options conjoin ; + +: option-off ( obj -- ) options delete-at ; : next-state ( regexp -- state ) [ state>> ] [ [ 1+ ] change-state drop ] bi ; @@ -106,6 +111,7 @@ M: kleene-star nfa-node ( node -- ) M: concatenation nfa-node ( node -- ) seq>> + reversed-regexp option? [ ] when [ [ nfa-node ] each ] [ length 1- [ concatenate-nodes ] times ] bi ; @@ -115,16 +121,59 @@ M: alternation nfa-node ( node -- ) [ length 1- [ alternate-nodes ] times ] bi ; M: constant nfa-node ( node -- ) - char>> literal-transition add-simple-entry ; + case-insensitive option? [ + dup char>> [ ch>lower ] [ ch>upper ] bi + 2dup = [ + 2drop + char>> literal-transition add-simple-entry + ] [ + [ literal-transition add-simple-entry ] bi@ + alternate-nodes drop + ] if + ] [ + char>> literal-transition add-simple-entry + ] if ; M: epsilon nfa-node ( node -- ) drop eps literal-transition add-simple-entry ; -M: word nfa-node ( node -- ) +M: word nfa-node ( node -- ) class-transition add-simple-entry ; + +M: any-char nfa-node ( node -- ) + [ dotall option? ] dip any-char-no-nl ? class-transition add-simple-entry ; +! M: beginning-of-text nfa-node ( node -- ) ; + +M: beginning-of-line nfa-node ( node -- ) class-transition add-simple-entry ; + +M: end-of-line nfa-node ( node -- ) class-transition add-simple-entry ; + +: choose-letter-class ( node -- node' ) + case-insensitive option? Letter-class rot ? ; + +M: letter-class nfa-node ( node -- ) + choose-letter-class class-transition add-simple-entry ; + +M: LETTER-class nfa-node ( node -- ) + choose-letter-class class-transition add-simple-entry ; + M: character-class-range nfa-node ( node -- ) - class-transition add-simple-entry ; + case-insensitive option? [ + dup [ from>> ] [ to>> ] bi + 2dup [ Letter? ] bi@ and [ + rot drop + [ [ ch>lower ] bi@ character-class-range boa ] + [ [ ch>upper ] bi@ character-class-range boa ] 2bi + [ class-transition add-simple-entry ] bi@ + alternate-nodes + ] [ + 2drop + class-transition add-simple-entry + ] if + ] [ + class-transition add-simple-entry + ] if ; M: capture-group nfa-node ( node -- ) eps literal-transition add-simple-entry @@ -141,26 +190,6 @@ M: non-capture-group nfa-node ( node -- ) M: reluctant-kleene-star nfa-node ( node -- ) term>> nfa-node ; -M: beginning-of-line nfa-node ( node -- ) - drop - eps literal-transition add-simple-entry - beginning-of-line add-global-flag ; - -M: end-of-line nfa-node ( node -- ) - drop - eps literal-transition add-simple-entry - end-of-line add-global-flag ; - -M: beginning-of-input nfa-node ( node -- ) - drop - eps literal-transition add-simple-entry - beginning-of-input add-global-flag ; - -M: end-of-input nfa-node ( node -- ) - drop - eps literal-transition add-simple-entry - end-of-input add-global-flag ; - M: negation nfa-node ( node -- ) negation-mode inc term>> nfa-node @@ -182,6 +211,10 @@ M: lookbehind nfa-node ( node -- ) lookbehind-off add-traversal-flag 2 [ concatenate-nodes ] times ; +M: option nfa-node ( node -- ) + [ option>> ] [ on?>> ] bi [ option-on ] [ option-off ] if + eps literal-transition add-simple-entry ; + : construct-nfa ( regexp -- ) [ reset-regexp diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index 0f25b2e3bf..fe4d2f1d1a 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -19,8 +19,8 @@ IN: regexp.parser [ ] [ "(?:a)" test-regexp ] unit-test [ ] [ "(?i:a)" test-regexp ] unit-test [ ] [ "(?-i:a)" test-regexp ] unit-test -[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with -[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with +[ "(?z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with +[ "(?-z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with [ ] [ "(?=a)" test-regexp ] unit-test diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 71a3e067f3..4d8f3ddfbc 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -4,12 +4,11 @@ USING: accessors arrays assocs combinators io io.streams.string kernel math math.parser namespaces qualified sets quotations sequences splitting symbols vectors math.order unicode.categories strings regexp.backend regexp.utils -unicode.case words locals ; +unicode.case words locals regexp.classes ; IN: regexp.parser FROM: math.ranges => [a,b] ; -MIXIN: node TUPLE: concatenation seq ; INSTANCE: concatenation node TUPLE: alternation seq ; INSTANCE: alternation node TUPLE: kleene-star term ; INSTANCE: kleene-star node @@ -40,38 +39,31 @@ INSTANCE: independent-group parentheses-group TUPLE: comment-group term ; INSTANCE: comment-group node INSTANCE: comment-group parentheses-group -TUPLE: character-class-range from to ; INSTANCE: character-class-range node SINGLETON: epsilon INSTANCE: epsilon node -SINGLETON: any-char INSTANCE: any-char node -SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node -SINGLETON: beginning-of-input INSTANCE: beginning-of-input node -SINGLETON: end-of-input INSTANCE: end-of-input node -SINGLETON: beginning-of-line INSTANCE: beginning-of-line node -SINGLETON: end-of-line INSTANCE: end-of-line node -TUPLE: option-on option ; INSTANCE: option-on node -TUPLE: option-off option ; INSTANCE: option-off node +TUPLE: option option on? ; INSTANCE: option node + SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case reversed-regexp ; -SINGLETONS: letter-class LETTER-class Letter-class digit-class -alpha-class non-newline-blank-class -ascii-class punctuation-class java-printable-class blank-class -control-character-class hex-digit-class java-blank-class c-identifier-class -unmatchable-class terminator-class word-boundary-class ; - -SINGLETONS: beginning-of-group end-of-group -beginning-of-character-class end-of-character-class +SINGLETONS: beginning-of-character-class end-of-character-class left-parenthesis pipe caret dash ; -: get-option ( option -- ? ) current-regexp get options>> at ; -: get-unix-lines ( -- ? ) unix-lines get-option ; -: get-dotall ( -- ? ) dotall get-option ; -: get-multiline ( -- ? ) multiline get-option ; -: get-comments ( -- ? ) comments get-option ; -: get-case-insensitive ( -- ? ) case-insensitive get-option ; -: get-unicode-case ( -- ? ) unicode-case get-option ; -: get-reversed-regexp ( -- ? ) reversed-regexp get-option ; +: push1 ( obj -- ) input-stream get stream>> push ; +: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ; +: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ; +: drop1 ( -- ) read1 drop ; + +: stack ( -- obj ) current-regexp get stack>> ; +: change-whole-stack ( quot -- ) + current-regexp get + [ stack>> swap call ] keep (>>stack) ; inline +: push-stack ( obj -- ) stack push ; +: pop-stack ( -- obj ) stack pop ; +: cut-out ( vector n -- vector' vector ) cut rest ; +ERROR: cut-stack-error ; +: cut-stack ( obj vector -- vector' vector ) + tuck last-index [ cut-stack-error ] unless* cut-out swap ; : ( obj -- kleene ) possessive-kleene-star boa ; : ( obj -- kleene ) reluctant-kleene-star boa ; @@ -80,18 +72,11 @@ left-parenthesis pipe caret dash ; : ( obj -- negation ) negation boa ; : ( seq -- concatenation ) - >vector get-reversed-regexp [ reverse ] when - [ epsilon ] [ concatenation boa ] if-empty ; + >vector [ epsilon ] [ concatenation boa ] if-empty ; : ( seq -- alternation ) >vector alternation boa ; : ( obj -- capture-group ) capture-group boa ; : ( obj -- kleene-star ) kleene-star boa ; -: ( obj -- constant ) - dup Letter? get-case-insensitive and [ - [ ch>lower ] [ ch>upper ] bi - [ constant boa ] bi@ 2array - ] [ - constant boa - ] if ; +: ( obj -- constant ) constant boa ; : first|concatenation ( seq -- first/concatenation ) dup length 1 = [ first ] [ ] if ; @@ -100,21 +85,14 @@ left-parenthesis pipe caret dash ; dup length 1 = [ first ] [ ] if ; : ( from to -- obj ) - 2dup [ Letter? ] bi@ or get-case-insensitive and [ - [ [ ch>lower ] bi@ character-class-range boa ] - [ [ ch>upper ] bi@ character-class-range boa ] 2bi - 2array [ [ from>> ] [ to>> ] bi < ] filter - [ unmatchable-class ] [ first|alternation ] if-empty - ] [ - 2dup < - [ character-class-range boa ] [ 2drop unmatchable-class ] if - ] if ; + 2dup < + [ character-class-range boa ] [ 2drop unmatchable-class ] if ; ERROR: unmatched-parentheses ; -ERROR: bad-option ch ; +ERROR: unknown-regexp-option option ; -: option ( ch -- singleton ) +: ch>option ( ch -- singleton ) { { CHAR: i [ case-insensitive ] } { CHAR: d [ unix-lines ] } @@ -124,13 +102,21 @@ ERROR: bad-option ch ; { CHAR: s [ dotall ] } { CHAR: u [ unicode-case ] } { CHAR: x [ comments ] } - [ bad-option ] + [ unknown-regexp-option ] } case ; -: option-on ( option -- ) current-regexp get options>> conjoin ; -: option-off ( option -- ) current-regexp get options>> delete-at ; +: option>ch ( option -- string ) + { + { case-insensitive [ CHAR: i ] } + { multiline [ CHAR: m ] } + { reversed-regexp [ CHAR: r ] } + { dotall [ CHAR: s ] } + [ unknown-regexp-option ] + } case ; + +: toggle-option ( ch ? -- ) + [ ch>option ] dip option boa push-stack ; -: toggle-option ( ch ? -- ) [ option ] dip [ option-on ] [ option-off ] if ; : (parse-options) ( string ? -- ) [ toggle-option ] curry each ; : parse-options ( string -- ) @@ -176,7 +162,7 @@ DEFER: (parse-regexp) [ drop1 (parse-special-group) ] [ capture-group f nested-parse-regexp ] if ; -: handle-dot ( -- ) get-dotall any-char any-char-no-nl ? push-stack ; +: handle-dot ( -- ) any-char push-stack ; : handle-pipe ( -- ) pipe push-stack ; : (handle-star) ( obj -- kleene-star ) peek1 { @@ -234,11 +220,8 @@ ERROR: invalid-range a b ; [ [ nip at-most-n ] [ at-least-n ] if* ] if ] [ drop 0 max exactly-n ] if ; -: handle-front-anchor ( -- ) - get-multiline beginning-of-line beginning-of-input ? push-stack ; - -: handle-back-anchor ( -- ) - get-multiline end-of-line end-of-input ? push-stack ; +: handle-front-anchor ( -- ) beginning-of-line push-stack ; +: handle-back-anchor ( -- ) end-of-line push-stack ; ERROR: bad-character-class obj ; ERROR: expected-posix-class ; @@ -247,8 +230,8 @@ ERROR: expected-posix-class ; read1 CHAR: { = [ expected-posix-class ] unless "}" read-until [ bad-character-class ] unless { - { "Lower" [ get-case-insensitive Letter-class letter-class ? ] } - { "Upper" [ get-case-insensitive Letter-class LETTER-class ? ] } + { "Lower" [ letter-class ] } + { "Upper" [ LETTER-class ] } { "Alpha" [ Letter-class ] } { "ASCII" [ ascii-class ] } { "Digit" [ digit-class ] } @@ -412,7 +395,8 @@ DEFER: handle-left-bracket [ first|concatenation ] map first|alternation ; : handle-right-parenthesis ( -- ) - stack dup [ parentheses-group "members" word-prop member? ] find-last -rot cut rest + stack dup [ parentheses-group "members" word-prop member? ] find-last + -rot cut rest [ [ push ] keep current-regexp get (>>stack) ] [ finish-regexp-parse push-stack ] bi* ; @@ -429,12 +413,9 @@ DEFER: handle-left-bracket { CHAR: [ [ handle-left-bracket t ] } { CHAR: \ [ handle-escape t ] } [ - dup CHAR: $ = peek1 f = and [ - drop - handle-back-anchor f - ] [ - push-constant t - ] if + dup CHAR: $ = peek1 f = and + [ drop handle-back-anchor f ] + [ push-constant t ] if ] } case ; @@ -451,7 +432,6 @@ DEFER: handle-left-bracket parse-regexp-beginning (parse-regexp) ] with-input-stream ] unless-empty - current-regexp get - stack finish-regexp-parse - >>parse-tree drop + current-regexp get [ finish-regexp-parse ] change-stack + dup stack>> >>parse-tree drop ] with-variable ; diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index e4bab990a4..27936eea1c 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -238,7 +238,7 @@ IN: regexp-tests [ t ] [ "abc" R/ abc/r matches? ] unit-test [ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test -[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/r matches? ] unit-test +[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test [ t ] [ "s@f" "[a-z.-]@[a-z]" matches? ] unit-test [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test @@ -307,17 +307,30 @@ IN: regexp-tests ! Bug in parsing word [ t ] [ "a" R' a' matches? ] unit-test +! Convert to lowercase until E +[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test +[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test + +! Convert to uppercase until E +[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test +[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test + ! [ "{Lower}" ] [ invalid-range? ] must-fail-with -[ t ] [ "a" R/ ^a/ matches? ] unit-test -[ f ] [ "\na" R/ ^a/ matches? ] unit-test -[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test -[ f ] [ "\ra" R/ ^a/ matches? ] unit-test +! [ t ] [ "a" R/ ^a/ matches? ] unit-test +! [ f ] [ "\na" R/ ^a/ matches? ] unit-test +! [ f ] [ "\r\na" R/ ^a/ matches? ] unit-test +! [ f ] [ "\ra" R/ ^a/ matches? ] unit-test -[ t ] [ "a" R/ a$/ matches? ] unit-test -[ f ] [ "a\n" R/ a$/ matches? ] unit-test -[ f ] [ "a\r" R/ a$/ matches? ] unit-test -[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test +! [ t ] [ "a" R/ a$/ matches? ] unit-test +! [ f ] [ "a\n" R/ a$/ matches? ] unit-test +! [ f ] [ "a\r" R/ a$/ matches? ] unit-test +! [ f ] [ "a\r\n" R/ a$/ matches? ] unit-test + +! [ t ] [ "a" R/ a$|b$/ matches? ] unit-test +! [ t ] [ "b" R/ a$|b$/ matches? ] unit-test +! [ t ] [ "ab" R/ a$|b$/ matches? ] unit-test +! [ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test ! [ t ] [ "a" R/ \Aa/ matches? ] unit-test ! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test @@ -347,14 +360,6 @@ IN: regexp-tests ! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test ! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test -! Convert to lowercase until E -[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test -[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test - -! Convert to uppercase until E -[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test -[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test - ! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test ! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test ! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index e61d5692f4..b41e4d271e 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -16,6 +16,7 @@ IN: regexp H{ } clone >>nfa-traversal-flags H{ } clone >>dfa-traversal-flags H{ } clone >>options + H{ } clone >>matchers reset-regexp ; : construct-regexp ( regexp -- regexp' ) @@ -93,26 +94,6 @@ IN: regexp { "R| " "|" } } swap [ subseq? not nip ] curry assoc-find drop ; -ERROR: unknown-regexp-option option ; - -: option>ch ( option -- string ) - { - { case-insensitive [ CHAR: i ] } - { multiline [ CHAR: m ] } - { reversed-regexp [ CHAR: r ] } - { dotall [ CHAR: s ] } - [ unknown-regexp-option ] - } case ; - -: ch>option ( ch -- option ) - { - { CHAR: i [ case-insensitive ] } - { CHAR: m [ multiline ] } - { CHAR: r [ reversed-regexp ] } - { CHAR: s [ dotall ] } - [ unknown-regexp-option ] - } case ; - : string>options ( string -- options ) [ ch>option dup ] H{ } map>assoc ; diff --git a/basis/regexp/utils/utils.factor b/basis/regexp/utils/utils.factor index 5116dd2b7e..af1b2fa1fb 100644 --- a/basis/regexp/utils/utils.factor +++ b/basis/regexp/utils/utils.factor @@ -26,23 +26,6 @@ IN: regexp.utils : ?insert-at ( value key hash/f -- hash ) [ H{ } clone ] unless* [ insert-at ] keep ; -: last-state ( regexp -- range ) stack>> peek first2 [a,b] ; -: push1 ( obj -- ) input-stream get stream>> push ; -: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ; -: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ; -: drop1 ( -- ) read1 drop ; - -: stack ( -- obj ) current-regexp get stack>> ; -: change-whole-stack ( quot -- ) - current-regexp get - [ stack>> swap call ] keep (>>stack) ; inline -: push-stack ( obj -- ) stack push ; -: pop-stack ( -- obj ) stack pop ; -: cut-out ( vector n -- vector' vector ) cut rest ; -ERROR: cut-stack-error ; -: cut-stack ( obj vector -- vector' vector ) - tuck last-index [ cut-stack-error ] unless* cut-out swap ; - ERROR: bad-octal number ; ERROR: bad-hex number ; : check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ; From 1f61f6dad0bcf1d0ac52a5c7d19d9cf22ec58b2e Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 25 Nov 2008 11:48:11 +0100 Subject: [PATCH 071/441] Emacs factor modes: gensym is not needed. --- misc/factor.el | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 6c9faf50c9..790ff0c56a 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -652,13 +652,12 @@ vocabularies which have been modified on disk." ;;; Key bindings: -(defmacro factor--define-key (key cmd &optional both) - (let ((m (gensym)) - (ms '(factor-mode-map))) - (when both (push 'factor-help-mode-map ms)) - `(dolist (,m (list ,@ms)) - (define-key ,m [(control ?c) ,key] ,cmd) - (define-key ,m [(control ?c) (control ,key)] ,cmd)))) +(defun factor--define-key (key cmd &optional both) + (let ((ms (list factor-mode-map))) + (when both (push factor-help-mode-map ms)) + (dolist (m ms) + (define-key m (vector '(control ?c) key) cmd) + (define-key m (vector '(control ?c) `(control ,key)) cmd)))) (factor--define-key ?f 'factor-run-file) (factor--define-key ?r 'factor-send-region) From de957735744620132c63e3291ce2f96d2a507ab5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 25 Nov 2008 05:55:49 -0600 Subject: [PATCH 072/441] generalizations: Update 'npick' to not use >r and r> --- basis/generalizations/generalizations.factor | 141 ++++++++++--------- 1 file changed, 73 insertions(+), 68 deletions(-) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index c63c2b66ca..74291bae33 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,68 +1,73 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo -! Cavazos, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private namespaces math -math.ranges combinators macros quotations fry arrays ; -IN: generalizations - -MACRO: nsequence ( n seq -- quot ) - [ - [ drop ] [ '[ _ _ new-sequence ] ] 2bi - [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce - ] keep - '[ @ _ like ] ; - -MACRO: narray ( n -- quot ) - '[ _ { } nsequence ] ; - -MACRO: firstn ( n -- ) - dup zero? [ drop [ drop ] ] [ - [ [ '[ [ _ ] dip nth-unsafe ] ] map ] - [ 1- '[ [ _ ] dip bounds-check 2drop ] ] - bi prefix '[ _ cleave ] - ] if ; - -MACRO: npick ( n -- ) - 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; - -MACRO: ndup ( n -- ) - dup '[ _ npick ] n*quot ; - -MACRO: nrot ( n -- ) - 1- dup saver swap [ r> swap ] n*quot append ; - -MACRO: -nrot ( n -- ) - 1- dup [ swap >r ] n*quot swap restorer append ; - -MACRO: ndrop ( n -- ) - [ drop ] n*quot ; - -: nnip ( n -- ) - swap >r ndrop r> ; inline - -MACRO: ntuck ( n -- ) - 2 + [ dupd -nrot ] curry ; - -MACRO: nrev ( n -- quot ) - 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; - -MACRO: ndip ( quot n -- ) - dup saver -rot restorer 3append ; - -MACRO: nslip ( n -- ) - dup saver [ call ] rot restorer 3append ; - -MACRO: nkeep ( n -- ) - [ ] [ 1+ ] [ ] tri - '[ [ _ ndup ] dip _ -nrot _ nslip ] ; - -MACRO: ncurry ( n -- ) - [ curry ] n*quot ; - -MACRO: nwith ( n -- ) - [ with ] n*quot ; - -MACRO: napply ( n -- ) - 2 [a,b] - [ [ 1- ] keep '[ _ ntuck _ nslip ] ] - map concat >quotation [ call ] append ; +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private namespaces math +math.ranges combinators macros quotations fry arrays ; +IN: generalizations + +MACRO: nsequence ( n seq -- quot ) + [ + [ drop ] [ '[ _ _ new-sequence ] ] 2bi + [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce + ] keep + '[ @ _ like ] ; + +MACRO: narray ( n -- quot ) + '[ _ { } nsequence ] ; + +MACRO: firstn ( n -- ) + dup zero? [ drop [ drop ] ] [ + [ [ '[ [ _ ] dip nth-unsafe ] ] map ] + [ 1- '[ [ _ ] dip bounds-check 2drop ] ] + bi prefix '[ _ cleave ] + ] if ; + +: npick-wrap ( quot n -- quot ) + dup 1 > + [ swap '[ _ dip swap ] swap 1 - npick-wrap ] + [ drop ] + if ; + +MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ; + +MACRO: ndup ( n -- ) + dup '[ _ npick ] n*quot ; + +MACRO: nrot ( n -- ) + 1- dup saver swap [ r> swap ] n*quot append ; + +MACRO: -nrot ( n -- ) + 1- dup [ swap >r ] n*quot swap restorer append ; + +MACRO: ndrop ( n -- ) + [ drop ] n*quot ; + +: nnip ( n -- ) + swap >r ndrop r> ; inline + +MACRO: ntuck ( n -- ) + 2 + [ dupd -nrot ] curry ; + +MACRO: nrev ( n -- quot ) + 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; + +MACRO: ndip ( quot n -- ) + dup saver -rot restorer 3append ; + +MACRO: nslip ( n -- ) + dup saver [ call ] rot restorer 3append ; + +MACRO: nkeep ( n -- ) + [ ] [ 1+ ] [ ] tri + '[ [ _ ndup ] dip _ -nrot _ nslip ] ; + +MACRO: ncurry ( n -- ) + [ curry ] n*quot ; + +MACRO: nwith ( n -- ) + [ with ] n*quot ; + +MACRO: napply ( n -- ) + 2 [a,b] + [ [ 1- ] keep '[ _ ntuck _ nslip ] ] + map concat >quotation [ call ] append ; From a11453e458d5e94e0ef04ff8528baf1dbf4acc79 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 25 Nov 2008 21:53:06 +0100 Subject: [PATCH 073/441] Emacs factor-mode: fix indentation of empty line after starting word definition. --- misc/factor.el | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 790ff0c56a..346642f70c 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -160,10 +160,6 @@ buffer." ;;; Factor mode font lock: -(defconst factor--regexp-word-start - (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) - (format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|")))) - (defconst factor--parsing-words '("{" "}" "^:" "^::" ";" "<<" ">" "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" @@ -222,6 +218,10 @@ buffer." ;;; Factor mode syntax: +(defconst factor--regexp-word-start + (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) + (format "^\\(%s\\)\\(:\\) " (regexp-opt sws)))) + (defconst factor--font-lock-syntactic-keywords `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;")) (,factor--regexp-word-start (2 "(;")) @@ -321,7 +321,7 @@ buffer." "PRIVATE>" " Date: Tue, 25 Nov 2008 16:26:17 -0600 Subject: [PATCH 074/441] Clean up --- basis/ui/gadgets/canvas/canvas.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 4ff7519a85..0028b9b165 100644 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -12,8 +12,7 @@ TUPLE: canvas < gadget dlist ; : delete-canvas-dlist ( canvas -- ) [ find-gl-context ] - [ dlist>> [ delete-dlist ] when* ] - [ f >>dlist drop ] tri ; + [ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ; : make-canvas-dlist ( canvas quot -- dlist ) [ drop ] [ GL_COMPILE swap make-dlist ] 2bi From 30f93f547f8e2eaeee912842b3e884f6234d69e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Nov 2008 16:47:47 -0600 Subject: [PATCH 075/441] generalizations and delegate no longer uses >r/r> --- basis/delegate/delegate.factor | 12 +----- basis/generalizations/generalizations.factor | 42 ++++++++++---------- 2 files changed, 24 insertions(+), 30 deletions(-) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 12860337ff..3a7cecb800 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions -prettyprint math hashtables sets macros namespaces make ; +prettyprint math hashtables sets generalizations namespaces make ; IN: delegate : protocol-words ( protocol -- words ) @@ -25,15 +25,7 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ - nip - [ - over second saver % - % - dup second restorer % - first , - ] [ ] make - ] 3bi + [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi define ; : change-word-prop ( word prop quot -- ) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 74291bae33..490fa77204 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,10 +1,18 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private namespaces math -math.ranges combinators macros quotations fry arrays ; +USING: kernel sequences sequences.private math math.ranges +combinators macros quotations fry ; IN: generalizations +<< + +: n*quot ( n seq -- seq' ) concat >quotation ; + +: repeat ( n obj quot -- ) swapd times ; inline + +>> + MACRO: nsequence ( n seq -- quot ) [ [ drop ] [ '[ _ _ new-sequence ] ] 2bi @@ -22,44 +30,38 @@ MACRO: firstn ( n -- ) bi prefix '[ _ cleave ] ] if ; -: npick-wrap ( quot n -- quot ) - dup 1 > - [ swap '[ _ dip swap ] swap 1 - npick-wrap ] - [ drop ] - if ; - -MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ; +MACRO: npick ( n -- quot ) + 1- [ dup ] [ '[ _ dip swap ] ] repeat ; MACRO: ndup ( n -- ) dup '[ _ npick ] n*quot ; MACRO: nrot ( n -- ) - 1- dup saver swap [ r> swap ] n*quot append ; + 1- [ ] [ '[ _ dip swap ] ] repeat ; MACRO: -nrot ( n -- ) - 1- dup [ swap >r ] n*quot swap restorer append ; + 1- [ ] [ '[ swap _ dip ] ] repeat ; MACRO: ndrop ( n -- ) [ drop ] n*quot ; -: nnip ( n -- ) - swap >r ndrop r> ; inline +MACRO: nnip ( n -- ) + '[ [ _ ndrop ] dip ] ; MACRO: ntuck ( n -- ) - 2 + [ dupd -nrot ] curry ; + 2 + '[ dup _ -nrot ] ; MACRO: nrev ( n -- quot ) 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; MACRO: ndip ( quot n -- ) - dup saver -rot restorer 3append ; + [ '[ _ dip ] ] times ; MACRO: nslip ( n -- ) - dup saver [ call ] rot restorer 3append ; + '[ [ call ] _ ndip ] ; -MACRO: nkeep ( n -- ) - [ ] [ 1+ ] [ ] tri - '[ [ _ ndup ] dip _ -nrot _ nslip ] ; +MACRO: nkeep ( quot n -- ) + tuck '[ _ ndup _ _ ndip ] ; MACRO: ncurry ( n -- ) [ curry ] n*quot ; @@ -69,5 +71,5 @@ MACRO: nwith ( n -- ) MACRO: napply ( n -- ) 2 [a,b] - [ [ 1- ] keep '[ _ ntuck _ nslip ] ] + [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ] map concat >quotation [ call ] append ; From f3f3b3e76966afa8d7e1a9807eddfeab26e04cc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Nov 2008 16:47:56 -0600 Subject: [PATCH 076/441] Remove some unused words --- basis/macros/macros.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 794d523d00..1481e6eea5 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -22,9 +22,3 @@ M: macro definition "macro" word-prop ; M: macro reset-word [ call-next-method ] [ f "macro" set-word-prop ] bi ; - -: n*quot ( n seq -- seq' ) concat >quotation ; - -: saver ( n -- quot ) \ >r >quotation ; - -: restorer ( n -- quot ) \ r> >quotation ; From 2f025f58ae2b8796aed0f4beaf8b50e7b288a1f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Nov 2008 19:20:25 -0600 Subject: [PATCH 077/441] Frames had problems with resizing --- basis/ui/gadgets/frames/frames-tests.factor | 15 +++++++++++++- basis/ui/gadgets/frames/frames.factor | 22 ++++++++++++--------- 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/basis/ui/gadgets/frames/frames-tests.factor b/basis/ui/gadgets/frames/frames-tests.factor index e38e97c76c..27d511e10a 100644 --- a/basis/ui/gadgets/frames/frames-tests.factor +++ b/basis/ui/gadgets/frames/frames-tests.factor @@ -1,4 +1,17 @@ +USING: accessors kernel namespaces tools.test ui.gadgets +ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ; IN: ui.gadgets.frames.tests -USING: ui.gadgets.frames ui.gadgets tools.test ; [ ] [ layout ] unit-test + +[ t ] [ + + "Hello world"