home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / reader.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  47.6 KB  |  1,418 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: reader.lisp,v 1.16 92/06/04 17:03:51 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Spice Lisp Reader 
  15. ;;; Written by David Dill
  16. ;;; Package system interface by Lee Schumacher.
  17. ;;; Runs in the standard Spice Lisp environment.
  18. ;;;
  19.  
  20. (in-package "EXTENSIONS")
  21. (export '*ignore-extra-close-parentheses*)
  22.  
  23. (in-package "LISP")
  24. (export '(readtable readtable-case readtablep *read-base* *readtable*
  25.       copy-readtable set-syntax-from-char set-macro-character
  26.       get-macro-character make-dispatch-macro-character
  27.       set-dispatch-macro-character get-dispatch-macro-character read
  28.       *read-default-float-format* read-preserving-whitespace
  29.       read-delimited-list parse-integer read-from-string *read-suppress*
  30.       reader-error))
  31.  
  32.  
  33. ;;;Random global variables
  34.  
  35. (defvar *read-default-float-format* 'single-float "Float format for 1.0E1")
  36.  
  37. (defvar *readtable* () "Variable bound to current readtable.")
  38.  
  39.  
  40. ;;;; Reader errors:
  41.  
  42. (define-condition reader-error (stream-error)
  43.   (format-control
  44.    (format-arguments :init-form ()))
  45.   (:report
  46.    (lambda (condition stream)
  47.      (let ((error-stream (stream-error-stream condition)))
  48.        (format stream "Reader error ~@[at ~D ~]on ~S:~%~?"
  49.            (file-position error-stream) error-stream
  50.            (reader-error-format-control condition)
  51.            (reader-error-format-arguments condition))))))
  52.  
  53. (define-condition reader-package-error (reader-error))
  54.  
  55. ;;; %READ-ERROR  --  Interface
  56. ;;;
  57. ;;;    Like, signal a READ-ERROR, man...
  58. ;;;
  59. (defun %reader-error (stream control &rest args)
  60.   (error 'reader-error :stream stream  :format-control control
  61.      :format-arguments args))
  62.  
  63. (define-condition reader-eof-error (end-of-file)
  64.   (context)
  65.   (:report
  66.    (lambda (condition stream)
  67.      (format stream "Unexpected EOF on ~S ~A."
  68.          (stream-error-stream condition)
  69.          (reader-eof-error-context condition)))))
  70.  
  71. (defun reader-eof-error (stream context)
  72.   (error 'reader-eof-error :stream stream  :context context))
  73.   
  74.  
  75. ;;;; Readtable implementation.
  76.  
  77.  
  78. (defvar std-lisp-readtable ()
  79.   "Standard lisp readtable. This is for recovery from broken
  80.    read-tables, and should not normally be user-visible.")
  81.  
  82. (defstruct (readtable
  83.         (:conc-name nil)
  84.         (:predicate readtablep)
  85.         (:copier nil)
  86.         (:print-function
  87.          (lambda (s stream d)
  88.            (declare (ignore d))
  89.            (print-unreadable-object (s stream :identity t)
  90.          (prin1 'readtable stream)))))
  91.   "Readtable is a data structure that maps characters into syntax
  92.    types for the Common Lisp expression reader."
  93.   ;; The CHARACTER-ATTRIBUTE-TABLE is a vector of CHAR-CODE-LIMIT integers for
  94.   ;; describing the character type.  Conceptually, there are 4 distinct
  95.   ;; "primary" character attributes: WHITESPACE, TERMINATING-MACRO, ESCAPE, and
  96.   ;; CONSTITUENT.  Non-terminating macros (such as the symbol reader) have the
  97.   ;; attribute CONSTITUENT.
  98.   ;;
  99.   ;; In order to make the READ-TOKEN fast, all this information is
  100.   ;; stored in the character attribute table by having different varieties of
  101.   ;; constituents.
  102.   (character-attribute-table (make-character-attribute-table)
  103.                  :type simple-vector)
  104.   ;;
  105.   ;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT functions.  One
  106.   ;; of these functions called with appropriate arguments whenever any
  107.   ;; non-WHITESPACE character is encountered inside READ-PRESERVING-WHITESPACE.
  108.   ;; These functions are used to implement user-defined read-macros, system
  109.   ;; read-macros, and the number-symbol reader.
  110.   (character-macro-table (make-character-macro-table) :type simple-vector)
  111.   ;;
  112.   ;; DISPATCH-TABLES entry, which is an alist from dispatch characters to
  113.   ;; vectors of CHAR-CODE-LIMIT functions, for use in defining dispatching
  114.   ;; macros (like #-macro).
  115.   (dispatch-tables () :type list)
  116.   (readtable-case :upcase :type (member :upcase :downcase :preserve :invert)))
  117.  
  118.  
  119. ;;;; Constants for character attributes.  These are all as in the manual.
  120.  
  121. (eval-when (compile load eval)
  122.   (defconstant whitespace 0)
  123.   (defconstant terminating-macro 1)
  124.   (defconstant escape 2)
  125.   (defconstant constituent 3)
  126.   (defconstant constituent-dot 4)
  127.   (defconstant constituent-expt 5)
  128.   (defconstant constituent-slash 6)
  129.   (defconstant constituent-digit 7)
  130.   (defconstant constituent-sign 8)
  131.   ; 9
  132.   (defconstant multiple-escape 10)
  133.   (defconstant package-delimiter 11)
  134.   ;;fake attribute for use in read-unqualified-token
  135.   (defconstant delimiter 12))
  136.  
  137.  
  138. ;;;; Package specials.
  139.  
  140. (defvar *old-package* ()
  141.   "Value of *package* at the start of the last read or Nil.")
  142.  
  143. ;;; In case we get an error trying to parse a symbol, we want to rebind the
  144. ;;; above stuff so it's cool.
  145.  
  146. (proclaim '(special *package* *keyword-package* *read-base*))
  147.  
  148.  
  149.  
  150. ;;;; Macros and functions for character tables.
  151.  
  152. (defmacro get-cat-entry (char rt)
  153.   ;;only give this side-effect-free args.
  154.   `(elt (the simple-vector (character-attribute-table ,rt))
  155.     (char-code ,char)))
  156.  
  157. (defun set-cat-entry (char newvalue &optional (rt *readtable*))
  158.   (setf (elt (the simple-vector (character-attribute-table rt))
  159.          (char-code char))
  160.     newvalue))
  161.  
  162. (defmacro get-cmt-entry (char rt)
  163.   `(elt (the simple-vector (character-macro-table ,rt))
  164.     (char-code ,char)))
  165.  
  166. (defun set-cmt-entry (char newvalue &optional (rt *readtable*))
  167.   (setf (elt (the simple-vector (character-macro-table rt))
  168.          (char-code char))
  169.     newvalue))
  170.  
  171. (defun make-character-attribute-table ()
  172.   (make-array char-code-limit :element-type t :initial-element #.constituent))
  173.  
  174. (defun make-character-macro-table ()
  175.   (make-array char-code-limit :element-type t
  176.           :initial-element #'undefined-macro-char))
  177.  
  178. (defun undefined-macro-char (stream char)
  179.   (unless *read-suppress*
  180.     (%reader-error stream "Undefined read-macro character ~S" char)))
  181.  
  182. ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers. 
  183.  
  184. (defmacro test-attribute (char whichclass rt)
  185.   `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass))
  186.  
  187. ;;; Predicates for testing character attributes
  188.  
  189. ;;; Make this a function, since other people want to use it.
  190. ;;;
  191. (proclaim '(inline whitespacep))
  192. (defun whitespacep (char &optional (rt *readtable*))
  193.   (test-attribute char whitespace rt))
  194.  
  195. (defmacro constituentp (char &optional (rt '*readtable*))
  196.   `(>= (get-cat-entry ,char ,rt) #.constituent))
  197.  
  198. (defmacro terminating-macrop (char &optional (rt '*readtable*))
  199.   `(test-attribute ,char #.terminating-macro ,rt))
  200.  
  201. (defmacro escapep (char &optional (rt '*readtable*))
  202.   `(test-attribute ,char #.escape ,rt))
  203.  
  204. (defmacro multiple-escape-p (char &optional (rt '*readtable*))
  205.   `(test-attribute ,char #.multiple-escape ,rt))
  206.  
  207. (defmacro token-delimiterp (char &optional (rt '*readtable*))
  208.   ;;depends on actual attribute numbering above.
  209.   `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
  210.  
  211.  
  212.  
  213. ;;;; Secondary attribute table.
  214.  
  215. ;;; There are a number of "secondary" attributes which are constant properties
  216. ;;; of characters characters (as long as they are constituents).
  217.  
  218. (defvar secondary-attribute-table ())
  219.  
  220. (defun set-secondary-attribute (char attribute)
  221.   (setf (elt (the simple-vector secondary-attribute-table) (char-code char))
  222.     attribute))
  223.  
  224.  
  225. (defun init-secondary-attribute-table ()
  226.   (setq secondary-attribute-table
  227.     (make-array char-code-limit :element-type t
  228.             :initial-element #.constituent))
  229.   (set-secondary-attribute #\: #.package-delimiter)
  230.   (set-secondary-attribute #\| #.multiple-escape)    ; |) [For EMACS]
  231.   (set-secondary-attribute #\. #.constituent-dot)
  232.   (set-secondary-attribute #\+ #.constituent-sign)
  233.   (set-secondary-attribute #\- #.constituent-sign)
  234.   (set-secondary-attribute #\/ #.constituent-slash)  
  235.   (do ((i (char-code #\0) (1+ i)))
  236.       ((> i (char-code #\9)))
  237.     (set-secondary-attribute (code-char i) #.constituent-digit))
  238.   (set-secondary-attribute #\E #.constituent-expt)
  239.   (set-secondary-attribute #\F #.constituent-expt)
  240.   (set-secondary-attribute #\D #.constituent-expt)
  241.   (set-secondary-attribute #\S #.constituent-expt)
  242.   (set-secondary-attribute #\L #.constituent-expt)
  243.   (set-secondary-attribute #\e #.constituent-expt)
  244.   (set-secondary-attribute #\f #.constituent-expt)
  245.   (set-secondary-attribute #\d #.constituent-expt)
  246.   (set-secondary-attribute #\s #.constituent-expt)
  247.   (set-secondary-attribute #\l #.constituent-expt))
  248.  
  249. (defmacro get-secondary-attribute (char)
  250.   `(elt (the simple-vector secondary-attribute-table)
  251.     (char-code ,char)))
  252.  
  253.  
  254.  
  255. ;;;; Readtable operations.
  256.  
  257. (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
  258.   "A copy is made of from-readtable and place into to-readtable."
  259.   (let ((from-readtable (or from-readtable std-lisp-readtable))
  260.     (to-readtable (or to-readtable (make-readtable))))
  261.     ;;physically clobber contents of internal tables.
  262.     (replace (character-attribute-table to-readtable)
  263.          (character-attribute-table from-readtable))
  264.     (replace (character-macro-table to-readtable)
  265.          (character-macro-table from-readtable))
  266.     (setf (dispatch-tables to-readtable)
  267.       (mapcar #'(lambda (pair) (cons (car pair)
  268.                      (copy-seq (cdr pair))))
  269.           (dispatch-tables from-readtable)))
  270.     to-readtable))
  271.  
  272. (defun set-syntax-from-char (to-char from-char &optional
  273.                      (to-readtable *readtable*)
  274.                      (from-readtable ()))
  275.   "Causes the syntax of to-char to be the same as from-char in the 
  276.   optional readtable (defaults to the current readtable).  The
  277.   from-table defaults the standard lisp readtable by being nil."
  278.   (let ((from-readtable (or from-readtable std-lisp-readtable)))
  279.     ;;copy from-char entries to to-char entries, but make sure that if
  280.     ;;from char is a constituent you don't copy non-movable secondary
  281.     ;;attributes (constituent types), and that said attributes magically
  282.     ;;appear if you transform a non-constituent to a constituent.
  283.     (let ((att (get-cat-entry from-char from-readtable)))
  284.       (if (constituentp from-char from-readtable)
  285.       (setq att (get-secondary-attribute to-char)))
  286.       (set-cat-entry to-char att to-readtable)
  287.       (set-cmt-entry to-char
  288.              (get-cmt-entry from-char from-readtable)
  289.              to-readtable)))
  290.   t)
  291.  
  292. (defun set-macro-character (char function &optional
  293.                  (non-terminatingp nil) (rt *readtable*))
  294.   "Causes char to be a macro character which invokes function when
  295.    seen by the reader.  The non-terminatingp flag can be used to
  296.    make the macro character non-terminating.  The optional readtable
  297.    argument defaults to the current readtable.  Set-macro-character
  298.    returns T."
  299.   (if non-terminatingp
  300.       (set-cat-entry char (get-secondary-attribute char) rt)
  301.       (set-cat-entry char #.terminating-macro rt))
  302.   (set-cmt-entry char function rt)
  303.   T)
  304.  
  305. (defun get-macro-character (char &optional rt)
  306.   "Returns the function associated with the specified char which is a macro
  307.   character.  The optional readtable argument defaults to the current
  308.   readtable."
  309.   (let ((rt (or rt *readtable*)))
  310.     ;; Check macro syntax, return associated function if it's there.
  311.     ;; Returns a value for all constituents.
  312.     (cond ((constituentp char)
  313.        (values (get-cmt-entry char rt) t))
  314.       ((terminating-macrop char)
  315.        (values (get-cmt-entry char rt) nil))
  316.       (t nil))))
  317.  
  318.  
  319. ;;;; These definitions support internal programming conventions.
  320.  
  321. (defconstant eof-object '(*eof*))
  322.  
  323. (defmacro eofp (char) `(eq ,char eof-object))
  324.  
  325. (defun flush-whitespace (stream)
  326.   ;;This flushes whitespace chars, returning the last char it read (a non-white
  327.   ;;one).  It always gets an error on end-of-file.
  328.   (prepare-for-fast-read-char stream
  329.     (do ((attribute-table (character-attribute-table *readtable*))
  330.      (char (fast-read-char t) (fast-read-char t)))
  331.       ((/= (the fixnum (svref attribute-table (char-code char))) #.whitespace)
  332.        (done-with-fast-read-char)
  333.        char))))
  334.  
  335.  
  336.  
  337. ;;;; Temporary initialization hack.
  338.  
  339. (defun init-std-lisp-readtable ()
  340.   (setq std-lisp-readtable (make-readtable))
  341.   ;;all characters default to "constituent" in make-readtable
  342.   ;;*** un-constituent-ize some of these ***
  343.   (let ((*readtable* std-lisp-readtable))
  344.     (set-cat-entry #\tab #.whitespace)
  345.     (set-cat-entry #\linefeed #.whitespace)  
  346.     (set-cat-entry #\space #.whitespace)
  347.     (set-cat-entry #\page #.whitespace)
  348.     (set-cat-entry #\return #.whitespace)
  349.     (set-cat-entry #\\ #.escape)
  350.     (set-cmt-entry #\\ #'read-token)
  351.     (set-cat-entry #\rubout #.whitespace)
  352.     (set-cmt-entry #\: #'read-token)
  353.     (set-cmt-entry #\| #'read-token)
  354.     ;;macro definitions
  355.     (set-macro-character #\" #'read-string)
  356.     ;;* # macro
  357.     (set-macro-character #\' #'read-quote)
  358.     (set-macro-character #\( #'read-list)
  359.     (set-macro-character #\) #'read-right-paren)
  360.     (set-macro-character #\; #'read-comment)
  361.     ;;* backquote
  362.     ;;all constituents
  363.     (do ((ichar 0 (1+ ichar))
  364.      (char))
  365.     ((= ichar #O200))
  366.       (setq char (code-char ichar))
  367.       (when (constituentp char std-lisp-readtable)
  368.         (set-cat-entry char (get-secondary-attribute char))
  369.         (set-cmt-entry char #'read-token)))))
  370.  
  371.  
  372.  
  373. ;;;; read-buffer implementation.
  374.  
  375. (defvar read-buffer)
  376. (defvar read-buffer-length)
  377.  
  378. (defvar inch-ptr)
  379. (defvar ouch-ptr)
  380.  
  381. (defmacro reset-read-buffer ()
  382.   ;;turn read-buffer into an empty read-buffer.
  383.   ;;ouch-ptr always points to next char to write
  384.   `(progn
  385.     ;;next is in case interrupt processor has re-bound read-buffer to nil.
  386.     (unless (or (boundp 'read-buffer) read-buffer) (init-read-buffer))
  387.     (setq ouch-ptr 0)
  388.     ;;inch-ptr always points to next char to read
  389.     (setq inch-ptr 0)))
  390.  
  391. (defun init-read-buffer ()
  392.   (setq read-buffer (make-string 512))            ;initial bufsize
  393.   (setq read-buffer-length 512)
  394.   (reset-read-buffer))
  395.  
  396. (defmacro ouch-read-buffer (char)
  397.   `(progn
  398.     (if (>= (the fixnum ouch-ptr)
  399.         (the fixnum read-buffer-length))
  400.     ;;buffer overflow -- double the size
  401.     (grow-read-buffer))
  402.     (setf (elt (the simple-string read-buffer) ouch-ptr) ,char)
  403.     (setq ouch-ptr (1+ ouch-ptr))))
  404. ;; macro to move ouch-ptr back one.
  405. (defmacro ouch-unread-buffer ()
  406.   '(if (> (the fixnum ouch-ptr) (the fixnum inch-ptr))
  407.        (setq ouch-ptr (1- (the fixnum ouch-ptr)))))
  408.  
  409. (defun grow-read-buffer ()
  410.   (let ((rbl (length (the simple-string read-buffer))))
  411.     (declare (fixnum rbl))
  412.     (setq read-buffer
  413.       (concatenate 'simple-string
  414.                (the simple-string read-buffer)
  415.                (the simple-string (make-string rbl))))
  416.     (setq read-buffer-length (* 2 rbl))))
  417.  
  418. (defun inchpeek-read-buffer ()
  419.   (if (>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
  420.       eof-object
  421.       (elt (the simple-string read-buffer) inch-ptr)))
  422.  
  423. (defun inch-read-buffer ()
  424.   (cond ((>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
  425.      eof-object)
  426.     (t (prog1 (elt (the simple-string read-buffer) inch-ptr)
  427.           (setq inch-ptr (1+ (the fixnum inch-ptr)))))))
  428.  
  429. (defmacro unread-buffer ()
  430.   `(decf (the fixnum inch-ptr)))
  431.  
  432. (defun read-unwind-read-buffer ()
  433.   ;;keep contents, but make next (inch..) return first char.
  434.   (setq inch-ptr 0))
  435.  
  436. (defun read-buffer-to-string ()
  437.   (subseq (the simple-string read-buffer) 0 ouch-ptr))
  438.  
  439.  
  440.  
  441. ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ.
  442.  
  443. (defvar *ignore-extra-close-parentheses* t
  444.   "If true, only warn when there is an extra close paren, otherwise error.")
  445.  
  446. ;; Alist for #=. Used to keep track of objects with labels assigned that have
  447. ;; been completly read.  Entry is (integer-tag gensym-tag value).
  448. ;;
  449. (defvar *sharp-equal-alist* ())
  450.  
  451. (proclaim '(special *standard-input*))
  452.  
  453. ;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure
  454. ;;; to leave terminating whitespace in the stream.
  455. ;;;
  456. (defun read-preserving-whitespace (&optional (stream *standard-input*)
  457.                          (eof-errorp t) (eof-value nil)
  458.                          (recursivep nil))
  459.   "Reads from stream and returns the object read, preserving the whitespace
  460.    that followed the object."
  461.   (cond
  462.    (recursivep
  463.     ;; Loop for repeating when a macro returns nothing.
  464.     (loop
  465.       (let ((char (read-char stream eof-errorp eof-object)))
  466.     (cond ((eofp char) (return eof-value))
  467.           ((whitespacep char))
  468.           (t
  469.            (let* ((macrofun (get-cmt-entry char *readtable*))
  470.               (result (multiple-value-list
  471.                    (funcall macrofun stream char))))
  472.          ;; Repeat if macro returned nothing.
  473.          (if result (return (car result)))))))))
  474.    (t
  475.     (let ((*sharp-equal-alist* nil))
  476.       (read-preserving-whitespace stream eof-errorp eof-value t)))))
  477.  
  478.  
  479. (defun read-maybe-nothing (stream char)
  480.   ;;returns nil or a list with one thing, depending.
  481.   ;;for functions that want comments to return so they can look
  482.   ;;past them.  Assumes char is not whitespace.
  483.   (let ((retval (multiple-value-list
  484.          (funcall (get-cmt-entry char *readtable*) stream char))))
  485.     (if retval (rplacd retval nil))))
  486.  
  487. (defun read (&optional (stream *standard-input*) (eof-errorp t)
  488.                (eof-value ()) (recursivep ()))
  489.   "Reads in the next object in the stream, which defaults to
  490.    *standard-input*. For details see the I/O chapter of
  491.    the manual."
  492.   (prog1
  493.       (read-preserving-whitespace stream eof-errorp eof-value recursivep)
  494.     (let ((whitechar (read-char stream nil eof-object)))
  495.       (if (and (not (eofp whitechar))
  496.            (or (not (whitespacep whitechar))
  497.            recursivep))
  498.       (unread-char whitechar stream)))))
  499.  
  500. (defun read-delimited-list (endchar &optional
  501.                     (input-stream *standard-input*)
  502.                     recursive-p)
  503.   "Reads objects from input-stream until the next character after an
  504.    object's representation is endchar.  A list of those objects read
  505.    is returned."
  506.   (declare (ignore recursive-p))
  507.   (do ((char (flush-whitespace input-stream)
  508.          (flush-whitespace input-stream))
  509.        (retlist ()))
  510.       ((char= char endchar) (nreverse retlist))
  511.     (setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
  512.  
  513.  
  514.  
  515. ;;;; Standard ReadMacro definitions to implement the reader.
  516.  
  517. (defun read-quote (stream ignore)
  518.   (declare (ignore ignore))
  519.   (list 'quote (read stream t nil t)))
  520.  
  521. (defun read-comment (stream ignore)
  522.   (declare (ignore ignore))
  523.   (prepare-for-fast-read-char stream
  524.     (do ((char (fast-read-char nil nil)
  525.            (fast-read-char nil nil)))
  526.     ((or (not char) (char= char #\newline))
  527.      (done-with-fast-read-char))))
  528.   ;;don't return anything
  529.   (values))
  530.  
  531. (defun read-list (stream ignore)
  532.   (declare (ignore ignore))
  533.   (let* ((thelist (list nil))
  534.      (listtail thelist))
  535.     (do ((firstchar (flush-whitespace stream) (flush-whitespace stream)))
  536.     ((char= firstchar #\) ) (cdr thelist))
  537.       (when (char= firstchar #\.)
  538.         (let ((nextchar (read-char stream t)))
  539.           (cond ((token-delimiterp nextchar)
  540.              (cond ((eq listtail thelist)
  541.                 (%reader-error stream "Nothing appears before . in list."))
  542.                ((whitespacep nextchar)
  543.                 (setq nextchar (flush-whitespace stream))))
  544.              (rplacd listtail
  545.                  ;;return list containing last thing.
  546.                  (car (read-after-dot stream nextchar)))
  547.              (return (cdr thelist)))
  548.             ;;put back nextchar so we can read it normally.
  549.             (t (unread-char nextchar stream)))))
  550.       ;;next thing is not an isolated dot.
  551.       (let ((listobj (read-maybe-nothing stream firstchar)))
  552.     ;;allows the possibility that a comment was read.
  553.     (when listobj
  554.           (rplacd listtail listobj)
  555.           (setq listtail listobj))))))
  556.  
  557. (defun read-after-dot (stream firstchar)
  558.   ;;firstchar is non-whitespace!
  559.   (let ((lastobj ()))
  560.     (do ((char firstchar (flush-whitespace stream)))
  561.     ((char= char #\) )
  562.      (%reader-error stream "Nothing appears after . in list."))
  563.       ;;see if there's something there.
  564.       (setq lastobj (read-maybe-nothing stream char))
  565.       (when lastobj (return t)))
  566.     ;;at least one thing appears after the dot.
  567.     ;;check for more than one thing following dot.
  568.     (do ((lastchar (flush-whitespace stream)
  569.            (flush-whitespace stream)))
  570.     ((char= lastchar #\) ) lastobj)    ;success!
  571.       ;;try reading virtual whitespace
  572.       (if (read-maybe-nothing stream lastchar)
  573.       (%reader-error stream "More than one object follows . in list.")))))
  574.  
  575. (defun read-string (stream closech)
  576.   ;;this accumulates chars until it sees same char that invoked it.
  577.   ;;for a very long string, this could end up bloating the read buffer.
  578.   (reset-read-buffer)
  579.   (prepare-for-fast-read-char stream
  580.     (do ((char (fast-read-char t) (fast-read-char t)))
  581.     ((char= char closech)
  582.      (done-with-fast-read-char))
  583.       (if (escapep char) (setq char (fast-read-char t)))
  584.       (ouch-read-buffer char)))
  585.   (read-buffer-to-string))
  586.  
  587. (defun read-right-paren (stream ignore)
  588.   (declare (ignore ignore))
  589.     (cond (*ignore-extra-close-parentheses*
  590.        (warn "Ignoring unmatched close parenthesis~
  591.           ~@[ at file position ~D~]."
  592.          (file-position stream))
  593.        (values))
  594.       (t
  595.        (%reader-error stream "Unmatched close parenthesis."))))
  596.  
  597. ;;; INTERNAL-READ-EXTENDED-TOKEN  --  Internal
  598. ;;;
  599. ;;; Read from the stream up to the next delimiter.  Leaves resulting token in
  600. ;;; read-buffer, returns two values:
  601. ;;; -- a list of the escaped character positions, and
  602. ;;; -- The position of the first package delimiter (or NIL).
  603. ;;;
  604. (defun internal-read-extended-token (stream firstchar)
  605.   (reset-read-buffer)
  606.   (do ((char firstchar (read-char stream nil eof-object))
  607.        (escapes ())
  608.        (colon nil))
  609.       ((cond ((eofp char) t)
  610.          ((token-delimiterp char)
  611.           (unread-char char stream)
  612.           t)
  613.          (t nil))
  614.        (values escapes colon))
  615.     (cond ((escapep char)
  616.        ;;it can't be a number, even if it's 1\23.
  617.        ;;read next char here, so it won't be casified.
  618.        (push ouch-ptr escapes)
  619.        (let ((nextchar (read-char stream nil eof-object)))
  620.          (if (eofp nextchar)
  621.          (reader-eof-error stream "after escape character")
  622.          (ouch-read-buffer nextchar))))
  623.       ((multiple-escape-p char)
  624.        ;; read to next multiple-escape, escaping single chars along
  625.        ;; the way
  626.        (loop
  627.          (let ((ch (read-char stream nil eof-object)))
  628.            (cond
  629.         ((eofp ch)
  630.          (reader-eof-error stream "inside extended token"))
  631.         ((multiple-escape-p ch) (return))
  632.         ((escapep ch)
  633.          (let ((nextchar (read-char stream nil eof-object)))
  634.            (if (eofp nextchar)
  635.                (reader-eof-error stream "after escape character")
  636.                (ouch-read-buffer nextchar))))
  637.         (t
  638.          (push ouch-ptr escapes)
  639.          (ouch-read-buffer ch))))))
  640.       (t
  641.        (when (and (constituentp char)
  642.               (eql (get-secondary-attribute char) #.package-delimiter)
  643.               (not colon))
  644.          (setq colon ouch-ptr))
  645.        (ouch-read-buffer char)))))
  646.  
  647.  
  648. ;;;; Character classes.
  649.  
  650. ;;; return the character class for a char
  651. ;;;
  652. (defmacro char-class (char attable)
  653.   `(let ((att (svref ,attable (char-code ,char))))
  654.      (declare (fixnum att))
  655.      (if (<= att #.terminating-macro)
  656.      #.delimiter
  657.      att)))
  658.  
  659. ;;; return the character class for a char which might be part of a rational
  660. ;;; number
  661. ;;;
  662. (defmacro char-class2 (char attable)
  663.   `(let ((att (svref ,attable (char-code ,char))))
  664.      (declare (fixnum att))
  665.      (if (<= att #.terminating-macro)
  666.      #.delimiter
  667.      (if (digit-char-p ,char *read-base*)
  668.          constituent-digit
  669.          (if (= att constituent-digit)
  670.          constituent
  671.          att)))))
  672.  
  673. ;;; return the character class for a char which might be part of a rational or
  674. ;;; floating number (assume that it is a digit if it could be)
  675. ;;;
  676. (defmacro char-class3 (char attable)
  677.   `(let ((att (svref ,attable (char-code ,char))))
  678.      (declare (fixnum att))
  679.      (if possibly-rational
  680.      (setq possibly-rational
  681.            (or (digit-char-p ,char *read-base*)
  682.            (= att constituent-slash))))
  683.      (if possibly-float
  684.      (setq possibly-float
  685.            (or (digit-char-p ,char 10)
  686.            (= att constituent-dot))))
  687.      (if (<= att #.terminating-macro)
  688.      #.delimiter
  689.      (if (digit-char-p ,char (max *read-base* 10))
  690.          (if (digit-char-p ,char *read-base*)
  691.          constituent-digit
  692.          constituent)
  693.          att))))
  694.  
  695.  
  696.  
  697. ;;;; Token fetching.
  698.  
  699. (defvar *read-suppress* nil 
  700.   "Suppresses most interpreting of the reader when T")
  701.  
  702. (defvar *read-base* 10
  703.   "The radix that Lisp reads numbers in.")
  704.  
  705.  
  706. ;;; CASIFY-READ-BUFFER  --  Internal
  707. ;;;
  708. ;;;    Modify the read-buffer according to READTABLE-CASE, ignoring escapes.
  709. ;;; ESCAPES is a list of the escaped indices, in reverse order. 
  710. ;;;
  711. (defun casify-read-buffer (escapes)
  712.   (let ((case (readtable-case *readtable*)))
  713.     (cond
  714.      ((and (null escapes) (eq case :upcase))
  715.       (dotimes (i ouch-ptr)
  716.     (setf (schar read-buffer i) (char-upcase (schar read-buffer i)))))
  717.      ((eq case :preserve))
  718.      (t
  719.       (macrolet ((skip-esc (&body body)
  720.            `(do ((i (1- ouch-ptr) (1- i))
  721.              (escapes escapes))
  722.             ((minusp i))
  723.               (declare (fixnum i))
  724.               (when (or (null escapes)
  725.                 (let ((esc (first escapes)))
  726.                   (declare (fixnum esc))
  727.                   (cond ((< esc i) t)
  728.                     (t
  729.                      (assert (= esc i))
  730.                      (pop escapes)
  731.                      nil))))
  732.             (let ((ch (schar read-buffer i)))
  733.               ,@body)))))
  734.     (flet ((lower-em ()
  735.          (skip-esc (setf (schar read-buffer i) (char-downcase ch))))
  736.            (raise-em ()
  737.          (skip-esc (setf (schar read-buffer i) (char-upcase ch)))))
  738.       (ecase case
  739.         (:upcase (raise-em))
  740.         (:downcase (lower-em))
  741.         (:invert
  742.          (let ((all-upper t)
  743.            (all-lower t))
  744.            (skip-esc
  745.          (when (both-case-p ch)
  746.            (if (upper-case-p ch)
  747.                (setq all-lower nil)
  748.                (setq all-upper nil))))
  749.            (cond (all-lower (raise-em))
  750.              (all-upper (lower-em))))))))))))
  751.   
  752. (defun read-token (stream firstchar)
  753.   "This function is just an fsm that recognizes numbers and symbols."
  754.   ;;check explicitly whether firstchar has entry for non-terminating
  755.   ;;in character-attribute-table and read-dot-number-symbol in CMT.
  756.   ;;Report an error if these are violated (if we called this, we want
  757.   ;;something that is a legitimate token!).
  758.   ;;read in the longest possible string satisfying the bnf for
  759.   ;;"unqualified-token".  Leave the result in the READ-BUFFER.
  760.   ;;Return next char after token (last char read).
  761.   (when *read-suppress*
  762.     (internal-read-extended-token stream firstchar)
  763.     (return-from read-token nil))
  764.   (let ((attribute-table (character-attribute-table *readtable*))
  765.     (package nil)
  766.     (colons 0)
  767.     (possibly-rational t)
  768.     (possibly-float t)
  769.     (escapes ()))
  770.     (reset-read-buffer)
  771.     (prog ((char firstchar))
  772.       (case (char-class3 char attribute-table)
  773.     (#.constituent-sign (go SIGN))
  774.     (#.constituent-digit (go LEFTDIGIT))
  775.     (#.constituent-dot (go FRONTDOT))
  776.     (#.escape (go ESCAPE))
  777.     (#.package-delimiter (go COLON))
  778.     (#.multiple-escape (go MULT-ESCAPE))
  779.     ;;can't have eof, whitespace, or terminating macro as first char!
  780.     (t (go SYMBOL)))
  781.      SIGN
  782.       ;;saw "sign"
  783.       (ouch-read-buffer char)
  784.       (setq char (read-char stream nil nil))
  785.       (unless char (go RETURN-SYMBOL))
  786.       (setq possibly-rational t
  787.         possibly-float t)
  788.       (case (char-class3 char attribute-table)
  789.     (#.constituent-digit (go LEFTDIGIT))
  790.     (#.constituent-dot (go SIGNDOT))
  791.     (#.escape (go ESCAPE))
  792.     (#.package-delimiter (go COLON))
  793.     (#.multiple-escape (go MULT-ESCAPE))    
  794.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  795.     (t (go SYMBOL)))
  796.      LEFTDIGIT
  797.       ;;saw "[sign] {digit}+"
  798.       (ouch-read-buffer char)
  799.       (setq char (read-char stream nil nil))
  800.       (unless char (return (make-integer stream)))
  801.       (case (char-class3 char attribute-table)
  802.     (#.constituent-digit (go LEFTDIGIT))
  803.     (#.constituent-dot (if possibly-float
  804.                    (go MIDDLEDOT)
  805.                    (go SYMBOL)))
  806.     (#.constituent-expt (go EXPONENT))
  807.     (#.constituent-slash (if possibly-rational
  808.                  (go RATIO)
  809.                  (go SYMBOL)))
  810.     (#.delimiter (unread-char char stream) (return (make-integer stream)))
  811.     (#.escape (go ESCAPE))
  812.     (#.multiple-escape (go MULT-ESCAPE))
  813.     (#.package-delimiter (go COLON))
  814.     (t (go SYMBOL)))
  815.      MIDDLEDOT
  816.       ;;saw "[sign] {digit}+ dot"
  817.       (ouch-read-buffer char)
  818.       (setq char (read-char stream nil nil))
  819.       (unless char (return (let ((*read-base* 10))
  820.                  (make-integer stream))))
  821.       (case (char-class char attribute-table)
  822.     (#.constituent-digit (go RIGHTDIGIT))
  823.     (#.constituent-expt (go EXPONENT))
  824.     (#.delimiter
  825.      (unread-char char stream)
  826.      (return (let ((*read-base* 10))
  827.            (make-integer stream))))
  828.     (#.escape (go ESCAPE))
  829.     (#.multiple-escape (go MULT-ESCAPE))
  830.     (#.package-delimiter (go COLON))
  831.     (t (go SYMBOL)))
  832.      RIGHTDIGIT
  833.       ;;saw "[sign] {digit}* dot {digit}+"
  834.       (ouch-read-buffer char)
  835.       (setq char (read-char stream nil nil))
  836.       (unless char (return (make-float)))
  837.       (case (char-class char attribute-table)
  838.     (#.constituent-digit (go RIGHTDIGIT))
  839.     (#.constituent-expt (go EXPONENT))
  840.     (#.delimiter (unread-char char stream) (return (make-float)))
  841.     (#.escape (go ESCAPE))
  842.     (#.multiple-escape (go MULT-ESCAPE))
  843.     (#.package-delimiter (go COLON))
  844.     (t (go SYMBOL)))
  845.      SIGNDOT
  846.       ;;saw "[sign] dot"
  847.       (ouch-read-buffer char)
  848.       (setq char (read-char stream nil nil))
  849.       (unless char (go RETURN-SYMBOL))
  850.       (case (char-class char attribute-table)
  851.     (#.constituent-digit (go RIGHTDIGIT))
  852.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  853.     (#.escape (go ESCAPE))
  854.     (#.multiple-escape (go MULT-ESCAPE))
  855.     (t (go SYMBOL)))
  856.      FRONTDOT
  857.       ;;saw "dot"
  858.       (ouch-read-buffer char)
  859.       (setq char (read-char stream nil nil))
  860.       (unless char (%reader-error stream "Dot context error."))
  861.       (case (char-class char attribute-table)
  862.     (#.constituent-digit (go RIGHTDIGIT))
  863.     (#.constituent-dot (go DOTS))
  864.     (#.delimiter  (%reader-error stream "Dot context error."))
  865.     (#.escape (go ESCAPE))
  866.     (#.multiple-escape (go MULT-ESCAPE))
  867.     (#.package-delimiter (go COLON))
  868.     (t (go SYMBOL)))
  869.      EXPONENT
  870.       (ouch-read-buffer char)
  871.       (setq char (read-char stream nil nil))
  872.       (unless char (go RETURN-SYMBOL))
  873.       (case (char-class char attribute-table)
  874.     (#.constituent-sign (go EXPTSIGN))
  875.     (#.constituent-digit (go EXPTDIGIT))
  876.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  877.     (#.escape (go ESCAPE))
  878.     (#.multiple-escape (go MULT-ESCAPE))
  879.     (#.package-delimiter (go COLON))
  880.     (t (go SYMBOL)))
  881.      EXPTSIGN
  882.       ;;we got to EXPONENT, and saw a sign character.
  883.       (ouch-read-buffer char)
  884.       (setq char (read-char stream nil nil))
  885.       (unless char (go RETURN-SYMBOL))
  886.       (case (char-class char attribute-table)
  887.     (#.constituent-digit (go EXPTDIGIT))
  888.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  889.     (#.escape (go ESCAPE))
  890.     (#.multiple-escape (go MULT-ESCAPE))
  891.     (#.package-delimiter (go COLON))
  892.     (t (go SYMBOL)))
  893.      EXPTDIGIT
  894.       ;;got to EXPONENT, saw "[sign] {digit}+"
  895.       (ouch-read-buffer char)
  896.       (setq char (read-char stream nil nil))
  897.       (unless char (return (make-float)))
  898.       (case (char-class char attribute-table)
  899.     (#.constituent-digit (go EXPTDIGIT))
  900.     (#.delimiter (unread-char char stream) (return (make-float)))
  901.     (#.escape (go ESCAPE))
  902.     (#.multiple-escape (go MULT-ESCAPE))
  903.     (#.package-delimiter (go COLON))
  904.     (t (go SYMBOL)))
  905.      RATIO
  906.       ;;saw "[sign] {digit}+ slash"
  907.       (ouch-read-buffer char)
  908.       (setq char (read-char stream nil nil))
  909.       (unless char (go RETURN-SYMBOL))
  910.       (case (char-class2 char attribute-table)
  911.     (#.constituent-digit (go RATIODIGIT))
  912.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  913.     (#.escape (go ESCAPE))
  914.     (#.multiple-escape (go MULT-ESCAPE))
  915.     (#.package-delimiter (go COLON))
  916.     (t (go SYMBOL)))
  917.      RATIODIGIT
  918.       ;;saw "[sign] {digit}+ slash {digit}+"
  919.       (ouch-read-buffer char)
  920.       (setq char (read-char stream nil nil))
  921.       (unless char (return (make-ratio)))
  922.       (case (char-class2 char attribute-table)
  923.     (#.constituent-digit (go RATIODIGIT))
  924.     (#.delimiter (unread-char char stream) (return (make-ratio)))
  925.     (#.escape (go ESCAPE))
  926.     (#.multiple-escape (go MULT-ESCAPE))
  927.     (#.package-delimiter (go COLON))
  928.     (t (go SYMBOL)))
  929.      DOTS
  930.       ;;saw "dot {dot}+"
  931.       (ouch-read-buffer char)
  932.       (setq char (read-char stream nil nil))
  933.       (unless char (%reader-error stream "Too many dots."))
  934.       (case (char-class char attribute-table)
  935.     (#.constituent-dot (go DOTS))
  936.     (#.delimiter
  937.      (unread-char char stream)
  938.      (%reader-error stream "Too many dots."))
  939.     (#.escape (go ESCAPE))
  940.     (#.multiple-escape (go MULT-ESCAPE))
  941.     (#.package-delimiter (go COLON))
  942.     (t (go SYMBOL)))
  943.      SYMBOL
  944.       ;;not a dot, dots, or number.
  945.       (prepare-for-fast-read-char stream
  946.     (prog ()
  947.      SYMBOL-LOOP
  948.       (ouch-read-buffer char)
  949.       (setq char (fast-read-char nil nil))
  950.       (unless char (go RETURN-SYMBOL))
  951.       (case (char-class char attribute-table)
  952.         (#.escape (done-with-fast-read-char)
  953.               (go ESCAPE))
  954.         (#.delimiter (done-with-fast-read-char)
  955.              (unread-char char stream)
  956.              (go RETURN-SYMBOL))
  957.         (#.multiple-escape (done-with-fast-read-char)
  958.                    (go MULT-ESCAPE))
  959.         (#.package-delimiter (done-with-fast-read-char)
  960.                  (go COLON))
  961.         (t (go SYMBOL-LOOP)))))
  962.      ESCAPE
  963.       ;;saw an escape.
  964.       ;;don't put the escape in the read-buffer.
  965.       ;;read-next char, put in buffer (no case conversion).
  966.       (let ((nextchar (read-char stream nil nil)))
  967.     (unless nextchar
  968.       (reader-eof-error stream "after escape character"))
  969.     (push ouch-ptr escapes)
  970.     (ouch-read-buffer nextchar))
  971.       (setq char (read-char stream nil nil))
  972.       (unless char (go RETURN-SYMBOL))
  973.       (case (char-class char attribute-table)
  974.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  975.     (#.escape (go ESCAPE))
  976.     (#.multiple-escape (go MULT-ESCAPE))
  977.     (#.package-delimiter (go COLON))
  978.     (t (go SYMBOL)))
  979.       MULT-ESCAPE
  980.       (do ((char (read-char stream t) (read-char stream t)))
  981.       ((multiple-escape-p char))
  982.     (if (escapep char) (setq char (read-char stream t)))
  983.     (push ouch-ptr escapes)
  984.     (ouch-read-buffer char))
  985.       (setq char (read-char stream nil nil))
  986.       (unless char (go RETURN-SYMBOL))
  987.       (case (char-class char attribute-table)
  988.     (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
  989.     (#.escape (go ESCAPE))
  990.     (#.multiple-escape (go MULT-ESCAPE))
  991.     (#.package-delimiter (go COLON))
  992.     (t (go SYMBOL)))
  993.       COLON
  994.       (casify-read-buffer escapes)
  995.       (unless (zerop colons)
  996.     (%reader-error stream "Too many colons in ~S"
  997.               (read-buffer-to-string)))
  998.       (setq colons 1)
  999.       (setq package (read-buffer-to-string))
  1000.  
  1001.       (reset-read-buffer)
  1002.       (setq escapes ())
  1003.       (setq char (read-char stream nil nil))
  1004.       (unless char (reader-eof-error stream "after reading a colon"))
  1005.       (case (char-class char attribute-table)
  1006.     (#.delimiter
  1007.      (unread-char char stream)
  1008.      (%reader-error stream "Illegal terminating character after a colon, ~S."
  1009.                char))
  1010.     (#.escape (go ESCAPE))
  1011.     (#.multiple-escape (go MULT-ESCAPE))
  1012.     (#.package-delimiter (go INTERN))
  1013.     (t (go SYMBOL)))
  1014.       INTERN
  1015.       (setq colons 2)
  1016.       (setq char (read-char stream nil nil))
  1017.       (unless char
  1018.     (reader-eof-error stream "after reading a colon"))
  1019.       (case (char-class char attribute-table)
  1020.     (#.delimiter
  1021.      (unread-char char stream)
  1022.      (%reader-error stream "Illegal terminating character after a colon, ~S"
  1023.                char))
  1024.     (#.escape (go ESCAPE))
  1025.     (#.multiple-escape (go MULT-ESCAPE))
  1026.     (#.package-delimiter
  1027.      (%reader-error stream "To many colons after ~S:" package))
  1028.     (t (go SYMBOL)))
  1029.       RETURN-SYMBOL
  1030.       (casify-read-buffer escapes)
  1031.       (let ((found (if package (find-package package) *package*)))
  1032.     (unless found
  1033.       (error 'reader-package-error :stream stream
  1034.          :format-arguments (list package)
  1035.          :format-control "Package ~S not found."))
  1036.  
  1037.     (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
  1038.         (return (intern* read-buffer ouch-ptr found))
  1039.         (multiple-value-bind (symbol test)
  1040.                  (find-symbol* read-buffer ouch-ptr found)
  1041.           (when (eq test :external) (return symbol))
  1042.           (let ((name (read-buffer-to-string)))
  1043.         (with-simple-restart (continue "Use symbol anyway.")
  1044.           (error 'reader-package-error :stream stream
  1045.              :format-arguments (list name (package-name found))
  1046.              :format-control
  1047.              (if test
  1048.                  "The symbol ~S is not external in the ~A package."
  1049.                  "Symbol ~S not found in the ~A package.")))
  1050.         (return (intern name found)))))))))
  1051.  
  1052.  
  1053. (defun read-extended-token (stream &optional (*readtable* *readtable*))
  1054.   "For semi-external use: returns 3 values: the string for the token,
  1055.    a flag for whether there was an escape char, and the position of any
  1056.    package delimiter."
  1057.   (let ((firstch (read-char stream nil nil t)))
  1058.     (cond (firstch
  1059.        (multiple-value-bind (escapes colon)
  1060.                 (internal-read-extended-token stream firstch)
  1061.          (casify-read-buffer escapes)
  1062.          (values (read-buffer-to-string) (not (null escapes)) colon)))
  1063.       (t
  1064.        (values "" nil nil)))))
  1065.  
  1066.  
  1067. ;;;; Number reading functions.
  1068.  
  1069. (defmacro digit* nil
  1070.   `(do ((ch char (inch-read-buffer)))
  1071.        ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
  1072.      ;;report if at least one digit is seen:
  1073.      (setq one-digit t)))
  1074.  
  1075. (defmacro exponent-letterp (letter)
  1076.   `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
  1077.  
  1078.  
  1079. (defvar *integer-reader-safe-digits*
  1080.   '#(NIL NIL
  1081.      26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
  1082.   "Holds the mapping of base to 'safe' number of digits to read for a fixnum.")
  1083.  
  1084. (defvar *integer-reader-base-power* 
  1085.   '#(NIL NIL
  1086.      67108864 129140163 67108864 48828125 60466176 40353607
  1087.      16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
  1088.      16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
  1089.      7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
  1090.      33554432 39135393 45435424 52521875 60466176)
  1091.   "Holds the largest fixnum power of the base for make-integer.")
  1092.  
  1093. #|
  1094. (defun init-integer-reader ()
  1095.   (do ((base 2 (1+ base)))
  1096.       ((> base 36))
  1097.     (let ((digits
  1098.       (do ((fix (truncate most-positive-fixnum base)
  1099.             (truncate fix base))
  1100.            (digits 0 (1+ digits)))
  1101.           ((zerop fix) digits))))       
  1102.       (setf (aref *integer-reader-safe-digits* base)
  1103.         digits
  1104.         (aref *integer-reader-base-power* base)
  1105.         (expt base digits)))))
  1106. |#
  1107.  
  1108. (defun make-integer (stream)
  1109.   "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, 
  1110.   then multiplying by a power of the base and adding."
  1111.   (let* ((base (if (boundp '*read-base*)
  1112.           (if (and (fixnump *read-base*)
  1113.                (<= 1 *read-base* 36))
  1114.               *read-base*
  1115.               (%reader-error stream "~A not a valid number for *read-base*."
  1116.                  *read-base*))
  1117.           10.))
  1118.      (digits-per (aref *integer-reader-safe-digits* base))
  1119.      (base-power (aref *integer-reader-base-power* base)) 
  1120.      (negativep nil)
  1121.      (number 0))
  1122.     (read-unwind-read-buffer)
  1123.     (let ((char (inch-read-buffer)))
  1124.       (cond ((char= char #\-)
  1125.          (setq negativep t))
  1126.         ((char= char #\+))
  1127.         (t (unread-buffer))))
  1128.     (loop
  1129.      (let ((num 0))
  1130.        (dotimes (digit digits-per)
  1131.      (let* ((ch (inch-read-buffer)))
  1132.        (cond ((or (eofp ch) (char= ch #\.))
  1133.           (return-from make-integer
  1134.                    (let ((res
  1135.                       (if (zerop number) num
  1136.                       (+ num (* number
  1137.                             (expt base digit))))))
  1138.                  (if negativep (- res) res))))
  1139.          (t (setq num (+ (digit-char-p ch base) (* num base)))))))
  1140.        (setq number (+ num (* number base-power)))))))
  1141.  
  1142.  
  1143.  
  1144. (defun make-float ()
  1145.   ;;assume that the contents of read-buffer are a legal float, with nothing
  1146.   ;;else after it.
  1147.   (read-unwind-read-buffer)
  1148.   (let ((negative-fraction nil)
  1149.     (number 0)
  1150.     (divisor 1)
  1151.     (negative-exponent nil)
  1152.     (exponent 0)
  1153.     (float-char ())
  1154.     (char (inch-read-buffer)))
  1155.     (if (cond ((char= char #\+) t)
  1156.           ((char= char #\-) (setq negative-fraction t)))
  1157.     ;;flush it
  1158.     (setq char (inch-read-buffer)))
  1159.     ;;read digits before the dot
  1160.     (do* ((ch char (inch-read-buffer))
  1161.       (dig (digit-char-p ch) (digit-char-p ch)))
  1162.      ((not dig) (setq char ch))
  1163.       (setq number (+ (* number 10) dig)))
  1164.     ;;deal with the dot, if it's there.
  1165.     (when (char= char #\.)
  1166.       (setq char (inch-read-buffer))
  1167.       ;;read digits after the dot.
  1168.       (do* ((ch char (inch-read-buffer))
  1169.         (dig (and (not (eofp ch)) (digit-char-p ch))
  1170.          (and (not (eofp ch)) (digit-char-p ch))))
  1171.        ((not dig) (setq char ch))
  1172.     (setq divisor (* divisor 10))
  1173.     (setq number (+ (* number 10) dig))))
  1174.     ;;is there an exponent letter?
  1175.     (cond ((eofp char)
  1176.        ;;if not, we've read the whole number.
  1177.        (let ((num (make-float-aux number divisor
  1178.                       *read-default-float-format*)))
  1179.          (return-from make-float (if negative-fraction (- num) num))))
  1180.       ((exponent-letterp char)
  1181.        (setq float-char char)
  1182.        ;;build exponent
  1183.        (setq char (inch-read-buffer))
  1184.        ;;check leading sign
  1185.        (if (cond ((char= char #\+) t)
  1186.              ((char= char #\-) (setq negative-exponent t)))
  1187.            ;;flush sign
  1188.            (setq char (inch-read-buffer)))
  1189.        ;;read digits for exponent
  1190.        (do* ((ch char (inch-read-buffer))
  1191.          (dig (and (not (eofp ch)) (digit-char-p ch))
  1192.               (and (not (eofp ch)) (digit-char-p ch))))
  1193.            ((not dig)
  1194.         (setq exponent (if negative-exponent (- exponent) exponent)))
  1195.            (setq exponent (+ (* exponent 10) dig)))
  1196.        ;;generate and return the float, depending on float-char:
  1197.        (let* ((float-format (case (char-upcase float-char)
  1198.                   (#\E *read-default-float-format*)
  1199.                   (#\S 'short-float)
  1200.                   (#\F 'single-float)
  1201.                   (#\D 'double-float)
  1202.                   (#\L 'long-float)))
  1203.           (num (make-float-aux number divisor float-format)))
  1204.          (setq num (* num (expt 10 exponent)))
  1205.          (return-from make-float (if negative-fraction (- num) num))))
  1206.       ;;should never happen:    
  1207.       (t (error "Internal error in floating point reader.")))))
  1208.  
  1209. (defun make-float-aux (number divisor float-format)
  1210.   (coerce (/ number divisor) float-format))
  1211.  
  1212.  
  1213. (defun make-ratio ()
  1214.   ;;assume read-buffer contains a legal ratio.  Build the number from
  1215.   ;;the string.
  1216.   ;;look for optional "+" or "-".
  1217.   (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
  1218.     (read-unwind-read-buffer)
  1219.     (setq char (inch-read-buffer))
  1220.     (cond ((char= char #\+)
  1221.        (setq char (inch-read-buffer)))
  1222.       ((char= char #\-)
  1223.        (setq char (inch-read-buffer))
  1224.        (setq negative-number t)))
  1225.     ;;get numerator
  1226.     (do* ((ch char (inch-read-buffer))
  1227.       (dig (digit-char-p ch *read-base*)
  1228.            (digit-char-p ch *read-base*)))
  1229.      ((not dig))
  1230.      (setq numerator (+ (* numerator *read-base*) dig)))
  1231.     ;;get denominator
  1232.     (do* ((ch (inch-read-buffer) (inch-read-buffer))
  1233.       (dig ()))
  1234.      ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
  1235.      (setq denominator (+ (* denominator *read-base*) dig)))
  1236.     (let ((num (/ numerator denominator)))
  1237.       (if negative-number (- num) num))))
  1238.  
  1239.        
  1240.  
  1241. ;;;; dispatching macro cruft
  1242.  
  1243. (defun make-char-dispatch-table ()
  1244.   (make-array char-code-limit :initial-element #'dispatch-char-error))
  1245.  
  1246. (defun dispatch-char-error (stream sub-char ignore)
  1247.   (declare (ignore ignore))
  1248.   (if *read-suppress*
  1249.       (values)
  1250.       (%reader-error stream "No dispatch function defined for ~S." sub-char)))
  1251.  
  1252. (defun make-dispatch-macro-character (char &optional
  1253.                        (non-terminating-p nil)
  1254.                        (rt *readtable*))
  1255.   "Causes char to become a dispatching macro character in readtable
  1256.    (which defaults to the current readtable).  If the non-terminating-p
  1257.    flag is set to T, the char will be non-terminating.  Make-dispatch-
  1258.    macro-character returns T."
  1259.   (set-macro-character char #'read-dispatch-char non-terminating-p rt)
  1260.   (let* ((dalist (dispatch-tables rt))
  1261.      (dtable (cdr (find char dalist :test #'char= :key #'car))))
  1262.     (cond (dtable
  1263.        (error "Dispatch character already exists"))
  1264.       (t
  1265.        (setf (dispatch-tables rt)
  1266.          (push (cons char (make-char-dispatch-table)) dalist))))))
  1267.  
  1268. (defun set-dispatch-macro-character
  1269.        (disp-char sub-char function &optional (rt *readtable*))
  1270.   "Causes function to be called whenever the reader reads
  1271.    disp-char followed by sub-char. Set-dispatch-macro-character
  1272.    returns T."
  1273.   ;;get the dispatch char for macro (error if not there), diddle
  1274.   ;;entry for sub-char.
  1275.   (when (digit-char-p sub-char)
  1276.     (error "Sub-Char must not be a decibal digit: ~S" sub-char))
  1277.   (let* ((sub-char (char-upcase sub-char))
  1278.      (dpair (find disp-char (dispatch-tables rt)
  1279.               :test #'char= :key #'car)))
  1280.     (if dpair
  1281.     (setf (elt (the simple-vector (cdr dpair))
  1282.            (char-code sub-char))
  1283.           function)
  1284.     (error "~S is not a dispatch char." disp-char))))
  1285.  
  1286. (defun get-dispatch-macro-character (disp-char sub-char &optional rt)
  1287.   "Returns the macro character function for sub-char under disp-char
  1288.    or nil if there is no associated function."
  1289.   (unless (digit-char-p sub-char)
  1290.     (let* ((sub-char (char-upcase sub-char))
  1291.        (rt (or rt *readtable*))
  1292.        (dpair (find disp-char (dispatch-tables rt)
  1293.             :test #'char= :key #'car)))
  1294.       (if dpair
  1295.       (elt (the simple-vector (cdr dpair))
  1296.            (char-code sub-char))
  1297.       (error "~S is not a dispatch char." disp-char)))))
  1298.  
  1299. (defun read-dispatch-char (stream char)
  1300.   ;;read some digits
  1301.   (let ((numargp nil)
  1302.     (numarg 0)
  1303.     (sub-char ()))
  1304.     (do* ((ch (read-char stream nil eof-object)
  1305.           (read-char stream nil eof-object))
  1306.       (dig ()))
  1307.      ((or (eofp ch)
  1308.           (not (setq dig (digit-char-p ch))))
  1309.       ;;take care of the extra char.
  1310.       (if (eofp ch)
  1311.           (reader-eof-error stream "inside dispatch character")
  1312.           (setq sub-char (char-upcase ch))))
  1313.       (setq numargp t)
  1314.       (setq numarg (+ (* numarg 10) dig)))
  1315.     ;;look up the function and call it.
  1316.     (let ((dpair (find char (dispatch-tables *readtable*)
  1317.                :test #'char= :key #'car)))
  1318.       (if dpair
  1319.       (funcall (elt (the simple-vector (cdr dpair))
  1320.             (char-code sub-char))
  1321.            stream sub-char (if numargp numarg nil))
  1322.       (%reader-error stream "No dispatch table for dispatch char.")))))
  1323.  
  1324.  
  1325.  
  1326. ;;;; READ-FROM-STRING.
  1327.  
  1328. (defvar read-from-string-spares ()
  1329.   "A resource of string streams for Read-From-String.")
  1330.  
  1331. (defun read-from-string (string &optional eof-error-p eof-value
  1332.                 &key (start 0) end
  1333.                 preserve-whitespace)
  1334.   "The characters of string are successively given to the lisp reader
  1335.    and the lisp object built by the reader is returned.  Macro chars
  1336.    will take effect."
  1337.   (declare (string string))
  1338.   (with-array-data ((string string)
  1339.             (start start)
  1340.             (end (or end (length string))))
  1341.     (unless read-from-string-spares
  1342.       (push (internal-make-string-input-stream "" 0 0)
  1343.         read-from-string-spares))
  1344.     (let ((stream (pop read-from-string-spares)))
  1345.       (setf (string-input-stream-string stream) string)
  1346.       (setf (string-input-stream-current stream) start)
  1347.       (setf (string-input-stream-end stream) end)
  1348.       (unwind-protect
  1349.       (values (if preserve-whitespace
  1350.               (read-preserving-whitespace stream eof-error-p eof-value)
  1351.               (read stream eof-error-p eof-value))
  1352.           (string-input-stream-current stream))
  1353.     (push stream read-from-string-spares)))))
  1354.  
  1355.  
  1356. ;;;; PARSE-INTEGER.
  1357.  
  1358. (defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
  1359.   "Examine the substring of string delimited by start and end
  1360.   (default to the beginning and end of the string)  It skips over
  1361.   whitespace characters and then tries to parse an integer.  The
  1362.   radix parameter must be between 2 and 36."
  1363.   (with-array-data ((string string)
  1364.             (start start)
  1365.             (end (or end (length string))))
  1366.     (let ((index (do ((i start (1+ i)))
  1367.              ((= i end)
  1368.               (if junk-allowed
  1369.               (return-from parse-integer (values nil end))
  1370.               (error "No non-whitespace characters in number.")))
  1371.            (declare (fixnum i))
  1372.            (unless (whitespacep (char string i)) (return i))))
  1373.       (minusp nil)
  1374.       (found-digit nil)
  1375.       (result 0))
  1376.       (declare (fixnum index))
  1377.       (let ((char (char string index)))
  1378.     (cond ((char= char #\-)
  1379.            (setq minusp t)
  1380.            (incf index))
  1381.           ((char= char #\+)
  1382.            (incf index))))
  1383.       (loop
  1384.     (when (= index end) (return nil))
  1385.     (let* ((char (char string index))
  1386.            (weight (digit-char-p char radix)))
  1387.       (cond (weight
  1388.          (setq result (+ weight (* result radix))
  1389.                found-digit t))
  1390.         (junk-allowed (return nil))
  1391.         ((whitespacep char)
  1392.          (do ((jndex (1+ index) (1+ jndex)))
  1393.              ((= jndex end))
  1394.            (declare (fixnum jndex))
  1395.            (unless (whitespacep (char string jndex))
  1396.              (error "There's junk in this string: ~S." string)))
  1397.          (return nil))
  1398.         (t
  1399.          (error "There's junk in this string: ~S." string))))
  1400.     (incf index))
  1401.       (values
  1402.        (if found-digit
  1403.        (if minusp (- result) result)
  1404.        (if junk-allowed
  1405.            nil
  1406.            (error "There's no digits in this string: ~S" string)))
  1407.        index))))
  1408.  
  1409.  
  1410. ;;;; Reader initialization code.
  1411.  
  1412. (defun reader-init ()
  1413.   (init-read-buffer)
  1414.   (init-secondary-attribute-table)
  1415.   (init-std-lisp-readtable)
  1416. ; (init-integer-reader)
  1417.   )
  1418.