From b03eaf3c32885517c23c691353c3bbb2c7a245a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 15:42:46 -0500 Subject: [PATCH 1/9] math: minor doc fixes --- basis/math/functions/functions-docs.factor | 1 + basis/math/libm/libm-docs.factor | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index d61ad9a14a..fb392191d4 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -48,6 +48,7 @@ ARTICLE: "power-functions" "Powers and logarithms" { $subsection exp } { $subsection cis } { $subsection log } +"Other logarithms:" { $subsection log1+ } { $subsection log10 } "Raising a number to a power:" diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index abbb6f1289..64f6026f0b 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions" { $warning "These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:" { $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" } -{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } } +{ $unchecked-example "USE: math.libm" "2.0 facos ." "0/0." } } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } @@ -20,6 +20,7 @@ ARTICLE: "math.libm" "C standard library math functions" "Exponentials and logarithms:" { $subsection fexp } { $subsection flog } +{ $subsection flog10 } "Powers:" { $subsection fpow } { $subsection fsqrt } ; @@ -66,6 +67,10 @@ HELP: flog { $values { "x" real } { "y" real } } { $description "Calls the natural logarithm function from the C standard library. User code should call " { $link log } " instead." } ; +HELP: flog10 +{ $values { "x" real } { "y" real } } +{ $description "Calls the base 10 logarithm function from the C standard library. User code should call " { $link log10 } " instead." } ; + HELP: fpow { $values { "x" real } { "y" real } { "z" real } } { $description "Calls the power function (" { $snippet "z=x^y" } ") from the C standard library. User code should call " { $link ^ } " instead." } ; From 9382c674372f55be58cd64ce903c87c3d08d2d4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 16:24:58 -0500 Subject: [PATCH 2/9] alien.syntax: improve C-ENUM: docs --- basis/alien/syntax/syntax-docs.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index c9190f68c0..e56c83a154 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -73,10 +73,12 @@ HELP: C-ENUM: { $syntax "C-ENUM: words... ;" } { $values { "words" "a sequence of word names" } } { $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." } -{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." } +{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." } { $examples - "The following two lines are equivalent:" - { $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" } + "Here is an example enumeration definition:" + { $code "C-ENUM: red green blue ;" } + "It is equivalent to the following series of definitions:" + { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" } } ; HELP: &: From 172219e93105f0e7bffa8c70334cc7209b816b0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 14:30:20 -0700 Subject: [PATCH 3/9] compiler.tree.propagation: fix unary-op type functions with complex number inputs --- .../compiler/tree/propagation/known-words/known-words.factor | 5 ++++- basis/compiler/tree/propagation/propagation-tests.factor | 4 ++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 63d2df543d..621b8d082b 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -81,7 +81,10 @@ IN: compiler.tree.propagation.known-words class>> dup null-class? [ drop null ] [ math-closure ] if ; : unary-op-interval ( info quot -- newinterval ) - [ interval>> ] dip call ; inline + [ + dup class>> real classes-intersect? + [ interval>> ] [ drop full-interval ] if + ] dip call ; inline : unary-op ( word interval-quot post-proc-quot -- ) '[ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index ec5fbd95cd..0c220542ca 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -186,6 +186,10 @@ IN: compiler.tree.propagation.tests [ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test +[ t ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test + +[ V{ float } ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test + [ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test [ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test From 096c7e7a47ffc41b6bf5c309120f334cfdad7972 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 14:48:56 -0700 Subject: [PATCH 4/9] help.html: don't strip out vocabs without roots since that gets rid of private vocabs --- basis/help/html/html-tests.factor | 8 +++++++- basis/help/html/html.factor | 3 ++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 90ff6c110f..b4e6103868 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -1,6 +1,12 @@ -USING: help.html tools.test help.topics kernel ; +USING: help.html tools.test help.topics kernel sequences vocabs ; IN: help.html.tests [ ] [ "xml" >link help>html drop ] unit-test [ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test + +[ t ] [ all-vocabs-really [ vocab-spec? ] all? ] unit-test + +[ t ] [ all-vocabs-really [ vocab-name "sequences.private" = ] any? ] unit-test + +[ f ] [ all-vocabs-really [ vocab-name "scratchpad" = ] any? ] unit-test diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index e8cc7e04c5..948b52a345 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -73,7 +73,8 @@ M: topic url-of topic>filename ; dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; : all-vocabs-really ( -- seq ) - all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ; + all-vocabs-recursive >hashtable no-roots remove-redundant-prefixes + [ vocab-name "scratchpad" = not ] filter ; : all-topics ( -- topics ) [ From 4d16c569f0002574bb9deb467726f2e27229a62c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Sep 2009 17:38:49 -0500 Subject: [PATCH 5/9] struct classes now make their own C type without help from alien.structs. remove alien.structs dependencies from everywhere outside of alien and compiler, and have the FFI handle both alien.structs and classes.struct c-types --- basis/alien/arrays/arrays.factor | 13 +-- basis/alien/c-types/c-types.factor | 18 ++++ basis/alien/complex/complex.factor | 2 +- basis/alien/complex/functor/functor.factor | 2 +- basis/alien/fortran/fortran-docs.factor | 9 +- basis/alien/fortran/fortran-tests.factor | 33 +------ basis/alien/fortran/fortran.factor | 10 +- basis/alien/structs/structs.factor | 4 +- basis/classes/struct/struct-tests.factor | 17 ++-- basis/classes/struct/struct.factor | 107 ++++++++++++--------- basis/compiler/alien/alien.factor | 2 +- basis/compiler/cfg/builder/builder.factor | 4 +- basis/compiler/codegen/codegen.factor | 9 +- basis/cpu/x86/64/64.factor | 2 +- basis/cpu/x86/64/unix/unix.factor | 11 ++- extra/gpu/render/render.factor | 2 +- 16 files changed, 126 insertions(+), 119 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 64827ec139..a69f7609b1 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.strings alien.c-types alien.accessors alien.structs +USING: alien alien.strings alien.c-types alien.accessors arrays words sequences math kernel namespaces fry libc cpu.architecture io.encodings.utf8 accessors ; IN: alien.arrays -UNION: value-type array struct-type ; +INSTANCE: array value-type M: array c-type ; @@ -40,15 +40,6 @@ M: array c-type-boxer-quot M: array c-type-unboxer-quot drop [ >c-ptr ] ; -M: value-type c-type-rep drop int-rep ; - -M: value-type c-type-getter - drop [ swap ] ; - -M: value-type c-type-setter ( type -- quot ) - [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri - '[ @ swap @ _ memcpy ] ; - PREDICATE: string-type < pair first2 [ "char*" = ] [ word? ] bi* and ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index b177ab35d4..35a9627d50 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -71,6 +71,13 @@ M: string c-type ( name -- type ) ] ?if ] if ; +GENERIC: c-struct? ( type -- ? ) + +M: object c-struct? + drop f ; +M: string c-struct? + dup "void" = [ drop f ] [ c-type c-struct? ] if ; + ! These words being foldable means that words need to be ! recompiled if a C type is redefined. Even so, folding the ! size facilitates some optimizations. @@ -215,6 +222,17 @@ M: string stack-size c-type stack-size ; M: c-type stack-size size>> cell align ; +MIXIN: value-type + +M: value-type c-type-rep drop int-rep ; + +M: value-type c-type-getter + drop [ swap ] ; + +M: value-type c-type-setter ( type -- quot ) + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; + GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; inline diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index b0229358d1..65c4095e25 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.structs alien.complex.functor accessors +USING: alien.c-types alien.complex.functor accessors sequences kernel ; IN: alien.complex diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index b1f9c2be85..1faa64be61 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.structs alien.c-types classes.struct math +USING: accessors alien alien.c-types classes.struct math math.functions sequences arrays kernel functors vocabs.parser namespaces quotations ; IN: alien.complex.functor diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 8027020c75..7778500bf1 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations sequences strings words.symbol ; +USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ; QUALIFIED-WITH: alien.syntax c IN: alien.fortran @@ -25,7 +25,7 @@ ARTICLE: "alien.fortran-types" "Fortran types" { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } - { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." } + { "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." } } "When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; @@ -42,10 +42,6 @@ HELP: LIBRARY: { $values { "name" "a logical library name" } } { $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ; -HELP: RECORD: -{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } -{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ; - HELP: add-fortran-library { $values { "name" string } { "soname" string } { "fortran-abi" symbol } } { $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." } @@ -66,7 +62,6 @@ ARTICLE: "alien.fortran" "Fortran FFI" { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } { $subsection POSTPONE: SUBROUTINE: } -{ $subsection POSTPONE: RECORD: } { $subsection fortran-invoke } ; diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 177d1077c2..9d893b95c4 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,6 +1,6 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.complex -alien.fortran alien.fortran.private alien.strings alien.structs +alien.fortran alien.fortran.private alien.strings classes.struct arrays assocs byte-arrays combinators fry generalizations io.encodings.ascii kernel macros macros.expander namespaces sequences shuffle tools.test ; @@ -8,10 +8,10 @@ IN: alien.fortran.tests << intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> LIBRARY: (alien.fortran-tests) -RECORD: FORTRAN_TEST_RECORD - { "INTEGER" "FOO" } - { "REAL(2)" "BAR" } - { "CHARACTER*4" "BAS" } ; +STRUCT: FORTRAN_TEST_RECORD + { FOO int } + { BAR double[2] } + { BAS char[4] } ; intel-unix-abi fortran-abi [ @@ -168,29 +168,6 @@ intel-unix-abi fortran-abi [ [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test - ! fortran-record>c-struct - - [ { - { "double" "ex" } - { "float" "wye" } - { "int" "zee" } - { "char[20]" "woo" } - } ] [ - { - { "DOUBLE-PRECISION" "EX" } - { "REAL" "WYE" } - { "INTEGER" "ZEE" } - { "CHARACTER(20)" "WOO" } - } fortran-record>c-struct - ] unit-test - - ! RECORD: - - [ 16 ] [ "fortran_test_record" heap-size ] unit-test - [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test - [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test - [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test - ! (fortran-invoke) [ [ diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 013c4d6f6a..52d69fd193 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,6 +1,6 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.complex alien.parser -alien.strings alien.structs alien.syntax arrays ascii assocs +alien.strings alien.syntax arrays ascii assocs byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals @@ -415,14 +415,6 @@ PRIVATE> : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ; -: fortran-record>c-struct ( record -- struct ) - [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; - -: define-fortran-record ( name vocab fields -- ) - [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; - -SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ; - : set-fortran-abi ( library -- ) library-fortran-abis get-global at fortran-abi set ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index a80adf5137..80837e9a01 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -8,6 +8,8 @@ IN: alien.structs TUPLE: struct-type < abstract-c-type fields return-in-registers? ; +INSTANCE: struct-type value-type + M: struct-type c-type ; M: struct-type c-type-stack-align? drop f ; @@ -33,7 +35,7 @@ M: struct-type box-return M: struct-type stack-size [ heap-size ] [ stack-size ] if-value-struct ; -: c-struct? ( type -- ? ) (c-type) struct-type? ; +M: struct-type c-struct? drop t ; : (define-struct) ( name size align fields class -- ) [ [ align ] keep ] 2dip new diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 8508230bb2..62fce7f353 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,5 +1,5 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.structs.fields ascii +USING: accessors alien alien.c-types 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 @@ -196,41 +196,46 @@ UNION-STRUCT: struct-test-float-and-bits [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test [ { - T{ field-spec + T{ struct-slot-spec { name "x" } { offset 0 } + { class fixnum } { type "char" } { reader x>> } { writer (>>x) } } - T{ field-spec + T{ struct-slot-spec { name "y" } { offset 4 } + { class $[ cell 8 = fixnum integer ? ] } { type "int" } { reader y>> } { writer (>>y) } } - T{ field-spec + T{ struct-slot-spec { name "z" } { offset 8 } { type "bool" } + { class boolean } { reader z>> } { writer (>>z) } } } ] [ "struct-test-foo" c-type fields>> ] unit-test [ { - T{ field-spec + T{ struct-slot-spec { name "f" } { offset 0 } { type "float" } + { class float } { reader f>> } { writer (>>f) } } - T{ field-spec + T{ struct-slot-spec { name "bits" } { offset 0 } { type "uint" } + { class $[ cell 8 = fixnum integer ? ] } { reader bits>> } { writer (>>bits) } } diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 893bc5a257..1de221d2aa 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -1,14 +1,12 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.structs -alien.structs.fields arrays byte-arrays classes classes.parser -classes.tuple classes.tuple.parser classes.tuple.private -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 summary namespaces assocs -compiler.tree.propagation.transforms ; -FROM: slots => reader-word writer-word ; +USING: accessors alien alien.c-types arrays byte-arrays classes +classes.parser classes.tuple classes.tuple.parser +classes.tuple.private combinators combinators.short-circuit +combinators.smart cpu.architecture 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 +summary namespaces assocs ; IN: classes.struct SPECIALIZED-ARRAY: uchar @@ -22,7 +20,7 @@ TUPLE: struct { (underlying) c-ptr read-only } ; TUPLE: struct-slot-spec < slot-spec - c-type ; + type ; PREDICATE: struct-class < tuple-class superclass \ struct eq? ; @@ -86,11 +84,11 @@ MACRO: ( class -- quot: ( ... -- struct ) ) [ struct-slots [ initial>> ] map over length tail append ] keep ; : (reader-quot) ( slot -- quot ) - [ c-type>> c-type-getter-boxer ] + [ type>> c-type-getter-boxer ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (writer-quot) ( slot -- quot ) - [ c-type>> c-setter ] + [ type>> c-setter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (boxer-quot) ( class -- quot ) @@ -117,6 +115,39 @@ M: struct-class writer-quot ! c-types +TUPLE: struct-c-type < abstract-c-type + fields + return-in-registers? ; + +INSTANCE: struct-c-type value-type + +M: struct-c-type c-type ; + +M: struct-c-type c-type-stack-align? drop f ; + +: if-value-struct ( ctype true false -- ) + [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline + +M: struct-c-type unbox-parameter + [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; + +M: struct-c-type box-parameter + [ %box-large-struct ] [ box-parameter ] if-value-struct ; + +: if-small-struct ( c-type true false -- ? ) + [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline + +M: struct-c-type unbox-return + [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; + +M: struct-c-type box-return + [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; + +M: struct-c-type stack-size + [ heap-size ] [ stack-size ] if-value-struct ; + +M: struct-c-type c-struct? drop t ; + struct [ ] 3sequence ] bi define-inline-method ; -: slot>field ( slot -- field ) - field-spec new swap { - [ name>> >>name ] - [ offset>> >>offset ] - [ c-type>> >>type ] - [ name>> reader-word >>reader ] - [ name>> writer-word >>writer ] +: c-type-for-class ( class -- c-type ) + struct-c-type new swap { + [ drop byte-array >>class ] + [ >>boxed-class ] + [ struct-slots >>fields ] + [ "struct-size" word-prop >>size ] + [ "struct-align" word-prop >>align ] + [ (unboxer-quot) >>unboxer-quot ] + [ (boxer-quot) >>boxer-quot ] } cleave ; - -: define-struct-for-class ( class -- ) - [ - { - [ name>> ] - [ "struct-size" word-prop ] - [ "struct-align" word-prop ] - [ struct-slots [ slot>field ] map ] - } cleave - struct-type (define-struct) - ] [ - { - [ name>> c-type ] - [ (unboxer-quot) >>unboxer-quot ] - [ (boxer-quot) >>boxer-quot ] - [ >>boxed-class ] - } cleave drop - ] bi ; - + : align-offset ( offset class -- offset' ) c-type-align align ; : struct-offsets ( slots -- size ) 0 [ - [ c-type>> align-offset ] keep - [ (>>offset) ] [ c-type>> heap-size + ] 2bi + [ type>> align-offset ] keep + [ (>>offset) ] [ type>> heap-size + ] 2bi ] reduce ; : union-struct-offsets ( slots -- size ) - [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ; + [ 0 >>offset type>> heap-size ] [ max ] map-reduce ; : struct-align ( slots -- align ) - [ c-type>> c-type-align ] [ max ] map-reduce ; + [ type>> c-type-align ] [ max ] map-reduce ; PRIVATE> M: struct-class c-type name>> c-type ; @@ -228,7 +243,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable [ (struct-methods) ] tri ; : check-struct-slots ( slots -- ) - [ c-type>> c-type drop ] each ; + [ type>> c-type drop ] each ; : redefine-struct-tuple-class ( class -- ) [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ; @@ -244,7 +259,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri (struct-word-props) ] - [ drop define-struct-for-class ] 2tri ; inline + [ drop [ c-type-for-class ] [ name>> ] bi typedef ] 2tri ; inline PRIVATE> : define-struct-class ( class slots -- ) @@ -265,7 +280,7 @@ ERROR: invalid-struct-slot token ; : ( name c-type attributes -- slot-spec ) [ struct-slot-spec new ] 3dip [ >>name ] - [ [ >>c-type ] [ struct-slot-class >>class ] bi ] + [ [ >>type ] [ struct-slot-class >>class ] bi ] [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ; >rep) >> heap-size cell align cell /i "__stack_value" c-type ; -M: struct-type flatten-value-type ( type -- seq ) +: flatten-struct ( c-type -- seq ) dup heap-size 16 > [ flatten-large-struct ] [ flatten-small-struct ] if ; +M: alien.structs:struct-type flatten-value-type ( type -- seq ) + flatten-struct ; +M: classes.struct:struct-c-type flatten-value-type ( type -- seq ) + flatten-struct ; + M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size 2 cells <= ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index c0dca56551..0ee9ab78c5 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alien alien.c-types alien.structs arrays +USING: accessors alien alien.c-types arrays assocs classes classes.mixin classes.parser classes.singleton classes.tuple classes.tuple.private combinators combinators.tuple destructors fry generic generic.parser gpu gpu.buffers gpu.framebuffers From 765aa5bc1df00207ca20b6995f7d0f54ba3ac8c3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 15:45:03 -0700 Subject: [PATCH 6/9] db: fix some typos in docs --- basis/db/db-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index a8b03398c7..e73783fdfc 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -252,14 +252,14 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl "First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." { $code <" -USING: db.sqlite db io.files ; +USING: db.sqlite db io.files io.files.temp ; : with-book-db ( quot -- ) "book.db" temp-file swap with-db ; inline"> } "Now let's create the table manually:" { $code <" "create table books (id integer primary key, title text, author text, date_published timestamp, edition integer, cover_price double, condition text)" - [ sql-command ] with-book-db" "> } + [ sql-command ] with-book-db"> } "Time to insert some books:" { $code <" "insert into books From 1478785b188c2d53630f18611ffaa9e797936e4b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 16:36:59 -0700 Subject: [PATCH 7/9] irc.client: fix suggested by ceninan --- extra/irc/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index ae48d3ac4e..3f1dba353c 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -9,7 +9,7 @@ IN: irc.client [ (connect-irc) (do-login) spawn-irc ] with-irc ; : attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ; -: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ; +: detach-chat ( irc-chat -- ) dup client>> [ remove-chat ] with-irc ; : speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ; : hear ( irc-chat -- message ) in-messages>> mailbox-get ; : terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ; From cc680ae69834e5e6bfb0e8684f0d43ef3e6ecb3d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Sep 2009 18:56:17 -0500 Subject: [PATCH 8/9] Revert "make struct classes print properly in the status bar" This reverts commit 4ee1a4f9e8590eb8846343dc5d30d9f5e3aaee26. --- .../struct/prettyprint/prettyprint.factor | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index 8bda9dc5f9..e88834530c 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -1,13 +1,18 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types arrays assocs classes classes.struct combinators combinators.short-circuit continuations -definitions fry kernel libc make math math.parser mirrors -prettyprint.backend prettyprint.custom prettyprint.sections -see see.private sequences slots strings summary words ; +fry kernel libc make math math.parser mirrors prettyprint.backend +prettyprint.custom prettyprint.sections see.private sequences +slots strings summary words ; IN: classes.struct.prettyprint = + [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ] + [ drop \ STRUCT: ] if ; + : struct>assoc ( struct -- assoc ) [ class struct-slots ] [ struct-slot-values ] bi zip ; @@ -34,14 +39,8 @@ IN: classes.struct.prettyprint PRIVATE> -M: struct-class definer - struct-slots dup length 2 >= - [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ] - [ drop \ STRUCT: ] if - \ ; ; - M: struct-class see-class* - pprint-; block> ; From 3c541f736f3af3b1bc2c4b8b00fec93ca058a457 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Sep 2009 19:10:05 -0500 Subject: [PATCH 9/9] fix failing classes.struct tests --- .../struct/prettyprint/prettyprint.factor | 4 ++-- basis/classes/struct/struct-tests.factor | 23 ++++++++----------- 2 files changed, 11 insertions(+), 16 deletions(-) diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index e88834530c..2c969531e8 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -20,7 +20,7 @@ IN: classes.struct.prettyprint > text ] - [ c-type>> dup string? [ text ] [ pprint* ] if ] + [ type>> dup string? [ text ] [ pprint* ] if ] [ read-only>> [ \ read-only pprint-word ] when ] [ initial>> [ \ initial: pprint-word pprint* ] when* ] } cleave block> @@ -111,7 +111,7 @@ M: struct-mirror >alist ( mirror -- alist ) ] [ '[ _ struct>assoc - [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map + [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map ] [ drop { } ] recover ] bi append ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 62fce7f353..bbbaf4f1d5 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -5,7 +5,7 @@ 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 parser lexer eval ; +tools.test parser lexer eval layouts ; SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: ushort @@ -199,26 +199,23 @@ UNION-STRUCT: struct-test-float-and-bits T{ struct-slot-spec { name "x" } { offset 0 } + { initial 0 } { class fixnum } { type "char" } - { reader x>> } - { writer (>>x) } } T{ struct-slot-spec { name "y" } { offset 4 } - { class $[ cell 8 = fixnum integer ? ] } + { initial 123 } + { class integer } { type "int" } - { reader y>> } - { writer (>>y) } } T{ struct-slot-spec { name "z" } { offset 8 } + { initial f } { type "bool" } - { class boolean } - { reader z>> } - { writer (>>z) } + { class object } } } ] [ "struct-test-foo" c-type fields>> ] unit-test @@ -228,16 +225,14 @@ UNION-STRUCT: struct-test-float-and-bits { offset 0 } { type "float" } { class float } - { reader f>> } - { writer (>>f) } + { initial 0.0 } } T{ struct-slot-spec { name "bits" } { offset 0 } { type "uint" } - { class $[ cell 8 = fixnum integer ? ] } - { reader bits>> } - { writer (>>bits) } + { class integer } + { initial 0 } } } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test