share/numericalio/numericalio.lisp

   1 ;;  Copyright 2005 by Robert Dodier
   2
   3 ;;  This program is free software; you can redistribute it and/or
   4 ;;  modify it under the terms of the GNU General Public License.
   5
   6 ;;  This program has NO WARRANTY, not even the implied warranty of
   7 ;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
   8
   9 (in-package :maxima)
  10
  11 ;; Read functions:
  12 ;;
  13 ;;   M: read_matrix (source, sep_ch_flag)
  14 ;;   read_matrix (source, M, sep_ch_flag)
  15 ;;   A : read_array (source, sep_ch_flag)
  16 ;;   read_array (source, A, sep_ch_flag)
  17 ;;   read_hashed_array (source, A, sep_ch_flag)
  18 ;;   L: read_nested_list (source, sep_ch_flag)
  19 ;;   L: read_list (source, sep_ch_flag)
  20 ;;   read_list (source, L, sep_ch_flag)
  21 ;;
  22 ;;   read_binary_matrix (source, M)
  23 ;;   A : read_binary_array (source)
  24 ;;   read_binary_array (source, A)
  25 ;;   L: read_binary_list (source)
  26 ;;   read_binary_list (source, L)
  27 ;;
  28 ;; `source' is a file name or input stream.
  29 ;;
  30 ;; Write functions:
  31 ;;
  32 ;; `sink' is a file name or output stream.
  33 ;;
  34 ;;   write_data (X, sink, sep_ch_flag)
  35 ;;   write_binary_data (X, sink)
  36 ;;
  37 ;; Helpers:
  38 ;;
  39 ;; byte_order_flag recognized values: msb, lsb
  40 ;;
  41 ;;   assume_external_byte_order (byte_order_flag)
  42 ;;
  43
  44 (defun $assume_external_byte_order (x)
  45   (cond
  46     ((eq x '$lsb)
  47      (define-external-byte-order :lsb))
  48     ((eq x '$msb)
  49      (define-external-byte-order :msb))
  50     (t
  51       (merror "assume_external_byte_order: unrecognized byte order flag: ~a" x))))
  52
  53 (defun lisp-or-declared-maxima-array-p (x)
  54   (or (arrayp x) (mget x 'array)))
  55
  56 ;; THESE FILE-OPENING FUNCTIONS WANT TO BE MOVED TO STRINGPROC (HOME OF OTHER SUCH FUNCTIONS) !!
  57
  58 (defun $openw_binary (file)
  59    (open
  60       #+sbcl (sb-ext:native-namestring file)
  61       #-sbcl file
  62       :direction :output
  63       :if-exists :supersede
  64       :element-type '(unsigned-byte 8)
  65       :if-does-not-exist :create))
  66
  67 (defun $opena_binary (file)
  68    (open
  69       #+sbcl (sb-ext:native-namestring file)
  70       #-sbcl file
  71       :direction :output
  72       :if-exists :append
  73       :element-type '(unsigned-byte 8)
  74       :if-does-not-exist :create))
  75
  76 (defun $openr_binary (file) (open
  77                              #+sbcl (sb-ext:native-namestring file)
  78                              #-sbcl file
  79                              :element-type '(unsigned-byte 8)))
  80
  81 ;; -------------------- read functions --------------------
  82
  83 ;; ---- functions to read a matrix
  84
  85 (defun $read_matrix (stream-or-filename &rest args)
  86   (if ($matrixp (car args))
  87     (let*
  88       ((M (car args))
  89        (sep-ch-flag (cadr args))
  90        (nrow (length (cdr M)))
  91        (ncol (if (> nrow 0) (length (cdadr M)) 0))
  92        (L ($read_list stream-or-filename sep-ch-flag (* nrow ncol))))
  93       ;; COPYING DATA HERE !!
  94       (fill-matrix-from-list L M nrow ncol))
  95     (let*
  96       ((sep-ch-flag (car args))
  97        (rows-list (cdr ($read_nested_list stream-or-filename sep-ch-flag)))
  98        (rows-list-nonempty (remove-if #'(lambda (x) (= ($length x) 0)) rows-list)))
  99       `(($matrix) ,@rows-list-nonempty))))
 100
 101 (defun $read_binary_matrix (stream-or-filename M)
 102   (if ($matrixp M)
 103     (let*
 104       ((nrow (length (cdr M)))
 105        (ncol (if (> nrow 0) (length (cdadr M)) 0))
 106        (L ($read_binary_list stream-or-filename (* nrow ncol))))
 107       ;; COPYING DATA HERE !!
 108       (fill-matrix-from-list L M nrow ncol))
 109     (merror "read_binary_matrix: expected a matrix, found ~a instead" (type-of M))))
 110
 111 (defun fill-matrix-from-list (L M nrow ncol)
 112   (let ((k 0))
 113     (dotimes (i nrow)
 114       (let ((row (nth (1+ i) M)))
 115         (dotimes (j ncol)
 116           (setf (nth (1+ j) row) (nth (1+ k) L))
 117           (setq k (1+ k))))))
 118   M)
 119
 120 ;; ---- functions to read a Lisp array or Maxima declared array
 121
 122 (defun $read_array (stream-or-filename &rest args)
 123   (if (and args (lisp-or-declared-maxima-array-p (car args)))
 124     (let
 125       ((A (car args))
 126        (sep-ch-flag (and (cdr args) (cadr args)))
 127        (mode 'text))
 128       (read-into-existing-array stream-or-filename A sep-ch-flag mode))
 129     (let
 130       ((sep-ch-flag (and args (car args)))
 131        (mode 'text))
 132       (read-and-return-new-array stream-or-filename sep-ch-flag mode))))
 133
 134 (defun $read_binary_array (file-name &rest args)
 135   (if (car args)
 136     (read-into-existing-array file-name (car args) nil 'binary)
 137     (read-and-return-new-array file-name nil 'binary)))
 138
 139 (defun read-into-existing-array (file-name A sep-ch-flag mode)
 140   (if (not (arrayp A))
 141     (setq A (get (mget A 'array) 'array)))
 142   (let*
 143     ((dimensions (array-dimensions A))
 144      (n (apply #'* dimensions)))
 145     (read-into-existing-array-size-known file-name A sep-ch-flag mode n)
 146     '$done))
 147
 148 (defun read-into-existing-array-size-known (stream-or-filename A sep-ch-flag mode n)
 149   (if (streamp stream-or-filename)
 150     (read-into-existing-array-size-known-from-stream stream-or-filename A sep-ch-flag mode n)
 151     (let ((file-name (require-string stream-or-filename)))
 152       (with-open-file
 153         (in
 154             #+sbcl (sb-ext:native-namestring file-name)
 155             #-sbcl file-name
 156             :if-does-not-exist nil
 157             :element-type (if (eq mode 'text) 'character '(unsigned-byte 8)))
 158         (if (not (null in))
 159           (read-into-existing-array-size-known-from-stream in A sep-ch-flag mode n)
 160           (merror "read_array: no such file `~a'" file-name))))))
 161
 162 (defun read-into-existing-array-size-known-from-stream (in A sep-ch-flag mode n)
 163   (let (x (sep-ch (get-input-sep-ch sep-ch-flag in)))
 164     (if (eq mode 'text) (reset-for-parse-next-element))
 165     (dotimes (i n)
 166       (if (eq (setq x (if (eq mode 'text) (parse-next-element in sep-ch) (read-float-64 in))) 'eof)
 167         (return A))
 168       (setf (row-major-aref A i) x))))
 169
 170 (defun read-into-existing-array-size-unknown-from-stream (in A sep-ch mode)
 171   (let (x)
 172     (if (eq mode 'text) (reset-for-parse-next-element))
 173     (loop
 174       (if (eq (setq x (if (eq mode 'text) (parse-next-element in sep-ch) (read-float-64 in))) 'eof)
 175         (return A))
 176       (vector-push-extend x A))))
 177
 178 (defun read-and-return-new-array (stream-or-filename sep-ch-flag mode)
 179   (if (streamp stream-or-filename)
 180     (read-and-return-new-array-from-stream stream-or-filename sep-ch-flag mode)
 181     (let ((file-name (require-string stream-or-filename)))
 182       (with-open-file
 183         (in
 184             #+sbcl (sb-ext:native-namestring file-name)
 185             #-sbcl file-name
 186             :if-does-not-exist nil
 187             :element-type (if (eq mode 'text) 'character '(unsigned-byte 8)))
 188         (if (not (null in))
 189           (read-and-return-new-array-from-stream in sep-ch-flag mode)
 190           (merror "read_array: no such file `~a'" file-name))))))
 191
 192 (defun read-and-return-new-array-from-stream (in sep-ch-flag mode)
 193   (let ((A (make-array 0 :adjustable t :fill-pointer t))
 194         (sep-ch (if (eq mode 'text) (get-input-sep-ch sep-ch-flag in))))
 195     (read-into-existing-array-size-unknown-from-stream in A sep-ch mode)))
 196
 197 ;; ---- functions to read a Maxima undeclared array
 198
 199 (defun $read_hashed_array (stream-or-filename A &optional sep-ch-flag)
 200   (if (streamp stream-or-filename)
 201     (read-hashed-array-from-stream stream-or-filename A sep-ch-flag)
 202     (let ((file-name (require-string stream-or-filename)))
 203       (with-open-file (in
 204                        #+sbcl (sb-ext:native-namestring file-name)
 205                        #-sbcl file-name
 206                        :if-does-not-exist nil)
 207         (if (not (null in))
 208           (read-hashed-array-from-stream in A sep-ch-flag)
 209           (merror "read_hashed_array no such file `~a'" file-name))))))
 210
 211 (defun read-hashed-array-from-stream (in A sep-ch-flag)
 212   (let (key L (sep-ch (get-input-sep-ch sep-ch-flag in)))
 213     (loop
 214       (setq L (read-line in nil 'eof))
 215       (if (eq L 'eof) (return))
 216       (setq L (make-mlist-from-string L sep-ch))
 217       (cond
 218         ((> ($length L) 0)
 219          (setq key ($first L))
 220          (if (= ($length L) 1)
 221            (arrstore (list (list A 'array) key) nil)
 222            (arrstore (list (list A 'array) key) ($rest L)))))))
 223   A)
 224
 225 ;; ---- functions to read a list or nested list
 226
 227 (defun $read_nested_list (stream-or-filename &optional sep-ch-flag)
 228   (if (streamp stream-or-filename)
 229     (read-nested-list-from-stream stream-or-filename sep-ch-flag)
 230     (let ((file-name (require-string stream-or-filename)))
 231       (with-open-file (in
 232                        #+sbcl (sb-ext:native-namestring file-name)
 233                        #-sbcl file-name
 234                        :if-does-not-exist nil)
 235         (if (not (null in))
 236           (read-nested-list-from-stream in sep-ch-flag)
 237           (merror "read_nested_list: no such file `~a'" file-name))))))
 238
 239 (defun read-nested-list-from-stream (in sep-ch-flag)
 240   (let (A L (sep-ch (get-input-sep-ch sep-ch-flag in)))
 241     (loop
 242       (setq L (read-line in nil 'eof))
 243       (if (eq L 'eof)
 244         (return (cons '(mlist simp) (nreverse A))))
 245       (setq A (cons (make-mlist-from-string L sep-ch) A)))))
 246
 247 (defun $read_list (stream-or-filename &rest args)
 248   (if ($listp (car args))
 249     (let*
 250       ((L (car args))
 251        (sep-ch-flag (cadr args))
 252        (n (or (caddr args) ($length L))))
 253       (read-into-existing-list stream-or-filename L sep-ch-flag 'text n))
 254     (if (integerp (car args))
 255       (let ((n (car args)))
 256         (read-list stream-or-filename nil 'text n))
 257       (let ((sep-ch-flag (car args)) (n (cadr args)))
 258         (read-list stream-or-filename sep-ch-flag 'text n)))))
 259
 260 (defun read-into-existing-list (stream-or-filename L sep-ch-flag mode n)
 261   (if (streamp stream-or-filename)
 262     (read-into-existing-list-from-stream stream-or-filename L sep-ch-flag mode n)
 263     (let ((file-name (require-string stream-or-filename)))
 264       (with-open-file
 265         (in
 266             #+sbcl (sb-ext:native-namestring file-name)
 267             #-sbcl file-name
 268             :if-does-not-exist nil
 269             :element-type (if (eq mode 'text) 'character '(unsigned-byte 8)))
 270         (if (not (null in))
 271           (read-into-existing-list-from-stream in L sep-ch-flag mode n)
 272           (merror "read_list: no such file `~a'" file-name))))))
 273
 274 (defun read-into-existing-list-from-stream (in L sep-ch-flag mode n)
 275   (let (x (sep-ch (if (eq mode 'text) (get-input-sep-ch sep-ch-flag in))))
 276     (if (eq mode 'text) (reset-for-parse-next-element))
 277     (dotimes (i n)
 278       (if (eq (setq x (if (eq mode 'text) (parse-next-element in sep-ch) (read-float-64 in))) 'eof)
 279         (return))
 280       (setf (nth (1+ i) L) x))
 281     L))
 282
 283 (defun read-list (stream-or-filename sep-ch-flag mode n)
 284   (if (streamp stream-or-filename)
 285     (read-list-from-stream stream-or-filename sep-ch-flag mode n)
 286     (let ((file-name (require-string stream-or-filename)))
 287       (with-open-file
 288        (in
 289             #+sbcl (sb-ext:native-namestring file-name)
 290             #-sbcl file-name
 291             :if-does-not-exist nil
 292             :element-type (if (eq mode 'text) 'character '(unsigned-byte 8)))
 293         (if (not (null in))
 294           (read-list-from-stream in sep-ch-flag mode n)
 295           (merror "read_list: no such file `~a'" file-name))))))
 296
 297 (defun read-list-from-stream (in sep-ch-flag mode n)
 298   (let (A x (sep-ch (if (eq mode 'text) (get-input-sep-ch sep-ch-flag in))))
 299     (if (eq mode 'text) (reset-for-parse-next-element))
 300     (loop
 301       (if
 302         (or
 303           (and n (eql n 0))
 304           (eq (setq x (if (eq mode 'text) (parse-next-element in sep-ch) (read-float-64 in)))
 305               'eof))
 306         (return (cons '(mlist simp) (nreverse A))))
 307       (setq A (nconc (list x) A))
 308       (if n (decf n)))))
 309
 310 (defun $read_binary_list (stream-or-filename &rest args)
 311   (if ($listp (car args))
 312     (let*
 313       ((L (car args))
 314        (n (or (cadr args) ($length L))))
 315       (read-into-existing-list stream-or-filename L nil 'binary n))
 316     (let ((n (car args)))
 317       (read-list stream-or-filename nil 'binary n))))
 318
 319 (defun make-mlist-from-string (s sep-ch)
 320   ; scan-one-token-g isn't happy with symbol at end of string.
 321   (setq s (concatenate 'string s " "))
 322
 323   (with-input-from-string (*parse-stream* s)
 324     (let ((token) (L) (LL) (sign) (found-token) (found-sep))
 325       (loop
 326         (setq token (scan-one-token-g t 'eof))
 327         (cond
 328           ((eq token 'eof)
 329            (cond
 330              ((not (null sign))
 331               (format t "numericalio: trailing sign (~S) at end of line; strange, but just eat it.~%" sign)))
 332            (cond
 333              ((eql sep-ch #\space)
 334               (return (cons '(mlist) LL)))
 335              (t
 336                (if (or found-token found-sep)
 337                  (return (cons '(mlist) (appropriate-append L LL)))
 338                  ;; We reached EOF without encountering a token or a separator;
 339                  ;; this is an empty line.
 340                  (return '((mlist))))))))
 341         (cond
 342           ((or (eq token '$-) (eq token '$+))
 343            (setq sign (cond ((eq token '$-) -1) (t 1))))
 344           (t
 345             (cond
 346               ((not (null sign))
 347                (setq token (m* sign token))
 348                (setq sign nil)))
 349             (cond
 350               ((eql sep-ch #\space)
 351                (setq found-token token)
 352                (setq LL (append LL (list token))))
 353               (t
 354                 (cond
 355                   ((eql token sep-ch)
 356                    (setq found-sep token)
 357                    (setq L (appropriate-append L LL))
 358                    (setq LL nil))
 359                   (t
 360                     (setq found-token token)
 361                     (setq LL (append LL (list token)))))))))))))
 362
 363 (defun appropriate-append (L LL)
 364   (cond
 365     ((null LL) (append L '(nil)))
 366     ((= (length LL) 1) (append L LL))
 367     (t (append L (list (append '((mlist)) LL))))))
 368
 369 ;; ----- begin backwards compatibility stuff ... sigh -----
 370 (defun $read_lisp_array (file-name A &optional sep-ch-flag)
 371   ($read_array file-name A sep-ch-flag))
 372
 373 (defun $read_maxima_array (file-name A &optional sep-ch-flag)
 374   ($read_array file-name A sep-ch-flag))
 375 ;; -----  end backwards compatibility stuff ... sigh  -----
 376
 377 ;; ---- read one element
 378
 379 (defvar newline-symbol (intern (coerce '(#\$ #\newline) 'string)))
 380 (defvar whitespace-sans-newline (remove #\newline *whitespace-chars*))
 381
 382 (let (prev-token-sep-ch sign start-of-line)
 383
 384   (defun reset-for-parse-next-element ()
 385     (setq prev-token-sep-ch nil)
 386     (setq sign 1)
 387     (setq start-of-line t))
 388
 389   (defun parse-next-element (in sep-ch)
 390     (let
 391       ((*parse-stream* in)
 392        ;; Treat newline as a token, so leading/trailing separators can be detected,
 393        ;; when separator is anything other than a space.
 394        (*whitespace-chars* (if (eql sep-ch #\space) *whitespace-chars* whitespace-sans-newline))
 395        token)
 396       (loop
 397         (setq token (scan-one-token-g t 'eof))
 398         (cond
 399           ((eq token newline-symbol)
 400            (setq start-of-line t)
 401            (when prev-token-sep-ch
 402              (setq prev-token-sep-ch nil)
 403              (return nil)))
 404           ((eq token 'eof)
 405            (if prev-token-sep-ch
 406              (progn
 407                (setq prev-token-sep-ch nil)
 408                (return nil))
 409              (return 'eof)))
 410           ((and (eql token sep-ch) (not (eql sep-ch #\space))) ;; TEST FOR #\SPACE IS REDUNDANT
 411            ;; We have a separator token.
 412            ;; If the preceding token was also a separator,
 413            ;; or we're at the start of a line, return NIL.
 414            (if (or prev-token-sep-ch start-of-line)
 415              (progn
 416                (setq start-of-line nil)
 417                (return nil))
 418              (setq prev-token-sep-ch token)))
 419           ((prog nil (setq start-of-line nil)))
 420           ((prog nil (setq prev-token-sep-ch nil)))
 421           ((member token '($- $+))
 422            (setq sign (* sign (if (eq token '$-) -1 1))))
 423           (t
 424             (let ((return-value (m* sign token)))
 425               (setq sign 1)
 426               (return return-value))))))))
 427
 428
 429 ;; -------------------- write functions -------------------
 430
 431 (defun open-file-appropriately (file-name mode)
 432   (open
 433         #+sbcl (sb-ext:native-namestring file-name)
 434         #-sbcl file-name
 435         :direction :output
 436         :element-type (if (eq mode 'text) 'character '(unsigned-byte 8))
 437         :if-exists (if (or (eq $file_output_append '$true) (eq $file_output_append t)) :append :supersede)
 438         :if-does-not-exist :create))
 439
 440 (defun $write_data (X stream-or-filename &optional sep-ch-flag)
 441   (write-data X stream-or-filename sep-ch-flag 'text))
 442
 443 (defun $write_binary_data (X stream-or-filename)
 444   (write-data X stream-or-filename nil 'binary))
 445
 446 (defun write-data (X stream-or-filename sep-ch-flag mode)
 447   (let
 448     ((out
 449        (if (streamp stream-or-filename)
 450          stream-or-filename
 451          (open-file-appropriately (require-string stream-or-filename) mode))))
 452     (cond
 453       (($matrixp X)
 454         (write-matrix X out sep-ch-flag mode))
 455       ((arrayp X)
 456         (write-lisp-array X out sep-ch-flag mode))
 457       ((mget X 'array)
 458         (write-maxima-array X out sep-ch-flag mode))
 459       ((mget X 'hashar)
 460         (write-hashed-array X out sep-ch-flag mode))
 461       (($listp X)
 462         (write-list X out sep-ch-flag mode))
 463       (t (merror "write_data: don't know what to do with a ~M" (type-of X))))
 464     (if (streamp stream-or-filename)
 465       (finish-output out)
 466       (close out))
 467     '$done))
 468
 469 (defun write-matrix (M out sep-ch-flag mode)
 470   (let ((sep-ch (get-output-sep-ch sep-ch-flag out)))
 471     (mapcar #'(lambda (x) (write-list-lowlevel (cdr x) out sep-ch mode)) (cdr M))))
 472
 473 (defun write-lisp-array (A out sep-ch-flag mode)
 474   (let ((sep-ch (get-output-sep-ch sep-ch-flag out)) (d (array-dimensions A)))
 475     (write-lisp-array-helper A d '() out sep-ch mode)))
 476
 477 (defun write-lisp-array-helper (A d indices out sep-ch mode)
 478   (cond ((equalp (length d) 1)
 479       (let ((L '()))
 480         (loop for i from 0 to (- (car d) 1) do
 481           (let ((x (apply 'aref (append (list A) (reverse (cons i indices))))))
 482             (setq L (cons x L))))
 483         (write-list-lowlevel (reverse L) out sep-ch mode)))
 484     (t
 485       (loop for i from 0 to (- (car d) 1) do
 486         (write-lisp-array-helper A (cdr d) (cons i indices) out sep-ch mode)
 487         (if (and (eq mode 'text) (> (length d) 2))
 488           (terpri out))))))
 489
 490 (defun write-maxima-array (A out sep-ch-flag mode)
 491   (write-lisp-array (symbol-array (mget A 'array)) out sep-ch-flag mode))
 492
 493 (defun write-hashed-array (A out sep-ch-flag mode)
 494   (let
 495     ((keys (cdddr (meval (list '($arrayinfo) A))))
 496      (sep-ch (get-output-sep-ch sep-ch-flag out))
 497      L)
 498     (loop
 499       (if (not keys) (return))
 500       (setq L ($arrayapply A (car keys)))
 501       (cond ((listp L) (pop L))
 502             (t (setq L (list L))))
 503       (write-list-lowlevel (append (cdr (pop keys)) L) out sep-ch mode))))
 504
 505 (defun write-list (L out sep-ch-flag mode)
 506   (let ((sep-ch (get-output-sep-ch sep-ch-flag out)))
 507     (write-list-lowlevel (cdr L) out sep-ch mode)))
 508
 509 (defun write-list-lowlevel (L out sep-ch mode)
 510   (setq sep-ch (cond ((symbolp sep-ch) (cadr (exploden sep-ch))) (t sep-ch)))
 511   (cond
 512     ((null L) (terpri out))
 513     (t
 514       (loop
 515         (if (not L) (return))
 516         (let ((e (pop L)))
 517           (cond (($listp e)
 518               (write-list-lowlevel (cdr e) out sep-ch mode))
 519             (t
 520               (cond
 521                 ((eq mode 'text)
 522                  (let
 523                    (($lispdisp t))
 524                    (declare (special $lispdisp))
 525                    (mgrind e out))
 526                  (cond
 527                    ((null L) (terpri out))
 528                    (t (write-char sep-ch out))))
 529                 ((eq mode 'binary)
 530                  (if ($numberp e)
 531                    (write-float ($float e) out)
 532                    (merror "write_data: encountered non-numeric data in binary output")))
 533                 (t
 534                   (merror "write_data: unrecognized mode"))))))))))
 535
 536 (defun get-input-sep-ch (sep-ch-flag my-stream)
 537   (cond
 538     ((eq sep-ch-flag '$tab)
 539      (format t "numericalio: separator flag ``tab'' not recognized for input; assume ``space'' instead.~%")
 540      #\space)
 541     (t (get-output-sep-ch sep-ch-flag my-stream))))
 542
 543 (defun get-output-sep-ch (sep-ch-flag my-stream)
 544   (cond
 545     ((eq sep-ch-flag '$space) #\space)
 546     ((eq sep-ch-flag '$tab) #\tab)
 547     ((or (eq sep-ch-flag '$comma) (eq sep-ch-flag '$csv)) '$\,) ; '$csv is backwards compatibility ... sigh
 548     ((eq sep-ch-flag '$pipe) '$\|)
 549     ((eq sep-ch-flag '$semicolon) '$\;)
 550
 551     ((stringp sep-ch-flag)
 552      (if (/= (length sep-ch-flag) 1)
 553        (progn (format t "numericalio: unrecognized separator; assume ``space''.~%")
 554               #\space)
 555        (let ((would-be-sep-ch (aref sep-ch-flag 0)))
 556          (cond
 557            ((eq would-be-sep-ch #\space) #\space)
 558            ((eq would-be-sep-ch #\tab) #\tab)
 559            ((eq would-be-sep-ch #\,) '$\,)
 560            ((eq would-be-sep-ch #\|) '$\|)
 561            ((eq would-be-sep-ch #\;) '$\;)
 562            (t
 563              (format t "numericalio: separator flag ~S not recognized; assume ``space''.~%" would-be-sep-ch)
 564              #\space)))))
 565     ((null sep-ch-flag)
 566       (cond
 567         ((ignore-errors (equal (pathname-type (truename my-stream)) "csv"))
 568          '$\,)
 569         (t #\space)))
 570     (t
 571       (format t "numericalio: separator flag ~S not recognized; assume ``space''.~%" (stripdollar sep-ch-flag))
 572       #\space)))
 573
 574 (defun require-string (s)
 575   (cond
 576     ((stringp s)
 577      s)
 578     (t
 579       (merror "numericalio: expected a string, instead found a ~:M" (type-of s)))))