;;;; Copyright (c) 2017, Jeremy Steward
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions are met:
;;;;
;;;; 1. Redistributions of source code must retain the above copyright notice,
;;;; this list of conditions and the following disclaimer.
;;;;
;;;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;;; this list of conditions and the following disclaimer in the documentation
;;;; and/or other materials provided with the distribution.
;;;;
;;;; 3. Neither the name of the copyright holder nor the names of its
;;;; contributors may be used to endorse or promote products derived from this
;;;; software without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;;; CONSEQUENTIAL DAMAGES  INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.

;;; Input/output

;; The external representation of an array consists of a # character, followed by
;; the letter a, followed by a sequence of digits indicating the rank of the
;; array, followed by a coded representation of the storage class, all with no
;; intervening whitespace. This prefix is followed, after optional whitespace, by
;; the representation of a nested list produced as if by array->nested-list. The
;; prefix is interpreted case-insensitively.

(define (digit-from-char c)
  (case c
    ((#\0) 0)
    ((#\1) 1)
    ((#\2) 2)
    ((#\3) 3)
    ((#\4) 4)
    ((#\5) 5)
    ((#\6) 6)
    ((#\7) 7)
    ((#\8) 8)
    ((#\9) 9)
    (else
     (error "Expected a char representing a digit." c))))

(define (is-digit? c)
  (any (cute eq? <> c)
       '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))

(define (storage-class-from-identifier id)
   (cond
    ((eq? id 'v) vector-storage-class)
    ((eq? id 'u8) u8vector-storage-class)
    ((eq? id 's8) s8vector-storage-class)
    ((eq? id 'u16) u16vector-storage-class)
    ((eq? id 's16) s16vector-storage-class)
    ((eq? id 'u32) u32vector-storage-class)
    ((eq? id 's32) s32vector-storage-class)
    ((eq? id 'f32) f32vector-storage-class)
    ((eq? id 'f64) f64vector-storage-class)
    ((eq? id 'c64) c64vector-storage-class)
    ((eq? id 'c128) c128vector-storage-class)
    (else
     (error "Unknown storage-class identifier." id))))

(set-sharp-read-syntax!
 #\a
 (lambda (port)
   (let loop ((rank (digit-from-char (read-char port))))
     (cond
       ((is-digit? (peek-char))
        (loop (fx+ (fx* rank 10)
                   (digit-from-char (read-char port)))))
       (else
        (let ((storage-identifier (read))
              (nested-list (read)))
          `(quote
            ,(nested-list->array
              nested-list
              (storage-class-from-identifier storage-identifier)
              rank))))))))

;; Standard numeric storage classes are encoded by using the first few characters
;; of the name of the storage class. Thus, the representation of an array of rank
;; 2 using u32vector-storage-class begins with #a2u32. Other storage classes,
;; including vector-storage-class, sparse-storage-class, and user-created
;; storage classes, are encoded using the empty string.

;; Reads the external representation of an array from input-port (the current
;; input port if input-port is not specified) and returns the corresponding
;; array. If the coded representation of the storage class is not recognized,
;; vector-storage-class is used; this permits the addition of new coded storage
;; classes in a backward compatible way.
(define (array-read #!optional (input-port (current-input-port)))
  (let loop ((rank (digit-from-char (read-char input-port))))
    (cond
      ((is-digit? (peek-char))
       (loop (fx+ (fx* rank 10)
                  (digit-from-char (read-char input-port)))))
      (else
       (let ((storage-identifier (read))
             (nested-list (read)))
         `(quote
           ,(nested-list->array
             nested-list
             (storage-class-from-identifier storage-identifier)
             rank)))))))


(define-record-printer (array a output-port)
  (fprintf output-port
           "#a~S~S~S"
           (%array-rank a)
           (storage-class-short-id (array-storage-class a))
           (array->nested-list a)))

;; Writes the external representation of array from output-port (the current
;; output port if output-port is not specified) and returns an unspecified
;; value.
(define (array-write array #!optional (output-port (current-output-port)))
  (fprintf output-port
           "#a~S~S~S"
           (%array-rank array)
           (storage-class-short-id (array-storage-class array))
           (array->nested-list array)))