Changeset 15053 in project for chicken


Ignore:
Timestamp:
06/24/09 12:07:52 (10 years ago)
Author:
felix winkelmann
Message:

format-string compiler macros cleanup and tests

Location:
chicken/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/batch-driver.scm

    r15037 r15053  
    4646  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    4747  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    48   broken-constant-nodes inline-substitutions-enabled
     48  broken-constant-nodes inline-substitutions-enabled compiler-syntax-statistics
    4949  emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
    5050  direct-call-ids foreign-type-table first-analysis emit-closure-info
     
    486486                         '((##core#undefined))) ] )
    487487
     488             (when (and (debugging 'x "applied compiler syntax:")
     489                        (pair? compiler-syntax-statistics))
     490               (for-each
     491                (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
     492                compiler-syntax-statistics))
    488493             (when (debugging '|N| "real name table:")
    489494               (display-real-name-table) )
  • chicken/trunk/compiler.scm

    r15038 r15053  
    12591259  (walk
    12601260   `(,(macro-alias 'begin '())
    1261       ,@(let ([p (reverse pending-canonicalizations)])
    1262           (set! pending-canonicalizations '())
    1263           p)
    1264       ,(begin
    1265          (set! extended-bindings (append internal-bindings extended-bindings))
    1266          exp) )
     1261     ,@(let ([p (reverse pending-canonicalizations)])
     1262         (set! pending-canonicalizations '())
     1263         p)
     1264     ,(begin
     1265        (set! extended-bindings (append internal-bindings extended-bindings))
     1266        exp) )
    12671267   '() (##sys#current-environment)
    12681268   #f) )
  • chicken/trunk/manual/Modules and macros

    r15038 r15053  
    4444in allowing the ellipsis identifier to be user-defined by passing it as the first
    4545argument to the {{syntax-rules}} form.
     46
     47The effect of destructively modifying the s-expression passed to a
     48transformer procedure is undefined.
    4649
    4750
  • chicken/trunk/optimizer.scm

    r15049 r15053  
    5959  topological-sort print-version print-usage initialize-analysis-database
    6060  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    61   units-used-by-default words-per-flonum rewrite inline-locally
     61  units-used-by-default words-per-flonum rewrite inline-locally compiler-syntax-statistics
    6262  parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6363  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    18071807;;; Compiler macros (that operate in the expansion phase)
    18081808
     1809(define compiler-syntax-statistics '())
     1810
    18091811(set! ##sys#compiler-syntax-hook
    18101812  (lambda (name result)
    1811     (debugging 'x "applying compiler syntax" name)))
     1813    (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
     1814      (set! compiler-syntax-statistics
     1815        (alist-update! name (add1 a) compiler-syntax-statistics)))))
    18121816
    18131817(define (r-c-s names transformer #!optional (se '()))
     
    18451849   '(sprintf #%sprintf format #%format)
    18461850   (lambda (x r c)
    1847      (if (and (>= (length x) 2)
    1848               (or (string? (cadr x))
    1849                   (and (list? (cadr x))
    1850                        (c (r 'quote) (caadr x))
    1851                        (string? (cadadr x)))))
    1852          (let* ((out (gensym 'out))
    1853                 (fstr (cadr x))
    1854                 (code (compile-format-string
    1855                        'sprintf out
    1856                        (if (string? fstr) fstr (cadr fstr))
    1857                        (cddr x)
    1858                        r)))
    1859            (if code
    1860                `(,(r 'let) ((,out (,(r 'open-output-string))))
    1861                  ,code
    1862                  (,(r 'get-output-string) ,out))
    1863                x))
    1864          x))
     1851     (let* ((out (gensym 'out))
     1852            (code (compile-format-string
     1853                   'sprintf out
     1854                   x
     1855                   (cdr x)
     1856                   r)))
     1857       (if code
     1858           `(,(r 'let) ((,out (,(r 'open-output-string))))
     1859             ,code
     1860             (,(r 'get-output-string) ,out))
     1861           x)))
    18651862   env)
    18661863  (r-c-s
    18671864   '(fprintf #%fprintf)
    18681865   (lambda (x r c)
    1869      (if (and (>= (length x) 3)
    1870               (or (string? (caddr x))
    1871                   (and (list? (caddr x))
    1872                        (c (r 'quote) (caaddr x))
    1873                        (string? (cadr (caddr x))))))
    1874          (let* ((fstr (caddr x))
    1875                 (code (compile-format-string
    1876                        'fprintf (cadr x)
    1877                        (if (string? fstr) fstr (cadr fstr))
    1878                        (cdddr x)
    1879                        r)))
     1866     (if (>= (length x) 3)
     1867         (let ((code (compile-format-string
     1868                      'fprintf (cadr x)
     1869                      x (cddr x)
     1870                      r)))
    18801871           (if code
    18811872               code
     
    18861877   '(printf #%printf)
    18871878   (lambda (x r c)
    1888      (if (and (>= (length x) 2)
    1889               (or (string? (cadr x))
    1890                   (and (list? (cadr x))
    1891                        (c (r 'quote) (caadr x))
    1892                        (string? (cadadr x)))))
    1893          (let* ((fstr (cadr x))
    1894                 (code (compile-format-string
    1895                        'printf '##sys#standard-output
    1896                        (if (string? fstr) fstr (cadr fstr))
    1897                        (cddr x)
    1898                        r)))
    1899            (if code
    1900                code
    1901                x))
    1902          x))
     1879     (let ((code (compile-format-string
     1880                  'printf '##sys#standard-output
     1881                  x (cdr x)
     1882                  r)))
     1883       (if code
     1884           code
     1885           x)))
    19031886   env))
    19041887
    1905 (define (compile-format-string func out fstr args r)
     1888(define (compile-format-string func out x args r)
    19061889  (call/cc
    19071890   (lambda (return)
    1908      (define (fail msg . args)
    1909        (warning
    1910         (sprintf "in format string ~s in call to `~a', ~?" fstr func msg args) )
    1911        (return #f))
    1912      (let ((code '())
    1913            (index 0)
    1914            (len (string-length fstr))
    1915            (%display (r 'display))
    1916            (%write (r 'write))
    1917            (%out (r 'out))
    1918            (%fprintf (r 'fprintf))
    1919            (%let (r 'let))
    1920            (%number->string (r 'number->string)))
    1921        (define (fetch)
    1922          (let ((c (string-ref fstr index)))
    1923            (set! index (fx+ index 1))
    1924            c) )
    1925        (define (next)
    1926          (if (null? args)
    1927              (fail "too few arguments to formatted output procedure")
    1928              (let ((x (car args)))
    1929                (set! args (cdr args))
    1930                x) ) )
    1931        (define (endchunk chunk)
    1932          (when (pair? chunk)
    1933            (push
    1934             (if (= 1 (length chunk))
    1935                 `(##sys#write-char-0 ,(car chunk) ,%out)
    1936                 `(,%display ,(reverse-list->string chunk) ,%out)))))
    1937        (define (push exp)
    1938          (set! code (cons exp code)))
    1939        (let loop ((chunk '()))
    1940          (cond ((>= index len)
    1941                 (endchunk chunk)
    1942                 `(,%let ((,%out ,out))
    1943                         ,@(reverse code)))
    1944                (else
    1945                 (let ((c (fetch)))
    1946                   (if (eq? c #\~)
    1947                       (let ((dchar (fetch)))
    1948                         (endchunk chunk)
    1949                         (case (char-upcase dchar)
    1950                           ((#\S) (push `(,%write ,(next) ,%out)))
    1951                           ((#\A) (push `(,%display ,(next) ,%out)))
    1952                           ((#\C) (push `(##sys#write-char-0 ,(next) ,%out)))
    1953                           ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
    1954                           ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
    1955                           ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
    1956                           ((#\!) (push `(##sys#flush-output ,%out)))
    1957                           ((#\?)
    1958                            (let* ([fstr (next)]
    1959                                   [lst (next)] )
    1960                              (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
    1961                           ((#\~) (push `(##sys#write-char-0 #\~ ,%out)))
    1962                           ((#\% #\N) (push `(##sys#write-char-0 #\newline ,%out)))
    1963                           (else
    1964                            (if (char-whitespace? dchar)
    1965                                (let skip ((c (fetch)))
    1966                                  (if (char-whitespace? c)
    1967                                      (skip (fetch))
    1968                                      (set! index (sub1 index))))
    1969                                (fail "illegal format-string character `~c'" dchar) ) ) )
    1970                         (loop '()) )
    1971                       (loop (cons c chunk)))))))))))
     1891     (and (>= (length args) 1)
     1892          (or (string? (car args))
     1893              (and (list? (car args))
     1894                   (c (r 'quote) (caar args))
     1895                   (string? (cadar args))))
     1896          (let ((fstr (if (string? (car args)) (car args) (cadar args)))
     1897                (args (cdr args)))
     1898            (define (fail ret? msg . args)
     1899              (let ((ln (get-line x)))
     1900                (compiler-warning
     1901                 'syntax
     1902                 "(~a) in format string ~s~a, ~?"
     1903                 func fstr
     1904                 (if ln (sprintf " in line ~a" ln) "")
     1905                 msg args) )
     1906              (when ret? (return #f)))
     1907            (let ((code '())
     1908                  (index 0)
     1909                  (len (string-length fstr))
     1910                  (%display (r 'display))
     1911                  (%write (r 'write))
     1912                  (%out (r 'out))
     1913                  (%fprintf (r 'fprintf))
     1914                  (%let (r 'let))
     1915                  (%number->string (r 'number->string)))
     1916              (define (fetch)
     1917                (let ((c (string-ref fstr index)))
     1918                  (set! index (fx+ index 1))
     1919                  c) )
     1920              (define (next)
     1921                (if (null? args)
     1922                    (fail #t "too few arguments to formatted output procedure")
     1923                    (let ((x (car args)))
     1924                      (set! args (cdr args))
     1925                      x) ) )
     1926              (define (endchunk chunk)
     1927                (when (pair? chunk)
     1928                  (push
     1929                   (if (= 1 (length chunk))
     1930                       `(##sys#write-char-0 ,(car chunk) ,%out)
     1931                       `(,%display ,(reverse-list->string chunk) ,%out)))))
     1932              (define (push exp)
     1933                (set! code (cons exp code)))
     1934              (let loop ((chunk '()))
     1935                (cond ((>= index len)
     1936                       (unless (null? args)
     1937                         (fail #f "too many arguments to formatted output procedure"))
     1938                       (endchunk chunk)
     1939                       `(,%let ((,%out ,out))
     1940                               ,@(reverse code)))
     1941                      (else
     1942                       (let ((c (fetch)))
     1943                         (if (eq? c #\~)
     1944                             (let ((dchar (fetch)))
     1945                               (endchunk chunk)
     1946                               (case (char-upcase dchar)
     1947                                 ((#\S) (push `(,%write ,(next) ,%out)))
     1948                                 ((#\A) (push `(,%display ,(next) ,%out)))
     1949                                 ((#\C) (push `(##sys#write-char-0 ,(next) ,%out)))
     1950                                 ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
     1951                                 ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
     1952                                 ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
     1953                                 ((#\!) (push `(##sys#flush-output ,%out)))
     1954                                 ((#\?)
     1955                                  (let* ([fstr (next)]
     1956                                         [lst (next)] )
     1957                                    (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
     1958                                 ((#\~) (push `(##sys#write-char-0 #\~ ,%out)))
     1959                                 ((#\% #\N) (push `(##sys#write-char-0 #\newline ,%out)))
     1960                                 (else
     1961                                  (if (char-whitespace? dchar)
     1962                                      (let skip ((c (fetch)))
     1963                                        (if (char-whitespace? c)
     1964                                            (skip (fetch))
     1965                                            (set! index (sub1 index))))
     1966                                      (fail #t "illegal format-string character `~c'" dchar) ) ) )
     1967                               (loop '()) )
     1968                             (loop (cons c chunk)))))))))))))
Note: See TracChangeset for help on using the changeset viewer.