alien.c-types: Add c-type-signed to protocol, which is true for signed
types. Use c-type-signed in classes.struct.db4
							parent
							
								
									eaed0db99a
								
							
						
					
					
						commit
						1a91e3a8ff
					
				| 
						 | 
				
			
			@ -26,6 +26,7 @@ TUPLE: abstract-c-type
 | 
			
		|||
{ getter callable }
 | 
			
		||||
{ setter callable }
 | 
			
		||||
{ size integer }
 | 
			
		||||
{ signed boolean }
 | 
			
		||||
{ align integer }
 | 
			
		||||
{ align-first integer } ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -94,6 +95,10 @@ GENERIC: c-type-setter ( name -- quot )
 | 
			
		|||
 | 
			
		||||
M: c-type c-type-setter setter>> ;
 | 
			
		||||
 | 
			
		||||
GENERIC: c-type-signed ( name -- boolean ) foldable
 | 
			
		||||
 | 
			
		||||
M: abstract-c-type c-type-signed signed>> ;
 | 
			
		||||
 | 
			
		||||
GENERIC: c-type-align ( name -- n ) foldable
 | 
			
		||||
 | 
			
		||||
M: abstract-c-type c-type-align align>> ;
 | 
			
		||||
| 
						 | 
				
			
			@ -143,6 +148,7 @@ PROTOCOL: c-type-protocol
 | 
			
		|||
    c-type-getter
 | 
			
		||||
    c-type-copier
 | 
			
		||||
    c-type-setter
 | 
			
		||||
    c-type-signed
 | 
			
		||||
    c-type-align
 | 
			
		||||
    c-type-align-first
 | 
			
		||||
    base-type
 | 
			
		||||
| 
						 | 
				
			
			@ -236,6 +242,7 @@ M: pointer lookup-c-type
 | 
			
		|||
        [ alien-signed-2 ] >>getter
 | 
			
		||||
        [ set-alien-signed-2 ] >>setter
 | 
			
		||||
        2 >>size
 | 
			
		||||
        t >>signed
 | 
			
		||||
        2 >>align
 | 
			
		||||
        2 >>align-first
 | 
			
		||||
        "from_signed_2" >>boxer
 | 
			
		||||
| 
						 | 
				
			
			@ -262,6 +269,7 @@ M: pointer lookup-c-type
 | 
			
		|||
        [ alien-signed-1 ] >>getter
 | 
			
		||||
        [ set-alien-signed-1 ] >>setter
 | 
			
		||||
        1 >>size
 | 
			
		||||
        t >>signed
 | 
			
		||||
        1 >>align
 | 
			
		||||
        1 >>align-first
 | 
			
		||||
        "from_signed_1" >>boxer
 | 
			
		||||
| 
						 | 
				
			
			@ -316,6 +324,7 @@ M: pointer lookup-c-type
 | 
			
		|||
            [ alien-signed-4 ] >>getter
 | 
			
		||||
            [ set-alien-signed-4 ] >>setter
 | 
			
		||||
            4 >>size
 | 
			
		||||
            t >>signed
 | 
			
		||||
            4 >>align
 | 
			
		||||
            4 >>align-first
 | 
			
		||||
            "from_signed_4" >>boxer
 | 
			
		||||
| 
						 | 
				
			
			@ -342,6 +351,7 @@ M: pointer lookup-c-type
 | 
			
		|||
            [ alien-signed-cell ] >>getter
 | 
			
		||||
            [ set-alien-signed-cell ] >>setter
 | 
			
		||||
            8 >>size
 | 
			
		||||
            t >>signed
 | 
			
		||||
            8 >>align
 | 
			
		||||
            8 >>align-first
 | 
			
		||||
            "from_signed_cell" >>boxer
 | 
			
		||||
| 
						 | 
				
			
			@ -382,6 +392,7 @@ M: pointer lookup-c-type
 | 
			
		|||
            [ alien-signed-cell ] >>getter
 | 
			
		||||
            [ set-alien-signed-cell ] >>setter
 | 
			
		||||
            4 >>size
 | 
			
		||||
            t >>signed
 | 
			
		||||
            4 >>align
 | 
			
		||||
            4 >>align-first
 | 
			
		||||
            "from_signed_cell" >>boxer
 | 
			
		||||
| 
						 | 
				
			
			@ -408,6 +419,7 @@ M: pointer lookup-c-type
 | 
			
		|||
            [ alien-signed-8 ] >>getter
 | 
			
		||||
            [ set-alien-signed-8 ] >>setter
 | 
			
		||||
            8 >>size
 | 
			
		||||
            t >>signed
 | 
			
		||||
            8-byte-alignment
 | 
			
		||||
            "from_signed_8" >>boxer
 | 
			
		||||
            "to_signed_8" >>unboxer
 | 
			
		||||
| 
						 | 
				
			
			@ -463,8 +475,8 @@ M: double-2-rep rep-component-type drop double ;
 | 
			
		|||
: 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 ] }
 | 
			
		||||
        { [ dup c-type-signed ] [ signed-interval ] }
 | 
			
		||||
        { [ dup c-type-signed not ] [ unsigned-interval ] }
 | 
			
		||||
    } cond ; foldable
 | 
			
		||||
 | 
			
		||||
: c-type-clamp ( value c-type -- value' )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -344,11 +344,7 @@ ERROR: bad-type-for-bits type ;
 | 
			
		|||
:: set-bits ( slot-spec n -- slot-spec )
 | 
			
		||||
    struct-bit-slot-spec new
 | 
			
		||||
        n >>bits
 | 
			
		||||
        slot-spec type>> {
 | 
			
		||||
            { int [ t ] }
 | 
			
		||||
            { uint [ f ] }
 | 
			
		||||
            [ bad-type-for-bits ]
 | 
			
		||||
        } case >>signed?
 | 
			
		||||
        slot-spec type>> c-type-signed >>signed?
 | 
			
		||||
        slot-spec name>> >>name
 | 
			
		||||
        slot-spec class>> >>class
 | 
			
		||||
        slot-spec type>> >>type
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue