diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss index ff779af4b4..3123a4b4e0 100644 --- a/collects/mzlib/private/sigmatch.ss +++ b/collects/mzlib/private/sigmatch.ss @@ -33,8 +33,9 @@ (loop (format "~a:~a" s (car path)) (cdr path))))) - (define (check-sig-match table sig path exact? who src-context dest-context) - (and (vector? (car sig)) + (define (check-sig-match table sig path exact? who src-context dest-context wrapped? unwrap) + (and (wrapped? sig) + (vector? (unwrap sig)) (andmap (lambda (s) (cond @@ -98,9 +99,10 @@ (current-continuation-marks))))) (hash-table-put! table (car s) #f) (check-sig-match v (cdr s) (cons (car s) path) - exact? who src-context dest-context))))] + exact? who src-context dest-context + wrapped? unwrap))))] [else #f])) - (vector->list (car sig))) + (vector->list (unwrap sig))) (or (not exact?) (hash-table-for-each table @@ -120,7 +122,7 @@ (current-continuation-marks))))))) #t))) - (define (verify-signature-match who exact? dest-context dest-sig src-context src-sig) + (define (-verify-signature-match who exact? dest-context dest-sig src-context src-sig wrapped? unwrap) (unless (symbol? who) (raise-type-error 'verify-signature-match "symbol" who)) (unless (string? dest-context) @@ -130,10 +132,21 @@ (let ([src-table (make-hash-table)]) (unless (hash-sig src-sig src-table) - (raise-type-error 'verify-signature-match "signature" src-sig)) + (raise-type-error 'verify-signature-match "exploded signature" src-sig)) (unless (check-sig-match src-table dest-sig null - exact? who src-context dest-context) - (raise-type-error 'verify-signature-match "signature" dest-sig)))) + exact? who src-context dest-context + wrapped? unwrap) + (raise-type-error 'verify-signature-match "exploded signature" dest-sig)))) - (provide verify-signature-match)) + (define (alt-verify-signature-match who exact? dest-context dest-sig src-context src-sig) + (-verify-signature-match who exact? dest-context dest-sig src-context src-sig + pair? car)) + + (define (verify-signature-match who exact? dest-context dest-sig src-context src-sig) + (-verify-signature-match who exact? dest-context dest-sig src-context src-sig + values values)) + + (provide -verify-signature-match + verify-signature-match + alt-verify-signature-match)) diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 4b96c0131b..7330ab74b0 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -857,7 +857,7 @@ (syntax-error #f expr (exn-message exn)))]) - (verify-signature-match + (alt-verify-signature-match 'compound-unit/sig #f (format "signature ~s" (signature-src use-sig)) (explode-sig use-sig #f) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index 368182c8d6..2cc060e786 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -107,7 +107,7 @@ (syntax/loc expr (let ([tagx uexpr] ... . interned-vectors) - (verify-linkage-signature-match + (alt-verify-linkage-signature-match 'compound-unit/sig '(tag ...) (list tagx ...) @@ -140,7 +140,7 @@ (syntax/loc expr (let ([unt u]) - (verify-linkage-signature-match + (alt-verify-linkage-signature-match (quote invoke-unit/sig) (quote (invoke)) (list unt) @@ -173,10 +173,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define verify-linkage-signature-match + (define -verify-linkage-signature-match (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) + (lambda (who tags units esigs isigs wrapped? unwrap) (for-each (lambda (u tag) (unless (signed-unit? u) @@ -190,12 +190,13 @@ units tags) (for-each (lambda (u tag esig) - (verify-signature-match + (-verify-signature-match who #f (format "specified export signature for ~a" tag) esig (format "export signature for actual ~a sub-unit" tag) - (signed-unit-exports u))) + (signed-unit-exports u) + wrapped? unwrap)) units tags esigs) (for-each (lambda (u tag isig) @@ -216,7 +217,7 @@ (unless (null? isig) (let ([expected (car expecteds)] [provided (car isig)]) - (verify-signature-match + (-verify-signature-match who #t (format "~a unit's ~s~s import (which is ~a)" tag pos (p-suffix pos) @@ -226,10 +227,19 @@ tag pos (p-suffix pos) (car provided)) - (cdr provided)) + (cdr provided) + wrapped? unwrap) (loop (cdr isig) (cdr expecteds) (add1 pos)))))) units tags isigs)))) + (define verify-linkage-signature-match + (lambda (who tags units esigs isigs) + (-verify-linkage-signature-match who tags units esigs isigs values values))) + + (define alt-verify-linkage-signature-match + (lambda (who tags units esigs isigs) + (-verify-linkage-signature-match who tags units esigs isigs pair? car))) + (define-syntax signature->symbols (lambda (stx) (syntax-case stx () @@ -287,7 +297,7 @@ (dv/iu ex-flattened (let ([unit-var unite]) - (verify-linkage-signature-match + (alt-verify-linkage-signature-match 'formname '(invoke) (list unit-var) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss index 93aaeb9bb1..32ffc8a0b5 100644 --- a/collects/tests/mzscheme/unitsig.ss +++ b/collects/tests/mzscheme/unitsig.ss @@ -680,6 +680,17 @@ (moot x (list x i:y i:z)))) ;; -------------------------------------------------- - + +(let () + (define-signature s^ (x)) + (test (void) + verify-linkage-signature-match 'where + (list 'tag) + (list (unit/sig s^ (import) (define x 1))) + (list (signature->symbols s^)) + (list (list)))) + +;; -------------------------------------------------- + (report-errs) diff --git a/src/mzscheme/src/renumber.ss b/src/mzscheme/src/renumber.ss new file mode 100644 index 0000000000..3b18a67e47 --- /dev/null +++ b/src/mzscheme/src/renumber.ss @@ -0,0 +1,35 @@ + +(define filename "stypes.h") + +(define lines + (with-input-from-file filename + (lambda () + (let loop () + (let ([l (read-line)]) + (if (eof-object? l) + null + (cons l (loop)))))))) + +(define n 0) + +(with-output-to-file filename + (lambda () + (for-each + (lambda (l) + (cond + [(regexp-match #rx"^( +[a-z_A-Z][a-z_A-Z0-9]*,) *(?:/[*] [0-9]* [*]/)? *$" l) + => (lambda (m) + (let ([s (cadr m)]) + (printf "~a~a~n" + s + (format "~a/* ~a */" + (make-string (max 0 (- 40 (string-length s))) #\space) + n))) + (set! n (add1 n)))] + [(regexp-match #rx"^ +[a-zA-Z_][a-z_A-Z0-9]*," l) + (set! n (add1 n)) + (printf "~a~n" l)] + [else + (printf "~a~n" l)])) + lines)) + 'truncate)