From 31a3316bf24c936a2d45e3e4aecffdd830c7c41f Mon Sep 17 00:00:00 2001
From: Daphne Preston-Kendal <git@dpk.io>
Date: Sat, 2 Nov 2024 11:01:54 +0100
Subject: [PATCH] Add `(rnrs syntax-case)`
---
lib/chibi/syntax-case.scm | 31 +++++++++---
lib/chibi/syntax-case.sld | 1 +
lib/rnrs/base.sld | 37 +++++++++++++-
lib/rnrs/conditions.sld | 101 ++++++++++++++++++++++++++++++++++++++
lib/rnrs/syntax-case.sld | 17 +++++++
5 files changed, 177 insertions(+), 10 deletions(-)
create mode 100644 lib/rnrs/conditions.sld
create mode 100644 lib/rnrs/syntax-case.sld
diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm
index f0b80d21..2a13187d 100644
--- a/lib/chibi/syntax-case.scm
+++ b/lib/chibi/syntax-case.scm
@@ -77,7 +77,7 @@
(define (make-pattern-variable pvar)
(lambda (expr)
- (error "reference to pattern variable outside syntax" pvar)))
+ (syntax-violation #f "reference to pattern variable outside syntax" pvar)))
(define (pattern-variable x)
(and-let*
@@ -163,7 +163,9 @@
((out envs)
(gen-template (car tmpl) (cons '() envs) ell? level)))
(if (null? (car envs))
- (error "too many ellipses following syntax template" (car tmpl)))
+ (syntax-violation 'syntax
+ "too many ellipses following syntax template"
+ (car tmpl)))
(values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
(,(rename 'cons) ,out ,(rename 'stx)))
,out* ,@(car envs))
@@ -180,7 +182,9 @@
(values `(,(rename 'list->vector) ,out) envs)))
((identifier? tmpl)
(cond ((ell? tmpl)
- (error "misplaced ellipsis in syntax template" tmpl))
+ (syntax-violation 'syntax
+ "misplaced ellipsis in syntax template"
+ tmpl))
((pattern-variable tmpl) =>
(lambda (binding)
(values (car binding)
@@ -199,7 +203,7 @@
(cond ((zero? level)
envs)
((null? envs)
- (error "too few ellipses following syntax template" id))
+ (syntax-violation #f "too few ellipses following syntax template" id))
(else
(let ((outer-envs (loop (- level 1) (cdr envs))))
(cond ((member x (car envs) bound-identifier=?)
@@ -214,7 +218,7 @@
(let ((expr (cadr expr))
(lit* (car (cddr expr)))
(clause* (reverse (cdr (cddr expr))))
- (error #'(error "syntax error" e)))
+ (error #`(syntax-violation #f "syntax error" e)))
#`(let ((e #,expr))
#,(if (null? clause*)
error
@@ -294,7 +298,7 @@
(fail)))
vars))
((ellipsis-identifier? pattern)
- (error "misplaced ellipsis" pattern))
+ (syntax-violation #f "misplaced ellipsis" pattern))
((free-identifier=? pattern #'_)
(values (lambda (k)
(k))
@@ -370,8 +374,19 @@
#'(syntax-case (list e0 ...) ()
((p ...) (let () e1 e2 ...)))))))
-(define (syntax-violation who message . form*)
- (apply error message form*))
+(define (syntax-violation who message form . maybe-subform)
+ (raise (condition (make-syntax-violation form
+ (if (null? maybe-subform)
+ #f
+ (car maybe-subform)))
+ (cond (who => make-who-condition)
+ ((identifier? form)
+ (make-who-condition (syntax->datum form)))
+ ((and (pair? form)
+ (identifier? (car form)))
+ (make-who-condition (syntax->datum (car form))))
+ (else (condition)))
+ (make-message-condition message))))
(define-syntax define-current-ellipsis
(lambda (stx)
diff --git a/lib/chibi/syntax-case.sld b/lib/chibi/syntax-case.sld
index a12a7316..c96bc9fb 100644
--- a/lib/chibi/syntax-case.sld
+++ b/lib/chibi/syntax-case.sld
@@ -14,6 +14,7 @@
procedure-arity procedure-variadic?
procedure-variable-transformer?
make-variable-transformer)
+ (rnrs conditions)
(only (meta) environment)
(srfi 1)
(srfi 2)
diff --git a/lib/rnrs/base.sld b/lib/rnrs/base.sld
index d8347f83..bf1e80a7 100644
--- a/lib/rnrs/base.sld
+++ b/lib/rnrs/base.sld
@@ -190,12 +190,16 @@
vector-set!
vector?
zero?)
- (import (rename (scheme base)
- (error r7rs:error))
+ (import (except (scheme base)
+ define-syntax
+ let-syntax
+ letrec-syntax
+ syntax-rules)
(scheme cxr)
(scheme inexact)
(scheme complex)
(rnrs conditions)
+ (only (srfi 1) every)
(rename (srfi 141)
(euclidean-quotient div)
(euclidean-remainder mod)
@@ -203,9 +207,38 @@
(balanced-quotient div0)
(balanced-remainder mod0)
(balanced/ div0-and-mod0))
+ (rename (chibi syntax-case)
+ (splicing-let-syntax let-syntax)
+ (splicing-letrec-syntax letrec-syntax))
(except (chibi ast) error)
(chibi show))
+ (define-syntax syntax-rules
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (lit ...) ((k . p) t) ...)
+ (every identifier? #'(lit ... k ...))
+ #'(lambda (x)
+ (syntax-case x (lit ...)
+ ((_ . p) #'t) ...))))))
+
+ (define-syntax identifier-syntax
+ (lambda (x)
+ (syntax-case x (set!)
+ ((_ e)
+ #'(lambda (x)
+ (syntax-case x ()
+ (id (identifier? #'id) #'e)
+ ((_ x (... ...)) #'(e x (... ...))))))
+ ((_ (id exp1) ((set! var val) exp2))
+ (and (identifier? #'id) (identifier? #'var))
+ #'(make-variable-transformer
+ (lambda (x)
+ (syntax-case x (set!)
+ ((set! var val) #'exp2)
+ ((id x (... ...)) #'(exp1 x (... ...)))
+ (id (identifier? #'id) #'exp1))))))))
+
(define-syntax assert
(syntax-rules ()
((_ expr)
diff --git a/lib/rnrs/conditions.sld b/lib/rnrs/conditions.sld
new file mode 100644
index 00000000..4d34ecfb
--- /dev/null
+++ b/lib/rnrs/conditions.sld
@@ -0,0 +1,101 @@
+(library (rnrs conditions)
+ (export &condition
+ (rename make-compound-condition condition)
+ simple-conditions
+ condition-predicate
+ condition-accessor
+ (rename define-condition-type/constructor define-condition-type)
+
+ ;; 7.3 Standard condition types
+ &message
+ make-message-condition
+ message-condition?
+ condition-message
+
+ &warning
+ make-warning
+ warning?
+
+ &serious
+ make-serious-condition
+ serious-condition?
+
+ &error
+ make-error
+ error?
+
+ &violation
+ make-violation
+ violation?
+
+ &assertion
+ make-assertion-violation
+ assertion-violation?
+
+ &irritants
+ make-irritants-condition
+ irritants-condition?
+ condition-irritants
+
+ &who
+ make-who-condition
+ who-condition?
+ condition-who
+
+ &non-continuable
+ make-non-continuable-violation
+ non-continuable-violation?
+
+ &implementation-restriction
+ make-implementation-restriction-violation
+ implementation-restriction-violation?
+
+ &lexical
+ make-lexical-violation
+ lexical-violation?
+
+ &syntax
+ make-syntax-violation
+ syntax-violation?
+ syntax-violation-form
+ syntax-violation-subform
+
+ &undefined
+ make-undefined-violation
+ undefined-violation?)
+ (import (srfi 35 internal))
+
+ (define-condition-type/constructor &warning &condition
+ make-warning warning?)
+
+ (define-condition-type/constructor &violation &serious
+ make-violation violation?)
+
+ (define-condition-type/constructor &assertion &violation
+ make-assertion-violation assertion-violation?)
+
+ (define-condition-type/constructor &irritants &condition
+ make-irritants-condition irritants-condition?
+ (irritants condition-irritants))
+
+ (define-condition-type/constructor &who &condition
+ make-who-condition who-condition?
+ (who condition-who))
+
+ (define-condition-type/constructor &non-continuable &violation
+ make-non-continuable-violation non-continuable-violation?)
+
+ (define-condition-type/constructor &implementation-restriction &violation
+ make-implementation-restriction-violation
+ implementation-restriction-violation?)
+
+ (define-condition-type/constructor &lexical &violation
+ make-lexical-violation lexical-violation?)
+
+ (define-condition-type/constructor &syntax &violation
+ make-syntax-violation syntax-violation?
+ (form syntax-violation-form)
+ (subform syntax-violation-subform))
+
+ (define-condition-type/constructor &undefined &violation
+ make-undefined-violation undefined-violation?))
diff --git a/lib/rnrs/syntax-case.sld b/lib/rnrs/syntax-case.sld
new file mode 100644
index 00000000..adfe2ed8
--- /dev/null
+++ b/lib/rnrs/syntax-case.sld
@@ -0,0 +1,17 @@
+(library (rnrs syntax-case)
+ (export make-variable-transformer
+ syntax-case
+ syntax
+ identifier?
+ bound-identifier=?
+ free-identifier=?
+ syntax->datum
+ datum->syntax
+ generate-temporaries
+ with-syntax
+ quasisyntax
+ unsyntax
+ unsyntax-splicing
+ syntax-violation)
+ (import (chibi ast)
+ (chibi syntax-case)))