;;; -*- cold-load:t; Mode:Common-Lisp; Package:SI ; Base:10 -*- file. ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; This code has been inspired from the Spice Lisp Reader(Written by David Dill). ;;;PAD 4/10/87 Zmacs support for pattern-matching. (DEFVAR XR-LIST-SO-FAR "When a reader macro is called, this contains the list so far at the current level.") (DEFVAR XR-SPLICE-P "A reader macro can set this to non NIL to indicate that it has modified XR-LIST-SO-FAR.") (defvar *read-intern-function* ) (DEFVAR XR-CORRESPONDENCE-FLAG) ;T if inside READ-ESTABLISH-CORRESPONDENCE. (DEFVAR XR-CORRESPONDENCE) ;Each list we read puts its correspondence ;entry on this list. (defvar *restrict-internal-symbols* nil "If T then a warning will be issued when someone references an internal symbol with only one :") ;Symbols which can head lists which go around defuns ;are given the MAY-SURROUND-DEFUN property. ; They are used when read-check-indentation is T (defprop eval-when t may-surround-defun) (defprop progn t may-surround-defun) (defprop local-declare t may-surround-defun) (defprop declare-flavor-instance-variables t may-surround-defun) (defprop compiler-let t may-surround-defun) (defprop if-for-maclisp t may-surround-defun) (defprop if-for-lispm t may-surround-defun) (defprop if-in-maclisp t may-surround-defun) (defprop if-in-lispm t may-surround-defun) (defprop if-for-maclisp-else-lispm t may-surround-defun) (defprop comment t may-surround-defun) (defprop quote t may-surround-defun) (defprop setq t may-surround-defun) (defprop def t may-surround-defun) (defprop macrolet t may-surround-defun) (defprop flet t may-surround-defun) (defprop labels t may-surround-defun) (defvar last-whitespace nil) ;; used to figure out if a list is starting at column 0 (defvar last-char-read nil) ;; used for the ucl reader, bound to the last char read. (defvar missing-close-paren nil) (defvar top-level-list nil) (defmacro fast-read-char (&optional errorp eofval) `(internal-read-char stream ,errorp ,eofval t )) (defmacro done-with-fast-read-char () nil) (defmacro prepare-for-fast-read-char (stream . body) `(let ((stream ,stream)) . ,body)) (defmacro fast-char-upcase (char) `(char-upcase ,char)) ;;-------------------------------------------------------------------------------- ;; Symbolics font support added - LSS 1/18/88 ;; New variable and functions (defvar *SYMBOLICS-EPSILON-FONT-PASSWORD* "D,#TD1PsT[Begin using 006 escapes]") (defun check-for-symbolics-font-password-in-stream (stream) ;; We have already read an  and a . Look for the rest of the password. (let ((s *symbolics-epsilon-font-password*)) (do ((n (length s)) (j 0 (1+ j))) ((= j n) t) ;; return condition (let ((new-ch (send stream :tyi))) (unless (char= new-ch (aref s j)) (send stream :untyi new-ch) (do((k (1- j) (1- k))) ((= k -1)) (send stream :untyi (aref s k))) (return nil)))))) (defun possibly-discard-epsilon-data (stream) ;; The reader has read an  character, possibly signalling the beginning of a font ;; code, which we probably want to ignore. (let ((ch (SEND STREAM :TYI))) (cond ( ;; Explorer fonts = OFF AND Symbolics fonts = OFF (and (not READ-DISCARD-FONT-CHANGES) (or (send stream :symbolics-thin-mode) (not (send stream :symbolics-fat-mode)))) ;; We don't handle fonts, except to look for the beginning of a Symbolics font password (cond ((eq ch (char-int #\)) (cond ((check-for-symbolics-font-password-in-stream stream) (send stream :set-symbolics-fat-mode t) (send stream :set-symbolics-thin-mode nil) nil) (t (send stream :untyi ch) #\))) (t (send stream :untyi ch) #\))) ( ;; Explorer fonts = ON AND Symbolics fonts = OFF (and READ-DISCARD-FONT-CHANGES (or (send stream :symbolics-thin-mode) (not (send stream :symbolics-fat-mode)))) ;; We look for a Symbolics password and for Explorer fonts (cond ((eq ch (char-int #\)) #\) ((eq ch (char-int #\)) (when (check-for-symbolics-font-password-in-stream stream) (send stream :set-symbolics-fat-mode t) (send stream :set-symbolics-thin-mode nil) nil)))) ( ;; Symbolics Fonts = ON -- Explorer Fonts = OFF or ON (send stream :symbolics-fat-mode) ;; We check for all possibilities (cond ((eq ch (char-int #\ )) #\ ) ((eq ch (char-int #\( )) (send stream :untyi ch) (SI:INTERNAL-READ STREAM T nil nil nil t) ;; read the next lisp expression (font info) nil) ((eq ch (char-int #\)) (when (check-for-symbolics-font-password-in-stream stream) (send stream :set-symbolics-fat-mode t) (send stream :set-symbolics-thin-mode nil) nil)) ((eq ch (char-int #\)) ;; ** Symbolics UnPassword - don't use fonts anymore (send stream :set-symbolics-fat-mode nil) (send stream :set-symbolics-thin-mode t) nil)))))) ;; New version - LSS - 1/18/88 (defun internal-read-char (stream &optional (errorp t) eofval noactivation &aux ch) (loop (SETQ CH (SEND STREAM (IF RUBOUT-HANDLER ':ANY-TYI ':TYI) errorp)) (COND ((NULL CH) (return eofval)) ((atom ch) (setf (char-font ch) 0) (if (or (neq ch (char-int #\)) (not (send stream :operation-handled-p :symbolics-fat-mode))) (RETURN (setf LAST-CHAR-READ (int-char ch))) ;;else (let ((new-char (possibly-discard-epsilon-data stream))) (when new-char (return (int-char new-char)))))) ((and (CONSP CH) (EQ (CAR CH) ':ACTIVATION) ;; Ignore activations except in top-level context. (null noactivation)) (null errorp) (return eofval))))) ;; Old version ;(defun internal-read-char (stream &optional (errorp t) eofval noactivation &aux ch) ; (loop ; (SETQ CH (SEND STREAM (IF RUBOUT-HANDLER ':ANY-TYI ':TYI) errorp)) ; (COND ((NULL CH) ; (return eofval)) ; ((atom ch) ; (setf (char-font ch) 0) ; (if (or (neq ch (char-int #\)) ; (not READ-DISCARD-FONT-CHANGES)) ; (RETURN (setf LAST-CHAR-READ (int-char ch))) ; (if (eq (char-int #\) (send stream ':tyi)) (return #\)))) ; ((and (CONSP CH) ; (EQ (CAR CH) ':ACTIVATION) ; ;; Ignore activations except in top-level context. ; (null noactivation)) ; (null errorp) ; (return eofval))))) ;;;Random global variables (defvar *read-default-float-format* 'single-float "Float format for 1.0E1") (defvar *read-accept-extensions* t "t to accept lisp machine extensions to the reader") ;;;Readtable implementation: the readtable is a structure with three ;;;components: the CHARACTER-ATTRIBUTE-TABLE is a vector of 256 integers ;;;for describing the character type. Conceptually, there are 4 distinct ;;;"primary" character attributes (WHITESPACE, TERMINATING-MACRO, ESCAPE, ;;;and CONSTITUENT -- non-terminating macros have the attribute ;;;CONSTITUENT, and the symbol reader is implemented as a non-terminating ;;;macro), and a number of "secondary" attributes that are used by the ;;;function READ-QUALIFIED-TOKEN, which apply only when the primary ;;;attribute is CONSTITUENT. In order to make the READ-QUALIFIED-TOKEN ;;;fast, all this information is stored in the character attribute table by ;;;having different varieties of constituents. In order to conform with ;;;the white pages, the primary attributes should be moved by ;;;SET-SYNTAX-FROM-CHARACTER and SET-MACRO-CHARACTER, while the secondary ;;;attributes are constant properties of the characters (as long as they ;;;are constituents). ;;;The CHARACTER-MACRO-TABLE is a vector of 256 functions. One of these ;;;functions called with appropriate arguments whenever any non-WHITESPACE ;;;character is encountered inside READ-PRESERVING-WHITESPACE. These ;;;functions are used to implement user-defined read-macros, system ;;;read-macros, and the number-symbol reader. Finally, there is a ;;;DISPATCH-TABLES entry, which is an alist from dispatch characters to ;;;vectors of 256 functions, for use in defining dispatching macros (like ;;;#-macro). (defvar std-lisp-readtable () "Standard lisp readtable. This is for recovery from broken read-tables, and should not normally be user-visible.") (defvar std-zetalisp-readtable () "Standard zetalisp readtable. This is for recovery from broken read-tables, and should not normally be user-visible.") (defvar *old-package* () "Value of *package* at the start of the last read or Nil.") ;;; In case we get an error trying to parse a symbol, we want to rebind the ;;; above stuff so it's cool. ;;;These definitions support internal programming conventions. (defconstant eof-object '(*eof*)) (defmacro eofp (char) `(eq ,char eof-object)) (defun flush-whitespace (stream) ;;This flushes whitespace chars, returning the last char it read (a non-white ;;one). It always gets an error on end-of-file. (prepare-for-fast-read-char stream (do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) ((/= (svref attribute-table (char-int char)) whitespace) (done-with-fast-read-char) char) (setf last-whitespace char)))) ;;;read-buffer implementation. (defmacro allocate-buffer (pool make-array-form) `(without-interrupts (let ((temp(assoc nil ,pool :test #'eq))) (if temp (progn (rplaca temp t) (cdr temp)) (let ((default-cons-area background-cons-area )) (cdar (push `(t . ,,make-array-form) ,pool))))))) (defmacro deallocate-buffer (pool object) `(without-interrupts (let ((temp (rassoc ,object ,pool :test #'eq))) (when temp (setf (car temp ) nil))))) (defvar read-buffer) (defvar read-buffer-length) (defvar read-buffer-pool `((nil . ,(make-array 512 :element-type 'string-char :fill-pointer 512)) (nil . ,(make-array 512 :element-type 'string-char :fill-pointer 512)))) (defvar inch-ptr) (defvar ouch-ptr) (defmacro reset-read-buffer () ;;turn read-buffer into an empty read-buffer. ;;ouch-ptr always points to next char to write `(progn (setq ouch-ptr 0) (setq read-buffer-length (length read-buffer)) ;;inch-ptr always points to next char to read (setq inch-ptr 0))) (defmacro ouch-read-buffer (char) `(progn (when (>= ouch-ptr read-buffer-length) ;;buffer overflow -- double the size (grow-read-buffer)) (setf (aref (the simple-string read-buffer) ouch-ptr) ,char) (setq ouch-ptr (1+ ouch-ptr)))) ;; macro to move ouch-ptr back one. (defmacro ouch-unread-buffer () '(when (> ouch-ptr inch-ptr) (setq ouch-ptr (1- ouch-ptr)))) (defun grow-read-buffer () (let ((rbl (length (the simple-string read-buffer)))) (when (and (boundp '*maximum-read-buffer-size*) (typep *maximum-read-buffer-size* 'fixnum) (> rbl *maximum-read-buffer-size*)) (ferror 'sys:read-error "Maximum read buffer size of ~S exceeded." *maximum-read-buffer-size* )) (setq read-buffer (string-nconc (the simple-string read-buffer) (the simple-string (make-array rbl :element-type 'string-char :area background-cons-area)))) (setq read-buffer-length (* 2 rbl)))) (defun inchpeek-read-buffer () (if (>= inch-ptr ouch-ptr) eof-object (elt (the simple-string read-buffer) inch-ptr))) (defun inch-read-buffer () (cond ((>= inch-ptr ouch-ptr) eof-object) (t (prog1 (aref (the simple-string read-buffer) inch-ptr) (setq inch-ptr (1+ inch-ptr)))))) (defmacro unread-buffer () `(decf inch-ptr)) (defun read-unwind-read-buffer () ;;keep contents, but make next (inch..) return first char. (setq inch-ptr 0)) (defun read-buffer-to-string () (subseq read-buffer 0 ouch-ptr )) ;;;Actual reader. (defvar *real-eof-errorp* () "Value checked by reader if recursivep is true.") (defvar *real-eof-value* () "Eof-value used for eof-value if recursivep is true.") (defvar right-paren-whitespace t "Flag that READ uses to tell when it's ok to treat right parens as whitespace.") ;; Alist for sharp-equal. Used to keep track of objects with labels assigned ;; that have been completly read. (defvar sharp-equal-alist ()) ;; Alist for sharp-sharp. Assoc's a number with a symbol produced by gensym. ;; Used by sharp-sharp as an unforgeable label, instead of the number. (defvar sharp-sharp-alist ()) (proclaim '(special *standard-input*)) ;;4/11/88 CLM for PHD - fix for spr 7158 (read-preserving-whitespace doesn't echo). (defun read-preserving-whitespace* (&optional (stream *standard-input*) (eof-errorp t) (eof-value ()) (recursivep ())) "Reads from stream and returns the object read, preserving the whitespace that followed the object." (case stream (nil (setf stream *standard-input*)) ((t) (setf stream *terminal-io*))) (let-if (null recursivep) ((*real-eof-value* eof-value) (*real-eof-errorp* eof-errorp) ;; The scope of these two lists is the top level read, so they ;; have to be reset here. (sharp-equal-alist nil) (sharp-sharp-alist nil) (read-buffer (allocate-buffer read-buffer-pool (make-array 512 :element-type 'string-char :fill-pointer 512))) (read-buffer-length) (ouch-ptr 0) (inch-ptr 0) (top-level-list t)) (unless recursivep (setq read-buffer-length (length read-buffer))) (unwind-protect ;;loop for repeating when a macro returns nothing. (do ((char (internal-read-char stream nil eof-object t) (internal-read-char stream nil eof-object t))) (()) (cond ((eofp char) (if eof-errorp (ferror 'sys:read-end-of-file "Unexpected end-of-file encountered.") (return eof-value))) ((whitespacep char)) (t (let* ((macrofun (get-cmt-entry char *readtable*)) (XR-SPLICE-P NIL) (result (multiple-value-list (funcall macrofun stream char)))) (let-if (null recursivep) ((XR-LIST-SO-FAR ':TOPLEVEL)) ;;repeat if macro returned nothing. (when result (return (car result)))))))) (unless recursivep (deallocate-buffer read-buffer-pool read-buffer ))))) ;; Read-preserving-whitespace behaves just like read only it makes sure ;; to leave terminating whitespace in the stream. ;;4/11/88 CLM for PHD - fix for spr 7158 (read-preserving-whitespace doesn't echo). (defun read-preserving-whitespace (&optional (stream *standard-input*) (eof-errorp t) (eof-value ()) (recursivep ()) ) "Reads from stream and returns the object read, preserving the whitespace that followed the object." (case stream (nil (setf stream *standard-input*)) ((t) (setf stream *terminal-io*))) (COND((AND (NOT RECURSIVEP) (NOT RUBOUT-HANDLER) (MEMber ':RUBOUT-HANDLER (FUNCALL STREAM ':WHICH-OPERATIONS) :test #'eq)) ;;We must get inside the rubout handler's top-level CATCH (FUNCALL STREAM ':RUBOUT-HANDLER '((:ACTIVATION = #\END)) #'read-preserving-whitespace* STREAM EOF-ERRORP EOF-VALUE nil)) (t (read-preserving-whitespace* stream eof-errorp eof-value recursivep)))) (defun read-maybe-nothing (stream char) ;;returns nil or a list with one thing. ;;Assumes char is not whitespace. (let ((retval (multiple-value-list (funcall (get-cmt-entry char *readtable*) stream char)))) (when retval (rplacd retval nil)))) ;;4/11/88 CLM for PHD - fix for spr 7158 (read-preserving-whitespace doesn't echo). (defun read (&optional (stream *standard-input*) (eof-errorp t) (eof-value ()) (recursivep ()) preserve-whitespace discard-close-parens check-indent &aux w-o ) "Reads in the next object in the stream, which defaults to *standard-input*. For details see the I/O chapter of the manual." (case stream (nil (setf stream *standard-input*)) ((t) (setf stream *terminal-io*))) (let-if (null recursivep) ((read-check-indentation check-indent) ( right-paren-whitespace discard-close-parens)) (SETQ W-O (FUNCALL STREAM ':WHICH-OPERATIONS)) (COND((MEMber ':READ W-O :test #'eq) (FUNCALL STREAM ':READ NIL)) ((AND (NOT RECURSIVEP) (NOT RUBOUT-HANDLER) (MEMber ':RUBOUT-HANDLER W-O :test #'eq)) ;;We must get inside the rubout handler's top-level CATCH (FUNCALL STREAM ':RUBOUT-HANDLER '((:ACTIVATION = #\END)) #'read-preserving-whitespace* STREAM EOF-ERRORP EOF-VALUE nil)) (t (prog1 (read-preserving-whitespace* stream eof-errorp eof-value recursivep) (when (and (null recursivep) (null preserve-whitespace) (listen stream)) (let ((whitechar (internal-read-char stream nil eof-object))) (if (and (not (eofp whitechar)) (not (whitespacep whitechar))) (unread-char whitechar stream))))))))) (deff internal-read #'read) ;;4/11/88 CLM for PHD - fix for spr 7158 (read-preserving-whitespace doesn't echo). (defun internal-read-form-or-implicit-list (&optional (stream *standard-input*) (eof-errorp t) eof-value recursive-p ignore discard-closeparens check-indentation &aux w-o) "This reader is a special version of SI:INTERNAL-READ for use by UCL top levels. It reads either a Lisp form or a symbol followed by a series of Lisp forms typed on one line (terminated by RETURN). In the first case the read form is returned. In the second case, a list containing the forms are returned as the first value and the keyword :IMPLICIT-LIST is returned as the second value. The UCL uses this function to read commands, implicit messages, and implicit-paren functions followed by arguments, along with regular Lisp expressions." (if (eq stream t) (setq stream *terminal-io*)) (let-if (null recursive-p) ((read-check-indentation check-indentation) ( right-paren-whitespace discard-closeparens)) (setq w-o (funcall stream ':which-operations)) (cond((member ':read w-o :test #'eq) (funcall stream ':read nil)) ((and (not recursive-p) (not rubout-handler) (member ':rubout-handler w-o :test #'eq)) ;;We must get inside the rubout handler's top-level CATCH (funcall stream ':rubout-handler '((:activation = #\End)) #'internal-read-form-or-implicit-list stream eof-errorp eof-value nil)) (t (let ((exp (read-preserving-whitespace* stream eof-errorp eof-value recursive-p ))) (if (or (char= last-char-read #\) ) (char= last-char-read #\cr)) exp (do ((implicit-list (list exp))) ((char= last-char-read #\cr) (values implicit-list :implicit-list)) (do ((char (internal-read-char stream nil eof-object t) (internal-read-char stream nil eof-object t))) (()) (cond ((eofp char) (if eof-errorp (ferror 'sys:read-end-of-file "Unexpected end-of-file encountered.") (return eof-value))) ((char= #\cr char) (if (cdr implicit-list ) (return-from internal-read-form-or-implicit-list implicit-list :implicit-list) (return-from internal-read-form-or-implicit-list(car implicit-list)))) ((whitespacep char)) (t (unread-char char stream) (push-end (read-preserving-whitespace* stream eof-errorp eof-value recursive-p ) implicit-list))))))))))) (defun read-delimited-list (endchar &optional (input-stream *standard-input*) recursivep &aux w-o) ;;PHD 12/23/86 Fixed it so it call be called at top level (recursivep being nil) (SETQ W-O (send input-STREAM ':WHICH-OPERATIONS)) (case input-stream (nil (setf input-stream *standard-input*)) ((t) (setf input-stream *terminal-io*))) (COND ((AND (NOT RECURSIVEP) (NOT RUBOUT-HANDLER) (SETQ W-O (send input-STREAM ':WHICH-OPERATIONS)) (MEMber ':RUBOUT-HANDLER W-O :test #'eq)) ;;We must get inside the rubout handler's top-level CATCH (FUNCALL input-STREAM ':RUBOUT-HANDLER '((:ACTIVATION = #\END)) #'read-delimited-list endchar input-STREAM nil)) (t (let-if (null recursivep) ((sharp-equal-alist nil) (sharp-sharp-alist nil) (read-buffer (allocate-buffer read-buffer-pool (make-array 512 :element-type 'string-char :fill-pointer 512))) (read-buffer-length) (ouch-ptr 0) (inch-ptr 0) (top-level-list t)) (unless recursivep (setq read-buffer-length (length read-buffer))) (unwind-protect (do* ((char (flush-whitespace input-stream) (flush-whitespace input-stream)) (thelist nil) ; PDC 8/7/86 (listtail (locf thelist))) ((char= char endchar) thelist) (let* ((XR-LIST-SO-FAR thelist) (XR-SPLICE-P NIL) (listobj (read-maybe-nothing input-stream char))) (COND (XR-SPLICE-P (SETQ theLIST XR-LIST-SO-FAR) (SETQ listtail (COND ((ATOM theLIST) (LOCF theLIST)) ((LAST theLIST)))))) ;;allows the possibility that a comment was read. (when listobj (rplacd listtail listobj) (setq listtail listobj)))) (unless recursivep (deallocate-buffer read-buffer-pool read-buffer ))))))) ;;;Standard ReadMacro definitions to implement the reader. (defun read-quote (stream ignore) (list 'quote (read-preserving-whitespace stream () () t))) (defun read-comment (stream ignore) (prepare-for-fast-read-char stream (do ((char (fast-read-char nil nil) (fast-read-char nil nil))) ((or (not char) (char= char #\newline)) (done-with-fast-read-char)))) ;;don't return anything (values)) (defun internal-read-list (stream &optional character) (let* ((thelist nil) (listtail (locf thelist)) (top-level-list top-level-list) correspondence-entry) (when (and read-Check-Indentation Last-Whitespace (Char= Last-Whitespace #\Cr) (null *read-suppress*)) ;;we are truly reading, not skipping things (If (Null Top-Level-List) (unless (and (listp xr-list-so-far) ; PDC 8/7/86 (symbolp (car xr-list-so-far)) (get (car xr-list-so-far) 'may-surround-defun)) (progn (signal-proceed-case (() 'sys:missing-closeparen "Open paren found in column zero; missing closeparens assumed.") (:no-action)) (setf missing-close-paren t) (unread-char #\( stream) (setf xr-splice-p t) (return-from internal-read-list nil))))) (setf last-whitespace nil) (setf missing-close-paren nil) (setf top-level-list nil) (when xr-correspondence-flag (unread-char character stream) (setq correspondence-entry `(nil ,(funcall stream :read-bp) ,@xr-correspondence)) (setq xr-correspondence correspondence-entry) (read-char stream)) (do ((firstchar (flush-whitespace stream) (flush-whitespace stream))) ((char= firstchar #\)) (when xr-correspondence-flag (rplaca correspondence-entry thelist)) thelist) (when (char= firstchar #\.) (let ((nextchar (internal-read-char stream t))) (cond ((token-delimiterp nextchar) (cond ((eq listtail (locf thelist)) (cerror :no-action nil 'sys:read-error-1 "Nothing appears before . in list.")) ((whitespacep nextchar) (setq nextchar (flush-whitespace stream)))) (rplacd listtail (let* ((XR-LIST-SO-FAR ':AFTER-DOT) (XR-SPLICE-P NIL) (values (read-after-dot stream nextchar))) (WHEN XR-SPLICE-P (return XR-LIST-SO-FAR)) ;;return list containing last thing. (car values))) (when xr-correspondence-flag (rplaca correspondence-entry thelist)) (return thelist)) ;;put back nextchar so we can read it normally. (t (unread-char nextchar stream))))) ;;next thing is not an isolated dot. (let* ((XR-LIST-SO-FAR thelist) (XR-SPLICE-P NIL) (listobj (read-maybe-nothing stream firstchar))) (COND (XR-SPLICE-P (SETQ theLIST XR-LIST-SO-FAR) (SETQ listtail (COND ((ATOM theLIST) (LOCF theLIST)) ( (LAST theLIST))))) ;;allows the possibility that a comment was read. (t (when listobj (rplacd listtail listobj) (setq listtail listobj))))) (when (and missing-close-paren (null top-level-list)) (when xr-correspondence-flag (rplaca correspondence-entry thelist)) (return thelist)) ))) (defun read-after-dot (stream firstchar) ;;firstchar is non-whitespace! (let ((lastobj ())) (do ((char firstchar (flush-whitespace stream))) ((char= char #\) ) (cerror :no-action nil 'sys:read-error-1 "Nothing appears after . in list.")) ;;see if there's something there. (setq lastobj (read-maybe-nothing stream char)) (when lastobj (return t))) ;;at least one thing appears after the dot. ;;check for more than one thing following dot. (do ((lastchar (flush-whitespace stream) (flush-whitespace stream))) ((char= lastchar #\) ) lastobj) ;success! ;;try reading virtual whitespace (if (read-maybe-nothing stream lastchar) (cerror :no-action nil 'sys:read-error-1 "More than one object follows . in list."))))) (defvar string-buffer-pool `((nil . ,(make-array 256 :fill-pointer 0 :adjustable t :element-type 'string-char)) (nil . ,(make-array 256 :fill-pointer 0 :adjustable t :element-type 'string-char)))) (defun internal-read-string (stream closech) (let ((string-buffer (allocate-buffer string-buffer-pool (make-array 256 :fill-pointer 0 :adjustable t :element-type 'string-char)))) (declare (string string-buffer)) (setf (fill-pointer string-buffer) 0) (unwind-protect (progn (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech) (done-with-fast-read-char)) (when (escapep char) (setq char (fast-read-char t))) (vector-push-extend char string-buffer (length string-buffer)))) (subseq string-buffer 0 (fill-pointer string-buffer))) (deallocate-buffer string-buffer-pool string-buffer)))) (defun read-right-paren (ignore ignore) (if right-paren-whitespace (values) (cerror :no-action nil 'sys:read-error-1 "Unmatched right parenthesis."))) (defun internal-read-extended-token (stream firstchar &aux (escape-appearedp nil)) ;;read the string up to the next delimiter. Leaves resulting token ;;in read-buffer, returns a flag that is true if an escape (\\) ;;appeared, meaning that it has to be a symbol. ;;needs to have package hacks added. (reset-read-buffer) (do ((char firstchar (internal-read-char stream nil eof-object))) ;;for now, treat #\: as a constituent: ;; does this cond need same fix as the top-level read did ?? ((cond ((eofp char) t) ((token-delimiterp char) (unread-char char stream) t) (t nil)) escape-appearedp) (cond ((escapep char) ;;it can't be a number, even if it's 1\23. (setq escape-appearedp t) ;;read next char here, so it won't be upper-casified. (let ((nextchar (internal-read-char stream nil eof-object))) (if (eofp nextchar) (ferror 'sys:read-end-of-file "End-of-file after escape character.") (ouch-read-buffer nextchar)))) (t (ouch-read-buffer (fast-char-upcase char)))))) (defmacro char-class (char attable) `(let ((att (svref ,attable (char-int ,char)))) (if (<= att terminating-macro) delimiter att))) (defun read-extended-token-for-read-suppress (stream firstchar ) ;;swallow up to the next delimiter or next expression ;;of the form pack: ;;needed to have package hacks added. (reset-read-buffer) (do ((char firstchar (internal-read-char stream nil eof-object)) (prev-char nil char) (attribute-table (character-attribute-table *readtable*))) ((cond ((eofp char) t) ((token-delimiterp char) (unread-char char stream) (when (and *read-accept-extensions* prev-char (eql (char-class prev-char attribute-table) package-delimiter)) (read-preserving-whitespace stream t nil t)) t) (t nil))) (when (escapep char) ;;read next char here, so it won't count as delimiter (let ((nextchar (internal-read-char stream nil eof-object))) (when (eofp nextchar) (ferror 'sys:read-end-of-file "End-of-file after escape character.")))))) (defmacro backup-char (char stream) `(if ,char (unread-char ,char ,stream))) (defvar *read-suppress* nil) ;;PHD 4/16/87 Allow reading of foo::(bar). (defun read-token (stream firstchar) "This function is just an fsm that recognizes numbers and symbols." ;;check explicitly whether firstchar has entry for non-terminating ;;in character-attribute-table and read-dot-number-symbol in CMT. ;;Report an error if these are violated (if we called this, we want ;;something that is a legitimate token!). ;;read in the longest possible string satisfying the bnf for ;;"unqualified-token". Leave the result in the READ-BUFFER. ;;Return next char after token (last char read). (DECLARE (inline fast-char-upcase)) (if *read-suppress* (read-extended-token-for-read-suppress stream firstchar) (let ((attribute-table (character-attribute-table *readtable*)) (pkg *package*) (colons 0)) (reset-read-buffer) (prog ((char firstchar)) (case (char-class char attribute-table) (#.constituent-sign (go SIGN)) (#.constituent-digit (go LEFTDIGIT)) (#.constituent-expt (go LEFTDIGIT)) (#.constituent-dot (go FRONTDOT)) (#.escape (go ESCAPE)) (#.package-delimiter (go COLON)) (#.multiple-escape (go MULT-ESCAPE)) ;;can't have eof, whitespace, or terminating macro as first char! (t (go SYMBOL))) SIGN ;;saw "sign" (ouch-read-buffer char) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-digit (go LEFTDIGIT)) (#.constituent-expt (go LEFTDIGIT)) (#.constituent-dot (go SIGNDOT)) (#.escape (go ESCAPE)) (#.package-delimiter (go COLON)) (#.multiple-escape (go MULT-ESCAPE)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (t (go SYMBOL))) LEFTDIGIT ;;saw "[sign] {digit}+" (unless (digit-char-p char (max 10. *read-base*)) (go SYMBOL)) (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (return (make-integer))) (case (char-class char attribute-table) (#.constituent-digit (go LEFTDIGIT)) (#.constituent-dot (go MIDDLEDOT)) (#.constituent-expt (if (digit-char-p char (max *read-base* 10.)) (go LEFTDIGIT) (go EXPONENT))) (#.constituent-slash (go RATIO)) (#.delimiter (unread-char char stream) (return (make-integer))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) MIDDLEDOT ;;saw "[sign] {digit}+ dot" (ouch-read-buffer char) (setq char (internal-read-char stream nil nil)) (unless char (return (let ((*read-base* 10)) (make-integer)))) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.constituent-expt (go EXPONENT)) (#.delimiter (unread-char char stream) (return (let ((*read-base* 10)) (make-integer)))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) RIGHTDIGIT ;;saw "[sign] {digit}* dot {digit}+" (unless (digit-char-p char (max *read-base* 10.)) (go SYMBOL)) (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (return (make-float))) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.constituent-expt (go EXPONENT)) (#.delimiter (unread-char char stream) (return (make-float))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) SIGNDOT ;;saw "[sign] dot" (ouch-read-buffer char) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (t (go SYMBOL))) FRONTDOT ;;saw "dot" (ouch-read-buffer char) (setq char (internal-read-char stream nil nil)) (unless char (cerror :no-action nil 'sys:read-error-1 "Dot context error.")) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.constituent-dot (go DOTS)) (#.delimiter (cerror :no-action nil 'sys:read-error-1 "Dot context error.")) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPONENT (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-sign (go EXPTSIGN)) (#.constituent-digit (go EXPTDIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPTSIGN ;;we got to EXPONENT, and saw a sign character. (ouch-read-buffer char) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-digit (go EXPTDIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPTDIGIT ;;got to EXPONENT, saw "[sign] {digit}+" (unless (digit-char-p char 10.) (go SYMBOL)) (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (return (make-float))) (case (char-class char attribute-table) (#.constituent-digit (go EXPTDIGIT)) (#.delimiter (unread-char char stream) (return (make-float))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) RATIO ;;saw "[sign] {digit}+ slash" (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-digit (go RATIODIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) RATIODIGIT ;;saw "[sign] {digit}+ slash {digit}+" (unless (digit-char-p char (max *read-base* 10.)) (go SYMBOL)) (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (return (make-ratio))) (case (char-class char attribute-table) (#.constituent-digit (go RATIODIGIT)) (#.delimiter (unread-char char stream) (return (make-ratio))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) DOTS ;;saw "dot {dot}+" (ouch-read-buffer char) (setq char (internal-read-char stream nil nil)) (unless char (if (common-lisp-on-p) (progn (cerror :no-action nil 'sys:read-error-1 "Too many dots.")) (go return-symbol))) (case (char-class char attribute-table) (#.constituent-dot (go DOTS)) (#.delimiter (unread-char char stream) (if (common-lisp-on-p) (progn (cerror :no-action nil 'sys:read-error-1 "Too many dots.")) (go return-symbol))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) SYMBOL ;;not a dot, dots, or number. (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP (ouch-read-buffer (fast-char-upcase char)) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.escape (done-with-fast-read-char) (go ESCAPE)) (#.delimiter (done-with-fast-read-char) (unread-char char stream) (go RETURN-SYMBOL)) (#.multiple-escape (done-with-fast-read-char) (go MULT-ESCAPE)) (#.package-delimiter (done-with-fast-read-char) (go COLON)) (#.sharp-sign (let ((next-char (internal-read-char stream nil nil))) ;;PHD 1/30/86 Added test on next-char (unless next-char (ouch-read-buffer char) (go return-symbol)) (if (eql (char-class next-char attribute-table) #.package-delimiter) (progn (done-with-fast-read-char) (go COLON)) (progn (unread-char next-char stream) (go symbol-loop))))) (t (go SYMBOL-LOOP))))) ESCAPE ;;saw an escape. ;;don't put the escape in the read-buffer. ;;read-next char, put in buffer (no case conversion). (let ((nextchar (internal-read-char stream nil nil))) (if nextchar (ouch-read-buffer nextchar) (ferror 'sys:read-end-of-file "End-of-file after escape character."))) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) MULT-ESCAPE (do ((char (internal-read-char stream t) (internal-read-char stream t))) ((multiple-escape-p char)) (if (escapep char) (setq char (internal-read-char stream t))) (ouch-read-buffer char)) (setq char (internal-read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) COLON (cond ((zerop colons) (setq colons 1)) (t (cerror :no-action nil 'sys:read-error-1 "Too many colons in ~S" (read-buffer-to-string)))) (do ((str (read-buffer-to-string))) ((setq pkg (find-package str))) (signal-proceed-case ((pkg-i) 'sys:read-package-not-found "Package ~s does not exist." str) (:no-action ;;PHD 1/30 set pkg to *package* (setf pkg *package*) (return)) (:new-name (setq str (string-upcase pkg-i))) (:create-package (or (find-package str) (make-package str))))) (reset-read-buffer) (setq char (internal-read-char stream nil nil)) (unless char (ferror 'sys:read-end-of-file "End of file encountered after reading a colon.")) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (unless *read-accept-extensions* (cerror :no-action nil 'sys:read-error-1 "Illegal terminating character after a colon, ~S" char)) (let ((*package* pkg)) (return (read-preserving-whitespace stream t nil t)))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go INTERN)) (t (go SYMBOL))) INTERN (setq colons 2) (setq char (internal-read-char stream nil nil)) (unless char (ferror 'sys:read-end-of-file "End of file encountered after reading a colon.")) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (unless *read-accept-extensions* (cerror :no-action nil 'sys:read-error-1 "Illegal terminating character after a colon, ~S" char)) (let ((*package* pkg)) (return (read-preserving-whitespace stream t nil t)))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (cerror :no-action nil 'sys:read-error-1 "Too many colons after ~S:" (package-name pkg)) (go intern)) (t (go SYMBOL))) RETURN-SYMBOL (return (read-make-symbol colons pkg)) )))) (defun read-extended-token (stream &optional (*readtable* *readtable*)) ;;for semi-external use: returns 2 values: the string for the token, ;;and a flag for whether there was an escape char. (let ((escape-appearedp (internal-read-extended-token stream (internal-read-char stream t)))) (values (read-buffer-to-string) escape-appearedp))) (defun read-make-symbol (colons pkg &aux (l (length read-buffer))) (unwind-protect (block nil (setf (fill-pointer read-buffer) ouch-ptr) (if (or (zerop colons) (and *read-accept-extensions* (null *restrict-internal-symbols*)) (= colons 2) (eq pkg *keyword-package*)) (return (let ((r (if (and (boundp '*read-intern-function*) (functionp *read-intern-function*)) (funcall *read-intern-function* read-buffer pkg) (intern read-buffer pkg)))) (if (and (plusp colons) ;We don't want substitution if the package we specified is the ;same as the symbol-package of the symbol we've read. (eq pkg (symbol-package r))) r (OR (CDR (assoc r *READER-SYMBOL-SUBSTITUTIONS* :test #'eq)) r)))) (multiple-value-bind (symbol test) (find-symbol read-buffer pkg) (cond ((eq test :external) (return (if (eq pkg (symbol-package symbol)) ;;We don't want substitution if the package we specified is the ;;same as the symbol-package of the symbol we've read ;;to force the package to be lisp. symbol (OR (CDR (assoc symbol *READER-SYMBOL-SUBSTITUTIONS* :test #'eq)) symbol)))) ((null test) (cerror :no-action nil 'sys:read-error-1 "Symbol ~S not found in package ~S." read-buffer pkg) (return (intern read-buffer pkg))) ((and *restrict-internal-symbols* (eq test :internal) (rassoc symbol *ZETALISP-SYMBOL-SUBSTITUTIONS* :test #'eq)) (return symbol)) (t (compiler:mindefs-warn nil :implausible "The symbol ~S is not external in the ~ package ~S" read-buffer pkg) (return symbol)))))) (setf (fill-pointer read-buffer) l))) ;;; Number reading functions. (defmacro digit* nil `(do ((ch char (inch-read-buffer))) ((or (eofp ch) (not (digit-char-p ch))) (setq char ch)) ;;report if at least one digit is seen: (setq one-digit t))) (defmacro exponent-letterp (letter) `(member ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d) :test #'eq)) ;;PAD 3/27/87 Allow reading of 8 as number if *read-accept-extensions* and *read-base* = 8. (defun make-integer () (let* ((%base (if (boundp '*read-base*) (if (and (locally (declare (optimize (safety 3))) (fixnump *read-base*)) (<= 1 *read-base* 36)) *read-base* (ferror 'sys:read-error-1 "~A not a valid number for *read-base*." *read-base*)) 10.)) (digit-base (if *read-accept-extensions* (max 10. %base) %base)) (negative-number nil) (number 0) (char ())) (read-unwind-read-buffer) (if (cond ((char= (setq char (inch-read-buffer)) #\-) (setq negative-number t)) ((char= char #\+) t)) (setq char (inch-read-buffer))) ;; Read (almost) normally until the number becomes a bignum. (do ((ch char (inch-read-buffer))) ;;there can be a dot at the end. ((or (eofp ch) (char= ch #\.))) (if (not (digit-char-p ch digit-base)) (return-from make-integer (progn (read-unwind-read-buffer) (read-make-symbol 0 *package*)))) (setq number (+ (* number %base) (digit-char-p ch digit-base)))) (if negative-number (- number) number))) (defun make-float () ;;assume that the contents of read-buffer are a legal float, with nothing ;;else after it. (flet ((coerce-to-short-float (x) (coerce x 'short-float)) (coerce-to-single-float (x) (coerce x 'single-float)) (coerce-to-double-float (x) (coerce x 'double-float)) (coerce-to-long-float (x) (coerce x 'long-float))) (flet ((pick-default-float ()(ecase *read-default-float-format* (short-float #'coerce-to-short-float ) (single-float #'coerce-to-single-float ) (double-float #'coerce-to-double-float ) (long-float #'coerce-to-long-float )))) (read-unwind-read-buffer) (prog ((negative-fraction nil) (number 0) (divisor-exp 0) (negative-exponent nil) (exponent 0) (float-char ()) (char (inch-read-buffer))) (if (cond ((char= char #\+) t) ((char= char #\-) (setq negative-fraction t))) ;;flush it (setq char (inch-read-buffer))) ;;read digits before the dot (do* ((ch char (inch-read-buffer)) (dig (digit-char-p ch) (digit-char-p ch))) ((not dig) (setq char ch)) (setq number (+ (* number 10) dig))) ;;deal with the dot, if it's there. (when (char= char #\.) (setq char (inch-read-buffer)) ;;read digits after the dot. (do* ((ch char (inch-read-buffer)) (dig (and (not (eofp ch)) (digit-char-p ch)) (and (not (eofp ch)) (digit-char-p ch)))) ((not dig) (setq char ch)) (incf divisor-exp) (setq number (+ (* number 10) dig)))) ;;is there an exponent letter? (cond ((eofp char) ;;if not, we've read the whole number. (let ((num (funcall (pick-default-float) (/ number (expt 10 divisor-exp))))) (return (if negative-fraction (- num) num)))) ((exponent-letterp char) (setq float-char char) ;;build exponent (setq char (inch-read-buffer)) ;;check leading sign (if (cond ((char= char #\+) t) ((char= char #\-) (setq negative-exponent t))) ;;flush sign (setq char (inch-read-buffer))) ;;read digits for exponent (do* ((ch char (inch-read-buffer)) (dig (and (not (eofp ch)) (digit-char-p ch)) (and (not (eofp ch)) (digit-char-p ch)))) ((not dig) (setq exponent (if negative-exponent (- exponent) exponent))) (setq exponent (+ (* exponent 10) dig))) ;;generate and return the float, depending on float-char: (decf exponent divisor-exp) ;Combine exponent and decimal-point info (let* ((coerce-float-function (case float-char (#\E (pick-default-float)) (#\S #'coerce-to-short-float) (#\F #'coerce-to-single-float) (#\D #'coerce-to-double-float) (#\L #'coerce-to-long-float))) (num (if (minusp exponent) (/ (funcall coerce-float-function number) (expt 10. (abs exponent))) (funcall coerce-float-function (* number (expt 10. exponent)))))) (return (if negative-fraction (- num) num)))) ;;should never happen: (t (ferror 'sys:read-error-1 "Internal error in floating point reader."))))))) (defun make-ratio () ;;assume read-buffer contains a legal ratio. Build the number from ;;the string. ;;look for optional "+" or "-". ;;PAD 3/27/87 Allow reading of 8 as number if *read-accept-extensions* and *read-base* = 8 (let* ((%base (if (boundp '*read-base*) (if (and (locally (declare (optimize (safety 3))) (fixnump *read-base*)) (<= 1 *read-base* 36)) *read-base* (ferror 'sys:read-error-1 "~A not a valid number for *read-base*." *read-base*)) 10.)) (digit-base (if *read-accept-extensions* (max 10. %base) %base)) (numerator 0) (denominator 0) (char ()) (negative-number nil)) (read-unwind-read-buffer) (setq char (inch-read-buffer)) (cond ((char= char #\+) (setq char (inch-read-buffer))) ((char= char #\-) (setq char (inch-read-buffer)) (setq negative-number t))) ;;get numerator (do* ((ch char (inch-read-buffer)) (dig (digit-char-p ch digit-base) (digit-char-p ch digit-base))) ((not dig)) (setq numerator (+ (* numerator %base) dig))) ;;get denominator (do* ((ch (inch-read-buffer) (inch-read-buffer)) (dig ())) ((or (eofp ch) (not (setq dig (digit-char-p ch))))) (setq denominator (+ (* denominator %base) dig))) (let ((num (/ numerator denominator))) (if negative-number (- num) num)))) ;;;;dispatching macro cruft (defun dispatch-char-error (ignore sub-char ignore) (cerror :no-action nil 'sys:read-error-1 "No dispatch function defined for ~S." sub-char)) (defun read-dispatch-char (stream char) ;;read some digits (let ((numargp nil) (numarg 0) (sub-char ())) (do* ((ch (internal-read-char stream nil eof-object) (internal-read-char stream nil eof-object)) (dig ())) ((or (eofp ch) (not (setq dig (digit-char-p ch)))) ;;take care of the extra char. (if (eofp ch) (ferror 'sys:read-end-of-file "End-of-file inside dispatch character.") (setq sub-char ch))) (setq numargp t) (setq numarg (+ (* numarg 10) dig))) ;;look up the function and call it. (let ((dpair (find-disp-char char (dispatch-tables *readtable*)))) (if dpair (funcall (elt (the simple-vector (cdr dpair)) (char-int (char-upcase sub-char))) stream sub-char (if numargp numarg nil)) (ferror 'sys:read-error-1 "No dispatch table for dispatch char."))))) ;;; Parse-Integer. (defun parse-integer (string ;&rest keywords &key(start 0) ( end (length string)) (radix 10) ( junk-allowed nil) ) "Return a number parsed from the contents of STRING, or a part of it. START and END are indices specify the part of the string; END = NIL means the end of it. RADIX is a number from 2 to 36, which defaults to ten. If JUNK-ALLOWED is NIL (default), the string must contain simply a number surrounded by whitespace. The number must be just digits (including suitable letters if RADIX is > 10) and an optional sign. Otherwise it is an error. If JUNK-ALLOWED is non-NIL, parsing stops when anything is encountered that doesn't fit that description, or at non-leading whitespace. If no number has been found by then, the value is NIL. The second value is the index in STRING of where parsing stopped." (let ((result nil) (index start) (minusp nil)) (block main ;; Skip over whitespace. (loop (when (>= index end) (return-from main)) (when (not (whitespacep (char string index))) (return)) (incf index)) ;; Record the sign, if any. (let ((char (char string index))) (cond ((char= char #\-) (setq minusp t) (incf index)) ((char= char #\+) (incf index)))) (loop (when (= index end) (return-from main)) (let* ((char (char string index)) (weight (digit-char-p char radix))) (cond (weight (setq result (+ weight (* (or result 0) radix)))) ((whitespacep char) (return)) (t (return-from main))) (incf index))) ;; Swallow whitespace (loop (incf index) (when (= index end) (return)) (when (not (whitespacep (char string index))) (return)))) (if junk-allowed (return-from parse-integer (values (if (and minusp result) (- result) result) index)) (if (/= index end) (ferror 'sys:read-error-1 "There's junk in this string: ~S." string) (return-from parse-integer (values (if (and minusp result) (- result) result) index)))))) (eval-when (load ) (setq secondary-attribute-table #.(init-secondary-attribute-table)) (setq standard-readtable #.(init-std-zetalisp-readtable)) (setq common-lisp-readtable #.(init-std-lisp-readtable)))