;;;;
;;;; srfi-4.stk	-- Implementation of SRFI-4 (Uniform Vectors)
;;;;
;;;; Copyright © 2001-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; 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)
;;;; Last file update: 19-Aug-2011 11:03 (eg)
;;;;


;; 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


(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)) 0.0 0)))
    `(begin
       ;; (TAGvector? obj)
       (define (,pred obj)
	 (%uvector? ,type obj))

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

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

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

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

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

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

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

(%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)


(provide "srfi-4")

; LocalWords:  UVECT TAGvalue TAGvector Avector TAGvect TAGlist