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