Merge branch 'master' of git://factorcode.org/git/factor

basis/classes/struct/prettyprint/prettyprint.factor

@@ -18,12 +18,12 @@ IN: classes.struct.prettyprint
 
 : pprint-struct-slot ( slot -- )
     <flow \ { pprint-word
-    {
+    f <inset {
         [ name>> 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 -- )

basis/classes/struct/struct-tests.factor

@@ -1,31 +1,16 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.libraries
+USING: accessors alien alien.c-types alien.structs.fields ascii
-alien.structs.fields alien.syntax ascii assocs byte-arrays
+assocs byte-arrays classes.struct classes.tuple.private
-classes.struct classes.tuple.private combinators
+combinators compiler.tree.debugger compiler.units destructors
-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
+prettyprint.config see sequences specialized-arrays system
-system tools.test ;
+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 <struct-boa> 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" <string-reader>
+    "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

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 )
+M: struct-class valid-superclass? drop f ;
-    "struct-slots" word-prop ;
+
+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
+M: struct-class c-type name>> c-type ;
-    name>> c-type ;
 
-M: struct-class c-type-align
+M: struct-class c-type-align c-type c-type-align ;
-    "struct-align" word-prop ;
 
-M: struct-class c-type-getter
+M: struct-class c-type-getter c-type c-type-getter ;
-    drop [ swap <displaced-alien> ] ;
 
-M: struct-class c-type-setter
+M: struct-class c-type-setter c-type c-type-setter ;
-    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
-    '[ @ swap @ _ memcpy ] ;
 
-M: struct-class c-type-boxer-quot
+M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
-    (boxer-quot) ;
 
-M: struct-class c-type-unboxer-quot
+M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
-    (unboxer-quot) ;
 
-M: struct-class heap-size
+M: struct-class heap-size c-type heap-size ;
-    "struct-size" word-prop ;
 
-M: struct byte-length
+M: struct byte-length class "struct-size" word-prop ; foldable
-    class "struct-size" word-prop ; foldable
 
 ! class definition
 
 <PRIVATE
 : make-struct-prototype ( class -- prototype )
-    [ heap-size <byte-array> ]
+    [ "struct-size" word-prop <byte-array> ]
     [ 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 ;
 

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
+specialized-arrays.private sequences alien.c-types accessors
-kernel arrays combinators compiler classes.struct
+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 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
 ] unit-test
+
+! Ensure that byte-length works with direct arrays
+[ 400 ] [
+    ALIEN: 123 100 <direct-int-array> 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 <direct-int-array> 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

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
+compiler.units functors kernel lexer libc math
-math.vectors.specialization namespaces parser
+math.vectors.specialization namespaces parser prettyprint.custom
-prettyprint.custom sequences sequences.private strings summary
+sequences sequences.private strings summary vocabs vocabs.loader
-vocabs vocabs.loader vocabs.parser words ;
+vocabs.parser words fry combinators ;
 IN: specialized-arrays
 
 MIXIN: specialized-array
@@ -86,8 +86,12 @@ M: A resize
     ] [ drop ] 2bi
     <direct-A> ; 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? [
+    dup c-types get at {
-        c-types get at underlying-type
+        { [ dup not ] [ drop no-c-type ] }
-    ] when ;
+        { [ 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 )
+: generate-vocab ( vocab-name quot -- vocab )
-    underlying-type
+    [ dup vocab [ ] ] dip '[
-    dup specialized-array-vocab vocab
-    [ ] [
-        [ defining-array-message ]
         [
             [
-                dup specialized-array-vocab
+                 _ with-current-vocab
-                [ define-array ] with-current-vocab
             ] with-compilation-unit
-        ]
+        ] keep
-        [ specialized-array-vocab ]
+    ] ?if ; inline
-        tri
+
-    ] ?if ;
+: define-array-vocab ( type -- vocab )
+    underlying-type
+    [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
+    generate-vocab ;
 
 M: string require-c-array define-array-vocab drop ;
 

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
+    [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
-    [ ] [
+    generate-vocab ;
-        [ defining-vector-message ]
-        [
-            [
-                dup specialized-vector-vocab
-                [ define-vector ] with-current-vocab
-            ] with-compilation-unit
-        ]
-        [ specialized-vector-vocab ]
-        tri
-    ] ?if ;
 
 SYNTAX: SPECIALIZED-VECTOR:
     scan

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 -- ? )
+GENERIC: valid-superclass? ( class -- ? )
-    [ tuple-class? ] [ tuple eq? ] bi or ;
+
+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 ;

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

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 -- )
+<PRIVATE
+
+: record-benchmark ( vocab -- )
     [ "=== " write print flush ] [
         [ [ require ] [ (run-benchmark) ] [ ] tri timings ]
         [ swap errors ]
         recover get set-at
     ] bi ;
 
+PRIVATE>
+
 : 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 ;