diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 71073ddc91..123abb5298 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser cpu.architecture alien alien.accessors alien.strings quotations layouts system compiler.units io io.files io.encodings.binary io.streams.memory accessors combinators effects continuations fry -classes vocabs vocabs.loader vocabs.parser words.symbol ; +classes vocabs vocabs.loader words.symbol ; QUALIFIED: math IN: alien.c-types @@ -16,7 +16,8 @@ SYMBOLS: long ulong longlong ulonglong float double - void* bool ; + void* bool + void ; DEFER: DEFER: *char @@ -55,56 +56,48 @@ PREDICATE: c-type-word < word UNION: c-type-name string c-type-word ; -: (c-type) ( name -- type/f ) - c-types get-global at dup [ - dup string? [ (c-type) ] when - ] when ; - ! C type protocol GENERIC: c-type ( name -- type ) foldable -: parse-c-type-name ( name -- word/string ) - [ search ] keep or ; - GENERIC: resolve-pointer-type ( name -- c-type ) M: word resolve-pointer-type dup "pointer-c-type" word-prop - [ ] [ drop void* ] ?if c-type ; + [ ] [ drop void* ] ?if ; M: string resolve-pointer-type c-types get at dup string? - [ "*" append ] [ drop void* ] if - c-type ; + [ "*" append ] [ drop void* ] if ; : resolve-typedef ( name -- type ) dup c-type-name? [ c-type ] when ; -: parse-array-type ( name -- array ) +: parse-array-type ( name -- dims type ) "[" split unclip - [ [ "]" ?tail drop string>number ] map ] dip - parse-c-type-name prefix ; - -: parse-c-type ( string -- array ) - { - { [ CHAR: ] over member? ] [ parse-array-type ] } - { [ dup search c-type-word? ] [ parse-c-type-name resolve-typedef ] } - { [ dup c-types get at ] [ c-types get at resolve-typedef ] } - { [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] } - [ no-c-type ] - } cond ; + [ [ "]" ?tail drop string>number ] map ] dip ; M: string c-type ( name -- type ) - parse-c-type ; + CHAR: ] over member? [ + parse-array-type prefix + ] [ + dup c-types get at [ + resolve-typedef + ] [ + "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if + ] ?if + ] if ; M: word c-type "c-type" word-prop resolve-typedef ; +: void? ( c-type -- ? ) + { void "void" } member? ; + GENERIC: c-struct? ( type -- ? ) M: object c-struct? drop f ; M: string c-struct? - dup "void" = [ drop f ] [ c-type c-struct? ] if ; + 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 @@ -366,7 +359,7 @@ M: long-long-type box-return ( type -- ) binary file-contents [ malloc-byte-array ] [ length ] bi ; : if-void ( type true false -- ) - pick "void" = [ drop nip call ] [ nip call ] if ; inline + pick void? [ drop nip call ] [ nip call ] if ; inline CONSTANT: primitive-types { diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index f855378890..bca7c93802 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,10 +1,23 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals lexer namespaces -summary math ; +USING: alien alien.c-types arrays assocs combinators effects +grouping kernel parser sequences splitting words fry locals +lexer namespaces summary math vocabs.parser ; IN: alien.parser +: parse-c-type-name ( name -- word/string ) + [ search ] keep or ; + +: parse-c-type ( string -- array ) + { + { [ dup "void" = ] [ drop void ] } + { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] } + { [ dup search c-type-word? ] [ parse-c-type-name ] } + { [ dup c-types get at ] [ ] } + { [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] } + [ no-c-type ] + } cond ; + : scan-c-type ( -- c-type ) scan dup "{" = [ drop \ } parse-until >array ] diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 040c6b0787..fac45176a3 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -22,10 +22,10 @@ SYNTAX: TYPEDEF: scan-c-type CREATE typedef ; SYNTAX: C-STRUCT: - CREATE current-vocab parse-definition define-struct ; deprecated + scan current-vocab parse-definition define-struct ; deprecated SYNTAX: C-UNION: - CREATE parse-definition define-union ; deprecated + scan parse-definition define-union ; deprecated SYNTAX: C-ENUM: ";" parse-tokens diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index bbbaf4f1d5..3be0be8ef1 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -6,6 +6,8 @@ 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 layouts ; +FROM: math => float +QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: ushort @@ -128,7 +130,7 @@ STRUCT: struct-test-bar ] unit-test UNION-STRUCT: struct-test-float-and-bits - { f float } + { f c:float } { bits uint } ; [ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test @@ -181,14 +183,14 @@ STRUCT: struct-test-string-ptr ] with-scope ] unit-test -[ <" USING: classes.struct ; +[ <" USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-foo { x char initial: 0 } { y int initial: 123 } { z bool } ; "> ] [ [ struct-test-foo see ] with-string-writer ] unit-test -[ <" USING: classes.struct ; +[ <" USING: alien.c-types classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits { f float initial: 0.0 } { bits uint initial: 0 } ; @@ -201,20 +203,20 @@ UNION-STRUCT: struct-test-float-and-bits { offset 0 } { initial 0 } { class fixnum } - { type "char" } + { type char } } T{ struct-slot-spec { name "y" } { offset 4 } { initial 123 } { class integer } - { type "int" } + { type int } } T{ struct-slot-spec { name "z" } { offset 8 } { initial f } - { type "bool" } + { type bool } { class object } } } ] [ "struct-test-foo" c-type fields>> ] unit-test @@ -223,14 +225,14 @@ UNION-STRUCT: struct-test-float-and-bits T{ struct-slot-spec { name "f" } { offset 0 } - { type "float" } + { type c:float } { class float } { initial 0.0 } } T{ struct-slot-spec { name "bits" } { offset 0 } - { type "uint" } + { type uint } { class integer } { initial 0 } } @@ -277,7 +279,7 @@ STRUCT: struct-test-array-slots ] unit-test STRUCT: struct-test-optimization - { x { "int" 3 } } { y int } ; + { x { int 3 } } { y int } ; SPECIALIZED-ARRAY: struct-test-optimization diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 1de221d2aa..a96a74d2ac 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -1,12 +1,12 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types arrays byte-arrays classes -classes.parser classes.tuple classes.tuple.parser +USING: accessors alien alien.c-types alien.parser 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 ; +summary namespaces assocs vocabs.parser ; IN: classes.struct SPECIALIZED-ARRAY: uchar @@ -197,20 +197,6 @@ M: struct-c-type c-struct? drop t ; [ type>> c-type-align ] [ max ] map-reduce ; PRIVATE> -M: struct-class c-type name>> c-type ; - -M: struct-class c-type-align c-type c-type-align ; - -M: struct-class c-type-getter c-type c-type-getter ; - -M: struct-class c-type-setter c-type c-type-setter ; - -M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ; - -M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ; - -M: struct-class heap-size c-type heap-size ; - M: struct byte-length class "struct-size" word-prop ; foldable ! class definition @@ -259,7 +245,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri (struct-word-props) ] - [ drop [ c-type-for-class ] [ name>> ] bi typedef ] 2tri ; inline + [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline PRIVATE> : define-struct-class ( class slots -- ) @@ -284,9 +270,6 @@ ERROR: invalid-struct-slot token ; [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ; array ] when ; - : parse-struct-slot ( -- slot ) scan scan-c-type \ } parse-until ; @@ -317,7 +300,7 @@ SYNTAX: S@ array ] [ >string-param ] if ; + scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ; : parse-struct-slot` ( accum -- accum ) scan-string-param scan-c-type` \ } parse-until diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 0456ff485f..ddf5aa0e02 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -456,7 +456,7 @@ TUPLE: callback-context ; : callback-return-quot ( ctype -- quot ) return>> { - { [ dup "void" = ] [ drop [ ] ] } + { [ dup void? ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } [ c-type c-type-unboxer-quot ] } cond ; diff --git a/basis/core-foundation/numbers/numbers.factor b/basis/core-foundation/numbers/numbers.factor index f01f522d61..ae061cb4eb 100644 --- a/basis/core-foundation/numbers/numbers.factor +++ b/basis/core-foundation/numbers/numbers.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax kernel math core-foundation ; +FROM: math => float ; IN: core-foundation.numbers TYPEDEF: void* CFNumberRef diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index 02235bb62e..c5cf2d470a 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: system kernel math math.order math.parser namespaces -alien.syntax combinators locals init io cpu.x86 compiler -compiler.units accessors ; +alien.c-types alien.syntax combinators locals init io cpu.x86 +compiler compiler.units accessors ; IN: cpu.x86.features > ] when ; + : specialized-array-vocab ( c-type -- vocab ) "specialized-arrays.instances." prepend ; @@ -125,26 +133,26 @@ PRIVATE> ] ?if ; inline : define-array-vocab ( type -- vocab ) - underlying-type + underlying-type-name [ specialized-array-vocab ] [ '[ _ define-array ] ] bi generate-vocab ; -M: string require-c-array define-array-vocab drop ; +M: c-type-name require-c-array define-array-vocab drop ; ERROR: specialized-array-vocab-not-loaded c-type ; -M: string c-array-constructor - underlying-type +M: c-type-name c-array-constructor + underlying-type-name dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable -M: string c-(array)-constructor - underlying-type +M: c-type-name c-(array)-constructor + underlying-type-name dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable -M: string c-direct-array-constructor - underlying-type +M: c-type-name c-direct-array-constructor + underlying-type-name dup [ "" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index da559abd78..3d150adf91 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -19,7 +19,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : alien-stack ( params extra -- ) over parameters>> length + consume-d >>in-d - dup return>> "void" = 0 1 ? produce-d >>out-d + dup return>> void? 0 1 ? produce-d >>out-d drop ; : return-prep-quot ( node -- quot ) diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 2100d6a215..3cf8b55e39 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -67,7 +67,7 @@ unless : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect ) swap [ [ second ] map ] - [ dup "void" = [ drop { } ] [ 1array ] if ] bi* + [ dup void? [ drop { } ] [ 1array ] if ] bi* ; : (define-word-for-function) ( function interface n -- )