Changeset 9483


Ignore:
Timestamp:
May 15, 2008, 1:31:46 PM (11 years ago)
Author:
gz
Message:

Fix format optimizer to return right value. Optimize ~ even if not first in string

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r9471 r9483  
    18831883                    `(princ-to-string ,object))
    18841884                   ((or (eq stream t) (nx-form-typep stream 'stream env))
    1885                     `(princ ,object ,(and (neq stream t) stream)))
     1885                    `(progn (princ ,object ,(and (neq stream t) stream)) nil))
    18861886                   (t `(let ((stream ,stream)
    18871887                             (object ,object))
    18881888                         (if (or (null stream) (stringp stream))
    18891889                           (format-to-string stream ,string object)
    1890                            (princ object (and (neq stream t) stream))))))))
     1890                           (progn (princ object (and (neq stream t) stream)) nil)))))))
    18911891          ((string-equal string "~s")
    18921892           (destructuring-bind (object) args
     
    18941894                    `(prin1-to-string ,object))
    18951895                   ((or (eq stream t) (nx-form-typep stream 'stream env))
    1896                     `(prin1 ,object ,(and (neq stream t) stream)))
     1896                    `(progn (prin1 ,object ,(and (neq stream t) stream)) nil))
    18971897                   (t `(let ((stream ,stream)
    18981898                             (object ,object))
    18991899                         (if (or (null stream) (stringp stream))
    19001900                           (format-to-string stream ,string object)
    1901                            (prin1 object (and (neq stream t) stream))))))))
     1901                           (progn (prin1 object (and (neq stream t) stream)) nil)))))))
    19021902          ((and (null (position #\~ string)) (null args))
    19031903           (cond ((null stream)
    19041904                  string)
    19051905                 ((or (eq stream t) (nx-form-typep stream 'stream env))
    1906                   `(write-string ,string ,(and (neq stream t) stream)))
     1906                  `(progn (write-string ,string ,(and (neq stream t) stream)) nil))
    19071907                 (t `(let ((stream ,stream))
    19081908                       (if (or (null stream) (stringp stream))
    19091909                         (format-to-string stream ,string)
    1910                          (write-string ,string (and (neq stream t) stream)))))))
    1911           ((and args (optimize-format-call stream string (car args) (%cdr args) env)))
     1910                         (progn (write-string ,string (and (neq stream t) stream)) nil))))))
     1911          ((optimize-format-call stream string args env))
    19121912          (t call))
    19131913    call))
    19141914
    1915 (defun optimize-format-call (stream string obj args env)
    1916   (let* ((start (or (search "~/" string) (return-from optimize-format-call nil)))
     1915(defun count-known-format-args (string start end)
     1916  (declare (fixnum start end))
     1917  (loop with count = 0
     1918        do (setq start (position #\~ string :start start :end end))
     1919        when (null start)
     1920          do (return count)
     1921        unless (< (incf start) end)
     1922          do (return nil)
     1923        do (let ((ch (aref string start)))
     1924             (cond ((memq ch '(#\a #\A #\s #\S)) (incf count))
     1925                   ((memq ch '(#\~ #\% #\&)))
     1926                   (t (return nil)))
     1927             (incf start))))
     1928
     1929(defun optimize-format-call (stream string args env)
     1930  (let* ((start (or (search "~/" string)
     1931                    (return-from optimize-format-call nil)))
    19171932         (ipos (+ start 2))
    1918          (epos (or (position #\/ string :start ipos) (return-from optimize-format-call nil))))
     1933         (epos (or (position #\/ string :start ipos)
     1934                   (return-from optimize-format-call nil)))
     1935         (nargs (or (count-known-format-args string 0 start)
     1936                    (return-from optimize-format-call nil))))
    19191937    (when (and
    1920            ;; Must be first directive, since otherwise don't know how to split args.
    1921            (not (position #\~ string :end start))
     1938           ;; Must be able to split args
     1939           (< nargs (length args))
    19221940           ;; Don't deal with packages
    19231941           (not (position #\: string :start ipos :end epos)))
    19241942      (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
    19251943             (prev (and (< 0 start) (subseq string 0 start)))
     1944             (prev-args (subseq args 0 nargs))
    19261945             (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
     1946             (rest-args (nthcdr nargs args))
     1947             (obj (pop rest-args))
    19271948             (stream-var (gensym))
    1928              (body `(,@(and prev `((write-string ,prev ,stream-var)))
     1949             (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args)))
    19291950                       (,func ,stream-var ,obj nil nil)
    1930                        ,@(and rest `((format ,stream-var ,rest ,@args))))))
     1951                       ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil))))
    19311952        (cond ((null stream)
    19321953               `(with-output-to-string (,stream-var)
     
    19411962                  (if (or (null ,stream-var) (stringp ,stream-var))
    19421963                    (format-to-string ,stream-var ,string ,obj ,@args)
    1943                     (progn
    1944                       (when (eq ,stream-var t) (setq ,stream-var *standard-output*))
     1964                    (let ((,stream-var
     1965                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
     1966                      ;; For the purposes of body, it's ok to assume stream-var
     1967                      ;; is a stream. method dispatch will signal any errors
     1968                      ;; at runtime if it's not true...
     1969                      (declare (type stream ,stream-var))
    19451970                      ,@body)))))))))
    19461971
Note: See TracChangeset for help on using the changeset viewer.