From d63d90b10a35f9ab46bf94442149f145287bd75f Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 4 Feb 1992 21:10:33 +0000 Subject: [PATCH] Added support for READTABLE-CASE in symbol printing. Added some missing array type declarations in SYMBOL-QUOTEP. The behavior when *PRINT-CASE* is :CAPITALIZE and *PRINT-ESCAPE* is NIL is now slightly different than before. --- code/print.lisp | 299 +++++++++++++++++++++++++++++++----------------- 1 file changed, 192 insertions(+), 107 deletions(-) diff --git a/code/print.lisp b/code/print.lisp index 415c67ecc..61ebcc740 100644 --- a/code/print.lisp +++ b/code/print.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/print.lisp,v 1.33 1992/01/26 07:36:36 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.34 1992/02/04 21:10:33 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -555,8 +555,11 @@ ;;;; Symbols. -(defvar *previous-case* () - "What the previous case selection the printer was set to.") +;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last time the +;;; printer was called. +;;; +(defvar *previous-case* nil) +(defvar *previous-readtable-case* nil) ;;; This variable contains the current definition of one of three symbol ;;; printers. SETUP-PRINTER-STATE sets this variable. @@ -571,16 +574,46 @@ ;;; stream is also reset. ;;; (defun setup-printer-state () - (unless (eq *print-case* *previous-case*) + (unless (and (eq *print-case* *previous-case*) + (eq (readtable-case *readtable*) *previous-readtable-case*)) (setq *previous-case* *print-case*) + (setq *previous-readtable-case* (readtable-case *readtable*)) + (unless (member *print-case* '(:upcase :downcase :capitalize)) + (setq *print-case* :upcase) + (error "Invalid *PRINT-CASE* value: ~S" *previous-case*)) + (unless (member *previous-readtable-case* + '(:upcase :downcase :invert :preserve)) + (setf (readtable-case *readtable*) :upcase) + (error "Invalid READTABLE-CASE value: ~S" *previous-readtable-case*)) + (setq *internal-symbol-output-function* - (case *print-case* - (:upcase #'output-uppercase-symbol) - (:downcase #'output-lowercase-symbol) - (:capitalize #'output-capitalize-symbol) - (T (let ((bad-case *print-case*)) - (setq *print-case* :upcase) - (Error "Invalid *print-case* value: ~s" bad-case))))))) + (case *previous-readtable-case* + (:upcase + (case *print-case* + (:upcase #'output-preserve-symbol) + (:downcase #'output-lowercase-symbol) + (:capitalize #'output-capitalize-symbol))) + (:downcase + (case *print-case* + (:upcase #'output-uppercase-symbol) + (:downcase #'output-preserve-symbol) + (:capitalize #'output-capitalize-symbol))) + (:preserve #'output-preserve-symbol) + (:invert #'output-invert-symbol))))) + +;;; OUTPUT-QUOTED-SYMBOL-NAME -- Internal +;;; +;;; Out Pname (a symbol-name or package-name) surrounded with |'s, and with +;;; any embedded |'s or \'s escaped. +;;; +(defun output-quoted-symbol-name (pname stream) + (write-char #\| stream) + (dotimes (index (length pname)) + (let ((char (schar pname index))) + (when (or (char= char #\\) (char= char #\|)) + (write-char #\\ stream)) + (write-char char stream))) + (write-char #\| stream)) (defun output-symbol (object stream) (if (or *print-escape* *print-readably*) @@ -612,25 +645,22 @@ ;; qualified. This can happen if the symbol has been inherited ;; from a package other than its home package. (unless (and accessible (eq symbol object)) - (funcall *internal-symbol-output-function* - (package-name package) - stream) + (let ((pkg-name (package-name package))) + (if (symbol-quotep pkg-name) + (output-quoted-symbol-name pkg-name stream) + (funcall *internal-symbol-output-function* pkg-name + stream))) (multiple-value-bind (symbol externalp) (find-external-symbol name package) (declare (ignore symbol)) (if externalp (write-char #\: stream) (write-string "::" stream))))))) - (funcall *internal-symbol-output-function* name stream)) - (case *print-case* - (:upcase - (write-string (symbol-name object) stream)) - (:downcase - (write-string (string-downcase (symbol-name object)) stream)) - (:capitalize - (write-string (string-capitalize (symbol-name object)) - stream))))) - + (if (symbol-quotep name) + (output-quoted-symbol-name name stream) + (funcall *internal-symbol-output-function* name stream))) + (funcall *internal-symbol-output-function* (symbol-name object) stream))) + ;;;; Escaping symbols: @@ -638,29 +668,38 @@ ;;; printed with escape characters. This isn't a whole lot easier than ;;; reading symbols in the first place. ;;; -;;; For each character, the value of the corresponding element is a fixnum -;;; with bits set corresponding to attributes that the character has. This -;;; is also used by the character printer. +;;; For each character, the value of the corresponding element is a fixnum with +;;; bits set corresponding to attributes that the character has. At characters +;;; have at least one bit set, so we can search for any character with a +;;; positive test. ;;; (defvar character-attributes - (make-array char-code-limit :element-type '(unsigned-byte 8) + (make-array char-code-limit :element-type '(unsigned-byte 16) :initial-element 0)) +;;; +(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit)) + character-attributes)) (eval-when (compile load eval) ;;; Constants which are a bit-mask for each interesting character attribute. ;;; -(defconstant number-attribute #b10) ; A numeric digit. -(defconstant letter-attribute #b100) ; A upper-case letter. -(defconstant sign-attribute #b1000) ; +- -(defconstant extension-attribute #b10000) ; ^_ -(defconstant dot-attribute #b100000) ; . -(defconstant slash-attribute #b1000000) ; / -(defconstant other-attribute #b1) ; Anything else legal. -(defconstant funny-attribute #b10000000) ; Anything illegal. - +(defconstant other-attribute (ash 1 0)) ; Anything else legal. +(defconstant number-attribute (ash 1 1)) ; A numeric digit. +(defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter. +(defconstant lowercase-attribute (ash 1 3)) ; A lowercase letter. +(defconstant sign-attribute (ash 1 4)) ; +- +(defconstant extension-attribute (ash 1 5)) ; ^_ +(defconstant dot-attribute (ash 1 6)) ; . +(defconstant slash-attribute (ash 1 7)) ; / +(defconstant funny-attribute (ash 1 8)) ; Anything illegal. + +;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters that +;;; don't need to be escaped (according to READTABLE-CASE.) +;;; (defconstant attribute-names - '((number . number-attribute) (letter . letter-attribute) + `((number . number-attribute) (lowercase . lowercase-attribute) + (uppercase . uppercase-attribute) (letter . letter-attribute) (sign . sign-attribute) (extension . extension-attribute) (dot . dot-attribute) (slash . slash-attribute) (other . other-attribute) (funny . funny-attribute))) @@ -683,7 +722,8 @@ (end (char-code #\Z))) ((> code end)) (declare (fixnum code end)) - (set-bit (code-char code) letter-attribute)) + (set-bit (code-char code) uppercase-attribute) + (set-bit (char-downcase (code-char code)) lowercase-attribute)) (set-bit #\- sign-attribute) (set-bit #\+ sign-attribute) @@ -701,7 +741,11 @@ ;;; base in which that character is a digit. ;;; (defvar digit-bases - (make-array char-code-limit :element-type '(mod 37) :initial-element 36)) + (make-array char-code-limit :element-type '(unsigned-byte 8) + :initial-element 36)) +;;; +(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit)) + digit-bases)) (dotimes (i 36) (let ((char (digit-char i 36))) @@ -741,6 +785,11 @@ (attributes character-attributes) (bases digit-bases) (base *print-base*) + (letter-attribute + (case (readtable-case *readtable*) + (:upcase uppercase-attribute) + (:downcase lowercase-attribute) + (t (logior lowercase-attribute uppercase-attribute)))) (index 0) (bits 0) (code 0) @@ -752,9 +801,15 @@ (return (not (test sign))) OTHER ; Not potential number, see if funny chars... - (return (not (null (%sp-find-character-with-attribute - name (1- index) len - attributes funny-attribute)))) + (let ((mask (logxor (logior lowercase-attribute uppercase-attribute + funny-attribute) + letter-attribute))) + (do ((i (1- index) (1+ i))) + ((= i len) (return-from symbol-quotep nil)) + (unless (zerop (logand (aref attributes (char-code (schar name i))) + mask)) + (return-from symbol-quotep t)))) + START (when (digitp) (if (test letter) @@ -846,79 +901,109 @@ (go DIGIT)))) -;;;; Printname hackery - -;;; This function takes the pname of a symbol and adds slashes and/or -;;; vertical bars to it to make it readable again. -;;; Special quoting characters are currently vertical bar and slash who's -;;; role in life are to specially quote symbols. Funny symbol characters -;;; are those who need special slashification when they are to be printed -;;; so they can be read in again. These currently include such characters -;;; as hash signs, colons of various sorts, etc. -;;; Now there are three different version: UPPERCASE, lowercase and Captialize. -;;; Check out the manual under the entry for *print-case* for details. - -(eval-when (compile eval) -(defmacro symbol-quote-char-p (char) - `(or (char= ,char #\\) (char= ,char #\|))) -); eval-when (compile eval) +;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* +;;; +;;; Case hackery. These functions are stored in +;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of *PRINT-CASE* +;;; and READTABLE-CASE. +;;; -(defun output-uppercase-symbol (pname stream) +;; Called when: +;; READTABLE-CASE *PRINT-CASE* +;; :UPCASE :UPCASE +;; :DOWNCASE :DOWNCASE +;; :PRESERVE any +(defun output-preserve-symbol (pname stream) (declare (simple-string pname)) - (cond ((symbol-quotep pname) - (write-char #\| stream) - (dotimes (index (length pname)) - (let ((char (schar pname index))) - ;;If it needs slashing, do it. - (if (symbol-quote-char-p char) - (write-char #\\ stream)) - (write-char char stream))) - (write-char #\| stream)) - (t - (write-string pname stream)))) + (write-string pname stream)) -;;; See documentation for output-symbol-uppercase (above). -;;; +;; Called when: +;; READTABLE-CASE *PRINT-CASE* +;; :UPCASE :DOWNCASE (defun output-lowercase-symbol (pname stream) (declare (simple-string pname)) - (cond ((symbol-quotep pname) - (write-char #\| stream) - (dotimes (index (length pname)) - (let ((char (schar pname index))) - ;;If it needs slashing, do it. - (if (symbol-quote-char-p char) - (write-char #\\ stream)) - (write-char char stream))) - (write-char #\| stream)) - (t - (dotimes (index (length pname)) - (let ((char (schar pname index))) - (write-char (char-downcase char) stream)))))) - + (dotimes (index (length pname)) + (let ((char (schar pname index))) + (write-char (char-downcase char) stream)))) +;; Called when: +;; READTABLE-CASE *PRINT-CASE* +;; :DOWNCASE :UPCASE +(defun output-uppercase-symbol (pname stream) + (declare (simple-string pname)) + (dotimes (index (length pname)) + (let ((char (schar pname index))) + (write-char (char-upcase char) stream)))) + +;; Called when: +;; READTABLE-CASE *PRINT-CASE* +;; :UPCASE :CAPITALIZE +;; :DOWNCASE :CAPITALIZE +;; (defun output-capitalize-symbol (pname stream) (declare (simple-string pname)) - (cond - ((symbol-quotep pname) - (write-char #\| stream) - (dotimes (index (length pname)) - (let ((char (schar pname index))) - ;;If it needs slashing, do it. - (if (symbol-quote-char-p char) - (write-char #\\ stream)) - (write-char char stream))) - (write-char #\| stream)) - (t - (do ((index 0 (1+ index)) - (pname-length (length (the string pname))) - (prev-not-alpha t)) - ((= index pname-length)) - (declare (fixnum index pname-length)) - (let ((char (char pname index))) - (write-char (if prev-not-alpha char (char-downcase char)) stream) - (setq prev-not-alpha (not (alpha-char-p char)))))))) - + (let ((prev-not-alpha t) + (up (eq (readtable-case *readtable*) :upcase))) + (dotimes (i (length pname)) + (let ((char (char pname i))) + (write-char (if up + (if (or prev-not-alpha (lower-case-p char)) + char + (char-downcase char)) + (if prev-not-alpha + (char-upcase char) + char)) + stream) + (setq prev-not-alpha (not (alpha-char-p char))))))) +;; Called when: +;; READTABLE-CASE *PRINT-CASE* +;; :INVERT any +(defun output-invert-symbol (pname stream) + (declare (simple-string pname)) + (let ((all-upper t) + (all-lower t)) + (dotimes (i (length pname)) + (let ((ch (schar pname i))) + (when (both-case-p ch) + (if (upper-case-p ch) + (setq all-lower nil) + (setq all-upper nil))))) + (cond (all-upper (output-lowercase-symbol pname stream)) + (all-lower (output-uppercase-symbol pname stream)) + (t + (write-string pname stream))))) + + +#| +(defun test1 () + (let ((*readtable* (copy-readtable nil))) + (format t "READTABLE-CASE Input Symbol-name~@ + ----------------------------------~%") + (dolist (readtable-case '(:upcase :downcase :preserve :invert)) + (setf (readtable-case *readtable*) readtable-case) + (dolist (input '("ZEBRA" "Zebra" "zebra")) + (format t "~&:~A~16T~A~24T~A" + (string-upcase readtable-case) + input + (symbol-name (read-from-string input))))))) + +(defun test2 () + (let ((*readtable* (copy-readtable nil))) + (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@ + --------------------------------------------------------~%") + (dolist (readtable-case '(:upcase :downcase :preserve :invert)) + (setf (readtable-case *readtable*) readtable-case) + (dolist (*print-case* '(:upcase :downcase :capitalize)) + (dolist (symbol '(|ZEBRA| |Zebra| |zebra|)) + (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A" + (string-upcase readtable-case) + (string-upcase *print-case*) + (symbol-name symbol) + (prin1-to-string symbol) + (princ-to-string symbol))))))) + +|# ;;;; Recursive objects. -- GitLab