Changed result of PARSE-BODY: the docstring is returned in a list, so that one can...
[com-informatimago:com-informatimago.git] / common-lisp / lisp-reader / reader.lisp
1 ;;;;**************************************************************************
2 ;;;;FILE:               reader.lisp
3 ;;;;LANGUAGE:           Common-Lisp
4 ;;;;SYSTEM:             Common-Lisp
5 ;;;;USER-INTERFACE:     NONE
6 ;;;;DESCRIPTION
7 ;;;;
8 ;;;;    See defpackage documentation string.
9 ;;;;
10 ;;;;AUTHORS
11 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
12 ;;;;MODIFICATIONS
13 ;;;;    2012-05-14 <PJB> Corrected set-syntax-from-char.
14 ;;;;    2011-04-29 <PJB> Added potential-number-p.
15 ;;;;    2009-08-26 <PJB> Corrected bugs reading "||", "( ;comment )" and "#C(123 456)".
16 ;;;;    2007-03-04 <PJB> Extracted from source.lisp
17 ;;;;BUGS
18 ;;;;
19 ;;;;    When we've reached the end of the stream, if we (read stream nil)
20 ;;;;    it goes on an infinite loop.
21 ;;;;
22 ;;;;    (READ-FROM-STRING "#1=(a b . #1#)") gives an error.
23 ;;;;
24 ;;;;LEGAL
25 ;;;;    AGPL3
26 ;;;;    
27 ;;;;    Copyright Pascal Bourguignon 2006 - 2012
28 ;;;;    
29 ;;;;    This program is free software: you can redistribute it and/or modify
30 ;;;;    it under the terms of the GNU Affero General Public License as published by
31 ;;;;    the Free Software Foundation, either version 3 of the License, or
32 ;;;;    (at your option) any later version.
33 ;;;;    
34 ;;;;    This program is distributed in the hope that it will be useful,
35 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
36 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
37 ;;;;    GNU Affero General Public License for more details.
38 ;;;;    
39 ;;;;    You should have received a copy of the GNU Affero General Public License
40 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
41 ;;;;**************************************************************************
42
43 (in-package "COMMON-LISP-USER")
44 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.READER"
45   (:use "COMMON-LISP"
46         "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
47   (:shadow "READTABLE"
48            "COPY-READTABLE" "MAKE-DISPATCH-MACRO-CHARACTER"
49            "READ" "READ-PRESERVING-WHITESPACE"
50            "READ-DELIMITED-LIST"
51            "READ-FROM-STRING"
52            "READTABLE-CASE" "READTABLEP"
53            "SET-DISPATCH-MACRO-CHARACTER" "GET-DISPATCH-MACRO-CHARACTER"
54            "SET-MACRO-CHARACTER" "GET-MACRO-CHARACTER"
55            "SET-SYNTAX-FROM-CHAR"
56            "WITH-STANDARD-IO-SYNTAX"
57            "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*"
58            "*READ-SUPPRESS*" "*READTABLE*")
59   (:export "READTABLE"
60            "COPY-READTABLE" "MAKE-DISPATCH-MACRO-CHARACTER"
61            "READ" "READ-PRESERVING-WHITESPACE"
62            "READ-DELIMITED-LIST"
63            "READ-FROM-STRING"
64            "READTABLE-CASE" "READTABLEP"
65            "SET-DISPATCH-MACRO-CHARACTER" "GET-DISPATCH-MACRO-CHARACTER"
66            "SET-MACRO-CHARACTER" "GET-MACRO-CHARACTER"
67            "SET-SYNTAX-FROM-CHAR"
68            "WITH-STANDARD-IO-SYNTAX"
69            "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*"
70            "*READ-SUPPRESS*" "*READTABLE*"
71            ;; Extensions:
72            "READTABLE-SYNTAX-TABLE" "READTABLE-PARSE-TOKEN"
73            "SET-INDIRECT-DISPATCH-MACRO-CHARACTER" 
74            "SET-INDIRECT-MACRO-CHARACTER"
75            "LIST-ALL-MACRO-CHARACTERS"
76            "SIMPLE-READER-ERROR" "SIMPLE-END-OF-FILE"
77            "MISSING-PACKAGE-ERROR" "SYMBOL-IN-MISSING-PACKAGE-ERROR"
78            "MISSING-SYMBOL-ERROR" "SYMBOL-MISSING-IN-PACKAGE-ERROR"
79            "INTERN-HERE" "RETURN-UNINTERNED"
80            ;; Utilities:
81            "POTENTIAL-NUMBER-P")
82   (:documentation
83    "
84 This package implements a standard Common Lisp reader.
85
86 We implement a Common Lisp Reader to be able to read lisp
87 sources.  This is a complete standard compliant lisp reader,
88 with additionnal hooks (token parser).
89
90 A READTABLE-PARSE-TOKEN function takes a TOKEN as argument, and
91 must return two values:
92 - A boolean indicating whether the it could parse the token,
93 - a parsed lisp object it could, or an error message (string) if not.
94
95 See also the TOKEN functions, CONSTITUENT-TRAIT, SYNTAX-TABLE and
96 CHARACTER-DESCRIPTION...
97
98
99 License:
100
101     AGPL3
102     
103     Copyright Pascal J. Bourguignon 2006 - 2012
104     
105     This program is free software: you can redistribute it and/or modify
106     it under the terms of the GNU Affero General Public License as published by
107     the Free Software Foundation, either version 3 of the License, or
108     (at your option) any later version.
109     
110     This program is distributed in the hope that it will be useful,
111     but WITHOUT ANY WARRANTY; without even the implied warranty of
112     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
113     GNU Affero General Public License for more details.
114     
115     You should have received a copy of the GNU Affero General Public License
116     along with this program. If not, see <http://www.gnu.org/licenses/>
117
118 "))
119 (in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP-READER.READER")
120
121
122
123 (define-condition simple-reader-error   (simple-error reader-error)
124   ()
125   (:documentation "A simple reader error condition."))
126
127 (define-condition simple-end-of-file    (simple-error end-of-file)
128   ()
129   (:documentation "A simple end-of-file condition."))
130
131 (define-condition missing-package-error (reader-error)
132   ((package-name :initarg :package-name))
133   (:documentation "The error condition signaled when trying use an inexistant package."))
134
135 (define-condition symbol-in-missing-package-error (missing-package-error)
136   ((symbol-name :initarg :symbol-name))
137   (:documentation "The error condition signaled when trying to read a symbol in an inexistant package."))
138
139 (define-condition missing-symbol-error (reader-error)
140   ((symbol-name :initarg :symbol-name))
141   (:documentation "The error condition signaled when trying to read a symbol not exported from a package."))
142
143 (define-condition symbol-missing-in-package-error (missing-symbol-error)
144   ((package-name :initarg :package-name))
145   (:documentation "The error condition signaled when trying to read a symbol not exported from a package."))
146
147 (defun serror (condition stream control-string &rest arguments)
148   (error condition
149          :stream stream
150          :format-control control-string
151          :format-arguments arguments))
152
153
154 ;; (LET ((*READTABLE* (COPY-READTABLE NIL)))
155 ;;   (SET-DISPATCH-MACRO-CHARACTER
156 ;;    #\# #\. (LAMBDA (&REST ARGS) ARGS)))
157 ;; ;; (setf (readtable-case *readtable*) :preserve)
158 ;; (let ((*readtable* (copy-readtable)))
159 ;;   ;; Quick and dirty disable : --> read three or four tokens
160 ;;   ;; for pack:sym or pack::sym
161 ;;   (set-macro-character #\: (lambda (stream char) #\:) nil)
162 ;;   (SAFE-TEXT-FILE-TO-STRING-LIST path))
163 ;;
164 ;;
165 ;; (defun unnamed-char-p (ch)
166 ;;   (not (null (regexp:match "^U\\([0-9A-F]\\{4\\}\\|[0-9A-F]\\{8\\}\\)$"
167 ;;                            (char-name ch)))))
168 ;;
169 ;;
170 ;; (defun collect-chars (&key (start 0) (end #x11000) name)
171 ;;   (loop
172 ;;      :with table = (make-hash-table :test (function equalp))
173 ;;      :for code :from start :below end
174 ;;      :for char = (code-char code)
175 ;;      :for name = (char-name char)
176 ;;      :do (unless (unnamed-char-p char)
177 ;;            (dolist (word (regexp:regexp-split "[-_]" name))
178 ;;              (push char (gethash word table nil))))
179 ;;      :finally (return table)))
180
181
182
183 ;;----------------------------------------
184
185 (defclass character-description ()
186   ((syntax   :reader character-syntax
187              :initarg :syntax)
188    (traits   :reader character-constituent-traits
189              :initarg :traits   :initform nil)
190    (macro    :reader character-macro
191              :initarg :macro    :initform nil
192              :documentation "A macro character function.")
193    (dispatch :reader character-dispatch
194              :initarg :dispatch :initform nil
195              :documentation "A HASH-TABLE character -> dmc function."))
196   (:documentation
197    "
198 Description of one character. 
199
200 In the syntax tables, a single character description instance can be
201 shared by several characters, but with copy-on-write.
202 "))
203
204 ;; macro-character-function
205 ;; dispatch-macro --> map character -> dispatch-macro-character-function
206
207
208 (eval-when (:compile-toplevel :load-toplevel :execute)
209 ;;; Character syntaxes:
210   (defconstant +cs-invalid+                         0)
211   (defconstant +cs-whitespace+                      1)
212   (defconstant +cs-single-escape+                   2)
213   (defconstant +cs-multiple-escape+                 3)
214   (defconstant +cs-constituent+                     4)
215   (defconstant +cs-terminating-macro-character+     5)
216   (defconstant +cs-non-terminating-macro-character+ 6)
217
218
219 ;;; Constituent traits:
220   (defconstant +ct-invalid+                        #b00000000000001)
221   (defconstant +ct-alphabetic+                     #b00000000000010)
222   (defconstant +ct-digit+                          #b00000000000100)
223   (defconstant +ct-alphadigit+                     #b00000000000110)
224   (defconstant +ct-package-marker+                 #b00000000001000)
225   (defconstant +ct-plus-sign+                      #b00000000010000)
226   (defconstant +ct-minus-sign+                     #b00000000100000)
227   (defconstant +ct-sign+                           #b00000000110000)
228   (defconstant +ct-dot+                            #b00000001000000)
229   (defconstant +ct-decimal-point+                  #b00000010000000)
230   (defconstant +ct-ratio-marker+                   #b00000100000000)
231   (defconstant +ct-float-exponent-marker+          #b00001000000000)
232   (defconstant +ct-short-float-exponent-marker+    #b00011000000000)
233   (defconstant +ct-single-float-exponent-marker+   #b00101000000000)
234   (defconstant +ct-double-float-exponent-marker+   #b01001000000000)
235   (defconstant +ct-long-float-exponent-marker+     #b10001000000000)
236   (defconstant +ct-max+ +ct-long-float-exponent-marker+)
237   ) ;;eval-when
238
239
240 (deftype constituent-trait () `(integer 0 ,(expt 2 (integer-length  +ct-max+))))
241
242
243 (declaim (inline traitp))
244 (defun traitp (trait traits)
245   "Returns whether the TRAIT is in the TRAITS 'set'."
246   (plusp (logand trait traits)))
247
248
249 ;;; The shared character descriptions:
250
251 (defparameter *cd-invalid*                (make-instance 'character-description
252                                             :syntax +cs-invalid+
253                                             :traits +ct-invalid+))
254 (defparameter *cd-whitespace*             (make-instance 'character-description
255                                             :syntax +cs-whitespace+
256                                             :traits +ct-invalid+))
257 (defparameter *cd-constituent-invalid*    (make-instance 'character-description
258                                             :syntax +cs-whitespace+
259                                             :traits +ct-invalid+))
260 (defparameter *cd-constituent-alphabetic* (make-instance 'character-description
261                                             :syntax +cs-constituent+
262                                             :traits +ct-alphabetic+))
263
264 ;; ----------------------------------------
265
266 (defclass syntax-table ()
267   (standard-characters
268    extended-characters
269    constituent
270    invalid)
271   (:documentation
272    "
273 STANDARD-CHARACTERS is a vector of CHARACTER-DESCRIPTION instances
274 for the standard character codes below +STANDARD-CHARACTERS-LIMIT+.
275
276 EXTENDED-CHARACTERS is NIL, or a HASH-TABLE mapping characters to
277 CHARACTER-DESCRIPTIONS instances for the extended characters with
278 codes above +STANDARD-CHARACTERS-LIMIT+.
279
280 Extended characters without an entry in EXTENDED-CHARACTERS either
281 have CONSTITUENT or INVALID CHARACTER-DESCRIPTION, depending on whether
282 they're GRAPHIC-CHAR-P or not.
283 "))
284
285 (defconstant +standard-characters-limit+ 128)
286
287
288 (defmethod initialize-instance
289     :after ((self syntax-table) &key &allow-other-keys)
290   (let ((table        (make-array +standard-characters-limit+
291                                   :initial-element *cd-invalid*)))
292     (setf (aref table (char-code #\Backspace)) *cd-constituent-invalid*
293           (aref table (char-code #\Rubout))    *cd-constituent-invalid*
294           (aref table (char-code #\Tab))       *cd-whitespace*
295           (aref table (char-code #\Newline))   *cd-whitespace*
296           (aref table (char-code #\Linefeed))  *cd-whitespace*
297           (aref table (char-code #\Page))      *cd-whitespace*
298           (aref table (char-code #\Return))    *cd-whitespace*
299           (aref table (char-code #\Space))     *cd-whitespace*)
300     (loop
301        :for chdesc
302        :in '((#.+cs-terminating-macro-character+ "\"'(),;`"
303               #.+ct-alphabetic+)
304              (#.+cs-non-terminating-macro-character+ "#"
305               #.+ct-alphabetic+)
306              (#.+cs-single-escape+ "\\"
307               #.+ct-alphabetic+)
308              (#.+cs-multiple-escape+ "|"
309               #.+ct-alphabetic+)
310              (#.+cs-constituent+ "!$%&*<=>?@[]^_{}~"
311               #.+ct-alphabetic+)
312              (#.+cs-constituent+ ":"
313               #.+ct-package-marker+)
314              (#.+cs-constituent+ "+"
315               #.+ct-alphabetic+ #.+ct-plus-sign+)
316              (#.+cs-constituent+ "-"
317               #.+ct-alphabetic+ #.+ct-minus-sign+)
318              (#.+cs-constituent+ "."
319               #.+ct-alphabetic+ #.+ct-dot+ #.+ct-decimal-point+)
320              (#.+cs-constituent+ "/"
321               #.+ct-alphabetic+ #.+ct-ratio-marker+)
322              (#.+cs-constituent+ "0123456789"
323               #.+ct-alphadigit+)
324              (#.+cs-constituent+ "Dd"
325               #.+ct-alphadigit+ #.+ct-double-float-exponent-marker+)
326              (#.+cs-constituent+ "Ee"
327               #.+ct-alphadigit+ #.+ct-float-exponent-marker+)
328              (#.+cs-constituent+ "Ff"
329               #.+ct-alphadigit+ #.+ct-single-float-exponent-marker+)
330              (#.+cs-constituent+ "Ll"
331               #.+ct-alphadigit+ #.+ct-long-float-exponent-marker+)
332              (#.+cs-constituent+ "Ss"
333               #.+ct-alphadigit+ #.+ct-short-float-exponent-marker+)
334              (#.+cs-constituent+ "ABCGHIJKMNOPQRTUVWXYZabcghijkmnopqrtuvwxyz"
335               #.+ct-alphadigit+))
336        :do (loop
337               :with desc = (make-instance 'character-description
338                              :syntax (first chdesc)
339                              :traits (if (null (cdddr chdesc))
340                                          (third chdesc)
341                                          (apply (function logior)
342                                                 (cddr chdesc))))
343               :for ch :across (second chdesc)
344               :do (setf (aref table (char-code ch)) desc)))
345     (setf (slot-value self 'standard-characters) table
346           (slot-value self 'extended-characters) nil))
347   self)
348
349 (defgeneric copy-syntax-table (syntax-table))
350 (defgeneric character-description (syntax-table character))
351
352 (defmethod copy-syntax-table ((self syntax-table))
353   (let ((copy (make-instance 'syntax-table)))
354     (setf (slot-value copy 'standard-characters)
355           (copy-seq (slot-value self 'standard-characters))
356           (slot-value copy 'extended-characters)
357           (and (slot-value self 'extended-characters)
358                (copy-hash-table (slot-value self 'extended-characters))))
359     copy))
360
361 (defmethod character-description ((self syntax-table) (ch character))
362   (let ((code (char-code ch)))
363     (if (< code +standard-characters-limit+)
364         (aref (slot-value self 'standard-characters) code)
365         (or (and (slot-value self 'extended-characters)
366                  (gethash code (slot-value self 'extended-characters)))
367             (if (graphic-char-p ch)
368                 *cd-constituent-alphabetic*
369                 *cd-invalid*)))))
370
371 (defgeneric (setf character-description) (val syntax-table character))
372 (defmethod (setf character-description) (val (self syntax-table) (ch character))
373   (let ((code (char-code ch)))
374     (if (< code +standard-characters-limit+)
375         (setf (aref (slot-value self 'standard-characters) code) val)
376         (progn
377           (unless (slot-value self 'extended-characters)
378             (setf (slot-value self 'extended-characters) (make-hash-table)))
379           (setf  (gethash code (slot-value self 'extended-characters)) val)))))
380
381 ;;----------------------------------------
382
383 (defvar *standard-readtable*         nil
384   "Only used by SET-SYNTAX-FROM-CHAR")
385
386 (defvar *readtable*                  nil
387   "
388 The value of *READTABLE* is called the current readtable. It controls
389 the parsing behavior of the Lisp reader, and can also influence the
390 Lisp printer (e.g., see the  function READTABLE-CASE).
391
392 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/v_rdtabl.htm>
393 ")
394
395 (defvar *read-base*                  10
396   "
397 Controls the interpretation of tokens by READ as being integers or
398 ratios.
399
400 The value of *READ-BASE*, called the current input base, is the radix
401 in which  integers and ratios are to be read by the Lisp reader. The
402 parsing of other numeric  types (e.g., floats) is not affected by this
403 option.
404
405 The effect of *READ-BASE* on the reading of any particular rational
406 number can be locally overridden by explicit use of the #O, #X, #B, or
407 #nR syntax or by a trailing decimal point.
408
409 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_bas.htm>
410 ")
411
412 (defvar *read-eval*                  t
413   "
414 If it is true, the #. reader macro has its normal effect. Otherwise,
415 that reader macro signals an error of type reader-error.
416
417 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_eva.htm>
418 ")
419
420 (defvar *read-suppress*              nil
421   "
422 This variable is intended primarily to support the operation of the
423 read-time conditional notations #+ and #-. If it is false, the Lisp
424 reader operates normally.  If the value of *read-suppress* is true,
425 read, read-preserving-whitespace,  read-delimited-list, and
426 read-from-string all return a primary value of nil when they complete
427 successfully.
428
429 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_sup.htm>
430 ")
431
432 (defvar *read-default-float-format* 'single-float
433   "
434 Controls the floating-point format that is to be used when reading a
435 floating-point number that has no exponent marker or that has e or E
436 for an exponent marker. Other  exponent markers explicitly prescribe
437 the floating-point format to be used.
438
439 The printer uses *read-default-float-format* to guide the choice of
440 exponent markers when printing floating-point numbers.
441
442 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_def.htm>
443 ")
444
445 ;; extensions
446 (defvar *input-stream* nil
447   "
448 Bound to the input stream, during token parsing.
449
450 Consequences are undefined, if any destructive operations are
451 attempted on this stream.
452 ")
453
454 (declaim (ftype (function (t) t) parse-token))
455
456 (defgeneric readtable-parse-token (readtable)
457   (:documentation "RETURN: The function used to parse a token that has been read."))
458 (defgeneric (setf readtable-parse-token) (new-function readtable)
459   (:documentation "DO:     Set the function used to parse a token that has been read."))
460 (defgeneric readtable-syntax-table (readtable)
461   (:documentation "RETURN: The syntax-table of the readtable."))
462
463 (defclass readtable ()
464   ((case          :initarg :case
465                   :initform :upcase
466                   :type (member :upcase :downcase :preserve :invert))
467    (syntax-table  :accessor readtable-syntax-table
468                   :initarg :syntax-table
469                   :initform (make-instance 'syntax-table))
470    (parse-token   :accessor readtable-parse-token
471                   :initarg :parse-token
472                   :initform (function parse-token)))
473   (:documentation
474    "
475 A READTABLE maps characters into syntax types for the Lisp reader; see
476 Section 2 (Syntax). A readtable also contains associations between
477 macro characters and their  reader macro functions, and records
478 information about the case conversion rules to be used by the Lisp
479 reader when parsing symbols.
480
481 Each simple character must be representable in the readtable. It is
482 implementation-defined whether non-simple characters can have syntax
483 descriptions in the readtable.
484
485 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/t_rdtabl.htm>
486 "))
487
488
489
490 (defun copy-readtable (&optional (from-readtable *readtable*) (to-readtable nil))
491 "
492 DO:     Copy the readtable.
493 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_cp_rdt.htm>
494 "
495   (if (null from-readtable)
496       (if (null to-readtable)
497           (make-instance 'readtable)
498           (progn
499             (setf (readtable-case to-readtable) :upcase
500                   (readtable-syntax-table to-readtable) (make-instance
501                                                             'syntax-table)
502                   (readtable-parse-token to-readtable)  (function parse-token))
503             to-readtable))
504       (if (null to-readtable)
505           (make-instance 'readtable
506             :case (readtable-case from-readtable)
507             :syntax-table (copy-syntax-table
508                            (readtable-syntax-table from-readtable))
509             :parse-token (readtable-parse-token from-readtable))
510           (progn
511             (setf (readtable-case to-readtable) (readtable-case from-readtable)
512                   (readtable-syntax-table to-readtable) (copy-syntax-table
513                                                          (readtable-syntax-table
514                                                           from-readtable))
515                   (readtable-parse-token to-readtable)  (readtable-parse-token
516                                                          from-readtable))
517             to-readtable))))
518
519 (defun reader-dispatch-macro-error-undefined (stream ch sub-char)
520   (serror 'simple-reader-error stream
521           "After #\\~A is #\\~A an undefined dispatch macro character"
522           ch sub-char))
523
524 (defun reader-dispatch-macro-error-invalid (stream sub-char arg)
525   (declare (ignore sub-char arg))
526   (serror 'simple-reader-error stream
527           "objects printed as # in view of *PRINT-LEVEL* cannot be read back in"))
528
529
530 (defun reader-macro-dispatch-function (stream ch)
531   (let* ((arg  (loop
532                   :for ch = (read-char stream t nil t)
533                   :while (digit-char-p ch)
534                   :collect ch :into digits
535                   :finally (unread-char ch stream)
536                   (return (when digits
537                             (parse-integer (coerce digits 'string))))))
538          (sub-char (read-char stream t nil t))
539          (cd (character-description (readtable-syntax-table *readtable*) ch))
540          (fun (gethash (char-upcase sub-char) (character-dispatch cd))))
541     (if fun
542         (funcall fun stream  arg sub-char)
543         (reader-dispatch-macro-error-undefined stream ch sub-char))))
544
545
546
547 (defgeneric process-case-function (mode)
548   (:method ((mode (eql :preserve))) (declare (ignorable mode)) (function identity))
549   (:method ((mode (eql :downcase))) (declare (ignorable mode)) (function char-downcase))
550   (:method ((mode (eql :upcase)))   (declare (ignorable mode)) (function char-upcase))
551   (:method ((mode (eql :invert)))
552     (declare (ignorable mode)) 
553     (lambda (ch)
554       (cond ((upper-case-p ch) (char-downcase ch))
555             ((lower-case-p ch) (char-upcase   ch))
556             (t                                ch)))))
557
558
559 ;;; For tokens we need to keep track of the characters and their
560 ;;; traits in parallel:
561
562 (declaim (inline make-token  token-text token-traits
563                  token-length token-char token-char-traits
564                  token-collect-character))
565 (defun make-token ()
566   (declare (inline arr))
567   (flet ((arr (type)
568            (make-array 8 :adjustable t :fill-pointer 0 :element-type type)))
569     (cons (arr 'character) (arr 'constituent-trait))))
570 (defun token-text        (token)       (car token))
571 (defun token-traits      (token)       (cdr token))
572 (defun token-length      (token)       (length (car token)))
573 (defun token-char        (token index) (aref (car token) index))
574 (defun token-char-traits (token index) (aref (cdr token) index))
575 (defun token-collect-character (token character traits)
576   (vector-push-extend  character (car token))
577   (vector-push-extend  traits    (cdr token)))
578
579 (defun token-delimiter-p (character)
580   (let ((cs (character-syntax
581              (character-description (readtable-syntax-table *readtable*)
582                                     character))))
583     (or (= cs +cs-whitespace+) (= cs +cs-terminating-macro-character+))))
584
585
586 (defvar *references* nil "Used to implement #= and ##.")
587
588
589 (defun read-token (input-stream eof-error-p eof-value recursive-p
590                    preserve-whitespace-p first-char readtable)
591   "
592 DO:             Implements parts of READ and READ-PRESERVING-WHITESPACE.
593
594 INPUT-STREAM:   The stream that is read.
595 EOF-ERROR-P:    Whether we should signal an END-OF-FILE error upon EOF.
596 EOF-VALUE:      Unless EOF-ERROR-P, the value to be returned in case of EOF.
597 RECURSIVE-P:    Whether the read is recursive.
598                 The *reference* table is reset only when RECURSIVE-P is false.
599 PRESERVE-WHITESPACE-P:
600                 Whether a terminating whitespace will be unread or not.
601 FIRST-CHAR:     NIL or a CHARACTER that is used first, before reading the stream.
602                 This should be faster than UNREAD-CHAR it, and foremost, it allows
603                 for two unread character, this FIRST-CHAR plus an actual UNREAD-CHAR one.
604 READTABLE:      The readtable to use.
605
606 RETURN:         tokenp == t    ; a token.  Or
607                 tokenp == :EOF ; the eof-value.  Or
608                 tokenp == NIL  ; a list of values read.
609
610 BUG:            The handling of readtable-case :invert is wrong.
611 "
612   (macrolet ((unless-eof (place &body body)
613                `(cond
614                   (,place      ,@body)
615                   (eof-error-p (serror 'simple-end-of-file input-stream
616                                        "input stream ~S has reached its end"
617                                        input-stream))
618                   (t       (return-from read-token (values :eof eof-value)))))
619              (error-invalid-character (ch)
620                `(serror 'simple-reader-error input-stream
621                         "invalid character #\\~A" ,ch)))
622     (let ((*references* (if recursive-p
623                             *references*
624                             (make-hash-table))))
625       (prog (x y
626              (token (make-token))
627              (syntax-table (readtable-syntax-table readtable))
628              (procase (process-case-function (readtable-case readtable))))
629        :begin
630        (setf x (or first-char (read-char input-stream nil nil t))
631              first-char nil)
632        (unless-eof x
633          (let ((cd (character-description syntax-table x)))
634            (ecase (character-syntax cd)
635              ((#.+cs-invalid+)
636               (error-invalid-character x))
637              ((#.+cs-whitespace+)
638               (go :begin))
639              ((#.+cs-single-escape+)
640               (let ((z (read-char input-stream nil nil t)))
641                 (unless-eof z
642                   (token-collect-character token z +ct-alphabetic+)))
643               (go :collect-token))
644              ((#.+cs-multiple-escape+)
645               (go :collect-multiple-escape-token))
646              ((#.+cs-constituent+)
647               (token-collect-character token (funcall procase x)
648                                        (character-constituent-traits cd))
649               (go :collect-token))
650              ((#.+cs-terminating-macro-character+
651                #.+cs-non-terminating-macro-character+)
652               ;; If the macro returns no value, the caller will
653               ;; have to call us again, or not: (#-(and)x)
654               (return-from read-token
655                 (values nil (multiple-value-list
656                              (funcall (get-macro-character x readtable)
657                                       input-stream x))))))))
658        :collect-token
659        (setf y (read-char input-stream nil nil t))
660        (if y
661            (let ((cd (character-description syntax-table y)))
662              (ecase (character-syntax cd)
663                ((#.+cs-invalid+)
664                 (error-invalid-character y))
665                ((#.+cs-whitespace+)
666                 (when preserve-whitespace-p
667                   (unread-char y input-stream))
668                 (go :parse-token))
669                ((#.+cs-single-escape+)
670                 (let ((z (read-char input-stream nil nil t)))
671                   (unless-eof z
672                     (token-collect-character token z +ct-alphabetic+)))
673                 (go :collect-token))
674                ((#.+cs-multiple-escape+)
675                 (go :collect-multiple-escape-token))
676                ((#.+cs-constituent+
677                  #.+cs-non-terminating-macro-character+)
678                 (token-collect-character token (funcall procase y)
679                                          (character-constituent-traits cd))
680                 (go :collect-token))
681                ((#.+cs-terminating-macro-character+)
682                 (unread-char y input-stream)
683                 (go :parse-token))))
684            (go :parse-token))
685        :collect-multiple-escape-token
686        (setf y (read-char input-stream nil nil t))
687        (unless-eof y
688          (let ((cd (character-description syntax-table y)))
689            (ecase (character-syntax cd)
690              ((#.+cs-invalid+)
691               (error-invalid-character y))
692              ((#.+cs-single-escape+)
693               (let ((z (read-char input-stream nil nil t)))
694                 (unless-eof z
695                   (token-collect-character token z +ct-alphabetic+)))
696               (go :collect-multiple-escape-token))
697              ((#.+cs-multiple-escape+)
698               (go :collect-token))
699              ((#.+cs-whitespace+
700                #.+cs-constituent+
701                #.+cs-non-terminating-macro-character+
702                #.+cs-terminating-macro-character+)
703               (token-collect-character token y +ct-alphabetic+)
704               (go :collect-multiple-escape-token)))))
705        :parse-token
706        ;; token can be of zero length...
707        (return (values t token))))))
708
709
710
711
712 ;; numeric-token ::= integer | ratio | float       
713 ;; integer  ::= [sign] decimal-digit+ decimal-point 
714 ;; integer  ::= [sign] digit+      
715 ;; ratio    ::= [sign] {digit}+ slash {digit}+    
716 ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ exponent
717 ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ 
718 ;; float    ::= [sign] {decimal-digit}+ exponent
719 ;; float    ::= [sign] {decimal-digit}+ decimal-point {decimal-digit}* exponent
720 ;; exponent ::=  exponent-marker [sign] {digit}+
721 ;; 
722 ;; consing-dot   ::= dot
723 ;; 
724 ;; symbol        ::= symbol-name
725 ;;                 | package-marker symbol-name
726 ;;                 | package-marker package-marker symbol-name
727 ;;                 | package-name package-marker symbol-name
728 ;;                 | package-name package-marker package-marker symbol-name
729 ;; 
730 ;; symbol-name   ::= {alphabetic}+ 
731 ;; package-name  ::= {alphabetic}+ 
732
733
734
735 (defmacro defparser (name arguments &body body)
736   "Defines a token parser function, which parses its argument token and returns
737 three values: a ok flag; a type of value; and a value parsed from the token.
738 When the ok flag is false, the type indicates whether it's a strong error,
739 and the value returned is an error message.
740 A strong error is a lexical error that is not ambiguous.  A weak error is
741 when the token could still be of another lexical category.
742 In the body of the parser, there are macrolet defined to REJECT or ACCEPT
743 the token, and to describe the parsed syntax with ALT, ZERO-OR-MORE, 
744 ONE-OR-MORE and OPT-SIGN."
745   (multiple-value-bind (docu decl body) (parse-body :lambda body)
746     `(defun ,name ,arguments
747        ,@docu
748        ,@decl
749        (macrolet ((reject (strongp &rest ctrlstring-and-args)
750                           `(return-from ,',name
751                              (values nil ,strongp
752                                      ,(when ctrlstring-and-args
753                                             `(format nil ,@ctrlstring-and-args)))))
754                   (accept (type token)
755                           `(return-from ,',name (values t ,type ,token)))
756                   (alt (&rest clauses)
757                        `(cond ,@clauses))
758                   (zero-or-more (test &body body)
759                     `(loop :while ,test :do ,@body))
760                   (one-or-more  (test &body body)
761                     `(progn
762                        (if ,test (progn ,@body) (reject nil))
763                        (loop :while ,test :do ,@body)))
764                   (opt-sign (sign token i)
765                             `(alt ((>= ,i (token-length ,token)))
766                                   ((traitp +ct-plus-sign+  (token-char-traits ,token ,i))
767                                    (setf ,sign +1 ,i (1+ ,i)))
768                                   ((traitp +ct-minus-sign+ (token-char-traits ,token ,i))
769                                    (setf ,sign -1 ,i (1+ ,i))))))
770            ,@body))))
771
772
773 (defparser parse-decimal-integer-token (token)
774   "integer ::= [sign] decimal-digit+ decimal-point"
775   (let ((sign 1)
776         (mant 0)
777         (i 0))
778     (unless (< i (token-length token)) (reject nil))
779     (unless (traitp +ct-decimal-point+
780                     (token-char-traits token (1- (token-length token))))
781       (reject nil))
782     (opt-sign sign token i)
783     (one-or-more (and (< i (token-length token))
784                       (traitp +ct-digit+ (token-char-traits token i))
785                       (digit-char-p (token-char token i)))
786                  (setf mant (+ (* 10. mant) (digit-char-p (token-char token i)))
787                        i (1+ i)))
788     (if (and (= (1+ i) (token-length token))
789              (traitp +ct-decimal-point+ (token-char-traits token i)))
790         (accept 'integer (* sign mant))
791         (reject t
792                 (if (= (1+ i) (token-length token))
793                     "Missing decimal point in decimal integer ~S"
794                     "Junk after decimal point in decimal integer ~S")
795                 (token-text token)))))
796
797
798 (defparser parse-integer-token (token)
799   "integer ::= [sign] digit+"
800   (let ((sign 1)
801         (mant 0)
802         (i 0))
803     (unless (< i (token-length token)) (reject nil))
804     (opt-sign sign token i)
805     (one-or-more (and (< i (token-length token))
806                       (traitp +ct-digit+ (token-char-traits token i))
807                       (digit-char-p (token-char token i) *read-base*))
808                  (setf mant (+ (* *read-base* mant)
809                                (digit-char-p (token-char token i) *read-base*))
810                        i (1+ i)))
811     (if (= i (token-length token))
812         (accept 'integer (* sign mant))
813         (reject t "Junk after integer ~S" (token-text token)))))
814
815 (defun %parse-integer (string &key (start 0) (end nil) (radix 10.) (junk-allowed nil)
816                        &aux (end (or end (length string))))
817   (loop
818      :named parse
819      :with sign = (case (aref string start)
820                     (#\+ (incf start) +1)
821                     (#\- (incf start) -1)
822                     (otherwise        +1))
823      :with mant = 0
824      :for i :from start :below end
825      :do (let ((digit (digit-char-p (aref string i) radix)))
826            (cond
827              (digit         (setf mant (+ (* mant radix) digit)))
828              (junk-allowed  (return-from parse (values (* sign mant) i)))
829              (t             (error 'parse-error))) ())
830      :finally (return-from parse (values (* sign mant) i))))
831
832
833 (defparser parse-ratio-token (token)
834   "ratio ::= [sign] {digit}+ slash {digit}+"
835   (let ((sign 1)
836         (nume 0)
837         (denu 0)
838         (i 0))
839     (unless (< i (token-length token)) (reject nil))
840     (opt-sign sign token i)
841     (one-or-more (and (< i (token-length token))
842                       (traitp +ct-digit+ (token-char-traits token i))
843                       (digit-char-p (token-char token i) *read-base*))
844                  (setf nume (+ (* *read-base* nume)
845                                (digit-char-p (token-char token i) *read-base*))
846                        i (1+ i)))
847     (if (traitp +ct-ratio-marker+ (token-char-traits token i))
848         (incf i)
849         (reject nil))
850     (one-or-more (and (< i (token-length token))
851                       (traitp +ct-digit+ (token-char-traits token i))
852                       (digit-char-p (token-char token i) *read-base*))
853                  (setf denu (+ (* *read-base* denu)
854                                (digit-char-p (token-char token i) *read-base*))
855                        i (1+ i)))
856     (cond
857       ((< i (token-length token))
858        (reject t "Junk after ratio ~S" (token-text token)))
859       #|| ((zerop denu) (reject t "Zero denominator ratio ~S" (token-text token))) ||#
860       (t
861        (accept 'ratio (/ (* sign nume) denu))))))
862
863
864 (defparser parse-float-1-token (token)
865   "float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
866 exponent ::=  exponent-marker [sign] {digit}+"
867   (let ((sign 1)
868         (nume 0)
869         (denu 1)
870         (type *read-default-float-format*)
871         (esgn 1)
872         (expo 0)
873         (i 0))
874     (opt-sign sign token i)
875     (zero-or-more (and (< i (token-length token))
876                        (traitp +ct-digit+ (token-char-traits token i))
877                        (digit-char-p (token-char token i)))
878                   (setf nume (+ (* 10. nume) (digit-char-p (token-char token i)))
879                         i (1+ i)))
880     (if (and (< i (token-length token))
881              (traitp +ct-decimal-point+ (token-char-traits token i)))
882         (incf i)
883         (reject nil))
884     (one-or-more (and (< i (token-length token))
885                       (traitp +ct-digit+ (token-char-traits token i))
886                       (digit-char-p (token-char token i)))
887                  (setf nume (+ (* 10. nume) (digit-char-p (token-char token i)))
888                        denu (* 10. denu)
889                        i (1+ i)))
890     (when (and (< i (token-length token))
891                (traitp +ct-float-exponent-marker+ (token-char-traits token i)))
892       (cond
893         ((traitp +ct-short-float-exponent-marker+ (token-char-traits token i))
894          (setf type 'short-float))
895         ((traitp +ct-single-float-exponent-marker+ (token-char-traits token i))
896          (setf type 'single-float))
897         ((traitp +ct-double-float-exponent-marker+ (token-char-traits token i))
898          (setf type 'double-float))
899         ((traitp +ct-long-float-exponent-marker+ (token-char-traits token i))
900          (setf type 'long-float)))
901       (incf i)
902       (opt-sign esgn token i)
903       (one-or-more (and (< i (token-length token))
904                         (traitp +ct-digit+ (token-char-traits token i))
905                         (digit-char-p (token-char token i)))
906                    (setf expo (+ (* 10. expo) (digit-char-p (token-char token i)))
907                          i (1+ i))))
908     (if (= i (token-length token))
909         (accept type
910                 (* (coerce (/ (* sign nume) denu) type)
911                    (expt 10.0 (* esgn expo))))
912         (reject t "Junk after floating point number ~S" (token-text token)))))
913
914
915 (defparser parse-float-2-token (token)
916   "float ::= [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
917 exponent ::=  exponent-marker [sign] {digit}+"
918   (let ((sign 1)
919         (nume 0)
920         (denu 1)
921         (type *read-default-float-format*)
922         (esgn 1)
923         (expo 0)
924         (i 0))
925     (opt-sign sign token i)
926     (one-or-more (and (< i (token-length token))
927                       (traitp +ct-digit+ (token-char-traits token i))
928                       (digit-char-p (token-char token i)))
929                  (setf nume (+ (* 10. nume) (digit-char-p (token-char token i)))
930                        i (1+ i)))
931     (when (and (< i (token-length token))
932                (traitp +ct-decimal-point+ (token-char-traits token i)))
933       (incf i)
934       (one-or-more (and (< i (token-length token))
935                         (traitp +ct-digit+ (token-char-traits token i))
936                         (digit-char-p (token-char token i)))
937                    (setf nume (+ (* 10. nume) (digit-char-p (token-char token i)))
938                          denu (* 10. denu)
939                          i (1+ i))))
940     (unless (and (< i (token-length token))
941                  (traitp +ct-float-exponent-marker+ (token-char-traits token i)))
942       (reject nil))
943     (cond
944       ((traitp +ct-short-float-exponent-marker+ (token-char-traits token i))
945        (setf type 'short-float))
946       ((traitp +ct-single-float-exponent-marker+ (token-char-traits token i))
947        (setf type 'single-float))
948       ((traitp +ct-double-float-exponent-marker+ (token-char-traits token i))
949        (setf type 'double-float))
950       ((traitp +ct-long-float-exponent-marker+ (token-char-traits token i))
951        (setf type 'long-float)))
952     (incf i)
953     (opt-sign esgn token i)
954     (one-or-more (and (< i (token-length token))
955                       (traitp +ct-digit+ (token-char-traits token i))
956                       (digit-char-p (token-char token i)))
957                  (setf expo (+ (* 10. expo) (digit-char-p (token-char token i)))
958                        i (1+ i)))
959     (if (= i (token-length token))
960         (accept type
961                 (* (coerce (/ (* sign nume) denu) type)
962                    (expt 10.0 (* esgn expo))))
963         (reject t "Junk after floating point number ~S" (token-text token)))))
964
965
966 ;; (defparser parse-consing-dot-token (token)
967 ;;   "consing-dot ::= dot"
968 ;;   (if (and (= 1 (token-length token))
969 ;;            (traitp +ct-dot+ (token-char-traits token 0)))
970 ;;       (accept 'consing-dot ".")
971 ;;       (reject nil)))
972
973
974 (defparser parse-symbol-token (token)
975   "symbol ::= symbol-name
976 symbol ::= package-marker symbol-name
977 symbol ::= package-marker package-marker symbol-name
978 symbol ::= package-name package-marker symbol-name
979 symbol ::= package-name package-marker package-marker symbol-name
980 symbol-name   ::= {alphabetic}+ 
981 package-name  ::= {alphabetic}+ "
982   (let ((colon (position-if
983                 (lambda (traits) (traitp +ct-package-marker+ traits))
984                 (token-traits token))))
985     (if colon
986         (let* ((double-colon (and (< (1+ colon) (token-length token))
987                                   (traitp +ct-package-marker+
988                                           (token-char-traits token (1+ colon)))))
989                (pname (subseq (token-text token) 0 colon))
990                (sname (subseq (token-text token)
991                               (+ colon (if double-colon 2 1)))))
992           (when (position-if
993                  (lambda (traits) (traitp +ct-package-marker+ traits))
994                  (token-traits token) :start (+ colon (if double-colon 2 1)))
995             (reject t "Too many package markers in token ~S" (token-text token)))
996           (when (zerop colon)
997             ;; Keywords always exist, so let's intern them before finding them.
998             (setf pname "KEYWORD")
999             (intern sname pname))
1000           ;; The following form thanks to Andrew Philpot <philpot@ISI.EDU>
1001           ;; corrects a bug when reading with double-colon uninterned symbols:
1002           (if (find-package pname)
1003               (if double-colon
1004                   (accept 'symbol (intern sname pname))
1005                   (multiple-value-bind (sym where) (find-symbol sname pname)
1006                     (if (eq where :external) 
1007                         (accept 'symbol sym)
1008                         (accept 'symbol
1009                                 (restart-case (error 'symbol-missing-in-package-error
1010                                                      :stream *input-stream* :package-name pname :symbol-name sname)
1011                                   (make-symbol (&rest rest)
1012                                     :report "Make the missing symbol in the specified package"
1013                                     (declare (ignore rest))
1014                                     (intern sname pname)))))))
1015               (accept 'symbol
1016                       (restart-case (error 'symbol-in-missing-package-error
1017                                            :stream *input-stream* :package-name pname :symbol-name sname)
1018                         (intern-here (&rest rest)
1019                           :report "Intern the symbol in the current package, instead"
1020                           (declare (ignore rest))
1021                           (intern sname))
1022                         (return-uninterned (&rest rest)
1023                           :report "Return an uninterned symbol, instead"
1024                           (declare (ignore rest))
1025                           (make-symbol sname))))))
1026         ;; no colon in token, let's just intern the symbol in the current package :
1027         (accept 'symbol (intern (token-text token) *package*)))))
1028
1029
1030 (defun parse-token (token)
1031   "
1032 RETURN:  okp ; the parsed lisp object if okp, or an error message if (not okp)
1033 "
1034   (let ((message nil))
1035     (macrolet
1036         ((rom (&body body)
1037            "Result Or Message"
1038            (if (null body)
1039                'nil
1040                (let ((vals (gensym)))
1041                  `(let ((,vals (multiple-value-list ,(car body))))
1042                     ;; (format *trace-output* "~S --> ~S~%" ',(car body) ,vals)
1043                     (if (first ,vals)
1044                         (values-list ,vals)
1045                         (progn
1046                           (when (second ,vals)
1047                             (setf message  (third ,vals)))
1048                           (rom ,@(cdr body)))))))))
1049       (multiple-value-bind (ok type object)
1050           (rom (parse-decimal-integer-token token)
1051                (parse-integer-token         token)
1052                (parse-ratio-token           token)
1053                (parse-float-1-token         token)
1054                (parse-float-2-token         token)
1055                ;; (parse-consing-dot-token     token)
1056                (parse-symbol-token          token))
1057         (declare (ignorable type))
1058         ;; (format *trace-output* "ok = ~S ; type = ~S ; object = ~S~%"
1059         ;;         ok type object)
1060         (values ok (if ok object message))))))
1061
1062
1063
1064 (defun all-dots-p (token)
1065   "
1066 RETURN: Whether the token is all dots, (excluding escaped dots).
1067 "
1068   (and (plusp (length (token-text token)))
1069        (every (lambda (traits) (traitp +ct-dot+ traits)) (token-traits token))))
1070
1071
1072 (defun read-0/1 (input-stream eof-error-p eof-value recursive-p
1073                  preserve-whitespace-p first-char allowed-all-dots)
1074   "
1075 DO:             Read zero or one token.  Use the *READTABLE*.
1076
1077 INPUT-STREAM:   The stream that is read.
1078 EOF-ERROR-P:    Whether we should signal an END-OF-FILE error upon EOF.
1079 EOF-VALUE:      Unless EOF-ERROR-P, the value to be returned in case of EOF.
1080 RECURSIVE-P:    Whether the read is recursive.
1081                 The *reference* table is reset only when RECURSIVE-P is false.
1082 PRESERVE-WHITESPACE-P:
1083                 Whether a terminating whitespace will be unread or not.
1084 FIRST-CHAR:     NIL or a CHARACTER that is used first, before reading the stream.
1085                 This should be faster than UNREAD-CHAR it, and foremost, it allows
1086                 for two unread character, this FIRST-CHAR plus an actual UNREAD-CHAR one.
1087 ALLOWED-ALL-DOTS:
1088                 May be T in which case tokens containing only dots are allowed,
1089                 or a (possibly empty) list of strings containing only dots that are
1090                 explicitely allowed (others rejected). Typically (\".\").
1091
1092 RETURN:         tokenp == t    ; an unparsed (alldots) token.  Or
1093                 tokenp == :EOF ; the eof-value.  Or
1094                 tokenp == NIL  ; a list of values read.
1095 "
1096   (multiple-value-bind (tokenp token)
1097       (read-token input-stream eof-error-p eof-value recursive-p
1098                   preserve-whitespace-p first-char *readtable*)
1099     (if (eq 't tokenp)
1100         (cond
1101           (*read-suppress*
1102            (values nil (list nil)))
1103           ((or (eq 't allowed-all-dots)
1104                (not (all-dots-p token))) ; We got a token, let's parse it.
1105            (values nil (list
1106                         (multiple-value-bind (okp object)
1107                             (let ((*input-stream* input-stream))
1108                               (funcall (readtable-parse-token *readtable*) token))
1109                           (if okp
1110                               object
1111                               (serror 'simple-reader-error input-stream
1112                                       "~A" object))))))
1113           ((member (token-text token) allowed-all-dots :test (function string=))
1114            (values t token))
1115           (t
1116            (serror 'simple-reader-error input-stream
1117                    "a token consisting only of dots cannot be ~
1118                    meaningfully read in")))
1119         (values tokenp token)))) 
1120
1121
1122
1123
1124 (defun read-1 (input-stream eof-error-p eof-value
1125                recursive-p preserve-whitespace-p first-char allowed-all-dots)
1126    "
1127 DO:             Read exactly one token.  Use the *READTABLE*.
1128
1129 INPUT-STREAM:   The stream that is read.
1130 EOF-ERROR-P:    Whether we should signal an END-OF-FILE error upon EOF.
1131 EOF-VALUE:      Unless EOF-ERROR-P, the value to be returned in case of EOF.
1132 RECURSIVE-P:    Whether the read is recursive.
1133                 The *reference* table is reset only when RECURSIVE-P is false.
1134 PRESERVE-WHITESPACE-P:
1135                 Whether a terminating whitespace will be unread or not.
1136 FIRST-CHAR:     NIL or a CHARACTER that is used first, before reading the stream.
1137                 This should be faster than UNREAD-CHAR it, and foremost, it allows
1138                 for two unread character, this FIRST-CHAR plus an actual UNREAD-CHAR one.
1139 ALLOWED-ALL-DOTS:
1140                 May be T in which case tokens containing only dots are allowed,
1141                 or a (possibly empty) list of strings containing only dots that are
1142                 explicitely allowed (others rejected). Typically (\".\").
1143
1144 RETURN:         The token read, or
1145                 when EOF-ERROR-P is false and EOF occurs, EOF-VALUE.
1146 " (loop
1147      :for (tokenp token) = (multiple-value-list
1148                             (read-0/1 input-stream eof-error-p eof-value
1149                                       recursive-p preserve-whitespace-p
1150                                       first-char allowed-all-dots))
1151      :until (or (eq :eof tokenp) token)
1152      :finally (return (if (eq :eof tokenp)
1153                           token
1154                           (first token)))))
1155
1156
1157 (defun read (&optional input-stream
1158              (eof-error-p t) (eof-value nil)
1159              (recursive-p nil))
1160   "
1161 RETURN: An object read.
1162 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_rd.htm>
1163 "
1164   (read-1 input-stream eof-error-p eof-value recursive-p  nil  nil '()))
1165
1166       
1167 (defun read-preserving-whitespace (&optional input-stream
1168                                    (eof-error-p t) (eof-value nil)
1169                                    (recursive-p nil))
1170   "
1171 RETURN: An object read.
1172 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_rd.htm>
1173 "
1174   (read-1 input-stream eof-error-p eof-value recursive-p  t    nil '()))
1175
1176
1177 (defun read-delimited-list (char &optional (input-stream *standard-input*)
1178                             (recursive-p nil))
1179   "
1180 RETURN: A list of objects read.
1181 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_del.htm>
1182 "
1183   (loop
1184      :with result = '()
1185      :for peek = (peek-char t input-stream nil input-stream recursive-p)
1186      :do (cond
1187            ((eql peek input-stream)
1188             (serror 'simple-end-of-file input-stream
1189                     "input stream ~S has reached its end" input-stream))
1190            ((char= peek char)
1191             (read-char input-stream nil nil recursive-p)
1192             (return-from read-delimited-list (nreverse result)))
1193            (t
1194             (multiple-value-bind (kind tokens)
1195                 (read-0/1 input-stream t nil recursive-p nil nil '())
1196               (declare (ignore kind))
1197               (when tokens
1198                 (push (first tokens) result)))))))
1199
1200
1201 (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
1202                          &key (start 0) (end nil) (preserve-whitespace nil))
1203 "
1204 RETURN: An object read from the string.
1205 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_fro.htm>
1206 "
1207   (let ((index 0))
1208     (values
1209      (with-input-from-string (input string :index index :start start :end end)
1210        (funcall (if preserve-whitespace
1211                     (function read-preserving-whitespace)
1212                     (function read))
1213                 input eof-error-p eof-value))
1214      index)))
1215
1216
1217 (defun readtable-case (readtable)
1218 "
1219 RETURN: The case of the readtable.
1220 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rdtabl.htm>
1221 "
1222   (slot-value readtable 'case))
1223
1224 (defun (setf readtable-case) (value readtable)
1225   "
1226 DO:     Set the case of the readtable.
1227 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rdtabl.htm>
1228 "
1229   (check-type value (member :upcase :downcase :preserve :invert))
1230   (setf (slot-value readtable 'case) value))
1231
1232
1233 (defun readtablep (object)
1234   "
1235 RETURN: Whether the object is a readtable.
1236 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_rdta_1.htm>
1237 "
1238   (typep object 'readtable))
1239
1240
1241 (defun make-dispatch-macro-character
1242     (char &optional (non-terminating-p nil) (readtable *readtable*))
1243 "
1244 DO:     Make the character a dispatch macro character in the readtable.
1245 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_dis.htm>
1246 "
1247   (let ((rst  (readtable-syntax-table readtable)))
1248     (setf (character-description rst char)
1249           (make-instance 'character-description
1250             :syntax (if non-terminating-p
1251                         +cs-non-terminating-macro-character+
1252                         +cs-terminating-macro-character+)
1253             :traits (character-constituent-traits
1254                      (character-description rst char))
1255             :macro (function reader-macro-dispatch-function)
1256             :dispatch (make-hash-table)))))
1257
1258
1259 (defun get-dispatch-macro-character (disp-char sub-char
1260                                      &optional (readtable *readtable*))
1261 "
1262 RETURN: The dispatch macro character function.
1263 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_set__1.htm>
1264 "
1265   (let* ((rst  (readtable-syntax-table readtable))
1266          (cd   (character-description rst disp-char)))
1267     (unless (character-dispatch cd)
1268       (error "~S is not  a dispatch macro character" disp-char))
1269     (and (character-dispatch cd)
1270          (gethash (char-upcase sub-char) (character-dispatch cd)))))
1271
1272
1273 (defun set-dispatch-macro-character (disp-char sub-char new-function
1274                                      &optional (readtable *readtable*))
1275 "
1276 DO:     Set the dispatch macro character function.
1277 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_set__1.htm>
1278 "
1279   (let* ((rst  (readtable-syntax-table readtable))
1280          (cd   (character-description rst disp-char)))
1281     (unless (character-dispatch cd)
1282       (error "~S is not  a dispatch macro character" disp-char))
1283     (setf (gethash (char-upcase sub-char) (character-dispatch cd))
1284           new-function))
1285   t)
1286
1287
1288 (defun get-macro-character (char &optional (readtable *readtable*))
1289 "
1290 RETURN: The macro character function.
1291 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_set_ma.htm>
1292 "
1293   (let* ((rst  (readtable-syntax-table readtable))
1294          (cd   (character-description rst char)))
1295     (values (character-macro cd)
1296             (= (character-syntax cd) +cs-non-terminating-macro-character+))))
1297
1298 (defun set-macro-character (char new-function &optional (non-terminating-p nil)
1299                             (readtable *readtable*))
1300   "
1301 DO:     Set then macro character function. 
1302 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_set_ma.htm>
1303 "
1304   (let* ((rst  (readtable-syntax-table readtable)))
1305     (setf (character-description rst char)
1306           (make-instance 'character-description
1307               :syntax (if non-terminating-p
1308                           +cs-non-terminating-macro-character+
1309                           +cs-terminating-macro-character+)
1310               :traits (character-constituent-traits
1311                        (character-description rst char))
1312               :macro new-function)))
1313   t)
1314
1315
1316 (defun set-indirect-dispatch-macro-character (disp-char sub-char function-name
1317                                               &optional (readtable *readtable*))
1318   "Like set-dispatch-macro-character, but with an indirect function, 
1319 to enable TRACE and redefinitions of the dispatch macro character function."
1320   (set-dispatch-macro-character
1321    disp-char sub-char
1322    (compile nil
1323             (let ((s (gensym)) (c (gensym)) (a (gensym)))
1324               `(lambda (,s ,c ,a) (,function-name ,s ,c ,a))))
1325    readtable))
1326
1327 (defun set-indirect-macro-character (char function-name
1328                                      &optional (readtable *readtable*))
1329   "Like set-macro-character, but with an indirect function, 
1330 to enable TRACE and redefinitions of the macro character function."
1331   (set-macro-character
1332    char
1333    (compile nil
1334             (let ((s (gensym)) (a (gensym)))
1335               `(lambda (,s ,a) (,function-name ,s ,a))))
1336    readtable))
1337
1338
1339
1340 ;; Copied from com.informatimago.common-lisp.cesarum.utility to avoid package use loop.
1341 (defun copy-hash-table (table)
1342   "
1343 TABLE:  (OR NULL HASH-TABLE)
1344 RETURN: If TABLE is NIL, then NIL, 
1345         else a new HASH-TABLE with the same TEST, SIZE, REHASH-THRESHOLD 
1346         REHASH-SIZE and KEY->VALUE associations than TABLE.
1347         (Neither the keys nor the values are copied).
1348 "
1349   (check-type table (or null hash-table))
1350   (when table
1351     (let ((copy (make-hash-table
1352                  :test             (hash-table-test             table)
1353                  :size             (hash-table-size             table)
1354                  :rehash-threshold (hash-table-rehash-threshold table)
1355                  :rehash-size      (hash-table-rehash-size      table))))
1356       (maphash (lambda (k v) (setf (gethash k copy) v)) table)
1357       copy)))
1358
1359
1360 (defun set-syntax-from-char (to-char from-char
1361                              &optional (to-readtable *readtable*)
1362                              (from-readtable *standard-readtable*))
1363 "
1364 DO:     Copy the syntax between characters in the readtable.
1365 URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_set_sy.htm>
1366 "
1367   (let* ((frst  (readtable-syntax-table from-readtable))
1368          (trst  (readtable-syntax-table   to-readtable))
1369          (fcd   (character-description frst from-char))
1370          (tcd   (character-description trst   to-char)))
1371     (setf (character-description trst to-char)
1372           (make-instance 'character-description
1373               :syntax   (character-syntax fcd)
1374               ;; constituent traits are not copied.
1375               :traits   (character-constituent-traits tcd) 
1376               ;; macros are copied only if from is a macro character.
1377               :macro    (or (character-macro fcd) (character-macro tcd))
1378               :dispatch (if (character-dispatch fcd)
1379                             (copy-hash-table (character-dispatch fcd))
1380                             (character-dispatch tcd)))))
1381   t)
1382
1383
1384 ;;;----------------------------------------
1385 ;;; STANDARD READER MACRO FUNCTIONS
1386 ;;;----------------------------------------
1387
1388 (defun reader-macro-line-comment (stream ch)
1389   "Standard ; macro reader."
1390   (declare (ignore ch))
1391   (read-line stream nil)
1392   (values))
1393
1394 (defun reader-macro-string (stream delim)
1395   "Standard \" macro reader."
1396   (flet ((error-eof ()
1397            (serror 'simple-end-of-file stream
1398                     "input stream ~S ends within a string" stream)))
1399     (loop
1400        :with rst    = (readtable-syntax-table *readtable*)
1401        :with string = (make-array 64 :element-type 'character
1402                                   :adjustable t :fill-pointer 0)
1403        :for ch      = (read-char stream nil nil t)
1404        :do (cond
1405              ((null ch)
1406               (error-eof))
1407              ((eql ch delim)
1408               (return-from reader-macro-string (copy-seq string)))
1409              ((= (character-syntax (character-description rst ch))
1410                  +cs-single-escape+)
1411               (let ((next (read-char stream nil nil)))
1412                 (when (null next)
1413                   (error-eof))
1414                 (vector-push-extend next string)))
1415              (t (vector-push-extend ch   string))))))
1416
1417
1418 (defun reader-macro-quote (stream ch)
1419   "Standard ' macro reader."
1420   (declare (ignore ch))
1421   `(quote ,(read stream t nil t)))
1422
1423
1424 (defun reader-macro-backquote (stream ch)
1425   "Standard ` macro reader."
1426   (declare (ignore ch))
1427   `(backquote ,(read stream t nil t)))
1428
1429
1430 (defun reader-macro-comma (stream ch)
1431   "Standard , macro reader."
1432   (declare (ignore ch))
1433   `(,(if (char= #\@ (peek-char nil stream t nil t)) 'splice 'unquote)
1434      ,(read stream t nil t)))
1435
1436
1437 (defun reader-macro-left-parenthesis (stream ch)
1438   "Standard ( macro reader."
1439   (declare (ignore ch))
1440   (loop
1441      :with result     = (cons nil nil)
1442      :with last-cons  = result
1443      :with last-cdr-p = nil
1444      :for ch = (progn (peek-char t stream nil t) (read-char stream t nil t))
1445      ;; :do (print `(:result ,result :last-cons ,last-cons
1446      ;;                      :last-cdr-p ,last-cdr-p :ch ,ch))
1447      :do (flet ((read-and-nconc (ch)
1448                   (let ((objects
1449                          (nth-value 1 (read-0/1 stream t nil t nil ch '()))))
1450                     (when objects
1451                       (case last-cdr-p
1452                         ((nil)     (setf (cdr last-cons) objects
1453                                          ;; (list (first objects))
1454                                          last-cons       (cdr last-cons)))
1455                         ((t)       (setf (cdr last-cons) (first objects)
1456                                          last-cdr-p      :done))
1457                         (otherwise (serror 'simple-reader-error stream
1458                                            "illegal end of dotted list")))))))
1459            (cond
1460              ((char= #\) ch) (loop-finish))
1461              ((char= #\. ch)
1462               (if (token-delimiter-p (peek-char nil stream t nil t))
1463                   (if (eq result last-cons)
1464                       (serror 'simple-reader-error stream
1465                               "missing an object before the \".\" in a cons cell")
1466                       (case last-cdr-p
1467                         ((nil)     (setf last-cdr-p t))
1468                         ((t)       (serror 'simple-reader-error stream
1469                                            "token \".\" not allowed here"))
1470                         (otherwise (serror 'simple-reader-error stream
1471                                            "illegal end of dotted list"))))
1472                   (read-and-nconc ch)))
1473              (t
1474               (read-and-nconc ch))))
1475      
1476      :finally (if (eq last-cdr-p 't)
1477                   (serror 'simple-reader-error stream
1478                                          "illegal end of dotted list")
1479                   (return (cdr result)))))
1480
1481
1482 (defun reader-macro-error-start (stream ch)
1483   (serror 'simple-reader-error stream
1484           "an object cannot start with ~C" ch))
1485
1486 ;;;----------------------------------------
1487 ;;; STANDARD READER DISPATCH MACRO FUNCTIONS
1488 ;;;----------------------------------------
1489
1490 (defun reader-dispatch-macro-label-reference   (stream arg sub-char)
1491   "Standard ## dispatch macro reader."
1492   (declare (ignore sub-char))
1493   (when (null arg)
1494     (serror 'simple-reader-error stream
1495             "a number must be given between # and #"))
1496   (multiple-value-bind (object presentp) (gethash arg *references*)
1497     (if presentp
1498         object
1499         (serror 'simple-reader-error stream "undefined label #~D#" arg))))
1500
1501
1502 (defun reader-dispatch-macro-label-definition  (stream arg sub-char)
1503   "Standard #= dispatch macro reader."
1504   (declare (ignore sub-char))
1505   (when (null arg)
1506     (serror 'simple-reader-error stream
1507             "a number must be given between # and ="))
1508   (multiple-value-bind (object presentp) (gethash arg *references*)
1509     (if presentp
1510         (serror 'simple-reader-error stream
1511                 "label #~D=~S already defined as ~S"
1512                 (read stream t nil t) arg object)
1513         (setf (gethash arg *references*) (read stream t nil t)))))
1514
1515
1516 (defun eval-feature (expression stream)
1517   "Evaluates a feature expression as a BOOLEAN."
1518   (flet ((illegal-feature ()
1519            (serror 'simple-reader-error stream "illegal feature ~S" expression))
1520          (eval-term (term)
1521            (eval-feature term stream)))
1522     (cond
1523       ;; Some implementations accept any atom:
1524       ((atom    expression) (not (null (member expression *features*))))
1525       (t (case (first expression)
1526            ((:not) (if (cddr expression)
1527                        (illegal-feature)
1528                        (not (eval-feature (second expression) stream))))
1529            ((:and) (every (function eval-term) (rest expression)))
1530            ((:or)  (some  (function eval-term) (rest expression)))
1531            (t      (illegal-feature)))))))
1532
1533
1534 (defun read-feature (stream affirmativep)
1535   "Reads a feature expression, and possibly eats one following sexp"
1536   (let ((expression (let ((*package*  (find-package "KEYWORD"))
1537                           (*read-suppress* nil))
1538                       (read stream nil stream t))))
1539     ;; (print `(:read-feature ,expression))
1540     (when (eq expression stream)
1541       (serror 'simple-end-of-file stream
1542               "EOF in ~S while reading the feature expression" stream))
1543     (unless (funcall (if affirmativep
1544                          (function identity)
1545                          (function not))
1546                      (eval-feature expression stream))
1547       ;; (print `(:read-feature ,expression false we eat))
1548       (let ((*read-suppress* t))
1549         ;; (print `(:read-feature ,(read stream t nil nil) :eaten))
1550         (read stream t nil nil)))
1551     (values)))
1552
1553
1554 (defun reader-dispatch-macro-feature           (stream arg sub-char)
1555   "Standard #+ dispatch macro reader."
1556   (declare (ignore sub-char arg))
1557   (read-feature stream t))
1558
1559
1560 (defun reader-dispatch-macro-not-feature       (stream arg sub-char)
1561   "Standard #- dispatch macro reader."
1562   (declare (ignore sub-char arg))
1563   (read-feature stream nil))
1564
1565
1566 ;; (defparameter *rt*
1567 ;;   (let ((rt (copy-readtable)))
1568 ;;     (set-dispatch-macro-character
1569 ;;      #\# #\+ (function reader-dispatch-macro-feature) rt)
1570 ;;     (set-dispatch-macro-character
1571 ;;      #\# #\- (function reader-dispatch-macro-not-feature) rt)
1572 ;;     rt))
1573
1574
1575 (defun reader-dispatch-macro-read-eval         (stream arg sub-char)
1576   "Standard #. dispatch macro reader."
1577   (declare (ignore sub-char arg))
1578   (if *read-eval*
1579       (eval (read stream t nil t))
1580       (serror 'simple-reader-error stream
1581               "*READ-EVAL* = NIL does not allow the evaluation of ~S"
1582               (read stream t nil t))))
1583
1584
1585 (defun reader-dispatch-macro-uninterned        (stream arg sub-char)
1586   "Standard #: dispatch macro reader."
1587   (declare (ignore sub-char arg))
1588   (multiple-value-bind (tokenp token)
1589       (read-token stream t nil t nil nil *readtable*)
1590     (if tokenp
1591         (make-symbol (token-text token))
1592         (serror 'simple-reader-error stream
1593                 "token expected after #:"))))
1594
1595
1596 (defun reader-dispatch-macro-unreadable        (stream arg sub-char)
1597   "Standard #< dispatch macro reader."
1598   (declare (ignore sub-char arg))
1599   (serror 'simple-reader-error stream
1600           "objects printed as #<...> cannot be read back in"))
1601
1602
1603 (defun reader-dispatch-macro-comment           (stream arg sub-char)
1604   "Standard #| dispatch macro reader."
1605   (declare (ignore sub-char arg))
1606   ;; #|...|# is treated as a comment by the reader. It must be balanced
1607   ;; with respect to other occurrences of #| and |#, but otherwise may
1608   ;; contain any characters whatsoever.
1609   (loop
1610      :with level = 1
1611      :with state = :normal
1612      :until (zerop level)
1613      :do (case state
1614            ((:normal) (case (read-char stream t nil t)
1615                         ((#\#)              (setf state :sharp))
1616                         ((#\|)              (setf state :pipe))))
1617            ((:sharp)  (case (read-char stream t nil t)
1618                         ((#\#))
1619                         ((#\|) (incf level) (setf state :normal))
1620                         (otherwise          (setf state :normal))))
1621            ((:pipe)   (case (read-char stream t nil t)
1622                         ((#\#) (decf level) (setf state :normal))
1623                         ((#\|))
1624                         (otherwise          (setf state :normal))))))
1625   (values))
1626
1627
1628 (defun reader-dispatch-macro-function          (stream arg sub-char)
1629   "Standard #' dispatch macro reader."
1630   (declare (ignore sub-char arg))
1631   `(cl:function ,(read stream t nil t)))
1632
1633
1634 (defun reader-dispatch-macro-vector            (stream arg sub-char)
1635   "Standard #( dispatch macro reader."
1636   (declare (ignore sub-char))
1637   ;; If an unsigned decimal integer appears between the # and (, it
1638   ;; specifies explicitly the length of the vector. The consequences are
1639   ;; undefined if the number of objects specified before the closing )
1640   ;; exceeds the unsigned decimal integer. If the number of  objects
1641   ;; supplied before the closing ) is less than the unsigned decimal
1642   ;; integer but greater than zero, the last object is used to fill all
1643   ;; remaining elements of the  vector. The consequences are undefined if
1644   ;; the unsigned decimal integer is non-zero and number of objects
1645   ;; supplied before the closing ) is zero.  In that case, we let the
1646   ;; implementation initialize the vector.
1647   ;;
1648   ;; Thanks to Budden for having signaled a bug in the first version of this function,
1649   ;; and thanks to Yulian Tarantuk for signaling the "comment before closing parenthesis" bug.
1650   (flet ((finish-vector (vector i)
1651            (if arg
1652                (progn
1653                  (cond
1654                    ((>= i arg)
1655                     ;; vector is longer than the explicitly given length
1656                     ;; We just eat the remaining stuff.
1657                     (loop
1658                        :until (char= #\) (peek-char t stream t nil t))
1659                        :do (let ((*read-suppress* t))
1660                          (read-0/1 stream t nil t nil nil '()))
1661                        :finally (read-char stream nil nil t)))
1662                    ;; vector is shorter.
1663                    ((plusp i)
1664                     ;; If we have at least one element in,
1665                     ;; we replicate it till the end. 
1666                     (loop
1667                        :with last-item = (aref vector (1- i))
1668                        :for j :from i :below arg
1669                        :do (setf (aref vector j) last-item)))
1670                    ;; Otherwise we will let it up to the implementation
1671                    ;; to do its implementation dependent thing.
1672                    )
1673                  vector)
1674                (copy-seq vector))))
1675     (loop
1676        :with vector = (if arg
1677                           (make-array arg)
1678                           (make-array 1024 :adjustable t :fill-pointer 0))
1679        :for i :from 0 :while (or (not arg) (< i arg))
1680        :do (let ((peek (peek-char t stream nil stream t)))
1681              (cond
1682               ((eql peek stream)
1683                (serror 'simple-end-of-file stream
1684                        "input stream ~S has reached its end" stream))
1685               ((char= peek #\))
1686                (read-char stream nil nil t)
1687                (return-from reader-dispatch-macro-vector (finish-vector vector i)))
1688               (t
1689                (multiple-value-bind (kind tokens)
1690                    (read-0/1 stream t nil t nil nil '())
1691                  (declare (ignore kind)) ; always nil here.
1692                  (when tokens
1693                    (if arg
1694                        (setf (aref vector i) (first tokens))
1695                        (vector-push-extend (first tokens) vector)))))))
1696        :finally (return-from reader-dispatch-macro-vector (finish-vector vector i)))))
1697
1698
1699
1700
1701
1702 (defun reader-dispatch-macro-bit-vector        (stream arg sub-char)
1703   "Standard #* dispatch macro reader.
1704 URL: <http://www.lispworks.com/documentation/HyperSpec/Body/02_dhd.htm>
1705 "
1706   (declare (ignore sub-char))
1707   ;; Syntax: #*<<bits>>
1708   ;; 
1709   ;; A simple bit vector is constructed containing the indicated bits (0's
1710   ;; and 1's), where the leftmost bit has index zero and the subsequent
1711   ;; bits have increasing indices.
1712   ;; 
1713   ;; Syntax: #<<n>>*<<bits>>
1714   ;; 
1715   ;; With an argument n, the vector to be created is of length n. If the
1716   ;; number of bits is less than n but greater than zero, the last bit is
1717   ;; used to fill all remaining bits of the bit vector.
1718   ;; 
1719   ;; The notations #* and #0* each denote an empty bit vector.
1720   ;; 
1721   ;; Regardless of whether the optional numeric argument n is provided, the
1722   ;; token that follows the asterisk is delimited by a normal token
1723   ;; delimiter. However, (unless the  value of *read-suppress* is true) an
1724   ;; error of type reader-error is signaled if that  token is not composed
1725   ;; entirely of 0's and 1's, or if n was supplied and the token is
1726   ;; composed of more than n bits, or if n is greater than one, but no bits
1727   ;; were specified.  Neither a single escape nor a multiple escape is
1728   ;; permitted in this token.
1729   (if arg
1730       (loop
1731          :with vector = (make-array arg :element-type 'bit :initial-element 0)
1732          :for i :from 0 :below arg
1733          :while (let ((ch (peek-char nil stream nil nil t)))
1734                   (and ch (not (token-delimiter-p ch))))
1735          :do (setf (aref vector i) (digit-char-p (read-char stream nil nil t)))
1736          :finally (progn
1737                     (cond
1738                       ((>= i arg)
1739                        (let ((*read-suppress* t))
1740                          (loop
1741                             :while (let ((ch (peek-char nil stream nil nil t)))
1742                                      (and ch (not (token-delimiter-p ch))))
1743                             :do (read-char stream nil nil t))))
1744                       ((plusp (aref vector (1- i)))
1745                        (loop
1746                           :for j :from i :below arg
1747                           :do (setf (aref vector j) 1))))
1748                     (return vector)))
1749       (loop
1750          :with vector = (make-array 1024 :adjustable t :fill-pointer 0
1751                                     :element-type 'bit :initial-element 0)
1752          :while (let ((ch (peek-char nil stream nil nil t)))
1753                   (and ch (not (token-delimiter-p ch))))
1754          ;; TODO: Check the behavior when the character is not a bit.
1755          :do (vector-push-extend (digit-char-p (read-char stream nil nil t)) vector)
1756          :finally (return (copy-seq vector)))))
1757
1758
1759 (defun reader-dispatch-macro-char              (stream arg sub-char)
1760   "Standard #\\ dispatch macro reader."
1761   (declare (ignore sub-char arg))
1762   (read-char stream t nil t))
1763
1764
1765 (defun reader-dispatch-macro-array             (stream arg sub-char)
1766   "Standard #A dispatch macro reader."
1767   (declare (ignore sub-char))
1768   (let ((initial-contents (read stream t nil t)))
1769     (labels ((collect-dimensions (n contents dimensions)
1770              (if (zerop n)
1771                  (nreverse dimensions)
1772                  (collect-dimensions (1- n) (first contents)
1773                                      (cons (length contents) dimensions)))))
1774       ;; TODO: we rely on make-array to raise some errors that it may not raise...
1775       (make-array (collect-dimensions (or arg 1) initial-contents '())
1776                   :initial-contents initial-contents))))
1777
1778
1779
1780 (defun read-rational-in-base (stream arg sub-char *read-base*)
1781   "
1782 DO:      Read a rational number in the base specified.
1783 RETURN:  The rational read.
1784 "
1785   (when arg (serror stream "no number allowed between # and ~A" sub-char))
1786   (let ((value (read stream t nil t)))
1787     (if (rationalp value)
1788         value
1789         (serror stream
1790                 "token \"~A\" after #~A is not a rational number in base ~D"
1791                 sub-char *read-base*))))
1792
1793 (defun reader-dispatch-macro-binary            (stream arg sub-char)
1794   "Standard #B dispatch macro reader."
1795   (read-rational-in-base stream arg sub-char 2.))
1796
1797 (defun reader-dispatch-macro-octal             (stream arg sub-char)
1798   "Standard #O dispatch macro reader."
1799   (read-rational-in-base stream arg sub-char 8.))
1800
1801 (defun reader-dispatch-macro-hexadecimal       (stream arg sub-char)
1802   "Standard #X dispatch macro reader."
1803   (read-rational-in-base stream arg sub-char 16.))
1804
1805 (defun reader-dispatch-macro-radix             (stream arg sub-char)
1806   "Standard #R dispatch macro reader."
1807   (unless arg
1808     (serror stream "the number base must be given between # and ~A" sub-char)) 
1809   (read-rational-in-base stream nil sub-char arg))
1810
1811
1812 ;; Copied from com.informatimago.common-lisp.cesarum.list to avoid package use loop.
1813 (defun proper-list-p (object)
1814   "
1815 RETURN: whether object is a proper list
1816 NOTE:   terminates with any kind of list, dotted, circular, etc.
1817 "
1818   (labels ((proper (current slow)
1819              (cond ((null current)       t)
1820                    ((atom current)       nil)
1821                    ((null (cdr current)) t)
1822                    ((atom (cdr current)) nil)
1823                    ((eq current slow)    nil)
1824                    (t                    (proper (cddr current) (cdr slow))))))
1825     (and (listp object) (proper object (cons nil object)))))
1826
1827
1828 (defun reader-dispatch-macro-complex           (stream arg sub-char)
1829   "Standard #C dispatch macro reader."
1830   (declare (ignore sub-char arg))
1831   (let ((c (read stream t nil t)))
1832     (unless (and (proper-list-p c)
1833                  (= 2 (length c))
1834                  (every (function realp) c))
1835       (serror 'simple-reader-error stream
1836               "bad syntax for complex number: #C~S" c))
1837     (complex (first c) (second c))))
1838
1839
1840 (defun reader-dispatch-macro-pathname          (stream arg sub-char)
1841   "Standard #P dispatch macro reader."
1842   (declare (ignore sub-char arg))
1843   (pathname (read stream t nil t)))
1844
1845
1846 (defun reader-dispatch-macro-structure         (stream arg sub-char)
1847   "Standard #S dispatch macro reader."
1848   (declare (ignore sub-char arg))
1849   (let* ((data (read stream t nil t))
1850          (constructor (intern (cl:with-standard-io-syntax (format nil "MAKE-~A" (first data)))))
1851          (arguments   (loop
1852                          :with keyword-package = (find-package "KEYWORD")
1853                          :for (k v) :on (rest data) :by (function cddr)
1854                          :collect (intern (string k) keyword-package)
1855                          :collect v)))
1856     (apply constructor arguments)))
1857
1858
1859 ;;;;
1860 ;;;;
1861
1862
1863
1864 (defun test-proper-list-p ()
1865   (assert
1866    (every 
1867     (function identity)
1868     (mapcar (lambda (test) (eq (first test) (proper-list-p (second test))))
1869             '((nil x)
1870               (t ())
1871               (t (a))
1872               (t (a b))
1873               (t (a b c))
1874               (t (a b c d))
1875               (nil (a . x))
1876               (nil (a b . x))
1877               (nil (a b c . x))
1878               (nil (a b c d . x))
1879               (nil #1=(a . #1#))
1880               (nil #2=(a b . #2#))
1881               (nil #3=(a b c . #3#))
1882               (nil #4=(a b c d . #4#))
1883               (nil (1 . #1#))
1884               (nil (1 2 . #1#))
1885               (nil (1 2 3 . #1#))
1886               (nil (1 2 3 4 . #1#))
1887               (nil (1 . #2#))
1888               (nil (1 2 . #2#))
1889               (nil (1 2 3 . #2#))
1890               (nil (1 2 3 4 . #2#))
1891               (nil (1 . #3#))
1892               (nil (1 2 . #3#))
1893               (nil (1 2 3 . #3#))
1894               (nil (1 2 3 4 . #3#))
1895               (nil (1 . #4#))
1896               (nil (1 2 . #4#))
1897               (nil (1 2 3 . #4#))
1898               (nil (1 2 3 4 . #4#)))))))
1899 ;;;;
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909 (defmethod initialize-instance
1910     :after ((self readtable) &rest rest &key &allow-other-keys)
1911   (unless (getf rest :syntax-table)
1912     (macrolet ((smc (&rest clauses)
1913                  `(progn
1914                     ,@(mapcar (lambda (clause)
1915                                 `(set-macro-character
1916                                   ,(first clause)
1917                                   (function ,(second clause))
1918                                   ,(third clause)
1919                                   self))
1920                               clauses))))
1921       (smc
1922        (#\; reader-macro-line-comment     nil)
1923        (#\" reader-macro-string           nil)
1924        (#\' reader-macro-quote            nil)
1925        (#\` reader-macro-backquote        nil)
1926        (#\, reader-macro-comma            nil)
1927        (#\( reader-macro-left-parenthesis nil)
1928        (#\) reader-macro-error-start      nil)))
1929     (macrolet ((dmc (&rest clauses)
1930                  `(progn
1931                     ,@(mapcar (lambda (clause)
1932                                 `(set-dispatch-macro-character
1933                                   ,(first  clause)
1934                                   ,(second clause)
1935                                   (function ,(third clause))
1936                                   self))
1937                               clauses))))
1938       (make-dispatch-macro-character #\# t self)
1939       (dmc
1940        (#\# #\SPACE   reader-dispatch-macro-error-invalid)
1941        (#\# #\NEWLINE reader-dispatch-macro-error-invalid)
1942        (#\# #\# reader-dispatch-macro-label-reference)
1943        (#\# #\' reader-dispatch-macro-function)
1944        (#\# #\( reader-dispatch-macro-vector)
1945        (#\# #\* reader-dispatch-macro-bit-vector)
1946        (#\# #\+ reader-dispatch-macro-feature)
1947        (#\# #\- reader-dispatch-macro-not-feature)
1948        (#\# #\. reader-dispatch-macro-read-eval)
1949        (#\# #\: reader-dispatch-macro-uninterned)
1950        (#\# #\< reader-dispatch-macro-unreadable)
1951        (#\# #\= reader-dispatch-macro-label-definition)
1952        (#\# #\A reader-dispatch-macro-array)
1953        (#\# #\B reader-dispatch-macro-binary)
1954        (#\# #\C reader-dispatch-macro-complex)
1955        (#\# #\O reader-dispatch-macro-octal)
1956        (#\# #\P reader-dispatch-macro-pathname)
1957        (#\# #\R reader-dispatch-macro-radix)
1958        (#\# #\S reader-dispatch-macro-structure)
1959        (#\# #\X reader-dispatch-macro-hexadecimal)
1960        (#\# #\\ reader-dispatch-macro-char)
1961        (#\# #\| reader-dispatch-macro-comment)
1962        ;; clisp extensions:
1963        ;; (#\# #\! reader-dispatch-macro-executable)
1964        ;; (#\# #\" reader-dispatch-macro-clisp-pathname)
1965        ;; (#\# #\, reader-dispatch-macro-load-eval)
1966        ;; (#\# #\Y SYSTEM::CLOSURE-READER)
1967        ))))
1968
1969
1970 (setf *standard-readtable* (copy-readtable nil)
1971       *readtable*          (copy-readtable nil))
1972
1973
1974
1975 ;; or could go to UTILITIES, but this version will run on our own readtables...
1976 (defun list-all-macro-characters (&optional (*readtable* *readtable*))
1977   "
1978 RETURN: A list of all the macro and dispatch-macro characters in the readtable.
1979 "
1980   (loop
1981      :with results = '()
1982      :for code :from 0 :below char-code-limit
1983      :for ch = (code-char code)
1984      :do (multiple-value-bind (fun ntp) (get-macro-character ch)
1985            (when (or fun ntp)
1986              (push (list ch fun ntp
1987                          (when (handler-case
1988                                    (progn (get-dispatch-macro-character ch #\a)
1989                                           t)
1990                                  (error () nil))
1991                            (loop
1992                               :for code :from 0 :below char-code-limit
1993                               :for sub = (code-char code)
1994                               :for fun = (get-dispatch-macro-character ch sub)
1995                               :when fun
1996                               :collect (list sub fun)))) results)))
1997      :finally (return results)))
1998
1999
2000
2001 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2002 ;;; Tests
2003 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2004
2005
2006 (defun test/reader ()
2007   (let ((*read-base* 10)
2008         (*read-eval* t)
2009         (*read-suppress* nil)
2010         (*read-default-float-format* 'single-float))
2011     (dolist (test
2012               '(
2013                 ;; integer  ::= [sign] digit+      
2014                 (nil "0"  0.)
2015                 (nil "1"  1.)
2016                 (nil "2"  2.)
2017                 (nil "9"  9.)
2018                 (nil "10" 10.)
2019                 (nil "11" 11.)
2020                 (nil "12" 12.)
2021                 (nil "19" 19.)
2022                 (((*read-base* 3.)) "0"  0.)
2023                 (((*read-base* 3.)) "1"  1.)
2024                 (((*read-base* 3.)) "2"  2.)
2025                 (((*read-base* 3.)) "9"  |9|)
2026                 (((*read-base* 3.)) "10" 3.)
2027                 (((*read-base* 3.)) "11" 4.)
2028                 (((*read-base* 3.)) "13" |13|)
2029                 (nil "-0"  -0.)
2030                 (nil "-1"  -1.)
2031                 (nil "-2"  -2.)
2032                 (nil "-9"  -9.)
2033                 (nil "-10" -10.)
2034                 (nil "-11" -11.)
2035                 (nil "-12" -12.)
2036                 (nil "-19" -19.)
2037                 (((*read-base* 3.)) "-0"  -0.)
2038                 (((*read-base* 3.)) "-1"  -1.)
2039                 (((*read-base* 3.)) "-2"  -2.)
2040                 (((*read-base* 3.)) "-9"  |-9|)
2041                 (((*read-base* 3.)) "-10" -3.)
2042                 (((*read-base* 3.)) "-11" -4.)
2043                 (((*read-base* 3.)) "-13" |-13|)
2044                 (nil "+0"  +0.)
2045                 (nil "+1"  +1.)
2046                 (nil "+2"  +2.)
2047                 (nil "+9"  +9.)
2048                 (nil "+10" +10.)
2049                 (nil "+11" +11.)
2050                 (nil "+12" +12.)
2051                 (nil "+19" +19.)
2052                 (((*read-base* 3.)) "+0"  +0.)
2053                 (((*read-base* 3.)) "+1"  +1.)
2054                 (((*read-base* 3.)) "+2"  +2.)
2055                 (((*read-base* 3.)) "+9"  |+9|)
2056                 (((*read-base* 3.)) "+10" +3.)
2057                 (((*read-base* 3.)) "+11" +4.)
2058                 (((*read-base* 3.)) "+13" |+13|)
2059                 ;; integer  ::= [sign] decimal-digit+ decimal-point 
2060                 (nil "0."  0.)
2061                 (nil "1."  1.)
2062                 (nil "2."  2.)
2063                 (nil "9."  9.)
2064                 (nil "10." 10.)
2065                 (nil "11." 11.)
2066                 (nil "12." 12.)
2067                 (nil "19." 19.)
2068                 (((*read-base* 3.)) "0."  0.)
2069                 (((*read-base* 3.)) "1."  1.)
2070                 (((*read-base* 3.)) "2."  2.)
2071                 (((*read-base* 3.)) "9."  9.)
2072                 (((*read-base* 3.)) "10." 10.)
2073                 (((*read-base* 3.)) "11." 11.)
2074                 (((*read-base* 3.)) "13." 13.)
2075                 (nil "-0."  -0.)
2076                 (nil "-1."  -1.)
2077                 (nil "-2."  -2.)
2078                 (nil "-9."  -9.)
2079                 (nil "-10." -10.)
2080                 (nil "-11." -11.)
2081                 (nil "-12." -12.)
2082                 (nil "-19." -19.)
2083                 (((*read-base* 3.)) "-0."  -0.)
2084                 (((*read-base* 3.)) "-1."  -1.)
2085                 (((*read-base* 3.)) "-2."  -2.)
2086                 (((*read-base* 3.)) "-9."  -9.)
2087                 (((*read-base* 3.)) "-10." -10.)
2088                 (((*read-base* 3.)) "-11." -11.)
2089                 (((*read-base* 3.)) "-13." -13.)
2090                 (nil "+0."  +0.)
2091                 (nil "+1."  +1.)
2092                 (nil "+2."  +2.)
2093                 (nil "+9."  +9.)
2094                 (nil "+10." +10.)
2095                 (nil "+11." +11.)
2096                 (nil "+12." +12.)
2097                 (nil "+19." +19.)
2098                 (((*read-base* 3.)) "+0."  +0.)
2099                 (((*read-base* 3.)) "+1."  +1.)
2100                 (((*read-base* 3.)) "+2."  +2.)
2101                 (((*read-base* 3.)) "+9."  +9.)
2102                 (((*read-base* 3.)) "+10." +10.)
2103                 (((*read-base* 3.)) "+11." +11.)
2104                 (((*read-base* 3.)) "+13." +13.)
2105                 ;; ratio    ::= [sign] {digit}+ slash {digit}+
2106                 (nil "0/0"    nil division-by-zero)
2107                 (nil "1/0"    nil division-by-zero)
2108                 (nil "10/000" nil division-by-zero)
2109                 (nil "0/1" 0)
2110                 (nil "1/1" 1)
2111                 (nil "2/1" 2)
2112                 (nil "20/10" 2)
2113                 (nil "200/100" 2)
2114                 (nil "0/2" 0)
2115                 (nil "1/2" 1/2)
2116                 (nil "0/20" 0)
2117                 (nil "10/20" 1/2)
2118                 (nil "100/200" 1/2)
2119                 (nil "001/2" 1/2)
2120                 (nil "000/20" 0)
2121                 (nil "010/20" 1/2)
2122                 (nil "100/200" 1/2)
2123                 (nil "12345/54321" 12345/54321)
2124                 (nil "+0/0"    nil division-by-zero)
2125                 (nil "+1/0"    nil division-by-zero)
2126                 (nil "+10/000" nil division-by-zero)
2127                 (nil "+0/1" 0)
2128                 (nil "+1/1" 1)
2129                 (nil "+2/1" 2)
2130                 (nil "+20/10" 2)
2131                 (nil "+200/100" 2)
2132                 (nil "+0/2" 0)
2133                 (nil "+1/2" 1/2)
2134                 (nil "+0/20" 0)
2135                 (nil "+10/20" 1/2)
2136                 (nil "+100/200" 1/2)
2137                 (nil "+001/2" 1/2)
2138                 (nil "+000/20" 0)
2139                 (nil "+010/20" 1/2)
2140                 (nil "+100/200" 1/2)
2141                 (nil "+12345/54321" 12345/54321)
2142                 (nil "-0/0"    nil division-by-zero)
2143                 (nil "-1/0"    nil division-by-zero)
2144                 (nil "-10/000" nil division-by-zero)
2145                 (nil "-0/1" -0)
2146                 (nil "-1/1" -1)
2147                 (nil "-2/1" -2)
2148                 (nil "-20/10" -2)
2149                 (nil "-200/100" -2)
2150                 (nil "-0/2" -0)
2151                 (nil "-1/2" -1/2)
2152                 (nil "-0/20" -0)
2153                 (nil "-10/20" -1/2)
2154                 (nil "-100/200" -1/2)
2155                 (nil "-001/2" -1/2)
2156                 (nil "-000/20" -0)
2157                 (nil "-010/20" -1/2)
2158                 (nil "-100/200" -1/2)
2159                 (nil "-12345/54321" -12345/54321)
2160 ;;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ exponent
2161 ;;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ 
2162 ;;; float    ::= [sign] {decimal-digit}+ exponent
2163 ;;; float    ::= [sign] {decimal-digit}+ decimal-point {decimal-digit}* exponent
2164 ;;; exponent ::=  exponent-marker [sign] {digit}+
2165 ;;; 
2166 ;;; consing-dot   ::= dot
2167 ;;; 
2168 ;;; symbol        ::= symbol-name
2169 ;;;                 | package-marker symbol-name
2170 ;;;                 | package-marker package-marker symbol-name
2171 ;;;                 | package-name package-marker symbol-name
2172 ;;;                 | package-name package-marker package-marker symbol-name
2173                 )
2174              :success)
2175       (multiple-value-bind (val err)
2176           (ignore-errors
2177             (eval `(progv
2178                        ',(mapcar (function first)  (first test))
2179                        ',(mapcar (function second) (first test))
2180                      (read-from-string ,(second test)))))
2181         (assert
2182          (if (fourth test)
2183              (typep err (fourth test))
2184              (eql   val (third test)))
2185          nil "~S gives ~:[~S~;~:*~S~*~]; expected: ~S"
2186          `(let ,(first test) (read-from-string ,(second test)))
2187          err val
2188          (or (fourth test) (third test)))))))
2189
2190
2191 (defun test-cases (test-name cases)
2192   (dolist (test cases :success)
2193     (destructuring-bind (expression expected-values expected-error) test
2194       (multiple-value-bind (actual-values actual-error)
2195           (ignore-errors (multiple-value-list (eval expression)))
2196         (assert (or (and (null expected-error) (null actual-error))
2197                     (typep actual-error expected-error))
2198                 () "Test ~A~%Testing ~S, expected ~
2199                       ~:[no error~;an error of type ~:*~S~], ~
2200                       got this error: ~A"
2201                 test-name expression expected-error actual-error)
2202         (assert (equalp expected-values actual-values)
2203                 () "Test ~A~%Testing ~S, expected ~S, got ~S" expression
2204                 test-name expected-values actual-values)))))
2205
2206
2207 (defmacro tests (&rest cases)
2208   (if (stringp (first cases))
2209       `(test-cases ,(first cases) ',(rest cases))
2210       `(test-cases "unamed" ',cases)))
2211
2212 (test/reader)
2213
2214 (tests "symbols"
2215        ((read-from-string "( abc ab a || |a| |ab| |a b c| )")
2216         ((abc ab a || |a| |ab| |a b c|) ;
2217          32)
2218         nil))
2219
2220 (let ((*features* '(:a :b :c)))
2221   (tests "*features*"
2222    ((eval-feature ':a *standard-input*)           (t)   nil)
2223    ((eval-feature ':z *standard-input*)           (nil) nil)
2224    ((eval-feature '42 *standard-input*)           (nil) nil)
2225    ((eval-feature '(:not :a)    *standard-input*) (nil) nil)
2226    ((eval-feature '(:not :z)    *standard-input*) (t)   nil)
2227    ((eval-feature '(:not :a :b) *standard-input*) ()    reader-error)
2228    ((eval-feature '(:and)       *standard-input*) (t)   nil)
2229    ((eval-feature '(:and :a)    *standard-input*) (t)   nil)
2230    ((eval-feature '(:and :a :b) *standard-input*) (t)   nil)
2231    ((eval-feature '(:and :a :c) *standard-input*) (t)   nil)
2232    ((eval-feature '(:and :a :z) *standard-input*) (nil) nil)
2233    ((eval-feature '(:and :y :z) *standard-input*) (nil) nil)
2234    ((eval-feature '(:or)        *standard-input*) (nil) nil)
2235    ((eval-feature '(:or :a)     *standard-input*) (t)   nil)
2236    ((eval-feature '(:or :a :b)  *standard-input*) (t)   nil)
2237    ((eval-feature '(:or :a :c)  *standard-input*) (t)   nil)
2238    ((eval-feature '(:or :a :z)  *standard-input*) (t)   nil)
2239    ((eval-feature '(:or :y :z)  *standard-input*) (nil) nil)
2240    ((eval-feature '(:or (:and :a (:not :z)) (:and (:not :a) :z))
2241                   *standard-input*)               (t)   nil)
2242    ((eval-feature '(:and (:or :a (:not :z)) (:or (:not :a) :z))
2243                   *standard-input*)               (nil) nil)
2244    ((eval-feature '(:and :a :b (:or :y :z (:not :a)))
2245                   *standard-input*)               (nil) nil)
2246    ((eval-feature '(:and :a :b (:or :y :z (:not 42)))
2247                   *standard-input*)               (t)   nil)))
2248
2249
2250
2251 (tests "lists"
2252  ((read-from-string "()")                       (() 2)           nil)
2253  ((read-from-string "(a)")                      ((a) 3)          nil)
2254  ((read-from-string "(a b)")                    ((a b) 5)        nil)
2255  ((read-from-string "(a b c)")                  ((a b c) 7)      nil)
2256  ((read-from-string "(a b c d)")                ((a b c d) 9)    nil)
2257  ((read-from-string "(a b c . d)")              ((a b c . d) 11)  nil)
2258  ((read-from-string "(a b c . d e)")            nil            reader-error)
2259  ((read-from-string "(a b c . . d)")            nil            reader-error)
2260  ((read-from-string "(a b c . d .)")            nil            reader-error)
2261  ((let ((*features* '(:test)))
2262     (read-from-string "(a b c #+test d)"))      ((a b c d) 16)    nil)
2263  ((let ((*features* '(:test)))
2264     (read-from-string "(a b c #-test d)"))      ((a b c) 16)      nil)
2265  ((let ((*features* '(:test)))
2266     (read-from-string "(a b c . #+test d)"))    ((a b c . d) 18)  nil)
2267  ((let ((*features* '(:test)))
2268     (read-from-string "(a b c . #-test d e)"))  ((a b c . e) 20)  nil)
2269  ((let ((*features* '(:test)))
2270     (read-from-string "(a b c #+test . d)"))    ((a b c . d) 18)  nil)
2271  ((let ((*features* '(:test)))
2272     (read-from-string "(a b c #-test . d)"))    ((a b c d) 18)    nil)
2273  ((read-from-string "(#+(or) #$foo       xyz)") nil               reader-error)
2274  ((read-from-string "(#+(or) abc:def:ghi xyz)") ((xyz) 24)        nil))
2275
2276
2277 (tests "#+ with #= and ##"
2278  ((let ((*features* (quote (:a :b))))
2279     (read-from-string "(#+#1=(or a b) #1#)"))
2280   (((:or :a :b)) 19)
2281   nil)
2282  ((let ((*features* (quote (:a :b))))
2283     (read-from-string "(#+#.(cl:if (cl:eq :a (cl:first cl:*features*)) '(:and) '(:or)) equal)"))
2284   ((equal) 70)
2285   nil))
2286
2287
2288 #- (and)
2289 (tests 
2290  ((let ((*features* (quote (:a :b)))) 
2291     (read-from-string "#+#1=(or a b) #1#"))
2292   ((:or :a :b) 44)
2293   nil))
2294
2295
2296 (tests "bit vectors, numbers, and pathnames"
2297  ((read-from-string "(#*101111 #6*10111110101 #6*101111 #6*1010 #6*1011 #* #0*11010)")
2298   ((#*101111 #*101111 #*101111 #*101000 #*101111 #* #*) 63)
2299   nil)
2300  ((read-from-string "(#b10111101 #o275 #xbd #36r59)")
2301   ((189 189 189 189) 30)
2302   nil)
2303  ((read-from-string "#P\"/tmp/a.c\"")
2304   (#.(make-pathname :directory '(:absolute "tmp")
2305                      :name "a"
2306                      :type "c"
2307                      :version #+(or ecl sbcl) :newest #-(or ecl sbcl) nil
2308                      :case :local) 12)
2309   nil))
2310
2311 #- (and)
2312 (tests
2313  ((progn
2314     (defstruct s a b c) (read-from-string "#S(s a 1 b 2 c 3)"))
2315   (#s(s :a 1 :b 2 :c 3) 17)
2316   nil))
2317
2318
2319 (tests "complex numbers"
2320  ((read-from-string "( #C(123 456) #c(-123 456)
2321                        #C(12.3 456) #c(-123 45.6)
2322                        #C(123/10 456/100) #c(-123/10 456/100) )")
2323   (( #c(123 456) #c(-123 456)
2324                        #c(12.3 456) #c(-123 45.6)
2325                        #c(123/10 456/100) #c(-123/10 456/100) )
2326    140)
2327   nil))
2328
2329
2330
2331 (tests "read-delimited-list with comments"
2332  ((with-input-from-string (src " \"!A\"
2333 ) def)
2334 ")
2335     (values (read-delimited-list #\) src)
2336             (read-delimited-list #\) src)))
2337   (("!A") (def))
2338   nil)
2339
2340  ((with-input-from-string (src "#( \"!A\" 
2341 ) (def)
2342 ")
2343     (values (read src)
2344             (read src)))
2345   (#("!A") (def))
2346   nil)
2347
2348  ((with-input-from-string (src "( \"!A\"
2349 ) (def)
2350 ")
2351     (values (read src)
2352             (read src)))
2353   (("!A") (def))
2354   nil)
2355
2356  ((with-input-from-string (src " \"!A\" ; comment
2357 ) def)
2358 ")
2359     (values (read-delimited-list #\) src)
2360             (read-delimited-list #\) src)))
2361   (("!A") (def))
2362   nil)
2363  
2364   ((with-input-from-string (src "#( \"!A\"  ; comment
2365 ) (def)
2366 ")
2367     (values (read src)
2368             (read src)))
2369   (#("!A") (def))
2370   nil)
2371
2372   ((with-input-from-string (src "( \"!A\" ; comment
2373 ) (def)
2374 ")
2375     (values (read src)
2376             (read src)))
2377   (("!A") (def))
2378   nil))
2379
2380