Changeset 15580 in project for chicken/trunk


Ignore:
Timestamp:
08/27/09 13:27:14 (10 years ago)
Author:
felix winkelmann
Message:

moved internally used compiler syntax into separate unit

Location:
chicken/trunk
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken.scm

    r15555 r15580  
    2727
    2828(declare
    29   (uses chicken-syntax srfi-1 srfi-4 utils files support compiler optimizer scrutinizer driver
    30         platform backend srfi-69)
     29  (uses chicken-syntax srfi-1 srfi-4 utils files support
     30        compiler optimizer compiler-syntax scrutinizer driver platform backend
     31        srfi-69)
    3132  (compile-syntax) )                   
    3233
  • chicken/trunk/data-structures.scm

    r15527 r15580  
    274274;;; Alists:
    275275
    276 (define (alist-update! x y lst . cmp)
    277   (let* ([cmp (if (pair? cmp) (car cmp) eqv?)]
    278          [aq (cond [(eq? eq? cmp) assq]
     276(define (alist-update! x y lst #!optional (cmp eqv?))
     277  (let* ([aq (cond [(eq? eq? cmp) assq]
    279278                   [(eq? eqv? cmp) assv]
    280279                   [(eq? equal? cmp) assoc]
  • chicken/trunk/distribution/manifest

    r15543 r15580  
    6464lolevel.c
    6565optimizer.c
     66compiler-syntax.c
    6667scrutinizer.c
    6768regex.c
     
    179180lolevel.scm
    180181optimizer.scm
     182compiler-syntax.scm
    181183scrutinizer.scm
    182184regex.scm
  • chicken/trunk/optimizer.scm

    r15543 r15580  
    17781778                (debugging 'p "moving liftables to toplevel...")
    17791779                (reconstruct! ls extra) ) ) ) ) ) ) ) )
    1780 
    1781 
    1782 ;;; Compiler macros (that operate in the expansion phase)
    1783 
    1784 (define compiler-syntax-statistics '())
    1785 
    1786 (set! ##sys#compiler-syntax-hook
    1787   (lambda (name result)
    1788     (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
    1789       (set! compiler-syntax-statistics
    1790         (alist-update! name (add1 a) compiler-syntax-statistics)))))
    1791 
    1792 (define (r-c-s names transformer #!optional (se '()))
    1793   (let ((t (cons (##sys#er-transformer transformer) se)))
    1794     (for-each
    1795      (lambda (name)
    1796        (##sys#put! name '##compiler#compiler-syntax t) )
    1797      (if (symbol? names) (list names) names) ) ) )
    1798 
    1799 (r-c-s
    1800  '(for-each ##sys#for-each #%for-each)
    1801  (lambda (x r c)
    1802    (let ((%let (r 'let))
    1803          (%if (r 'if))
    1804          (%loop (r 'loop))
    1805          (%lst (r 'lst))
    1806          (%begin (r 'begin))
    1807          (%pair? (r 'pair?)))
    1808      (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus
    1809               (= 3 (length x)))                  ; intrinsic marks) isn't set up yet
    1810          `(,%let ,%loop ((,%lst ,(caddr x)))
    1811                  (,%if (,%pair? ,%lst)
    1812                        (,%begin
    1813                         (,(cadr x) (##sys#slot ,%lst 0))
    1814                         (##core#app ,%loop (##sys#slot ,%lst 1))) ) )
    1815          x)))
    1816  `((pair? . ,(##sys#primitive-alias 'pair?))))
    1817 
    1818 (r-c-s
    1819  '(o #%o)
    1820  (lambda (x r c)
    1821    (if (and (fx> (length x) 1)
    1822             (memq 'o extended-bindings) )
    1823        (let ((%tmp (r 'tmp)))
    1824          `(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x))))
    1825        x)))
    1826 
    1827 (let ((env `((display . ,(##sys#primitive-alias 'display)) ;XXX clean this up
    1828              (write . ,(##sys#primitive-alias 'write))
    1829              (fprintf . ,(##sys#primitive-alias 'fprintf))
    1830              (number->string . ,(##sys#primitive-alias 'number->string))
    1831              (write-char . ,(##sys#primitive-alias 'write-char))
    1832              (open-output-string . ,(##sys#primitive-alias 'open-output-string))
    1833              (get-output-string . ,(##sys#primitive-alias 'get-output-string)) ) ) )
    1834   (r-c-s
    1835    '(sprintf #%sprintf format #%format)
    1836    (lambda (x r c)
    1837      (let* ((out (gensym 'out))
    1838             (code (compile-format-string
    1839                    (if (memq (car x) '(sprintf #%sprintf))
    1840                        'sprintf
    1841                        'format)
    1842                    out
    1843                    x
    1844                    (cdr x)
    1845                    r c)))
    1846        (if code
    1847            `(,(r 'let) ((,out (,(r 'open-output-string))))
    1848              ,code
    1849              (,(r 'get-output-string) ,out))
    1850            x)))
    1851    env)
    1852   (r-c-s
    1853    '(fprintf #%fprintf)
    1854    (lambda (x r c)
    1855      (if (>= (length x) 3)
    1856          (let ((code (compile-format-string
    1857                       'fprintf (cadr x)
    1858                       x (cddr x)
    1859                       r c)))
    1860            (if code
    1861                code
    1862                x))
    1863          x))
    1864    env)
    1865   (r-c-s
    1866    '(printf #%printf)
    1867    (lambda (x r c)
    1868      (let ((code (compile-format-string
    1869                   'printf '##sys#standard-output
    1870                   x (cdr x)
    1871                   r c)))
    1872        (if code
    1873            code
    1874            x)))
    1875    env))
    1876 
    1877 (define (compile-format-string func out x args r c)
    1878   (call/cc
    1879    (lambda (return)
    1880      (and (>= (length args) 1)
    1881           (memq func extended-bindings) ; s.a.
    1882           (or (string? (car args))
    1883               (and (list? (car args))
    1884                    (c (r 'quote) (caar args))
    1885                    (string? (cadar args))))
    1886           (let ((fstr (if (string? (car args)) (car args) (cadar args)))
    1887                 (args (cdr args)))
    1888             (define (fail ret? msg . args)
    1889               (let ((ln (get-line x)))
    1890                 (compiler-warning
    1891                  'syntax
    1892                  "(~a) in format string ~s~a, ~?"
    1893                  func fstr
    1894                  (if ln (sprintf " in line ~a" ln) "")
    1895                  msg args) )
    1896               (when ret? (return #f)))
    1897             (let ((code '())
    1898                   (index 0)
    1899                   (len (string-length fstr))
    1900                   (%display (r 'display))
    1901                   (%write (r 'write))
    1902                   (%write-char (r 'write-char))
    1903                   (%out (r 'out))
    1904                   (%fprintf (r 'fprintf))
    1905                   (%let (r 'let))
    1906                   (%number->string (r 'number->string)))
    1907               (define (fetch)
    1908                 (let ((c (string-ref fstr index)))
    1909                   (set! index (fx+ index 1))
    1910                   c) )
    1911               (define (next)
    1912                 (if (null? args)
    1913                     (fail #t "too few arguments to formatted output procedure")
    1914                     (let ((x (car args)))
    1915                       (set! args (cdr args))
    1916                       x) ) )
    1917               (define (endchunk chunk)
    1918                 (when (pair? chunk)
    1919                   (push
    1920                    (if (= 1 (length chunk))
    1921                        `(,%write-char ,(car chunk) ,%out)
    1922                        `(,%display ,(reverse-list->string chunk) ,%out)))))
    1923               (define (push exp)
    1924                 (set! code (cons exp code)))
    1925               (let loop ((chunk '()))
    1926                 (cond ((>= index len)
    1927                        (unless (null? args)
    1928                          (fail #f "too many arguments to formatted output procedure"))
    1929                        (endchunk chunk)
    1930                        `(,%let ((,%out ,out))
    1931                                ,@(reverse code)))
    1932                       (else
    1933                        (let ((c (fetch)))
    1934                          (if (eq? c #\~)
    1935                              (let ((dchar (fetch)))
    1936                                (endchunk chunk)
    1937                                (case (char-upcase dchar)
    1938                                  ((#\S) (push `(,%write ,(next) ,%out)))
    1939                                  ((#\A) (push `(,%display ,(next) ,%out)))
    1940                                  ((#\C) (push `(,%write-char ,(next) ,%out)))
    1941                                  ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
    1942                                  ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
    1943                                  ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
    1944                                  ((#\!) (push `(##sys#flush-output ,%out)))
    1945                                  ((#\?)
    1946                                   (let* ([fstr (next)]
    1947                                          [lst (next)] )
    1948                                     (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
    1949                                  ((#\~) (push `(,write-char #\~ ,%out)))
    1950                                  ((#\% #\N) (push `(,%write-char #\newline ,%out)))
    1951                                  (else
    1952                                   (if (char-whitespace? dchar)
    1953                                       (let skip ((c (fetch)))
    1954                                         (if (char-whitespace? c)
    1955                                             (skip (fetch))
    1956                                             (set! index (sub1 index))))
    1957                                       (fail #t "illegal format-string character `~c'" dchar) ) ) )
    1958                                (loop '()) )
    1959                              (loop (cons c chunk)))))))))))))
  • chicken/trunk/rules.make

    r15579 r15580  
    5151
    5252COMPILER_OBJECTS_1 = \
    53        chicken batch-driver compiler optimizer scrutinizer support \
     53       chicken batch-driver compiler optimizer compiler-syntax scrutinizer support \
    5454       c-platform c-backend
    5555COMPILER_OBJECTS        = $(COMPILER_OBJECTS_1:=$(O))
     
    580580          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
    581581          $(C_COMPILER_OUTPUT)
     582compiler-syntax$(O): compiler-syntax.c chicken.h $(CHICKEN_CONFIG_H)
     583        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     584          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
     585          $(C_COMPILER_OUTPUT)
    582586scrutinizer$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
    583587        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    624628          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
    625629optimizer-static$(O): optimizer.c chicken.h $(CHICKEN_CONFIG_H)
     630        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     631          $(C_COMPILER_STATIC_OPTIONS) \
     632          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
     633compiler-syntax-static$(O): compiler-syntax.c chicken.h $(CHICKEN_CONFIG_H)
    626634        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
    627635          $(C_COMPILER_STATIC_OPTIONS) \
     
    11791187          $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    11801188        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
     1189compiler-syntax.c: $(SRCDIR)compiler-syntax.scm $(SRCDIR)compiler-namespace.scm \
     1190          $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
     1191        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    11811192scrutinizer.c: $(SRCDIR)scrutinizer.scm $(SRCDIR)compiler-namespace.scm \
    11821193          $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
     
    12281239        usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c \
    12291240        chicken-profile.c chicken-install.c chicken-uninstall.c chicken-status.c chicken-setup.c \
    1230         csc.c csi.c chicken.c batch-driver.c compiler.c optimizer.c scrutinizer.c support.c \
     1241        csc.c csi.c chicken.c batch-driver.c compiler.c optimizer.c  \
     1242        compiler-syntax.c scrutinizer.c support.c \
    12311243        c-platform.c c-backend.c chicken-bug.c $(IMPORT_LIBRARIES:=.import.c)
    12321244
     
    12761288          usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-bug.c \
    12771289          csc.c csi.c chicken-install.c chicken-setup.c chicken-uninstall.c chicken-status.c \
    1278           chicken.c batch-driver.c compiler.c optimizer.c scrutinizer.c support.c \
     1290          chicken.c batch-driver.c compiler.c optimizer.c compiler-syntax.c \
     1291          scrutinizer.c support.c \
    12791292          c-platform.c c-backend.c chicken-boot$(EXE) setup-api.c setup-download.c \
    12801293          $(IMPORT_LIBRARIES:=.import.c)
  • chicken/trunk/tests/runtests.sh

    r15543 r15580  
    190190$compile -e embedded2.scm
    191191./a.out
     192
     193#echo "======================================== regex benchmarks ..."
     194
     195#cd ../benchmarks/regex
     196#../../csi -bnq -include-path ../.. benchmark.scm
     197#cd ${TEST_DIR}
    192198
    193199echo "======================================== benchmarks ..."
Note: See TracChangeset for help on using the changeset viewer.