Add SRFI 35 support

lib/chibi/repl.scm

@@ -370,6 +370,49 @@
                (display ".\nNote module files must end in \".sld\".\n" out)))))))
     )))
 
+(define (repl-print-condition exn out)
+  (define components (simple-conditions exn))
+  (define n-components (length components))
+  (display "CONDITION: " out)
+  (display n-components out)
+  (display " component" out)
+  (if (not (=  n-components 1)) (display "s" out))
+  (display "\n" out)
+  (for-each
+   (lambda (component idx)
+     (define component-type (type-of component))
+     (display " " out)
+     (display idx out)
+     (display ". " out)
+     (display (type-name component-type) out)
+     (display "\n" out)
+     (let loop ((as (reverse
+                     (condition-type-ancestors component-type)))
+                (idx 0))
+       (if (not (null? as))
+           (let ((a (car as)))
+             (let a-loop ((fields (type-slots a))
+                          (idx idx))
+               (if (null? fields)
+                   (loop (cdr as) idx)
+                   (begin
+                     (display "    " out)
+                     (display (if (pair? (car fields))
+                                  (car (cdar fields))
+                                  (car fields))
+                              out)
+                     (if (not (eqv? a component-type))
+                         (begin
+                           (display " (" out)
+                           (display (type-name a) out)
+                           (display ")" out)))
+                     (display ": " out)
+                     (write (slot-ref component-type component idx) out)
+                     (display "\n" out)
+                     (a-loop (cdr fields) (+ idx 1)))))))))
+   components
+   (iota n-components 1)))
+
 (define undefined-value (if #f #f))
 
 (define $0 undefined-value)
@@ -420,6 +463,8 @@
      (lambda (n) (thread-interrupt! thread))
      (lambda ()
        (protect (exn
+                 ((condition? exn)
+                  (repl-print-condition exn out))
                  (else
                   (repl-print-exception exn out)
                   (repl-advise-exception exn (current-error-port))))

lib/chibi/repl.sld

@@ -9,6 +9,7 @@
           (srfi 1)
           (srfi 9)
           (only (srfi 18) current-thread)
+          (srfi 35 internal)
           (srfi 38)
           (srfi 95)
           (srfi 98))

lib/srfi/35.sld

@@ -0,0 +1,24 @@
+(define-library (srfi 35)
+  (import (srfi 35 internal))
+  (export make-condition-type
+          condition-type?
+          make-condition
+          condition?
+          condition-has-type?
+          condition-ref
+          make-compound-condition
+          extract-condition
+          define-condition-type
+          condition
+
+          &condition
+
+          &message
+          message-condition?
+          condition-message
+
+          &serious
+          serious-condition?
+
+          &error
+          error?))

lib/srfi/35/internal.scm

@@ -0,0 +1,230 @@
+(define-record-type Simple-Condition
+  (make-simple-condition)
+  simple-condition?)
+
+(define-record-type Compound-Condition
+  (%make-compound-condition components)
+  compound-condition?
+  (components compound-condition-components))
+
+(define (make-condition-type id parent field-names)
+  (make-rtd id
+            (list->vector
+             (map
+              (lambda (field-name)
+                (list 'immutable field-name))
+              field-names))
+            parent))
+
+(define (condition? obj)
+  (or (simple-condition? obj)
+      (compound-condition? obj)))
+
+(define (condition-type? obj)
+  (condition-subtype? obj Simple-Condition))
+
+(define (condition-subtype? maybe-child-ct maybe-parent-ct)
+  (and (rtd? maybe-child-ct)
+       (or (eqv? maybe-child-ct maybe-parent-ct)
+           (condition-subtype? (rtd-parent maybe-child-ct)
+                               maybe-parent-ct))))
+
+(define (condition-type-ancestors ct)
+  (unfold (lambda (a) (not (condition-type? a)))
+          (lambda (a) a)
+          (lambda (a) (rtd-parent a))
+          ct))
+
+(define (condition-type-common-ancestor ct_1 ct_2)
+  (let ((ct_1-as (condition-type-ancestors ct_1))
+        (ct_2-as (condition-type-ancestors ct_2)))
+    (find (lambda (a)
+            (memv a ct_2-as))
+          ct_1-as)))
+
+(define (make-condition ct . plist)
+  (define *undef* (cons '*undef* '()))
+  (let* ((field-names (rtd-all-field-names ct))
+         (field-values (make-vector (vector-length field-names) *undef*)))
+    (let loop ((property plist))
+      (if (null? property)
+          (cond ((vector-any (lambda (name value)
+                               (and (eq? value *undef*) name))
+                             field-names
+                             field-values)
+                 => (lambda (undef-field-name)
+                      (error "make-condition: value not given for field"
+                             undef-field-name
+                             ct)))
+                (else
+                 (apply (rtd-constructor ct) (vector->list field-values))))
+          (let ((idx (vector-index (lambda (x) (eq? x (car property)))
+                                   field-names)))
+            (if idx
+                (begin
+                  (vector-set! field-values idx (cadr property))
+                  (loop (cddr property)))
+                (error "make-condition: unknown field" (car property))))))))
+
+(define (make-compound-condition . cs)
+  (if (= (length cs) 1)
+      (car cs)
+      ;; SRFI 35 requires at least one component, but R6RS doesn’t;
+      ;; defer to R6RS’s less strict error checking (!)
+      (%make-compound-condition
+       (append-map
+        (lambda (c)
+          (if (simple-condition? c)
+              (list c)
+              (compound-condition-components c)))
+        cs))))
+
+(define (condition-has-type? c ct)
+  (if (simple-condition? c)
+      (is-a? c ct)
+      (any
+       (lambda (comp) (condition-has-type? comp ct))
+       (compound-condition-components c))))
+
+(define (condition-ref c field-name)
+  (if (simple-condition? c)
+      ((rtd-accessor (record-rtd c) field-name) c)
+      (condition-ref
+       (find
+        (lambda (comp)
+          (find field-name
+                (vector->list
+                 (rtd-all-field-names (record-rtd c)))))
+        (compound-condition-components c))
+       field-name)))
+
+(define (simple-conditions c)
+  (if (simple-condition? c)
+      (list c)
+      (compound-condition-components c)))
+
+(define (extract-condition c ct)
+  (if (and (simple-condition? c)
+           (condition-has-type? c ct))
+      c
+      (find
+       (lambda (comp)
+         (condition-has-type? comp ct))
+       (compound-condition-components ct))))
+
+(define (condition-predicate ct)
+  (lambda (obj)
+    (and (condition? obj)
+         (condition-has-type? obj ct))))
+(define (condition-accessor ct proc)
+  (lambda (c)
+    (cond ((and (simple-condition? c)
+                (condition-has-type? c ct))
+           (proc c))
+          ((find (lambda (comp) (condition-has-type? comp ct))
+                 (compound-condition-components c))
+           => (lambda (comp)
+                (proc comp)))
+          (else (error "condition-accessor: condition does not have the right type"
+                       c ct)))))
+
+(define-syntax define-condition-type/constructor
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((name (list-ref expr 1))
+            (parent (list-ref expr 2))
+            (constructor (list-ref expr 3))
+            (predicate (list-ref expr 4))
+            (field-specs (drop expr 5))
+            (field-names (map first field-specs))
+            (field-accessors (map second field-specs)))
+       (define _begin (rename 'begin))
+       (define _define (rename 'define))
+       (define _make-condition-type (rename 'make-condition-type))
+       (define _compound-condition? (rename 'compound-condition?))
+       (define _condition-predicate (rename 'condition-predicate))
+       (define _condition-accessor (rename 'condition-accessor))
+       (define _rtd-constructor (rename 'rtd-constructor))
+       (define _rtd-accessor (rename 'rtd-accessor))
+       (define _and (rename 'and))
+       (define _if (rename 'if))
+       (define _ct (rename 'ct))
+       (define _x (rename 'x))
+       `(,_begin
+         (,_define ,_ct
+           (,_make-condition-type ',name
+                                  ,parent
+                                  ',field-names))
+         (,_define ,name ,_ct)
+         (,_define ,constructor (,_rtd-constructor ,_ct))
+         (,_define ,predicate (,_condition-predicate ,_ct))
+         ,@(map
+            (lambda (field-name field-accessor)
+              `(,_define ,field-accessor
+                 (,_condition-accessor
+                  ,_ct
+                  (,_rtd-accessor ,_ct ',field-name))))
+            field-names
+            field-accessors))))))
+
+(define-syntax define-condition-type
+  (syntax-rules ()
+    ((_ name parent predicate (field-name field-accessor) ...)
+     (define-condition-type/constructor
+       name parent blah-ignored predicate
+       (field-name field-accessor) ...))))
+
+(define (%condition . specs)
+  (define (find-common-field-spec ct name)
+    (let loop ((more-specs specs))
+      (if (null? more-specs)
+          #f
+          (let* ((other-ct (caar more-specs))
+                 (field-specs (cdar more-specs))
+                 (a (condition-type-common-ancestor ct other-ct)))
+            (cond ((and (vector-index
+                         (lambda (n)
+                           (eq? n name))
+                         (rtd-all-field-names a))
+                        (assq name field-specs)))
+                  (else (loop (cdr more-specs))))))))
+  (let loop ((more-specs specs)
+             (components '()))
+    (if (null? more-specs)
+        (apply make-compound-condition (reverse components))
+        (let* ((this-spec (car more-specs))
+               (ct (car this-spec))
+               (field-specs (cdr this-spec))
+               (field-names (rtd-all-field-names ct))
+               (field-values
+                (vector-map
+                 (lambda (field-name)
+                   (cond ((assq field-name field-specs) => cdr)
+                         ((find-common-field-spec ct field-name) => cdr)
+                         (else
+                          (error "condition: value not given for field"
+                                 field-name
+                                 ct))))
+                 field-names)))
+          (loop
+           (cdr more-specs)
+           (cons
+            (apply (rtd-constructor ct) (vector->list field-values))
+            components))))))
+(define-syntax condition
+  (syntax-rules ()
+    ((_ (ct (field-name field-value) ...) ...)
+     (%condition (list ct (cons 'field-name field-value) ...) ...))))
+
+(define &condition Simple-Condition)
+
+(define-condition-type/constructor &message &condition
+  make-message-condition message-condition?
+  (message condition-message))
+
+(define-condition-type/constructor &serious &condition
+  make-serious-condition serious-condition?)
+
+(define-condition-type/constructor &error &serious
+  make-error error?)
+

lib/srfi/35/internal.sld

@@ -0,0 +1,49 @@
+(define-library (srfi 35 internal)
+  (import (except (scheme base)
+                  define-record-type
+                  ;; exclude (srfi 1 immutable) duplicate imports:
+                  map cons list append reverse)
+          (only (chibi)
+                er-macro-transformer
+                is-a?)
+          ;; don’t let people go messing with a compound condition
+          ;; components list:
+          (srfi 1 immutable)
+          (srfi 99)
+          (srfi 133))
+  (export simple-condition?
+          compound-condition?
+          make-condition-type
+          condition?
+          condition-type?
+          condition-subtype?
+          condition-type-ancestors
+          make-condition
+          make-compound-condition
+          condition-has-type?
+          condition-ref
+          simple-conditions
+          extract-condition
+          compound-condition-components
+          condition-predicate
+          condition-accessor
+          define-condition-type/constructor
+          define-condition-type
+          condition
+
+          &condition
+
+          &message
+          make-message-condition
+          message-condition?
+          condition-message
+
+          &serious
+          make-serious-condition
+          serious-condition?
+
+          &error
+          make-error
+          error?)
+
+  (include "internal.scm"))

lib/srfi/35/test.sld

@@ -0,0 +1,94 @@
+(define-library (srfi 35 test)
+  (import (scheme base)
+          (srfi 35 internal)
+          (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-35: condition types")
+      (test-group "Adapted from the SRFI 35 examples"
+        (define-condition-type &c &condition
+          c?
+          (x c-x))
+
+        (define-condition-type &c1 &c
+          c1?
+          (a c1-a))
+
+        (define-condition-type &c2 &c
+          c2?
+          (b c2-b))
+        (define v1 (make-condition &c1 'x "V1" 'a "a1"))
+        (define v2 (condition (&c2
+                               (x "V2")
+                               (b "b2"))))
+        (define v3 (condition (&c1
+                               (x "V3/1")
+                               (a "a3"))
+                              (&c2
+                               (b "b3"))))
+        (define v4 (make-compound-condition v1 v2))
+        (define v5 (make-compound-condition v2 v3))
+
+        (test #t (c? v1))
+        (test #t (c1? v1))
+        (test #f (c2? v1))
+        (test "V1" (c-x v1))
+        (test "a1" (c1-a v1))
+
+        (test #t (c? v2))
+        (test #f (c1? v2))
+        (test #t (c2? v2))
+        (test "V2" (c-x v2))
+        (test "b2" (c2-b v2))
+
+        (test #t (c? v3))
+        (test #t (c1? v3))
+        (test #t (c2? v3))
+        (test "V3/1" (c-x v3))
+        (test "a3" (c1-a v3))
+        (test "b3" (c2-b v3))
+
+        (test #t (c? v4))
+        (test #t (c1? v4))
+        (test #t (c2? v4))
+        (test "V1" (c-x v4))
+        (test "a1" (c1-a v4))
+        (test "b2" (c2-b v4))
+
+        (test #t (c? v5))
+        (test #t (c1? v5))
+        (test #t (c2? v5))
+        (test "V2" (c-x v5))
+        (test "a3" (c1-a v5))
+        (test "b2" (c2-b v5)))
+
+      (test-group "Standard condition hierarchy"
+        (let ((mc (make-message-condition "foo!")))
+          (test #t (message-condition? mc))
+          (test "foo!" (condition-message mc))
+
+          (let ((ec (make-error)))
+            (test #t (error? ec))
+            (test #t (serious-condition? ec))
+
+            (let ((cc (make-compound-condition ec mc)))
+              (test #t (error? cc))
+              (test #t (serious-condition? cc))
+              (test #t (message-condition? cc))
+              (test "foo!" (condition-message mc))))))
+
+      (test-group "R6RS extension: shadowing field names"
+        (define-condition-type/constructor &a &condition
+          make-a a?
+          (val a-val))
+        (define-condition-type/constructor &b &a
+          make-b b?
+          (val b-val))
+
+        (define c (make-b 'a 'b))
+
+        (test 'a (a-val c))
+        (test 'b (b-val c)))
+
+      (test-end))))

lib/srfi/99/records/procedural.scm

@@ -9,7 +9,13 @@
   (type? x))
 
 (define (rtd-constructor rtd . o)
-  (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd))))
+  (let ((fields
+         (if (pair? o)
+             (map
+              (lambda (field)
+                (rtd-field-offset rtd field))
+              (vector->list (car o)))
+             (iota (vector-length (rtd-all-field-names rtd)))))
         (make (make-constructor (type-name rtd) rtd)))
     (lambda args
       (let ((res (make)))
@@ -18,7 +24,7 @@
            ((null? a) (if (null? p) res (error "not enough args" p)))
            ((null? p) (error "too many args" a))
            (else
-            (slot-set! rtd res (rtd-field-offset rtd (car p)) (car a))
+            (slot-set! rtd res (car p) (car a))
             (lp (cdr a) (cdr p)))))))))
 
 (define (rtd-predicate rtd)
@@ -35,13 +41,13 @@
 
 (define (rtd-field-offset rtd field)
   (let ((p (type-parent rtd)))
-    (or (and (type? p)
-             (rtd-field-offset p field))
-        (let ((i (field-index-of (type-slots rtd) field)))
+    (or (let ((i (field-index-of (type-slots rtd) field)))
           (and i
                (if (type? p)
                    (+ i (vector-length (rtd-all-field-names p)))
-                   i))))))
+                   i)))
+        (and (type? p)
+             (rtd-field-offset p field)))))
 
 (define (rtd-accessor rtd field)
   (make-getter (type-name rtd) rtd (rtd-field-offset rtd field)))

lib/srfi/99/records/procedural.sld

@@ -1,5 +1,8 @@
 
 (define-library (srfi 99 records procedural)
   (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
-  (import (chibi) (chibi ast) (srfi 99 records inspection))
+  (import (chibi)
+          (chibi ast)
+          (only (srfi 1) iota)
+          (srfi 99 records inspection))
   (include "procedural.scm"))

tests/lib-tests.scm

@@ -8,6 +8,7 @@
         (rename (srfi 18 test) (run-tests run-srfi-18-tests))
         (rename (srfi 26 test) (run-tests run-srfi-26-tests))
         (rename (srfi 27 test) (run-tests run-srfi-27-tests))
+        (rename (srfi 35 test) (run-tests run-srfi-35-tests))
         (rename (srfi 38 test) (run-tests run-srfi-38-tests))
         (rename (srfi 41 test) (run-tests run-srfi-41-tests))
         (rename (srfi 69 test) (run-tests run-srfi-69-tests))
@@ -83,6 +84,7 @@
 (run-srfi-18-tests)
 (run-srfi-26-tests)
 (run-srfi-27-tests)
+(run-srfi-35-tests)
 (run-srfi-38-tests)
 (run-srfi-41-tests)
 (run-srfi-69-tests)