;;;;
;;;; srfi-4.stk	-- Implementation of SRFI-4 (Uniform Vectors)
;;;;
;;;; Copyright © 2001-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 15-Apr-2001 11:36 (eg)
;;;;


(define-module srfi/4

  (export s8vector? make-s8vector s8vector s8vector-length s8vector-ref
          s8vector-set! s8vector->list list->s8vector

          u8vector? make-u8vector u8vector u8vector-length u8vector-ref
          u8vector-set! u8vector->list list->u8vector

          s16vector? make-s16vector s16vector s16vector-length s16vector-ref
          s16vector-set! s16vector->list list->s16vector

          u16vector? make-u16vector u16vector u16vector-length u16vector-ref
          u16vector-set! u16vector->list list->u16vector

          s32vector? make-s32vector s32vector s32vector-length s32vector-ref
          s32vector-set! s32vector->list list->s32vector

          u32vector? make-u32vector u32vector u32vector-length u32vector-ref
          u32vector-set! u32vector->list list->u32vector

          s64vector? make-s64vector s64vector s64vector-length s64vector-ref
          s64vector-set! s64vector->list list->s64vector

          u64vector?  make-u64vector u64vector u64vector-length u64vector-ref
          u64vector-set! u64vector->list list->u64vector

          f32vector?  make-f32vector f32vector f32vector-length f32vector-ref
          f32vector-set! f32vector->list list->f32vector

          f64vector?  make-f64vector f64vector f64vector-length f64vector-ref
          f64vector-set! f64vector->list list->f64vector

          c64vector?  make-c64vector c64vector c64vector-length c64vector-ref
          c64vector-set! c64vector->list list->c64vector

          c128vector?  make-c128vector c128vector c128vector-length c128vector-ref
          c128vector-set! c128vector->list list->c128vector

          ;; STklos extensions
          uvector? uvector-length uvector-ref uvector-set! uvector->list
          )


;; Following two definitions have been added here to avoid compilation warnings


;; This implementation is built on the uniform layer present in the file
;; src/uvector.c. Nearly everything is written in Scheme


;; Internal coding (don't change it without modifying file uvector.c
;;  UVECT_S8    0
;;  UVECT_U8    1
;;  UVECT_S16   2
;;  UVECT_U16   3
;;  UVECT_S32   4
;;  UVECT_U32   5
;;  UVECT_U64   6
;;  UVECT_S64   7
;;
;;  UVECT_F32   8
;;  UVECT_F64   9

;; NOTE: SRFI 160 also defines
;; UVECT_C64    10
;; UVECT_C128   11
;; See lib/srfi/160/base.stk
;; --jpellegrini


;; Avoid warnings

  (%compile-time-define %list->uvector %uvector->list)

(define-macro (%uniform-vector-functions tag type)
  (let ((pred   (string->symbol (format #f "~Avector?" tag)))
        (make   (string->symbol (format #f "make-~Avector" tag)))
        (constr (string->symbol (format #f "~Avector" tag)))
        (len    (string->symbol (format #f "~Avector-length" tag)))
        (ref    (string->symbol (format #f "~Avector-ref" tag)))
        (set    (string->symbol (format #f "~Avector-set!" tag)))
        (v->l   (string->symbol (format #f "~Avector->list" tag)))
        (l->v   (string->symbol (format #f "list->~Avector" tag)))
        (dfl    (if (memv tag '(f32 f64 c64 c128)) 0.0 0)))
    `(begin
       ;; (TAGvector? obj)
       (define (,pred obj)
         (%uvector? obj ,type))

       ;; (make-TAGvector n [ TAGvalue ])
       (define (,make size :optional (default ,dfl))
         (%make-uvector size default ,type))

       ;; (TAGvector TAGvalue...)
       (define (,constr . l)
         (%uvector l ,type))

       ;; (TAGvector-length TAGvect)
       (define (,len vect)
         (%uvector-length vect ,type))

       ;; (TAGvector-ref TAGvect i)
       (define (,ref vect i)
         (%uvector-ref vect i ,type))

       ;; (TAGvector-set! TAGvect i TAGvalue)
       (define (,set vect i val)
         (%uvector-set! vect i val ,type))

       ;; (set! (setter TAGvector-ref) TAGvector-set!)
       (set! (setter ,ref) ,set)

       ;; (TAGvector->list TAGvect)
       (define (,v->l vect)
         (%uvector->list vect ,type))

       ;; (list->TAGvector TAGlist)
       (define (,l->v lst)
         (%list->uvector lst ,type)))))

(%allow-uvectors)

(%uniform-vector-functions s8  0)
(%uniform-vector-functions u8  1)

(%uniform-vector-functions s16 2)
(%uniform-vector-functions u16 3)

(%uniform-vector-functions s32 4)
(%uniform-vector-functions u32 5)

(%uniform-vector-functions s64 6)
(%uniform-vector-functions u64 7)

(%uniform-vector-functions f32 8)
(%uniform-vector-functions f64 9)

(%uniform-vector-functions c64  10)
(%uniform-vector-functions c128 11)

#|
<doc EXT uvector? uvector-length uvector-ref uvector-set! uvector->list uvector-tag
 * (uvector? uv)
 * (uvector-length uv)
 * (uvector-ref uv k)
 * (uvector-set! uv k val)
 * (uvector->list uv)
 * (uvector-tag uv)
 *
 * These primitives extend {{quick-link-srfi 4}}. They can be called with any type
 * of uniform (homogeneous) vector.  The primitive |uvector-tag| returns the tag
 * of the uniform vector, as a symbol
 * @lisp
 * (uvector? #s16(-1 2 3))    => #t
 * (uvector-length #u32(1 2)) => 2
 * (uvector-length #s64(1 2)) => 2
 * (uvector-tag #u8(1 2 3))   => u8
 * (uvector-tag #c32())       => c32
 * @end lisp
doc>
|#
(define (uvector? uv)           (%uvector? uv))
(define (uvector-length uv)     (%uvector-length uv))
(define (uvector-ref uv k)      (%uvector-ref uv k))
(define (uvector-set! uv k val) (%uvector-set! uv k val))
(define (uvector->list uv)      (%uvector->list uv))
;; uvector-tag is implemented in C


) ;; End of module

(provide "srfi/4")

; LocalWords:  UVECT TAGvalue TAGvector Avector TAGvect TAGlist
