fixed verify- ops to take old-format exploded signatures

svn: r277

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)
+  (define (check-sig-match table sig path exact? who src-context dest-context wrapped? unwrap)
-    (and (vector? (car sig))
+    (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)
+			       exact? who src-context dest-context
-	(raise-type-error 'verify-signature-match "signature" dest-sig))))
+			       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))

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)

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)

collects/tests/mzscheme/unitsig.ss

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

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)