Skip to content
Snippets Groups Projects
Commit e66de4a6 authored by wlott's avatar wlott
Browse files

Replaced the FORMAT transform with one that uses FORMATTER for more

complete handling of format directives.
parent 7305cf47
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -1504,84 +1504,30 @@
;;;; FORMAT transform: ;;;; FORMAT transform:
;;; A transform for FORMAT, based on the original (courtesy of Skef.)
;;; ;;;
(deftransform format ((stream control &rest args) ;;; If the control string is a compile-time constant, then replace it with
((or (member t) stream) simple-string &rest t)) ;;; a use of the FORMATTER macro so that the control string is ``compiled.''
"convert to output primitives" ;;; 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) (unless (constant-continuation-p control)
(give-up "Control string is not a constant.")) (give-up "Control string is not a constant."))
(let* ((control (continuation-value control)) (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
(end (length control)) `(lambda (dest control ,@arg-names)
(penultimus (1- end)) (declare (ignore control))
(stream-form (if (csubtypep (continuation-type stream) (format dest (formatter ,(continuation-value control)) ,@arg-names))))
(specifier-type 'stream)) ;;;
`(stream) (deftransform format ((stream control &rest args) (stream function &rest t))
())) (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
(arg-vars (mapcar #'(lambda (x) `(lambda (stream control ,@arg-names)
(declare (ignore x)) (funcall control stream ,@arg-names)
(gensym)) nil)))
args)) ;;;
(args arg-vars) (deftransform format ((tee control &rest args) ((member t) function &rest t))
(index 0)) (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
(declare (simple-string control)) `(lambda (tee control ,@arg-names)
(collect ((forms)) (declare (ignore tee))
(loop (funcall control *standard-output* ,@arg-names)
(let ((command-index (position #\~ control :start index))) nil)))
(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)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment