! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs kernel kernel.private libc math
-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 ;
+USING: byte-arrays arrays assocs kernel kernel.private math
+math.order math.parser namespaces make parser sequences strings
+words splitting 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 words.symbol ;
+QUALIFIED: math
IN: alien.c-types
+SYMBOLS:
+ char uchar
+ short ushort
+ int uint
+ long ulong
+ longlong ulonglong
+ float double
+ bool void*
+ void ;
+
DEFER: <int>
DEFER: *char
-: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-
TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
-size
-align ;
+{ size integer }
+{ align integer }
+{ align-first integer } ;
TUPLE: c-type < abstract-c-type
boxer
{ rep initial: int-rep }
stack-align? ;
-: <c-type> ( -- type )
- \ c-type new ;
-
-SYMBOL: c-types
-
-global [
- c-types [ H{ } assoc-like ] change
-] bind
+: <c-type> ( -- c-type )
+ \ c-type new ; inline
ERROR: no-c-type name ;
-: (c-type) ( name -- type/f )
- c-types get-global at dup [
- dup string? [ (c-type) ] when
- ] when ;
+PREDICATE: c-type-word < word
+ "c-type" word-prop ;
! C type protocol
-GENERIC: c-type ( name -- type ) foldable
-
-: resolve-pointer-type ( name -- name )
- c-types get at dup string?
- [ "*" append ] [ drop "void*" ] if
- c-type ;
-
-: resolve-typedef ( name -- type )
- dup string? [ c-type ] when ;
-
-: parse-array-type ( name -- array )
- "[" split unclip
- [ [ "]" ?tail drop string>number ] map ] dip prefix ;
-
-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 ;
+GENERIC: c-type ( name -- c-type ) foldable
-GENERIC: c-struct? ( type -- ? )
+: void? ( c-type -- ? )
+ void = ; inline
-M: object c-struct?
- drop f ;
-M: string c-struct?
- dup "void" = [ drop f ] [ c-type c-struct? ] if ;
+TUPLE: pointer { to initial: void read-only } ;
+C: <pointer> pointer
-! 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: abstract-c-type heap-size size>> ;
-
-GENERIC: require-c-array ( c-type -- )
+: resolve-typedef ( name -- c-type )
+ dup void? [ no-c-type ] when
+ dup c-type-word? [ c-type ] when ;
-M: array require-c-array first require-c-array ;
+<PRIVATE
-GENERIC: c-array-constructor ( c-type -- word )
-
-GENERIC: c-(array)-constructor ( c-type -- word )
-
-GENERIC: c-direct-array-constructor ( c-type -- word )
-
-GENERIC: <c-array> ( len c-type -- array )
-
-M: string <c-array>
- c-array-constructor execute( len -- array ) ; inline
-
-GENERIC: (c-array) ( len c-type -- array )
+: parse-array-type ( name -- dims c-type )
+ "[" split unclip
+ [ [ "]" ?tail drop string>number ] map ] dip ;
-M: string (c-array)
- c-(array)-constructor execute( len -- array ) ; inline
+PRIVATE>
-GENERIC: <c-direct-array> ( alien len c-type -- array )
+M: word c-type
+ dup "c-type" word-prop resolve-typedef
+ [ ] [ no-c-type ] ?if ;
-M: string <c-direct-array>
- c-direct-array-constructor execute( alien len -- array ) ; inline
+GENERIC: c-struct? ( c-type -- ? )
-: malloc-array ( n type -- alien )
- [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+M: object c-struct? drop f ;
-: (malloc-array) ( n type -- alien )
- [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+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
+! size facilitates some optimizations.
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-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: string 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: string 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: string 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: string 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: string 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: string 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: string 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: string 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: string 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-word c-type-align-first c-type c-type-align-first ;
+
+M: abstract-c-type c-type-align-first align-first>> ;
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-word c-type-stack-align? c-type c-type-stack-align? ;
-: c-type-box ( n type -- )
+: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
-: c-type-unbox ( n ctype -- )
+: c-type-unbox ( n c-type -- )
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
-GENERIC: box-parameter ( n ctype -- )
+GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
-M: string box-parameter c-type box-parameter ;
+M: c-type-word box-parameter c-type box-parameter ;
-GENERIC: box-return ( ctype -- )
+GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
-M: string box-return c-type box-return ;
+M: c-type-word box-return c-type box-return ;
-GENERIC: unbox-parameter ( n ctype -- )
+GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
-M: string unbox-parameter c-type unbox-parameter ;
+M: c-type-word unbox-parameter c-type unbox-parameter ;
-GENERIC: unbox-return ( ctype -- )
+GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
-M: string unbox-return c-type unbox-return ;
+M: c-type-word unbox-return c-type unbox-return ;
-GENERIC: stack-size ( type -- size ) foldable
+: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-M: string stack-size c-type stack-size ;
+GENERIC: heap-size ( name -- size )
-M: c-type stack-size size>> cell align ;
+M: c-type-word heap-size c-type heap-size ;
-MIXIN: value-type
+M: abstract-c-type heap-size size>> ;
-M: value-type c-type-rep drop int-rep ;
+GENERIC: stack-size ( name -- size )
-M: value-type c-type-getter
- drop [ swap <displaced-alien> ] ;
+M: c-type-word stack-size c-type stack-size ;
-M: value-type c-type-setter ( type -- quot )
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
+M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
M: f byte-length drop 0 ; inline
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
+
+MIXIN: value-type
+
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
[ "Cannot write struct fields with this type" throw ]
] unless* ;
-: <c-object> ( type -- array )
- heap-size <byte-array> ; inline
-
-: (c-object) ( type -- array )
- heap-size (byte-array) ; inline
-
-: malloc-object ( type -- alien )
- 1 swap heap-size calloc ; inline
-
-: (malloc-object) ( type -- alien )
- heap-size malloc ; inline
-
-: malloc-byte-array ( byte-array -- alien )
- dup byte-length [ nip malloc dup ] 2keep memcpy ;
-
-: memory>byte-array ( alien len -- byte-array )
- [ nip (byte-array) dup ] 2keep memcpy ;
-
-: malloc-string ( string encoding -- alien )
- string>alien malloc-byte-array ;
-
-M: memory-stream stream-read
- [
- [ index>> ] [ alien>> ] bi <displaced-alien>
- swap memory>byte-array
- ] [ [ + ] change-index drop ] 2bi ;
-
-: byte-array>memory ( byte-array base -- )
- swap dup byte-length memcpy ; inline
-
-: array-accessor ( type quot -- def )
+: array-accessor ( c-type quot -- def )
[
\ 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-word? ;
+
+M: word typedef ( old new -- )
+ {
+ [ nip define-symbol ]
+ [ swap "c-type" set-word-prop ]
+ } 2cleave ;
+
+M: pointer typedef ( old new -- )
+ to>> dup c-type-word?
+ [ ]
+ [ 2drop ] if ;
TUPLE: long-long-type < c-type ;
-: <long-long-type> ( -- type )
+: <long-long-type> ( -- c-type )
long-long-type new ;
-M: long-long-type unbox-parameter ( n type -- )
+M: long-long-type unbox-parameter ( n c-type -- )
c-type-unboxer %unbox-long-long ;
-M: long-long-type unbox-return ( type -- )
+M: long-long-type unbox-return ( c-type -- )
f swap unbox-parameter ;
-M: long-long-type box-parameter ( n type -- )
+M: long-long-type box-parameter ( n c-type -- )
c-type-boxer %box-long-long ;
-M: long-long-type box-return ( type -- )
+M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
-: define-deref ( name -- )
- [ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
+: define-deref ( c-type -- )
+ [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
(( c-ptr -- value )) define-inline ;
-: define-out ( name -- )
- [ "alien.c-types" constructor-word ]
- [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
+: define-out ( c-type -- )
+ [ name>> "alien.c-types" constructor-word ]
+ [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
-: >c-bool ( ? -- int ) 1 0 ? ; inline
+: define-primitive-type ( c-type name -- )
+ [ typedef ] [ define-deref ] [ define-out ] tri ;
-: c-bool> ( int -- ? ) 0 = not ; inline
+: if-void ( c-type true false -- )
+ pick void? [ drop nip call ] [ nip call ] if ; inline
+
+CONSTANT: primitive-types
+ {
+ char uchar
+ short ushort
+ int uint
+ long ulong
+ longlong ulonglong
+ float double
+ void* bool
+ }
-: define-primitive-type ( type name -- )
- [ typedef ]
- [ define-deref ]
- [ define-out ]
- tri ;
+SYMBOLS:
+ ptrdiff_t intptr_t uintptr_t size_t
+ char* ;
-: malloc-file-contents ( path -- alien len )
- binary file-contents [ malloc-byte-array ] [ length ] bi ;
+<PRIVATE
-: if-void ( type true false -- )
- pick "void" = [ drop nip call ] [ nip call ] if ; inline
+: (pointer-c-type) ( void* type -- void*' )
+ [ clone ] dip c-type-boxer-quot >>boxer-quot ;
-CONSTANT: primitive-types
+: 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 )
{
- "char" "uchar"
- "short" "ushort"
- "int" "uint"
- "long" "ulong"
- "longlong" "ulonglong"
- "float" "double"
- "void*" "bool"
- }
+ { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
+ { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
+ [ 8 >>align 8 >>align-first ]
+ } cond ;
[
<c-type>
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
+ bootstrap-cell >>align-first
[ >c-ptr ] >>unboxer-quot
- "box_alien" >>boxer
+ "allot_alien" >>boxer
"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 >>align
- "box_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 >>align
- "box_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
- "box_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
- "box_unsigned_cell" >>boxer
- "to_cell" >>unboxer
- "ulong" define-primitive-type
+ \ void* define-primitive-type
<c-type>
integer >>class
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
- "box_signed_4" >>boxer
+ 4 >>align-first
+ "from_signed_4" >>boxer
"to_fixnum" >>unboxer
- "int" define-primitive-type
+ \ int define-primitive-type
<c-type>
integer >>class
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
- "box_unsigned_4" >>boxer
+ 4 >>align-first
+ "from_unsigned_4" >>boxer
"to_cell" >>unboxer
- "uint" define-primitive-type
+ \ uint define-primitive-type
<c-type>
fixnum >>class
[ set-alien-signed-2 ] >>setter
2 >>size
2 >>align
- "box_signed_2" >>boxer
+ 2 >>align-first
+ "from_signed_2" >>boxer
"to_fixnum" >>unboxer
- "short" define-primitive-type
+ \ short define-primitive-type
<c-type>
fixnum >>class
[ set-alien-unsigned-2 ] >>setter
2 >>size
2 >>align
- "box_unsigned_2" >>boxer
+ 2 >>align-first
+ "from_unsigned_2" >>boxer
"to_cell" >>unboxer
- "ushort" define-primitive-type
+ \ ushort define-primitive-type
<c-type>
fixnum >>class
[ set-alien-signed-1 ] >>setter
1 >>size
1 >>align
- "box_signed_1" >>boxer
+ 1 >>align-first
+ "from_signed_1" >>boxer
"to_fixnum" >>unboxer
- "char" define-primitive-type
+ \ char define-primitive-type
<c-type>
fixnum >>class
[ set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
- "box_unsigned_1" >>boxer
+ 1 >>align-first
+ "from_unsigned_1" >>boxer
"to_cell" >>unboxer
- "uchar" define-primitive-type
-
- <c-type>
- [ alien-unsigned-1 c-bool> ] >>getter
- [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
- 1 >>size
- 1 >>align
- "box_boolean" >>boxer
- "to_boolean" >>unboxer
- "bool" define-primitive-type
+ \ uchar define-primitive-type
+
+ cpu ppc? [
+ <c-type>
+ [ alien-unsigned-4 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ 4 >>align-first
+ "from_boolean" >>boxer
+ "to_boolean" >>unboxer
+ ] [
+ <c-type>
+ [ alien-unsigned-1 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ 1 >>align-first
+ "from_boolean" >>boxer
+ "to_boolean" >>unboxer
+ ] if
+ \ bool define-primitive-type
<c-type>
- float >>class
- float >>boxed-class
+ math:float >>class
+ math:float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
- "box_float" >>boxer
+ 4 >>align-first
+ "from_float" >>boxer
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
- "float" define-primitive-type
+ \ float define-primitive-type
<c-type>
- float >>class
- float >>boxed-class
+ math:float >>class
+ math:float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
- 8 >>align
- "box_double" >>boxer
+ 8-byte-alignment
+ "from_double" >>boxer
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
- "double" define-primitive-type
+ \ double define-primitive-type
+
+ 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
- "long" "ptrdiff_t" typedef
- "long" "intptr_t" typedef
- "ulong" "size_t" typedef
+ \ 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-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: char-16-rep rep-component-type drop char ;
+M: uchar-16-rep rep-component-type drop uchar ;
+M: short-8-rep rep-component-type drop short ;
+M: ushort-8-rep rep-component-type drop ushort ;
+M: int-4-rep rep-component-type drop int ;
+M: uint-4-rep rep-component-type drop uint ;
+M: longlong-2-rep rep-component-type drop longlong ;
+M: ulonglong-2-rep rep-component-type drop ulonglong ;
+M: float-4-rep rep-component-type drop float ;
+M: double-2-rep rep-component-type drop double ;
+
+: (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
+: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
+
+: c-type-interval ( c-type -- from to )
+ {
+ { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
+ { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
+ { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
+ } cond ; foldable
+
+: c-type-clamp ( value c-type -- value' )
+ dup { float double } member-eq?
+ [ drop ] [ c-type-interval clamp ] if ; inline
projects / factor.git / blobdiff