From e66de4a6bb575eb8641a8e2bbb9fdd83ad1fcb7b Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Wed, 3 Feb 1993 18:26:14 +0000 Subject: [PATCH] Replaced the FORMAT transform with one that uses FORMATTER for more complete handling of format directives. --- compiler/srctran.lisp | 104 ++++++++++-------------------------------- 1 file changed, 25 insertions(+), 79 deletions(-) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index a85ab957f..164783a2c 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.39 1992/12/13 15:18:54 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.40 1993/02/03 18:26:14 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1504,84 +1504,30 @@ ;;;; FORMAT transform: - -;;; A transform for FORMAT, based on the original (courtesy of Skef.) ;;; -(deftransform format ((stream control &rest args) - ((or (member t) stream) simple-string &rest t)) - "convert to output primitives" +;;; If the control string is a compile-time constant, then replace it with +;;; a use of the FORMATTER macro so that the control string is ``compiled.'' +;;; Furthermore, if the destination is either a stream or T and the control +;;; string is a function (i.e. formatter), then convert the call to format to +;;; just a funcall of that function. +;;; +(deftransform format ((dest control &rest args) (t simple-string &rest t)) (unless (constant-continuation-p control) (give-up "Control string is not a constant.")) - (let* ((control (continuation-value control)) - (end (length control)) - (penultimus (1- end)) - (stream-form (if (csubtypep (continuation-type stream) - (specifier-type 'stream)) - `(stream) - ())) - (arg-vars (mapcar #'(lambda (x) - (declare (ignore x)) - (gensym)) - args)) - (args arg-vars) - (index 0)) - (declare (simple-string control)) - (collect ((forms)) - (loop - (let ((command-index (position #\~ control :start index))) - (unless command-index - ;; Write out the final part of the string. - (forms `(write-string ,(subseq control index end) - ,@stream-form)) - (when args - (compiler-warning "~R extra format argument~:P. Ignoring..." - (length args)) - (forms `(progn ,@args))) - - (return `(lambda (stream control ,@arg-vars) - (declare (ignorable stream control)) - ,@(forms) - nil))) - - (when (= command-index penultimus) - (abort-transform "FORMAT control string ends in a ~~: ~S" - control)) - - ;; Non-command stuff gets write-string'ed out. - (when (/= index command-index) - (forms `(write-string - ,(subseq control index command-index) - ,@stream-form))) - - ;; Get the format directive. - (flet ((next-arg () - (unless args - (abort-transform "Missing FORMAT argument.")) - (pop args))) - (forms - (case (schar control (1+ command-index)) - ((#\b #\B) `(let ((*print-base* 2)) - (princ ,(next-arg) ,@stream-form))) - ((#\o #\O) `(let ((*print-base* 8)) - (princ ,(next-arg) ,@stream-form))) - ((#\d #\D) `(let ((*print-base* 10)) - (princ ,(next-arg) ,@stream-form))) - ((#\x #\X) `(let ((*print-base* 16)) - (princ ,(next-arg) ,@stream-form))) - ((#\a #\A) `(princ ,(next-arg) ,@stream-form)) - ((#\s #\S) `(prin1 ,(next-arg) ,@stream-form)) - (#\% `(terpri ,@stream-form)) - (#\& `(fresh-line ,@stream-form)) - (#\| `(write-char #\form ,@stream-form)) - (#\~ `(write-char #\~ ,@stream-form)) - (#\newline - (let ((new-pos (position-if-not - #'lisp::whitespace-char-p - control - :start (+ command-index 2)))) - (if new-pos - (setq command-index (- new-pos 2))))) - (t - (give-up))))) - - (setq index (+ command-index 2))))))) + (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) + `(lambda (dest control ,@arg-names) + (declare (ignore control)) + (format dest (formatter ,(continuation-value control)) ,@arg-names)))) +;;; +(deftransform format ((stream control &rest args) (stream function &rest t)) + (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) + `(lambda (stream control ,@arg-names) + (funcall control stream ,@arg-names) + nil))) +;;; +(deftransform format ((tee control &rest args) ((member t) function &rest t)) + (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) + `(lambda (tee control ,@arg-names) + (declare (ignore tee)) + (funcall control *standard-output* ,@arg-names) + nil))) -- GitLab