;;;;
;;;; test-srfi.stk	-- Test of various SRFIs
;;;;
;;;; Copyright © 2005-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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@essi.fr]
;;;;    Creation date:  4-Aug-2005 10:34 (eg)
;;;; Last file update:  5-Apr-2010 00:29 (eg)
;;;;

(require "test")

(test-section "SRFIs")

;; ----------------------------------------------------------------------
;; 	SRFI 62 ...
;; ----------------------------------------------------------------------
(test-subsection "SRFI 62 - S-expression comments")

(test "srfi-62.1" 5 (+ 1 #;(* 2 3) 4))
(test "srfi-62.2" '(x z) (list 'x #;'y 'z))
(test "srfi-62.3" 12 (* 3 4 #;(+ 1 2)))
(test "srfi-62.4" 16 (#;sqrt abs -16))

(test "srfi-62.5" '(a e) (list 'a #;(list 'b #;c 'd) 'e))
(test "srfi-62.6" '(a . c) '(a . #;b c))
(test "srfi-62.7" '(a . b) '(a . b #;c))

;; ----------------------------------------------------------------------
;; 	SRFI 71 ...
;; ----------------------------------------------------------------------
(test-subsection "SRFI 70 - Numbers")

(test "complex?" #t (complex? +inf.0))
(test "real?" #t (real? -inf.0))
(test "rational?" #f (rational? +inf.0))
(test "integer?" #f (integer? -inf.0))

(test "inexact?" #t (inexact? +inf.0))

(test "=.1" #t (= +inf.0 +inf.0))
(test "=.2" #f (= -inf.0 +inf.0))
(test "=.3" #t (= -inf.0 -inf.0))

(test "positive?" #t (positive? +inf.0))
(test "negative?" #t (negative? -inf.0))
(test "finite?" #f (finite? -inf.0))
(test "infinite?" #t (infinite? +inf.0))

(test "max.1" +inf.0 (max 12 +inf.0))
(test "max.2" +inf.0 (max 12.0 +inf.0))
(test "max.3" +inf.0 (max -inf.0 +inf.0))
(test "min.1" -inf.0 (min 12 -inf.0))
(test "min.2" -inf.0 (min 12.0 -inf.0))
(test "min.3" -inf.0 (min -inf.0 +inf.0))

(test "+.1" +inf.0 (+ +inf.0 +inf.0))
(test "+.2" +nan.0 (+ +inf.0 -inf.0))

(test "*.1" +inf.0 (* 5 +inf.0))
(test "*.2" -inf.0 (* -5 +inf.0))
(test "*.3" +inf.0 (* +inf.0 +inf.0))
(test "*.4" -inf.0 (* +inf.0 -inf.0))
(test "*.5" +nan.0 (* 0 +inf.0))

(test "-" +nan.0 (- +inf.0 +inf.0))


(test "/.1" +inf.0 (/ 0.0))
(test "/.2" +inf.0 (/ 1.0 0))
(test "/.3" -inf.0 (/ -1 0.0))
(test "/.4" +nan.0 (/ 0 0.0))
(test "/.5" +nan.0 (/ 0.0 0))
(test "/.6" +nan.0 (/ 0.0 0.0))

(test "angle.1" #t (< (- (* 4 (atan 1))
			 (angle -inf.0))
		      0.00001))
(test "angle.2" 0.0 (angle +inf.0))

(test "string->number.1" +inf.0 (string->number "+inf.0"))
(test "string->number.2" -inf.0 (string->number "-inf.0"))
(test "number->string.1" "+inf.0" (number->string +inf.0))
(test "number->string.2" "-inf.0" (number->string -inf.0))

;; ----------------------------------------------------------------------
;; 	SRFI 74 ...
;; ----------------------------------------------------------------------
(test-subsection "SRFI 74 - BLOBs")

(require "srfi-74")

(define b1 (make-blob 16))

(test "blob-length" 16 (blob-length b1))

(blob-u8-set! b1 0 223)
(blob-s8-set! b1 1 123)
(blob-s8-set! b1 2 -123)
(blob-u8-set! b1 3 15)

(test "blob repr"
      '(223 123 123 -123 133 15)
      (list (blob-u8-ref b1 0)
	    (blob-s8-ref b1 1)
	    (blob-u8-ref b1 1)
	    (blob-s8-ref b1 2)
	    (blob-u8-ref b1 2)
	    (blob-u8-ref b1 3)))

(blob-uint-set! 16 (endianness little) b1 0 (- (expt 2 128) 3))
(test "blob-uint-ref.1"
      (- (expt 2 128) 3)
      (blob-uint-ref 16 (endianness little) b1 0))
(test "blob-uint-ref.2"
      -3
      (blob-sint-ref 16 (endianness little) b1 0))

(test "blob->u8-list"
      '(253 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255)
      (blob->u8-list b1))

(blob-uint-set! 16 (endianness big) b1 0 (- (expt 2 128) 3))

(test "blob-uint-ref.3"
      (- (expt 2 128) 3)
      (blob-uint-ref 16 (endianness big) b1 0))

(test "blob-sint-ref"
      -3
      (blob-sint-ref 16 (endianness big) b1 0))

(test "blob->u8-list"
      '(255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 253)
      (blob->u8-list b1))

(test "blob-u16-ref"
      65023
      (blob-u16-ref (endianness little) b1 14))

(test "blob-s16-ref"
      -513
      (blob-s16-ref (endianness little) b1 14))

(test "blob-u16-ref"
      65533
      (blob-u16-ref (endianness big) b1 14))

(test "blob-s16-ref"
      -3
      (blob-s16-ref (endianness big) b1 14))


(blob-u16-set! (endianness little) b1 0 12345)
(blob-u16-native-set! b1 0 12345)

(test "blob-u16-native-ref"
      12345
      (blob-u16-native-ref b1 0))

(test "blob-u32-ref"
      4261412863
      (blob-u32-ref (endianness little) b1 12))
(test "blob-s32-ref"
      -33554433
      (blob-s32-ref (endianness little) b1 12))

(test "blob-u32-ref"
      4294967293
      (blob-u32-ref (endianness big) b1 12))
(test "blob-s32-ref"
      -3
      (blob-s32-ref(endianness big) b1 12))

(blob-u32-set! (endianness little) b1 0 12345)
(blob-u32-native-set! b1 0 12345)

(test "blob-u32-native-ref"
      12345
      (blob-u32-native-ref b1 0))
(test "blob-u64-ref"
      18302628885633695743
       (blob-u64-ref (endianness little) b1 8))
(test "(blob-s64-ref (endianness little) b1 8)"
      -144115188075855873
      (blob-s64-ref (endianness little) b1 8))
(test "(blob-u64-ref (endianness big) b1 8)"
      18446744073709551613
      (blob-u64-ref (endianness big) b1 8))
(test "(blob-s64-ref (endianness big) b1 8)"
      -3
      (blob-s64-ref (endianness big) b1 8))

(blob-u64-set! (endianness little) b1 0 12345)
(blob-u64-native-set! b1 0 12345)

(test "(blob-u64-native-ref b1 0)"
      12345
      (blob-u64-native-ref b1 0))

(define b2 (u8-list->blob '(1 2 3 4 5 6 7 8)))
(define b3 (blob-copy b2))

(test "(blob=? b2 b3)"
      #t
      (blob=? b2 b3))
(test "(blob=? b1 b2)"
      #f
      (blob=? b1 b2))

(blob-copy! b3 0 b3 4 4)
(test "(blob->u8-list b3)"
      '(1 2 3 4 1 2 3 4)
      (blob->u8-list b3))

(blob-copy! b3 0 b3 2 6)
(test "(blob->u8-list b3)"
      '(1 2 1 2 3 4 1 2)
      (blob->u8-list b3))

(blob-copy! b3 2 b3 0 6)
(test "(blob->u8-list b3)"
      '(1 2 3 4 1 2 1 2)
      (blob->u8-list b3))
(test "(blob->uint-list 1 (endianness little) b3)"
      '(1 2 3 4 1 2 1 2)
      (blob->uint-list 1 (endianness little) b3))
(test "(blob->uint-list 2 (endianness little) b3)"
      '(513 1027 513 513)
      (blob->uint-list 2 (endianness little) b3))

(define b4 (u8-list->blob '(0 0 0 0 0 0 48 57 255 255 255 255 255 255 255 253)))

(test "(blob->sint-list 2 (endianness little) b4)"
      '(0 0 0 14640 -1 -1 -1 -513)
      (blob->sint-list 2 (endianness little) b4))

;; ----------------------------------------------------------------------
(test-section-end)