suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

check new optimizations, BEGIN_/END_ESCAPABLE

Browse Source 
svn: r3901
This commit is contained in:
Matthew Flatt 2006-07-31 11:40:07 +00:00
parent 0862b6de0d
commit ca2b00a9a3
6 changed files with 45 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/tests/mzscheme/benchmarks/common/nestedloop.sch
View File

@ -56,7 +56,8 @@
(loop5 (+ i5 1) result)
(loop6 (+ i6 1) (+ result 1)))))))))))))))
(display (time (loops 18))) (newline)
(display (time (func-loops 18))) (newline)
(define cnt 18)
(display (time (loops cnt))) (newline)
(display (time (func-loops cnt))) (newline)

8
collects/tests/mzscheme/benchmarks/common/nfa.sch
View File

@ -40,9 +40,11 @@
(time (let ((input (string-append (make-string 133 #\a) "bc")))
(let loop ((n 10000))
(unless (zero? n)
(recursive-nfa input)
(loop (- n 1))))))
(if (zero? n)
'done
(begin
(recursive-nfa input)
(loop (- n 1)))))))

2
collects/tests/mzscheme/benchmarks/common/tak.sch
View File

@ -20,6 +20,6 @@
;;; call: (tak 18 12 6)
(time (tak 18 12 (read)))
(time (tak 18 12 2))

5
collects/tests/mzscheme/optimize.ss
View File

@ -211,6 +211,11 @@
(un-exact (- (expt 2 30)) 'bitwise-not (sub1 (expt 2 30)))
(un-exact (- -1 (expt 2 32)) 'bitwise-not (expt 2 32))
(bin-exact #t 'char=? #\a #\a)
(bin-exact #t 'char=? #\u1034 #\u1034)
(bin-exact #f 'char=? #\a #\b)
(bin-exact #f 'char=? #\u1034 #\a)
(bin-exact 'a 'vector-ref #(a b c) 0)
(bin-exact 'b 'vector-ref #(a b c) 1)
(bin-exact 'c 'vector-ref #(a b c) 2)

12
collects/tests/mzscheme/stx.ss
View File

@ -265,15 +265,14 @@
(test 10 syntax-property (expand s) 'testing)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check tracking of primitive expanders
;; Check tracking of (formerly) primitive expanders
(test '(let) (tree-map syntax-e) (syntax-property (expand #'(let ([x 10]) x)) 'origin))
(test '(let let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
(test '(let*-values let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
(test '(let) (tree-map syntax-e) (syntax-property (expand #'(let loop ([x 10]) x)) 'origin))
(test '(letrec) (tree-map syntax-e) (syntax-property (expand #'(letrec ([x 10]) x)) 'origin))
(test '(let*-values) (tree-map syntax-e) (syntax-property (expand #'(let*-values ([(x) 10]) x)) 'origin))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Symbol Keys
(test null syntax-property-symbol-keys #'a)
@ -637,7 +636,7 @@
(lambda (expr)
(let ([e (expand expr)])
(syntax-case e ()
[(lv () beg)
[(lv (bind ...) beg)
(let ([db (syntax-property #'beg 'disappeared-binding)])
(syntax-case #'beg ()
[(bg e)
@ -652,7 +651,10 @@
(bound-identifier=? (car db) (car o))))
db o))]))])))])
(check-expr #'(let () (letrec-syntaxes+values ([(x) (lambda (stx) #'(quote y))]) () x)))
(check-expr #'(let () (define-syntax (x stx) #'(quote y)) x)))
(check-expr #'(let-values () (define-syntax (x stx) #'(quote y)) x))
(check-expr #'(let-values ([(y) 2]) (define-syntax (x stx) #'(quote y)) x))
(check-expr #'(let () (define-syntax (x stx) #'(quote y)) x))
(check-expr #'(let ([z 45]) (define-syntax (x stx) #'(quote y)) x)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; protected identifiers

24
collects/tests/mzscheme/thread.ss
View File

@ -1219,6 +1219,30 @@
(thread (lambda () (k null)))
(sync r-ch))))))))
;; --------------------
;; Check BEGIN_ESCAPABLE:
(let ([try
(lambda (break? kill?)
(let ([t (parameterize ([current-directory (or (current-load-relative-directory)
(current-directory))])
(thread (lambda ()
(with-handlers ([exn:break? void])
(let loop () (directory-list) (loop)))
(when kill?
(let loop () (sleep 0.01) (loop))))))])
(sleep SLEEP-TIME)
(when break?
(break-thread t)
(when kill?
(sleep SLEEP-TIME)))
(when kill?
(kill-thread t))
(thread-wait t)))])
(try #t #f)
(try #f #t)
(try #t #t))
; --------------------
(report-errs)