From bbe388656cf98aac8bcc0c093c77a33875b58074 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Mon, 17 Dec 2007 11:37:10 -0500
Subject: [PATCH] fixes bug 176756: define-condition-type does not work in repl

---
 scheme/last-revision       |  2 +-
 scheme/psyntax.expander.ss | 53 +++++++++++++++++++++++---------------
 2 files changed, 33 insertions(+), 22 deletions(-)

diff --git a/scheme/last-revision b/scheme/last-revision
index 3a20daa..28c4289 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1251
+1252
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index e102670..349dc1d 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -521,9 +521,13 @@
       (cond
         ((imported-label->binding x) =>
          (lambda (b) 
-           (if (and (pair? b) (eq? (car b) '$core-rtd)) 
-               (cons '$rtd (map bless (cdr b)))
-               b)))
+           (cond
+             [(and (pair? b) (eq? (car b) '$core-rtd))
+              (cons '$rtd (map bless (cdr b)))]
+             [(and (pair? b) (eq? (car b) 'global-rtd))
+              (let ([lib (cadr b)] [loc (cddr b)])
+                (cons '$rtd (symbol-value loc)))]
+             [else b])))
         ((assq x r) => cdr)
         (else '(displaced-lexical . #f)))))
 
@@ -816,7 +820,7 @@
                 (type (binding-type b)))
            (unless lab (stx-error e "unbound identifier"))
            (unless (and (eq? type '$rtd) (not (list? (binding-value b))))
-             (stx-error e "invalid type"))
+             (stx-error e "invalid type" b))
            (build-data no-source (binding-value b)))))))
 
   (define record-type-descriptor-transformer
@@ -828,7 +832,7 @@
                 (type (binding-type b)))
            (unless lab (stx-error e "unbound identifier"))
            (unless (and (eq? type '$rtd) (list? (binding-value b)))
-             (stx-error e "invalid type"))
+             (stx-error e "invalid type" b))
            (chi-expr (car (binding-value b)) r mr))))))
 
   (define record-constructor-descriptor-transformer
@@ -2809,21 +2813,28 @@
 
   (define set-global-macro-binding!
     (lambda (id loc b)
-      (let ([type
-             (case (binding-type b)
-               [(local-macro) 'global-macro]
-               [(local-macro!) 'global-macro!]
-               [else
-                (assertion-violation 'set-global-macro-binding!
-                  "BUG: invalid type" b)])]
-            [transformer (cadr b)]
-            [label (id->label id)]
-            [sym (id->sym id)])
-        (set-symbol-value! loc transformer)
-        (extend-library-subst! (interaction-library) sym label)
-        (extend-library-env! (interaction-library) label 
-          (cons* type (interaction-library) loc)))))
-  
+      (define (extend-macro! id loc type transformer)
+        (let ([sym (id->sym id)]
+              [label (id->label id)])
+          (set-symbol-value! loc transformer)
+          (extend-library-subst! (interaction-library) sym label)
+          (extend-library-env! (interaction-library) label 
+            (cons* type (interaction-library) loc))))
+      (case (binding-type b)
+        [(local-macro) 
+         (extend-macro! id loc 'global-macro (cadr b))]
+        [(local-macro!)
+         (extend-macro! id loc 'global-macro! (cadr b))]
+        [($rtd) 
+         (extend-macro! id loc 'global-rtd (cdr b))]
+        ; (extend-library-subst! (interaction-library) 
+        ;    (id->sym id) (id->label id))
+        ; (extend-library-env! (interaction-library) 
+        ;    (id->label id) b)]
+        [else
+         (assertion-violation 'set-global-macro-binding!
+           "BUG: invalid type" b)])))
+
   (define gen-global-macro-binding
     (lambda (id ctxt) (gen-global-var-binding id ctxt)))
   
@@ -2832,7 +2843,7 @@
       (let ((label (id->label id)))
         (let ((b (imported-label->binding label)))
           (case (binding-type b)
-            ((global global-macro global-macro!)
+            ((global global-macro global-macro! global-rtd)
              (let ((x (binding-value b)))
                (let ((lib (car x)) (loc (cdr x)))
                  (cond