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

fixed verify- ops to take old-format exploded signatures

Browse Source 
svn: r277
This commit is contained in:
Matthew Flatt 2005-06-30 16:40:13 +00:00
parent a17bb02f6d
commit 3d8c40afe4
5 changed files with 89 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))

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

@ -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)

28
collects/mzlib/unitsig.ss
View File

@ -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)

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

@ -681,5 +681,16 @@
;; --------------------------------------------------
(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)

35
src/mzscheme/src/renumber.ss Normal file
View File

@ -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)