Import Upstream version 2c3upstream/2c3

1 files changed, 33 insertions, 17 deletions

diff --git a/mwdenote.scm b/mwdenote.scm
index c3fe5f3..def1d4d 100644
--- a/mwdenote.scm
+++ b/mwdenote.scm
@@ -42,6 +42,7 @@
     (set!          . (special set!))
     (begin         . (special begin))
     (define        . (special define))
+    (case          . (special case))               ;; @@ added wdc
     (let           . (special let))                ;; @@ added KAD
     (let*          . (special let*))               ;; @@    "
     (letrec        . (special letrec))             ;; @@    "
@@ -150,6 +151,9 @@
 (define mw:denote-of-:::
   (mw:syntax-lookup mw:standard-syntax-environment ':::))
 
+(define mw:denote-of-case
+  (mw:syntax-lookup mw:standard-syntax-environment 'case))       ;; @@ wdc
+
 (define mw:denote-of-let
   (mw:syntax-lookup mw:standard-syntax-environment 'let))        ;; @@ KenD
 
@@ -200,23 +204,35 @@
 
 ; Given a datum, strips the suffixes from any symbols that appear within
 ; the datum, trying not to copy any more of the datum than necessary.
-; Well, right now I'm just copying the datum, but I need to fix that!
-
-(define (mw:strip x)
-  (cond ((symbol? x)
-	 (let ((chars (memv mw:suffix-character
-			    (reverse (string->list
-				      (symbol->string x))))))
-	   (if chars
-	       (string->symbol
-		(list->string (reverse (cdr chars))))
-	       x)))
-	((pair? x)
-	 (cons (mw:strip (car x))
-	       (mw:strip (cdr x))))
-	((vector? x)
-	 (list->vector (map mw:strip (vector->list x))))
-	(else x)))
+
+; @@ rewrote to strip *all* suffixes -- wdc
+
+(define mw:strip
+  (letrec ((original-symbol
+            (lambda (x)
+              (let ((s (symbol->string x)))
+                (loop x s 0 (string-length s)))))
+           (loop
+            (lambda (sym s i n)
+              (cond ((= i n) sym)
+                    ((char=? (string-ref s i)
+                             mw:suffix-character)
+                     (string->symbol (substring s 0 i)))
+                    (else
+                     (loop sym s (+ i 1) n))))))
+    (lambda (x)
+      (cond ((symbol? x)
+             (original-symbol x))
+            ((pair? x)
+             (let ((y (mw:strip (car x)))
+                   (z (mw:strip (cdr x))))
+               (if (and (eq? y (car x))
+                        (eq? z (cdr x)))
+                   x
+                   (cons y z))))
+            ((vector? x)
+             (list->vector (map mw:strip (vector->list x))))
+            (else x)))))
 
 ; Given a list of identifiers, returns an alist that associates each
 ; identifier with a fresh identifier.