* fixed bugs in define-record-type (constructor name was ignored)

* fixed bugs in record-constructor (incorrect constructor was
  returned when when no protocol is supplied) 
* added r6rs condition types (constructors and standard conditions).

scheme/Makefile.am

@@ -1,6 +1,6 @@
 
 nodist_bin_SCRIPTS=ikarus.boot
-EXTRA_DIST=ikarus.boot.orig ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
+EXTRA_DIST=ikarus.boot.orig ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.conditions.ss  ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.transcoders.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
 
 all: $(nodist_bin_SCRIPTS)
 

scheme/ikarus.conditions.ss

@@ -0,0 +1,293 @@
+
+(library (ikarus conditions)
+  (export condition? simple-conditions condition-predicate
+          condition condition-accessor
+
+          ;;; too much junk
+          make-message-condition message-condition?
+          condition-message make-warning warning?
+          make-serious-condition serious-condition? make-error
+          error? make-violation violation? make-assertion-violation
+          assertion-violation? make-irritants-condition
+          irritants-condition? condition-irritants
+          make-who-condition who-condition? condition-who
+          make-non-continuable-violation non-continuable-violation?
+          make-implementation-restriction-violation
+          implementation-restriction-voilation?
+          make-lexical-violation lexical-violation?
+          make-syntax-violation syntax-violation?
+          syntax-violation-form syntax-violation-subform
+          make-undefined-violation undefined-violation?
+          make-i/o-error i/o-error? make-i/o-read-error
+          i/o-read-error? make-i/o-write-error i/o-write-error?
+          make-i/o-invalid-position-error
+          i/o-invalid-position-error? i/o-error-position
+          make-i/o-filename-error i/o-filename-error?
+          i/o-error-filename make-i/o-file-protection-error
+          i/o-file-protection-error? make-i/o-fie-is-read-only-error
+          i/o-fie-is-read-only-error?
+          make-i/o-file-already-exists-error
+          i/o-file-already-exists-error?
+          make-i/o-file-does-not-exist-error
+          i/o-file-does-not-exist-error? make-i/o-port-error
+          i/o-port-error? i/o-error-port make-i/o-decoding-error
+          i/o-decoding-error? make-i/o-encoding-error
+          i/o-encoding-error? i/o-encoding-error-char
+          
+          &condition-rtd &condition-rcd &message-rtd &message-rcd
+          &warning-rtd &warning-rcd &serious-rtd &serious-rcd
+          &error-rtd &error-rcd &violation-rtd &violation-rcd
+          &assertion-rtd &assertion-rcd &irritants-rtd
+          &irritants-rcd &who-rtd &who-rcd &non-continuable-rtd
+          &non-continuable-rcd &implementation-restriction-rtd
+          &implementation-restriction-rcd &lexical-rtd &lexical-rcd
+          &syntax-rtd &syntax-rcd &undefined-rtd &undefined-rcd
+          &i/o-rtd &i/o-rcd &i/o-read-rtd &i/o-read-rcd
+          &i/o-write-rtd &i/o-write-rcd &i/o-invalid-position-rtd
+          &i/o-invalid-position-rcd &i/o-filename-rtd
+          &i/o-filename-rcd &i/o-file-protection-rtd
+          &i/o-file-protection-rcd &i/o-fie-is-read-only-rtd
+          &i/o-fie-is-read-only-rcd &i/o-file-already-exists-rtd
+          &i/o-file-already-exists-rcd &i/o-file-does-not-exist-rtd
+          &i/o-file-does-not-exist-rcd &i/o-port-rtd &i/o-port-rcd
+          &i/o-decoding-rtd &i/o-decoding-rcd &i/o-encoding-rtd
+          &i/o-encoding-rcd
+
+          )
+  (import
+    (only (rnrs) record-type-descriptor record-constructor-descriptor record-predicate)
+    (only (ikarus records procedural) rtd? rtd-subtype?)
+    (except (ikarus) define-condition-type condition? simple-conditions
+          condition condition-predicate condition-accessor
+          
+          ;;; more junk
+          make-message-condition message-condition?
+          condition-message make-warning warning?
+          make-serious-condition serious-condition? make-error
+          error? make-violation violation? make-assertion-violation
+          assertion-violation? make-irritants-condition
+          irritants-condition? condition-irritants
+          make-who-condition who-condition? condition-who
+          make-non-continuable-violation non-continuable-violation?
+          make-implementation-restriction-violation
+          implementation-restriction-voilation?
+          make-lexical-violation lexical-violation?
+          make-syntax-violation syntax-violation?
+          syntax-violation-form syntax-violation-subform
+          make-undefined-violation undefined-violation?
+          make-i/o-error i/o-error? make-i/o-read-error
+          i/o-read-error? make-i/o-write-error i/o-write-error?
+          make-i/o-invalid-position-error
+          i/o-invalid-position-error? i/o-error-position
+          make-i/o-filename-error i/o-filename-error?
+          i/o-error-filename make-i/o-file-protection-error
+          i/o-file-protection-error? make-i/o-fie-is-read-only-error
+          i/o-fie-is-read-only-error?
+          make-i/o-file-already-exists-error
+          i/o-file-already-exists-error?
+          make-i/o-file-does-not-exist-error
+          i/o-file-does-not-exist-error? make-i/o-port-error
+          i/o-port-error? i/o-error-port make-i/o-decoding-error
+          i/o-decoding-error? make-i/o-encoding-error
+          i/o-encoding-error? i/o-encoding-error-char
+          
+          ))
+  
+  (define-record-type &condition 
+    (nongenerative))
+  (define &condition-rtd (record-type-descriptor &condition))
+  (define &condition-rcd (record-constructor-descriptor &condition))
+  
+  (define-record-type compound-condition
+    (nongenerative)
+    (fields (immutable components))
+    (sealed #t)
+    (opaque #t))
+
+  (define (condition? x) 
+    (or (&condition? x) 
+        (compound-condition? x)))
+
+  (define condition
+    (case-lambda
+      [() (make-compound-condition '())]
+      [(x) 
+       (if (condition? x)
+           x 
+           (error 'condition "~s is not a condition type" x))]
+      [x*
+       (let ([ls
+              (let f ([x* x*])
+                (cond
+                  [(null? x*) '()]
+                  [(&condition? (car x*)) 
+                   (cons (car x*) (f (cdr x*)))]
+                  [(compound-condition? (car x*)) 
+                   (append (simple-conditions (car x*)) (f (cdr x*)))]
+                  [else (error 'condition "~s is not a condition" (car x*))]))])
+         (cond
+           [(null? ls) (make-compound-condition '())]
+           [(null? (cdr ls)) (car ls)]
+           [else (make-compound-condition ls)]))]))
+
+  (define (simple-conditions x)
+    (cond
+      [(compound-condition? x) (compound-condition-components x)]
+      [(&condition? x) (list x)]
+      [else (error 'simple-conditions "~s is not a condition" x)]))
+
+  (define (condition-predicate rtd) 
+    (unless (rtd? rtd) 
+      (error 'condition-predicate "~s is not a record type descriptor" rtd))
+    (unless (rtd-subtype? rtd (record-type-descriptor &condition))
+      (error 'condition-predicate "~s is not a descendant of &condition" rtd))
+    (let ([p? (record-predicate rtd)])
+      (lambda (x) 
+        (or (p? x) 
+            (and (compound-condition? x) 
+                 (let f ([ls (compound-condition-components x)])
+                   (and (pair? ls) 
+                        (or (p? (car ls)) 
+                            (f (cdr ls))))))))))
+  
+  (define (condition-accessor rtd proc) 
+    (unless (rtd? rtd) 
+      (error 'condition-accessor "~s is not a record type descriptor" rtd))
+    (unless (procedure? proc) 
+      (error 'condition-accessor "~s is not a procedure" proc))
+    (unless (rtd-subtype? rtd (record-type-descriptor &condition))
+      (error 'condition-accessor "~s is not a descendant of &condition" rtd))
+    (let ([p? (record-predicate rtd)])
+      (lambda (x) 
+        (cond
+          [(p? x) (proc x)]
+          [(compound-condition? x) 
+           (let f ([ls (compound-condition-components x)])
+             (cond
+               [(pair? ls) 
+                (if (p? (car ls)) 
+                    (proc (car ls))
+                    (f (cdr ls)))]
+               [else
+                (error 'condition-accessor "~s is not a condition of type ~s" x rtd)]))]
+          [else 
+           (error 'condition-accessor "~s is not a condition of type ~s" x rtd)]))))
+
+  (define-syntax define-condition-type
+    (lambda (x)
+      (define (mkname name suffix)
+        (datum->syntax name 
+           (string->symbol 
+             (string-append 
+               (symbol->string (syntax->datum name))
+               suffix))))
+      (syntax-case x ()
+        [(ctxt name super constructor predicate (field* accessor*) ...)
+         (and (identifier? #'name) 
+              (identifier? #'super)
+              (identifier? #'constructor)
+              (identifier? #'predicate)
+              (andmap identifier? #'(field* ...))
+              (andmap identifier? #'(accessor* ...)))
+         (with-syntax ([(aux-accessor* ...) (generate-temporaries #'(accessor* ...))]
+                       [rtd (mkname #'name "-rtd")]
+                       [rcd (mkname #'name "-rcd")])
+            #'(begin
+               (define-record-type (name constructor p?)
+                  (parent super)
+                  (fields (immutable field* aux-accessor*) ...)
+                  (nongenerative)
+                  (sealed #f) (opaque #f))
+               (define predicate (condition-predicate (record-type-descriptor name)))
+               (define accessor* (condition-accessor (record-type-descriptor name) aux-accessor*)) 
+               ...
+               (define rtd (record-type-descriptor name))
+               (define rcd (record-constructor-descriptor name))))])))
+
+  (define-condition-type &message &condition
+    make-message-condition message-condition? 
+    (message condition-message))
+
+  (define-condition-type &warning &condition
+    make-warning warning?)
+
+  (define-condition-type &serious &condition 
+    make-serious-condition serious-condition?)
+
+  (define-condition-type &error &serious 
+    make-error error?)
+
+  (define-condition-type &violation &serious
+    make-violation violation?)
+
+  (define-condition-type &assertion &violation
+    make-assertion-violation assertion-violation?)
+
+  (define-condition-type &irritants &condition
+    make-irritants-condition irritants-condition? 
+    (irritants condition-irritants))
+
+  (define-condition-type &who &condition 
+    make-who-condition who-condition?
+    (who condition-who))
+
+  (define-condition-type &non-continuable &violation
+    make-non-continuable-violation non-continuable-violation?)
+
+  (define-condition-type &implementation-restriction &violation
+    make-implementation-restriction-violation
+    implementation-restriction-voilation?)
+
+  (define-condition-type &lexical &violation
+    make-lexical-violation lexical-violation?)
+
+  (define-condition-type &syntax &violation
+    make-syntax-violation syntax-violation?
+    (form syntax-violation-form)
+    (subform syntax-violation-subform))
+
+  (define-condition-type &undefined &violation
+    make-undefined-violation undefined-violation?)
+
+  (define-condition-type &i/o &error 
+    make-i/o-error i/o-error?)
+
+  (define-condition-type &i/o-read &i/o
+    make-i/o-read-error i/o-read-error?)
+
+  (define-condition-type &i/o-write &i/o
+    make-i/o-write-error i/o-write-error?)
+
+  (define-condition-type &i/o-invalid-position &i/o
+    make-i/o-invalid-position-error i/o-invalid-position-error?
+    (position i/o-error-position))
+
+  (define-condition-type &i/o-filename &i/o
+    make-i/o-filename-error i/o-filename-error?
+    (filename i/o-error-filename))
+
+  (define-condition-type &i/o-file-protection &i/o
+    make-i/o-file-protection-error i/o-file-protection-error?)
+
+  (define-condition-type &i/o-fie-is-read-only &i/o-file-protection
+    make-i/o-fie-is-read-only-error i/o-fie-is-read-only-error?)
+
+  (define-condition-type &i/o-file-already-exists &i/o-filename
+    make-i/o-file-already-exists-error i/o-file-already-exists-error?)
+
+  (define-condition-type &i/o-file-does-not-exist &i/o-filename
+    make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?)
+
+  (define-condition-type &i/o-port &i/o
+    make-i/o-port-error i/o-port-error?
+    (port i/o-error-port))
+
+  (define-condition-type &i/o-decoding &i/o-port
+    make-i/o-decoding-error i/o-decoding-error?)
+
+  (define-condition-type &i/o-encoding &i/o-port
+    make-i/o-encoding-error i/o-encoding-error?
+    (char i/o-encoding-error-char))
+
+  )
+

scheme/ikarus.records.procedural.ss

@@ -6,12 +6,13 @@
     record-mutator record-constructor record-predicate record?
     record-rtd record-type-name record-type-parent record-type-uid
     record-type-generative?  record-type-sealed? record-type-opaque?
-    record-type-field-names record-field-mutable?)
+    record-type-field-names record-field-mutable? rtd-subtype? rtd?)
   (import 
     (except (ikarus)
       record-constructor record-predicate record?  record-type-name
       record-type-parent record-type-descriptor?
-      record-type-field-names record-field-mutable?)
+      record-type-field-names record-field-mutable?
+      rtd? rtd-subtype?)
     (ikarus system $structs))
 
   (define-struct rtd 
@@ -186,12 +187,21 @@
           [else (error who "~s is not a valid uid" uid)]))))
 
   (define-struct rcd (rtd prcd proc))
+
   (define (is-parent-of? prtd rtd)
     (let ([p (rtd-parent rtd)])
       (cond
         [(eq? p prtd) #t]
         [(not p) #f]
         [else (is-parent-of? prtd p)])))
+
+  (define (rtd-subtype? rtd parent-rtd) 
+    (unless (rtd? rtd) 
+      (error 'rtd-subtype? "~s is not an rtd" rtd))
+    (unless (rtd? parent-rtd) 
+      (error 'rtd-substype? "~s is not an rtd" parent-rtd))
+    (or (eq? rtd parent-rtd)
+        (is-parent-of? parent-rtd rtd)))
         
   (define make-record-constructor-descriptor
     (lambda (rtd prcd protocol)
@@ -238,13 +248,19 @@
             (let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))]
                   [n (- size sz)])
               (lambda (f*)
-                (let ([v (lambda fmls
+                (if proto
-                           (lambda flds
+                    (proto 
-                             (unless (= (length flds) n) 
+                      (lambda fmls
-                               (error 'record-constructor 
+                        (lambda flds
-                                  "expecting ~s args, got ~s" n flds))
+                          (unless (= (length flds) n) 
-                             (apply (p (cons flds f*)) fmls)))])
+                            (error 'record-constructor 
-                  (if proto (proto v) v)))))))
+                               "expecting ~s args, got ~s" n flds))
+                          (apply (p (cons flds f*)) fmls))))
+                    (lambda flds
+                      (unless (= (length flds) n) 
+                         (error 'record-constructor 
+                           "expecting ~s args, got ~s" n flds))
+                      ((p (cons flds f*))))))))))
     (unless (rcd? rcd)
       (error who "~s is not a record constructor descriptor" rcd))
     (let ([rtd (rcd-rtd rcd)]

scheme/makefile.ss

@@ -43,7 +43,9 @@
     "ikarus.date-string.ss"
     "ikarus.symbols.ss"
     "ikarus.vectors.ss"
+    "ikarus.unicode-data.ss"
     "ikarus.numerics.ss"
+    "ikarus.conditions.ss"
     "ikarus.guardians.ss"
     "ikarus.command-line.ss"
     "ikarus.codecs.ss"
@@ -55,7 +57,6 @@
     "ikarus.io.input-strings.ss"
     "ikarus.io.output-strings.ss"
     "ikarus.hash-tables.ss"
-    "ikarus.unicode-data.ss"
     "ikarus.writer.ss"
     "ikarus.reader.ss"
     "ikarus.code-objects.ss"
@@ -1128,7 +1129,7 @@
     [vector-sort!                                i r sr]
     [file-exists?                                i r fi]
     [delete-file                                 i r fi]
-    [define-record-type                          r rs]
+    [define-record-type                          i r rs]
     [fields                                      i r rs]
     [immutable                                   i r rs]
     [mutable                                     i r rs]
@@ -1137,7 +1138,7 @@
     [parent-rtd                                  i r rs]
     [protocol                                    i r rs]
     [record-constructor-descriptor               r rs]
-    [record-type-descriptor                      r rs]
+    [record-type-descriptor                      i r rs]
     [sealed                                      i r rs]
     [nongenerative                               i r rs]
     [record-field-mutable?                       r ri]

scheme/psyntax.expander.ss

@@ -1487,16 +1487,70 @@
         (syntax-match (get-clause 'protocol clause*) ()
           [(_ expr) expr]
           [_        #f]))
+      (define (get-fields clause*)
+        (syntax-match clause* (fields)
+          [() '()]
+          [((fields f* ...) . _) f*]
+          [(_ . rest) (get-fields rest)]))
+      (define (get-mutator-indices fields)
+        (let f ([fields fields] [i 0])
+          (syntax-match fields (mutable)
+            [() '()]
+            [((mutable . _) . rest)
+             (cons i (f rest (+ i 1)))]
+            [(_ . rest)
+             (f rest (+ i 1))])))
+      (define (get-mutators foo fields ctxt)
+        (define (gen-name x) 
+          (datum->syntax ctxt
+            (string->symbol 
+              (string-append "set-" 
+                (symbol->string (syntax->datum foo))
+                "-"
+                (symbol->string (syntax->datum x))
+                "!"))))
+        (let f ([fields fields])
+          (syntax-match fields (mutable)
+            [() '()]
+            [((mutable name accessor mutator) . rest) 
+             (cons mutator (f rest))]
+            [((mutable name) . rest)
+             (cons (gen-name name) (f rest))]
+            [(_ . rest) (f rest)])))
+      (define (get-accessors foo fields ctxt)
+        (define (gen-name x) 
+          (datum->syntax ctxt
+            (string->symbol 
+              (string-append
+                (symbol->string (syntax->datum foo))
+                "-"
+                (symbol->string (syntax->datum x))))))
+        (map 
+          (lambda (field)
+            (syntax-match field (mutable immutable)
+              [(mutable name accessor mutator) (id? accessor) accessor]
+              [(immutable name accessor)       (id? accessor) accessor]
+              [(mutable name)                  (id? name) (gen-name name)]
+              [(immutable name)                (id? name) (gen-name name)]
+              [name                            (id? name) (gen-name name)]
+              [others (stx-error field "invalid field spec")]))
+          fields))
+      (define (enumerate ls)
+        (let f ([ls ls] [i 0])
+          (cond
+            [(null? ls) '()]
+            [else (cons i (f (cdr ls) (+ i 1)))])))
       (define (do-define-record ctxt namespec clause*)
         (let* ([foo (get-record-name namespec)]
                [foo-rtd (gensym)]
                [foo-rcd (gensym)]
                [protocol (gensym)]
-               [make-foo (get-record-constructor-name foo ctxt)]
+               [make-foo (get-record-constructor-name namespec ctxt)]
-               ;;; FIXME: getters and setters are not initialized
+               [fields (get-fields clause*)]
-               [foo-x* '()]
+               [idx* (enumerate fields)]
-               [set-foo-x!* '()]
+               [foo-x* (get-accessors foo fields ctxt)]
-               [idx* '()]
+               [set-foo-x!* (get-mutators foo fields ctxt)]
+               [set-foo-idx* (get-mutator-indices fields)]
                [foo? (get-record-predicate-name namespec ctxt)]
                [foo-rtd-code (foo-rtd-code ctxt foo clause*)]
                [foo-rcd-code (foo-rcd-code clause* foo-rtd protocol)]
@@ -1516,7 +1570,7 @@
                ,@(map 
                    (lambda (set-foo-x! idx)
                      `(define ,set-foo-x! (record-mutator ,foo-rtd ,idx)))
-                   set-foo-x!* idx*)))))
+                   set-foo-x!* set-foo-idx*)))))
       (syntax-match x ()
         [(ctxt namespec clause* ...)
          (do-define-record ctxt namespec clause*)])))