summaryrefslogtreecommitdiffstats
path: root/mwdenote.scm
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-11-09 21:18:01 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commit926b1b647ac830660933a5e63eb52d4a2552e264 (patch)
treee25db5f6e1441d67f5d9af063432018ee20a5f51 /mwdenote.scm
parentb21cac3362022718634f7086964208b2eed8e897 (diff)
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-926b1b647ac830660933a5e63eb52d4a2552e264.tar.gz
slib-926b1b647ac830660933a5e63eb52d4a2552e264.zip
Import Debian changes 2c3-3debian/2c3-3
slib (2c3-3) frozen unstable; urgency=low * Fixes #16235. * Fixes #19943. * Fixes #20265. * Fixes #24917. * Fixes #27389. slib (2c3-2) frozen unstable; urgency=low * Re-uploaded for slink freeze. slib (2c3-1) unstable; urgency=low * New upstream release.
Diffstat (limited to 'mwdenote.scm')
-rw-r--r--mwdenote.scm50
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.