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

.

Browse Source 
original commit: 0bd3f21d885bd04008db565949af48bbb3d525fb
This commit is contained in:
Matthew Flatt 2004-04-16 19:10:23 +00:00
parent 6f933fb41a
commit cf7206160f
9 changed files with 38 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/class.ss
View File

@ -20,5 +20,5 @@
is-a? subclass? implementation? interface-extension?
object-interface object-info object->vector
method-in-interface? interface->method-names class->interface class-info
exn:object? struct:exn:object make-exn:object
(struct exn:fail:object ())
make-primitive-class))

4
collects/mzlib/cm.ss
View File

@ -237,7 +237,9 @@
[default-handler (current-load/use-compiled)]
[modes (use-compiled-file-paths)])
(when (null? modes)
(error 'make-compilation-manager-... "empty use-compiled-file-paths list"))
(raise-mismatch-error 'make-compilation-manager-...
"empty use-compiled-file-paths list: "
modes))
(letrec ([compilation-manager-load-handler
(lambda (path mod-name)
(cond

4
collects/mzlib/cml.ss
View File

@ -39,9 +39,9 @@
(thread-dead-waitable th))
(define (current-time)
(current-seconds))
(current-inexact-milliseconds))
(define (time-evt t)
(make-alarm t))
(make-alarm-waitable t))
(provide/contract
(spawn ((-> any) . -> . thread?))

10
collects/mzlib/private/sigmatch.ss
View File

@ -42,7 +42,7 @@
(let ([v (hash-table-get table s
(lambda ()
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a value name `~a', required by ~a"
@ -56,7 +56,7 @@
(unless (symbol? v)
(let ([p (sig-path-name s path)])
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a contains `~a' as a sub-unit name, but ~a contains `~a' as a value name"
@ -72,7 +72,7 @@
(let ([v (hash-table-get table (car s)
(lambda ()
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
@ -86,7 +86,7 @@
(unless (hash-table? v)
(let ([p (sig-path-name (car s) path)])
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a contains `~a' as a value name, but ~a contains `~a' as a sub-unit name"
@ -108,7 +108,7 @@
(when v
(let ([p (sig-path-name k path)])
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a contains an extra ~a name `~a' that is not required by ~a"

2
collects/mzlib/private/sigutil.ss
View File

@ -792,7 +792,7 @@
(letrec ([check-sig
(lambda (sig use-sig)
(when use-sig
(with-handlers ([exn:unit?
(with-handlers ([exn:fail:unit?
(lambda (exn)
(syntax-error
#f expr

18
collects/mzlib/unit.ss
View File

@ -17,7 +17,7 @@
(define insp (current-inspector)) ; for named structures
(define-struct unit (num-imports exports go)) ; unit value
(define-struct (exn:unit exn) ()) ; run-time exception
(define-struct (exn:fail:unit exn:fail) ()) ; run-time exception
;; For units with inferred names, generate a struct that prints using the name:
(define (make-naming-constructor type name)
@ -333,13 +333,13 @@
(define (check-expected-interface tag unit num-imports exports)
(unless (unit? unit)
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit))
(current-continuation-marks))))
(unless (= num-imports (unit-num-imports unit))
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
tag
@ -352,7 +352,7 @@
(cond
[(null? l)
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format "compount-unit: unit for tag ~s has no ~s export"
tag ex))
@ -719,13 +719,13 @@
(define (check-unit u n)
(unless (unit? u)
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format "invoke-unit: result of unit expression was not a unit: ~e" u))
(current-continuation-marks))))
(unless (= (unit-num-imports u) n)
(raise
(make-exn:unit
(make-exn:fail:unit
(string->immutable-string
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
n (unit-num-imports u)))
@ -825,7 +825,7 @@
(values (mk #f) (mk #t))))
(provide (rename :unit unit) compound-unit invoke-unit unit?
exn:unit? struct:exn:unit make-exn:unit
(struct exn:fail:unit ())
define-values/invoke-unit
namespace-variable-bind/invoke-unit))
define-values/invoke-unit
namespace-variable-bind/invoke-unit))

2
collects/mzlib/unitsig.ss
View File

@ -171,7 +171,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define verify-linkage-signature-match
(let ([make-exn make-exn:unit]
(let ([make-exn make-exn:fail:unit]
[p-suffix (lambda (pos) (case pos [(1) 'st][(2) 'nd][(3) 'rd][else 'th]))])
(lambda (who tags units esigs isigs)
(for-each

6
collects/tests/mzscheme/unit.ss
View File

@ -56,9 +56,9 @@
(syntax-test #'(unit (import i) (export) (set! i 5)))
; Empty exports are syntactically ok::
(error-test #'(compound-unit (import) (link (A (0))) (export (A))) exn:unit?)
(error-test #'(compound-unit (import) (link (A (0 (B))) (B (0))) (export)) exn:unit?)
(error-test #'(compound-unit (import) (link (A (0)) (B (0))) (export (A x) (B))) exn:unit?)
(error-test #'(compound-unit (import) (link (A (0))) (export (A))) exn:fail:unit?)
(error-test #'(compound-unit (import) (link (A (0 (B))) (B (0))) (export)) exn:fail:unit?)
(error-test #'(compound-unit (import) (link (A (0)) (B (0))) (export (A x) (B))) exn:fail:unit?)
; Self-import is now allowed
; (syntax-test #'(compound-unit (import) (link (A (0 (A)))) (export)))

26
collects/tests/mzscheme/unitsig.ss
View File

@ -94,19 +94,19 @@
(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@)))))
(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var))))
(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open))))
(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?)
(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
(error-test #'(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:fail:unit?)
(syntax-test #'(compound-unit/sig (import) (link [b@ : b (0 5)]) (export)))
(syntax-test #'(compound-unit/sig (import) (link [b@ : b (0 ())]) (export)))
(syntax-test #'(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export)))