Commit 3d37e3b9346092b58e820723ae20f114dc912d44

Authored by Raymond Toy
1 parent 6c912447

Move #Q reader functions to new file qd-reader.lisp.

qd-reader.lisp:
o New file containing #Q reader functions.
o Create a new readtable containing our reader functions so we don't
  destructively modify the default *readtable*.

oct.asd:
o Add qd-reader.lisp.

qd-complex.lisp:
qd-elliptic.lisp:
qd-format.lisp:
o Set the *readtable* to *oct-readtable* before compiling these
  files.
... ... @@ -54,12 +54,14 @@
54 54 :depends-on ("qd-fun"))
55 55 (:file "qd-methods"
56 56 :depends-on ("qd-class"))
57   - (:file "qd-format"
  57 + (:file "qd-reader"
58 58 :depends-on ("qd-methods"))
  59 + (:file "qd-format"
  60 + :depends-on ("qd-methods" "qd-reader"))
59 61 (:file "qd-complex"
60   - :depends-on ("qd-methods"))
  62 + :depends-on ("qd-methods" "qd-reader"))
61 63 (:file "qd-elliptic"
62   - :depends-on ("qd-methods"))
  64 + :depends-on ("qd-methods" "qd-reader"))
63 65 ))
64 66  
65 67 (defmethod perform ((op test-op) (c (eql (find-system :oct))))
... ...
qd-complex.lisp
... ... @@ -25,6 +25,9 @@
25 25  
26 26 (in-package #:oct)
27 27  
  28 +(eval-when (:compile-toplevel :load-toplevel :execute)
  29 + (setf *readtable* *oct-readtable*))
  30 +
28 31 (defmethod add1 ((a qd-complex))
29 32 (make-instance 'qd-complex
30 33 :real (add-qd-d (qd-value (realpart a)) 1d0)
... ...
qd-elliptic.lisp
... ... @@ -24,6 +24,9 @@
24 24  
25 25 (in-package #:oct)
26 26  
  27 +(eval-when (:compile-toplevel :load-toplevel :execute)
  28 + (setf *readtable* *oct-readtable*))
  29 +
27 30 (declaim (inline descending-transform ascending-transform))
28 31  
29 32 (defun ascending-transform (u m)
... ...
qd-format.lisp
... ... @@ -25,6 +25,9 @@
25 25  
26 26 (in-package #:oct)
27 27  
  28 +(eval-when (:compile-toplevel :load-toplevel :execute)
  29 + (setf *readtable* *oct-readtable*))
  30 +
28 31 (defun qd-scale-exponent (original-x)
29 32 (let* ((x original-x))
30 33 (multiple-value-bind (sig exponent)
... ...
qd-reader.lisp 0 → 100644
  1 +;;;; -*- Mode: lisp -*-
  2 +;;;;
  3 +;;;; Copyright (c) 2007, 2008, 2011 Raymond Toy
  4 +;;;;
  5 +;;;; Permission is hereby granted, free of charge, to any person
  6 +;;;; obtaining a copy of this software and associated documentation
  7 +;;;; files (the "Software"), to deal in the Software without
  8 +;;;; restriction, including without limitation the rights to use,
  9 +;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell
  10 +;;;; copies of the Software, and to permit persons to whom the
  11 +;;;; Software is furnished to do so, subject to the following
  12 +;;;; conditions:
  13 +;;;;
  14 +;;;; The above copyright notice and this permission notice shall be
  15 +;;;; included in all copies or substantial portions of the Software.
  16 +;;;;
  17 +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  18 +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  19 +;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  20 +;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  21 +;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  22 +;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  23 +;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  24 +;;;; OTHER DEALINGS IN THE SOFTWARE.
  25 +
  26 +(in-package #:oct)
  27 +
  28 +
  29 +
  30 +(defun read-qd-real-or-complex (stream)
  31 + (let ((c (peek-char t stream)))
  32 + (cond ((char= c #\()
  33 + ;; Read a QD complex
  34 + (read-char stream) ; Skip the paren
  35 + (let ((real (read stream t nil t))
  36 + (imag (read stream t nil t)))
  37 + (unless (char= (peek-char t stream) #\))
  38 + (error "Illegal QD-COMPLEX number format"))
  39 + ;; Read closing paren
  40 + (read-char stream)
  41 + (make-instance 'qd-complex
  42 + :real (qd-value (float real +qd-real-one+))
  43 + :imag (qd-value (float imag +qd-real-one+)))))
  44 + (t
  45 + (make-instance 'qd-real :value (read-qd stream))))))
  46 +
  47 +(defun qd-class-reader (stream subchar arg)
  48 + (declare (ignore subchar))
  49 + (when arg
  50 + (warn "Numeric argument ignored in #~DQ" arg))
  51 + (read-qd-real-or-complex stream))
  52 +
  53 +(defvar *oct-readtable*
  54 + (let ((rt (copy-readtable nil)))
  55 + (set-dispatch-macro-character #\# #\Q #'qd-class-reader rt)
  56 + rt)
  57 + "Readtable that extends the standard readtable to include #q for
  58 + reading QD-REAL and QD-COMPLEX numbers")
... ...