source: project/release/4/mat5-lib/trunk/mat5-lib.scm @ 26979

Last change on this file since 26979 was 26979, checked in by Ivan Raikov, 9 years ago

mat5-lib: bug fix in MAT5:array->srfi-4-major when using column major order

File size: 78.7 KB
Line 
1;;
2;;
3;; Definitions and read/write routines for MAT 5.0 binary format.
4;;
5;; Copyright 2005, 2012 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22
23(module mat5-lib 
24
25
26        ( 
27         MAT5:data-type?                 
28
29         miINT8 miUINT8 miINT16 miUINT16 miINT32 miUINT32 
30         miSINGLE miDOUBLE miINT64 miUINT64 miMATRIX 
31         miCOMPRESSED miUTF8 miUTF16 miUTF32
32
33         make-MAT5:header MAT5:header?
34         MAT5:header-magic MAT5:header-text MAT5:header-subsys
35         MAT5:header-version MAT5:header-eport
36
37         make-MAT5:data-element MAT5:data-element?
38         MAT5:data-element-type MAT5:data-element-bytes MAT5:data-element-data 
39
40         MAT5:array? MAT5:object MAT5:structure MAT5:cell-array MAT5:sparse-array MAT5:num-array
41         MAT5:dimensions?
42         MAT5:numeric-type? 
43         MAT5:array-type? 
44
45         init-MAT5:cell MAT5:cell? MAT5:cell-data MAT5:cell-dims
46         vector->MAT5:cell
47         MAT5:cell-dims 
48         MAT5:cell-ref 
49         MAT5:cell-set!
50
51         MAT5:array-foldi
52         MAT5:array->srfi-4-vector
53
54         MAT5:read-header               
55         MAT5:read-data-element
56
57         MAT5:write-header
58         MAT5:write-data-element
59
60         MAT5:debug-level
61         )
62
63        (import scheme chicken)
64        (require-library srfi-1 srfi-13 srfi-14 data-structures extras posix)
65        (require-library endian-blob srfi-63)
66        (import (only srfi-1 first second third last list-tabulate filter every)
67                (only srfi-13 string-pad-right string-trim-right)
68                (only srfi-14 char-set char-set-union char-set:whitespace)
69                (only data-structures alist-ref string-intersperse)
70                (only extras fprintf sprintf)
71                (only posix file-write open-output-file* file-mkstemp)
72                (only srfi-63 
73                      A:floR64b A:floR32b A:floR16b
74                      A:fixZ64b A:fixZ32b A:fixZ16b A:fixZ8b 
75                      A:fixN64b A:fixN32b A:fixN16b A:fixN8b
76                      array? make-array array-dimensions array-ref array-set! )
77                (only endian-blob MSB LSB))
78        (require-extension srfi-4 datatype endian-port iset z3)
79
80
81;--------------------
82;  Message routines
83;
84;
85
86(define MAT5:debug-level (make-parameter 0))
87
88
89(define (MAT5:warning x . rest)
90  (let loop ((port (open-output-string)) (objs (cons x rest)))
91    (if (null? objs)
92        (begin
93          (newline port)
94          (print-error-message (get-output-string port) 
95                               (current-error-port) "MAT5 warning:"))
96        (begin (display (car objs) port)
97               (display " " port)
98               (loop port (cdr objs))))))
99
100
101(define (MAT5:error x . rest)
102  (let ((port (open-output-string)))
103    (if (endian-port? x)
104        (begin
105          (display "[" port)
106          (display (endian-port-filename x) port)
107          (display ":" port)
108          (display (endian-port-pos x) port)
109          (display "] " port)))
110    (let loop ((objs (if (endian-port? x) rest (cons x rest))))
111      (if (null? objs)
112          (begin
113            (newline port)
114            (error 'MAT5 (get-output-string port)))
115          (begin (display (car objs) port)
116                 (display " " port)
117                 (loop (cdr objs)))
118          ))
119    ))
120
121
122(define-syntax  MAT5:debug
123   (syntax-rules  ()
124      ((_ level x ...)
125       (if (>= (MAT5:debug-level) level)
126           (print (sprintf "MAT5[~A]: " level) x ...)))
127      ))
128
129
130;----------------------------------
131;  General-purpose utility routines
132;
133
134(define (byte-vector->zstring x)
135  (let ((ws  (char-set-union char-set:whitespace (char-set (integer->char 0))))
136        (s   (blob->string x)))
137    (string-trim-right s ws)))
138
139(define (natural? x) (and (integer? x) (positive? x)))
140
141(define (natural-list? x)
142  (and (list? x) (every natural? x)))
143
144(define (positive-or-zero? x) (and (integer? x) (or (zero? x) (positive? x))))
145
146(define (positive-or-zero-list? x)
147  (and (list? x) (every positive-or-zero? x)))
148
149
150(define (string-list? x)
151  (and (list? x) (every string? x)))
152
153
154
155
156
157; Procedure:
158; align-eport-pos:: ENDIAN-PORT -> UNDEFINED
159;
160; Set file position to 64-bit boundary. Returns the # bytes skipped
161;
162;   * eport    an endian port
163;
164(define (align-eport-pos eport)
165  (let* ((pos  (endian-port-pos eport))
166         (pos1  (let loop ((pos1 pos))
167                   (if (not (zero? (modulo pos1 8))) 
168                       (loop (+ pos1 1)) pos1))))
169    (endian-port-setpos eport pos1)
170    (- pos1 pos)))
171
172
173
174;-------------------------------------
175;  MAT-File constants
176;
177
178(define MAT5:header-text-size    116)
179(define MAT5:header-subsys-size    8)
180
181
182; Version and magic numbers
183(define MAT5:lsb-version  #x0001)
184(define MAT5:lsb-magic    #x494D)
185(define MAT5:msb-version  #x0100)
186(define MAT5:msb-magic    #x4D49)
187
188;
189; MAT-File array flags (represented as bit positions)
190;
191(define mxLOGICAL_FLAG  1)
192(define mxGLOBAL_FLAG   2)
193(define mxCOMPLEX_FLAG  3)
194
195(define MAT5:field-name-length 32)
196
197;-------------------------------------
198;  Structure and datatype definitions
199;
200
201; Datatype: MAT5:data-type
202;
203; MAT-file data types
204(define-datatype MAT5:data-type MAT5:data-type? 
205  (miINT8)
206  (miUINT8)
207  (miINT16)     
208  (miUINT16)     
209  (miINT32)     
210  (miUINT32)     
211  (miSINGLE)     
212  (miDOUBLE)     
213  (miINT64)     
214  (miUINT64)     
215  (miMATRIX)     
216  (miCOMPRESSED)
217  (miUTF8)       
218  (miUTF16)     
219  (miUTF32))
220
221;
222; MAT-File array classes
223;
224(define-datatype MAT5:array-class MAT5:array-class? 
225  (mxCELL_CLASS)
226  (mxSTRUCT_CLASS)
227  (mxOBJECT_CLASS)
228  (mxCHAR_CLASS)
229  (mxSPARSE_CLASS)
230  (mxDOUBLE_CLASS)
231  (mxSINGLE_CLASS)
232  (mxINT8_CLASS)
233  (mxUINT8_CLASS)
234  (mxINT16_CLASS)
235  (mxUINT16_CLASS)
236  (mxINT32_CLASS)
237  (mxUINT32_CLASS))
238
239
240;  Structure: MAT5:header
241;
242;  MAT-file Level 5 Header Format
243
244;  * text     is a byte vector of size 116
245;  * subsys   is a byte vector of size 8
246;  * version  is unsigned 16-bit version number
247;  * eport    is an endian port (see module endian-port)
248;
249(define-record MAT5:header  magic text subsys version eport)
250
251
252;  Structure: MAT5:data-element
253;
254;  MAT-file Level 5 data element 
255
256;  * type     is of type MAT5:data-type
257;  * bytes    is the size of the data element in bytes
258;  * data     is the data element object -- either a fixnum/flonum or an array
259;
260(define-record MAT5:data-element  type bytes data)
261
262
263;  Structure: MAT5:array-flags
264;
265;  MAT-file Level 5 array flags
266;
267;  * flags    a bit vector that contains the mxLOGICAL_FLAG, mxGLOBAL_FLAG,
268;             mxCOMPLEX_FLAG flags, if set.
269;  * class    array class; see the definition of MAT5:array-class datatype
270;  * nzmax    maximum number of non-zero elements in a sparse matrix
271;
272(define-record MAT5:array-flags  flags  class  nzmax)
273
274
275; Datatype: MAT5:array
276;
277; A representation of the different types of MAT-file arrays
278;
279(define-datatype MAT5:array MAT5:array? 
280
281
282  ;
283  ; Object
284  ;
285  ;  * dims        dimensions (a list of positive integers) -- these are the
286  ;                dimensions of the cells contained in the structure, if any
287  ;  * class       class name (string)
288  ;  * fields      a cell in which every element is an alist of  fields
289  ;
290  (MAT5:object      (name         string?)
291                    (dims         natural-list?)
292                    (class-name   string?)
293                    (field-names  string-list?)
294                    (fields       MAT5:cell?))
295
296  ; Structure
297  ;
298  ;  * dims        dimensions (a list of positive integers) -- these are the
299  ;                dimensions of the cells contained in the structure, if any
300  ;  * fields      a cell in which every element is an alist of  fields
301  ;
302  (MAT5:structure   (name         string?)
303                    (dims         natural-list?)
304                    (field-names  string-list?)
305                    (fields       MAT5:cell?))
306
307  ;
308  ; Cell array
309  ;
310  ;  * dims        dimensions (a list of positive integers)
311  ;  * cell        a MAT5:cell object (nested R5RS vectors)
312  ;
313  (MAT5:cell-array    (name       string?)
314                      (dims       natural-list?)
315                      (cell       MAT5:cell?))
316
317  ;
318  ; Homogeneous sparse array
319  ;
320  ;  * data-type   array element MAT5 type (can only be numeric type)
321  ;  * dims        dimensions (a list of positive integers)
322  ;  * row-index   row indices of non-zero elements
323  ;  * col-index   column indices of non-zero elements
324  ;  * real        real part (an SRFI-47 array)
325  ;  * imag        imaginary part (array or #f)
326  ;
327  (MAT5:sparse-array    (name       string?)
328                        (data-type  MAT5:numeric-type?)
329                        (dims       MAT5:dimensions?)
330                        (row-index  natural-list?)
331                        (col-index  natural-list?)
332                        (real       (lambda (x) (array? x)))
333                        (imag       (lambda (x) (or (array? x) (not x)))))
334
335  ;
336  ; Homogeneous numeric array
337  ;
338  ;  * data-type  array element MAT5 type (can only be numeric type)
339  ;  * dims       dimensions (a list of positive integers)
340  ;  * real       real part (an SRFI-47 array)
341  ;  * imag       imaginary part (array or #f)
342  ;
343  (MAT5:num-array  (name       string?)
344                   (data-type  MAT5:numeric-type?)
345                   (dims       MAT5:dimensions?) 
346                   (real       (lambda (x) (array? x)))
347                   (imag       (lambda (x) (or (array? x) (not x)))))
348)
349
350;
351; The dimensions of a MAT5 object/struct/cell/array are defined as a
352; list of positive integers, OR a list of positive integers where the
353; last element is the symbol ??  The second format is used when the
354; array data is represented by a stream of column vectors, and it is
355; not known how many elements are in the stream ahead of time.
356;
357(define (MAT5:dimensions? x)
358  (let* ((rx   (reverse x))
359         (last (car rx)))
360    (cond ((natural? last) (natural-list? (cdr rx)))
361          ((eq? '?? last)  (natural-list? (cdr rx)))
362          (else #f))))
363
364
365
366;-----------------------
367; Record pretty printers
368;
369
370(define-record-printer (array x out)
371  (define m 5)
372  (let* ((dims  (array-dimensions x))
373         (vdx  (last dims)))
374    (letrec ((arpp  (lambda (dims idxs lst)
375                      (cond ((null? (cdr dims))
376                             (let ((v  (list-tabulate 
377                                        (if (> m vdx) vdx m) 
378                                        (lambda (i) 
379                                          (apply array-ref x (reverse (cons i idxs)))))))
380                             (cons (if (< m vdx) (append v '(...)) v) lst)))
381                            (else
382                             (let ((dim  (car dims))
383                                   (lst1 '()))
384                               (do ((idx 0 (+ 1 idx)))
385                                   ((or (>= idx dim) (>= idx m)) 
386                                    (if (>= idx m) 
387                                        (cons (reverse (cons '... lst1)) lst)
388                                        (cons (reverse lst1) lst)))
389                                 (set! lst1 (arpp (cdr dims) (cons idx idxs) lst1)))))))))
390
391      (fprintf out "#(array ~S)" (reverse (arpp dims '() '())))
392      )))
393   
394 
395
396(define-record-printer (MAT5:header x out)
397  (fprintf out "#(MAT5:header magic=0x~X text=~S subsys=~S version=~S)"
398           (MAT5:header-magic x)
399           (MAT5:header-text x) 
400           (MAT5:header-subsys x) 
401           (MAT5:header-version x)) )
402
403
404(define-record-printer (MAT5:data-element x out)
405  (fprintf out "#(MAT5:data-element type=~S bytes=~S data=~S)"
406           (MAT5:data-element-type x)
407           (MAT5:data-element-bytes x)
408           (MAT5:data-element-data x)) )
409
410
411(define-record-printer (MAT5:data-type x out)
412  (fprintf out "~A" (MAT5:data-type->string x)) )
413
414
415(define-record-printer (MAT5:array-class x out)
416  (fprintf out "~A" (MAT5:array-class->string x)) )
417
418
419(define-record-printer (MAT5:array x out)
420  (cases MAT5:array x
421         (MAT5:object (name dims class field-names fields)
422                      (fprintf out "#(MAT5:object name=~S dims=~S class=~S field-names=~A fields=~S)"
423                               name dims class field-names fields))
424
425         (MAT5:structure (name dims field-names fields)
426                         (fprintf out "#(MAT5:structure name=~S dims=~S field-names=~A fields=~S)"
427                                  name dims field-names fields))
428         
429         (MAT5:cell-array (name dims cell)
430                          (fprintf out "#(MAT5:cell name=~S dims=~S cell=~S)"
431                                   name dims cell))
432         
433         (MAT5:sparse-array (name data-type dims row-index col-index real imag) 
434          (fprintf out "#(MAT5:sparse-array name=~S data-type=~A dims=~S row-index=~S col-index=~S real=~S imag=~S)"
435                   name data-type dims row-index col-index real imag))
436         
437         (MAT5:num-array (name data-type dims  real imag)
438                         (fprintf out "#(MAT5:num-array name=~S data-type=~A dims=~S real=~S imag=~S)"
439                                  name data-type dims  real imag))
440         
441         (else           "#<MAT5:array>")))
442
443
444(define-record-printer (MAT5:array-flags x out)
445  (let ((flags (MAT5:array-flags-flags x))
446        (class (MAT5:array-flags-class x))
447        (nzmax (MAT5:array-flags-nzmax x)))
448    (let ((sflags (filter (lambda(x) x)
449                          (list (if (bit-vector-ref flags mxLOGICAL_FLAG) "mxLOGICAL_FLAG" #f)
450                                (if (bit-vector-ref flags mxGLOBAL_FLAG)  "mxGLOBAL_FLAG" #f)
451                                (if (bit-vector-ref flags mxCOMPLEX_FLAG) "mxCOMPLEX_FLAG" #f)))))
452      (fprintf out "#(MAT5:array-flags flags=~A  class=~S  nzmax=~S)"
453               (string-intersperse sflags "|") class nzmax))))
454
455
456(define-record-printer (MAT5:cell x out)
457  (let ((dims (MAT5:cell-dims x))
458        (data (MAT5:cell-data x)))
459    (fprintf out "#(MAT5:cell dims=~A  data=~S)" dims data)))
460
461;------------------------------------------------------------
462; Predicates and routines for handling MAT-file datatypes and
463; structures
464;
465;
466 
467; Procedure:
468; MAT5:complex-array?:: MAT5:ARRAY-FLAGS -> BOOLEAN
469;
470; Returns true if the complex flag is set in the given array flags
471;
472(define (MAT5:complex-array? flags)
473  (bit-vector-ref (MAT5:array-flags-flags flags)  mxCOMPLEX_FLAG))
474
475
476; Procedure:
477; MAT5:sparse-class?:: MAT5:ARRAY-FLAGS -> BOOLEAN
478;
479; Returns true if the class field in the given array flags is sparse
480;
481(define (MAT5:sparse-class? flags)
482  (cases MAT5:array-class (MAT5:array-flags-class flags)
483         (mxSPARSE_CLASS () #t)
484         (else              #f)))
485
486
487; Procedure:
488; MAT5:cell-class?:: MAT5:ARRAY-FLAGS -> BOOLEAN
489;
490; Returns true if the class field in the given array flags is cell
491;
492(define (MAT5:cell-class? flags)
493  (cases MAT5:array-class (MAT5:array-flags-class flags)
494         (mxCELL_CLASS () #t)
495         (else              #f)))
496
497
498; Procedure:
499; MAT5:structure-class?:: MAT5:ARRAY-FLAGS -> BOOLEAN
500;
501; Returns true if the class field in the given array flags is structure
502;
503(define (MAT5:structure-class? flags)
504  (cases MAT5:array-class (MAT5:array-flags-class flags)
505         (mxSTRUCT_CLASS () #t)
506         (else              #f)))
507
508
509; Procedure:
510; MAT5:object-class?:: MAT5:ARRAY-FLAGS -> BOOLEAN
511;
512; Returns true if the class field in the given array flags is object
513;
514(define (MAT5:object-class? flags)
515  (cases MAT5:array-class (MAT5:array-flags-class flags)
516         (mxOBJECT_CLASS () #t)
517         (else              #f)))
518
519
520; Procedure:
521; MAT5:numeric-type?:: MAT5:DATA-TYPE -> BOOLEAN
522;
523; Return true if type is an atomic numeric type
524;
525(define (MAT5:numeric-type? t)
526  (cases MAT5:data-type t
527         (miINT8   ()     #t)
528         (miUINT8  ()     #t)
529         (miINT16  ()     #t)
530         (miUINT16 ()     #t)
531         (miINT32  ()     #t)
532         (miUINT32 ()     #t)
533         (miSINGLE ()     #t)
534         (miDOUBLE ()     #t)
535         (miINT64  ()     #t)
536         (miUINT64 ()     #t)
537         (miUTF8   ()     #t)
538         (miUTF16  ()     #t)
539         (miUTF32  ()     #t)
540         (else            #f)))
541
542
543; Procedure:
544; MAT5:array-type?:: MAT5:DATA-TYPE -> BOOLEAN
545;
546; Return true if type is array type (miMATRIX)
547;
548(define (MAT5:array-type? t)
549  (cases MAT5:data-type t
550         (miMATRIX  ()     #t)
551         (else            #f)))
552
553
554; Procedure:
555; MAT5:sizeof:: MAT5:ARRAY-FLAGS -> UINTEGER
556;
557; Returns the size in bytes of the atomic datatype t
558;
559; t must not be miMATRIX or miCOMPRESSED
560;
561(define (MAT5:sizeof t)
562  (cases MAT5:data-type t
563         (miINT8   ()     1)
564         (miUINT8  ()     1)
565         (miINT16  ()     2)
566         (miUINT16 ()     2)
567         (miINT32  ()     4)
568         (miUINT32 ()     4)
569         (miSINGLE ()     4)
570         (miDOUBLE ()     8)
571         (miINT64  ()     8)
572         (miUINT64 ()     8)
573         (miUTF8   ()     1)
574         (miUTF16  ()     2)
575         (miUTF32  ()     4)
576         (else            #f)))
577
578
579; Procedure:
580; MAT5:data-type->string:: MAT5:DATA-TYPE -> STRING
581;
582; Returns the string identifier for the given datatype
583;
584(define (MAT5:data-type->string t)
585  (cases MAT5:data-type t
586         (miINT8   ()     "miINT8")
587         (miUINT8  ()     "miUINT8")
588         (miINT16  ()     "miINT16")
589         (miUINT16 ()     "miUINT16")
590         (miINT32  ()     "miINT32")
591         (miUINT32 ()     "miUINT32")
592         (miSINGLE ()     "miSINGLE")
593         ;;      RESERVED     #x00000008
594         (miDOUBLE ()     "miDOUBLE")
595         ;;      RESERVED     #x0000000A
596         ;;      RESERVED     #x0000000B
597         (miINT64  ()     "miINT64")
598         (miUINT64 ()     "miUINT64")
599         (miMATRIX ()     "miMATRIX")
600         (miCOMPRESSED () "miCOMPRESSED")
601         (miUTF8   ()     "miUTF8")
602         (miUTF16  ()     "miUTF16")
603         (miUTF32  ()     "miUTF32")
604         (else            #f)))
605
606
607; Procedure:
608; MAT5:data-type->array-class:: MAT5:DATA-TYPE -> MAT5:ARRAY-FLAGS
609;
610; Return the numeric array class corresponding to the given datatype
611;
612(define (MAT5:data-type->array-class t)
613  (cases MAT5:data-type t
614         (miINT8   ()     (mxINT8_CLASS))
615         (miUINT8  ()     (mxUINT8_CLASS))
616         (miINT16  ()     (mxINT16_CLASS))
617         (miUINT16 ()     (mxUINT16_CLASS))
618         (miINT32  ()     (mxINT32_CLASS))
619         (miUINT32 ()     (mxUINT32_CLASS))
620         (miSINGLE ()     (mxSINGLE_CLASS))
621         ;;      RESERVED     #x00000008
622         (miDOUBLE ()     (mxDOUBLE_CLASS))
623         ;;      RESERVED     #x0000000A
624         ;;      RESERVED     #x0000000B
625         (else            #f)))
626
627
628; Procedure:
629; MAT5:data-type->word:: MAT5:DATA-TYPE -> UINTEGER
630;
631; Return the numeric code for the given datatype
632;
633(define (MAT5:data-type->word t)
634  (cases MAT5:data-type t
635         (miINT8   ()     #x00000001)
636         (miUINT8  ()     #x00000002)
637         (miINT16  ()     #x00000003)
638         (miUINT16 ()     #x00000004)
639         (miINT32  ()     #x00000005)
640         (miUINT32 ()     #x00000006)
641         (miSINGLE ()     #x00000007)
642         ;;      RESERVED     #x00000008
643         (miDOUBLE ()     #x00000009)
644         ;;      RESERVED     #x0000000A
645         ;;      RESERVED     #x0000000B
646         (miINT64  ()     #x0000000C)
647         (miUINT64 ()     #x0000000D)
648         (miMATRIX ()     #x0000000E)
649         (miCOMPRESSED () #x0000000F)
650         (miUTF8   ()     #x00000010)
651         (miUTF16  ()     #x00000011)
652         (miUTF32  ()     #x00000012)
653         (else            #f)))
654
655
656; Procedure:
657; MAT5:word->data-type:: UINTEGER -> MAT5:DATA-TYPE
658;
659; Return the datatype corresponding to the given numeric value, or #f
660;
661(define (MAT5:word->data-type x)
662  (cond ((= x #x00000001)   (miINT8))
663        ((= x #x00000002)   (miUINT8))
664        ((= x #x00000003)   (miINT16))
665        ((= x #x00000004)   (miUINT16))
666        ((= x #x00000005)   (miINT32))
667        ((= x #x00000006)   (miUINT32))
668        ((= x #x00000007)   (miSINGLE))
669        ((= x #x00000009)   (miDOUBLE))
670        ((= x #x0000000C)   (miINT64))
671        ((= x #x0000000D)   (miUINT64))
672        ((= x #x0000000E)   (miMATRIX))
673        ((= x #x0000000F)   (miCOMPRESSED))
674        ((= x #x00000010)   (miUTF8))
675        ((= x #x00000011)   (miUTF16))
676        ((= x #x00000012)   (miUTF32))
677        (else               #f)))
678
679         
680; Procedure:
681; MAT5:array-class->string:: MAT5:ARRAY-CLASS -> STRING
682;
683; Return the numeric code corresponding to the given array class
684;
685(define (MAT5:array-class->string x)
686  (cases MAT5:array-class x
687         (mxCELL_CLASS   ()    "mxCELL_CLASS")
688         (mxSTRUCT_CLASS ()    "mxSTRUCT_CLASS")
689         (mxOBJECT_CLASS ()    "mxOBJECT_CLASS")
690         (mxCHAR_CLASS   ()    "mxCHAR_CLASS")
691         (mxSPARSE_CLASS ()    "mxSPARSE_CLASS")
692         (mxDOUBLE_CLASS ()    "mxDOUBLE_CLASS")
693         (mxSINGLE_CLASS ()    "mxSINGLE_CLASS")
694         (mxINT8_CLASS   ()    "mxINT8_CLASS")
695         (mxUINT8_CLASS  ()    "mxUINT8_CLASS")
696         (mxINT16_CLASS  ()    "mxINT16_CLASS")
697         (mxUINT16_CLASS ()    "mxUINT16_CLASS")
698         (mxINT32_CLASS  ()    "mxINT32_CLASS")
699         (mxUINT32_CLASS ()    "mxUINT32_CLASS")
700         (else                 #f)))
701
702         
703; Procedure:
704; MAT5:array-class->wordMAT5:ARRAY-CLASS -> UINTEGER
705;
706; Returns the numeric code corresponding to the given array class
707;
708(define (MAT5:array-class->word x)
709  (cases MAT5:array-class x
710         (mxCELL_CLASS   ()    #x01)
711         (mxSTRUCT_CLASS ()    #x02)
712         (mxOBJECT_CLASS ()    #x03)
713         (mxCHAR_CLASS   ()    #x04)
714         (mxSPARSE_CLASS ()    #x05)
715         (mxDOUBLE_CLASS ()    #x06)
716         (mxSINGLE_CLASS ()    #x07)
717         (mxINT8_CLASS   ()    #x08)
718         (mxUINT8_CLASS  ()    #x09)
719         (mxINT16_CLASS  ()    #x0A)
720         (mxUINT16_CLASS ()    #x0B)
721         (mxINT32_CLASS  ()    #x0C)
722         (mxUINT32_CLASS ()    #x0D)
723         (else                 #f)))
724
725
726; Procedure:
727; MAT5:word->array-class:: UINTEGER -> MAT5:ARRAY-CLASS
728;
729;
730; Return the array class corresponding to the given numeric code, or
731; #f
732;
733(define (MAT5:word->array-class x)
734  (cond  ((= x #x01)   (mxCELL_CLASS))
735         ((= x #x02)   (mxSTRUCT_CLASS))
736         ((= x #x03)   (mxOBJECT_CLASS))
737         ((= x #x04)   (mxCHAR_CLASS))
738         ((= x #x05)   (mxSPARSE_CLASS))
739         ((= x #x06)   (mxDOUBLE_CLASS))
740         ((= x #x07)   (mxSINGLE_CLASS))
741         ((= x #x08)   (mxINT8_CLASS))
742         ((= x #x09)   (mxUINT8_CLASS))
743         ((= x #x0A)   (mxINT16_CLASS))
744         ((= x #x0B)   (mxUINT16_CLASS))
745         ((= x #x0C)   (mxINT32_CLASS))
746         ((= x #x0D)   (mxUINT32_CLASS))
747         (else         #f)))
748
749
750; Procedure:
751; MAT5:array-vector-ops:: MAT5:DATA-TYPE -> PROTO * VECTOR-SET * VECTOR-REF * VECTOR-LEN * VECTOR?
752;
753; Returns a set of routines used for the creation and manipulation of
754; homogenous numeric vectors and arrays. Used by the read-array-
755; functions below.
756;
757(define (MAT5:array-vector-ops data-type)
758  (cases MAT5:data-type data-type
759         (miINT8   ()       (values A:fixZ8b   s8vector-set!  s8vector-ref  s8vector-length  s8vector?))
760         (miUINT8  ()       (values A:fixN8b   u8vector-set!  u8vector-ref  u8vector-length  u8vector?))
761         (miINT16  ()       (values A:fixZ16b  s16vector-set! s16vector-ref s16vector-length s16vector?))
762         (miUINT16 ()       (values A:fixN16b  u16vector-set! u16vector-ref u16vector-length u16vector?))
763         (miINT32  ()       (values A:fixZ32b  s32vector-set! s32vector-ref s32vector-length s32vector?))
764         (miUINT32 ()       (values A:fixN32b  u32vector-set! u32vector-ref u32vector-length u32vector?))
765;;       (miINT64  ()       (values A:fixZ64b  s64vector-set! s64vector-ref s64vector-length))
766;;       (miUINT64 ()       (values A:fixN64b  u64vector-set! u64vector-ref u64vector-length))
767         (miUTF8   ()       (values A:fixN8b   u8vector-ref   u8vector-ref  u8vector-length  u8vector?))
768         (miUTF16  ()       (values A:fixN16b  u16vector-set! u16vector-ref u16vector-length u16vector?))
769         (miUTF32  ()       (values A:fixN32b  u32vector-set! u32vector-ref u32vector-length u32vector?))
770         (miSINGLE ()       (values A:floR32b  f32vector-set! f32vector-ref f32vector-length f32vector?))
771         (miDOUBLE ()       (values A:floR64b  f64vector-set! f64vector-ref f64vector-length f64vector?))
772         (miMATRIX ()       (MAT5:error "nested arrays not permitted in numeric arrays"))
773         (else              (MAT5:error "unrecognized type " data-type))))
774
775
776; Procedure:
777; MAT5:array-vector-length:: MAT5:DATA-TYPE * UINTEGER -> UINTEGER
778;
779; Returns the length of the vector that would be necessary to hold all
780; values for an array of the specified size and type.
781;
782;   * data-type   array/vector type
783;   * data-size   array/vector size in bytes
784;
785(define (MAT5:array-vector-length data-type data-size)
786  (cases MAT5:data-type data-type
787         (miINT8   ()        data-size)
788         (miUINT8  ()        data-size)
789         (miINT16  ()        (/ data-size (MAT5:sizeof data-type)))
790         (miUINT16 ()        (/ data-size (MAT5:sizeof data-type)))
791         (miINT32  ()        (/ data-size (MAT5:sizeof data-type)))
792         (miUINT32 ()        (/ data-size (MAT5:sizeof data-type)))
793;;       (miINT64  ()        (/ data-size (MAT5:sizeof data-type)))
794;;       (miUINT64 ()        (/ data-size (MAT5:sizeof data-type)))
795         (miUTF8   ()        data-size)
796         (miUTF16  ()        (/ data-size (MAT5:sizeof data-type)))
797         (miUTF32  ()        (/ data-size (MAT5:sizeof data-type)))
798         (miSINGLE ()        (/ data-size (MAT5:sizeof data-type)))
799         (miDOUBLE ()        (/ data-size (MAT5:sizeof data-type)))
800         (miMATRIX ()       (MAT5:error "nested arrays not permitted in numeric arrays"))
801         (else              (MAT5:error "unrecognized type " data-type))))
802 
803
804; Procedure:
805; MAT5:array-vector-make:: MAT5:DATA-TYPE * UINTEGER -> VECTOR
806;
807; Returns a vector used to hold the values for an array of the
808; specified size and type.  Used by the read-array- functions below.
809;
810;   * data-type   array/vector type
811;   * data-size   array/vector size in bytes
812;
813(define (MAT5:array-vector-make data-type data-size)
814  (let ((len (MAT5:array-vector-length data-type data-size)))
815    (cases MAT5:data-type data-type
816         (miINT8   ()        (make-s8vector   len))
817         (miUINT8  ()        (make-u8vector   len))
818         (miINT16  ()        (make-s16vector  len))
819         (miUINT16 ()        (make-u16vector  len))
820         (miINT32  ()        (make-s32vector  len))
821         (miUINT32 ()        (make-u32vector  len))
822;;       (miINT64  ()        (make-s64vector  len))
823;;       (miUINT64 ()        (make-u64vector  len))
824         (miUTF8   ()        (make-u8vector   len))
825         (miUTF16  ()        (make-u16vector  len))
826         (miUTF32  ()        (make-u32vector  len))
827         (miSINGLE ()        (make-f32vector  len))
828         (miDOUBLE ()        (make-f64vector  len))
829         (miMATRIX ()       (MAT5:error "nested arrays not permitted in numeric arrays"))
830         (else              (MAT5:error "unrecognized type " data-type)))))
831 
832
833; Procedure:
834; MAT5:vector-make:: MAT5:DATA-TYPE * UINTEGER -> VECTOR
835;
836; Returns a vector used to hold the values of the specified type.
837;
838;   * data-type   vector type
839;   * len         vector length
840;
841(define (MAT5:vector-make data-type len)
842    (cases MAT5:data-type data-type
843         (miINT8   ()        (make-s8vector   len))
844         (miUINT8  ()        (make-u8vector   len))
845         (miINT16  ()        (make-s16vector  len))
846         (miUINT16 ()        (make-u16vector  len))
847         (miINT32  ()        (make-s32vector  len))
848         (miUINT32 ()        (make-u32vector  len))
849;;       (miINT64  ()        (make-s64vector  len))
850;;       (miUINT64 ()        (make-u64vector  len))
851         (miUTF8   ()        (make-u8vector   len))
852         (miUTF16  ()        (make-u16vector  len))
853         (miUTF32  ()        (make-u32vector  len))
854         (miSINGLE ()        (make-f32vector  len))
855         (miDOUBLE ()        (make-f64vector  len))
856         (miMATRIX ()       (MAT5:error "nested arrays not permitted in numeric arrays"))
857         (else              (MAT5:error "unrecognized type " data-type))))
858 
859
860;--------------------
861;  MAT5 cell routines
862;
863;  A MAT5 cell is represented as an R5RS non-homogenous array that
864;  contains elements of type MAT5:array
865;
866
867;  Structure: MAT5:cell
868;
869;  A representation of MAT5 cells.
870;
871;  * dims is the cell dimensions (see MAT5:dimensions?) 
872;  * data is an R5RS non-homogenous array that contains
873;    elements of type MAT5:array.
874(define-record MAT5:cell  dims  data)
875
876
877; Procedure:
878; init-MAT5:cell:: UINTEGER * ... -> MAT5:CELL
879;
880; Create a new MAT5:cell object with the specified dimensions. The
881; dimensions must all be positive integers, and at least one dimension
882; must be specified.
883;
884(define (init-MAT5:cell d . dimensions)
885  (let ((dims (cons d dimensions)))
886    (if (not (natural-list? dims))   (MAT5:error "invalid cell dimensions")
887        (let ((ar  (make-vector (car dims))))
888          (init-cell1 ar (cdr dims))
889          (make-MAT5:cell dims ar)))
890    ))
891
892
893; helper function for init-MAT5:cell above
894(define (init-cell1 v dims)
895  (if (not (null? dims))
896      (let loop ((i 0) (len (vector-length v)))
897        (if (not (zero? len))
898            (let ((v1  (make-vector (car dims))))
899              (vector-set! v i v1)
900              (init-cell1 v1 (cdr dims))
901              (loop (+ i 1) (- len 1)))
902            ))
903      ))
904
905
906; Procedure:
907; MAT5:cell-ref:: MAT5:CELL * UINTEGER ... -> VALUE
908;
909; Given a MAT5:cell object and an index, returns the value found at
910; that index in the cell. The index must be a list of positive
911; integers, and it must be within the bounds of the cell dimensions.
912;
913(define (MAT5:cell-ref x i . rest)
914  (let ((ar  (MAT5:cell-data x))
915        (il  (cons i rest)))
916    (if (not (positive-or-zero-list? il))
917        (MAT5:error "invalid cell dimensions")
918        (MAT5:cell-ref1 ar il))
919    ))
920
921 
922;; helper function for MAT5:cell-ref above
923;;  i is a list of dimensions
924(define (MAT5:cell-ref1 x i)
925  (cond ((vector? x)  (if (null? i) (MAT5:error "cell dimension mismatch")
926                          (MAT5:cell-ref1 (vector-ref x (car i)) (cdr i))))
927        (else    (if (null? i) x   (MAT5:error "cell dimension mismatch")))))
928
929
930; Procedure:
931; MAT5:cell-set!:: MAT5:CELL * VALUE * UINTEGER ... -> UNDEFINED
932;
933; Given a MAT5:cell object and an index, destructively replaces the
934; element at the given index of the cell with the given value.
935;
936(define (MAT5:cell-set! x  v  i . rest)
937  (let ((ar  (MAT5:cell-data x))
938        (il  (cons i rest)))
939    (if (not (positive-or-zero-list? il))
940        (MAT5:error "invalid cell dimensions")
941        (MAT5:cell-set1 ar v il))
942    ))
943 
944
945; helper function for MAT5:cell-set! above
946(define (MAT5:cell-set1 x v i)
947  (cond ((null? i)        (MAT5:error "invalid cell dimensions"))
948        ((null? (cdr i))  (if (and (vector? x) (not (vector? (vector-ref x (car i)))))
949                              (vector-set! x (car i) v)
950                              (MAT5:error "cell dimension mismatch")))
951        (else             (if (vector? x)
952                              (MAT5:cell-set1 (vector-ref x (car i)) v (cdr i))
953                              (MAT5:error "cell dimension mismatch")))
954        ))
955
956;---------------------------------------
957;  MAT5 vector/array conversion routines
958;
959
960
961; Procedure:
962; vector->array:: VECTOR-OPS VECTOR ARRAY-PROTOTYPE DIMENSIONS -> ARRAY
963;
964; Based on vector->array from SRFI-63 reference implementation
965; Copyright (C) 2001, 2003, 2005 Aubrey Jaffer
966;
967(define (vector->array vops vect prototype dimensions . rest)
968  (let-optionals  rest ((order 'row-major))
969   (let* ((vector-length (alist-ref 'vector-length vops))
970          (vector-ref (alist-ref 'vector-ref vops))
971          (vdx (vector-length vect)))
972     (if (not (eqv? vdx (apply * dimensions))) (MAT5:error "incompatible dimensions"))
973     (letrec ((ra (apply make-array prototype dimensions))
974              (v2ra  (lambda (dims idxs)
975                       (cond ((null? dims)
976                              (set! vdx (+ -1 vdx))
977                              (apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
978                             (else
979                              (do ((idx (+ -1 (car dims)) (+ -1 idx)))
980                                  ((negative? idx) vect)
981                                (v2ra (cdr dims) (cons idx idxs)))))))
982              (v2ca   (lambda (dims idxs)
983                        (cond ((null? dims)
984                               (set! vdx (+ -1 vdx))
985                               (apply array-set! ra (vector-ref vect vdx) idxs))
986                              (else
987                               (do ((idx (+ -1 (car dims)) (+ -1 idx)))
988                                   ((negative? idx) vect)
989                                 (v2ca (cdr dims) (cons idx idxs))))))))
990       (if (eq? order 'row-major)
991           (v2ra dimensions '())
992           (v2ca (reverse dimensions) '()))
993         ra))))
994
995
996; Procedure:
997; MAT5:array->srfi-4-vector:: ARRAY * MAKE-VECTOR * VECTOR-SET! [* ORDER] -> SRFI-4-VECTOR
998
999(define (MAT5:array->srfi-4-vector ar make-vector vector-set! . rest)
1000
1001  (let-optionals  rest ((order 'row-major))
1002
1003   (let* ((dims (array-dimensions ar))
1004          (vdx  (apply * dims))
1005          (rv   (make-vector vdx)))
1006
1007     (letrec (
1008              (ra2v  (lambda (dims idxs)
1009                       (cond ((null? dims)
1010                              (let ((val (apply array-ref ar (reverse idxs))))
1011                                (set! vdx (+ -1 vdx))
1012                                (vector-set! rv vdx val)))
1013                             (else
1014                              (do ((idx (+ -1 (car dims)) (+ -1 idx)))
1015                                  ((negative? idx) rv)
1016                                (ra2v (cdr dims) (cons idx idxs))))
1017                             )))
1018
1019              (ca2v   (lambda (dims idxs)
1020                        (cond ((null? dims)
1021                               (let ((val (apply array-ref ar idxs)))
1022                                 (set! vdx (+ -1 vdx))
1023                                 (vector-set! rv vdx val)))
1024                              (else
1025                               (do ((idx (+ -1 (car dims)) (+ -1 idx)))
1026                                   ((negative? idx) rv)
1027                                 (ca2v (cdr dims) (cons idx idxs)))))))
1028              )
1029
1030       (if (eq? order 'row-major)
1031           (ra2v dims '())
1032           (ca2v (reverse dims) '()))
1033
1034         rv))))
1035
1036
1037; Procedure:
1038; vector->MAT5:cell:: VECTOR * UINTEGER LIST [* ORDER] -> MAT5:CELL
1039;
1040; Given a vector, creates a new MAT5:cell object that consists of the
1041; elements of the vector. The vector must be of length equal to the
1042; total size of the array, and its elements are used to initialize the
1043; cell in either row-major order (left to right and top to bottom), or
1044; in column-major order (top to bottom and then left to right).
1045;
1046; The optional argument ORDER specifies the initialization order and
1047; can be either 'row-major or 'col-major. The default is 'row-major.
1048;
1049; This is based on vector->array from SRFI-63 reference implementation
1050; Copyright (C) 2001, 2003, 2005 Aubrey Jaffer
1051(define (vector->MAT5:cell vect dimensions . rest)
1052  (let-optionals  rest ((order 'row-major))
1053   (let* ((vdx (vector-length vect)))
1054     (if (not (eqv? vdx (apply * dimensions))) (MAT5:error "incompatible dimensions"))
1055     (letrec ((ra (apply init-MAT5:cell  dimensions))
1056              (v2ra  (lambda (dims idxs)
1057                       (cond ((null? dims)
1058                              (set! vdx (+ -1 vdx))
1059                              (apply MAT5:cell-set! ra (vector-ref vect vdx) (reverse idxs)))
1060                             (else
1061                              (do ((idx (+ -1 (car dims)) (+ -1 idx)))
1062                                  ((negative? idx) vect)
1063                                (v2ra (cdr dims) (cons idx idxs)))))))
1064              (v2ca   (lambda (dims idxs)
1065                        (cond ((null? dims)
1066                               (set! vdx (+ -1 vdx))
1067                               (apply MAT5:cell-set! ra (vector-ref vect vdx) idxs))
1068                              (else
1069                               (do ((idx (+ -1 (car dims)) (+ -1 idx)))
1070                                   ((negative? idx) vect)
1071                                 (v2ca (cdr dims) (cons idx idxs))))))))
1072       (if (eq? order 'row-major)
1073                (v2ra dimensions '())
1074                (v2ca (reverse dimensions) '()))
1075       ra))
1076   ))
1077
1078
1079; Procedure:
1080; MAT5:array-foldi:: (INDEX * VALUE * AX -> AX) [* ORDER] -> MAT5:ARRAY * AX -> AX
1081;
1082; Iterator function for non-homogenous MAT5:array objects; that is,
1083; objects that are either MAT5:cell-array (MAT5 cell) or
1084; MAT5:structure (MAT5 structure).
1085;
1086; Analogous to the list iterator, this procedure repeatedly applies
1087; the given function to each element of the array, and accumulates the
1088; return value. The order of iteration is specified by the optional
1089; argument ORDER, which can be 'row-major (left to right and top to
1090; bottom) or 'col-major (top to bottom and then left to right). The
1091; default is 'row-major.
1092;
1093(define (MAT5:array-foldi  f . rest)
1094  (let-optionals  rest ((order 'row-major))
1095   (lambda (x ax)
1096     (let-values (((dims vdx arr elm-ref) 
1097                   (cases MAT5:array x
1098                          (MAT5:cell-array (name dims cell) 
1099                                           (let ((vdx (apply * dims)))
1100                                             (values dims vdx cell MAT5:cell-ref)))
1101                          (MAT5:structure (name dims field-names fields) 
1102                                          (let* ((flen  (length field-names))
1103                                                 (vdx   (* (apply * dims) flen))) 
1104                                            (values dims vdx fields MAT5:cell-ref)))
1105                          (MAT5:object (name dims class-name field-names fields)
1106                                       (let* ((flen  (length field-names))
1107                                              (vdx   (* (apply * dims) flen))) 
1108                                         (values dims vdx fields MAT5:cell-ref)))
1109                          (else   (MAT5:error "invalid MAT5 array")))))
1110                 (letrec ((ra2v  (lambda (dims idxs ax)
1111                                   (cond ((null? dims)
1112                                          (set! vdx (+ -1 vdx))
1113                                          (f vdx  (apply elm-ref arr (reverse idxs)) ax))
1114                                         (else
1115                                          (let ((dim (car dims)))
1116                                            (do ((idx 0 (+ 1 idx)))
1117                                                ((>= idx dim) ax)
1118                                              (set! ax (ra2v (cdr dims) (cons idx idxs) ax))))))))
1119                          (ca2v   (lambda (dims idxs ax)
1120                                    (cond ((null? dims)
1121                                           (set! vdx (+ -1 vdx))
1122                                           (f vdx  (apply elm-ref arr  idxs) ax))
1123                                          (else
1124                                           (let ((dim (car dims)))
1125                                             (do ((idx 0 (+ 1 idx)))
1126                                                 ((>= idx dim) ax)
1127                                             (set! ax (ca2v (cdr dims) (cons idx idxs) ax)))))))))
1128                   (if (eq? order 'row-major)
1129                       (ra2v dims '() ax)
1130                       (ca2v (reverse dims) '() ax)))))
1131   ))
1132
1133
1134; Procedure:
1135; array-foldi
1136;
1137(define (array-foldi  f . rest)
1138  (let-optionals  rest ((order 'row-major))
1139   (lambda (arr ax)
1140     (if (not (array? arr)) (MAT5:error "invalid array"))
1141     (let ((dims (array-dimensions arr)))
1142       (letrec ((vdx   (apply * dims))
1143                (ra2v  (lambda (dims idxs ax)
1144                         (cond ((null? dims)
1145                                (set! vdx (+ -1 vdx))
1146                                (f vdx  (apply array-ref arr (reverse idxs)) ax))
1147                               (else
1148                                (let ((dim (car dims)))
1149                                  (do ((idx 0 (+ 1 idx)))
1150                                      ((>= idx dim) ax)
1151                                    (set! ax (ra2v (cdr dims) (cons idx idxs) ax))))))))
1152                (ca2v   (lambda (dims idxs ax)
1153                          (cond ((null? dims)
1154                                 (set! vdx (+ -1 vdx))
1155                                 (f vdx  (apply array-ref arr idxs) ax))
1156                                (else
1157                                 (let ((dim (car dims)))
1158                                   (do ((idx 0 (+ 1 idx)))
1159                                       ((>= idx dim) ax)
1160                                     (set! ax (ca2v (cdr dims) (cons idx idxs) ax)))))))))
1161         (if (eq? order 'row-major)
1162             (ra2v dims '() ax)
1163             (ca2v (reverse dims) '() ax)))))
1164   ))
1165
1166
1167(define (update-array-name name x)
1168    (cases MAT5:array x
1169         (MAT5:object
1170          (name1 dims class field-names fields)
1171          (if (string=? name1 "")
1172              (MAT5:object name dims class field-names fields) x))
1173
1174         (MAT5:structure 
1175          (name1 dims field-names fields)
1176          (if (string=? name1 "")
1177              (MAT5:structure name dims field-names fields) x))
1178
1179         
1180         (MAT5:cell-array
1181          (name1 dims cell)
1182          (if (string=? name1 "")
1183              (MAT5:cell-array name dims cell) x))
1184                         
1185         
1186         (MAT5:sparse-array
1187          (name1 data-type dims row-index col-index real imag) 
1188          (if (string=? name1 "")
1189              (MAT5:sparse-array name data-type dims row-index col-index real imag) x))
1190         
1191         (MAT5:num-array
1192          (name1 data-type dims  real imag)
1193          (if (string=? name1 "")
1194              (MAT5:num-array name data-type dims real imag) x))
1195         
1196         (else           x)
1197         ))
1198
1199
1200;--------------------------
1201; MAT-file Reading Routines
1202;
1203
1204; Procedure:
1205; MAT5:read-header:: ENDIAN-PORT -> MAT5:HEADER
1206;
1207; Reads a MAT5 header from the given endian port. Returns a
1208; MAT5:header record.
1209;
1210(define (MAT5:read-header eport)
1211  (endian-port-setpos eport 0)
1212  (let* ((text     (endian-port-read-byte-vector  eport MAT5:header-text-size MSB))
1213         (subsys   (endian-port-read-byte-vector  eport MAT5:header-subsys-size MSB))
1214         (version  (endian-port-read-int2 eport MSB))
1215         (magic    (endian-port-read-int2 eport MSB)))
1216    (cond ((= magic MAT5:lsb-magic) (endian-port-set-littlendian! eport))
1217          ((= magic MAT5:msb-magic) (endian-port-set-bigendian! eport))
1218          (else                     (MAT5:error "MAT-file magic number not found")))
1219    (if (not (or (= version MAT5:msb-version) (= version MAT5:lsb-version)))
1220        (MAT5:warning "unknown MAT-file version " version))
1221    (make-MAT5:header magic (byte-vector->zstring text) (byte-vector->zstring subsys) version eport)
1222    ))
1223
1224
1225
1226; Procedure:
1227; read-data-element-header:: ENDIAN-PORT -> MAT5:DATA-TYPE * DATA-SIZE * BYTES
1228;
1229; Reads the header of a MAT5 data element.
1230;
1231; Returns (values data-type data-size bytes)
1232;
1233(define (read-data-element-header eport)
1234  (let ((type-word  (endian-port-read-int4 eport)))
1235
1236    (MAT5:debug 2 "read-data-element-header: type-word = " 
1237                (if (number? type-word) 
1238                    (sprintf "0x~X" type-word) 
1239                    type-word))
1240    (MAT5:debug 2 "read-data-element-header: small element = " 
1241                (if (number? type-word) 
1242                    (not (zero? (bitwise-and #xFFFF0000 type-word)))
1243                    type-word))
1244
1245    ;; Check for small data element format: when reading a MAT-file,
1246    ;; determine that we are processing a small data element by
1247    ;; comparing the value of the first two bytes of the tag with the
1248    ;; value zero. If these two bytes are not zero, the tag uses the
1249    ;; small data element format.
1250    (if (not type-word)
1251        (values #f #f #f)
1252        (if (zero? (bitwise-and #xFFFF0000 type-word))
1253            (let ((data-type (MAT5:word->data-type type-word)))
1254              (values   data-type
1255                        (endian-port-read-int4 eport)
1256                        8))
1257            (let ((data-type (MAT5:word->data-type (bitwise-and #x0000FFFF type-word))))
1258              (values  data-type
1259                       (arithmetic-shift (bitwise-and #xFFFF0000 type-word) -16)
1260                       4)))
1261        )))
1262
1263
1264; Procedure:
1265; read-data-element:: ENDIAN-PORT * DATA-TYPE * SIZE -> MAT5:DATA-ELEMENT
1266;
1267; Given an eport and MAT5 data type, read a word of that type from
1268; the eport. Returns a record of type MAT5:data-element.
1269;
1270; This function is parameterized over the routines for reading numeric
1271; array data. See function read-array for understanding of the two
1272; interfaces.
1273;
1274(define (read-data-element read-sparse-array-data 
1275                           read-num-array-data)
1276  (let ((read-array (read-array read-sparse-array-data 
1277                                read-num-array-data)))
1278    (lambda (eport type size)
1279      (if (MAT5:numeric-type? type) 
1280          (read-num-data-element eport type size)
1281          (cases MAT5:data-type type
1282                 (miMATRIX ()     (let-values (((array bytes)  (read-array eport)))
1283                                              (make-MAT5:data-element type bytes array)))
1284                 (miCOMPRESSED () (read-compressed-data-element eport size))
1285                 
1286                 (else (MAT5:error eport "unrecognized type " type)))
1287          ))
1288    ))
1289
1290
1291; Given a compressed data element, uncompress it, create a temporary
1292; eport that points to the uncompressed data, then call
1293; MAT5:read-data-element with that eport
1294(define (read-compressed-data-element eport size)
1295
1296  (let* ((zdata  (endian-port-read-byte-vector eport size MSB))
1297         (dd (MAT5:debug 2 "read-compressed-data-element: length zdata = " 
1298                         (blob-size zdata)))
1299         (dd (MAT5:debug 3 "read-compressed-data-element: zdata = " 
1300                         zdata))
1301         (zstr   (z3:decode-buffer (substring (blob->string zdata) 2))))
1302
1303    (MAT5:debug 2 "read-compressed-data-element: data decoded" )
1304
1305    (let-values (((fd temp-path) (file-mkstemp "/tmp/mat5-lib.XXXXXX")))
1306      (file-write fd zstr) 
1307
1308      (MAT5:debug 2 "read-compressed-data-element: decoded data written to temp file" )
1309
1310      (let* ((temp-port (open-output-file* fd))
1311             (ezport (port->endian-port temp-port)))
1312
1313          (if (eq? (endian-port-byte-order eport) MSB)
1314              (endian-port-set-bigendian! ezport)
1315              (endian-port-set-littlendian! ezport))
1316          (endian-port-setpos ezport 0)
1317          (let ((elms (MAT5:read-data-element ezport)))
1318            (MAT5:debug 2 "read-compressed-data-element: elements read" )
1319            (close-endian-port ezport)
1320            (delete-file temp-path)
1321            (cons size elms)
1322            ))
1323        ))
1324    )
1325
1326; Procedure:
1327; read-num-data-element:: ENDIAN-PORT * MAT5:DATA-TYPE * SIZE -> MAT5:DATA-ELEMENT
1328;
1329; Reads an atomic numeric data element (i.e. one that is not a matrix).
1330;
1331(define (read-num-data-element eport type size)
1332  (cases MAT5:data-type type
1333         (miINT8   ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int1 eport)))
1334         (miUINT8  ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int1 eport)))
1335         (miINT16  ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int2 eport)))
1336         (miUINT16 ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int2 eport)))
1337         (miINT32  ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int4 eport)))
1338         (miUINT32 ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int4 eport)))
1339         (miSINGLE ()     (let ((fpword (endian-port-read-ieee-float32 eport)))
1340                                      (make-MAT5:data-element type (MAT5:sizeof type) fpword)))
1341         (miDOUBLE ()     (let ((fpword (endian-port-read-ieee-float64 eport)))
1342                            (make-MAT5:data-element type (MAT5:sizeof type) fpword)))
1343         ;;      (miINT64  ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int8 eport)))
1344         ;;      (miUINT64 ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int8 eport)))
1345         (miUTF8   ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int1 eport)))
1346         (miUTF16  ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int2 eport)))
1347         (miUTF32  ()     (make-MAT5:data-element type (MAT5:sizeof type)  (endian-port-read-int4 eport)))
1348         (else            (MAT5:error eport "unrecognized type " type))))
1349         
1350
1351
1352; Procedure:
1353; read-array-flags:: ENDIAN-PORT -> MAT5:ARRAY-FLAGS * BYTES
1354;
1355; Reads array flags data element from the given eport, and returns the
1356; array flags and how many bytes were read.
1357;
1358(define (read-array-flags eport)
1359  (let-values
1360   (((data-type data-size header-bytes) (read-data-element-header eport)))
1361
1362   (if (not data-type) (MAT5:error eport "invalid data element type"))
1363   (cases MAT5:data-type data-type
1364          (miUINT32 () 
1365                    (let* ((flags-word  (endian-port-read-int4 eport))
1366                           (flags       (integer->bit-vector (arithmetic-shift 
1367                                                              (bitwise-and #x0000FF00 flags-word) -8)))
1368                           (class-word  (bitwise-and #x000000FF flags-word))
1369                           (class       (MAT5:word->array-class class-word))
1370                           (nzmax       (endian-port-read-int4 eport))
1371                           (pad-bytes   (align-eport-pos eport)))
1372
1373                      (if (not class) (MAT5:error eport "invalid class: " class-word))
1374                      (values (make-MAT5:array-flags flags class nzmax) 
1375                              (+ header-bytes pad-bytes data-size))))
1376          (else
1377           (MAT5:error eport "array flags data element is not of type UINT32; type is "
1378                       data-type)))))
1379         
1380
1381; Procedure:
1382; read-array-dimensions:: ENDIAN-PORT -> UINTEGER LIST * BYTES
1383;
1384; Reads array dimensions data element from the given eport, and
1385; returns the dimensions as a list of positive integers, and how many
1386; bytes were read.
1387;
1388(define (read-array-dimensions eport)
1389  (let-values
1390   (((data-type data-size header-bytes) (read-data-element-header eport)))
1391   (if (not data-type) (MAT5:error eport "invalid data element type"))
1392   (let* ((count      (/ data-size (MAT5:sizeof data-type))))
1393     (cases MAT5:data-type data-type
1394            (miINT32 ()  (if (> count 1)
1395                             (let loop ((i 1) (lst (list (endian-port-read-int4 eport))))
1396                               (if (< i count)
1397                                   (loop (+ i 1) (cons (endian-port-read-int4 eport) lst))
1398                                   (let ((pad-bytes (align-eport-pos eport)))
1399                                     (values (reverse lst) (+ header-bytes pad-bytes data-size)))))
1400                             (MAT5:error eport count " array dimensions found; at least 2 array dimensions required")))
1401            (else         (MAT5:error eport "array dimension data element is not of type INT32"))))))
1402
1403       
1404; Procedure:
1405; read-array-name:: ENDIAN-PORT -> STRING * BYTES
1406;
1407;
1408; Reads array name data element from the given eport, and returns the
1409; name as a string, and how many bytes were read.
1410;
1411(define (read-array-name eport)
1412  (let-values
1413   (((data-type data-size header-bytes) (read-data-element-header eport)))
1414   (if (not data-type) (MAT5:error eport "invalid data element type"))
1415   (cases MAT5:data-type data-type
1416          (miINT8 ()   (let* ((bv  (endian-port-read-byte-vector eport data-size MSB))
1417                              (pad-bytes  (align-eport-pos eport)))
1418                         (values (byte-vector->zstring bv) (+ header-bytes pad-bytes data-size))))
1419          (else        (MAT5:error eport "array name data element is not of type INT8")))))
1420
1421
1422; Procedure:
1423; read-row-index:: ENDIAN-PORT * MAT5:ARRAY-FLAGS -> UINTEGER LIST * BYTES
1424;
1425; Reads a sparse array row-index data element from the given
1426; eport. Argument array-flags is used to determine the number of
1427; non-zero rows.
1428;
1429(define (read-row-index eport array-flags)
1430  (let-values
1431   (((data-type data-size header-bytes) (read-data-element-header eport)))
1432   (if (not data-type) (MAT5:error eport "invalid data element type"))
1433   (let*  ((count      (/ data-size (MAT5:sizeof data-type)))
1434           (nzmax      (MAT5:array-flags-nzmax array-flags)))
1435     (cases MAT5:data-type data-type
1436            (miINT32 ()   (if (= nzmax count)
1437                              (let loop ((i 1) (lst (list (endian-port-read-int4 eport))))
1438                                (if (< i count)
1439                                    (loop (+ i 1) (cons (endian-port-read-int4 eport) lst))
1440                                    (let ((pad-bytes  (align-eport-pos eport)))
1441                                      (values (reverse lst) (+ header-bytes pad-bytes data-size)))))
1442                              (MAT5:error eport "mismatch between ir count and nzmax: ir count = " 
1443                                          count " nzmax = " nzmax)))
1444            (else          (MAT5:error eport "array row index data element is not of type INT32"))))))
1445
1446
1447; Procedure:
1448; read-col-index:: ENDIAN-PORT * MAT5:ARRAY-FLAGS -> UINTEGER LIST * BYTES
1449;
1450; Reads a sparse array column-index data element from the given
1451; eport. Argument array-flags is used to determine the number of
1452; non-zero rows.
1453;
1454(define (read-col-index eport array-dims)
1455  (let-values
1456   (((data-type data-size header-bytes) (read-data-element-header eport)))
1457   (if (not data-type) (MAT5:error eport "invalid data element type"))
1458   (let* ((count      (/ data-size (MAT5:sizeof data-type))))
1459     (cases MAT5:data-type data-type
1460            (miINT32 ()   (if (= 1 (- count (second array-dims)))
1461                              (let loop ((i 1) (lst (list (endian-port-read-int4 eport))))
1462                                (if (< i count)
1463                                    (loop (+ i 1) (cons (endian-port-read-int4 eport) lst))
1464                                    (let ((pad-bytes  (align-eport-pos eport)))
1465                                      (values (reverse lst) (+ header-bytes pad-bytes data-size)))))
1466                              (MAT5:error eport "mismatch between jc count and second dimension: jc count = " count
1467                                          " dimensions = " array-dims)))
1468            (else (MAT5:error eport "array column index data element is not of type INT32"))))))
1469
1470
1471; Procedure:
1472; read-fieldname-len
1473;
1474;
1475; Read field name length (for structures and objects)
1476;
1477(define (read-fieldname-len eport)
1478  (let-values
1479   (((data-type data-size header-bytes)  (read-data-element-header eport)))
1480   (if (not data-type) (MAT5:error eport "invalid data element type"))
1481   (cases MAT5:data-type data-type
1482          (miINT32 ()     (let* ((fieldname-len    (endian-port-read-int4 eport))
1483                                 (pad-bytes (align-eport-pos eport)))
1484                            (values fieldname-len (+ header-bytes pad-bytes data-size))))
1485          (else           (MAT5:error eport "field name length data element is not of type INT32")))))
1486
1487
1488; Procedure:
1489; read-field-names:: ENDIAN-PORT * UINTEGER -> STRING LIST * BYTES
1490;
1491; Reads field names (for structures and objects). Returns the field
1492; names as a list of strings, and how many bytes were read.
1493;
1494(define (read-field-names eport fieldname-len)
1495  (let-values
1496   (((data-type data-size header-bytes)  (read-data-element-header eport)))
1497   (if (not data-type) (MAT5:error eport "invalid data element type"))
1498   (cases MAT5:data-type data-type
1499            (miINT8 ()      (let loop ((names '())   (len (/ data-size fieldname-len)))
1500                              (if (zero? len)
1501                                  (let ((pad-bytes (align-eport-pos eport))
1502                                        (bv->string (lambda (x) (byte-vector->zstring x))))
1503                                    (values (map bv->string (reverse names))  (+ header-bytes pad-bytes data-size)))
1504                                  (let  ((name  (endian-port-read-byte-vector eport fieldname-len MSB)))
1505                                    (loop (cons name names) (- len 1))))))
1506            (else           (MAT5:error eport "field name data element is not of type INT8")))))
1507
1508; Procedure:
1509; read-fields:: ENDIAN-PORT * STRING LIST -> VALUE LIST * BYTES
1510;
1511; Given an endian port, and a list of field names, reads the field
1512; values for a MAT5 structure. This function is parameterized over the
1513; routines for reading numeric array data. See function read-array for
1514; understanding of the two interfaces.
1515
1516(define (read-fields read-sparse-array-data 
1517                     read-num-array-data)
1518  (lambda (eport field-names)
1519    (let ((read-data-element (read-data-element read-sparse-array-data 
1520                                                read-num-array-data)))
1521      (let loop ((fields '()) (field-names field-names) (bytes 0))
1522        (if (null? field-names)  (values fields bytes)
1523            (let-values
1524             (((data-type data-size header-bytes) (read-data-element-header eport)))
1525             (if (not data-type) (MAT5:error eport "invalid data element type"))
1526             (let* ((data-element   (read-data-element eport data-type data-size))
1527                    (data           (MAT5:data-element-data data-element))
1528                    (data-bytes     (MAT5:data-element-bytes data-element))
1529                    (field          (update-array-name (car field-names) data)))
1530               (loop (cons field fields) (cdr field-names) 
1531                     (+ bytes header-bytes data-bytes)))
1532             ))
1533        ))
1534    ))
1535
1536
1537; Procedure:
1538; read-struct-data:: ENDIAN-PORT * MAT5:ARRAY-FLAGS * MAT5:DIMENSIONS * STRING LIST ->
1539;                    MAT5:CELL * BYTES
1540;
1541; Reads the data for a MAT5 structure. The structure is represented
1542; as a MAT5:cell object, where each element is a list of field values.
1543;
1544(define (read-struct-data read-sparse-array-data 
1545                          read-num-array-data)
1546  (let ((read-fields (read-fields read-sparse-array-data 
1547                                  read-num-array-data)))
1548    (lambda (eport array-flags array-dims field-names)
1549      (let ((vector-data (make-vector (apply * array-dims))))
1550        (let loop ((i 0)  (len (apply * array-dims)) (bytes 0))
1551          (if (zero? len)
1552              (let ((pad-bytes  (align-eport-pos eport)))
1553                (values (vector->MAT5:cell vector-data array-dims 'col-major) 
1554                        (+ pad-bytes bytes)))
1555              (let-values (((fields fields-bytes)  (read-fields eport field-names)))
1556                          (vector-set! vector-data i (reverse fields))
1557                          (loop (+ i 1) (- len 1) (+ bytes fields-bytes)))
1558              ))
1559        ))
1560    ))
1561
1562
1563; Procedure:
1564; read-cell-data:: ENDIAN-PORT * MAT5:ARRAY-FLAGS * MAT5:DIMENSIONS ->
1565;                  MAT5:CELL * BYTES
1566;
1567; Reads the data for a MAT5 cell.
1568;
1569(define (read-cell-data read-sparse-array-data 
1570                        read-num-array-data)
1571  (let ((read-data-element (read-data-element read-sparse-array-data 
1572                                              read-num-array-data)))
1573    (lambda (eport array-flags array-dims)
1574      (let ((vector-data (make-vector (apply * array-dims))))
1575        (let loop ((i 0)  (len (apply * array-dims)) (bytes 0))
1576          (if (zero? len)
1577              (let ((pad-bytes  (align-eport-pos eport)))
1578                (values (vector->MAT5:cell vector-data array-dims 'col-major) 
1579                        (+ pad-bytes bytes)))
1580              (let-values
1581               (((data-type data-size header-bytes) (read-data-element-header eport)))
1582               (if (not data-type) (MAT5:error eport "invalid data element type"))
1583               (let ((data-element (read-data-element eport data-type data-size)))
1584                 (vector-set! vector-data i (MAT5:data-element-data data-element))
1585                 (loop (+ i 1)  (- len 1) (+ bytes header-bytes data-size))
1586                 ))
1587              ))
1588        ))
1589    ))
1590
1591
1592; Procedure:
1593; read-sparse-array-data:: ENDIAN-PORT * MAT5:ARRAY-FLAGS * ROW-INDEX * COL-INDEX ->
1594;                          VECTOR (of MAT5:data-element) * BYTES
1595;
1596;
1597; Reads the data for a sparse numeric array.
1598;
1599(define (read-sparse-array-data eport array-flags row-index col-index)
1600  (let-values
1601   (((data-type data-size header-bytes) (read-data-element-header eport)))
1602   (if (not data-type) (MAT5:error eport "invalid data element type"))
1603   (if (not (MAT5:numeric-type? data-type)) (MAT5:error eport "non-numeric sparse array data"))
1604   (if (not (= (MAT5:array-vector-length data-type data-size) 
1605               (* (length row-index) (length col-index))))
1606       (MAT5:error eport "incompatible dimensions: data length is " 
1607                   (MAT5:array-vector-length data-type data-size)
1608                   " sparse array dimensions are specified as " 
1609                   row-index " " col-index))
1610   (let-values   
1611    (((prototype vector-set! vector-ref vector-length vector?) 
1612      (MAT5:array-vector-ops data-type)))
1613    (let ((vector-data (MAT5:array-vector-make data-type data-size)))
1614      (let loop ((i 0) (len (vector-length vector-data)))
1615        (if (zero? len)
1616            (let ((vops     `((vector-ref . ,vector-ref)
1617                              (vector-length . ,vector-length)))
1618                  (pad-bytes  (align-eport-pos eport)))
1619              (values data-type
1620                      (vector->array vops vector-data (prototype) 
1621                                     (list (length row-index) (length col-index)) 'col-major) 
1622                      (+ pad-bytes header-bytes data-size)))
1623            (let ((data-element (read-num-data-element eport data-type data-size)))
1624              (vector-set! vector-data i (MAT5:data-element-data data-element))
1625              (loop (+ i 1)  (- len 1)))
1626            ))
1627      ))
1628   ))
1629
1630; Procedure:
1631; read-num-array-data:: ENDIAN-PORT * MAT5:ARRAY-FLAGS * MAT5:DIMENSIONS ->
1632;                       ARRAY * BYTES
1633;
1634; Reads the data for a homogeneous numeric array.
1635(define (read-num-array-data eport array-flags array-dims)
1636  (let-values
1637
1638   (((data-type data-size header-bytes) (read-data-element-header eport)))
1639
1640   (if (not data-type) (MAT5:error eport "invalid data element type"))
1641   (if (not (MAT5:numeric-type? data-type)) (MAT5:error eport "non-numeric array data"))
1642   (if (not (= (MAT5:array-vector-length data-type data-size) (apply * array-dims)))
1643       (MAT5:error eport "incompatible dimensions: data length is " 
1644                   (MAT5:array-vector-length data-type data-size)
1645                   " array dimensions are specified as " array-dims))
1646   (let-values   
1647    (((prototype vector-set! vector-ref vector-length vector?) 
1648      (MAT5:array-vector-ops data-type)))
1649
1650    (let ((vector-data (MAT5:array-vector-make data-type data-size)))
1651
1652      (MAT5:debug 3 "read-num-array-data: vector-data = " vector-data)
1653
1654      (let loop ((i 0) (len (vector-length vector-data)))
1655
1656        (if (zero? len)
1657
1658            (let* ((vops      `((vector-ref . ,vector-ref)
1659                                (vector-length . ,vector-length)))
1660                   (pad-bytes  (align-eport-pos eport)))
1661
1662              (values  data-type
1663                       (vector->array vops vector-data (prototype) array-dims 'col-major) 
1664                       (+ pad-bytes header-bytes data-size)))
1665
1666            (let ((data-element (read-num-data-element eport data-type data-size)))
1667              (vector-set! vector-data i (MAT5:data-element-data data-element))
1668              (loop (+ i 1)  (- len 1)))
1669            ))
1670      ))
1671   ))
1672
1673
1674; Procedure:
1675; read-array
1676;
1677(define (read-array read-sparse-array-data 
1678                    read-num-array-data)
1679  (lambda (eport)
1680    (let ((read-struct-data (read-struct-data read-sparse-array-data 
1681                                              read-num-array-data))
1682          (read-cell-data (read-cell-data read-sparse-array-data 
1683                                          read-num-array-data)))
1684         
1685    (let*-values 
1686     (((array-flags flags-bytes)  (read-array-flags eport))
1687      ((array-dims  dims-bytes)   (read-array-dimensions eport))
1688      ((array-name  name-bytes)   (read-array-name eport)))
1689     (cond  
1690     
1691     
1692      ;; read an object
1693      ((MAT5:object-class? array-flags) 
1694       (begin
1695         (let*-values (((class-name      class-name-bytes)      (read-array-name eport))
1696                       ((fieldname-len   fieldname-len-bytes)   (read-fieldname-len eport))
1697                       ((field-names     field-names-bytes)     (read-field-names eport fieldname-len))
1698                       ((fields          fields-bytes)          (read-struct-data eport array-flags array-dims 
1699                                                                                  field-names)))
1700                      (values  (MAT5:object array-name array-dims class-name field-names fields)
1701                               (+ flags-bytes dims-bytes name-bytes class-name-bytes 
1702                                  fieldname-len-bytes field-names-bytes fields-bytes)))))
1703     
1704      ;; read a structure
1705      ((MAT5:structure-class? array-flags) 
1706       (begin
1707         (let*-values (((fieldname-len   fieldname-len-bytes)   (read-fieldname-len eport))
1708                       ((field-names     field-names-bytes)     (read-field-names eport fieldname-len))
1709                       ((fields          fields-bytes)          (read-struct-data eport array-flags array-dims
1710                                                                                  field-names)))
1711                     
1712                      (values  (MAT5:structure array-name array-dims field-names fields)
1713                               (+ flags-bytes dims-bytes name-bytes fieldname-len-bytes
1714                                  field-names-bytes fields-bytes)))))
1715     
1716      ;; read a cell array
1717      ((MAT5:cell-class? array-flags) 
1718       (begin
1719         (let*-values (((cell   cell-bytes)   
1720                        (read-cell-data eport array-flags array-dims)))
1721                      (values  (MAT5:cell-array array-name array-dims cell)
1722                               (+ flags-bytes dims-bytes name-bytes cell-bytes)))))
1723     
1724      ;; read a sparse array
1725      ((MAT5:sparse-class? array-flags) 
1726       (begin
1727         (if (not (= (length array-dims) 2)) 
1728             (MAT5:error eport "read-array supports only two-dimensional sparse arrays"))
1729         (let*-values (((row-index   row-bytes)    (read-row-index eport array-flags))
1730                       ((col-index   col-bytes)    (read-col-index eport array-dims))
1731                       ((data-type real-part   real-bytes)   
1732                        (read-sparse-array-data eport array-flags row-index col-index))
1733                       ((dummy imag-part   imag-bytes)   
1734                        (if (MAT5:complex-array? array-flags)
1735                            (read-sparse-array-data eport array-flags row-index col-index)
1736                            (values #f #f 0))))
1737                      (values  (MAT5:sparse-array
1738                                array-name data-type array-dims row-index col-index real-part imag-part)
1739                               (+ flags-bytes dims-bytes name-bytes row-bytes col-bytes real-bytes imag-bytes)))
1740         ))
1741     
1742      ;; read a homogeneous numeric array
1743      (else
1744       (let*-values (((data-type real-part real-bytes)   
1745                      (read-num-array-data eport array-flags array-dims))
1746                     ((dummy imag-part imag-bytes)   
1747                      (if (MAT5:complex-array? array-flags)
1748                          (read-num-array-data eport array-flags array-dims)  (values #f #f 0))))
1749         (values  (MAT5:num-array array-name data-type array-dims real-part imag-part)
1750                  (+ flags-bytes dims-bytes name-bytes real-bytes imag-bytes)))
1751       ))
1752     ))
1753    ))
1754
1755(define strict-read-data-element
1756  (read-data-element  read-sparse-array-data
1757                      read-num-array-data))
1758
1759
1760; Procedure:
1761; MAT5:read-data-element:: ENDIAN-PORT -> MAT5:DATA-ELEMENT
1762;
1763; Reads a MAT5 data element from the given endian port.
1764;
1765(define (MAT5:read-data-element eport)
1766  (let-values  (((data-type data-size header-bytes) 
1767                 (read-data-element-header eport)))
1768    (MAT5:debug 2 "MAT5:read-data-element: data-type = " data-type)
1769    (MAT5:debug 2 "MAT5:read-data-element: data-size = " data-size)
1770    (MAT5:debug 2 "MAT5:read-data-element: header-bytes = " header-bytes)
1771    (and data-type
1772         (let ((data
1773                (let  loop  ((i 0) (lst '()))
1774                  (if (< i data-size)
1775                      (let ((word  (strict-read-data-element eport data-type data-size)))
1776                        (if (pair? word) 
1777                            (loop (+ i (car word)) (append (cdr word) lst))
1778                            (loop (+ i (MAT5:data-element-bytes word)) (cons word lst))))
1779                      (if (= i data-size)
1780                          (reverse lst)
1781                          (MAT5:error eport "data element size mismatch: i = " i " data-size = " data-size))))))
1782           data))
1783    ))
1784
1785 
1786;--------------------------
1787;
1788; MAT-file Writing Routines
1789;
1790
1791; Procedure:
1792; write-pad-bytes:: ENDIAN-PORT ->  BYTES
1793;
1794; Writes pad bytes to a file, so that it is aligned on a 64-bit
1795; boundary. Returns the number of bytes written.
1796;
1797(define (write-pad-bytes  eport)
1798  (let* ((pos  (endian-port-pos eport))
1799         (pos1  (let loop ((pos1 pos))
1800                   (if (not (zero? (modulo pos1 8))) 
1801                       (loop (+ pos1 1)) pos1))))
1802    (if (> pos1 pos)
1803        (let* ((dx   (- pos1 pos))
1804               (bv   (make-blob dx)))
1805          (endian-port-write-byte-vector eport bv)
1806          dx)  0)))
1807
1808
1809; Procedure:
1810; MAT5:write-header:: ENDIAN-PORT * STRING * STRING -> UNDEFINED
1811;
1812; Writes a MAT5 header to the given endian port. Arguments TEXT and
1813; SUBSYS are strings. If they are longer than their maximum permitted
1814; lengths (116 and 8, respectively), they will be truncated.
1815;
1816(define (MAT5:write-header eport text subsys)
1817  (let* ((text     (let ((src   (cond ((string? text)  (string-pad-right text MAT5:header-text-size  #\nul))
1818                                      (else     (MAT5:error eport "text argument is of invalid type: " text)))))
1819                         (string->blob src)))
1820         (subsys   (let ((src   (cond ((string? subsys)  (string-pad-right subsys MAT5:header-subsys-size  #\nul))
1821                                      (else     (MAT5:error eport "subsys argument is of invalid type: " subsys))))) 
1822                         (string->blob src)))
1823         (magic    MAT5:msb-magic))
1824    (endian-port-setpos eport 0)
1825    (endian-port-write-byte-vector eport text MSB)
1826    (endian-port-write-byte-vector eport subsys MSB)
1827    (endian-port-write-int2 eport MAT5:msb-version MSB)
1828    (endian-port-write-int2 eport magic)
1829    (write-pad-bytes eport)))
1830
1831
1832; Procedure:
1833; write-num-data-element:: ENDIAN-PORT * MAT5:DATA-TYPE * VALUE -> BYTES
1834;
1835; Writes a data atom (a number or a char) to the given endian
1836; port. Returns the number of bytes written.
1837;
1838(define (write-num-data-element eport type data)
1839  (cases MAT5:data-type type
1840         (miINT8   ()     (endian-port-write-int1 eport  data))
1841         (miUINT8  ()     (endian-port-write-int1 eport  data))
1842         (miINT16  ()     (endian-port-write-int2 eport  data))
1843         (miUINT16 ()     (endian-port-write-int2 eport  data))
1844         (miINT32  ()     (endian-port-write-int4 eport  data))
1845         (miUINT32 ()     (endian-port-write-int4 eport  data))
1846         (miSINGLE ()     (endian-port-write-ieee-float32 eport  data))
1847         (miDOUBLE ()     (endian-port-write-ieee-float64 eport  data))
1848         ;;      (miINT64  ()     (endian-port-write-int8 eport  data) 8)
1849         ;;      (miUINT64 ()     (endian-port-write-int8 eport  data) 8)
1850         (miUTF8   ()     (endian-port-write-int1 eport  data))
1851         (miUTF16  ()     (endian-port-write-int2 eport  data))
1852         (miUTF32  ()     (endian-port-write-int4 eport  data))
1853         (else            (MAT5:error eport "unrecognized type " type))
1854         ))
1855
1856; Procedure:
1857; write-data-element:: ENDIAN-PORT * MAT5:DATA-TYPE * VALUE -> BYTES
1858;
1859; Writes a data atom or an array/cell/structure to the given endian
1860; port.
1861(define (write-data-element write-sparse-array-data
1862                            write-num-array-data)
1863  (let ((write-array (write-array write-sparse-array-data 
1864                                  write-num-array-data)))
1865    (lambda (eport type data . rest)
1866      (let-optionals  rest ((include-header-bytes #f))
1867        (if (MAT5:numeric-type? type)
1868            (write-num-data-element eport type data)
1869            (cases MAT5:data-type type
1870                   (miMATRIX ()     (write-array eport  data include-header-bytes))
1871                   (else            (MAT5:error eport "unrecognized type " type))
1872                   ))
1873        ))
1874    ))
1875 
1876
1877; Procedure:
1878; write-data-element-header
1879;
1880;
1881(define (write-data-element-header eport data-type data-size . rest)
1882  (let-optionals 
1883   rest ((small #f))
1884   (let ((type-word (MAT5:data-type->word data-type)))
1885     (if (and small (<= data-size 4))
1886         (let* ((bytes  (endian-port-write-int2 eport data-size))
1887                (bytes  (+ bytes (endian-port-write-int2 eport type-word))))
1888           bytes)
1889         (let* ((bytes  (endian-port-write-int4 eport type-word))
1890                (bytes  (+ bytes (endian-port-write-int4 eport data-size))))
1891           bytes)))
1892   ))
1893
1894
1895; Procedure:
1896; write-array-flags
1897;
1898;
1899(define (write-array-flags eport flags class nzmax . rest)
1900  (let-optionals 
1901   rest  ((small #f))
1902   (let* ((data-type   (miUINT32))
1903          (data-size   (* 2 (MAT5:sizeof data-type)))
1904          (flags-word  (bitwise-ior  (if (bit-vector-ref flags mxLOGICAL_FLAG) #b00000010 0)
1905                                     (if (bit-vector-ref flags mxGLOBAL_FLAG)  #b00000100 0)
1906                                     (if (bit-vector-ref flags mxCOMPLEX_FLAG) #b00001000 0)))
1907          (flags-word  (bitwise-ior (arithmetic-shift flags-word 8)
1908                                    (MAT5:array-class->word class)))
1909          (bytes       (write-data-element-header eport data-type  data-size small))
1910          (bytes       (+ bytes (endian-port-write-int4 eport flags-word)))
1911          (bytes       (+ bytes (endian-port-write-int4 eport nzmax)))
1912          (bytes       (+ bytes (write-pad-bytes eport))))
1913     bytes)))
1914     
1915         
1916; Procedure:
1917; write-array-dimensions
1918;
1919;
1920(define (write-array-dimensions eport dims . rest)
1921  (let-optionals rest  ((small #f))
1922   (if (null? dims) (MAT5:error "empty dimension list"))
1923   (if (not (MAT5:dimensions? dims)) (MAT5:error "invalid dimension list"))
1924   (let* ((data-type   (miINT32))
1925          (data-size   (* (length dims) (MAT5:sizeof data-type)))
1926          (bytes       (write-data-element-header eport data-type  data-size small))
1927          (bytes       (+ bytes 
1928                          (let loop ((dims dims) (bytes 0))
1929                            (cond ((not (null? dims))
1930                                   (let* ((dim    (car dims))
1931                                          (x      (if (eq? dim '??) 0 dim))
1932                                          (bytes  (+ bytes (endian-port-write-int4 eport x))))
1933                                     (loop (cdr dims) bytes)))
1934                                  (else bytes)))))
1935          (bytes       (+ bytes (write-pad-bytes eport))))
1936     bytes)))
1937
1938
1939; Procedure:
1940; write-array-name
1941;
1942;
1943(define (write-array-name eport name . rest)
1944  (let-optionals 
1945   rest  ((small #f))
1946   (let* ((bv          (string->blob name))
1947          (data-type   (miINT8))
1948          (data-size   (* (blob-size bv) (MAT5:sizeof data-type)))
1949          (bytes       (write-data-element-header eport data-type  data-size small))
1950          (bytes       (+ bytes (endian-port-write-byte-vector eport bv MSB)))
1951          (bytes       (+ bytes (write-pad-bytes eport))))
1952     bytes)))
1953   
1954
1955; Procedure:
1956; write-row-index
1957;
1958;
1959(define (write-row-index eport row-index . rest)
1960  (let-optionals 
1961   rest  ((small #f))
1962   (if (null? row-index) (MAT5:error "empty row-index list"))
1963   (let* ((data-type   (miINT32))
1964          (data-size   (* (length row-index) (MAT5:sizeof data-type)))
1965          (bytes       (write-data-element-header eport data-type  data-size small))
1966          (bytes       (+ bytes (let loop ((row-index row-index) (bytes 0))
1967                                  (cond ((not (null? row-index))
1968                                         (let ((bytes (+ bytes (endian-port-write-int4 eport (car row-index)))))
1969                                           (loop (cdr row-index) bytes)))))))
1970          (bytes       (+ bytes (write-pad-bytes eport))))
1971     bytes)))
1972
1973
1974; Procedure:
1975; write-col-index
1976;
1977;
1978(define (write-col-index eport col-index . rest)
1979  (let-optionals 
1980   rest  ((small #f))
1981   (if (null? col-index) (MAT5:error "empty col-index list"))
1982   (let* ((data-type   (miINT32))
1983          (data-size   (* (length col-index) (MAT5:sizeof data-type)))
1984          (bytes       (write-data-element-header eport data-type  data-size small))
1985          (bytes       (+ bytes (let loop ((col-index col-index) (bytes 0))
1986                                  (cond ((not (null? col-index))
1987                                         (let ((bytes (+ bytes (endian-port-write-int4 eport (car col-index)))))
1988                                           (loop (cdr col-index) bytes)))))))
1989          (bytes       (+ bytes (write-pad-bytes eport))))
1990     bytes)))
1991
1992
1993; Procedure:
1994; write-fieldname-len
1995;
1996;
1997(define (write-fieldname-len eport len . rest)
1998  (let-optionals 
1999   rest  ((small #f))
2000   (let* ((data-type   (miINT32))
2001          (data-size   (MAT5:sizeof data-type))
2002          (bytes       (write-data-element-header eport data-type  data-size small))
2003          (bytes       (+ bytes (endian-port-write-int4 eport len)))
2004          (bytes       (+ bytes (write-pad-bytes eport))))
2005     bytes)))
2006   
2007
2008; Procedure:
2009; write-field-names
2010;
2011;
2012(define (write-field-names eport fieldname-len field-names . rest)
2013  (let-optionals 
2014   rest  ((small #f))
2015   (if (null? field-names) (MAT5:error "empty field-names list"))
2016   (let* ((data-type   (miINT8))
2017          (data-size   (* (length field-names) (* fieldname-len (MAT5:sizeof data-type))))
2018          (bytes       (write-data-element-header eport data-type  data-size small))
2019          (bytes       (+ bytes (let loop ((field-names field-names) (bytes 0))
2020                                  (let* ((field-name  (string-pad-right (car field-names) fieldname-len #\nul))
2021                                         (bv          (string->blob field-name)))
2022                                    (let ((bytes  (+ bytes (endian-port-write-byte-vector eport bv MSB))))
2023                                      (if (null? (cdr field-names))
2024                                          bytes
2025                                          (loop (cdr field-names) bytes)))))))
2026          (bytes       (+  bytes (write-pad-bytes eport))))
2027     bytes)))
2028
2029; Procedure:
2030; write-fields
2031
2032(define (write-fields write-sparse-array-data 
2033                      write-num-array-data)
2034  (lambda (eport fields)
2035    (let ((write-data-element  (write-data-element write-sparse-array-data
2036                                                   write-num-array-data)))
2037      (let loop ((fields fields) (bytes 0))
2038        (if (null? fields)  (+ bytes (write-pad-bytes eport))
2039            (loop (cdr fields) (+ bytes (write-data-element eport (miMATRIX) (car fields) #t))))))))
2040
2041
2042; Procedure:
2043; write-struct-data
2044;
2045; the same as write-cell-data, only we expect each element of the cell
2046; to be a list of fields (MAT5 data elements), instead of individual
2047; data elements.
2048;
2049(define (write-struct-data  write-sparse-array-data
2050                            write-num-array-data)
2051  (let ((write-fields  (write-fields write-sparse-array-data
2052                                     write-num-array-data)))
2053    (lambda (eport x)
2054      (let* ((write-el    (lambda (i x ax) (+ ax (write-fields eport x))))
2055             (data-size   ((MAT5:array-foldi write-el 'col-major) x 0))
2056             (bytes       (+ data-size (write-pad-bytes eport))))
2057        bytes))))
2058   
2059
2060
2061; Procedure:
2062; write-cell-data
2063;
2064;
2065(define (write-cell-data  write-sparse-array-data
2066                          write-num-array-data)
2067  (let ((write-data-element  (write-data-element write-sparse-array-data
2068                                                 write-num-array-data)))
2069    (lambda (eport x)
2070      (let* ((write-el    (lambda (i x ax) (+ ax (write-data-element eport (miMATRIX) x #t))))
2071             (data-size   ((MAT5:array-foldi write-el 'col-major) x 0))
2072             (bytes       (+ data-size (write-pad-bytes eport))))
2073        bytes))))
2074   
2075
2076; Procedure:
2077; write-sparse-array-data
2078;
2079;
2080(define (write-sparse-array-data eport data-type x)
2081  (write-num-array-data eport data-type x))
2082   
2083
2084; Procedure:
2085; write-num-array-data
2086;
2087;
2088(define (write-num-array-data eport data-type x)
2089  (let ((begin-pos    (endian-port-pos eport))
2090        (bytes        (write-data-element-header eport data-type 0)))
2091    (let* ((write-el    (lambda (i x ax) 
2092                          (+ ax (write-num-data-element eport data-type x))))
2093           (data-size   ((array-foldi write-el 'col-major) x 0))
2094           (bytes       (+ bytes data-size (write-pad-bytes eport)))
2095           (end-pos     (endian-port-pos eport)))
2096      (endian-port-setpos eport begin-pos)
2097      (write-data-element-header eport data-type data-size)
2098      (endian-port-setpos eport end-pos)
2099      (values bytes (array-dimensions x)))))
2100   
2101
2102; Procedure:
2103; write-array
2104;
2105;
2106(define (write-array write-sparse-array-data 
2107                     write-num-array-data)
2108  (lambda (eport x . rest)
2109    (let-optionals  rest ((include-header-bytes #f))
2110    (cases MAT5:array x
2111           (MAT5:object (name dims class-name field-names fields)
2112                        (let* ((flags        (integer->bit-vector 0))
2113                               (begin-pos    (endian-port-pos eport))
2114                               (header-bytes (write-data-element-header eport (miMATRIX) 0))
2115                               (bytes        (write-array-flags eport flags (mxOBJECT_CLASS) 0 #t))
2116                               (bytes        (+ bytes (write-array-dimensions eport dims #t)))
2117                               (bytes        (+ bytes (write-array-name eport name #t)))
2118                               (bytes        (+ bytes (write-array-name eport class-name #t)))
2119                               (bytes        (+ bytes (write-fieldname-len eport MAT5:field-name-length #t)))
2120                               (bytes        (+ bytes (write-field-names eport MAT5:field-name-length
2121                                                                         field-names #t)))
2122                               (bytes        (+ bytes ((write-struct-data write-sparse-array-data
2123                                                                          write-num-array-data) eport x)))
2124                               (end-pos      (endian-port-pos eport)))
2125                          (endian-port-setpos eport begin-pos)
2126                          (write-data-element-header eport (miMATRIX) bytes)
2127                          (endian-port-setpos eport end-pos)
2128                          (if include-header-bytes (+ bytes header-bytes)
2129                              bytes)))
2130           
2131           
2132           (MAT5:structure (name dims field-names fields)
2133                           (let* ((flags        (integer->bit-vector 0))
2134                                  (begin-pos    (endian-port-pos eport))
2135                                  (header-bytes (write-data-element-header eport (miMATRIX) 0))
2136                                  (bytes        (write-array-flags eport flags (mxSTRUCT_CLASS) 0 #t))
2137                                  (bytes        (+ bytes (write-array-dimensions eport dims #t)))
2138                                  (bytes        (+ bytes (write-array-name eport name #t)))
2139                                  (bytes        (+ bytes (write-fieldname-len eport MAT5:field-name-length #t)))
2140                                  (bytes        (+ bytes (write-field-names eport MAT5:field-name-length
2141                                                                            field-names #t)))
2142                                  (bytes        (+ bytes ((write-struct-data write-sparse-array-data
2143                                                                             write-num-array-data) eport x)))
2144                                  (end-pos      (endian-port-pos eport)))
2145                             (endian-port-setpos eport begin-pos)
2146                             (write-data-element-header eport (miMATRIX) bytes)
2147                             (endian-port-setpos eport end-pos)
2148                             (if include-header-bytes (+ bytes header-bytes)
2149                                 bytes)))
2150           
2151           (MAT5:cell-array (name dims cell)
2152                            (let* ((flags        (integer->bit-vector 0))
2153                                   (begin-pos    (endian-port-pos eport))
2154                                   (header-bytes (write-data-element-header eport (miMATRIX) 0))
2155                                   (bytes        (write-array-flags eport flags (mxCELL_CLASS) 0 #t))
2156                                   (bytes        (+ bytes (write-array-dimensions eport dims #t)))
2157                                   (bytes        (+ bytes (write-array-name eport name #t)))
2158                                   (bytes        (+ bytes ((write-cell-data write-sparse-array-data
2159                                                                            write-num-array-data) 
2160                                                           eport x)))
2161                                   (end-pos      (endian-port-pos eport)))
2162                              (endian-port-setpos eport begin-pos)
2163                              (write-data-element-header eport (miMATRIX) bytes)
2164                              (endian-port-setpos eport end-pos)
2165                              (if include-header-bytes (+ bytes header-bytes)
2166                                  bytes)))
2167
2168
2169           (MAT5:sparse-array (name data-type dims row-index col-index real imag) 
2170                              (let* ((flags        (integer->bit-vector 0))
2171                                     (flags        (if imag (bit-vector-set! flags mxCOMPLEX_FLAG #t) flags))
2172                                     (nzmax        (* (length row-index) (length col-index)))
2173                                     (begin-pos    (endian-port-pos eport))
2174                                     (header-bytes (write-data-element-header eport (miMATRIX) 0))
2175                                     (bytes        (write-array-flags eport flags (mxSPARSE_CLASS) nzmax #t))
2176                                     (bytes        (+ bytes (write-array-dimensions eport dims #t)))   
2177                                     (bytes        (+ bytes (write-array-name eport name #t)))
2178                                     (bytes        (+ bytes (write-row-index eport row-index)))
2179                                     (bytes        (+ bytes (write-col-index eport col-index)))
2180                                     (bytes        (+ bytes (write-sparse-array-data eport data-type real)))
2181                                     (bytes        (if imag 
2182                                                       (+ bytes (write-sparse-array-data eport data-type imag))
2183                                                       bytes))
2184                                     (end-pos      (endian-port-pos eport)))
2185                                (endian-port-setpos eport begin-pos)
2186                                (write-data-element-header eport (miMATRIX) bytes)
2187                                (endian-port-setpos eport end-pos)
2188                                (if include-header-bytes (+ bytes header-bytes)
2189                                    bytes)))
2190           
2191           
2192           (MAT5:num-array (name data-type dims real imag)
2193                           (let* ((flags        (integer->bit-vector 0))
2194                                  (flags        (if imag (bit-vector-set! flags mxCOMPLEX_FLAG #t) flags))
2195                                  (class        (MAT5:data-type->array-class data-type))
2196                                  (begin-pos    (endian-port-pos eport))
2197                                  (header-bytes (write-data-element-header eport (miMATRIX) 0))
2198                                  (bytes        (write-array-flags eport flags class 0 #t))
2199                                  (dims-pos     (endian-port-pos eport))
2200                                  (bytes        (+ bytes (write-array-dimensions eport dims #t)))       
2201                                  (bytes        (+ bytes (write-array-name eport name #t))))
2202                             (let-values (((data-size real-dims) (write-num-array-data eport data-type real)))
2203                                         (let* ((bytes (+ bytes data-size))
2204                                                (bytes (if imag 
2205                                                           (let-values 
2206                                                            (((data-size imag-dims)
2207                                                              (write-num-array-data eport data-type imag)))
2208                                                            (+ bytes data-size))
2209                                                           bytes))
2210                                                (end-pos      (endian-port-pos eport)))
2211                                           (endian-port-setpos eport begin-pos)
2212                                           (write-data-element-header eport (miMATRIX) bytes)
2213                                           (endian-port-setpos eport dims-pos)
2214                                           (write-array-dimensions eport real-dims #t)
2215                                           (endian-port-setpos eport end-pos)
2216                                           (if include-header-bytes (+ bytes header-bytes)
2217                                               bytes)))))
2218           
2219           (else (MAT5:error "invalid array type"))
2220           ))
2221    ))
2222
2223
2224; Procedure:
2225; write-vector
2226;
2227;
2228(define (write-vector eport type vops vect)
2229 
2230  (let* ((vector-length  (alist-ref 'vector-length vops))
2231         (vector-ref     (alist-ref 'vector-ref vops))
2232         (len            (vector-length vect))
2233         (size           (* (MAT5:sizeof type) len))
2234         (bytes          (write-data-element-header eport type size))
2235         (bytes          (+ bytes (let loop ((i 0)  (bytes 0))
2236                                    (if (< i len) bytes
2237                                        (let ((v (vector-ref vect i)))
2238                                          (loop (+ i 1)  (+ bytes (write-num-data-element eport type v)))
2239                                          ))
2240                                    ))
2241                         ))
2242    (write-pad-bytes  eport)
2243    bytes))
2244
2245
2246; Procedure:
2247; write-string
2248;
2249;
2250(define (write-string eport  str)   
2251  (let* ((type  (miINT8))
2252         (size  (* (MAT5:sizeof type) (length str)))
2253         (bytes  (write-data-element-header eport type size))
2254         (bytes  (+ bytes (let loop ((chars (string->list str))  (bytes 0))
2255                            (if (null? chars) bytes
2256                                (let ((bytes (+ bytes (write-num-data-element eport type (car chars)))))
2257                                  (loop (cdr chars) bytes)))
2258                            ))
2259                 ))
2260    bytes))
2261
2262
2263(define s8vops   `((vector-ref .    ,s8vector-ref)
2264                   (vector-length . ,s8vector-length)))
2265(define u8vops   `((vector-ref .    ,u8vector-ref)
2266                   (vector-length . ,u8vector-length)))
2267(define s16vops  `((vector-ref .   ,s16vector-ref)
2268                   (vector-length . ,s16vector-length)))
2269(define u16vops  `((vector-ref .   ,u16vector-ref)
2270                   (vector-length . ,u16vector-length)))
2271(define s32vops  `((vector-ref .   ,s32vector-ref)
2272                   (vector-length . ,s32vector-length)))
2273(define u32vops  `((vector-ref .   ,u32vector-ref)
2274                   (vector-length . ,u32vector-length)))
2275;;(define s64vops  `((vector-ref .   ,s64vector-ref)
2276;;                 (vector-length . ,s64vector-length)))
2277;;(define u64vops  `((vector-ref .   ,u64vector-ref)
2278;;                 (vector-length . ,u64vector-length)))
2279(define f32vops  `((vector-ref .   ,f32vector-ref)
2280                   (vector-length . ,f32vector-length)))
2281(define f64vops  `((vector-ref .   ,f64vector-ref)
2282                   (vector-length . ,f64vector-length)))
2283
2284
2285
2286(define strict-write-data-element
2287  (write-data-element  write-sparse-array-data
2288                       write-num-array-data))
2289
2290
2291; Procedure:
2292; MAT5:write-data-element:: ENDIAN-PORT * VALUE -> BYTES
2293;
2294;
2295; Writes a MAT5 data element to the given endian port.
2296;
2297(define (MAT5:write-data-element eport data-element)
2298  (cond ((MAT5:array? data-element)  (strict-write-data-element eport (miMATRIX) data-element))
2299       
2300        ((string? data-element)      (write-string eport data-element))
2301       
2302        ((s8vector? data-element)    (write-vector eport (miINT8)   s8vops data-element))
2303
2304        ((u8vector? data-element)    (write-vector eport (miUINT8)  u8vops data-element))
2305
2306        ((s16vector? data-element)   (write-vector eport (miINT16)  s16vops data-element))
2307
2308        ((u16vector? data-element)   (write-vector eport (miUINT16) u16vops data-element))
2309
2310        ((s32vector? data-element)   (write-vector eport (miINT32)  s32vops data-element))
2311
2312        ((u32vector? data-element)   (write-vector eport (miUINT32) u32vops data-element))
2313
2314;;      ((s64vector? data-element)   (write-vector eport (miINT64)  s64vops data-element))
2315
2316;;      ((u64vector? data-element)   (write-vector eport (miUINT64) u64vops data-element))
2317
2318        ((f32vector? data-element)   (write-vector eport (miSINGLE) f32vops data-element))
2319
2320        ((f64vector? data-element)   (write-vector eport (miDOUBLE) f64vops data-element))
2321
2322        (else        (MAT5:error "element " data-element " is of unknown type"))))
2323
2324
2325
2326)
2327
Note: See TracBrowser for help on using the repository browser.