From 0f8505d11410d718de8e1048454eab1ea865a0df Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 29 Nov 1991 19:47:19 +0000 Subject: [PATCH] Added MAKE-CASE-FROB-STREAM which is used by the new format to handle ~(...~) variants. See the doc string for details. --- code/stream.lisp | 217 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 214 insertions(+), 3 deletions(-) diff --git a/code/stream.lisp b/code/stream.lisp index 076e549cb..0a822b92a 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.12 1991/06/10 16:57:47 chiles Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.13 1991/11/29 19:47:19 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.12 1991/06/10 16:57:47 chiles Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.13 1991/11/29 19:47:19 wlott Exp $ ;;; ;;; Stream functions for Spice Lisp. ;;; Written by Skef Wholey and Rob MacLachlan. @@ -1106,7 +1106,218 @@ (t (funcall method sub-stream operation arg1 arg2))))) -(proclaim '(notinline read-char unread-char read-byte listen)) +(proclaim '(maybe-inline read-char unread-char read-byte listen)) + + + +;;;; Case frobbing streams, used by format ~(...~). + +(in-package "EXT") +(export '(make-case-frob-stream)) +(in-package "LISP") + +(defstruct (case-frob-stream + (:include stream + (:misc #'case-frob-misc)) + (:constructor %make-case-frob-stream (target out sout))) + (target (required-argument) :type stream)) + +(defun make-case-frob-stream (target kind) + "Returns a stream that sends all output to the stream TARGET, but modifies + the case of letters, depending on KIND, which should be one of: + :upcase - convert to upper case. + :downcase - convert to lower case. + :capitalize - convert the first letter of words to upper case and the + rest of the word to lower case. + :capitalize-first - convert the first letter of the first word to upper + case and everything else to lower case." + (declare (type stream target) + (type (member :upcase :downcase :capitalize :capitalize-first) + kind) + (values stream)) + (if (case-frob-stream-p target) + ;; If we are going to be writing to a stream that already does case + ;; frobbing, why bother frobbing the case just so it can frob it + ;; again? + target + (multiple-value-bind + (out sout) + (ecase kind + (:upcase + (values #'case-frob-upcase-out + #'case-frob-upcase-sout)) + (:downcase + (values #'case-frob-downcase-out + #'case-frob-downcase-sout)) + (:capitalize + (values #'case-frob-capitalize-out + #'case-frob-capitalize-sout)) + (:capitalize-first + (values #'case-frob-capitalize-first-out + #'case-frob-capitalize-first-sout))) + (%make-case-frob-stream target out sout)))) + +(defun case-frob-misc (stream op &optional arg1 arg2) + (declare (type case-frob-stream stream)) + (case op + (:close) + (t + (let ((target (case-frob-stream-target stream))) + (funcall (stream-misc target) target op arg1 arg2))))) + + +(defun case-frob-upcase-out (stream char) + (declare (type case-frob-stream stream) + (type base-character char)) + (let ((target (case-frob-stream-target stream))) + (funcall (stream-out target) target (char-upcase char)))) + +(defun case-frob-upcase-sout (stream str start end) + (declare (type case-frob-stream stream) + (type simple-base-string str) + (type index start) + (type (or index null) end)) + (let* ((target (case-frob-stream-target stream)) + (len (length str)) + (end (or end len))) + (funcall (stream-sout target) target + (if (and (zerop start) (= len end)) + (string-upcase str) + (nstring-upcase (subseq str start end))) + 0 + (- end start)))) + +(defun case-frob-downcase-out (stream char) + (declare (type case-frob-stream stream) + (type base-character char)) + (let ((target (case-frob-stream-target stream))) + (funcall (stream-out target) target (char-downcase char)))) + +(defun case-frob-downcase-sout (stream str start end) + (declare (type case-frob-stream stream) + (type simple-base-string str) + (type index start) + (type (or index null) end)) + (let* ((target (case-frob-stream-target stream)) + (len (length str)) + (end (or end len))) + (funcall (stream-sout target) target + (if (and (zerop start) (= len end)) + (string-downcase str) + (nstring-downcase (subseq str start end))) + 0 + (- end start)))) + +(defun case-frob-capitalize-out (stream char) + (declare (type case-frob-stream stream) + (type base-character char)) + (let ((target (case-frob-stream-target stream))) + (cond ((alphanumericp char) + (funcall (stream-out target) target (char-upcase char)) + (setf (case-frob-stream-out stream) + #'case-frob-capitalize-aux-out) + (setf (case-frob-stream-sout stream) + #'case-frob-capitalize-aux-sout)) + (t + (funcall (stream-out target) target char))))) + +(defun case-frob-capitalize-sout (stream str start end) + (declare (type case-frob-stream stream) + (type simple-base-string str) + (type index start) + (type (or index null) end)) + (let* ((target (case-frob-stream-target stream)) + (str (subseq str start end)) + (len (length str)) + (inside-word nil)) + (dotimes (i len) + (let ((char (schar str i))) + (cond ((not (alphanumericp char)) + (setf inside-word nil)) + (inside-word + (setf (schar str i) (char-downcase char))) + (t + (setf inside-word t) + (setf (schar str i) (char-upcase char)))))) + (when inside-word + (setf (case-frob-stream-out stream) + #'case-frob-capitalize-aux-out) + (setf (case-frob-stream-sout stream) + #'case-frob-capitalize-aux-sout)) + (funcall (stream-sout target) target str 0 len))) + +(defun case-frob-capitalize-aux-out (stream char) + (declare (type case-frob-stream stream) + (type base-character char)) + (let ((target (case-frob-stream-target stream))) + (cond ((alphanumericp char) + (funcall (stream-out target) target (char-downcase char))) + (t + (funcall (stream-out target) target char) + (setf (case-frob-stream-out stream) + #'case-frob-capitalize-out) + (setf (case-frob-stream-sout stream) + #'case-frob-capitalize-sout))))) + +(defun case-frob-capitalize-aux-sout (stream str start end) + (declare (type case-frob-stream stream) + (type simple-base-string str) + (type index start) + (type (or index null) end)) + (let* ((target (case-frob-stream-target stream)) + (str (subseq str start end)) + (len (length str)) + (inside-word t)) + (dotimes (i len) + (let ((char (schar str i))) + (cond ((not (alphanumericp char)) + (setf inside-word nil)) + (inside-word + (setf (schar str i) (char-downcase char))) + (t + (setf inside-word t) + (setf (schar str i) (char-upcase char)))))) + (unless inside-word + (setf (case-frob-stream-out stream) + #'case-frob-capitalize-out) + (setf (case-frob-stream-sout stream) + #'case-frob-capitalize-sout)) + (funcall (stream-sout target) target str 0 len))) + +(defun case-frob-capitalize-first-out (stream char) + (declare (type case-frob-stream stream) + (type base-character char)) + (let ((target (case-frob-stream-target stream))) + (cond ((alphanumericp char) + (funcall (stream-out target) target (char-upcase char)) + (setf (case-frob-stream-out stream) + #'case-frob-downcase-out) + (setf (case-frob-stream-sout stream) + #'case-frob-downcase-sout)) + (t + (funcall (stream-out target) target char))))) + +(defun case-frob-capitalize-first-sout (stream str start end) + (declare (type case-frob-stream stream) + (type simple-base-string str) + (type index start) + (type (or index null) end)) + (let* ((target (case-frob-stream-target stream)) + (str (subseq str start end)) + (len (length str))) + (dotimes (i len) + (let ((char (schar str i))) + (when (alphanumericp char) + (setf (schar str i) (char-upcase char)) + (do ((i (1+ i) (1+ i))) + ((= i len)) + (setf (schar str i) (char-downcase (schar str i)))) + (setf (case-frob-stream-out stream) + #'case-frob-downcase-out) + (setf (case-frob-stream-sout stream) + #'case-frob-downcase-sout) + (return)))) + (funcall (stream-sout target) target str 0 len))) -- GitLab