Partial R6RS library compatibility

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/meta-7.scm

@@ -355,6 +355,60 @@
 (define-syntax define-library define-library-transformer)
 (define-syntax module define-library-transformer)
 
+(define r6rs-library-transformer
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (clean-up-r6rs-library-name name)
+       (define (srfi-number->exact-integer component)
+         (if (symbol? component)
+             (let* ((symbol-name (symbol->string component)))
+               (if (and (char=? (string-ref symbol-name 0) #\:)
+                        (every char-numeric?
+                               (cdr (string->list symbol-name))))
+                   (string->number maybe-number-as-string)
+                   #f))
+             #f))
+       (apply append
+              (map
+               (lambda (component)
+                 (cond ((list? component) ; ignore version numbers
+                        '())
+                       ((srfi-number->exact-integer component) => list)
+                       (else (list component))))
+               name)))
+     (define (clean-up-r6rs-import import-spec)
+       (cond ((identifier? import-spec) import-spec)
+             ((memq (car import-spec)
+                    '(only except prefix rename))
+              (cons (car import-spec)
+                    (cons (clean-up-r6rs-library-name (cadr import-spec))
+                          (cddr import-spec))))
+             ((memq (car import-spec)
+                    '(library for))
+              (clean-up-r6rs-library-name (cadr import-spec)))
+             (else (clean-up-r6rs-library-name import-spec))))
+
+     (if (not (eq? (car expr) 'library))
+       (error "r6rs-library-transformer: I expect to process declarations called library, but this was a new one to me" (car expr)))
+     (if (not (and (list? expr)
+                   (>= (length expr) 3)
+                   (list? (list-ref expr 1))
+                   (list? (list-ref expr 2))
+                   (eq? (car (list-ref expr 2)) 'export)
+                   (list? (list-ref expr 3))
+                   (eq? (car (list-ref expr 3)) 'import)))
+       (error "r6rs-library-transformer: the form of a library declaration is (library <name> (export <export-spec> ...) (import <import-spec> ...) <defexpr> ...)" expr))
+     (let ((library-name (clean-up-r6rs-library-name (list-ref expr 1)))
+           (exports (cdr (list-ref expr 2)))
+           (imports (map clean-up-r6rs-import (cdr (list-ref expr 3))))
+           (body (cddr (cddr expr))))
+       `(define-library ,library-name
+          (export ,@exports)
+          (import ,@imports)
+          (begin ,@body))))))
+
+(define-syntax library r6rs-library-transformer)
+
 (define-syntax pop-this-path
   (er-macro-transformer
    (lambda (expr rename compare)