aboutsummaryrefslogtreecommitdiffstats
path: root/mwdenote.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitfa3f23105ddcf07c5900de47f19af43d1db1b597 (patch)
treeb2c6cce6b97698098f50cbc78c23fdc0f8d401ab /mwdenote.scm
parentf24b9140d6f74804d5599ec225717d38ca443813 (diff)
downloadslib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz
slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip
Import Upstream version 2c3upstream/2c3
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.