Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/reader.clisp
There are no other files named reader.clisp in the archive.
;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; Spice Lisp Reader 
;;; Written by David Dill
;;; Package system interface by Lee Schumacher.
;;; Runs in the standard Spice Lisp environment.

;;; ****************************************************************

(in-package 'lisp)

(export '(*readtable* copy-readtable set-syntax-from-char set-macro-character
	  get-macro-character make-dispatch-macro-character
	  set-dispatch-macro-character get-dispatch-macro-character
	  *read-default-float-format* parse-integer read-from-string))
;;; Spice Lisp specific hacks.
;;; This macro can be replaced by the obvious system function.

(defmacro reader-fast-int-char (char)
  ;;no type checking.  Assumes no funny font, bits.
  `(%sp-make-immediate-type ,char %character-type))

;;;Random global variables

(defvar *read-default-float-format* 'single-float "Float format for 1.0E1")

(defvar *readtable* () "Variable bound to current readtable.")
;;;Readtable implementation: the readtable is a structure with three
;;;components: the CHARACTER-ATTRIBUTE-TABLE is a vector of 128 integers
;;;for describing the character type.  Conceptually, there are 6 distinct
;;;"primary" character attributes (WHITESPACE, CONSTITUENT, SINGLE ESCAPE,
;;;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
;;;attributes are constant properties of the characters (as long as they
;;;are constituents).

;;;The CHARACTER-MACRO-TABLE is a vector of 128 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.  Note that any character
;;;that does not have a read macro definition gets READ-TOKEN as its
;;;macro definition.  Finally, there is a
;;;DISPATCH-TABLES entry, which is an alist from dispatch characters to
;;;vectors of 128 functions, for use in defining dispatching macros (like

(defvar std-lisp-readtable ()
  "Standard lisp readtable. This is for recovery from broken
   read-tables, and should not normally be user-visible.")

(defstruct (readtable
	    (:conc-name nil)
	    (:predicate readtablep))
  (character-attribute-table (make-character-attribute-table)
			     :type simple-vector)
  (character-macro-table (make-character-macro-table)
			 :type simple-vector)
  (dispatch-tables () :type list))
;;;Constants for character attributes.  These are all as in the manual.
(eval-when (compile load eval)

  (defconstant whitespace 0)
  (defconstant terminating-macro 1)
  (defconstant non-terminating-macro 2)
  (defconstant escape 3)
  (defconstant multiple-escape 4)
  (defconstant constituent 5)
  (defconstant constituent-dot 6)
  (defconstant constituent-expt 7)
  (defconstant constituent-slash 8)
  (defconstant constituent-digit 9)
  (defconstant constituent-letter-digit 10)
  (defconstant constituent-decimal-digit 11)
  (defconstant constituent-sign 12)
  (defconstant package-delimiter 13)
  (defconstant illegal 14))

(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.

(proclaim '(special *package* *keyword-package* *read-base*))
;;;macros and functions for character tables.

(defmacro get-cat-entry (char rt)
  ;;only give this side-effect-free args.
  `(elt (the simple-vector (character-attribute-table ,rt))
	(char-int ,char)))

(defun set-cat-entry (char newvalue &optional (rt *readtable*))
  (setf (elt (the simple-vector (character-attribute-table rt))
	     (char-int char))

(defmacro get-cmt-entry (char rt)
  `(elt (the simple-vector (character-macro-table ,rt))
	(char-int ,char)))

(defun set-cmt-entry (char newvalue &optional (rt *readtable*))
  (setf (elt (the simple-vector (character-macro-table rt))
	     (char-int char))

(defun make-character-attribute-table ()
  (make-array 128 :element-type t :initial-element #.constituent))

(defun make-character-macro-table ()
  (make-array 128 :element-type t
		      :initial-element #'undefined-macro-char))

(defun undefined-macro-char (ignore char)
  (error "Undefined read-macro character ~S" char))
;;;The character attribute table is a 128-long vector of integers. 

(defmacro test-attribute (char whichclass rt)
  `(= (get-cat-entry ,char ,rt) ,whichclass)))

;;;Predicates for testing character attributes

(defmacro whitespacep (char &optional (rt '*readtable*))
  `(test-attribute ,char #.whitespace ,rt))

(defmacro constituentp (char &optional (rt '*readtable*))
  `(>= (get-cat-entry ,char ,rt) #.constituent))

(defmacro terminating-macrop (char &optional (rt '*readtable*))
  `(test-attribute ,char #.terminating-macro ,rt))

(defmacro non-terminating-macrop (char &optional (rt '*readtable*))
  `(test-attribute ,char #.non-terminating-macro ,rt))

(defmacro escapep (char &optional (rt '*readtable*))
  `(test-attribute ,char #.escape ,rt))

(defmacro multiple-escape-p (char &optional (rt '*readtable*))
  `(test-attribute ,char #.multiple-escape ,rt))

(defmacro token-delimiterp (char &optional (rt '*readtable*))
  ;;depends on actual attribute numbering above.
  `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
(defvar secondary-attribute-table ())

(defun set-secondary-attribute (char attribute)
  (setf (elt (the simple-vector secondary-attribute-table) (char-int char))

(defmacro get-secondary-attribute (char)
  `(elt (the simple-vector secondary-attribute-table)
	(char-int ,char)))
(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
  "A copy is made of FROM-READTABLE, which defaults to the current readtable.
  If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable
  is made.  If TO-READTABLE is unsupplied or NIL, a fresh copy is made.
  Otherwise, TO-READTABLE must be a readtable, which is destructively copied
  (if (null from-readtable) (setq from-readtable std-lisp-readtable))
  (if (null to-readtable) (setq to-readtable (make-readtable)))
  ;;physically clobber contents of internal tables.
  (replace (character-attribute-table to-readtable)
	   (character-attribute-table from-readtable))
  (replace (character-macro-table to-readtable)
	   (character-macro-table from-readtable))
  (setf (dispatch-tables to-readtable)
	(mapcar #'(lambda (pair) (cons (car pair)
				       (copy-seq (cdr pair))))
		(dispatch-tables from-readtable)))
(defun set-syntax-from-char (to-char from-char &optional
				     (to-readtable *readtable*)
				     (from-readtable ()))
  "This makes the syntax of TO-CHAR in TO-READTABLE be the same as the syntax
  (if (null from-readtable) (setq from-readtable std-lisp-readtable))
  ;;copy from-char entries to to-char entries, but make sure that if
  ;;from char is a constituent you don't copy non-movable secondary
  ;;attributes (constituent types), and that said attributes magically
  ;;appear if you transform a non-constituent to a constituent.
  (let ((att (get-cat-entry from-char from-readtable)))
    (if (constituentp from-char from-readtable)
	(setq att (get-secondary-attribute to-char)))
    (set-cat-entry to-char att to-readtable)
    (set-cmt-entry to-char
		   (get-cmt-entry from-char from-readtable)
(defun set-macro-character (char function &optional
				 (non-terminatingp nil) (rt *readtable*))
  (if non-terminatingp
      (set-cat-entry char #.non-terminating-macro rt)
      (set-cat-entry char #.terminating-macro rt))
  (set-cmt-entry char function rt))

(defun get-macro-character (char &optional (rt *readtable*))
  "Returns the function associated with CHAR and, as a second value, returns
  the NON-TERMINATING-P flag; it returns NIL of CHAR does not have
  macro-character syntax."
  ;;check macro syntax, return associated function if it's there.
  ;;returns a value for all constituents.
  (cond ((non-terminating-macrop char)
	 (values (get-cmt-entry char rt) t))
	((terminating-macrop char)
	 (values (get-cmt-entry char rt) nil))
	(t nil)))
;;;These definitions support internal programming conventions.

(defconstant eof-object '(*eof*))

(defmacro eofp (char) `(eq ,char eof-object))
;;;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.")

;; 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*))
(defvar *read-suppress* nil)
;;;dispatching macro cruft

(defun make-char-dispatch-table ()
  (make-array 128 :initial-element #'dispatch-char-error))

(defun dispatch-char-error (ignore sub-char ignore)
  (error "No dispatch function defined for ~S."	sub-char))

(defun make-dispatch-macro-character (char &optional
					   (non-terminating-p nil)
					   (rt *readtable*))
  "Causes the character CHAR to be a dispatching macro character in READTABLE.
  If NON-TERMINATING-P is not NIL, then it will be a non-terminating macro
  character: it may be embedded within extended tokens.  Returns T."
  (set-macro-character char #'read-dispatch-char non-terminating-p rt)
  (let* ((dalist (dispatch-tables rt))
	 (dtable (cdr (find char dalist :test #'char= :key #'car))))
    (cond (dtable
	   (error "Dispatch character already exists"))
	   (setf (dispatch-tables rt)
	    (push (cons char (make-char-dispatch-table)) dalist))))))

(defun set-dispatch-macro-character
       (disp-char sub-char function &optional (rt *readtable*))
  "Causes FUNCTION to be called when the DISP-CHAR followed by SUB-CHAR is
  read.  The READTABLE defaults to the current readtable."
  ;;get the dispatch char for macro (error if not there), diddle
  ;;entry for sub-char.
  (let ((dpair (find disp-char (dispatch-tables rt)
		     :test #'char= :key #'car)))
    (if dpair
	(setf (elt (the simple-vector (cdr dpair))
		   (char-int sub-char))
	(error "~S is not a dispatch char." disp-char))))

(defun get-dispatch-macro-character (disp-char sub-char
					       &optional (rt *readtable*))
  "Returns the macro-character frunction for SUB-CHAR under DISP-CHAR, or
  NIL if there is no function associated with SUB-CHAR."
  (let ((dpair (find disp-char (dispatch-tables rt)
		     :test #'char= :key #'car)))
    (if dpair
	(elt (the simple-vector (cdr dpair))
	     (char-int sub-char))
	(error "~S is not a dispatch char." disp-char))))

(defun read-dispatch-char (stream char)
  ;;read some digits
  (let ((numargp nil)
	(numarg 0)
	(sub-char ()))
    (do* ((ch (read-char stream nil eof-object)
	      (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)
	      (error "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 char (dispatch-tables *readtable*)
		       :test #'char= :key #'car)))
      (if dpair
	  (funcall (elt (the simple-vector (cdr dpair))
			(char-int sub-char))
		   stream sub-char (if numargp numarg nil))
	  (error "No dispatch table for dispatch char.")))))


(defun read-from-string (string &optional eof-error-p
	eof-value &key start end preserve-whitespace)
  "The characters of STRING are given successively to the Lisp reader, and
  the Lisp object built by the reader is returned.  Macro characters and so on
  will all take effect."
  (%sp-read-from-string string eof-error-p eof-value start end 

(defun parse-integer (string &key (start 0) (end (length string))
			     (radix 10) junk-allowed)
  "This function examines the substring of STRING delimited by :START
  and :END (which default to the beginning and the end of the string).  It
  skips over whitespace characters and then attempts to parse an integer.
  The :RADIX parameter defaults to 10 and must be an integer between 
  2 and 36."
  ;; Skip over whitespace.
  (let ((index (do ((i start (1+ i)))
		   ((= i end)
		    (if junk-allowed
			(return-from parse-integer (values nil end))
			(error "No non-whitespace characters in number."))) 
		 (unless (whitespacep (char string i)) (return i))))
	(minusp nil)
	(found-digit nil)
	(result 0))
    (let ((char (char string index)))
      ;; Record the sign, if any.
      (cond ((char= char #\-)
	     (setq minusp t)
	     (incf index))
	    ((char= char #\+)
	     (incf index))))
    ;; Zoom through the string, parsing an integer.
     (when (= index end) (return nil))
     (let* ((char (char string index))
	    (weight (digit-char-p char radix)))
       (cond (weight
	      (setq result (+ weight (* result radix))
		    found-digit t))
	     (junk-allowed (return nil))
	     ((whitespacep char)
	      (do ((jndex (1+ index) (1+ jndex)))
		  ((= jndex end))
		(unless (whitespacep (char string jndex))
		  (error "There's junk in this string: ~S." string)))
	      (return nil))
	      (error "There's junk in this string: ~S." string))))
     (incf index))
     (if found-digit
	 (if minusp (- result) result)
	 (if junk-allowed
	     (error "There's no digits in this string: ~S" string)))