Changeset 9464 for branches

Timestamp:

May 13, 2008, 6:56:14 AM (17 years ago)

Author:

gz

Message:

Compiler macros for write-string -> write-simple-string, and some common cases of format.

Location:

branches/working-0711/ccl

Files:

• compiler/optimizers.lisp (modified) (1 diff)
• level-1/l1-format.lisp (modified) (2 diffs)
• level-1/l1-io.lisp (modified) (1 diff)
• lib/format.lisp (modified) (2 diffs)

branches/working-0711/ccl/compiler/optimizers.lisp

@@ -1866 +1866 @@
 
 
+(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))

branches/working-0711/ccl/level-1/l1-format.lisp

@@ -64 +64 @@
 ; *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 +82 @@
         (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

branches/working-0711/ccl/level-1/l1-io.lisp

@@ -93 +93 @@
         (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

branches/working-0711/ccl/lib/format.lisp

@@ -336 +336 @@
         (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 +359 @@
                  (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)