basis/alien/endian/endian.factor

   1 ! Copyright (C) 2011 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors alien.c-types alien.data
   4 classes.struct.private combinators compiler.units endian fry
   5 generalizations kernel macros math namespaces sequences words
   6 arrays slots ;
   7 QUALIFIED-WITH: alien.c-types ac
   8 IN: alien.endian
   9
  10 ERROR: invalid-signed-conversion n ;
  11
  12 : convert-signed-quot ( n -- quot )
  13     {
  14         { 1 [ [ char <ref> char deref ] ] }
  15         { 2 [ [ ac:short <ref> ac:short deref ] ] }
  16         { 4 [ [ int <ref> int deref ] ] }
  17         { 8 [ [ longlong <ref> longlong deref ] ] }
  18         [ invalid-signed-conversion ]
  19     } case ; inline
  20
  21 <PRIVATE
  22
  23 : byte-mask ( #bits-shift -- mask )
  24     [ HEX: ff ] dip shift ; foldable
  25
  26 PRIVATE>
  27
  28 MACRO: byte-reverse ( n signed? -- quot )
  29     [
  30         drop
  31         [
  32             dup iota [
  33                 [ 1 + - -8 * ] [ nip 8 * ] 2bi
  34                 [ + ] [ nip byte-mask ] 2bi
  35                 '[ _ shift _ bitand ]
  36             ] with map
  37         ] [ 1 - [ bitor ] n*quot ] bi
  38     ] [
  39         [ convert-signed-quot ] [ drop [ ] ] if
  40     ] 2bi
  41     '[ _ cleave @ @ ] ;
  42
  43 SYMBOLS: le8 be8 ule8 ube8
  44 ule16 ule32 ule64 ube16 ube32 ube64
  45 le16 le32 le64 be16 be32 be64 ;
  46
  47 : endian-c-type? ( symbol -- ? )
  48     {
  49         le8 be8 ule8 ube8 ule16 ule32 ule64
  50         ube16 ube32 ube64 le16 le32 le64 be16 be32 be64
  51     } member? ;
  52
  53 ERROR: unknown-endian-c-type symbol ;
  54
  55 : endian-c-type>c-type-symbol ( symbol -- symbol' )
  56     {
  57         { [ dup { ule16 ube16 } member? ] [ drop ushort ] }
  58         { [ dup { le16 be16 } member? ] [ drop ac:short ] }
  59         { [ dup { ule32 ube32 } member? ] [ drop uint ] }
  60         { [ dup { le32 be32 } member? ] [ drop int ] }
  61         { [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
  62         { [ dup { le64 be64 } member? ] [ drop longlong ] }
  63         [ unknown-endian-c-type ]
  64     } cond ;
  65
  66 : change-c-type-accessors ( n ? c-type -- c-type' )
  67     endian-c-type>c-type-symbol "c-type" word-prop clone
  68     -rot
  69     [ '[ [ _ _ byte-reverse ] compose ] change-getter drop ]
  70     [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi ;
  71
  72 : typedef-endian ( n ? c-type endian -- )
  73     native-endianness get = [
  74         2nip [ endian-c-type>c-type-symbol ] keep typedef
  75     ] [
  76         [ change-c-type-accessors ] keep typedef
  77     ] if ;
  78
  79 : typedef-le ( n ? c-type -- ) little-endian typedef-endian ;
  80 : typedef-be ( n ? c-type -- ) big-endian typedef-endian ;
  81
  82 [
  83     \ char \ le8 typedef
  84     \ char \ be8 typedef
  85     \ uchar \ ule8 typedef
  86     \ uchar \ ube8 typedef
  87     2 f \ ule16 typedef-le
  88     2 f \ ube16 typedef-be
  89     2 t \ le16 typedef-le
  90     2 t \ be16 typedef-be
  91     4 f \ ule32 typedef-le
  92     4 f \ ube32 typedef-be
  93     4 t \ le32 typedef-le
  94     4 t \ be32 typedef-be
  95     8 f \ ule64 typedef-le
  96     8 f \ ube64 typedef-be
  97     8 t \ le64 typedef-le
  98     8 t \ be64 typedef-be
  99 ] with-compilation-unit
 100
 101 ! pair: { le be }
 102 : pair>c-type ( pair -- c-type )
 103     [ native-endianness get big-endian = ] dip first2 ? ;
 104
 105 ! endian is desired endian type. if we match endianness, return the c type
 106 ! otherwise return the opposite of our endianness
 107 : endian-slot ( endian c-type pair -- endian-slot )
 108     [ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ;
 109
 110 ERROR: unsupported-endian-type endian slot ;
 111
 112 : slot>endian-slot ( endian slot -- endian-slot )
 113     dup array? [
 114         first2 [ slot>endian-slot ] dip 2array
 115     ] [
 116         {
 117             { [ dup char = ] [ 2drop char ] }
 118             { [ dup uchar = ] [ 2drop uchar ] }
 119             { [ dup ac:short = ] [ { le16 be16 } endian-slot ] }
 120             { [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
 121             { [ dup int = ] [ { le32 be32 } endian-slot ] }
 122             { [ dup uint = ] [ { ule32 ube32 } endian-slot ] }
 123             { [ dup longlong = ] [ { le64 be64 } endian-slot ] }
 124             { [ dup ulonglong = ] [ { ule64 ube64 } endian-slot ] }
 125             { [ dup endian-c-type? ] [ nip ] }
 126             [ unsupported-endian-type ]
 127         } cond
 128     ] if ;
 129
 130 : set-endian-slots ( endian slots -- slot-specs )
 131     [ [ slot>endian-slot ] change-type ] with map ;
 132
 133 : define-endian-struct-class ( class slots endian -- )
 134     swap make-slots set-endian-slots
 135     [ compute-struct-offsets ] [ struct-alignment ]
 136     (define-struct-class) ;
 137
 138 : define-endian-packed-struct-class ( class slots endian -- )
 139     swap make-packed-slots set-endian-slots
 140     [ compute-struct-offsets ] [ drop 1 ]
 141     (define-struct-class) ;
 142
 143 SYNTAX: LE-STRUCT:
 144     parse-struct-definition
 145     little-endian define-endian-struct-class ;
 146
 147 SYNTAX: BE-STRUCT:
 148     parse-struct-definition
 149     big-endian define-endian-struct-class ;
 150
 151 SYNTAX: LE-PACKED-STRUCT:
 152     parse-struct-definition
 153     little-endian define-endian-packed-struct-class ;
 154
 155 SYNTAX: BE-PACKED-STRUCT:
 156     parse-struct-definition
 157     big-endian define-endian-packed-struct-class ;
 158