From 980662cba1fc916683e6b472a233f503086db25b Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 4 Feb 1992 16:21:09 +0000 Subject: [PATCH] Added READTABLE-CASE. Added a print-function for READTABLE. --- code/reader.lisp | 106 +++++++++++++++++++++++++++++++++++------------ 1 file changed, 79 insertions(+), 27 deletions(-) diff --git a/code/reader.lisp b/code/reader.lisp index 23468f3da..b1d08ab12 100644 --- a/code/reader.lisp +++ b/code/reader.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.9 1991/12/12 16:18:40 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.10 1992/02/04 16:21:09 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,11 +17,11 @@ ;;; Runs in the standard Spice Lisp environment. ;;; (in-package 'lisp) -(export '(readtable readtablep *read-base* *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 *read-default-float-format* read-preserving-whitespace +(export '(readtable readtable-case readtablep *read-base* *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 + *read-default-float-format* read-preserving-whitespace read-delimited-list parse-integer read-from-string *read-suppress*)) ;;;Random global variables @@ -66,13 +66,18 @@ (defstruct (readtable (:conc-name nil) (:predicate readtablep) - (:copier nil)) + (:copier nil) + (:print-function + (lambda (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :identity t) + (prin1 'readtable stream))))) "Readtable is a data structure that maps characters into syntax types for the Common Lisp expression reader." (character-attribute-table (make-character-attribute-table) :type simple-vector) (character-macro-table (make-character-macro-table) :type simple-vector) - (dispatch-tables () :type list)) - + (dispatch-tables () :type list) + (readtable-case :upcase :type (member :upcase :downcase :preserve :invert))) ;;;; Constants for character attributes. These are all as in the manual. @@ -635,17 +640,58 @@ ;;;; Token fetching. -#| -(defmacro backup-char (char stream) - `(if ,char (unread-char ,char ,stream))) -|# - (defvar *read-suppress* nil "Suppresses most interpreting of the reader when T") (defvar *read-base* 10 "The radix that Lisp reads numbers in.") +;;; CASIFY-READ-BUFFER -- Internal +;;; +;;; Modify the read-buffer according to READTABLE-CASE, ignoring escapes. +;;; ESCAPES is a list of the escaped indices, in reverse order. +;;; +(defun casify-read-buffer (escapes) + (let ((case (readtable-case *readtable*))) + (cond + ((and (null escapes) (eq case :upcase)) + (dotimes (i ouch-ptr) + (setf (schar read-buffer i) (char-upcase (schar read-buffer i))))) + ((eq case :preserve)) + (t + (macrolet ((skip-esc (&body body) + `(do ((i (1- ouch-ptr) (1- i)) + (escapes escapes)) + ((minusp i)) + (declare (fixnum i)) + (when (or (null escapes) + (let ((esc (first escapes))) + (declare (fixnum esc)) + (cond ((< esc i) t) + (t + (assert (= esc i)) + (pop escapes) + nil)))) + (let ((ch (schar read-buffer i))) + ,@body))))) + (flet ((lower-em () + (skip-esc (setf (schar read-buffer i) (char-downcase ch)))) + (raise-em () + (skip-esc (setf (schar read-buffer i) (char-upcase ch))))) + (ecase case + (:upcase (raise-em)) + (:downcase (lower-em)) + (:invert + (let ((all-upper t) + (all-lower t)) + (skip-esc + (when (both-case-p ch) + (if (upper-case-p ch) + (setq all-lower nil) + (setq all-upper nil)))) + (cond (all-lower (raise-em)) + (all-upper (lower-em)))))))))))) + (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 @@ -655,13 +701,14 @@ ;;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). - (if *read-suppress* - (internal-read-extended-token stream firstchar) + (when *read-suppress* + (return-from read-token (internal-read-extended-token stream firstchar))) (let ((attribute-table (character-attribute-table *readtable*)) (package *package*) (colons 0) (possibly-rational t) - (possibly-float t)) + (possibly-float t) + (escapes ())) (reset-read-buffer) (prog ((char firstchar)) (case (char-class3 char attribute-table) @@ -690,7 +737,7 @@ (t (go SYMBOL))) LEFTDIGIT ;;saw "[sign] {digit}+" - (ouch-read-buffer (char-upcase char)) + (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) (case (char-class3 char attribute-table) @@ -760,7 +807,7 @@ (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPONENT - (ouch-read-buffer (char-upcase char)) + (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) @@ -809,7 +856,7 @@ (t (go SYMBOL))) RATIODIGIT ;;saw "[sign] {digit}+ slash {digit}+" - (ouch-read-buffer (char-upcase char)) + (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio))) (case (char-class2 char attribute-table) @@ -836,7 +883,7 @@ (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP - (ouch-read-buffer (char-upcase char)) + (ouch-read-buffer char) (setq char (fast-read-char nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) @@ -855,9 +902,10 @@ ;;don't put the escape in the read-buffer. ;;read-next char, put in buffer (no case conversion). (let ((nextchar (read-char stream nil nil))) - (if nextchar - (ouch-read-buffer nextchar) - (error "End-of-file after escape character."))) + (unless nextchar + (error "End-of-file after escape character.")) + (push ouch-ptr escapes) + (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) @@ -870,6 +918,7 @@ (do ((char (read-char stream t) (read-char stream t))) ((multiple-escape-p char)) (if (escapep char) (setq char (read-char stream t))) + (push ouch-ptr escapes) (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -880,6 +929,7 @@ (#.package-delimiter (go COLON)) (t (go SYMBOL))) COLON + (casify-read-buffer escapes) (cond ((zerop colons) (setq colons 1) (setq package (find-package (read-buffer-to-string))) @@ -911,6 +961,7 @@ (package-name package))) (t (go SYMBOL))) RETURN-SYMBOL + (casify-read-buffer escapes) (if (or (zerop colons) (= colons 2) (eq package *keyword-package*)) (return (intern* read-buffer ouch-ptr package)) (multiple-value-bind (symbol test) @@ -1003,7 +1054,7 @@ (let* ((ch (inch-read-buffer))) (cond ((or (eofp ch) (char= ch #\.)) (return-from make-integer - (let ((Res + (let ((res (if (zerop number) num (+ num (* number (expt base digit)))))) @@ -1022,7 +1073,8 @@ (divisor 1) (negative-exponent nil) (exponent 0) - (float-char ()) (char (inch-read-buffer))) + (float-char ()) + (char (inch-read-buffer))) (if (cond ((char= char #\+) t) ((char= char #\-) (setq negative-fraction t))) ;;flush it @@ -1065,7 +1117,7 @@ (setq exponent (if negative-exponent (- exponent) exponent))) (setq exponent (+ (* exponent 10) dig))) ;;generate and return the float, depending on float-char: - (let* ((float-format (case float-char + (let* ((float-format (case (char-upcase float-char) (#\E *read-default-float-format*) (#\S 'short-float) (#\F 'single-float) -- GitLab