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