long ulong
longlong ulonglong
float double
- void* bool
+ bool void*
void ;
DEFER: <int>
: <c-type> ( -- c-type )
\ c-type new ; inline
-SYMBOL: c-types
-
-global [
- c-types [ H{ } assoc-like ] change
-] bind
-
ERROR: no-c-type name ;
PREDICATE: c-type-word < word
"c-type" word-prop ;
-UNION: c-type-name string c-type-word ;
-
! C type protocol
GENERIC: c-type ( name -- c-type ) foldable
-GENERIC: resolve-pointer-type ( name -- c-type )
-
-<< \ void \ void* "pointer-c-type" set-word-prop >>
-
: void? ( c-type -- ? )
- { void "void" } member? ;
-
-M: word resolve-pointer-type
- dup "pointer-c-type" word-prop
- [ ] [ drop void* ] ?if ;
-
-M: string resolve-pointer-type
- dup "*" append dup c-types get at
- [ nip ] [
- drop
- c-types get at dup c-type-name?
- [ resolve-pointer-type ] [ drop void* ] if
- ] if ;
+ void = ; inline
+
+TUPLE: pointer { to initial: void read-only } ;
+C: <pointer> pointer
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
- dup c-type-name? [ c-type ] when ;
+ dup c-type-word? [ c-type ] when ;
<PRIVATE
PRIVATE>
-M: string c-type ( name -- c-type )
- CHAR: ] over member? [
- parse-array-type prefix
- ] [
- dup c-types get at [ ] [
- "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
- ] ?if resolve-typedef
- ] if ;
-
M: word c-type
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
M: object c-struct? drop f ;
-M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
+M: c-type-word 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
M: abstract-c-type c-type-class class>> ;
-M: c-type-name c-type-class c-type c-type-class ;
+M: c-type-word 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: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
+M: c-type-word c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
-M: c-type-name c-type-boxer c-type c-type-boxer ;
+M: c-type-word 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: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
+M: c-type-word c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
-M: c-type-name c-type-unboxer c-type c-type-unboxer ;
+M: c-type-word 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: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
+M: c-type-word c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-rep rep>> ;
-M: c-type-name c-type-rep c-type c-type-rep ;
+M: c-type-word c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
-M: c-type-name c-type-getter c-type c-type-getter ;
+M: c-type-word c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
-M: c-type-name c-type-setter c-type c-type-setter ;
+M: c-type-word c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: abstract-c-type c-type-align align>> ;
-M: c-type-name c-type-align c-type c-type-align ;
+M: c-type-word c-type-align c-type c-type-align ;
GENERIC: c-type-align-first ( name -- n )
-M: c-type-name c-type-align-first c-type c-type-align-first ;
+M: c-type-word c-type-align-first c-type c-type-align-first ;
M: abstract-c-type c-type-align-first align-first>> ;
M: c-type c-type-stack-align? stack-align?>> ;
-M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
+M: c-type-word c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
M: c-type box-parameter c-type-box ;
-M: c-type-name box-parameter c-type box-parameter ;
+M: c-type-word box-parameter c-type box-parameter ;
GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
-M: c-type-name box-return c-type box-return ;
+M: c-type-word box-return c-type box-return ;
GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
-M: c-type-name unbox-parameter c-type unbox-parameter ;
+M: c-type-word unbox-parameter c-type unbox-parameter ;
GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
-M: c-type-name unbox-return c-type unbox-return ;
+M: c-type-word unbox-return c-type unbox-return ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- size )
-M: c-type-name heap-size c-type heap-size ;
+M: c-type-word heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
-M: c-type-name stack-size c-type stack-size ;
+M: c-type-word stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
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 ;
+ "c-type" word-prop c-type-word? ;
M: word typedef ( old new -- )
{
[ nip define-symbol ]
- [ name>> typedef ]
[ swap "c-type" set-word-prop ]
- [
- swap dup c-type-name? [
- resolve-pointer-type
- "pointer-c-type" set-word-prop
- ] [ 2drop ] if
- ]
} 2cleave ;
+M: pointer typedef ( old new -- )
+ to>> dup c-type-word?
+ [ ]
+ [ 2drop ] if ;
+
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- c-type )
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
- char* uchar* ;
+ char* ;
+
+<PRIVATE
+
+: (pointer-c-type) ( void* type -- void*' )
+ [ clone ] dip c-type-boxer-quot >>boxer-quot ;
+
+: string-pointer-type? ( type -- ? )
+ dup pointer? [ drop f ]
+ [ resolve-typedef { char uchar } member? ] if ;
+
+: primitive-pointer-type? ( type -- ? )
+ dup pointer? [ drop t ] [
+ resolve-typedef [ void? ] [ primitive-types member? ] bi or
+ ] if ;
+
+PRIVATE>
+
+M: pointer c-type
+ [ \ void* c-type ] dip
+ to>> {
+ { [ dup string-pointer-type? ] [ drop \ char* c-type ] }
+ { [ dup primitive-pointer-type? ] [ drop ] }
+ [ (pointer-c-type) ]
+ } cond ;
: 8-byte-alignment ( c-type -- c-type )
{
"alien_offset" >>unboxer
\ void* define-primitive-type
- <long-long-type>
- integer >>class
- integer >>boxed-class
- [ alien-signed-8 ] >>getter
- [ set-alien-signed-8 ] >>setter
- 8 >>size
- 8-byte-alignment
- "from_signed_8" >>boxer
- "to_signed_8" >>unboxer
- \ longlong define-primitive-type
-
- <long-long-type>
- integer >>class
- integer >>boxed-class
- [ alien-unsigned-8 ] >>getter
- [ set-alien-unsigned-8 ] >>setter
- 8 >>size
- 8-byte-alignment
- "from_unsigned_8" >>boxer
- "to_unsigned_8" >>unboxer
- \ ulonglong define-primitive-type
-
- <c-type>
- integer >>class
- integer >>boxed-class
- [ alien-signed-cell ] >>getter
- [ set-alien-signed-cell ] >>setter
- bootstrap-cell >>size
- bootstrap-cell >>align
- bootstrap-cell >>align-first
- "from_signed_cell" >>boxer
- "to_fixnum" >>unboxer
- \ long define-primitive-type
-
- <c-type>
- integer >>class
- integer >>boxed-class
- [ alien-unsigned-cell ] >>getter
- [ set-alien-unsigned-cell ] >>setter
- bootstrap-cell >>size
- bootstrap-cell >>align
- bootstrap-cell >>align-first
- "from_unsigned_cell" >>boxer
- "to_cell" >>unboxer
- \ ulong define-primitive-type
-
<c-type>
integer >>class
integer >>boxed-class
[ >float ] >>unboxer-quot
\ double define-primitive-type
- cpu x86.64? os windows? and [
+ cell 8 = [
+ <c-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-signed-cell ] >>getter
+ [ set-alien-signed-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ bootstrap-cell >>align-first
+ "from_signed_cell" >>boxer
+ "to_fixnum" >>unboxer
+ \ longlong define-primitive-type
+
+ <c-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-unsigned-cell ] >>getter
+ [ set-alien-unsigned-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ bootstrap-cell >>align-first
+ "from_unsigned_cell" >>boxer
+ "to_cell" >>unboxer
+ \ ulonglong define-primitive-type
+
+ os windows? [
+ \ int c-type \ long define-primitive-type
+ \ uint c-type \ ulong define-primitive-type
+ ] [
+ \ longlong c-type \ long define-primitive-type
+ \ ulonglong c-type \ ulong define-primitive-type
+ ] if
+
\ longlong c-type \ ptrdiff_t typedef
\ longlong c-type \ intptr_t typedef
+
\ ulonglong c-type \ uintptr_t typedef
\ ulonglong c-type \ size_t typedef
] [
- \ long c-type \ ptrdiff_t typedef
- \ long c-type \ intptr_t typedef
- \ ulong c-type \ uintptr_t typedef
- \ ulong c-type \ size_t typedef
+ <long-long-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-signed-8 ] >>getter
+ [ set-alien-signed-8 ] >>setter
+ 8 >>size
+ 8-byte-alignment
+ "from_signed_8" >>boxer
+ "to_signed_8" >>unboxer
+ \ longlong define-primitive-type
+
+ <long-long-type>
+ integer >>class
+ integer >>boxed-class
+ [ alien-unsigned-8 ] >>getter
+ [ set-alien-unsigned-8 ] >>setter
+ 8 >>size
+ 8-byte-alignment
+ "from_unsigned_8" >>boxer
+ "to_unsigned_8" >>unboxer
+ \ ulonglong define-primitive-type
+
+ \ int c-type \ long define-primitive-type
+ \ uint c-type \ ulong define-primitive-type
+
+ \ int c-type \ ptrdiff_t typedef
+ \ int c-type \ intptr_t typedef
+
+ \ uint c-type \ uintptr_t typedef
+ \ uint c-type \ size_t typedef
] if
] with-compilation-unit
M: float-4-rep rep-component-type drop float ;
M: double-2-rep rep-component-type drop double ;
-: rep-length ( rep -- n )
- 16 swap rep-component-type heap-size /i ; foldable
-
: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
projects / factor.git / blobdiff