diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 3d20e37..fbafaf4 100644 --- a/scheme/Makefile.am +++ b/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) diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index 37b5fdc..d1ed8b6 100644 Binary files a/scheme/ikarus.boot.orig and b/scheme/ikarus.boot.orig differ diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss new file mode 100644 index 0000000..bcdbe38 --- /dev/null +++ b/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)) + + ) + diff --git a/scheme/ikarus.records.procedural.ss b/scheme/ikarus.records.procedural.ss index f2818b2..434b0ca 100644 --- a/scheme/ikarus.records.procedural.ss +++ b/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 - (lambda flds - (unless (= (length flds) n) - (error 'record-constructor - "expecting ~s args, got ~s" n flds)) - (apply (p (cons flds f*)) fmls)))]) - (if proto (proto v) v))))))) + (if proto + (proto + (lambda fmls + (lambda flds + (unless (= (length flds) n) + (error 'record-constructor + "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)] diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 7ca103c..16842aa 100755 --- a/scheme/makefile.ss +++ b/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] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index a1108de..032ca9f 100644 --- a/scheme/psyntax.expander.ss +++ b/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)] - ;;; FIXME: getters and setters are not initialized - [foo-x* '()] - [set-foo-x!* '()] - [idx* '()] + [make-foo (get-record-constructor-name namespec ctxt)] + [fields (get-fields clause*)] + [idx* (enumerate fields)] + [foo-x* (get-accessors foo fields ctxt)] + [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*)])))