Guile-hoot/lib/hoot/bytevectors.scm

;;; Bytevectors
;;; Copyright (C) 2024 Igalia, S.L.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Bytevectors.
;;;
;;; Code:

(library (hoot bytevectors)
  (export make-bytevector
          bytevector-length
          bytevector-u8-ref
          bytevector-u8-set!
          bytevector-s8-ref
          bytevector-s8-set!
          bytevector-u16-native-ref
          bytevector-u16-native-set!
          bytevector-s16-native-ref
          bytevector-s16-native-set!
          bytevector-u32-native-ref
          bytevector-u32-native-set!
          bytevector-s32-native-ref
          bytevector-s32-native-set!
          bytevector-u64-native-ref
          bytevector-u64-native-set!
          bytevector-s64-native-ref
          bytevector-s64-native-set!
          bytevector-ieee-single-native-ref
          bytevector-ieee-single-native-set!
          bytevector-ieee-double-native-ref
          bytevector-ieee-double-native-set!
          bytevector?
          bytevector
          bytevector-concatenate
          bytevector-concatenate-reverse
          bytevector-append
          bytevector-copy
          bytevector-copy!)
  (import (rename (hoot primitives)
                  (%< <)
                  (%- -)
                  (%+ +)
                  (%null? null?)
                  (%car car)
                  (%cdr cdr))
    (hoot errors)
    (hoot match)
    (hoot bitwise))

  (define (1- x) (- x 1))
  (define (1+ x) (+ x 1))

  (define (bytevector? x) (%bytevector? x))
  (define (bytevector-length bv) (%bytevector-length bv))

  (define* (make-bytevector len #:optional (init 0))
    (check-size len (1- (ash 1 29)) 'make-bytevector)
    (check-range init -128 255 'make-bytevector)
    (%inline-wasm
     '(func (param $len i32) (param $init i32)
            (result (ref eq))
            (struct.new
             $mutable-bytevector
             (i32.const 0)
             (array.new $raw-bytevector (local.get $init) (local.get $len))))
     len init))

  (define (bytevector-u8-ref bv i)     (%bytevector-u8-ref bv i))
  (define (bytevector-u8-set! bv i x)  (%bytevector-u8-set! bv i x))
  (define (bytevector-s8-ref bv i)     (%bytevector-s8-ref bv i))
  (define (bytevector-s8-set! bv i x)  (%bytevector-s8-set! bv i x))
  (define (bytevector-u16-native-ref bv i)    (%bytevector-u16-native-ref bv i))
  (define (bytevector-u16-native-set! bv i x) (%bytevector-u16-native-set! bv i x))
  (define (bytevector-s16-native-ref bv i)    (%bytevector-s16-native-ref bv i))
  (define (bytevector-s16-native-set! bv i x) (%bytevector-s16-native-set! bv i x))
  (define (bytevector-u32-native-ref bv i)    (%bytevector-u32-native-ref bv i))
  (define (bytevector-u32-native-set! bv i x) (%bytevector-u32-native-set! bv i x))
  (define (bytevector-s32-native-ref bv i)    (%bytevector-s32-native-ref bv i))
  (define (bytevector-s32-native-set! bv i x) (%bytevector-s32-native-set! bv i x))
  (define (bytevector-u64-native-ref bv i)    (%bytevector-u64-native-ref bv i))
  (define (bytevector-u64-native-set! bv i x) (%bytevector-u64-native-set! bv i x))
  (define (bytevector-s64-native-ref bv i)    (%bytevector-s64-native-ref bv i))
  (define (bytevector-s64-native-set! bv i x) (%bytevector-s64-native-set! bv i x))
  (define (bytevector-ieee-single-native-ref bv i)    (%bytevector-ieee-single-native-ref bv i))
  (define (bytevector-ieee-single-native-set! bv i x) (%bytevector-ieee-single-native-set! bv i x))
  (define (bytevector-ieee-double-native-ref bv i)    (%bytevector-ieee-double-native-ref bv i))
  (define (bytevector-ieee-double-native-set! bv i x) (%bytevector-ieee-double-native-set! bv i x))

  (define (bytevector . inits)
    (define (length l)
      (let lp ((len 0) (l l))
        (if (null? l) len (lp (+ len 1) (cdr l)))))
    (let* ((len (length inits))
           (bv (make-bytevector len)))
      (let lp ((i 0) (inits inits))
        (when (< i len)
          (bytevector-u8-set! bv i (car inits))
          (lp (1+ i) (cdr inits))))
      bv))

  (define (bytevector-length* bv*)
    (let lp ((bv* bv*) (len 0))
      (match bv*
        (() len)
        ((bv . bv*) (lp bv* (+ len (bytevector-length bv)))))))

  (define (bytevector-concatenate bv*)
    (match bv*
      (() #vu8())
      ((bv) bv)
      (bv*
       (let* ((len (bytevector-length* bv*))
              (flattened (make-bytevector len 0)))
         (let lp ((bv* bv*) (cur 0))
           (match bv*
             (() flattened)
             ((bv . bv*)
              (bytevector-copy! flattened cur bv)
              (lp bv* (+ cur (bytevector-length bv))))))))))

  (define (bytevector-concatenate-reverse bv*)
    (match bv*
      (() #vu8())
      ((bv) bv)
      (bv*
       (let* ((len (bytevector-length* bv*))
              (flattened (make-bytevector len 0)))
         (let lp ((bv* bv*) (cur len))
           (match bv*
             (() flattened)
             ((bv . bv*)
              (let ((cur (- cur (bytevector-length bv))))
                (bytevector-copy! flattened cur bv)
                (lp bv* cur)))))))))

  (define (bytevector-append . args)
    (bytevector-concatenate args))

  (define* (bytevector-copy x #:optional (start 0) (end (bytevector-length x)))
    (check-type x bytevector? 'bytevector-copy)
    (check-range start 0 (bytevector-length x) 'bytevector-copy)
    (check-range end start (bytevector-length x) 'bytevector-copy)
    (%inline-wasm
     '(func (param $src (ref $bytevector)) (param $start i32) (param $end i32)
            (result (ref eq))
            (local $i0 i32)
            (local $vu0 (ref $raw-bytevector))
            (local.set $i0 (i32.sub (local.get $end) (local.get $start)))
            (local.set $vu0 (array.new_default $raw-bytevector (local.get $i0)))
            (array.copy $raw-bytevector $raw-bytevector
                        (local.get $vu0) (i32.const 0)
                        (struct.get $bytevector $vals (local.get $src))
                        (local.get $start) (local.get $i0))
            (struct.new $bytevector (i32.const 0) (local.get $vu0)))
     x start end))

  (define* (bytevector-copy! to at from #:optional
                             (start 0) (end (bytevector-length from)))
    ;; FIXME: check that `to` is mutable
    (check-type to bytevector? 'bytevector-copy!)
    (check-range at 0 (bytevector-length to) 'bytevector-copy!)
    (check-type from bytevector? 'bytevector-copy!)
    (check-range start 0 (bytevector-length from) 'bytevector-copy!)
    (check-range end start (bytevector-length from) 'bytevector-copy!)
    (%inline-wasm
     '(func (param $to (ref $mutable-bytevector)) (param $at i32)
            (param $from (ref $bytevector)) (param $start i32) (param $end i32)
            (array.copy $raw-bytevector $raw-bytevector
                        (struct.get $mutable-bytevector $vals (local.get $to))
                        (local.get $at)
                        (struct.get $bytevector $vals (local.get $from))
                        (local.get $start)
                        (i32.sub (local.get $end) (local.get $start))))
     to at from start end)))