steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2009-09-10 21:26:20 -04:00
parent 5e4751db64 cffa0c2b4f
commit f029a854eb
9 changed files with 144 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -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 -- )

58
basis/classes/struct/struct-tests.factor
View File

@ -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 <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

49
basis/classes/struct/struct.factor
View File

@ -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 <displaced-alien> ] ;
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
<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 ;

47
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -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 <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

48
basis/specialized-arrays/specialized-arrays.factor
View File

@ -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
<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? [
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 ;

23
basis/specialized-vectors/specialized-vectors.factor
View File

@ -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

9
core/classes/tuple/tuple.factor
View File

@ -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 ;

2
core/syntax/syntax-docs.factor
View File

@ -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

10
extra/benchmark/benchmark.factor
View File

@ -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 ;