From b7bb1fa2e540c895410767c0dcf451b6651b1884 Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Mon, 4 Aug 2003 07:31:33 +0000
Subject: [PATCH] Subject: Extend type<->sexp conversion to variable type

type->sexp was not capable of converting the variable type to a
sexp. This caused problems if the module system wanted to tell the
user that the types of exported bindings did not match:

config> (define-structure foo (export (bar :syntax)) (open scheme) (begin (define bar 1)))
; no values returned
config> ,user
> ,open foo

Error: exception
       wrong-type-argument
       (checked-record-ref '(variable #{Type :value #f #f}) '#{Record-type 14 meta-type} 1)

I've now extended TYPE->SEXP by a check for the variable type and let
it produce a list with 'VARIABLE as first and the actual type as
second element. Likewise, I extended SEXP->TYPE to produce a variable
type if 'VARIABEL is the first element of a list.

This seems to work but a second look by someone who really understands
the type system would be appreciated.

(Merge from s48 rev 423)
---
 scheme/bcomp/mtype.scm | 30 +++++++++++++++++-------------
 1 file changed, 17 insertions(+), 13 deletions(-)

diff --git a/scheme/bcomp/mtype.scm b/scheme/bcomp/mtype.scm
index 2354cf6..d878d3d 100644
--- a/scheme/bcomp/mtype.scm
+++ b/scheme/bcomp/mtype.scm
@@ -1,4 +1,4 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
 
 ; Type lattice.
 ; Sorry this is so hairy, but before it was written, type checking 
@@ -619,6 +619,8 @@
 	      (reduce join-type (car l) (cdr l))))
 	   ((mask->type)
 	    (mask->type (cadr x)))
+           ((variable)
+            (variable-type (sexp->type (cadr x) r?)))
 	   (else (error "unrecognized type" x))))
 	(else (error "unrecognized type" x))))
 
@@ -641,18 +643,20 @@
 ; Convert type to S-expression
 
 (define (type->sexp t r?)
-  (if (> (bitwise-and (type-mask t) mask/&rest) 0)
-      (if (same-type? t any-values-type)
-	  ':values
-	  `(some-values ,@(rail-type->sexp t r?)))
-      (let ((j (disjoin-type t)))
-	(cond ((null? j) ':error)
-	      ((null? (cdr j))
-	       (atomic-type->sexp (car j) r?))
-	      (else
-	       `(join ,@(map (lambda (t)
-			       (atomic-type->sexp t r?))
-			     j)))))))
+  (if (variable-type? t)
+      `(variable ,(type->sexp (variable-value-type t) r?))
+      (if (> (bitwise-and (type-mask t) mask/&rest) 0)
+          (if (same-type? t any-values-type)
+              ':values
+              `(some-values ,@(rail-type->sexp t r?)))
+          (let ((j (disjoin-type t)))
+            (cond ((null? j) ':error)
+                  ((null? (cdr j))
+                   (atomic-type->sexp (car j) r?))
+                  (else
+                   `(join ,@(map (lambda (t)
+                                   (atomic-type->sexp t r?))
+                                 j))))))))
 	 
 (define (atomic-type->sexp t r?)
   (let ((m (type-mask t)))