Index: /branches/working-0711/ccl/compiler/optimizers.lisp =================================================================== --- /branches/working-0711/ccl/compiler/optimizers.lisp (revision 9463) +++ /branches/working-0711/ccl/compiler/optimizers.lisp (revision 9464) @@ -1866,4 +1866,84 @@ +(define-compiler-macro write-string (&environment env &whole call + string &optional (stream nil) &rest keys) + (if (nx-form-typep string 'simple-string env) + (if keys + `((lambda (string stream &key start end) + (write-simple-string string stream start end)) + ,string ,stream ,@keys) + `(write-simple-string ,string ,stream 0 nil)) + call)) + +(define-compiler-macro format (&environment env &whole call stream string &rest args) + (if (stringp string) + (cond ((string-equal string "~a") + (destructuring-bind (object) args + (cond ((null stream) + `(princ-to-string ,object)) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(princ ,object ,(and (neq stream t) stream))) + (t `(let ((stream ,stream) + (object ,object)) + (if (or (null stream) (stringp stream)) + (format-to-string stream ,string object) + (princ object (and (neq stream t) stream)))))))) + ((string-equal string "~s") + (destructuring-bind (object) args + (cond ((null stream) + `(prin1-to-string ,object)) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(prin1 ,object ,(and (neq stream t) stream))) + (t `(let ((stream ,stream) + (object ,object)) + (if (or (null stream) (stringp stream)) + (format-to-string stream ,string object) + (prin1 object (and (neq stream t) stream)))))))) + ((and (null (position #\~ string)) (null args)) + (cond ((null stream) + string) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(write-string ,string ,(and (neq stream t) stream))) + (t `(let ((stream ,stream)) + (if (or (null stream) (stringp stream)) + (format-to-string stream ,string) + (write-string ,string (and (neq stream t) stream))))))) + ((and args (optimize-format-call stream string (car args) (%cdr args) env))) + (t call)) + call)) + +(defun optimize-format-call (stream string obj args env) + (let* ((start (or (search "~/" string) (return-from optimize-format-call nil))) + (ipos (+ start 2)) + (epos (or (position #\/ string :start ipos) (return-from optimize-format-call nil)))) + (when (and + ;; Must be first directive, since otherwise don't know how to split args. + (not (position #\~ string :end start)) + ;; Don't deal with packages + (not (position #\: string :start ipos :end epos))) + (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user)) + (prev (and (< 0 start) (subseq string 0 start))) + (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos)))) + (stream-var (gensym)) + (body `(,@(and prev `((write-string ,prev ,stream-var))) + (,func ,stream-var ,obj nil nil) + ,@(and rest `((format ,stream-var ,rest ,@args)))))) + (cond ((null stream) + `(with-output-to-string (,stream-var) + (declare (type stream ,stream-var)) + ,@body)) + ((or (eq stream t) (nx-form-typep stream 'stream env)) + `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream))) + (declare (type stream ,stream-var)) + ,@body)) + (t + `(let ((,stream-var ,stream)) + (if (or (null ,stream-var) (stringp ,stream-var)) + (format-to-string stream-var ,string ,obj ,@args) + (progn + (when (eq ,stream-var t) (setq ,stream-var *standard-output*)) + ,@body))))))))) + + (define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others) (if (and sub0 (null others)) Index: /branches/working-0711/ccl/level-1/l1-format.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-format.lisp (revision 9463) +++ /branches/working-0711/ccl/level-1/l1-format.lisp (revision 9464) @@ -64,7 +64,10 @@ ; *format-control-string* and *format-length*, before returning. -(defun sub-format (stream *format-index* *format-length* &aux (string *format-control-string*) char) - (prog* ((length *format-length*) (i *format-index*) (lastpos i)) - (declare (fixnum i length lastpos)) +(defun sub-format (stream *format-index* *format-length* &aux char) + (prog* ((string (require-type *format-control-string* 'simple-string)) + (length *format-length*) + (i *format-index*) + (lastpos i)) + (declare (fixnum i length lastpos) (type simple-string string)) (go START) EOF-ERROR @@ -79,5 +82,5 @@ (let* ((limit (the fixnum (1- i)))) (unless (= limit lastpos) - (write-string string stream :start lastpos :end limit))) + (write-simple-string string stream lastpos limit))) (let ((params nil) (fn) (colon nil) (atsign nil)) (block nil Index: /branches/working-0711/ccl/level-1/l1-io.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-io.lisp (revision 9463) +++ /branches/working-0711/ccl/level-1/l1-io.lisp (revision 9464) @@ -93,4 +93,24 @@ (stream-write-string stream string start end))) string)) + +(defun write-simple-string (string output-stream start end) + "Write the characters of the subsequence of simple-string STRING bounded by START +and END to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream)) + (string (the simple-string string))) ;; typecheck at high safety. + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream)) + (start (or start 0))) + (with-ioblock-output-locked (ioblock) + (if (and (eq start 0) (null end)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (let* ((end (check-sequence-bounds string start end))) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string start (%i- end start)))))) + (if (and (not start) (not end)) + (stream-write-string stream string) + (stream-write-string stream string start end))) + string)) (defun write-line (string &optional output-stream Index: /branches/working-0711/ccl/lib/format.lisp =================================================================== --- /branches/working-0711/ccl/lib/format.lisp (revision 9463) +++ /branches/working-0711/ccl/lib/format.lisp (revision 9464) @@ -336,7 +336,9 @@ (if (functionp control-string) (apply control-string stream format-arguments) - (let ((*format-control-string* (ensure-simple-string control-string)) - (*format-pprint* nil) - (*format-justification-semi* nil)) + (let* ((control-string (ensure-simple-string control-string)) + (*format-control-string* control-string) + (*format-pprint* nil) + (*format-justification-semi* nil)) + (declare (type simple-string control-string)) (cond ;; Try to avoid pprint overhead in this case. @@ -357,4 +359,13 @@ (do-sub-format stream)))))) nil)))) + +(defun format-to-string (string control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (if string + (with-output-to-string (stream string) + (apply #'format stream control-string format-arguments)) + (with-output-to-string (stream) + (apply #'format stream control-string format-arguments)))) + (defun do-sub-format (stream)