Changeset 15049 in project for chicken/trunk


Ignore:
Timestamp:
06/23/09 14:53:54 (10 years ago)
Author:
felix winkelmann
Message:

types.db fixes; optimizer defines compiler syntax for for-each and [sf]printf/format; scrutiny done on debugbuild, not via explicit make target

Location:
chicken/trunk
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/Makefile

    r14882 r15049  
    8080bench:
    8181        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
    82 scrutiny:
    83         $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) scrutiny
    8482endif
  • chicken/trunk/chicken-syntax.scm

    r15047 r15049  
    941941(##sys#extend-macro-environment
    942942 'cut
    943  `((apply . (##sys#primitive-alias 'apply)))
     943 `((apply . ,(##sys#primitive-alias 'apply)))
    944944 (##sys#er-transformer
    945945  (lambda (form r c)
  • chicken/trunk/csi.scm

    r13713 r15049  
    648648             (fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
    649649             (let ([code (integer->char x)])
    650                (when (fx< code #x10000) (fprintf out ", character ~S" code)) )
     650               (when (fx< x #x10000) (fprintf out ", character ~S" code)) )
    651651             (##sys#write-char-0 #\newline ##sys#standard-output) ]
    652652            [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
  • chicken/trunk/defaults.make

    r14940 r15049  
    282282CHICKEN_OPTIONS = -no-trace -optimize-level 2 -include-path . -include-path $(SRCDIR)
    283283ifdef DEBUGBUILD
    284 CHICKEN_OPTIONS += -feature debugbuild
     284CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db -debug x
    285285endif
    286286CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use
    287287CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    288288CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
    289 CHICKEN_SCRUTINY_OPTIONS = -types $(SRCDIR)types.db -analyze-only -scrutinize -ignore-repository
    290289CHICKEN_UNSAFE_OPTIONS = -unsafe -no-lambda-info
    291290CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
  • chicken/trunk/expand.scm

    r15047 r15049  
    323323                    ((and cs? (symbol? head2) (##sys#get head2 '##compiler#compiler-syntax)) =>
    324324                     (lambda (cs)
    325                        (dc "applying compiler syntax for `" head2 "' ...")
    326325                       (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
    327                          (if (eq? result exp)
    328                              (expand head exp head2)
    329                              (loop result)))))
     326                         (cond ((eq? result exp) (expand head exp head2))
     327                               (else
     328                                (when ##sys#compiler-syntax-hook
     329                                  (##sys#compiler-syntax-hook head result))
     330                                (loop result))))))
    330331                    [else (expand head exp head2)] ) )
    331332            (values exp #f) ) )
    332333      (values exp #f) ) ) )
    333334
     335(define ##sys#compiler-syntax-hook #f)
    334336(define ##sys#enable-runtime-macros #f)
    335337
  • chicken/trunk/optimizer.scm

    r15037 r15049  
    3131  compiler-arguments process-command-line perform-lambda-lifting!
    3232  default-standard-bindings default-extended-bindings
    33   foldable-bindings llist-length
     33  foldable-bindings llist-length r-c-s compile-format-string
    3434  installation-home decompose-lambda-list external-to-pointer
    3535  copy-node! variable-visible? mark-variable intrinsic?
     
    18031803                (debugging 'p "moving liftables to toplevel...")
    18041804                (reconstruct! ls extra) ) ) ) ) ) ) ) )
     1805
     1806
     1807;;; Compiler macros (that operate in the expansion phase)
     1808
     1809(set! ##sys#compiler-syntax-hook
     1810  (lambda (name result)
     1811    (debugging 'x "applying compiler syntax" name)))
     1812
     1813(define (r-c-s names transformer #!optional (se '()))
     1814  (let ((t (cons (##sys#er-transformer transformer) se)))
     1815    (for-each
     1816     (lambda (name)
     1817       (##sys#put! name '##compiler#compiler-syntax t) )
     1818     (if (symbol? names) (list names) names) ) ) )
     1819
     1820(r-c-s
     1821 '(for-each ##sys#for-each #%for-each)
     1822 (lambda (x r c)
     1823   (let ((%let (r 'let))
     1824         (%if (r 'if))
     1825         (%loop (r 'loop))
     1826         (%lst (r 'lst))
     1827         (%begin (r 'begin))
     1828         (%pair? (r 'pair?)))
     1829     (if (= 3 (length x))
     1830         `(,%let ,%loop ((,%lst ,(caddr x)))
     1831                 (,%if (,%pair? ,%lst)
     1832                       (,%begin
     1833                        (,(cadr x) (##sys#slot ,%lst 0))
     1834                        (##core#app ,%loop (##sys#slot ,%lst 1))) ) )
     1835         x)))
     1836 `((pair? . ,(##sys#primitive-alias 'pair?))))
     1837
     1838(let ((env `((display . ,(##sys#primitive-alias 'display)) ;XXX clean this up
     1839             (write . ,(##sys#primitive-alias 'write))
     1840             (fprintf . ,(##sys#primitive-alias 'fprintf))
     1841             (number->string . ,(##sys#primitive-alias 'number->string))
     1842             (open-output-string . ,(##sys#primitive-alias 'open-output-string))
     1843             (get-output-string . ,(##sys#primitive-alias 'get-output-string)) ) ) )
     1844  (r-c-s
     1845   '(sprintf #%sprintf format #%format)
     1846   (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))
     1865   env)
     1866  (r-c-s
     1867   '(fprintf #%fprintf)
     1868   (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)))
     1880           (if code
     1881               code
     1882               x))
     1883         x))
     1884   env)
     1885  (r-c-s
     1886   '(printf #%printf)
     1887   (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))
     1903   env))
     1904
     1905(define (compile-format-string func out fstr args r)
     1906  (call/cc
     1907   (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)))))))))))
  • chicken/trunk/rules.make

    r14940 r15049  
    12171217endif
    12181218
    1219 clean: scrutiny-clean
     1219clean:
    12201220        -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) chicken$(EXE) csi$(EXE) csc$(EXE) \
    12211221          chicken-profile$(EXE) csi-static$(EXE) \
     
    13041304        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
    13051305        $(CSI) -s cscbench.scm $(BENCHMARK_OPTIONS)
    1306 
    1307 
    1308 # scrutiny
    1309 
    1310 .PHONY: scrutiny scrutiny-clean
    1311 
    1312 scrutiny: $(SCRUTINIZED_LIBRARIES:=.scrutiny1) $(COMPILER_OBJECTS_1:=.scrutiny2)
    1313 
    1314 %.scrutiny1: $(SRCDIR)%.scm
    1315         $(CHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_LIBRARY_OPTIONS) 2>&1 | tee $@
    1316 
    1317 %.scrutiny2: $(SRCDIR)%.scm
    1318         $(CHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_COMPILER_OPTIONS) 2>&1 | tee $@
    1319 
    1320 scrutiny-clean:
    1321         $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) *.scrutiny1 *.scrutiny2
  • chicken/trunk/types.db

    r15001 r15049  
    246246(chicken-home (procedure chicken-home () string))
    247247(chicken-version (procedure chicken-version (#!optional *) string))
    248 (command-line-arguments (procedure command-line-arguments () list))
     248(command-line-arguments (procedure command-line-arguments (#!optional list) list))
    249249(condition-predicate (procedure condition-predicate (symbol) (procedure ((struct condition)) boolean)))
    250250(condition-property-accessor (procedure condition-property-accessor (symbol symbol #!optional *) (procedure ((struct condition)) *)))
     
    361361(print* (procedure print* (#!rest) undefined))
    362362(procedure-information (procedure procedure-information (procedure) *))
    363 (program-name (procedure program-name () string))
     363(program-name (procedure program-name (#!optional string) string))
    364364(promise? (procedure promise? (*) boolean))
    365365(put! (procedure put! (symbol symbol *) undefined))
     
    478478(randomize (procedure randomize (#!optional number) undefined))
    479479(read-byte (procedure read-byte (#!optional port) fixnum))
    480 (read-file (procedure read-file (#!optional port (procedure (port) *) fixnum) list))
     480(read-file (procedure read-file (#!optional (or port string) (procedure (port) *) fixnum) list))
    481481(read-line (procedure read-line (#!optional port fixnum) *))
    482 (read-lines (procedure read-lines (#!optional port fixnum) list))
     482(read-lines (procedure read-lines (#!optional (or port string) fixnum) list))
    483483(read-string (procedure read-string (#!optional * port) string))
    484484(read-string! (procedure read-string! (fixnum string #!optional port fixnum) fixnum))
     
    645645(create-session (procedure create-session () fixnum))
    646646(create-symbolic-link (procedure create-symbolic-link (string string) undefined))
    647 (current-directory (procedure current-directory () string))
     647(current-directory (procedure current-directory (#!optional string) string))
    648648(current-effective-group-id (procedure current-effective-group-id () fixnum))
    649649(current-effective-user-id (procedure current-effective-user-id () fixnum))
     
    10451045(string-skip (procedure string-skip (string * #!optional fixnum fixnum) fixnum))
    10461046(string-skip-right (procedure string-skip-right (string * #!optional fixnum fixnum) fixnum))
    1047 (string-suffix-ci? (procedure string-suffix-ci? (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
     1047(string-suffix-ci? (procedure string-suffix-ci? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
    10481048(string-suffix-length (procedure string-suffix-length (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
    10491049(string-suffix-length-ci (procedure string-suffix-length-ci (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
    1050 (string-suffix? (procedure string-suffix? (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
     1050(string-suffix? (procedure string-suffix? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
    10511051(string-tabulate (procedure string-tabulate ((procedure (fixnum) char) fixnum) string))
    10521052(string-take (procedure string-take (string fixnum) string))
Note: See TracChangeset for help on using the changeset viewer.