From ac4141695381147d5aef180e9841a5dba6340120 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Sep 2009 15:18:54 -0500 Subject: [PATCH] create words for c-types --- basis/alien/arrays/arrays.factor | 38 ++--- basis/alien/c-types/c-types.factor | 159 +++++++++++++-------- basis/alien/parser/parser.factor | 8 +- basis/alien/prettyprint/prettyprint.factor | 16 ++- basis/alien/structs/structs.factor | 2 +- basis/alien/syntax/syntax.factor | 9 +- 6 files changed, 146 insertions(+), 86 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 64827ec139..86d6c2d49b 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -22,15 +22,15 @@ M: array c-type-align first c-type-align ; M: array c-type-stack-align? drop f ; -M: array unbox-parameter drop "void*" unbox-parameter ; +M: array unbox-parameter drop void* unbox-parameter ; -M: array unbox-return drop "void*" unbox-return ; +M: array unbox-return drop void* unbox-return ; -M: array box-parameter drop "void*" box-parameter ; +M: array box-parameter drop void* box-parameter ; -M: array box-return drop "void*" box-return ; +M: array box-return drop void* box-return ; -M: array stack-size drop "void*" stack-size ; +M: array stack-size drop void* stack-size ; M: array c-type-boxer-quot unclip @@ -50,7 +50,7 @@ M: value-type c-type-setter ( type -- quot ) '[ @ swap @ _ memcpy ] ; PREDICATE: string-type < pair - first2 [ "char*" = ] [ word? ] bi* and ; + first2 [ char* = ] [ word? ] bi* and ; M: string-type c-type ; @@ -59,37 +59,37 @@ M: string-type c-type-class drop object ; M: string-type c-type-boxed-class drop object ; M: string-type heap-size - drop "void*" heap-size ; + drop void* heap-size ; M: string-type c-type-align - drop "void*" c-type-align ; + drop void* c-type-align ; M: string-type c-type-stack-align? - drop "void*" c-type-stack-align? ; + drop void* c-type-stack-align? ; M: string-type unbox-parameter - drop "void*" unbox-parameter ; + drop void* unbox-parameter ; M: string-type unbox-return - drop "void*" unbox-return ; + drop void* unbox-return ; M: string-type box-parameter - drop "void*" box-parameter ; + drop void* box-parameter ; M: string-type box-return - drop "void*" box-return ; + drop void* box-return ; M: string-type stack-size - drop "void*" stack-size ; + drop void* stack-size ; M: string-type c-type-rep drop int-rep ; M: string-type c-type-boxer - drop "void*" c-type-boxer ; + drop void* c-type-boxer ; M: string-type c-type-unboxer - drop "void*" c-type-unboxer ; + drop void* c-type-unboxer ; M: string-type c-type-boxer-quot second '[ _ alien>string ] ; @@ -103,6 +103,8 @@ M: string-type c-type-getter M: string-type c-type-setter drop [ set-alien-cell ] ; -{ "char*" utf8 } "char*" typedef -"char*" "uchar*" typedef +{ char* utf8 } char* typedef +char* uchar* typedef +char char* "pointer-c-type" set-word-prop +uchar uchar* "pointer-c-type" set-word-prop diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index b177ab35d4..2d53e01f0f 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 ; +classes vocabs vocabs.loader vocabs.parser ; IN: alien.c-types DEFER: @@ -40,6 +40,11 @@ global [ ERROR: no-c-type name ; +PREDICATE: c-type-word < word + "c-type" word-prop ; + +UNION: c-type-name string c-type-word ; + : (c-type) ( name -- type/f ) c-types get-global at dup [ dup string? [ (c-type) ] when @@ -48,35 +53,48 @@ ERROR: no-c-type name ; ! C type protocol GENERIC: c-type ( name -- type ) foldable -: resolve-pointer-type ( name -- name ) +: 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 ; +M: string resolve-pointer-type c-types get at dup string? - [ "*" append ] [ drop "void*" ] if + [ "*" append ] [ drop void* ] if c-type ; : resolve-typedef ( name -- type ) - dup string? [ c-type ] when ; + dup c-type-name? [ c-type ] when ; : parse-array-type ( name -- array ) "[" split unclip - [ [ "]" ?tail drop string>number ] map ] dip prefix ; + [ [ "]" ?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 ] [ dup c-types get at resolve-typedef ] } + { [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] } + [ no-c-type ] + } cond ; M: string c-type ( name -- type ) - CHAR: ] over member? [ - parse-array-type - ] [ - dup c-types get at [ - resolve-typedef - ] [ - "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if - ] ?if - ] if ; + parse-c-type ; + +M: word c-type + "c-type" word-prop resolve-typedef ; ! 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. GENERIC: heap-size ( type -- size ) foldable -M: string heap-size c-type heap-size ; +M: c-type-name heap-size c-type heap-size ; M: abstract-c-type heap-size size>> ; @@ -92,7 +110,7 @@ GENERIC: c-direct-array-constructor ( c-type -- word ) GENERIC: ( len c-type -- array ) -M: string +M: c-type-name c-array-constructor execute( len -- array ) ; inline GENERIC: (c-array) ( len c-type -- array ) @@ -102,7 +120,7 @@ M: string (c-array) GENERIC: ( alien len c-type -- array ) -M: string +M: c-type-name c-direct-array-constructor execute( alien len -- array ) ; inline : malloc-array ( n type -- alien ) @@ -115,67 +133,67 @@ GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; -M: string c-type-class c-type c-type-class ; +M: c-type-name c-type-class c-type c-type-class ; GENERIC: c-type-boxed-class ( name -- class ) M: abstract-c-type c-type-boxed-class boxed-class>> ; -M: string c-type-boxed-class c-type c-type-boxed-class ; +M: c-type-name c-type-boxed-class c-type c-type-boxed-class ; GENERIC: c-type-boxer ( name -- boxer ) M: c-type c-type-boxer boxer>> ; -M: string c-type-boxer c-type c-type-boxer ; +M: c-type-name c-type-boxer c-type c-type-boxer ; GENERIC: c-type-boxer-quot ( name -- quot ) M: abstract-c-type c-type-boxer-quot boxer-quot>> ; -M: string c-type-boxer-quot c-type c-type-boxer-quot ; +M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ; GENERIC: c-type-unboxer ( name -- boxer ) M: c-type c-type-unboxer unboxer>> ; -M: string c-type-unboxer c-type c-type-unboxer ; +M: c-type-name c-type-unboxer c-type c-type-unboxer ; GENERIC: c-type-unboxer-quot ( name -- quot ) M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ; -M: string c-type-unboxer-quot c-type c-type-unboxer-quot ; +M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ; GENERIC: c-type-rep ( name -- rep ) M: c-type c-type-rep rep>> ; -M: string c-type-rep c-type c-type-rep ; +M: c-type-name c-type-rep c-type c-type-rep ; GENERIC: c-type-getter ( name -- quot ) M: c-type c-type-getter getter>> ; -M: string c-type-getter c-type c-type-getter ; +M: c-type-name c-type-getter c-type c-type-getter ; GENERIC: c-type-setter ( name -- quot ) M: c-type c-type-setter setter>> ; -M: string c-type-setter c-type c-type-setter ; +M: c-type-name c-type-setter c-type c-type-setter ; GENERIC: c-type-align ( name -- n ) M: abstract-c-type c-type-align align>> ; -M: string c-type-align c-type c-type-align ; +M: c-type-name c-type-align c-type c-type-align ; GENERIC: c-type-stack-align? ( name -- ? ) M: c-type c-type-stack-align? stack-align?>> ; -M: string c-type-stack-align? c-type c-type-stack-align? ; +M: c-type-name c-type-stack-align? c-type c-type-stack-align? ; : c-type-box ( n type -- ) [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi @@ -189,29 +207,29 @@ GENERIC: box-parameter ( n ctype -- ) M: c-type box-parameter c-type-box ; -M: string box-parameter c-type box-parameter ; +M: c-type-name box-parameter c-type box-parameter ; GENERIC: box-return ( ctype -- ) M: c-type box-return f swap c-type-box ; -M: string box-return c-type box-return ; +M: c-type-name box-return c-type box-return ; GENERIC: unbox-parameter ( n ctype -- ) M: c-type unbox-parameter c-type-unbox ; -M: string unbox-parameter c-type unbox-parameter ; +M: c-type-name unbox-parameter c-type unbox-parameter ; GENERIC: unbox-return ( ctype -- ) M: c-type unbox-return f swap c-type-unbox ; -M: string unbox-return c-type unbox-return ; +M: c-type-name unbox-return c-type unbox-return ; GENERIC: stack-size ( type -- size ) foldable -M: string stack-size c-type stack-size ; +M: c-type-name stack-size c-type stack-size ; M: c-type stack-size size>> cell align ; @@ -269,7 +287,15 @@ M: memory-stream stream-read \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* ] [ ] make ; -: typedef ( old new -- ) c-types get set-at ; +GENERIC: typedef ( old new -- ) + +PREDICATE: typedef-word < c-type-word + "c-type" word-prop c-type-name? ; + +M: string typedef ( old new -- ) c-types get set-at ; +M: word typedef ( old new -- ) + [ name>> typedef ] + [ swap "c-type" set-word-prop ] 2bi ; TUPLE: long-long-type < c-type ; @@ -303,8 +329,8 @@ M: long-long-type box-return ( type -- ) : define-primitive-type ( type name -- ) [ typedef ] - [ define-deref ] - [ define-out ] + [ name>> define-deref ] + [ name>> define-out ] tri ; : malloc-file-contents ( path -- alien len ) @@ -313,17 +339,30 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +SYMBOLS: + char uchar + short ushort + int uint + long ulong + longlong ulonglong + float double + void* bool ; + CONSTANT: primitive-types { - "char" "uchar" - "short" "ushort" - "int" "uint" - "long" "ulong" - "longlong" "ulonglong" - "float" "double" - "void*" "bool" + char uchar + short ushort + int uint + long ulong + longlong ulonglong + float double + void* bool } +SYMBOLS: + ptrdiff_t intptr_t size_t + char* uchar* ; + [ c-ptr >>class @@ -335,7 +374,7 @@ CONSTANT: primitive-types [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer - "void*" define-primitive-type + \ void* define-primitive-type integer >>class @@ -346,7 +385,7 @@ CONSTANT: primitive-types 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer - "longlong" define-primitive-type + \ longlong define-primitive-type integer >>class @@ -357,7 +396,7 @@ CONSTANT: primitive-types 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer - "ulonglong" define-primitive-type + \ ulonglong define-primitive-type integer >>class @@ -368,7 +407,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer - "long" define-primitive-type + \ long define-primitive-type integer >>class @@ -379,7 +418,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer - "ulong" define-primitive-type + \ ulong define-primitive-type integer >>class @@ -390,7 +429,7 @@ CONSTANT: primitive-types 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer - "int" define-primitive-type + \ int define-primitive-type integer >>class @@ -401,7 +440,7 @@ CONSTANT: primitive-types 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer - "uint" define-primitive-type + \ uint define-primitive-type fixnum >>class @@ -412,7 +451,7 @@ CONSTANT: primitive-types 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer - "short" define-primitive-type + \ short define-primitive-type fixnum >>class @@ -423,7 +462,7 @@ CONSTANT: primitive-types 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer - "ushort" define-primitive-type + \ ushort define-primitive-type fixnum >>class @@ -434,7 +473,7 @@ CONSTANT: primitive-types 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer - "char" define-primitive-type + \ char define-primitive-type fixnum >>class @@ -445,7 +484,7 @@ CONSTANT: primitive-types 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer - "uchar" define-primitive-type + \ uchar define-primitive-type [ alien-unsigned-1 c-bool> ] >>getter @@ -454,7 +493,7 @@ CONSTANT: primitive-types 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer - "bool" define-primitive-type + \ bool define-primitive-type float >>class @@ -467,7 +506,7 @@ CONSTANT: primitive-types "to_float" >>unboxer float-rep >>rep [ >float ] >>unboxer-quot - "float" define-primitive-type + \ float define-primitive-type float >>class @@ -480,10 +519,10 @@ CONSTANT: primitive-types "to_double" >>unboxer double-rep >>rep [ >float ] >>unboxer-quot - "double" define-primitive-type + \ double define-primitive-type - "long" "ptrdiff_t" typedef - "long" "intptr_t" typedef - "ulong" "size_t" typedef + \ long \ ptrdiff_t typedef + \ long \ intptr_t typedef + \ ulong \ size_t typedef ] with-compilation-unit diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 19ab08c03c..f855378890 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -5,12 +5,18 @@ parser sequences splitting words fry locals lexer namespaces summary math ; IN: alien.parser +: scan-c-type ( -- c-type ) + scan dup "{" = + [ drop \ } parse-until >array ] + [ parse-c-type ] if ; + : normalize-c-arg ( type name -- type' name' ) [ length ] [ [ CHAR: * = ] trim-head [ length - CHAR: * append ] keep - ] bi ; + ] bi + [ parse-c-type ] dip ; : parse-arglist ( parameters return -- types effect ) [ diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index 0ffd5023a7..6201f1e245 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel combinators alien alien.strings alien.syntax -math.parser prettyprint.backend prettyprint.custom -prettyprint.sections ; +USING: kernel combinators alien alien.strings alien.c-types +alien.syntax math.parser prettyprint.backend prettyprint.custom +prettyprint.sections definitions see see.private ; IN: alien.prettyprint M: alien pprint* @@ -13,3 +13,13 @@ M: alien pprint* } cond ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; + +M: c-type-word definer drop \ C-TYPE: f ; +M: c-type-word definition drop f ; + +M: typedef-word see-class* + ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index a80adf5137..1558748164 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -13,7 +13,7 @@ M: struct-type c-type ; M: struct-type c-type-stack-align? drop f ; : if-value-struct ( ctype true false -- ) - [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline + [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline M: struct-type unbox-parameter [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index e8206c6968..040c6b0787 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -19,18 +19,21 @@ SYNTAX: FUNCTION: (FUNCTION:) define-declared ; SYNTAX: TYPEDEF: - scan scan typedef ; + scan-c-type CREATE typedef ; SYNTAX: C-STRUCT: - scan current-vocab parse-definition define-struct ; deprecated + CREATE current-vocab parse-definition define-struct ; deprecated SYNTAX: C-UNION: - scan parse-definition define-union ; deprecated + CREATE parse-definition define-union ; deprecated SYNTAX: C-ENUM: ";" parse-tokens [ [ create-in ] dip define-constant ] each-index ; +SYNTAX: C-TYPE: + "Primitive C type definition not supported" throw ; + ERROR: no-such-symbol name library ; : address-of ( name library -- value )