Changeset 9464


Ignore:
Timestamp:
May 13, 2008, 1:56:14 PM (11 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:
4 edited

Legend:

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

    r9390 r9464  
    18661866
    18671867
     1868(define-compiler-macro write-string (&environment env &whole call
     1869                                                  string &optional (stream nil) &rest keys)
     1870  (if (nx-form-typep string 'simple-string env)
     1871    (if keys
     1872      `((lambda (string stream &key start end)
     1873          (write-simple-string string stream start end))
     1874        ,string ,stream ,@keys)
     1875      `(write-simple-string ,string ,stream 0 nil))
     1876    call))
     1877
     1878(define-compiler-macro format (&environment env &whole call stream string &rest args)
     1879  (if (stringp string)
     1880    (cond ((string-equal string "~a")
     1881           (destructuring-bind (object) args
     1882             (cond ((null stream)
     1883                    `(princ-to-string ,object))
     1884                   ((or (eq stream t) (nx-form-typep stream 'stream env))
     1885                    `(princ ,object ,(and (neq stream t) stream)))
     1886                   (t `(let ((stream ,stream)
     1887                             (object ,object))
     1888                         (if (or (null stream) (stringp stream))
     1889                           (format-to-string stream ,string object)
     1890                           (princ object (and (neq stream t) stream))))))))
     1891          ((string-equal string "~s")
     1892           (destructuring-bind (object) args
     1893             (cond ((null stream)
     1894                    `(prin1-to-string ,object))
     1895                   ((or (eq stream t) (nx-form-typep stream 'stream env))
     1896                    `(prin1 ,object ,(and (neq stream t) stream)))
     1897                   (t `(let ((stream ,stream)
     1898                             (object ,object))
     1899                         (if (or (null stream) (stringp stream))
     1900                           (format-to-string stream ,string object)
     1901                           (prin1 object (and (neq stream t) stream))))))))
     1902          ((and (null (position #\~ string)) (null args))
     1903           (cond ((null stream)
     1904                  string)
     1905                 ((or (eq stream t) (nx-form-typep stream 'stream env))
     1906                  `(write-string ,string ,(and (neq stream t) stream)))
     1907                 (t `(let ((stream ,stream))
     1908                       (if (or (null stream) (stringp stream))
     1909                         (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)))
     1912          (t call))
     1913    call))
     1914
     1915(defun optimize-format-call (stream string obj args env)
     1916  (let* ((start (or (search "~/" string) (return-from optimize-format-call nil)))
     1917         (ipos (+ start 2))
     1918         (epos (or (position #\/ string :start ipos) (return-from optimize-format-call nil))))
     1919    (when (and
     1920           ;; Must be first directive, since otherwise don't know how to split args.
     1921           (not (position #\~ string :end start))
     1922           ;; Don't deal with packages
     1923           (not (position #\: string :start ipos :end epos)))
     1924      (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
     1925             (prev (and (< 0 start) (subseq string 0 start)))
     1926             (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
     1927             (stream-var (gensym))
     1928             (body `(,@(and prev `((write-string ,prev ,stream-var)))
     1929                       (,func ,stream-var ,obj nil nil)
     1930                       ,@(and rest `((format ,stream-var ,rest ,@args))))))
     1931        (cond ((null stream)
     1932               `(with-output-to-string (,stream-var)
     1933                  (declare (type stream ,stream-var))
     1934                  ,@body))
     1935              ((or (eq stream t) (nx-form-typep stream 'stream env))
     1936               `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream)))
     1937                  (declare (type stream ,stream-var))
     1938                  ,@body))
     1939              (t
     1940               `(let ((,stream-var ,stream))
     1941                  (if (or (null ,stream-var) (stringp ,stream-var))
     1942                    (format-to-string stream-var ,string ,obj ,@args)
     1943                    (progn
     1944                      (when (eq ,stream-var t) (setq ,stream-var *standard-output*))
     1945                      ,@body)))))))))
     1946
     1947
    18681948(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
    18691949  (if (and sub0 (null others))
  • branches/working-0711/ccl/level-1/l1-format.lisp

    r9362 r9464  
    6464; *format-control-string* and *format-length*, before returning.
    6565
    66 (defun sub-format (stream *format-index* *format-length* &aux (string *format-control-string*) char)
    67   (prog* ((length *format-length*) (i *format-index*) (lastpos i))
    68     (declare (fixnum i length lastpos))
     66(defun sub-format (stream *format-index* *format-length* &aux char)
     67  (prog* ((string (require-type *format-control-string* 'simple-string))
     68          (length *format-length*)
     69          (i *format-index*)
     70          (lastpos i))
     71    (declare (fixnum i length lastpos) (type simple-string string))
    6972    (go START)
    7073    EOF-ERROR
     
    7982        (let* ((limit (the fixnum (1- i))))
    8083          (unless (= limit lastpos)
    81             (write-string string stream :start  lastpos :end limit)))
     84            (write-simple-string string stream  lastpos limit)))
    8285        (let ((params nil) (fn) (colon nil) (atsign nil))
    8386          (block nil
  • branches/working-0711/ccl/level-1/l1-io.lisp

    r9408 r9464  
    9393        (stream-write-string stream string start end)))
    9494  string))
     95
     96(defun write-simple-string (string output-stream start end)
     97  "Write the characters of the subsequence of simple-string STRING bounded by START
     98and END to OUTPUT-STREAM."
     99  (let* ((stream (%real-print-stream output-stream))
     100         (string (the simple-string string))) ;; typecheck at high safety.
     101    (if (typep stream 'basic-stream)
     102      (let* ((ioblock (basic-stream-ioblock stream))
     103             (start (or start 0)))
     104        (with-ioblock-output-locked (ioblock)
     105          (if (and (eq start 0) (null end))
     106            (funcall (ioblock-write-simple-string-function ioblock)
     107                     ioblock string 0 (length string))
     108            (let* ((end (check-sequence-bounds string start end)))
     109              (funcall (ioblock-write-simple-string-function ioblock)
     110                       ioblock string start  (%i- end start))))))
     111      (if (and (not start) (not end))
     112        (stream-write-string stream string)
     113        (stream-write-string stream string start end)))
     114    string))
    95115
    96116(defun write-line (string &optional output-stream
  • branches/working-0711/ccl/lib/format.lisp

    r9364 r9464  
    336336        (if (functionp control-string)
    337337          (apply control-string stream format-arguments)
    338           (let ((*format-control-string* (ensure-simple-string control-string))
    339                 (*format-pprint* nil)
    340                 (*format-justification-semi* nil))
     338          (let* ((control-string (ensure-simple-string control-string))
     339                 (*format-control-string* control-string)
     340                 (*format-pprint* nil)
     341                 (*format-justification-semi* nil))
     342            (declare (type simple-string control-string))
    341343            (cond
    342344              ;; Try to avoid pprint overhead in this case.
     
    357359                 (do-sub-format stream))))))
    358360        nil))))
     361
     362(defun format-to-string (string control-string &rest format-arguments)
     363  (declare (dynamic-extent format-arguments))
     364  (if string
     365    (with-output-to-string (stream string)
     366      (apply #'format stream control-string format-arguments))
     367    (with-output-to-string (stream)
     368      (apply #'format stream control-string format-arguments))))
     369
    359370
    360371(defun do-sub-format (stream)
Note: See TracChangeset for help on using the changeset viewer.