Ignore:
Timestamp:
May 15, 2008, 2:35:27 PM (12 years ago)
Author:
gz
Message:

Propagate r9464 to here so doesn't get lost in back-merge

File:
1 edited

Legend:

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

    r9418 r9486  
    18591859
    18601860
     1861(define-compiler-macro write-string (&environment env &whole call
     1862                                                  string &optional (stream nil) &rest keys)
     1863  (if (nx-form-typep string 'simple-string env)
     1864    (if keys
     1865      `((lambda (string stream &key start end)
     1866          (write-simple-string string stream start end))
     1867        ,string ,stream ,@keys)
     1868      `(write-simple-string ,string ,stream 0 nil))
     1869    call))
     1870
     1871(define-compiler-macro format (&environment env &whole call stream string &rest args)
     1872  (if (stringp string)
     1873    (cond ((string-equal string "~a")
     1874           (destructuring-bind (object) args
     1875             (cond ((null stream)
     1876                    `(princ-to-string ,object))
     1877                   ((or (eq stream t) (nx-form-typep stream 'stream env))
     1878                    `(progn (princ ,object ,(and (neq stream t) stream)) nil))
     1879                   (t `(let ((stream ,stream)
     1880                             (object ,object))
     1881                         (if (or (null stream) (stringp stream))
     1882                           (format-to-string stream ,string object)
     1883                           (progn (princ object (and (neq stream t) stream)) nil)))))))
     1884          ((string-equal string "~s")
     1885           (destructuring-bind (object) args
     1886             (cond ((null stream)
     1887                    `(prin1-to-string ,object))
     1888                   ((or (eq stream t) (nx-form-typep stream 'stream env))
     1889                    `(progn (prin1 ,object ,(and (neq stream t) stream)) nil))
     1890                   (t `(let ((stream ,stream)
     1891                             (object ,object))
     1892                         (if (or (null stream) (stringp stream))
     1893                           (format-to-string stream ,string object)
     1894                           (progn (prin1 object (and (neq stream t) stream)) nil)))))))
     1895          ((and (null (position #\~ string)) (null args))
     1896           (cond ((null stream)
     1897                  string)
     1898                 ((or (eq stream t) (nx-form-typep stream 'stream env))
     1899                  `(progn (write-string ,string ,(and (neq stream t) stream)) nil))
     1900                 (t `(let ((stream ,stream))
     1901                       (if (or (null stream) (stringp stream))
     1902                         (format-to-string stream ,string)
     1903                         (progn (write-string ,string (and (neq stream t) stream)) nil))))))
     1904          ((optimize-format-call stream string args env))
     1905          (t call))
     1906    call))
     1907
     1908(defun count-known-format-args (string start end)
     1909  (declare (fixnum start end))
     1910  (loop with count = 0
     1911        do (setq start (position #\~ string :start start :end end))
     1912        when (null start)
     1913          do (return count)
     1914        unless (< (incf start) end)
     1915          do (return nil)
     1916        do (let ((ch (aref string start)))
     1917             (cond ((memq ch '(#\a #\A #\s #\S)) (incf count))
     1918                   ((memq ch '(#\~ #\% #\&)))
     1919                   (t (return nil)))
     1920             (incf start))))
     1921
     1922(defun optimize-format-call (stream string args env)
     1923  (let* ((start (or (search "~/" string)
     1924                    (return-from optimize-format-call nil)))
     1925         (ipos (+ start 2))
     1926         (epos (or (position #\/ string :start ipos)
     1927                   (return-from optimize-format-call nil)))
     1928         (nargs (or (count-known-format-args string 0 start)
     1929                    (return-from optimize-format-call nil))))
     1930    (when (and
     1931           ;; Must be able to split args
     1932           (< nargs (length args))
     1933           ;; Don't deal with packages
     1934           (not (position #\: string :start ipos :end epos)))
     1935      (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
     1936             (prev (and (< 0 start) (subseq string 0 start)))
     1937             (prev-args (subseq args 0 nargs))
     1938             (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
     1939             (rest-args (nthcdr nargs args))
     1940             (obj (pop rest-args))
     1941             (stream-var (gensym))
     1942             (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args)))
     1943                       (,func ,stream-var ,obj nil nil)
     1944                       ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil))))
     1945        (cond ((null stream)
     1946               `(with-output-to-string (,stream-var)
     1947                  (declare (type stream ,stream-var))
     1948                  ,@body))
     1949              ((or (eq stream t) (nx-form-typep stream 'stream env))
     1950               `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream)))
     1951                  (declare (type stream ,stream-var))
     1952                  ,@body))
     1953              (t
     1954               `(let ((,stream-var ,stream))
     1955                  (if (or (null ,stream-var) (stringp ,stream-var))
     1956                    (format-to-string ,stream-var ,string ,obj ,@args)
     1957                    (let ((,stream-var
     1958                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
     1959                      ;; For the purposes of body, it's ok to assume stream-var
     1960                      ;; is a stream. method dispatch will signal any errors
     1961                      ;; at runtime if it's not true...
     1962                      (declare (type stream ,stream-var))
     1963                      ,@body)))))))))
     1964
     1965
    18611966(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
    18621967  (if (and sub0 (null others))
Note: See TracChangeset for help on using the changeset viewer.