+++ /dev/null
-;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
-;; ALL RIGHTS RESERVED.
-;;
-;; $Id: reader.lisp,v 1.10 2004/02/20 07:23:42 yuji Exp $
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions
-;; are met:
-;;
-;; * Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;; * 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.
-;;
-;; 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
-;; OWNER 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.
-
-;;;; The ParenScript reader, used for reading Parenscript files and other
-;;;; forms during the Parenscript compilation process. The main difference
-;;;; between this reader and the standard Lisp reader is that package
-;;;; prefixes are SCRIPT package names rather than Lisp package names.
-
-;;; The main function, READ, will not work unless *compilation-environement*
-;;; is bound to a valid Parenscript COMPILATION-ENVIRONMENT.
-(in-package parenscript.reader)
-
-(defstruct (readtable (:predicate readtablep) (:copier nil))
- (syntax (make-hash-table) :type hash-table)
- (case :upcase :type (member :upcase :downcase :preserve :invert)))
-
-(defvar *read-base* '10)
-(defvar *read-default-float-format* 'single-float)
-(defvar *read-eval* 't)
-(defvar *read-suppress* 'nil)
-(defvar *readtable*)
-
-
-(defvar *sharp-equal-alist* nil)
-(defvar *consing-dot-allowed* nil)
-(defvar *consing-dot* (gensym))
-(defvar *preserve-whitespace-p* nil)
-(defvar *input-stream* nil)
-(defvar *backquote-level* 0)
-(defvar *dispatch-macro-char* nil)
-(defvar *standard-readtable*)
-
-(define-condition reader-error (parse-error)
- ((format-control :reader reader-error-format-control :initarg :format-control)
- (format-arguments :reader reader-error-format-arguments
- :initarg :format-arguments)))
-
-(define-condition invalid-character-error (reader-error)
- ((character :type character :reader invalid-character-error-character
- :initarg :character))
- (:report
- (lambda (condition stream)
- (format stream "Invalid character ~S is read."
- (invalid-character-error-character condition)))))
-
-(defun reader-error (&optional format-control &rest format-arguments)
- (error 'reader-error
- :format-control format-control :format-arguments format-arguments))
-
-(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
- (flet ((copy-syntax (src)
- (let ((new (make-hash-table)))
- (maphash
- #'(lambda (k v)
- (let ((plist (copy-list v)))
- (setf (gethash k new) plist)
- (when (getf plist :dispatch-table)
- (let ((hash (make-hash-table)))
- (maphash #'(lambda (k v) (setf (gethash k hash) v))
- (getf plist :dispatch-table))
- (setf (getf plist :dispatch-table) hash)))))
- src)
- new)))
- (let ((from (or from-readtable *standard-readtable*)))
- (if to-readtable
- (prog1 to-readtable
- (setf (readtable-syntax to-readtable)
- (copy-syntax (readtable-syntax from)))
- (setf (readtable-case to-readtable) (readtable-case from)))
- (make-readtable :syntax (copy-syntax (readtable-syntax from))
- :case (readtable-case from))))))
-
-(defun syntax-type (char &optional (readtable *readtable*))
- (let ((plist (gethash char (readtable-syntax readtable))))
- (getf plist :syntax :constituent)))
-
-(defun get-macro-character (char &optional (readtable *readtable*))
- (unless readtable (setq readtable *standard-readtable*))
- (let ((plist (gethash char (readtable-syntax readtable))))
- (case (syntax-type char readtable)
- (:terminating-macro-char (values (getf plist :macro-function) nil))
- (:non-terminating-macro-char (values (getf plist :macro-function) t))
- (t (values nil nil)))))
-
-(defun set-macro-character (char new-function
- &optional non-terminating-p (readtable *readtable*))
- (check-type char character)
-; (check-type new-function function-designator)
- (when (null readtable)
- (error "Standard readtable must not be changed."))
- (let ((plist (gethash char (readtable-syntax readtable))))
- (setf (getf plist :syntax) (if non-terminating-p
- :non-terminating-macro-char
- :terminating-macro-char)
- (getf plist :macro-function) new-function
- (gethash char (readtable-syntax readtable)) plist))
- t)
-
-(defun get-dispatch-macro-character (disp-char sub-char
- &optional (readtable *readtable*))
- (unless readtable (setq readtable *standard-readtable*))
- (unless (eq (get-macro-character disp-char readtable)
- 'dispatch-macro-character)
- (error "~S is not a dispatching macro character." disp-char))
- (let* ((syntax-table (readtable-syntax readtable))
- (dispatch-table (getf (gethash disp-char syntax-table) :dispatch-table))
- (sub-char (char-upcase sub-char)))
- (multiple-value-bind (value present-p) (gethash sub-char dispatch-table)
- (cond
- ((digit-char-p sub-char 10) nil)
- (present-p value)
- (t
- #'(lambda (stream sub-char number)
- (declare (ignore stream number))
- (reader-error "No dispatch function defined for ~S." sub-char)))))))
-
-(defun set-dispatch-macro-character (disp-char sub-char new-function
- &optional (readtable *readtable*))
- (when (null readtable) (error "Standard readtable must not be changed."))
- (unless (eq (get-macro-character disp-char readtable)
- 'dispatch-macro-character)
- (error "~S is not a dispatch character." disp-char))
- (let* ((syntax-table (readtable-syntax readtable))
- (dispatch-table (getf (gethash disp-char syntax-table) :dispatch-table))
- (sub-char (char-upcase sub-char)))
- (setf (gethash sub-char dispatch-table) new-function)
- t))
-
-(defun make-dispatch-macro-character (char &optional non-terminating-p
- (readtable *readtable*))
- (when (null readtable) (error "Standard readtable must not be changed."))
- (set-macro-character char 'dispatch-macro-character
- non-terminating-p readtable)
-
- (setf (getf (gethash char (readtable-syntax readtable)) :dispatch-table)
- (make-hash-table))
- t)
-
-(defun dispatch-macro-character (stream char)
- (let ((n (when (digit-char-p (peek-char nil stream t nil t) 10)
- (loop
- with n = 0
- for digit = (read-char stream t nil t)
- do (setq n (+ (* n 10) (digit-char-p digit 10)))
- while (digit-char-p (peek-char nil stream t nil t) 10)
- finally (return n))))
- (*dispatch-macro-char* char)
- (sub-char (char-upcase (read-char stream t nil t))))
- (funcall (get-dispatch-macro-character char sub-char) stream sub-char n)))
-
-(defun set-syntax-from-char (to-char from-char
- &optional (to-readtable *readtable*)
- (from-readtable *standard-readtable*))
- (check-type to-char character)
- (check-type from-char character)
- (check-type to-readtable readtable)
- (unless from-readtable (setq from-readtable *standard-readtable*))
- (check-type from-readtable readtable)
- (let ((plist (copy-list (gethash from-char
- (readtable-syntax from-readtable)))))
- (when (getf plist :dispatch-table)
- (let ((hash (make-hash-table)))
- (maphash #'(lambda (k v) (setf (gethash k hash) v))
- (getf plist :dispatch-table))
- (setf (getf plist :dispatch-table) hash)))
- (setf (gethash to-char (readtable-syntax to-readtable)) plist)
- t))
-
-;; (defmacro with-standard-io-syntax (&rest forms)
-;; `(let ((*package* (find-package "CL-USER"))
-;; (*print-array* t)
-;; (*print-base* 10)
-;; (*print-case* :upcase)
-;; (*print-circle* nil)
-;; (*print-escape* t)
-;; (*print-gensym* t)
-;; (*print-length* nil)
-;; (*print-level* nil)
-;; (*print-lines* nil)
-;; (*print-miser-width* nil)
-;; ;;(*print-pprint-dispatch* *standard-print-pprint-dispatch*)
-;; (*print-pretty* nil)
-;; (*print-radix* nil)
-;; (*print-readably* t)
-;; (*print-right-margin* nil)
-;; (*read-base* 10)
-;; (*read-default-float-format* 'single-float)
-;; (*read-eval* t)
-;; (*read-suppress* nil)
-;; (*readtable* (copy-readtable nil)))
-;; ,@forms))
-
-
-(defun read-preserving-whitespace (&optional (input-stream *standard-input*)
- (eof-error-p t) eof-value recursive-p)
- (let ((*preserve-whitespace-p* (if recursive-p *preserve-whitespace-p* t)))
- (declare (special *preserve-whitespace-p*))
- (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
-
-(defun read (&optional (input-stream *standard-input*)
- (eof-error-p t) eof-value recursive-p)
- (let ((*preserve-whitespace-p* (when recursive-p *preserve-whitespace-p*)))
- (declare (special *preserve-whitespace-p*))
- (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
-
-(defun read-from-string (string &optional (eof-error-p t) eof-value
- &key (start 0) end preserve-whitespace)
- (let ((index nil))
- (values (with-input-from-string (stream string :index index
- :start start :end end)
- (funcall (if preserve-whitespace
- #'read-preserving-whitespace
- #'read)
- stream eof-error-p eof-value))
- index)))
-
-(defun make-str (chars)
- (make-array (length chars) :element-type 'character :initial-contents chars))
-
-(defun read-list (char &optional (stream *standard-input*) recursive-p
- &key allow-consing-dot)
- (let ((*sharp-equal-alist* (when recursive-p *sharp-equal-alist*))
- (*consing-dot-allowed* allow-consing-dot)
- c stack values)
- (loop
- (setq c (peek-char t stream t nil t))
- (when (char= char c)
- (when (eq (first stack) *consing-dot*)
- (error "Nothing appears after . in list."))
- (read-char stream t nil t)
- (if (eq (second stack) *consing-dot*)
- (return (nreconc (cddr stack) (first stack)))
- (return (nreverse stack))))
- (when (setq values (multiple-value-list (lisp-object? stream t nil t)))
- (if (eq (second stack) *consing-dot*)
- (error "More than one object follows . in list.")
- (push (car values) stack))))))
-
-(defun read-delimited-list (char &optional (stream *standard-input*) recursive-p)
- (let ((list (read-list char stream recursive-p)))
- (unless *read-suppress* list)))
-
-(defun lisp-object? (stream eof-error-p eof-value recursive-p)
- (loop
- (let* ((c (read-char stream eof-error-p eof-value recursive-p)))
- (when (and (not eof-error-p) (eq c eof-value)) (return eof-value))
- (ecase (syntax-type c)
- (:invalid (error 'invalid-character-error :character c))
- (:whitespace 'skip)
- ((:single-escape :multiple-escape :constituent)
- (return (read-number-or-symbol stream c)))
- ((:terminating-macro-char :non-terminating-macro-char)
- (return (funcall (get-macro-character c) stream c)))))))
-
-(defun read-lisp-object (stream eof-error-p eof-value recursive-p)
- (let ((*sharp-equal-alist* (when recursive-p *sharp-equal-alist*)))
- (loop
- (let ((values (multiple-value-list (lisp-object? stream
- eof-error-p eof-value
- recursive-p))))
- (when values (return (unless *read-suppress* (car values))))))))
-
-(defun read-ch () (read-char *input-stream* nil nil t))
-(defun read-ch-or-die () (read-char *input-stream* t nil t))
-(defun unread-ch (c) (unread-char c *input-stream*))
-
-(defun collect-escaped-lexemes (c)
- (ecase (syntax-type c)
- (:invalid (error 'invalid-character-error :character c))
- (:multiple-escape nil)
- (:single-escape (cons (read-ch-or-die)
- (collect-escaped-lexemes (read-ch-or-die))))
- ((:constituent
- :whitespace :terminating-macro-char :non-terminating-macro-char)
- (cons c (collect-escaped-lexemes (read-ch-or-die))))))
-
-(defun collect-lexemes (c &optional (stream *input-stream*))
- (let ((*input-stream* stream))
- (when c
- (ecase (syntax-type c)
- (:invalid (error 'invalid-character-error :character c))
- (:whitespace (when *preserve-whitespace-p* (unread-ch c)))
- (:terminating-macro-char (unread-ch c))
- (:multiple-escape (cons (collect-escaped-lexemes (read-ch-or-die))
- (collect-lexemes (read-ch))))
- (:single-escape (cons (list (read-ch-or-die))
- (collect-lexemes (read-ch))))
- ((:constituent :non-terminating-macro-char)
- (cons c (collect-lexemes (read-ch))))))))
-
-;; integer ::= [sign] decimal-digit+ decimal-point
-;; | [sign] digit+
-;; ratio ::= [sign] {digit}+ slash {digit}+
-;; float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
-;; | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
-;; exponent ::= exponent-marker [sign] {digit}+
-
-(defun construct-number (chars)
- (labels ((sign ()
- (let ((c (and chars (car chars))))
- (cond
- ((eql c #\-) (pop chars) -1)
- ((eql c #\+) (pop chars) +1)
- (t +1))))
- (digit* (&optional (base *read-base*))
- (let ((pos (or (position-if-not #'(lambda (d) (digit-char-p d base))
- chars)
- (length chars))))
- (prog1 (subseq chars 0 pos)
- (setq chars (subseq chars pos)))))
- (int? (sign digits &optional (base *read-base*))
- (when (and digits
- (every #'(lambda (d) (digit-char-p d base)) digits))
- (* sign (reduce #'(lambda (a b) (+ (* base a) b))
- (mapcar #'(lambda (d) (digit-char-p d base))
- digits)))))
- (float? (sign)
- (let* ((int (digit* 10))
- (fraction (when (eql (car chars) #\.)
- (pop chars) (digit* 10)))
- (exp-marker (when (and chars
- (find (char-upcase (car chars))
- '(#\D #\E #\F #\L #\S)))
- (char-upcase (pop chars))))
- (exp-sign (and exp-marker (sign)))
- (exp-digits (and exp-sign (digit*))))
- (when (and (null chars)
- (or fraction (and int exp-marker exp-digits)))
- (float (* (int? sign (append int fraction) 10)
- (expt 10 (- (or (int? exp-sign exp-digits 10) 0)
- (length fraction))))
- (ecase (or exp-marker *read-default-float-format*)
- (#\E 1.0e0)
- ((#\D double-float) 1.0d0)
- ((#\F single-float) 1.0f0)
- ((#\L long-float) 1.0l0)
- ((#\S short-float) 1.0s0)))))))
- (let ((sign (sign))
- pos numerator denominator)
- (when chars
- (or
- ;; [sign] digit+
- (int? sign chars)
- ;; [sign] decimal-digit+ decimal-point
- (and (eql (car (last chars)) #\.) (int? sign (butlast chars) 10))
- ;; [sign] {digit}+ slash {digit}+
- (and (setq pos (position #\/ chars))
- (setq numerator (int? sign (subseq chars 0 pos)))
- (setq denominator (int? 1 (subseq chars (1+ pos))))
- (not (zerop denominator))
- (/ numerator denominator))
- ;; [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
- ;; [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
- (float? sign))))))
-
-(defun ensure-external-symbol (name package)
- "Ensures that the symbol with name NAME is external for the given script package PACKAGE.
-Raises a continuable error if NAME is not external in PACKAGE. Otherwise interns NAME
-in PACKAGE and returns the symbol."
- (if package
- (multiple-value-bind (symbol status)
- (find-script-symbol name package)
- (unless (eq status :external)
- (cerror (if (null status)
- "Intern and export script symbol ~S in package ~S."
- "Export script symbol ~S in package ~S.")
- "There is no external symbol by the name of ~S in script package ~S."
- name package)
- (script-export (setq symbol (script-intern name package)) package))
- symbol)
- (script-intern name "KEYWORD")))
-
-(defun construct-symbol (lexemes &key uninterned-symbol-wanted)
- (labels ((up (x) (if (listp x) (copy-list x) (list (char-upcase x))))
- (down (x) (if (listp x) (copy-list x) (list (char-downcase x))))
- (chars (lexemes)
- (ecase (readtable-case *readtable*)
- (:upcase (mapcan #'up lexemes))
- (:downcase (mapcan #'down lexemes))
- (:invert
- (let ((unescaped (remove-if-not #'alpha-char-p
- (remove-if #'listp lexemes))))
- (mapcan (cond
- ((every #'upper-case-p unescaped) #'down)
- ((every #'lower-case-p unescaped) #'up)
- (t #'(lambda (x)
- (if (listp x) (copy-list x) (list x)))))
- lexemes)))
- (:preserve (mapcan #'(lambda (x)
- (if (listp x) (copy-list x) (list x)))
- lexemes))))
- (name (lexemes)
- (when (and (find #\: lexemes) t)
-;; (not *intern-package-prefixes*))
- (error "Too many package markers."))
- (make-str (chars lexemes))))
- (let* ((pos (position #\: lexemes))
- (external-p (and pos (not (eql (nth (1+ pos) lexemes) #\:))))
- (package (when pos (name (subseq lexemes 0 pos))))
- (script-package (find-script-package package))
- (name (name (subseq lexemes (if pos (+ pos (if external-p 1 2)) 0)))))
- (values (cond
- (uninterned-symbol-wanted
- (if package
- (reader-error)
- (make-symbol name)))
- (external-p
- (ensure-external-symbol name script-package))
- (t (script-intern name
- (or script-package
- (parenscript::comp-env-current-package
- *compilation-environment*)))))))))
-
-(defun read-number-or-symbol (stream c)
- (let ((lexemes (collect-lexemes c stream)))
- (assert lexemes)
- (unless *read-suppress*
- (cond
- ((and lexemes (every #'(lambda (x) (eql x #\.)) lexemes))
- (when (rest lexemes)
- (reader-error "Tokens consisting of only dots are invalid."))
- (when (not *consing-dot-allowed*)
- (reader-error "Consing dot is not allowed."))
- *consing-dot*)
- (t
- (or (and (every #'characterp lexemes) (construct-number lexemes))
- (construct-symbol lexemes)))))))
-
-
-;; backquote
-(defmacro define-constant (name value &optional doc)
- `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
- ,@(when doc (list doc))))
-(define-constant backquote (gensym))
-(define-constant backquote-comma (gensym))
-(define-constant backquote-comma-at (gensym))
-(define-constant backquote-comma-dot (gensym))
-
-(defun backquoted-expression-type (exp)
- (if (atom exp)
- :normal
- (cond
- ((eq (first exp) backquote-comma) :comma)
- ((eq (first exp) backquote-comma-at) :comma-at)
- ((eq (first exp) backquote-comma-dot) :comma-dot)
- (t :normal))))
-
-(defmacro backquote (object)
- (if (atom object)
- (if (simple-vector-p object)
- (list 'apply #'vector (list backquote (concatenate 'list object)))
- (list 'quote object))
- (let* ((list (copy-list object))
- (last (loop for x = list then (cdr x)
- until (or (atom (cdr x))
- (find (cadr x) (list backquote
- backquote-comma
- backquote-comma-at
- backquote-comma-dot)))
- finally (return (prog1 (cdr x) (setf (cdr x) nil)))))
- (types (mapcar #'backquoted-expression-type list)))
- (append
- (cons (if (notany #'(lambda (x) (eq x :comma-at)) types) 'nconc 'append)
- (mapcar #'(lambda (x)
- (ecase (backquoted-expression-type x)
- (:normal (list 'list (list 'backquote x)))
- (:comma (list 'list x))
- ((:comma-at :comma-dot) x)))
- list))
- (list (ecase (backquoted-expression-type last)
- (:normal (list 'quote last))
- (:comma last)
- (:comma-at (error ",@ after dot"))
- (:comma-dot (error ",. after dot"))))))))
-
-(defmacro backquote-comma (obj) obj)
-(setf (macro-function backquote) (macro-function 'backquote))
-(setf (macro-function backquote-comma) (macro-function 'backquote-comma))
-(setf (macro-function backquote-comma-at) (macro-function 'backquote-comma))
-(setf (macro-function backquote-comma-dot) (macro-function 'backquote-comma))
-
-
-(defun read-comma-form (stream c)
- (declare (ignore c))
- (unless (> *backquote-level* 0)
- (error "Comma must be used in a backquoted expression."))
- (let ((*backquote-level* (1- *backquote-level*)))
- (case (peek-char t stream t nil t)
- (#\@ (read-char stream t nil t)
- (list backquote-comma-at (read stream t nil t)))
- (#\. (read-char stream t nil t)
- (list backquote-comma-dot (read stream t nil t)))
- (t (list backquote-comma (read stream t nil t))))))
-
-(defun read-backquoted-expression (stream c)
- (declare (ignore c))
- (let ((*backquote-level* (1+ *backquote-level*)))
- (list backquote (read stream t nil t))))
-
-
-(defun sharp-backslash (stream sub-char n)
- (declare (ignore n))
- (let* ((lexemes (collect-lexemes sub-char stream))
- (str (make-str (mapcan #'(lambda (x)
- (if (listp x) (copy-list x) (list x)))
- lexemes))))
- (unless *read-suppress*
- (cond
- ((= 1 (length str)) (char str 0))
- ((name-char str))
- (t (reader-error "Unrecognized character name: ~S" str))))))
-
-(defun sharp-single-quote (stream sub-char n)
- (declare (ignore sub-char n))
- `(function ,(read stream t nil t)))
-
-(defun sharp-left-parenthesis (stream sub-char n)
- (declare (ignore sub-char))
- (let ((list (read-delimited-list #\) stream t)))
- (unless *read-suppress*
- (when (and n (> (length list) n))
- (reader-error "vector is longer than specified length #~A*~A."
- n list))
- (apply #'vector
- (if (and n (< (length list) n))
- (append list (make-list (- n (length list))
- :initial-element (car (last list))))
- list)))))
-
-(defun sharp-asterisk (stream sub-char n)
- (declare (ignore sub-char))
- (let* ((*input-stream* stream)
- (lexemes (collect-lexemes (read-ch)))
- (bits (mapcar #'(lambda (d)
- (unless (characterp d)
- (error "Binary digit must be given"))
- (digit-char-p d 2)) lexemes)))
- (unless *read-suppress*
- (unless (every #'(lambda (d) (digit-char-p d 2)) lexemes)
- (reader-error "Illegal bit vector format."))
- (when (and n (> (length bits) n))
- (reader-error "Bit vector is longer than specified length #~A*~A."
- n (make-str lexemes)))
- (when (and n (> n 0) (zerop (length bits)))
- (reader-error
- "At least one bit must be given for non-zero #* bit-vectors."))
- (make-array (or n (length bits)) :element-type 'bit
- :initial-contents
- (if (and n (< (length bits) n))
- (append bits
- (make-list (- n (length bits))
- :initial-element (car (last bits))))
- bits)))))
-
-(defun sharp-colon (stream sub-char n)
- (declare (ignore sub-char n))
- (let* ((*input-stream* stream)
- (lexemes (collect-lexemes (read-ch))))
- (unless *read-suppress*
- (construct-symbol lexemes :uninterned-symbol-wanted t))))
-
-(defun sharp-dot (stream sub-char n)
- (declare (ignore sub-char n))
- (let ((object (read stream t nil t)))
- (unless *read-suppress*
- (unless *read-eval*
- (reader-error "Attempt to read #. while *READ-EVAL* is bound to NIL."))
- (eval object))))
-
-(defun sharp-b (stream sub-char n)
- (declare (ignore n))
- (sharp-r stream sub-char 2))
-
-(defun sharp-o (stream sub-char n)
- (declare (ignore n))
- (sharp-r stream sub-char 8))
-
-(defun sharp-x (stream sub-char n)
- (declare (ignore n))
- (sharp-r stream sub-char 16))
-
-(defun sharp-r (stream sub-char n)
- (cond
- (*read-suppress* (read stream t nil t))
- ((not n) (reader-error "Radix missing in #R."))
- ((not (<= 2 n 36)) (reader-error "Illegal radix for #R: ~D." n))
- (t (let ((rational (let ((*read-base* n)) (read stream t nil t))))
- (unless (typep rational 'rational)
- (reader-error "#~A (base ~D) value is not a rational: ~S."
- sub-char n rational))
- rational))))
-
-
-(defun sharp-c (stream sub-char n)
- (declare (ignore sub-char n))
- (let ((pair (read stream t nil t)))
- (unless *read-suppress*
- (unless (and (listp pair) (= (length pair) 2))
- (reader-error "Illegal complex number format: #C~S" pair))
- (complex (first pair) (second pair)))))
-
-(defun sharp-a (stream sub-char rank)
- (declare (ignore sub-char))
- (cond
- (*read-suppress* (read stream t nil t))
- ((null rank)
- (reader-error "Rank for #A notation is missing."))
- (t (let* ((contents (read stream t nil t))
- (dimensions (loop repeat rank
- for x = contents then (first x)
- collect (length x))))
- (make-array dimensions :initial-contents contents)))))
-
-
-(defun find-default-constructor (name)
- (declare (ignore name)))
-
-(defun sharp-s (stream sub-char n)
- (declare (ignore sub-char n))
- (let ((structure-spec (read stream t nil t)))
- (unless *read-suppress*
- (unless (listp structure-spec)
- (reader-error "Non list follows #S."))
- (unless (symbolp (first structure-spec))
- (reader-error "Structure type is not a symbol: ~S" (car structure-spec)))
- (let* ((name (first structure-spec))
- (plist (loop
- for list on (rest structure-spec) by #'cddr
- append (list (intern (string (first list)) "KEYWORD")
- (second list))))
- (class (find-class name nil)))
- (unless (typep class 'structure-class)
- (reader-error "~S is not a defined structure type." name))
- (let ((constructor (find-default-constructor name)))
- (apply constructor plist))))))
-
-(defun sharp-p (stream sub-char n)
- (declare (ignore sub-char n))
- (let ((namestring (read stream t nil t)))
- (unless *read-suppress* (parse-namestring namestring))))
-
-(defun container-subst (new old tree
- &optional (done (make-hash-table :test 'eq)))
- (cond
- ((eq tree old) new)
- ((gethash tree done) tree)
- (t (setf (gethash tree done) t)
- (typecase tree
- (null nil)
- (cons (setf (car tree) (container-subst new old (car tree) done)
- (cdr tree) (container-subst new old (cdr tree) done))
- tree)
- (array (loop for i below (array-total-size tree)
- do (setf (row-major-aref tree i)
- (container-subst new old
- (row-major-aref tree i) done)))
- tree)
- (t tree)))))
-
-(defun sharp-equal (stream sub-char n)
- (declare (ignore sub-char))
- (if *read-suppress*
- (values)
- (let* ((this (gensym))
- (object (let ((*sharp-equal-alist* (acons n this
- *sharp-equal-alist*)))
- (read stream t nil t)))
- (assoc (assoc n *sharp-equal-alist*)))
- (when (null n)
- (reader-error "Missing label number for #=."))
- (when assoc
- (reader-error "#~D= is already defined." n))
- (setq *sharp-equal-alist* (acons n object *sharp-equal-alist*))
- (when (eq object this)
- (reader-error "need to tag something more than just #~D#." n))
- (container-subst object this object))))
-
-(defun sharp-sharp (stream sub-char n)
- (declare (ignore sub-char stream))
- (unless *read-suppress*
- (unless n (reader-error "Label is missing for ##."))
- (let ((assoc (assoc n *sharp-equal-alist*)))
- (unless assoc
- (reader-error "No object labeld ~D is defined." n))
- (cdr assoc))))
-
-(defun featurep (x)
- (if (atom x)
- (member x *features*)
- (ecase (first x)
- (:not (not (featurep (second x))))
- (:and (every #'featurep (rest x)))
- (:or (some #'featurep (rest x))))))
-
-(defun read-feature-test (stream)
- (let ((*package* (or (find-package "KEYWORD")
- (error "KEYWORD package not found."))))
- (read stream t nil t)))
-
-(defun sharp-plus (stream sub-char n)
- (declare (ignore sub-char n))
- (if (featurep (read-feature-test stream))
- (read stream t nil t)
- (let ((*read-suppress* t)) (read stream t nil t) (values))))
-
-(defun sharp-minus (stream sub-char n)
- (declare (ignore sub-char n))
- (if (not (featurep (read-feature-test stream)))
- (read stream t nil t)
- (let ((*read-suppress* t)) (read stream t nil t) (values))))
-
-(defun sharp-vertical-bar (stream sub-char n)
- (declare (ignore sub-char n))
- (loop for c = (read-char stream t nil t)
- if (and (char= c #\#) (char= (read-char stream t nil t) #\|))
- do (sharp-vertical-bar stream #\| nil)
- until (and (char= c #\|) (char= (read-char stream t nil t) #\#)))
- (values))
-
-(defun sharp-l (stream sub-char n)
- "#L uses the Lisp reader for the next form."
- (declare (ignore sub-char n))
- (cl:read stream))
-
-
-(defvar *standard-syntax-table*
- (let ((table (make-hash-table)))
- (mapc #'(lambda (x)
- (let ((syntax (first x))
- (chars (rest x)))
- (dolist (c chars)
- (setf (gethash c table) `(:syntax ,syntax)))))
- '((:whitespace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space)
- (:single-escape #\\)
- (:multiple-escape #\|)))
- table))
-
-(setq *standard-readtable* (make-readtable :syntax *standard-syntax-table*))
-
-(set-macro-character #\` 'read-backquoted-expression nil *standard-readtable*)
-(set-macro-character #\, 'read-comma-form nil *standard-readtable*)
-
-(set-macro-character #\( #'(lambda (stream char)
- (declare (ignore char))
- (read-list #\) stream t :allow-consing-dot t))
- nil *standard-readtable*)
-
-(set-macro-character #\) #'(lambda (stream char)
- (declare (ignore stream char))
- (error "Unmatched close parenthesis."))
- nil *standard-readtable*)
-
-(set-macro-character #\' #'(lambda (stream char)
- (declare (ignore char))
- `(quote ,(read stream t nil t)))
- nil *standard-readtable*)
-
-(set-macro-character #\; #'(lambda (stream char)
- (declare (ignore char))
- (loop
- for c = (read-char stream nil nil t)
- until (or (null c) (eql c #\Newline)))
- (values))
- nil *standard-readtable*)
-
-(set-macro-character #\" #'(lambda (stream char)
- (declare (ignore char))
- (loop
- for c = (read-char stream t nil t)
- until (char= c #\")
- if (eq :single-escape (syntax-type c))
- collect (read-char stream t nil t) into chars
- else
- collect c into chars
- finally
- (return (make-array (length chars)
- :element-type 'character
- :initial-contents chars))))
- nil *standard-readtable*)
-
-
-(make-dispatch-macro-character #\# t *standard-readtable*)
-(mapc
- #'(lambda (pair)
- (set-dispatch-macro-character #\# (first pair) (second pair)
- *standard-readtable*))
- '((#\\ sharp-backslash) (#\' sharp-single-quote) (#\( sharp-left-parenthesis)
- (#\* sharp-asterisk) (#\: sharp-colon) (#\. sharp-dot) (#\b sharp-b)
- (#\o sharp-o) (#\x sharp-x) (#\r sharp-r) (#\c sharp-c) (#\a sharp-a)
- (#\s sharp-s) (#\p sharp-p) (#\= sharp-equal) (#\# sharp-sharp)
- (#\+ sharp-plus) (#\- sharp-minus) (#\| sharp-vertical-bar)
- (#\L sharp-l)))
-
-(setq *readtable* (copy-readtable nil))
-
-
HCoop / clinton / parenscript.git / commitdiff