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 math.bitwise ;
   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 MACRO: byte-reverse ( n signed? -- quot )
  22     [
  23         drop
  24         [
  25             dup iota [
  26                 [ 1 + - -8 * ] [ nip 8 * ] 2bi
  27                 '[ _ shift 0xff bitand _ shift ]
  28             ] with map
  29         ] [ 1 - [ bitor ] n*quot ] bi
  30     ] [
  31         [ convert-signed-quot ] [ drop [ ] ] if
  32     ] 2bi
  33     '[ _ cleave @ @ ] ;
  34
  35 SYMBOLS: le8 be8 ule8 ube8
  36 ule16 ule32 ule64 ube16 ube32 ube64
  37 le16 le32 le64 be16 be32 be64 ;
  38
  39 : endian-c-type? ( symbol -- ? )
  40     {
  41         le8 be8 ule8 ube8 ule16 ule32 ule64
  42         ube16 ube32 ube64 le16 le32 le64 be16 be32 be64
  43     } member? ;
  44
  45 ERROR: unknown-endian-c-type symbol ;
  46
  47 : endian-c-type>c-type-symbol ( symbol -- symbol' )
  48     {
  49         { [ dup { ule16 ube16 } member? ] [ drop ushort ] }
  50         { [ dup { le16 be16 } member? ] [ drop ac:short ] }
  51         { [ dup { ule32 ube32 } member? ] [ drop uint ] }
  52         { [ dup { le32 be32 } member? ] [ drop int ] }
  53         { [ dup { ule64 ube64 } member? ] [ drop ulonglong ] }
  54         { [ dup { le64 be64 } member? ] [ drop longlong ] }
  55         [ unknown-endian-c-type ]
  56     } cond ;
  57
  58 : change-c-type-accessors ( n ? c-type -- c-type' )
  59     endian-c-type>c-type-symbol "c-type" word-prop clone
  60     -rot over 8 = [
  61         [
  62             nip
  63             [
  64                 [
  65                     [ alien-unsigned-4 4 f byte-reverse 32 shift ]
  66                     [ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor
  67                 ]
  68             ] dip [ [ 64 >signed ] compose ] when
  69             >>getter drop
  70         ]
  71         [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
  72     ] [
  73         [ '[ [ _ _ byte-reverse ] compose ] change-getter drop ]
  74         [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
  75     ] if ;
  76
  77 : typedef-endian ( n ? c-type endian -- )
  78     native-endianness get = [
  79         2nip [ endian-c-type>c-type-symbol ] keep typedef
  80     ] [
  81         [ change-c-type-accessors ] keep typedef
  82     ] if ;
  83
  84 : typedef-le ( n ? c-type -- ) little-endian typedef-endian ;
  85 : typedef-be ( n ? c-type -- ) big-endian typedef-endian ;
  86
  87 [
  88     \ char \ le8 typedef
  89     \ char \ be8 typedef
  90     \ uchar \ ule8 typedef
  91     \ uchar \ ube8 typedef
  92     2 f \ ule16 typedef-le
  93     2 f \ ube16 typedef-be
  94     2 t \ le16 typedef-le
  95     2 t \ be16 typedef-be
  96     4 f \ ule32 typedef-le
  97     4 f \ ube32 typedef-be
  98     4 t \ le32 typedef-le
  99     4 t \ be32 typedef-be
 100     8 f \ ule64 typedef-le
 101     8 f \ ube64 typedef-be
 102     8 t \ le64 typedef-le
 103     8 t \ be64 typedef-be
 104 ] with-compilation-unit
 105
 106 ! pair: { le be }
 107 : pair>c-type ( pair -- c-type )
 108     [ native-endianness get big-endian = ] dip first2 ? ;
 109
 110 ! endian is desired endian type. if we match endianness, return the c type
 111 ! otherwise return the opposite of our endianness
 112 : endian-slot ( endian c-type pair -- endian-slot )
 113     [ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ;
 114
 115 ERROR: unsupported-endian-type endian slot ;
 116
 117 : slot>endian-slot ( endian slot -- endian-slot )
 118     dup array? [
 119         first2 [ slot>endian-slot ] dip 2array
 120     ] [
 121         {
 122             { [ dup char = ] [ 2drop char ] }
 123             { [ dup uchar = ] [ 2drop uchar ] }
 124             { [ dup ac:short = ] [ { le16 be16 } endian-slot ] }
 125             { [ dup ushort = ] [ { ule16 ube16 } endian-slot ] }
 126             { [ dup int = ] [ { le32 be32 } endian-slot ] }
 127             { [ dup uint = ] [ { ule32 ube32 } endian-slot ] }
 128             { [ dup longlong = ] [ { le64 be64 } endian-slot ] }
 129             { [ dup ulonglong = ] [ { ule64 ube64 } endian-slot ] }
 130             { [ dup endian-c-type? ] [ nip ] }
 131             [ unsupported-endian-type ]
 132         } cond
 133     ] if ;
 134
 135 : set-endian-slots ( endian slots -- slot-specs )
 136     [ [ slot>endian-slot ] change-type ] with map ;
 137
 138 : define-endian-struct-class ( class slots endian -- )
 139     swap make-slots set-endian-slots
 140     [ compute-struct-offsets ] [ struct-alignment ]
 141     (define-struct-class) ;
 142
 143 : define-endian-packed-struct-class ( class slots endian -- )
 144     swap make-packed-slots set-endian-slots
 145     [ compute-struct-offsets ] [ drop 1 ]
 146     (define-struct-class) ;
 147
 148 SYNTAX: LE-STRUCT:
 149     parse-struct-definition
 150     little-endian define-endian-struct-class ;
 151
 152 SYNTAX: BE-STRUCT:
 153     parse-struct-definition
 154     big-endian define-endian-struct-class ;
 155
 156 SYNTAX: LE-PACKED-STRUCT:
 157     parse-struct-definition
 158     little-endian define-endian-packed-struct-class ;
 159
 160 SYNTAX: BE-PACKED-STRUCT:
 161     parse-struct-definition
 162     big-endian define-endian-packed-struct-class ;
 163