.
original commit: 74267d720a902ce204564b1d6d9c5a2f0e064990
This commit is contained in:
Matthew Flatt
parent
36175660bd
commit
6d25b7ecde
|
|
@ -1,10 +1,9 @@
|
|||
|
||||
(if (not (defined? 'SECTION))
|
||||
(load "testing.ss"))
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'macrolib)
|
||||
|
||||
(require-library "macro.ss")
|
||||
(require (lib "etc.ss"))
|
||||
|
||||
(let ([u (letrec ([x x]) x)])
|
||||
(let ([l1
|
||||
|
|
@ -25,7 +24,7 @@
|
|||
[l2 (list u u u 1 1 2 1 1 2 3 5)])
|
||||
(test l1 'let-plus l2)))
|
||||
|
||||
(require-library "shared.ss")
|
||||
(require (lib "shared.ss"))
|
||||
|
||||
(test "((car . cdr) #(one two three four five six) #&box (list1 list2 list3 list4) #<weak-box> 3 3)"
|
||||
'shared
|
||||
|
|
@ -46,7 +45,7 @@
|
|||
(define x 7)
|
||||
(test 6 'local (local ((define x 6)) x))
|
||||
(test 7 'local x)
|
||||
(test 6 vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1)
|
||||
(test '... vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1)
|
||||
(test #t 'local (local [(define o (lambda (x) (if (zero? x) #f (e (sub1 x)))))
|
||||
(define e (lambda (x) (if (zero? x) #t (o (sub1 x)))))]
|
||||
(e 10)))
|
||||
|
|
@ -65,35 +64,33 @@
|
|||
(test 17 'local (local [(define-values (apple b) (values 12 17))] b))
|
||||
(test 4 'local (local [(define-struct cons (car cdr))] (cons-car (make-cons 4 5))))
|
||||
(test 40 'local (local [(define-struct (cons struct:exn) (car cdr))] (cons-car (make-cons "" (void) 40 50))))
|
||||
(syntax-test '(local))
|
||||
(syntax-test '(local . 1))
|
||||
(syntax-test '(local ()))
|
||||
(syntax-test '(local () . 1))
|
||||
(syntax-test '(local 1 1))
|
||||
(syntax-test '(local (1) 1))
|
||||
(syntax-test '(local (x) 1))
|
||||
(syntax-test '(local ((+ 1 2)) 1))
|
||||
(syntax-test '(local ((define x)) 1))
|
||||
(syntax-test '(local ((define x 4) (+ 1 2)) 1))
|
||||
(syntax-test '(local ((define x 4) (+ 1 2) (define y 10)) 1))
|
||||
(syntax-test '(local ((define (x 8) 4)) 1))
|
||||
(syntax-test '(local ((define (x . 8) 4)) 1))
|
||||
(syntax-test '(local ((define x 8 4)) 1))
|
||||
(syntax-test '(local ((define 1 8 4)) 1))
|
||||
(syntax-test '(let ([define 10]) (local ((define x 4)) 10)))
|
||||
(syntax-test '(let ([define-values 10]) (local ((define-values (x) 4)) 10)))
|
||||
(syntax-test '(let ([define-struct 10]) (local ((define-struct x ())) 10)))
|
||||
(syntax-test #'(local))
|
||||
(syntax-test #'(local . 1))
|
||||
(syntax-test #'(local ()))
|
||||
(syntax-test #'(local () . 1))
|
||||
(syntax-test #'(local 1 1))
|
||||
(syntax-test #'(local (1) 1))
|
||||
(syntax-test #'(local (x) 1))
|
||||
(syntax-test #'(local ((+ 1 2)) 1))
|
||||
(syntax-test #'(local ((define x)) 1))
|
||||
(syntax-test #'(local ((define x 4) (+ 1 2)) 1))
|
||||
(syntax-test #'(local ((define x 4) (+ 1 2) (define y 10)) 1))
|
||||
(syntax-test #'(local ((define (x 8) 4)) 1))
|
||||
(syntax-test #'(local ((define (x . 8) 4)) 1))
|
||||
(syntax-test #'(local ((define x 8 4)) 1))
|
||||
(syntax-test #'(local ((define 1 8 4)) 1))
|
||||
(syntax-test #'(let ([define 10]) (local ((define x 4)) 10)))
|
||||
(syntax-test #'(let ([define-values 10]) (local ((define-values (x) 4)) 10)))
|
||||
(syntax-test #'(let ([define-struct 10]) (local ((define-struct x ())) 10)))
|
||||
|
||||
(for-each syntax-test
|
||||
(list '(evcase)
|
||||
'(evcase 1 (a))
|
||||
'(evcase 1 (a b) a)
|
||||
'(evcase 1 (a . b) a)
|
||||
'(evcase 1 [else 5] [1 10])))
|
||||
(list #'(evcase)
|
||||
#'(evcase 1 (a))
|
||||
#'(evcase 1 (a b) a)
|
||||
#'(evcase 1 (a . b) a)
|
||||
#'(evcase 1 [else 5] [1 10])))
|
||||
(define => 17)
|
||||
(test (void) 'void-evcase (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1)))
|
||||
(define save-comp (compile-allow-cond-fallthrough))
|
||||
(compile-allow-cond-fallthrough #f)
|
||||
(test #t andmap (lambda (x) (= x 17))
|
||||
(list
|
||||
(evcase 3 [3 17])
|
||||
|
|
@ -104,92 +101,12 @@
|
|||
(evcase 3 [4 4] [2 10] [else 17])
|
||||
(let ([else 10]) (evcase 3 [4 4] [2 10] [else 15] [3 17]))
|
||||
(let ([else 3]) (evcase 3 [else 17] [2 14]))
|
||||
(with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1))
|
||||
(if (eq? (void) (evcase 1)) 17 'bad)
|
||||
(evcase 3 [3 =>])
|
||||
(evcase 3 [3 => 17])
|
||||
(let ([=> 12]) (evcase 3 [3 => 17]))
|
||||
(let ([=> 17]) (evcase 3 [3 =>]))))
|
||||
(compile-allow-cond-fallthrough save-comp)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require-library "invoke.ss")
|
||||
|
||||
(define make-z
|
||||
(lambda (x-val)
|
||||
(unit
|
||||
(import z)
|
||||
(export (x z) y)
|
||||
|
||||
(define x x-val)
|
||||
(define y (lambda () (- z x))))))
|
||||
|
||||
(define z1 (make-z 8))
|
||||
(define z2 (make-z 7))
|
||||
|
||||
(define m3
|
||||
(compound-unit
|
||||
(import)
|
||||
(link [Z1 (z1 (Z2 z))][Z2 (z2 (Z1 z))])
|
||||
(export [Z1 (y y1) (z x1)][Z2 (y y2) (z x2)])))
|
||||
|
||||
(define-values/invoke-unit (y1 x1 y2 x2) m3)
|
||||
(test '(-1 1 8 7) 'invoke-open-unit (list (y1) (y2) x1 x2))
|
||||
|
||||
; Linking environments
|
||||
|
||||
(when (defined? 'x)
|
||||
(undefine 'x))
|
||||
|
||||
(define (make--eval)
|
||||
(let ([n (make-namespace)])
|
||||
(lambda (e)
|
||||
(let ([orig (current-namespace)])
|
||||
(dynamic-wind
|
||||
(lambda () (current-namespace n))
|
||||
(lambda ()
|
||||
(require-library "invoke.ss")
|
||||
(eval e))
|
||||
(lambda () (current-namespace orig)))))))
|
||||
|
||||
(define u
|
||||
(unit
|
||||
(import)
|
||||
(export x)
|
||||
(define x 5)))
|
||||
(define e (make--eval))
|
||||
(e (list 'define-values/invoke-unit '(x) u #f))
|
||||
(test #f defined? 'x)
|
||||
(test #t e '(defined? 'x))
|
||||
|
||||
(define u2
|
||||
(let ([u u])
|
||||
(unit
|
||||
(import)
|
||||
(export)
|
||||
(global-define-values/invoke-unit (x) u #f))))
|
||||
(define e (make--eval))
|
||||
(e (list 'define-values/invoke-unit '() u2 #f))
|
||||
(test #f defined? 'x)
|
||||
(test #t e '(defined? 'x))
|
||||
|
||||
|
||||
; Export var from embedded unit:
|
||||
|
||||
(define-signature e ((unit w : (embedded-v))))
|
||||
(define-values/invoke-unit/sig (embedded-v)
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [E : e ((compound-unit/sig
|
||||
(import)
|
||||
(link [w : (embedded-v) ((unit/sig (embedded-v)
|
||||
(import)
|
||||
(define embedded-v 0)))])
|
||||
(export (unit w))))])
|
||||
(export (var ((E w) embedded-v)))))
|
||||
(test 0 'embedded-v embedded-v)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(report-errs)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
|
||||
(unless (defined? 'SECTION)
|
||||
(load-relative "testing.ss"))
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(SECTION 'pconvert)
|
||||
|
||||
(import (lib "unit.ss"))
|
||||
(import (lib "class.ss"))
|
||||
(import (lib "pconvert.ss"))
|
||||
(require (lib "unit.ss"))
|
||||
(require (lib "class.ss"))
|
||||
(require (lib "pconvert.ss"))
|
||||
|
||||
(constructor-style-printing #t)
|
||||
(quasi-read-style-printing #f)
|
||||
|
|
@ -348,10 +347,10 @@
|
|||
(test-not-shared #\a #\a)
|
||||
(test-not-shared 'x ''x)
|
||||
(test-shared (lambda (x) x) '(lambda (a1) ...))
|
||||
(test-shared (make-promise (lambda () 1)) '(delay ...))
|
||||
(test-shared (delay 1) '(delay ...))
|
||||
(test-shared (class object% ()) '(class ...))
|
||||
(test-shared (unit (import) (export)) '(unit ...))
|
||||
(test-shared (make-object (class object% () (sequence (super-init)))) '(make-object (class ...) ...))
|
||||
(test-shared (make-object (class object% (super-instantiate ()))) '(make-object (class ...) ...))
|
||||
|
||||
(test-shared "abc" "abc")
|
||||
(test-shared (list 1 2 3) '(list 1 2 3))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user