Add (rnrs syntax-case)

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)

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)

lib/rnrs/base.sld

@@ -190,22 +190,55 @@
           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)
                   (euclidean/ div-and-mod)
                   (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)

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?))

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)))