basis/alien/c-types/c-types.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors arrays byte-arrays
   4 classes combinators compiler.units cpu.architecture delegate
   5 fry kernel layouts locals macros math math.order quotations
   6 sequences system words words.symbol summary ;
   7 QUALIFIED: math
   8 IN: alien.c-types
   9
  10 SYMBOLS:
  11     char uchar
  12     short ushort
  13     int uint
  14     long ulong
  15     longlong ulonglong
  16     float double
  17     void* bool ;
  18
  19 SINGLETON: void
  20
  21 TUPLE: abstract-c-type
  22 { class class initial: object }
  23 { boxed-class class initial: object }
  24 { boxer-quot callable }
  25 { unboxer-quot callable }
  26 { getter callable }
  27 { setter callable }
  28 { size integer }
  29 { align integer }
  30 { align-first integer } ;
  31
  32 TUPLE: c-type < abstract-c-type
  33 boxer
  34 unboxer
  35 { rep initial: int-rep } ;
  36
  37 : <c-type> ( -- c-type )
  38     \ c-type new ; inline
  39
  40 ERROR: no-c-type word ;
  41
  42 M: no-c-type summary drop "Not a C type" ;
  43
  44 ! C type protocol
  45 GENERIC: c-type ( name -- c-type ) foldable
  46
  47 PREDICATE: c-type-word < word
  48     "c-type" word-prop ;
  49
  50 TUPLE: pointer { to initial: void read-only } ;
  51 C: <pointer> pointer
  52
  53 UNION: c-type-name
  54     c-type-word pointer ;
  55
  56 : resolve-typedef ( name -- c-type )
  57     dup void? [ no-c-type ] when
  58     dup c-type-name? [ c-type ] when ;
  59
  60 M: word c-type
  61     dup "c-type" word-prop resolve-typedef
  62     [ ] [ no-c-type ] ?if ;
  63
  64 GENERIC: c-type-class ( name -- class )
  65
  66 M: abstract-c-type c-type-class class>> ;
  67
  68 GENERIC: c-type-boxed-class ( name -- class )
  69
  70 M: abstract-c-type c-type-boxed-class boxed-class>> ;
  71
  72 GENERIC: c-type-boxer-quot ( name -- quot )
  73
  74 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
  75
  76 GENERIC: c-type-unboxer-quot ( name -- quot )
  77
  78 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
  79
  80 GENERIC: c-type-rep ( name -- rep )
  81
  82 M: c-type c-type-rep rep>> ;
  83
  84 GENERIC: c-type-getter ( name -- quot )
  85
  86 M: c-type c-type-getter getter>> ;
  87
  88 GENERIC: c-type-copier ( name -- quot )
  89
  90 M: c-type c-type-copier drop [ ] ;
  91
  92 GENERIC: c-type-setter ( name -- quot )
  93
  94 M: c-type c-type-setter setter>> ;
  95
  96 GENERIC: c-type-align ( name -- n ) foldable
  97
  98 M: abstract-c-type c-type-align align>> ;
  99
 100 GENERIC: c-type-align-first ( name -- n )
 101
 102 M: abstract-c-type c-type-align-first align-first>> ;
 103
 104 GENERIC: base-type ( c-type -- c-type )
 105
 106 M: c-type-name base-type c-type ;
 107
 108 M: c-type base-type ;
 109
 110 GENERIC: heap-size ( name -- size )
 111
 112 M: abstract-c-type heap-size size>> ;
 113
 114 MIXIN: value-type
 115
 116 MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
 117     [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
 118
 119 MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
 120     [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
 121
 122 MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
 123     [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
 124     [ c-type-setter ]
 125     bi append ;
 126
 127 : array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
 128     [ swapd heap-size * >fixnum ] keep ; inline
 129
 130 : alien-element ( n c-ptr c-type -- value )
 131     array-accessor alien-value ; inline
 132
 133 : set-alien-element ( value n c-ptr c-type -- )
 134     array-accessor set-alien-value ; inline
 135
 136 PROTOCOL: c-type-protocol
 137     c-type-class
 138     c-type-boxed-class
 139     c-type-boxer-quot
 140     c-type-unboxer-quot
 141     c-type-rep
 142     c-type-getter
 143     c-type-copier
 144     c-type-setter
 145     c-type-align
 146     c-type-align-first
 147     base-type
 148     heap-size ;
 149
 150 CONSULT: c-type-protocol c-type-name
 151     c-type ;
 152
 153 PREDICATE: typedef-word < c-type-word
 154     "c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
 155
 156 : typedef ( old new -- )
 157     {
 158         [ nip define-symbol ]
 159         [ swap "c-type" set-word-prop ]
 160     } 2cleave ;
 161
 162 TUPLE: long-long-type < c-type ;
 163
 164 : <long-long-type> ( -- c-type )
 165     long-long-type new ;
 166
 167 : if-void ( c-type true false -- )
 168     pick void? [ drop nip call ] [ nip call ] if ; inline
 169
 170 SYMBOLS:
 171     ptrdiff_t intptr_t uintptr_t size_t
 172     c-string ;
 173
 174 CONSTANT: primitive-types
 175     {
 176         char uchar
 177         short ushort
 178         int uint
 179         long ulong
 180         longlong ulonglong
 181         float double
 182         void* bool
 183         c-string
 184     }
 185
 186 : >c-bool ( ? -- int ) 1 0 ? ; inline
 187
 188 : c-bool> ( int -- ? ) 0 = not ; inline
 189
 190 <PRIVATE
 191
 192 : 8-byte-alignment ( c-type -- c-type )
 193     {
 194         { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
 195         { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
 196         [ 8 >>align 8 >>align-first ]
 197     } cond ;
 198
 199 : resolve-pointer-typedef ( type -- base-type )
 200     dup "c-type" word-prop dup word?
 201     [ nip resolve-pointer-typedef ] [
 202         pointer? [ drop void* ] when
 203     ] if ;
 204
 205 : primitive-pointer-type? ( type -- ? )
 206     dup c-type-word? [
 207         resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
 208     ] [ drop t ] if ;
 209
 210 : (pointer-c-type) ( void* type -- void*' )
 211     [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
 212
 213 PRIVATE>
 214
 215 M: pointer c-type
 216     [ \ void* c-type ] dip
 217     to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
 218
 219 [
 220     <c-type>
 221         c-ptr >>class
 222         c-ptr >>boxed-class
 223         [ alien-cell ] >>getter
 224         [ set-alien-cell ] >>setter
 225         bootstrap-cell >>size
 226         bootstrap-cell >>align
 227         bootstrap-cell >>align-first
 228         [ >c-ptr ] >>unboxer-quot
 229         "allot_alien" >>boxer
 230         "alien_offset" >>unboxer
 231     \ void* typedef
 232
 233     <c-type>
 234         fixnum >>class
 235         fixnum >>boxed-class
 236         [ alien-signed-2 ] >>getter
 237         [ set-alien-signed-2 ] >>setter
 238         2 >>size
 239         2 >>align
 240         2 >>align-first
 241         "from_signed_2" >>boxer
 242         "to_signed_2" >>unboxer
 243         [ >fixnum ] >>unboxer-quot
 244     \ short typedef
 245
 246     <c-type>
 247         fixnum >>class
 248         fixnum >>boxed-class
 249         [ alien-unsigned-2 ] >>getter
 250         [ set-alien-unsigned-2 ] >>setter
 251         2 >>size
 252         2 >>align
 253         2 >>align-first
 254         "from_unsigned_2" >>boxer
 255         "to_unsigned_2" >>unboxer
 256         [ >fixnum ] >>unboxer-quot
 257     \ ushort typedef
 258
 259     <c-type>
 260         fixnum >>class
 261         fixnum >>boxed-class
 262         [ alien-signed-1 ] >>getter
 263         [ set-alien-signed-1 ] >>setter
 264         1 >>size
 265         1 >>align
 266         1 >>align-first
 267         "from_signed_1" >>boxer
 268         "to_signed_1" >>unboxer
 269         [ >fixnum ] >>unboxer-quot
 270     \ char typedef
 271
 272     <c-type>
 273         fixnum >>class
 274         fixnum >>boxed-class
 275         [ alien-unsigned-1 ] >>getter
 276         [ set-alien-unsigned-1 ] >>setter
 277         1 >>size
 278         1 >>align
 279         1 >>align-first
 280         "from_unsigned_1" >>boxer
 281         "to_unsigned_1" >>unboxer
 282         [ >fixnum ] >>unboxer-quot
 283     \ uchar typedef
 284
 285     <c-type>
 286         math:float >>class
 287         math:float >>boxed-class
 288         [ alien-float ] >>getter
 289         [ set-alien-float ] >>setter
 290         4 >>size
 291         4 >>align
 292         4 >>align-first
 293         "from_float" >>boxer
 294         "to_float" >>unboxer
 295         float-rep >>rep
 296         [ >float ] >>unboxer-quot
 297     \ float typedef
 298
 299     <c-type>
 300         math:float >>class
 301         math:float >>boxed-class
 302         [ alien-double ] >>getter
 303         [ set-alien-double ] >>setter
 304         8 >>size
 305         8-byte-alignment
 306         "from_double" >>boxer
 307         "to_double" >>unboxer
 308         double-rep >>rep
 309         [ >float ] >>unboxer-quot
 310     \ double typedef
 311
 312     cell 8 = [
 313         <c-type>
 314             fixnum >>class
 315             fixnum >>boxed-class
 316             [ alien-signed-4 ] >>getter
 317             [ set-alien-signed-4 ] >>setter
 318             4 >>size
 319             4 >>align
 320             4 >>align-first
 321             "from_signed_4" >>boxer
 322             "to_signed_4" >>unboxer
 323             [ >fixnum ] >>unboxer-quot
 324         \ int typedef
 325
 326         <c-type>
 327             fixnum >>class
 328             fixnum >>boxed-class
 329             [ alien-unsigned-4 ] >>getter
 330             [ set-alien-unsigned-4 ] >>setter
 331             4 >>size
 332             4 >>align
 333             4 >>align-first
 334             "from_unsigned_4" >>boxer
 335             "to_unsigned_4" >>unboxer
 336             [ >fixnum ] >>unboxer-quot
 337         \ uint typedef
 338
 339         <c-type>
 340             integer >>class
 341             integer >>boxed-class
 342             [ alien-signed-cell ] >>getter
 343             [ set-alien-signed-cell ] >>setter
 344             8 >>size
 345             8 >>align
 346             8 >>align-first
 347             "from_signed_cell" >>boxer
 348             "to_fixnum" >>unboxer
 349             [ >integer ] >>unboxer-quot
 350         \ longlong typedef
 351
 352         <c-type>
 353             integer >>class
 354             integer >>boxed-class
 355             [ alien-unsigned-cell ] >>getter
 356             [ set-alien-unsigned-cell ] >>setter
 357             8 >>size
 358             8 >>align
 359             8 >>align-first
 360             "from_unsigned_cell" >>boxer
 361             "to_cell" >>unboxer
 362             [ >integer ] >>unboxer-quot
 363         \ ulonglong typedef
 364
 365         os windows? [
 366             \ int c-type \ long typedef
 367             \ uint c-type \ ulong typedef
 368         ] [
 369             \ longlong c-type \ long typedef
 370             \ ulonglong c-type \ ulong typedef
 371         ] if
 372
 373         \ longlong c-type \ ptrdiff_t typedef
 374         \ longlong c-type \ intptr_t typedef
 375
 376         \ ulonglong c-type \ uintptr_t typedef
 377         \ ulonglong c-type \ size_t typedef
 378     ] [
 379         <c-type>
 380             integer >>class
 381             integer >>boxed-class
 382             [ alien-signed-cell ] >>getter
 383             [ set-alien-signed-cell ] >>setter
 384             4 >>size
 385             4 >>align
 386             4 >>align-first
 387             "from_signed_cell" >>boxer
 388             "to_fixnum" >>unboxer
 389             [ >integer ] >>unboxer-quot
 390         \ int typedef
 391
 392         <c-type>
 393             integer >>class
 394             integer >>boxed-class
 395             [ alien-unsigned-cell ] >>getter
 396             [ set-alien-unsigned-cell ] >>setter
 397             4 >>size
 398             4 >>align
 399             4 >>align-first
 400             "from_unsigned_cell" >>boxer
 401             "to_cell" >>unboxer
 402             [ >integer ] >>unboxer-quot
 403         \ uint typedef
 404
 405         <long-long-type>
 406             integer >>class
 407             integer >>boxed-class
 408             [ alien-signed-8 ] >>getter
 409             [ set-alien-signed-8 ] >>setter
 410             8 >>size
 411             8-byte-alignment
 412             "from_signed_8" >>boxer
 413             "to_signed_8" >>unboxer
 414             [ >integer ] >>unboxer-quot
 415         \ longlong typedef
 416
 417         <long-long-type>
 418             integer >>class
 419             integer >>boxed-class
 420             [ alien-unsigned-8 ] >>getter
 421             [ set-alien-unsigned-8 ] >>setter
 422             8 >>size
 423             8-byte-alignment
 424             "from_unsigned_8" >>boxer
 425             "to_unsigned_8" >>unboxer
 426             [ >integer ] >>unboxer-quot
 427         \ ulonglong typedef
 428
 429         \ int c-type \ long typedef
 430         \ uint c-type \ ulong typedef
 431
 432         \ int c-type \ ptrdiff_t typedef
 433         \ int c-type \ intptr_t typedef
 434
 435         \ uint c-type \ uintptr_t typedef
 436         \ uint c-type \ size_t typedef
 437     ] if
 438
 439     cpu ppc? \ uint \ uchar ? c-type clone
 440         [ >c-bool ] >>unboxer-quot
 441         [ c-bool> ] >>boxer-quot
 442         object >>boxed-class
 443     \ bool typedef
 444
 445 ] with-compilation-unit
 446
 447 M: char-16-rep rep-component-type drop char ;
 448 M: uchar-16-rep rep-component-type drop uchar ;
 449 M: short-8-rep rep-component-type drop short ;
 450 M: ushort-8-rep rep-component-type drop ushort ;
 451 M: int-4-rep rep-component-type drop int ;
 452 M: uint-4-rep rep-component-type drop uint ;
 453 M: longlong-2-rep rep-component-type drop longlong ;
 454 M: ulonglong-2-rep rep-component-type drop ulonglong ;
 455 M: float-4-rep rep-component-type drop float ;
 456 M: double-2-rep rep-component-type drop double ;
 457
 458 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
 459 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
 460 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
 461 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
 462
 463 : c-type-interval ( c-type -- from to )
 464     {
 465         { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
 466         { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
 467         { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
 468     } cond ; foldable
 469
 470 : c-type-clamp ( value c-type -- value' )
 471     dup { float double } member-eq?
 472     [ drop ] [ c-type-interval clamp ] if ; inline