From 5cdb67d5713b8d7a6010e72c1faf134566b7a0c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Sep 2009 14:46:26 -0500 Subject: [PATCH 1/4] specialized-arrays, specialized-vectors: fix some code duplication and prettyprinting --- .../specialized-arrays-tests.factor | 47 ++++++++++++++++-- .../specialized-arrays.factor | 48 +++++++++---------- .../specialized-vectors.factor | 23 ++------- 3 files changed, 72 insertions(+), 46 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 3290eccd2f..ebc21eec56 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,9 +1,10 @@ IN: specialized-arrays.tests USING: tools.test alien.syntax specialized-arrays -specialized-arrays sequences alien.c-types accessors -kernel arrays combinators compiler classes.struct +specialized-arrays.private sequences alien.c-types accessors +kernel arrays combinators compiler compiler.units classes.struct combinators.smart compiler.tree.debugger math libc destructors -sequences.private ; +sequences.private multiline eval words vocabs namespaces +assocs prettyprint ; SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: bool @@ -106,3 +107,43 @@ SPECIALIZED-ARRAY: fixed-string [ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ ALIEN: 123 4 [ (underlying)>> ] { } map-as ] unit-test + +! Ensure that byte-length works with direct arrays +[ 400 ] [ + ALIEN: 123 100 byte-length +] unit-test + +! Test prettyprinting +[ "int-array{ 1 2 3 }" ] [ int-array{ 1 2 3 } unparse ] unit-test +[ "int-array@ f 100" ] [ f 100 unparse ] unit-test + +! If the C type doesn't exist, don't generate a vocab +[ ] [ + [ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit + "__does_not_exist__" c-types get delete-at +] unit-test + +[ + <" +IN: specialized-arrays.tests +USING: specialized-arrays ; + +SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- ) +] must-fail + +[ ] [ + <" +IN: specialized-arrays.tests +USING: classes.struct specialized-arrays ; + +STRUCT: __does_not_exist__ { x int } ; + +SPECIALIZED-ARRAY: __does_not_exist__ +"> eval( -- ) +] unit-test + +[ f ] [ + "__does_not_exist__-array{" + "__does_not_exist__" specialized-array-vocab lookup + deferred? +] unit-test diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 3a1ce48e68..15245cc710 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types assocs byte-arrays classes -compiler.units functors io kernel lexer libc math -math.vectors.specialization namespaces parser -prettyprint.custom sequences sequences.private strings summary -vocabs vocabs.loader vocabs.parser words ; +compiler.units functors kernel lexer libc math +math.vectors.specialization namespaces parser prettyprint.custom +sequences sequences.private strings summary vocabs vocabs.loader +vocabs.parser words fry combinators ; IN: specialized-arrays MIXIN: specialized-array @@ -86,8 +86,12 @@ M: A resize ] [ drop ] 2bi ; inline -M: A byte-length underlying>> length ; inline +M: A byte-length length T heap-size * ; inline + +M: A direct-array-syntax drop \ A@ ; + M: A pprint-delims drop \ A{ \ } ; + M: A >pprint-sequence ; SYNTAX: A{ \ } [ >A ] parse-literal ; @@ -100,34 +104,30 @@ A T c-type-boxed-class f specialize-vector-words ;FUNCTOR : underlying-type ( c-type -- c-type' ) - dup c-types get at string? [ - c-types get at underlying-type - ] when ; + dup c-types get at { + { [ dup not ] [ drop no-c-type ] } + { [ dup string? ] [ nip underlying-type ] } + [ drop ] + } cond ; : specialized-array-vocab ( c-type -- vocab ) "specialized-arrays.instances." prepend ; -: defining-array-message ( type -- ) - "quiet" get [ drop ] [ - "Generating specialized " " arrays..." surround print - ] if ; - PRIVATE> -: define-array-vocab ( type -- vocab ) - underlying-type - dup specialized-array-vocab vocab - [ ] [ - [ defining-array-message ] +: generate-vocab ( vocab-name quot -- vocab ) + [ dup vocab [ ] ] dip '[ [ [ - dup specialized-array-vocab - [ define-array ] with-current-vocab + _ with-current-vocab ] with-compilation-unit - ] - [ specialized-array-vocab ] - tri - ] ?if ; + ] keep + ] ?if ; inline + +: define-array-vocab ( type -- vocab ) + underlying-type + [ specialized-array-vocab ] [ '[ _ define-array ] ] bi + generate-vocab ; M: string require-c-array define-array-vocab drop ; diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index 19f32a7fdb..dbadd7a74a 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs compiler.units functors -growable io kernel lexer namespaces parser prettyprint.custom +growable kernel lexer namespaces parser prettyprint.custom sequences specialized-arrays specialized-arrays.private strings vocabs vocabs.parser ; QUALIFIED: vectors.functor @@ -44,27 +44,12 @@ INSTANCE: V S : specialized-vector-vocab ( type -- vocab ) "specialized-vectors.instances." prepend ; -: defining-vector-message ( type -- ) - "quiet" get [ drop ] [ - "Generating specialized " " vectors..." surround print - ] if ; - PRIVATE> -: define-vector-vocab ( type -- vocab ) +: define-vector-vocab ( type -- vocab ) underlying-type - dup specialized-vector-vocab vocab - [ ] [ - [ defining-vector-message ] - [ - [ - dup specialized-vector-vocab - [ define-vector ] with-current-vocab - ] with-compilation-unit - ] - [ specialized-vector-vocab ] - tri - ] ?if ; + [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi + generate-vocab ; SYNTAX: SPECIALIZED-VECTOR: scan From d9ebfe5f4898230fe182948eb652d40c226a1362 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Sep 2009 15:53:14 -0500 Subject: [PATCH 2/4] syntax: improve T{ docs --- core/syntax/syntax-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 50c7c047c7..fd5590fde1 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -302,7 +302,7 @@ HELP: C{ { $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ; HELP: T{ -{ $syntax "T{ class slots... }" } +{ $syntax "T{ class }" "T{ class f slot-values... }" "T{ class { slot-name slot-value } ... }" } { $values { "class" "a tuple class word" } { "slots" "slot values" } } { $description "Marks the beginning of a literal tuple." $nl From d5bc1ceca239682ee23f20c781782606c5182f6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Sep 2009 15:59:27 -0500 Subject: [PATCH 3/4] classes.struct: fix some bugs - STRUCT: foo in listener threw an error - S{ did not throw an error when used with non-struct types - attempting to subclass a struct class now fails - forgetting a struct class now removes the corresponding C type - 'see'ing a struct class now indents correctly --- .../struct/prettyprint/prettyprint.factor | 4 +- basis/classes/struct/struct-tests.factor | 58 +++++++++---------- basis/classes/struct/struct.factor | 49 ++++++++-------- core/classes/tuple/tuple.factor | 9 ++- 4 files changed, 64 insertions(+), 56 deletions(-) diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index 58c923e6d0..e88834530c 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -18,12 +18,12 @@ IN: classes.struct.prettyprint : pprint-struct-slot ( slot -- ) > text ] [ c-type>> dup string? [ text ] [ pprint* ] if ] [ read-only>> [ \ read-only pprint-word ] when ] [ initial>> [ \ initial: pprint-word pprint* ] when* ] - } cleave + } cleave block> \ } pprint-word block> ; : pprint-struct ( struct -- ) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 22d194d2a4..8508230bb2 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,31 +1,16 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.libraries -alien.structs.fields alien.syntax ascii assocs byte-arrays -classes.struct classes.tuple.private combinators -compiler.tree.debugger compiler.units destructors +USING: accessors alien alien.c-types alien.structs.fields ascii +assocs byte-arrays classes.struct classes.tuple.private +combinators compiler.tree.debugger compiler.units destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math mirrors multiline namespaces prettyprint -prettyprint.config see sequences specialized-arrays -system tools.test ; +prettyprint.config see sequences specialized-arrays system +tools.test parser lexer eval ; SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: ushort IN: classes.struct.tests -<< -: libfactor-ffi-tests-path ( -- string ) - "resource:" (normalize-path) - { - { [ os winnt? ] [ "libfactor-ffi-test.dll" ] } - { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } - { [ os unix? ] [ "libfactor-ffi-test.so" ] } - } cond append-path ; - -"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library - -"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library ->> - SYMBOL: struct-test-empty [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ] @@ -278,15 +263,6 @@ STRUCT: struct-test-equality-2 ] with-destructors ] unit-test -STRUCT: struct-test-ffi-foo - { x int } - { y int } ; - -LIBRARY: f-cdecl -FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ; - -[ 14 ] [ 1 2 3 struct-test-ffi-foo 4 ffi_test_11 ] unit-test - STRUCT: struct-test-array-slots { x int } { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } } @@ -350,3 +326,27 @@ STRUCT: struct-that's-a-word { x int } ; [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test +! Interactive parsing of struct slot definitions +[ + "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" + "struct-class-test-1" parse-stream +] [ error>> error>> unexpected-eof? ] must-fail-with + +! S{ with non-struct type +[ + "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }" + eval( -- value ) +] must-fail + +! Subclassing a struct class should not be allowed +[ + "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;" + eval( -- ) +] must-fail + +! Remove c-type when struct class is forgotten +[ ] [ + "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- ) +] unit-test + +[ f ] [ "a-struct" c-types get key? ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 24d7e592bd..893bc5a257 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -6,7 +6,7 @@ combinators combinators.short-circuit combinators.smart definitions functors.backend fry generalizations generic.parser kernel kernel.private lexer libc locals macros make math math.order parser quotations sequences slots slots.private -specialized-arrays vectors words +specialized-arrays vectors words summary namespaces assocs compiler.tree.propagation.transforms ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -15,16 +15,23 @@ SPECIALIZED-ARRAY: uchar ERROR: struct-must-have-slots ; +M: struct-must-have-slots summary + drop "Struct definitions must have slots" ; + TUPLE: struct { (underlying) c-ptr read-only } ; TUPLE: struct-slot-spec < slot-spec c-type ; -PREDICATE: struct-class < tuple-class \ struct subclass-of? ; +PREDICATE: struct-class < tuple-class + superclass \ struct eq? ; -: struct-slots ( struct-class -- slots ) - "struct-slots" word-prop ; +M: struct-class valid-superclass? drop f ; + +GENERIC: struct-slots ( struct-class -- slots ) + +M: struct-class struct-slots "struct-slots" word-prop ; ! struct allocation @@ -175,36 +182,27 @@ M: struct-class writer-quot [ c-type>> c-type-align ] [ max ] map-reduce ; PRIVATE> -M: struct-class c-type - name>> c-type ; +M: struct-class c-type name>> c-type ; -M: struct-class c-type-align - "struct-align" word-prop ; +M: struct-class c-type-align c-type c-type-align ; -M: struct-class c-type-getter - drop [ swap ] ; +M: struct-class c-type-getter c-type c-type-getter ; -M: struct-class c-type-setter - [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri - '[ @ swap @ _ memcpy ] ; +M: struct-class c-type-setter c-type c-type-setter ; -M: struct-class c-type-boxer-quot - (boxer-quot) ; +M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ; -M: struct-class c-type-unboxer-quot - (unboxer-quot) ; +M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ; -M: struct-class heap-size - "struct-size" word-prop ; +M: struct-class heap-size c-type heap-size ; -M: struct byte-length - class "struct-size" word-prop ; foldable +M: struct byte-length class "struct-size" word-prop ; foldable ! class definition ] + [ "struct-size" word-prop ] [ memory>struct ] [ struct-slots ] tri [ @@ -237,8 +235,9 @@ M: struct byte-length : (define-struct-class) ( class slots offsets-quot -- ) [ + empty? [ struct-must-have-slots ] - [ drop redefine-struct-tuple-class ] if-empty + [ redefine-struct-tuple-class ] if ] swap '[ make-slots dup @@ -254,6 +253,9 @@ PRIVATE> : define-union-struct-class ( class slots -- ) [ union-struct-offsets ] (define-struct-class) ; +M: struct-class reset-class + [ call-next-method ] [ name>> c-types get delete-at ] bi ; + ERROR: invalid-struct-slot token ; : struct-slot-class ( c-type -- class' ) @@ -277,6 +279,7 @@ ERROR: invalid-struct-slot token ; scan { { ";" [ f ] } { "{" [ parse-struct-slot over push t ] } + { f [ unexpected-eof ] } [ invalid-struct-slot ] } case ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 44eae9038f..0b1cd513b7 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -252,8 +252,13 @@ M: tuple-class update-class [ [ "slots" word-prop ] dip = ] bi-curry* bi and ; -: valid-superclass? ( class -- ? ) - [ tuple-class? ] [ tuple eq? ] bi or ; +GENERIC: valid-superclass? ( class -- ? ) + +M: tuple-class valid-superclass? drop t ; + +M: builtin-class valid-superclass? tuple eq? ; + +M: class valid-superclass? drop f ; : check-superclass ( superclass -- ) dup valid-superclass? [ bad-superclass ] unless drop ; From cffa0c2b4f6aa2732e60a9fe203ccde7b320bc37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Sep 2009 18:32:45 -0500 Subject: [PATCH 4/4] benchmark: rename (run-benchmark) to run-benchmark, and run-benchmark to record-benchmark, since (run-benchmark) was actually useful on its own --- extra/benchmark/benchmark.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 23809f2744..b6e65f44cb 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -12,23 +12,27 @@ SYMBOL: errors PRIVATE> -: (run-benchmark) ( vocab -- time ) +: run-benchmark ( vocab -- time ) [ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ; -: run-benchmark ( vocab -- ) + + : run-benchmarks ( -- timings errors ) [ V{ } clone timings set V{ } clone errors set "benchmark" child-vocab-names [ find-vocab-root ] filter - [ run-benchmark ] each + [ record-benchmark ] each timings get errors get ] with-scope ;