summaryrefslogtreecommitdiff
path: root/module/ice-9
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9')
-rw-r--r--module/ice-9/psyntax-pp.scm137
-rw-r--r--module/ice-9/psyntax.scm22
2 files changed, 11 insertions, 148 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index f82a14c0c..d1ad7fe27 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2682,83 +2682,6 @@
"source expression failed to match any pattern"
tmp-1)))))))
-(define do
- (make-syntax-transformer
- 'do
- 'macro
- (lambda (orig-x)
- (let ((tmp-1 orig-x))
- (let ((tmp ($sc-dispatch
- tmp-1
- '(_ #(each (any any . any)) (any . each-any) . each-any))))
- (if tmp
- (apply (lambda (var init step e0 e1 c)
- (let ((tmp-1 (map (lambda (v s)
- (let ((tmp-1 s))
- (let ((tmp ($sc-dispatch tmp-1 '())))
- (if tmp
- (apply (lambda () v) tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(any))))
- (if tmp
- (apply (lambda (e) e) tmp)
- (syntax-violation 'do "bad step expression" orig-x s)))))))
- var
- step)))
- (let ((tmp ($sc-dispatch tmp-1 'each-any)))
- (if tmp
- (apply (lambda (step)
- (let ((tmp e1))
- (let ((tmp-1 ($sc-dispatch tmp '())))
- (if tmp-1
- (apply (lambda ()
- (list '#(syntax-object let ((top)) (hygiene guile))
- '#(syntax-object doloop ((top)) (hygiene guile))
- (map list var init)
- (list '#(syntax-object if ((top)) (hygiene guile))
- (list '#(syntax-object not ((top)) (hygiene guile)) e0)
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (append
- c
- (list (cons '#(syntax-object
- doloop
- ((top))
- (hygiene guile))
- step)))))))
- tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
- (if tmp-1
- (apply (lambda (e1 e2)
- (list '#(syntax-object let ((top)) (hygiene guile))
- '#(syntax-object doloop ((top)) (hygiene guile))
- (map list var init)
- (list '#(syntax-object if ((top)) (hygiene guile))
- e0
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (cons e1 e2))
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (append
- c
- (list (cons '#(syntax-object
- doloop
- ((top))
- (hygiene guile))
- step)))))))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp)))))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))))
-
(define quasiquote
(make-syntax-transformer
'quasiquote
@@ -3163,66 +3086,6 @@
"expression not valid outside of quasiquote"
x))))
-(define case
- (make-syntax-transformer
- 'case
- 'macro
- (lambda (x)
- (let ((tmp-1 x))
- (let ((tmp ($sc-dispatch tmp-1 '(_ any any . each-any))))
- (if tmp
- (apply (lambda (e m1 m2)
- (let ((tmp (let f ((clause m1) (clauses m2))
- (if (null? clauses)
- (let ((tmp-1 clause))
- (let ((tmp ($sc-dispatch
- tmp-1
- '(#(free-id #(syntax-object else ((top)) (hygiene guile)))
- any
- .
- each-any))))
- (if tmp
- (apply (lambda (e1 e2)
- (cons '#(syntax-object begin ((top)) (hygiene guile)) (cons e1 e2)))
- tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(each-any any . each-any))))
- (if tmp
- (apply (lambda (k e1 e2)
- (list '#(syntax-object if ((top)) (hygiene guile))
- (list '#(syntax-object memv ((top)) (hygiene guile))
- '#(syntax-object t ((top)) (hygiene guile))
- (list '#(syntax-object quote ((top)) (hygiene guile))
- k))
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (cons e1 e2))))
- tmp)
- (syntax-violation 'case "bad clause" x clause))))))
- (let ((tmp (f (car clauses) (cdr clauses))))
- (let ((rest tmp))
- (let ((tmp clause))
- (let ((tmp ($sc-dispatch tmp '(each-any any . each-any))))
- (if tmp
- (apply (lambda (k e1 e2)
- (list '#(syntax-object if ((top)) (hygiene guile))
- (list '#(syntax-object memv ((top)) (hygiene guile))
- '#(syntax-object t ((top)) (hygiene guile))
- (list '#(syntax-object quote ((top)) (hygiene guile))
- k))
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (cons e1 e2))
- rest))
- tmp)
- (syntax-violation 'case "bad clause" x clause))))))))))
- (let ((body tmp))
- (list '#(syntax-object let ((top)) (hygiene guile))
- (list (list '#(syntax-object t ((top)) (hygiene guile)) e))
- body))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))))
-
(define make-variable-transformer
(lambda (proc)
(if (procedure? proc)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 760f8252f..2cc6386e9 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -608,22 +608,15 @@
;; syntax object wraps
- ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
- ;; <subst> ::= <shift> | <subs>
- ;; <subs> ::= #(<old name> <label> (<mark> ...))
- ;; <shift> ::= positive fixnum
+ ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+ ;; <subst> ::= shift | <subs>
+ ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+ ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons))
(define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr))
- (define-syntax subst-rename? (identifier-syntax vector?))
- (define-syntax-rule (rename-old x) (vector-ref x 0))
- (define-syntax-rule (rename-new x) (vector-ref x 1))
- (define-syntax-rule (rename-marks x) (vector-ref x 2))
- (define-syntax-rule (make-rename old new marks)
- (vector old new marks))
-
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
@@ -2903,6 +2896,9 @@
(binding (car bindings)))
#'(let (binding) body))))))))
+;; This definition of 'do' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm.
+#;
(define-syntax do
(lambda (orig-x)
(syntax-case orig-x ()
@@ -3076,6 +3072,10 @@
"expression not valid outside of quasiquote"
x)))
+;; This definition of 'case' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm. This version lacks
+;; R7RS-mandated support for '=>'.
+#;
(define-syntax case
(lambda (x)
(syntax-case x ()