From 248790aca5d5b6dc9a8edeea1abed0195ac1338e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?IOhannes=20m=20zm=C3=B6lnig?=
 <zmoelnig@umlautQ.umlaeute.mur.at>
Date: Tue, 17 May 2016 12:21:04 +0200
Subject: Imported Upstream version 16.5~dfsg

---
 binary-io.scm | 52 ++++++++++++++++++++++++----------------------------
 1 file changed, 24 insertions(+), 28 deletions(-)

(limited to 'binary-io.scm')

diff --git a/binary-io.scm b/binary-io.scm
index 07697b1..b5ce723 100644
--- a/binary-io.scm
+++ b/binary-io.scm
@@ -14,11 +14,12 @@
     (do ((c (read-byte) (read-byte)))
 	((or (eof-object? c)
 	     (= c 0))
-	 (apply string (reverse chars)))
+	 (reverse (apply string chars)))
       (set! chars (cons (integer->char c) chars)))))
 
 (define (io-write-string str)
-  (for-each write-char str) ; or maybe (lambda (c) (write-byte (char->integer c)))
+  (format () "~{~A~}" str)
+  ;(for-each write-char str)
   (write-byte 0))
 
 
@@ -31,7 +32,8 @@
       (set! (str i) (read-char)))))
 	 
 (define (write-chars str)
-  (for-each write-char str))
+  (format () "~{~A~}" str))
+;  (for-each write-char str))
 
 
 ;;; -------- 16-bit ints
@@ -72,16 +74,15 @@
       int)))
 
 (define (write-bint32 int)
-  (write-byte (logand (ash int -24) #xff))
-  (write-byte (logand (ash int -16) #xff))
-  (write-byte (logand (ash int -8) #xff))
-  (write-byte (logand int #xff)))
-
+  (for-each write-byte (vector (logand (ash int -24) 255) 
+			       (logand (ash int -16) 255) 
+			       (logand (ash int -8) 255) 
+			       (logand int 255))))
 (define (write-lint32 int)
-  (write-byte (logand int #xff))
-  (write-byte (logand (ash int -8) #xff))
-  (write-byte (logand (ash int -16) #xff))
-  (write-byte (logand (ash int -24) #xff)))
+  (for-each write-byte (vector (logand int 255) 
+			       (logand (ash int -8) 255) 
+			       (logand (ash int -16) 255) 
+			       (logand (ash int -24) 255))))
 
 
 ;;; -------- 64-bit ints
@@ -135,7 +136,7 @@
 	;; we're assuming floats are (64-bit) doubles in s7, so this is coercing to a 32-bit float in a sense
 	;;   this causes some round-off error
 	(logior (if (negative? sign) #x80000000 0)
-		(ash (+ expon 52 127) 23)
+		(ash (+ expon 179) 23)   ; 179 = (+ 52 127)
 		(logand (ash signif -29) #x7fffff)))))
 
 (define (write-bfloat32 flt)
@@ -170,7 +171,7 @@
     (if (= expon signif 0)
 	0
 	(logior (if (negative? sign) #x8000000000000000 0)
-		(ash (+ expon 52 1023) 52)
+		(ash (+ expon 1075) 52) ; 1075 = (+ 52 1023)
 		(logand signif #xfffffffffffff)))))
 
 (define (write-bfloat64 flt)
@@ -216,7 +217,7 @@
     (if (not (zero? val))
 	(begin
 	  (set! exp (round (+ (log val 2.0) 16383.0)))
-	  (set! val (* val (expt 2 (- (+ 16383 31) exp))))
+	  (set! val (* val (expt 2 (- 16414 exp)))) ; 16414 = (+ 16383 31)
 	  (set! mant1 (floor val))
 	  (set! val (- val mant1))
 	  (set! mant0 (floor (* val (expt 2 32))))))
@@ -241,12 +242,12 @@
       (let ((magic (read-chars 4)))
 	(if (not (string=? magic ".snd"))
 	    (error 'bad-header "~A is not an au file: ~A" file)
-	    (let ((data-location (read-bint32))
-		  (data-size (read-bint32))
-		  (sample-type (read-bint32))
-		  (srate (read-bint32))
-		  (chns (read-bint32))
-		  (comment (io-read-string)))
+	    (let* ((data-location (read-bint32))
+		   (data-size (read-bint32))
+		   (sample-type (read-bint32))
+		   (srate (read-bint32))
+		   (chns (read-bint32))
+		   (comment (io-read-string)))
 	      (list magic data-location data-size sample-type srate chns comment)))))))
 
 (define (write-au-header file chns srate data-size sample-type comment) ; data-size in bytes
@@ -257,11 +258,7 @@
 	     (data-location (+ 24 (* 4 (floor (+ 1 (/ comlen 4))))))
 	     (curloc 24))
 	(write-chars ".snd")
-	(write-bint32 data-location)
-	(write-bint32 data-size)
-	(write-bint32 sample-type)
-	(write-bint32 srate)
-	(write-bint32 chns)
+	(for-each write-bint32 (vector data-location data-size sample-type srate chns))
 	(if (> comlen 0)
 	    (begin
 	      (io-write-string comment)
@@ -286,8 +283,7 @@
 	      (let (;(size (read-bint32))
 		    (magic (read-chars 4)))
 		(set! current-location 12)
-		(if (and (not (string=? magic "AIFF"))
-			 (not (string=? magic "AIFC")))
+		(if (not (member magic '("AIFF" "AIFC") string=?))
 		    (error 'bad-header "~A is not an aif file: ~A" file magic)
 		    ;; now look for the "SSND" and "COMM" chunks
 		    (call-with-exit
-- 
cgit v1.2.3