conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* 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).
This commit is contained in:
Abdulaziz Ghuloum 2007-10-23 16:38:34 -04:00
parent 658e441d6c
commit 56d279297b
6 changed files with 383 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/Makefile.am
View File

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

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

293
scheme/ikarus.conditions.ss Normal file
View File

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

34
scheme/ikarus.records.procedural.ss
View File

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

7
scheme/makefile.ss
View File

@ -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]

66
scheme/psyntax.expander.ss
View File

@ -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*)])))