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

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: byte-arrays arrays assocs kernel kernel.private math
   4 math.order math.parser namespaces make parser sequences strings
   5 words splitting cpu.architecture alien alien.accessors
   6 alien.strings quotations layouts system compiler.units io
   7 io.files io.encodings.binary io.streams.memory accessors
   8 combinators effects continuations fry classes vocabs
   9 vocabs.loader words.symbol ;
  10 QUALIFIED: math
  11 IN: alien.c-types
  12
  13 SYMBOLS:
  14     char uchar
  15     short ushort
  16     int uint
  17     long ulong
  18     longlong ulonglong
  19     float double
  20     void* bool
  21     void ;
  22
  23 DEFER: <int>
  24 DEFER: *char
  25
  26 TUPLE: abstract-c-type
  27 { class class initial: object }
  28 { boxed-class class initial: object }
  29 { boxer-quot callable }
  30 { unboxer-quot callable }
  31 { getter callable }
  32 { setter callable }
  33 { size integer }
  34 { align integer }
  35 { align-first integer } ;
  36
  37 TUPLE: c-type < abstract-c-type
  38 boxer
  39 unboxer
  40 { rep initial: int-rep }
  41 stack-align? ;
  42
  43 : <c-type> ( -- c-type )
  44     \ c-type new ; inline
  45
  46 ERROR: no-c-type name ;
  47
  48 PREDICATE: c-type-word < word
  49     "c-type" word-prop ;
  50
  51 UNION: c-type-name string c-type-word ;
  52
  53 ! C type protocol
  54 GENERIC: c-type ( name -- c-type ) foldable
  55
  56 GENERIC: resolve-pointer-type ( name -- c-type )
  57
  58 << \ void \ void* "pointer-c-type" set-word-prop >>
  59
  60 : void? ( c-type -- ? )
  61     { void "void" } member? ;
  62
  63 M: word resolve-pointer-type
  64     dup "pointer-c-type" word-prop
  65     [ ] [ drop void* ] ?if ;
  66
  67 M: array resolve-pointer-type
  68     first resolve-pointer-type ;
  69
  70 : resolve-typedef ( name -- c-type )
  71     dup void? [ no-c-type ] when
  72     dup c-type-name? [ c-type ] when ;
  73
  74 <PRIVATE
  75
  76 : parse-array-type ( name -- dims c-type )
  77     "[" split unclip
  78     [ [ "]" ?tail drop string>number ] map ] dip ;
  79
  80 PRIVATE>
  81
  82 M: word c-type
  83     dup "c-type" word-prop resolve-typedef
  84     [ ] [ no-c-type ] ?if ;
  85
  86 GENERIC: c-struct? ( c-type -- ? )
  87
  88 M: object c-struct? drop f ;
  89
  90 M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
  91
  92 ! These words being foldable means that words need to be
  93 ! recompiled if a C type is redefined. Even so, folding the
  94 ! size facilitates some optimizations.
  95 GENERIC: c-type-class ( name -- class )
  96
  97 M: abstract-c-type c-type-class class>> ;
  98
  99 M: c-type-name c-type-class c-type c-type-class ;
 100
 101 GENERIC: c-type-boxed-class ( name -- class )
 102
 103 M: abstract-c-type c-type-boxed-class boxed-class>> ;
 104
 105 M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
 106
 107 GENERIC: c-type-boxer ( name -- boxer )
 108
 109 M: c-type c-type-boxer boxer>> ;
 110
 111 M: c-type-name c-type-boxer c-type c-type-boxer ;
 112
 113 GENERIC: c-type-boxer-quot ( name -- quot )
 114
 115 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 116
 117 M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
 118
 119 GENERIC: c-type-unboxer ( name -- boxer )
 120
 121 M: c-type c-type-unboxer unboxer>> ;
 122
 123 M: c-type-name c-type-unboxer c-type c-type-unboxer ;
 124
 125 GENERIC: c-type-unboxer-quot ( name -- quot )
 126
 127 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 128
 129 M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
 130
 131 GENERIC: c-type-rep ( name -- rep )
 132
 133 M: c-type c-type-rep rep>> ;
 134
 135 M: c-type-name c-type-rep c-type c-type-rep ;
 136
 137 GENERIC: c-type-getter ( name -- quot )
 138
 139 M: c-type c-type-getter getter>> ;
 140
 141 M: c-type-name c-type-getter c-type c-type-getter ;
 142
 143 GENERIC: c-type-setter ( name -- quot )
 144
 145 M: c-type c-type-setter setter>> ;
 146
 147 M: c-type-name c-type-setter c-type c-type-setter ;
 148
 149 GENERIC: c-type-align ( name -- n )
 150
 151 M: abstract-c-type c-type-align align>> ;
 152
 153 M: c-type-name c-type-align c-type c-type-align ;
 154
 155 GENERIC: c-type-align-first ( name -- n )
 156
 157 M: c-type-name c-type-align-first c-type c-type-align-first ;
 158
 159 M: abstract-c-type c-type-align-first align-first>> ;
 160
 161 GENERIC: c-type-stack-align? ( name -- ? )
 162
 163 M: c-type c-type-stack-align? stack-align?>> ;
 164
 165 M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
 166
 167 : c-type-box ( n c-type -- )
 168     [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
 169     %box ;
 170
 171 : c-type-unbox ( n c-type -- )
 172     [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
 173     %unbox ;
 174
 175 GENERIC: box-parameter ( n c-type -- )
 176
 177 M: c-type box-parameter c-type-box ;
 178
 179 M: c-type-name box-parameter c-type box-parameter ;
 180
 181 GENERIC: box-return ( c-type -- )
 182
 183 M: c-type box-return f swap c-type-box ;
 184
 185 M: c-type-name box-return c-type box-return ;
 186
 187 GENERIC: unbox-parameter ( n c-type -- )
 188
 189 M: c-type unbox-parameter c-type-unbox ;
 190
 191 M: c-type-name unbox-parameter c-type unbox-parameter ;
 192
 193 GENERIC: unbox-return ( c-type -- )
 194
 195 M: c-type unbox-return f swap c-type-unbox ;
 196
 197 M: c-type-name unbox-return c-type unbox-return ;
 198
 199 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 200
 201 GENERIC: heap-size ( name -- size )
 202
 203 M: c-type-name heap-size c-type heap-size ;
 204
 205 M: abstract-c-type heap-size size>> ;
 206
 207 GENERIC: stack-size ( name -- size )
 208
 209 M: c-type-name stack-size c-type stack-size ;
 210
 211 M: c-type stack-size size>> cell align ;
 212
 213 GENERIC: byte-length ( seq -- n ) flushable
 214
 215 M: byte-array byte-length length ; inline
 216
 217 M: f byte-length drop 0 ; inline
 218
 219 : >c-bool ( ? -- int ) 1 0 ? ; inline
 220
 221 : c-bool> ( int -- ? ) 0 = not ; inline
 222
 223 MIXIN: value-type
 224
 225 : c-getter ( name -- quot )
 226     c-type-getter [
 227         [ "Cannot read struct fields with this type" throw ]
 228     ] unless* ;
 229
 230 : c-type-getter-boxer ( name -- quot )
 231     [ c-getter ] [ c-type-boxer-quot ] bi append ;
 232
 233 : c-setter ( name -- quot )
 234     c-type-setter [
 235         [ "Cannot write struct fields with this type" throw ]
 236     ] unless* ;
 237
 238 : array-accessor ( c-type quot -- def )
 239     [
 240         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
 241     ] [ ] make ;
 242
 243 GENERIC: typedef ( old new -- )
 244
 245 PREDICATE: typedef-word < c-type-word
 246     "c-type" word-prop c-type-name? ;
 247
 248 M: word typedef ( old new -- )
 249     {
 250         [ nip define-symbol ]
 251         [ swap "c-type" set-word-prop ]
 252         [
 253             swap dup c-type-name? [
 254                 resolve-pointer-type
 255                 "pointer-c-type" set-word-prop
 256             ] [ 2drop ] if
 257         ]
 258     } 2cleave ;
 259
 260 TUPLE: long-long-type < c-type ;
 261
 262 : <long-long-type> ( -- c-type )
 263     long-long-type new ;
 264
 265 M: long-long-type unbox-parameter ( n c-type -- )
 266     c-type-unboxer %unbox-long-long ;
 267
 268 M: long-long-type unbox-return ( c-type -- )
 269     f swap unbox-parameter ;
 270
 271 M: long-long-type box-parameter ( n c-type -- )
 272     c-type-boxer %box-long-long ;
 273
 274 M: long-long-type box-return ( c-type -- )
 275     f swap box-parameter ;
 276
 277 : define-deref ( c-type -- )
 278     [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
 279     (( c-ptr -- value )) define-inline ;
 280
 281 : define-out ( c-type -- )
 282     [ name>> "alien.c-types" constructor-word ]
 283     [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
 284     (( value -- c-ptr )) define-inline ;
 285
 286 : define-primitive-type ( c-type name -- )
 287     [ typedef ] [ define-deref ] [ define-out ] tri ;
 288
 289 : if-void ( c-type true false -- )
 290     pick void? [ drop nip call ] [ nip call ] if ; inline
 291
 292 CONSTANT: primitive-types
 293     {
 294         char uchar
 295         short ushort
 296         int uint
 297         long ulong
 298         longlong ulonglong
 299         float double
 300         void* bool
 301     }
 302
 303 SYMBOLS:
 304     ptrdiff_t intptr_t uintptr_t size_t
 305     char* uchar* ;
 306
 307 : 8-byte-alignment ( c-type -- c-type )
 308     {
 309         { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
 310         { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
 311         [ 8 >>align 8 >>align-first ]
 312     } cond ;
 313
 314 [
 315     <c-type>
 316         c-ptr >>class
 317         c-ptr >>boxed-class
 318         [ alien-cell ] >>getter
 319         [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
 320         bootstrap-cell >>size
 321         bootstrap-cell >>align
 322         bootstrap-cell >>align-first
 323         [ >c-ptr ] >>unboxer-quot
 324         "allot_alien" >>boxer
 325         "alien_offset" >>unboxer
 326     \ void* define-primitive-type
 327
 328     <c-type>
 329         integer >>class
 330         integer >>boxed-class
 331         [ alien-signed-4 ] >>getter
 332         [ set-alien-signed-4 ] >>setter
 333         4 >>size
 334         4 >>align
 335         4 >>align-first
 336         "from_signed_4" >>boxer
 337         "to_fixnum" >>unboxer
 338     \ int define-primitive-type
 339
 340     <c-type>
 341         integer >>class
 342         integer >>boxed-class
 343         [ alien-unsigned-4 ] >>getter
 344         [ set-alien-unsigned-4 ] >>setter
 345         4 >>size
 346         4 >>align
 347         4 >>align-first
 348         "from_unsigned_4" >>boxer
 349         "to_cell" >>unboxer
 350     \ uint define-primitive-type
 351
 352     <c-type>
 353         fixnum >>class
 354         fixnum >>boxed-class
 355         [ alien-signed-2 ] >>getter
 356         [ set-alien-signed-2 ] >>setter
 357         2 >>size
 358         2 >>align
 359         2 >>align-first
 360         "from_signed_2" >>boxer
 361         "to_fixnum" >>unboxer
 362     \ short define-primitive-type
 363
 364     <c-type>
 365         fixnum >>class
 366         fixnum >>boxed-class
 367         [ alien-unsigned-2 ] >>getter
 368         [ set-alien-unsigned-2 ] >>setter
 369         2 >>size
 370         2 >>align
 371         2 >>align-first
 372         "from_unsigned_2" >>boxer
 373         "to_cell" >>unboxer
 374     \ ushort define-primitive-type
 375
 376     <c-type>
 377         fixnum >>class
 378         fixnum >>boxed-class
 379         [ alien-signed-1 ] >>getter
 380         [ set-alien-signed-1 ] >>setter
 381         1 >>size
 382         1 >>align
 383         1 >>align-first
 384         "from_signed_1" >>boxer
 385         "to_fixnum" >>unboxer
 386     \ char define-primitive-type
 387
 388     <c-type>
 389         fixnum >>class
 390         fixnum >>boxed-class
 391         [ alien-unsigned-1 ] >>getter
 392         [ set-alien-unsigned-1 ] >>setter
 393         1 >>size
 394         1 >>align
 395         1 >>align-first
 396         "from_unsigned_1" >>boxer
 397         "to_cell" >>unboxer
 398     \ uchar define-primitive-type
 399
 400     cpu ppc? [
 401         <c-type>
 402             [ alien-unsigned-4 c-bool> ] >>getter
 403             [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
 404             4 >>size
 405             4 >>align
 406             4 >>align-first
 407             "from_boolean" >>boxer
 408             "to_boolean" >>unboxer
 409     ] [
 410         <c-type>
 411             [ alien-unsigned-1 c-bool> ] >>getter
 412             [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
 413             1 >>size
 414             1 >>align
 415             1 >>align-first
 416             "from_boolean" >>boxer
 417             "to_boolean" >>unboxer
 418     ] if
 419     \ bool define-primitive-type
 420
 421     <c-type>
 422         math:float >>class
 423         math:float >>boxed-class
 424         [ alien-float ] >>getter
 425         [ [ >float ] 2dip set-alien-float ] >>setter
 426         4 >>size
 427         4 >>align
 428         4 >>align-first
 429         "from_float" >>boxer
 430         "to_float" >>unboxer
 431         float-rep >>rep
 432         [ >float ] >>unboxer-quot
 433     \ float define-primitive-type
 434
 435     <c-type>
 436         math:float >>class
 437         math:float >>boxed-class
 438         [ alien-double ] >>getter
 439         [ [ >float ] 2dip set-alien-double ] >>setter
 440         8 >>size
 441         8-byte-alignment
 442         "from_double" >>boxer
 443         "to_double" >>unboxer
 444         double-rep >>rep
 445         [ >float ] >>unboxer-quot
 446     \ double define-primitive-type
 447
 448     cell 8 = [
 449         <c-type>
 450             integer >>class
 451             integer >>boxed-class
 452             [ alien-signed-cell ] >>getter
 453             [ set-alien-signed-cell ] >>setter
 454             bootstrap-cell >>size
 455             bootstrap-cell >>align
 456             bootstrap-cell >>align-first
 457             "from_signed_cell" >>boxer
 458             "to_fixnum" >>unboxer
 459         \ longlong define-primitive-type
 460
 461         <c-type>
 462             integer >>class
 463             integer >>boxed-class
 464             [ alien-unsigned-cell ] >>getter
 465             [ set-alien-unsigned-cell ] >>setter
 466             bootstrap-cell >>size
 467             bootstrap-cell >>align
 468             bootstrap-cell >>align-first
 469             "from_unsigned_cell" >>boxer
 470             "to_cell" >>unboxer
 471         \ ulonglong define-primitive-type
 472
 473         os windows? [
 474             \ int c-type \ long define-primitive-type
 475             \ uint c-type \ ulong define-primitive-type
 476         ] [
 477             \ longlong c-type \ long define-primitive-type
 478             \ ulonglong c-type \ ulong define-primitive-type
 479         ] if
 480
 481         \ longlong c-type \ ptrdiff_t typedef
 482         \ longlong c-type \ intptr_t typedef
 483
 484         \ ulonglong c-type \ uintptr_t typedef
 485         \ ulonglong c-type \ size_t typedef
 486     ] [
 487         <long-long-type>
 488             integer >>class
 489             integer >>boxed-class
 490             [ alien-signed-8 ] >>getter
 491             [ set-alien-signed-8 ] >>setter
 492             8 >>size
 493             8-byte-alignment
 494             "from_signed_8" >>boxer
 495             "to_signed_8" >>unboxer
 496         \ longlong define-primitive-type
 497
 498         <long-long-type>
 499             integer >>class
 500             integer >>boxed-class
 501             [ alien-unsigned-8 ] >>getter
 502             [ set-alien-unsigned-8 ] >>setter
 503             8 >>size
 504             8-byte-alignment
 505             "from_unsigned_8" >>boxer
 506             "to_unsigned_8" >>unboxer
 507         \ ulonglong define-primitive-type
 508
 509         \ int c-type \ long define-primitive-type
 510         \ uint c-type \ ulong define-primitive-type
 511
 512         \ int c-type \ ptrdiff_t typedef
 513         \ int c-type \ intptr_t typedef
 514
 515         \ uint c-type \ uintptr_t typedef
 516         \ uint c-type \ size_t typedef
 517     ] if
 518 ] with-compilation-unit
 519
 520 M: char-16-rep rep-component-type drop char ;
 521 M: uchar-16-rep rep-component-type drop uchar ;
 522 M: short-8-rep rep-component-type drop short ;
 523 M: ushort-8-rep rep-component-type drop ushort ;
 524 M: int-4-rep rep-component-type drop int ;
 525 M: uint-4-rep rep-component-type drop uint ;
 526 M: longlong-2-rep rep-component-type drop longlong ;
 527 M: ulonglong-2-rep rep-component-type drop ulonglong ;
 528 M: float-4-rep rep-component-type drop float ;
 529 M: double-2-rep rep-component-type drop double ;
 530
 531 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
 532 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
 533 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
 534 : signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable
 535
 536 : c-type-interval ( c-type -- from to )
 537     {
 538         { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
 539         { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
 540         { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
 541     } cond ; foldable
 542
 543 : c-type-clamp ( value c-type -- value' )
 544     dup { float double } member-eq?
 545     [ drop ] [ c-type-interval clamp ] if ; inline