src/reader.lisp

   1 ;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
   2 ;; ALL RIGHTS RESERVED.
   3 ;;
   4 ;; $Id: reader.lisp,v 1.10 2004/02/20 07:23:42 yuji Exp $
   5 ;;
   6 ;; Redistribution and use in source and binary forms, with or without
   7 ;; modification, are permitted provided that the following conditions
   8 ;; are met:
   9 ;;
  10 ;;  * Redistributions of source code must retain the above copyright
  11 ;;    notice, this list of conditions and the following disclaimer.
  12 ;;  * Redistributions in binary form must reproduce the above copyright
  13 ;;    notice, this list of conditions and the following disclaimer in
  14 ;;    the documentation and/or other materials provided with the
  15 ;;    distribution.
  16 ;;
  17 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20 ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 ;;;; The ParenScript reader, used for reading Parenscript files and other
  30 ;;;; forms during the Parenscript compilation process.  The main difference
  31 ;;;; between this reader and the standard Lisp reader is that package
  32 ;;;; prefixes are SCRIPT package names rather than Lisp package names.
  33
  34 ;;; The main function, READ, will not work unless *compilation-environement*
  35 ;;; is bound to a valid Parenscript COMPILATION-ENVIRONMENT.
  36 (in-package parenscript.reader)
  37
  38 (defstruct (readtable (:predicate readtablep) (:copier nil))
  39   (syntax (make-hash-table) :type hash-table)
  40   (case :upcase :type (member :upcase :downcase :preserve :invert)))
  41
  42 (defvar *read-base* '10)
  43 (defvar *read-default-float-format* 'single-float)
  44 (defvar *read-eval* 't)
  45 (defvar *read-suppress* 'nil)
  46 (defvar *readtable*)
  47
  48
  49 (defvar *sharp-equal-alist* nil)
  50 (defvar *consing-dot-allowed* nil)
  51 (defvar *consing-dot* (gensym))
  52 (defvar *preserve-whitespace-p* nil)
  53 (defvar *input-stream* nil)
  54 (defvar *backquote-level* 0)
  55 (defvar *dispatch-macro-char* nil)
  56 (defvar *standard-readtable*)
  57
  58 (define-condition reader-error (parse-error)
  59   ((format-control :reader reader-error-format-control :initarg :format-control)
  60    (format-arguments :reader reader-error-format-arguments
  61                     :initarg :format-arguments)))
  62
  63 (define-condition invalid-character-error (reader-error)
  64   ((character :type character :reader invalid-character-error-character
  65               :initarg :character))
  66   (:report
  67    (lambda (condition stream)
  68      (format stream "Invalid character ~S is read."
  69              (invalid-character-error-character condition)))))
  70
  71 (defun reader-error (&optional format-control &rest format-arguments)
  72   (error 'reader-error
  73          :format-control format-control :format-arguments format-arguments))
  74
  75 (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
  76   (flet ((copy-syntax (src)
  77            (let ((new (make-hash-table)))
  78              (maphash
  79               #'(lambda (k v)
  80                   (let ((plist (copy-list v)))
  81                     (setf (gethash k new) plist)
  82                     (when (getf plist :dispatch-table)
  83                       (let ((hash (make-hash-table)))
  84                         (maphash #'(lambda (k v) (setf (gethash k hash) v))
  85                                  (getf plist :dispatch-table))
  86                         (setf (getf plist :dispatch-table) hash)))))
  87               src)
  88              new)))
  89     (let ((from (or from-readtable *standard-readtable*)))
  90       (if to-readtable
  91           (prog1 to-readtable
  92             (setf (readtable-syntax to-readtable)
  93                   (copy-syntax (readtable-syntax from)))
  94             (setf (readtable-case to-readtable) (readtable-case from)))
  95           (make-readtable :syntax (copy-syntax (readtable-syntax from))
  96                           :case (readtable-case from))))))
  97
  98 (defun syntax-type (char &optional (readtable *readtable*))
  99   (let ((plist (gethash char (readtable-syntax readtable))))
 100     (getf plist :syntax :constituent)))
 101
 102 (defun get-macro-character (char &optional (readtable *readtable*))
 103   (unless readtable (setq readtable *standard-readtable*))
 104   (let ((plist (gethash char (readtable-syntax readtable))))
 105     (case (syntax-type char readtable)
 106       (:terminating-macro-char (values (getf plist :macro-function) nil))
 107       (:non-terminating-macro-char (values (getf plist :macro-function) t))
 108       (t (values nil nil)))))
 109
 110 (defun set-macro-character (char new-function
 111                             &optional non-terminating-p (readtable *readtable*))
 112   (check-type char character)
 113 ;  (check-type new-function function-designator)
 114   (when (null readtable)
 115     (error "Standard readtable must not be changed."))
 116   (let ((plist (gethash char (readtable-syntax readtable))))
 117     (setf (getf plist :syntax) (if non-terminating-p
 118                                    :non-terminating-macro-char
 119                                    :terminating-macro-char)
 120           (getf plist :macro-function) new-function
 121           (gethash char (readtable-syntax readtable)) plist))
 122   t)
 123
 124 (defun get-dispatch-macro-character (disp-char sub-char
 125                                      &optional (readtable *readtable*))
 126   (unless readtable (setq readtable *standard-readtable*))
 127   (unless (eq (get-macro-character disp-char readtable)
 128               'dispatch-macro-character)
 129     (error "~S is not a dispatching macro character." disp-char))
 130   (let* ((syntax-table (readtable-syntax readtable))
 131          (dispatch-table (getf (gethash disp-char syntax-table) :dispatch-table))
 132          (sub-char (char-upcase sub-char)))
 133     (multiple-value-bind (value present-p) (gethash sub-char dispatch-table)
 134       (cond
 135         ((digit-char-p sub-char 10) nil)
 136         (present-p value)
 137         (t
 138          #'(lambda (stream sub-char number)
 139              (declare (ignore stream number))
 140              (reader-error "No dispatch function defined for ~S." sub-char)))))))
 141
 142 (defun set-dispatch-macro-character (disp-char sub-char new-function
 143                                      &optional (readtable *readtable*))
 144   (when (null readtable) (error "Standard readtable must not be changed."))
 145   (unless (eq (get-macro-character disp-char readtable)
 146               'dispatch-macro-character)
 147     (error "~S is not a dispatch character." disp-char))
 148   (let* ((syntax-table (readtable-syntax readtable))
 149          (dispatch-table (getf (gethash disp-char syntax-table) :dispatch-table))
 150          (sub-char (char-upcase sub-char)))
 151     (setf (gethash sub-char dispatch-table) new-function)
 152     t))
 153
 154 (defun make-dispatch-macro-character (char &optional non-terminating-p
 155                                       (readtable *readtable*))
 156   (when (null readtable) (error "Standard readtable must not be changed."))
 157   (set-macro-character char 'dispatch-macro-character
 158                        non-terminating-p readtable)
 159
 160   (setf (getf (gethash char (readtable-syntax readtable)) :dispatch-table)
 161         (make-hash-table))
 162   t)
 163
 164 (defun dispatch-macro-character (stream char)
 165   (let ((n (when (digit-char-p (peek-char nil stream t nil t) 10)
 166              (loop
 167               with n = 0
 168               for digit = (read-char stream t nil t)
 169               do (setq n (+ (* n 10) (digit-char-p digit 10)))
 170               while (digit-char-p (peek-char nil stream t nil t) 10)
 171               finally (return n))))
 172         (*dispatch-macro-char* char)
 173         (sub-char (char-upcase (read-char stream t nil t))))
 174     (funcall (get-dispatch-macro-character char sub-char) stream sub-char n)))
 175
 176 (defun set-syntax-from-char (to-char from-char
 177                              &optional (to-readtable *readtable*)
 178                              (from-readtable *standard-readtable*))
 179   (check-type to-char character)
 180   (check-type from-char character)
 181   (check-type to-readtable readtable)
 182   (unless from-readtable (setq from-readtable *standard-readtable*))
 183   (check-type from-readtable readtable)
 184   (let ((plist (copy-list (gethash from-char
 185                                    (readtable-syntax from-readtable)))))
 186     (when (getf plist :dispatch-table)
 187       (let ((hash (make-hash-table)))
 188         (maphash #'(lambda (k v) (setf (gethash k hash) v))
 189                  (getf plist :dispatch-table))
 190         (setf (getf plist :dispatch-table) hash)))
 191     (setf (gethash to-char (readtable-syntax to-readtable)) plist)
 192     t))
 193
 194 ;; (defmacro with-standard-io-syntax (&rest forms)
 195 ;;   `(let ((*package* (find-package "CL-USER"))
 196 ;;          (*print-array* t)
 197 ;;          (*print-base* 10)
 198 ;;          (*print-case* :upcase)
 199 ;;          (*print-circle* nil)
 200 ;;          (*print-escape* t)
 201 ;;          (*print-gensym* t)
 202 ;;          (*print-length* nil)
 203 ;;          (*print-level* nil)
 204 ;;          (*print-lines* nil)
 205 ;;          (*print-miser-width* nil)
 206 ;;          ;;(*print-pprint-dispatch* *standard-print-pprint-dispatch*)
 207 ;;          (*print-pretty* nil)
 208 ;;          (*print-radix* nil)
 209 ;;          (*print-readably* t)
 210 ;;          (*print-right-margin* nil)
 211 ;;          (*read-base* 10)
 212 ;;          (*read-default-float-format* 'single-float)
 213 ;;          (*read-eval* t)
 214 ;;          (*read-suppress* nil)
 215 ;;          (*readtable* (copy-readtable nil)))
 216 ;;     ,@forms))
 217
 218
 219 (defun read-preserving-whitespace (&optional (input-stream *standard-input*)
 220                                    (eof-error-p t) eof-value recursive-p)
 221   (let ((*preserve-whitespace-p* (if recursive-p *preserve-whitespace-p* t)))
 222     (declare (special *preserve-whitespace-p*))
 223     (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
 224
 225 (defun read (&optional (input-stream *standard-input*)
 226              (eof-error-p t) eof-value recursive-p)
 227   (let ((*preserve-whitespace-p* (when recursive-p *preserve-whitespace-p*)))
 228     (declare (special *preserve-whitespace-p*))
 229     (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
 230
 231 (defun read-from-string (string &optional (eof-error-p t) eof-value
 232                          &key (start 0) end preserve-whitespace)
 233   (let ((index nil))
 234     (values (with-input-from-string (stream string :index index
 235                                             :start start :end end)
 236               (funcall (if preserve-whitespace
 237                            #'read-preserving-whitespace
 238                            #'read)
 239                        stream eof-error-p eof-value))
 240             index)))
 241
 242 (defun make-str (chars)
 243   (make-array (length chars) :element-type 'character :initial-contents chars))
 244
 245 (defun read-list (char &optional (stream *standard-input*) recursive-p
 246                   &key allow-consing-dot)
 247   (let ((*sharp-equal-alist* (when recursive-p *sharp-equal-alist*))
 248         (*consing-dot-allowed* allow-consing-dot)
 249         c stack values)
 250     (loop
 251      (setq c (peek-char t stream t nil t))
 252      (when (char= char c)
 253        (when (eq (first stack) *consing-dot*)
 254          (error "Nothing appears after . in list."))
 255        (read-char stream t nil t)
 256        (if (eq (second stack) *consing-dot*)
 257            (return (nreconc (cddr stack) (first stack)))
 258            (return (nreverse stack))))
 259      (when (setq values (multiple-value-list (lisp-object? stream t nil t)))
 260        (if (eq (second stack) *consing-dot*)
 261            (error "More than one object follows . in list.")
 262            (push (car values) stack))))))
 263
 264 (defun read-delimited-list (char &optional (stream *standard-input*) recursive-p)
 265   (let ((list (read-list char stream recursive-p)))
 266     (unless *read-suppress* list)))
 267
 268 (defun lisp-object? (stream eof-error-p eof-value recursive-p)
 269   (loop
 270    (let* ((c (read-char stream eof-error-p eof-value recursive-p)))
 271      (when (and (not eof-error-p) (eq c eof-value)) (return eof-value))
 272      (ecase (syntax-type c)
 273        (:invalid (error 'invalid-character-error :character c))
 274        (:whitespace 'skip)
 275        ((:single-escape :multiple-escape :constituent)
 276         (return (read-number-or-symbol stream c)))
 277        ((:terminating-macro-char :non-terminating-macro-char)
 278         (return (funcall (get-macro-character c) stream c)))))))
 279
 280 (defun read-lisp-object (stream eof-error-p eof-value recursive-p)
 281   (let ((*sharp-equal-alist* (when recursive-p *sharp-equal-alist*)))
 282     (loop
 283      (let ((values (multiple-value-list (lisp-object? stream
 284                                                       eof-error-p eof-value
 285                                                       recursive-p))))
 286        (when values (return (unless *read-suppress* (car values))))))))
 287
 288 (defun read-ch () (read-char *input-stream* nil nil t))
 289 (defun read-ch-or-die () (read-char *input-stream* t nil t))
 290 (defun unread-ch (c) (unread-char c *input-stream*))
 291
 292 (defun collect-escaped-lexemes (c)
 293   (ecase (syntax-type c)
 294     (:invalid (error 'invalid-character-error :character c))
 295     (:multiple-escape nil)
 296     (:single-escape (cons (read-ch-or-die)
 297                           (collect-escaped-lexemes (read-ch-or-die))))
 298     ((:constituent
 299       :whitespace :terminating-macro-char :non-terminating-macro-char)
 300      (cons c (collect-escaped-lexemes (read-ch-or-die))))))
 301
 302 (defun collect-lexemes (c &optional (stream *input-stream*))
 303   (let ((*input-stream* stream))
 304     (when c
 305       (ecase (syntax-type c)
 306         (:invalid (error 'invalid-character-error :character c))
 307         (:whitespace (when *preserve-whitespace-p* (unread-ch c)))
 308         (:terminating-macro-char (unread-ch c))
 309         (:multiple-escape (cons (collect-escaped-lexemes (read-ch-or-die))
 310                                 (collect-lexemes (read-ch))))
 311         (:single-escape (cons (list (read-ch-or-die))
 312                               (collect-lexemes (read-ch))))
 313         ((:constituent :non-terminating-macro-char)
 314          (cons c (collect-lexemes (read-ch))))))))
 315
 316 ;; integer  ::= [sign] decimal-digit+ decimal-point
 317 ;;            | [sign] digit+
 318 ;; ratio    ::= [sign] {digit}+ slash {digit}+
 319 ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
 320 ;;            | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
 321 ;; exponent ::= exponent-marker [sign] {digit}+
 322
 323 (defun construct-number (chars)
 324   (labels ((sign ()
 325              (let ((c (and chars (car chars))))
 326                (cond
 327                  ((eql c #\-) (pop chars) -1)
 328                  ((eql c #\+) (pop chars) +1)
 329                  (t +1))))
 330            (digit* (&optional (base *read-base*))
 331              (let ((pos (or (position-if-not #'(lambda (d) (digit-char-p d base))
 332                                              chars)
 333                             (length chars))))
 334                (prog1 (subseq chars 0 pos)
 335                  (setq chars (subseq chars pos)))))
 336            (int? (sign digits &optional (base *read-base*))
 337              (when (and digits
 338                         (every #'(lambda (d) (digit-char-p d base)) digits))
 339                (* sign (reduce #'(lambda (a b) (+ (* base a) b))
 340                                (mapcar #'(lambda (d) (digit-char-p d base))
 341                                        digits)))))
 342            (float? (sign)
 343              (let* ((int (digit* 10))
 344                     (fraction (when (eql (car chars) #\.)
 345                                 (pop chars) (digit* 10)))
 346                     (exp-marker (when (and chars
 347                                            (find (char-upcase (car chars))
 348                                                  '(#\D #\E #\F #\L #\S)))
 349                                   (char-upcase (pop chars))))
 350                     (exp-sign (and exp-marker (sign)))
 351                     (exp-digits (and exp-sign (digit*))))
 352                (when (and (null chars)
 353                           (or fraction (and int exp-marker exp-digits)))
 354                  (float (* (int? sign (append int fraction) 10)
 355                            (expt 10 (- (or (int? exp-sign exp-digits 10) 0)
 356                                        (length fraction))))
 357                         (ecase (or exp-marker *read-default-float-format*)
 358                           (#\E                1.0e0)
 359                           ((#\D double-float) 1.0d0)
 360                           ((#\F single-float) 1.0f0)
 361                           ((#\L long-float)   1.0l0)
 362                           ((#\S short-float)  1.0s0)))))))
 363     (let ((sign (sign))
 364           pos numerator denominator)
 365       (when chars
 366         (or
 367          ;; [sign] digit+
 368          (int? sign chars)
 369          ;; [sign] decimal-digit+ decimal-point
 370          (and (eql (car (last chars)) #\.) (int? sign (butlast chars) 10))
 371          ;; [sign] {digit}+ slash {digit}+
 372          (and (setq pos (position #\/ chars))
 373               (setq numerator (int? sign (subseq chars 0 pos)))
 374               (setq denominator (int? 1 (subseq chars (1+ pos))))
 375               (not (zerop denominator))
 376               (/ numerator denominator))
 377          ;; [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
 378          ;; [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
 379          (float? sign))))))
 380
 381 (defun ensure-external-symbol (name package)
 382   "Ensures that the symbol with name NAME is external for the given script package PACKAGE.
 383 Raises a continuable error if NAME is not external in PACKAGE.  Otherwise interns NAME
 384 in PACKAGE and returns the symbol."
 385   (if package
 386       (multiple-value-bind (symbol status)
 387           (find-script-symbol name package)
 388         (unless (eq status :external)
 389           (cerror (if (null status)
 390                       "Intern and export script symbol ~S in package ~S."
 391                       "Export script symbol ~S in package ~S.")
 392                   "There is no external symbol by the name of ~S in script package ~S."
 393                   name package)
 394           (script-export (setq symbol (script-intern name package)) package))
 395         symbol)
 396       (script-intern name "KEYWORD")))
 397
 398 (defun construct-symbol (lexemes &key uninterned-symbol-wanted)
 399   (labels ((up (x) (if (listp x) (copy-list x) (list (char-upcase x))))
 400            (down (x) (if (listp x) (copy-list x) (list (char-downcase x))))
 401            (chars (lexemes)
 402              (ecase (readtable-case *readtable*)
 403                (:upcase (mapcan #'up lexemes))
 404                (:downcase (mapcan #'down lexemes))
 405                (:invert
 406                 (let ((unescaped (remove-if-not #'alpha-char-p
 407                                                 (remove-if #'listp lexemes))))
 408                   (mapcan (cond
 409                             ((every #'upper-case-p unescaped) #'down)
 410                             ((every #'lower-case-p unescaped) #'up)
 411                             (t #'(lambda (x)
 412                                    (if (listp x) (copy-list x) (list x)))))
 413                           lexemes)))
 414                (:preserve (mapcan #'(lambda (x)
 415                                       (if (listp x) (copy-list x) (list x)))
 416                                   lexemes))))
 417            (name (lexemes)
 418              (when (and (find #\: lexemes) t)
 419 ;;                        (not *intern-package-prefixes*))
 420                (error "Too many package markers."))
 421              (make-str (chars lexemes))))
 422     (let* ((pos (position #\: lexemes))
 423            (external-p (and pos (not (eql (nth (1+ pos) lexemes) #\:))))
 424            (package (when pos (name (subseq lexemes 0 pos))))
 425            (script-package (find-script-package package))
 426            (name (name (subseq lexemes (if pos (+ pos (if external-p 1 2)) 0)))))
 427       (values (cond
 428                (uninterned-symbol-wanted
 429                 (if package
 430                     (reader-error)
 431                     (make-symbol name)))
 432                (external-p
 433                 (ensure-external-symbol name script-package))
 434                (t (script-intern name
 435                                  (or script-package
 436                                      (parenscript::comp-env-current-package
 437                                       *compilation-environment*)))))))))
 438
 439 (defun read-number-or-symbol (stream c)
 440   (let ((lexemes (collect-lexemes c stream)))
 441     (assert lexemes)
 442     (unless *read-suppress*
 443       (cond
 444         ((and lexemes (every #'(lambda (x) (eql x #\.)) lexemes))
 445          (when (rest lexemes)
 446            (reader-error "Tokens consisting of only dots are invalid."))
 447          (when (not *consing-dot-allowed*)
 448            (reader-error "Consing dot is not allowed."))
 449          *consing-dot*)
 450         (t
 451          (or (and (every #'characterp lexemes) (construct-number lexemes))
 452              (construct-symbol lexemes)))))))
 453
 454
 455 ;; backquote
 456 (defmacro define-constant (name value &optional doc)
 457   `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
 458      ,@(when doc (list doc))))
 459 (define-constant backquote (gensym))
 460 (define-constant backquote-comma (gensym))
 461 (define-constant backquote-comma-at (gensym))
 462 (define-constant backquote-comma-dot (gensym))
 463
 464 (defun backquoted-expression-type (exp)
 465   (if (atom exp)
 466       :normal
 467       (cond
 468         ((eq (first exp) backquote-comma) :comma)
 469         ((eq (first exp) backquote-comma-at) :comma-at)
 470         ((eq (first exp) backquote-comma-dot) :comma-dot)
 471         (t :normal))))
 472
 473 (defmacro backquote (object)
 474   (if (atom object)
 475       (if (simple-vector-p object)
 476           (list 'apply #'vector (list backquote (concatenate 'list object)))
 477           (list 'quote object))
 478       (let* ((list (copy-list object))
 479              (last (loop for x = list then (cdr x)
 480                          until (or (atom (cdr x))
 481                                    (find (cadr x) (list backquote
 482                                                         backquote-comma
 483                                                         backquote-comma-at
 484                                                         backquote-comma-dot)))
 485                          finally (return (prog1 (cdr x) (setf (cdr x) nil)))))
 486              (types (mapcar #'backquoted-expression-type list)))
 487         (append
 488          (cons (if (notany #'(lambda (x) (eq x :comma-at)) types) 'nconc 'append)
 489                (mapcar #'(lambda (x)
 490                            (ecase (backquoted-expression-type x)
 491                              (:normal (list 'list (list 'backquote x)))
 492                              (:comma (list 'list x))
 493                              ((:comma-at :comma-dot) x)))
 494                        list))
 495          (list (ecase (backquoted-expression-type last)
 496                  (:normal (list 'quote last))
 497                  (:comma last)
 498                  (:comma-at (error ",@ after dot"))
 499                  (:comma-dot (error ",. after dot"))))))))
 500
 501 (defmacro backquote-comma (obj) obj)
 502 (setf (macro-function backquote) (macro-function 'backquote))
 503 (setf (macro-function backquote-comma) (macro-function 'backquote-comma))
 504 (setf (macro-function backquote-comma-at) (macro-function 'backquote-comma))
 505 (setf (macro-function backquote-comma-dot) (macro-function 'backquote-comma))
 506
 507
 508 (defun read-comma-form (stream c)
 509   (declare (ignore c))
 510   (unless (> *backquote-level* 0)
 511     (error "Comma must be used in a backquoted expression."))
 512   (let ((*backquote-level* (1- *backquote-level*)))
 513     (case (peek-char t stream t nil t)
 514       (#\@ (read-char stream t nil t)
 515            (list backquote-comma-at (read stream t nil t)))
 516       (#\. (read-char stream t nil t)
 517            (list backquote-comma-dot (read stream t nil t)))
 518       (t (list backquote-comma (read stream t nil t))))))
 519
 520 (defun read-backquoted-expression (stream c)
 521   (declare (ignore c))
 522   (let ((*backquote-level* (1+ *backquote-level*)))
 523     (list backquote (read stream t nil t))))
 524
 525
 526 (defun sharp-backslash (stream sub-char n)
 527   (declare (ignore n))
 528   (let* ((lexemes (collect-lexemes sub-char stream))
 529          (str (make-str (mapcan #'(lambda (x)
 530                                     (if (listp x) (copy-list x) (list x)))
 531                                 lexemes))))
 532     (unless *read-suppress*
 533       (cond
 534         ((= 1 (length str)) (char str 0))
 535         ((name-char str))
 536         (t (reader-error "Unrecognized character name: ~S" str))))))
 537
 538 (defun sharp-single-quote (stream sub-char n)
 539   (declare (ignore sub-char n))
 540   `(function ,(read stream t nil t)))
 541
 542 (defun sharp-left-parenthesis (stream sub-char n)
 543   (declare (ignore sub-char))
 544   (let ((list (read-delimited-list #\) stream t)))
 545     (unless *read-suppress*
 546       (when (and n (> (length list) n))
 547         (reader-error "vector is longer than specified length #~A*~A."
 548                       n list))
 549       (apply #'vector
 550              (if (and n (< (length list) n))
 551                  (append list (make-list (- n (length list))
 552                                          :initial-element (car (last list))))
 553                  list)))))
 554
 555 (defun sharp-asterisk (stream sub-char n)
 556   (declare (ignore sub-char))
 557   (let* ((*input-stream* stream)
 558          (lexemes (collect-lexemes (read-ch)))
 559          (bits (mapcar #'(lambda (d)
 560                            (unless (characterp d)
 561                              (error "Binary digit must be given"))
 562                            (digit-char-p d 2)) lexemes)))
 563     (unless *read-suppress*
 564       (unless (every #'(lambda (d) (digit-char-p d 2)) lexemes)
 565         (reader-error "Illegal bit vector format."))
 566       (when (and n (> (length bits) n))
 567         (reader-error "Bit vector is longer than specified length #~A*~A."
 568                       n (make-str lexemes)))
 569       (when (and n (> n 0) (zerop (length bits)))
 570         (reader-error
 571          "At least one bit must be given for non-zero #* bit-vectors."))
 572       (make-array (or n (length bits)) :element-type 'bit
 573                   :initial-contents
 574                   (if (and n (< (length bits) n))
 575                       (append bits
 576                               (make-list (- n (length bits))
 577                                          :initial-element (car (last bits))))
 578                       bits)))))
 579
 580 (defun sharp-colon (stream sub-char n)
 581   (declare (ignore sub-char n))
 582   (let* ((*input-stream* stream)
 583          (lexemes (collect-lexemes (read-ch))))
 584     (unless *read-suppress*
 585       (construct-symbol lexemes :uninterned-symbol-wanted t))))
 586
 587 (defun sharp-dot (stream sub-char n)
 588   (declare (ignore sub-char n))
 589   (let ((object (read stream t nil t)))
 590     (unless *read-suppress*
 591       (unless *read-eval*
 592         (reader-error "Attempt to read #. while *READ-EVAL* is bound to NIL."))
 593       (eval object))))
 594
 595 (defun sharp-b (stream sub-char n)
 596   (declare (ignore n))
 597   (sharp-r stream sub-char 2))
 598
 599 (defun sharp-o (stream sub-char n)
 600   (declare (ignore n))
 601   (sharp-r stream sub-char 8))
 602
 603 (defun sharp-x (stream sub-char n)
 604   (declare (ignore n))
 605   (sharp-r stream sub-char 16))
 606
 607 (defun sharp-r (stream sub-char n)
 608   (cond
 609     (*read-suppress* (read stream t nil t))
 610     ((not n) (reader-error "Radix missing in #R."))
 611     ((not (<= 2 n 36)) (reader-error "Illegal radix for #R: ~D." n))
 612     (t (let ((rational (let ((*read-base* n)) (read stream t nil t))))
 613          (unless (typep rational 'rational)
 614            (reader-error "#~A (base ~D) value is not a rational: ~S."
 615                          sub-char n rational))
 616          rational))))
 617
 618
 619 (defun sharp-c (stream sub-char n)
 620   (declare (ignore sub-char n))
 621   (let ((pair (read stream t nil t)))
 622     (unless *read-suppress*
 623       (unless (and (listp pair) (= (length pair) 2))
 624         (reader-error "Illegal complex number format: #C~S" pair))
 625       (complex (first pair) (second pair)))))
 626
 627 (defun sharp-a (stream sub-char rank)
 628   (declare (ignore sub-char))
 629   (cond
 630     (*read-suppress* (read stream t nil t))
 631     ((null rank)
 632      (reader-error "Rank for #A notation is missing."))
 633     (t (let* ((contents (read stream t nil t))
 634               (dimensions (loop repeat rank
 635                                 for x = contents then (first x)
 636                                 collect (length x))))
 637          (make-array dimensions :initial-contents contents)))))
 638
 639
 640 (defun find-default-constructor (name)
 641   (declare (ignore name)))
 642
 643 (defun sharp-s (stream sub-char n)
 644   (declare (ignore sub-char n))
 645   (let ((structure-spec (read stream t nil t)))
 646     (unless *read-suppress*
 647       (unless (listp structure-spec)
 648         (reader-error "Non list follows #S."))
 649       (unless (symbolp (first structure-spec))
 650         (reader-error "Structure type is not a symbol: ~S" (car structure-spec)))
 651       (let* ((name (first structure-spec))
 652              (plist (loop
 653                      for list on (rest structure-spec) by #'cddr
 654                      append (list (intern (string (first list)) "KEYWORD")
 655                                   (second list))))
 656              (class (find-class name nil)))
 657         (unless (typep class 'structure-class)
 658           (reader-error "~S is not a defined structure type." name))
 659         (let ((constructor (find-default-constructor name)))
 660           (apply constructor plist))))))
 661
 662 (defun sharp-p (stream sub-char n)
 663   (declare (ignore sub-char n))
 664   (let ((namestring (read stream t nil t)))
 665     (unless *read-suppress* (parse-namestring namestring))))
 666
 667 (defun container-subst (new old tree
 668                         &optional (done (make-hash-table :test 'eq)))
 669   (cond
 670     ((eq tree old) new)
 671     ((gethash tree done) tree)
 672     (t (setf (gethash tree done) t)
 673        (typecase tree
 674          (null nil)
 675          (cons (setf (car tree) (container-subst new old (car tree) done)
 676                      (cdr tree) (container-subst new old (cdr tree) done))
 677                tree)
 678          (array (loop for i below (array-total-size tree)
 679                       do (setf (row-major-aref tree i)
 680                                (container-subst new old
 681                                                 (row-major-aref tree i) done)))
 682                 tree)
 683          (t tree)))))
 684
 685 (defun sharp-equal (stream sub-char n)
 686   (declare (ignore sub-char))
 687   (if *read-suppress*
 688       (values)
 689       (let* ((this (gensym))
 690              (object (let ((*sharp-equal-alist* (acons n this
 691                                                        *sharp-equal-alist*)))
 692                        (read stream t nil t)))
 693              (assoc (assoc n *sharp-equal-alist*)))
 694         (when (null n)
 695           (reader-error "Missing label number for #=."))
 696         (when assoc
 697           (reader-error "#~D= is already defined." n))
 698         (setq *sharp-equal-alist* (acons n object *sharp-equal-alist*))
 699         (when (eq object this)
 700           (reader-error "need to tag something more than just #~D#." n))
 701         (container-subst object this object))))
 702
 703 (defun sharp-sharp (stream sub-char n)
 704   (declare (ignore sub-char stream))
 705   (unless *read-suppress*
 706     (unless n (reader-error "Label is missing for ##."))
 707     (let ((assoc (assoc n *sharp-equal-alist*)))
 708       (unless assoc
 709         (reader-error "No object labeld ~D is defined." n))
 710       (cdr assoc))))
 711
 712 (defun featurep (x)
 713   (if (atom x)
 714       (member x *features*)
 715       (ecase (first x)
 716         (:not (not (featurep (second x))))
 717         (:and (every #'featurep (rest x)))
 718         (:or (some #'featurep (rest x))))))
 719
 720 (defun read-feature-test (stream)
 721   (let ((*package* (or (find-package "KEYWORD")
 722                        (error "KEYWORD package not found."))))
 723     (read stream t nil t)))
 724
 725 (defun sharp-plus (stream sub-char n)
 726   (declare (ignore sub-char n))
 727   (if (featurep (read-feature-test stream))
 728       (read stream t nil t)
 729       (let ((*read-suppress* t)) (read stream t nil t) (values))))
 730
 731 (defun sharp-minus (stream sub-char n)
 732   (declare (ignore sub-char n))
 733   (if (not (featurep (read-feature-test stream)))
 734       (read stream t nil t)
 735       (let ((*read-suppress* t)) (read stream t nil t) (values))))
 736
 737 (defun sharp-vertical-bar (stream sub-char n)
 738   (declare (ignore sub-char n))
 739   (loop for c = (read-char stream t nil t)
 740         if (and (char= c #\#) (char= (read-char stream t nil t) #\|))
 741         do (sharp-vertical-bar stream #\| nil)
 742         until (and (char= c #\|) (char= (read-char stream t nil t) #\#)))
 743   (values))
 744
 745 (defun sharp-l (stream sub-char n)
 746   "#L uses the Lisp reader for the next form."
 747   (declare (ignore sub-char n))
 748   (cl:read stream))
 749
 750
 751 (defvar *standard-syntax-table*
 752   (let ((table (make-hash-table)))
 753     (mapc #'(lambda (x)
 754               (let ((syntax (first x))
 755                     (chars (rest x)))
 756                 (dolist (c chars)
 757                   (setf (gethash c table) `(:syntax ,syntax)))))
 758           '((:whitespace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space)
 759             (:single-escape #\\)
 760             (:multiple-escape #\|)))
 761     table))
 762
 763 (setq *standard-readtable* (make-readtable :syntax *standard-syntax-table*))
 764
 765 (set-macro-character #\` 'read-backquoted-expression nil *standard-readtable*)
 766 (set-macro-character #\, 'read-comma-form nil *standard-readtable*)
 767
 768 (set-macro-character #\( #'(lambda (stream char)
 769                              (declare (ignore char))
 770                              (read-list #\) stream t :allow-consing-dot t))
 771                      nil *standard-readtable*)
 772
 773 (set-macro-character #\) #'(lambda (stream char)
 774                              (declare (ignore stream char))
 775                              (error "Unmatched close parenthesis."))
 776                      nil *standard-readtable*)
 777
 778 (set-macro-character #\' #'(lambda (stream char)
 779                              (declare (ignore char))
 780                              `(quote ,(read stream t nil t)))
 781                      nil *standard-readtable*)
 782
 783 (set-macro-character #\; #'(lambda (stream char)
 784                              (declare (ignore char))
 785                              (loop
 786                               for c = (read-char stream nil nil t)
 787                               until (or (null c) (eql c #\Newline)))
 788                              (values))
 789                      nil *standard-readtable*)
 790
 791 (set-macro-character #\" #'(lambda (stream char)
 792                              (declare (ignore char))
 793                              (loop
 794                               for c = (read-char stream t nil t)
 795                               until (char= c #\")
 796                               if (eq :single-escape (syntax-type c))
 797                               collect (read-char stream t nil t) into chars
 798                               else
 799                               collect c into chars
 800                               finally
 801                               (return (make-array (length chars)
 802                                                   :element-type 'character
 803                                                   :initial-contents chars))))
 804                      nil *standard-readtable*)
 805
 806
 807 (make-dispatch-macro-character #\# t *standard-readtable*)
 808 (mapc
 809  #'(lambda (pair)
 810      (set-dispatch-macro-character #\# (first pair) (second pair)
 811                                    *standard-readtable*))
 812  '((#\\ sharp-backslash) (#\' sharp-single-quote) (#\( sharp-left-parenthesis)
 813    (#\* sharp-asterisk) (#\: sharp-colon) (#\. sharp-dot) (#\b sharp-b)
 814    (#\o sharp-o) (#\x sharp-x) (#\r sharp-r) (#\c sharp-c) (#\a sharp-a)
 815    (#\s sharp-s) (#\p sharp-p) (#\= sharp-equal) (#\# sharp-sharp)
 816    (#\+ sharp-plus) (#\- sharp-minus) (#\| sharp-vertical-bar)
 817    (#\L sharp-l)))
 818
 819 (setq *readtable* (copy-readtable nil))
 820
 821