extra/leb128/leb128.factor

   1 ! Copyright (C) 2023 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: byte-arrays byte-vectors combinators hints io kernel math
   5 math.bitwise namespaces sequences typed ;
   6
   7 IN: leb128
   8
   9 ! Unsigned LEB128
  10
  11 <PRIVATE
  12
  13 :: (write-uleb128) ( n quot: ( b -- ) -- )
  14     n assert-non-negative [
  15         [ -7 shift dup 0 = not ] [ 7 bits ] bi
  16         over [ 0x80 bitor ] when quot call
  17     ] loop drop ; inline
  18
  19 HINTS: (write-uleb128) { fixnum object } ;
  20
  21 PRIVATE>
  22
  23 TYPED: stream-write-uleb128 ( n: integer stream -- )
  24     '[ _ stream-write1 ] (write-uleb128) ; inline
  25
  26 : write-uleb128 ( n -- )
  27     output-stream get stream-write-uleb128 ;
  28
  29 TYPED: >uleb128 ( n: integer -- byte-array )
  30     16 <byte-vector> [ '[ _ push ] (write-uleb128) ] keep B{ } like ;
  31
  32 :: stream-read-uleb128 ( stream -- n )
  33     0 0 [
  34         stream stream-read1 :> ( i b )
  35         b 0x7f bitand i 7 * shift +
  36         i 1 + b 7 bit?
  37     ] loop drop ;
  38
  39 : read-uleb128 ( -- n )
  40     input-stream get stream-read-uleb128 ;
  41
  42 TYPED: uleb128> ( byte-array: byte-array -- n )
  43     0 [ [ 0x7f bitand ] [ 7 * shift ] bi* + ] reduce-index ;
  44
  45 ! Signed LEB128
  46
  47 <PRIVATE
  48
  49 :: (write-leb128) ( n quot: ( b -- ) -- )
  50     n [
  51         [ -7 shift dup ] [ 0x7f bitand ] bi :> ( i b )
  52         {
  53             { [ i  0 = ] [ b 6 bit? not ] }
  54             { [ i -1 = ] [ b 6 bit? ] }
  55             [ f ]
  56         } cond [ f b ] [ t b 0x80 bitor ] if quot call
  57     ] loop drop ; inline
  58
  59 HINTS: (write-leb128) { fixnum object } ;
  60
  61 PRIVATE>
  62
  63 TYPED: stream-write-leb128 ( n: integer stream -- )
  64     '[ _ stream-write1 ] (write-leb128) ;
  65
  66 : write-leb128 ( n -- )
  67     output-stream get stream-write-leb128 ;
  68
  69 TYPED: >leb128 ( n: integer -- byte-array )
  70     16 <byte-vector> [ '[ _ push ] (write-leb128) ] keep B{ } like ;
  71
  72 :: stream-read-leb128 ( stream -- n )
  73     0 0 [
  74         stream stream-read1 :> ( i b )
  75         b 0x7f bitand i 7 * shift +
  76         i 1 + b 7 bit? dup [
  77             b 6 bit? [
  78                 [ [ 7 * 2^ neg bitor ] keep ] dip
  79             ] when
  80         ] unless
  81     ] loop drop ;
  82
  83 : read-leb128 ( -- n )
  84     input-stream get stream-read-leb128 ;
  85
  86 TYPED: leb128> ( byte-array: byte-array -- n )
  87     [ uleb128> ] keep dup last 6 bit?
  88     [ length 7 * 2^ neg bitor ] [ drop ] if ;