diff options
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/6/conditions.scm | 201 | ||||
-rw-r--r-- | module/rnrs/6/exceptions.scm | 51 | ||||
-rw-r--r-- | module/rnrs/6/syntax-case.scm | 55 | ||||
-rw-r--r-- | module/rnrs/io/6/simple.scm | 77 | ||||
-rw-r--r-- | module/rnrs/records/6/procedural.scm | 256 | ||||
-rw-r--r-- | module/rnrs/records/6/syntactic.scm | 200 |
6 files changed, 840 insertions, 0 deletions
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm new file mode 100644 index 000000000..461984fd0 --- /dev/null +++ b/module/rnrs/6/conditions.scm @@ -0,0 +1,201 @@ +;;; conditions.scm --- The R6RS conditions library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs conditions (6)) + (export &condition + condition + simple-conditions + condition? + condition-predicate + condition-accessor + define-condition-type + + &message + make-message-condition + message-condition? + condition-message + + &warning + make-warning + warning? + + &serious + make-serious-condition + serious-condition? + + &error + make-error + error? + + &violation + make-violation + violation? + + &assertion + make-assertion-violation + assertion-violation? + + &irritants + make-irritants-condition + irritants-condition? + condition-irritants + + &who + make-who-condition + who-condition? + condition-who + + &non-continuable + make-non-continuable-violation + non-continuable-violation? + + &implementation-restriction + make-implementation-restriction + implementation-restriction-violation? + + &lexical + make-lexical-violation + lexical-violation? + + &syntax + make-syntax-violation + syntax-violation? + syntax-violation-form + syntax-violation-subform + + &undefined + make-undefined-violation + undefined-violation?) + (import (rnrs base (6)) + (rnrs io simple (6)) + (rnrs records procedural (6)) + (rnrs records syntactic (6)) + (rnrs syntax-case (6))) + + (define &compound-condition (make-record-type-descriptor + '&compound-condition #f #f #f #f + '#((immutable components)))) + (define compound-condition? (record-predicate &compound-condition)) + + (define make-compound-condition + (record-constructor (make-record-constructor-descriptor + &compound-condition #f #f))) + (define compound-condition-components (record-accessor &compound-condition 0)) + + (define-syntax define-condition-type + (lambda (stx) + (syntax-case stx () + ((_ condition-type supertype constructor predicate + (field accessor) ...) + (let + ((fields (let* ((field-spec-syntax #'((field accessor) ...)) + (field-specs (syntax->datum field-spec-syntax))) + (datum->syntax stx + (cons 'fields + (map (lambda (field-spec) + (cons 'immutable field-spec)) + field-specs)))))) + #`(define-record-type (condition-type constructor predicate) + (parent supertype) + #,fields)))))) + + (define &condition (@@ (rnrs records procedural) &condition)) + (define &condition-constructor-descriptor + (make-record-constructor-descriptor &condition #f #f)) + (define condition-internal? (record-predicate &condition)) + + (define condition + (lambda conditions + (define (flatten cond) + (if (compound-condition? cond) + (fold append '() (map flatten (compound-condition-components cond))) + cond)) + (or (for-all condition? conditions) + (raise (make-assertion-violation))) + (make-compound-condition (flatten conditions)))) + + (define (simple-conditions condition) (record-accessor &compound-condition 0)) + (define (condition? obj) + (or (compound-condition? obj) (condition-internal? obj))) + (define (condition-predicate rtd) + (let ((rtd-predicate (record-predicate rtd))) + (lambda (obj) + (cond ((compound-condition? obj) + (find rtd-predicate (compound-condition-components obj))) + ((condition-internal? obj) (rtd-predicate obj)) + (else #f))))) + + (define (condition-accessor rtd proc) + (let ((rtd-predicate (record-predicate rtd))) + (lambda (obj) + (cond ((rtd-predicate obj) (proc obj)) + ((compound-condition? obj) + (and=> (find rtd-predicate simple-conditions obj) proc)) + (else #f))))) + + (define-condition-type &message &condition + make-message-condition message-condition? + (message condition-message)) + + (define-condition-type &warning &condition make-warning warning?) + + (define &serious (@@ (rnrs records procedural) &serious)) + (define make-serious-condition + (@@ (rnrs records procedural) make-serious-condition)) + (define serious-condition? (@@ (rnrs records procedural) serious-condition?)) + + (define-condition-type &error &serious make-error error?) + + (define &violation (@@ (rnrs records procedural) &violation)) + (define make-violation (@@ (rnrs records procedural) make-violation)) + (define violation? (@@ (rnrs records procedural) violation?)) + + (define &assertion (@@ (rnrs records procedural) &assertion)) + (define make-assertion-violation + (@@ (rnrs records procedural) make-assertion-violation)) + (define assertion-violation? + (@@ (rnrs records procedural) 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-violation?) + + (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?)) diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm new file mode 100644 index 000000000..eeea9238b --- /dev/null +++ b/module/rnrs/6/exceptions.scm @@ -0,0 +1,51 @@ +;;; exceptions.scm --- The R6RS exceptions library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs exceptions (6)) + (export with-exception-handler raise raise-continuable) + (import (rnrs base (6)) + (rnrs conditions (6)) + (rnrs records procedural (6)) + (only (guile) with-throw-handler)) + + (define raise (@@ (rnrs records procedural) r6rs-raise)) + (define raise-continuable + (@@ (rnrs records procedural) r6rs-raise-continuable)) + (define raise-object-wrapper? + (@@ (rnrs records procedural) raise-object-wrapper?)) + (define raise-object-wrapper-obj + (@@ (rnrs records procedural) raise-object-wrapper-obj)) + (define raise-object-wrapper-continuation + (@@ (rnrs records procedural) raise-object-wrapper-continuation)) + + (define (with-exception-handler handler thunk) + (with-throw-handler 'r6rs:exception + thunk + (lambda (key . args) + (if (and (not (null? args)) + (raise-object-wrapper? (car args))) + (let* ((cargs (car args)) + (obj (raise-object-wrapper-obj cargs)) + (continuation (raise-object-wrapper-continuation cargs)) + (handler-return (handler obj))) + (if continuation + (continuation handler-return) + (raise (make-non-continuable-violation)))) + *unspecified*)))) +) diff --git a/module/rnrs/6/syntax-case.scm b/module/rnrs/6/syntax-case.scm new file mode 100644 index 000000000..91ca6002e --- /dev/null +++ b/module/rnrs/6/syntax-case.scm @@ -0,0 +1,55 @@ +;;; syntax-case.scm --- R6RS support for `syntax-case' macros + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs syntax-case (6)) + (export make-variable-transformer + syntax-case + syntax + + identifier? + bound-identifier=? + free-identifier=? + + syntax->datum + datum->syntax + generate-temporaries + with-syntax + + quasisyntax + unsyntax + unsyntax-splicing + + syntax-violation) + (import (only (guile) syntax-case + syntax + + identifier? + bound-identifier=? + free-identifier=? + + syntax->datum + datum->syntax + generate-temporaries + with-syntax + + quasisyntax + unsyntax + unsyntax-splicing + + syntax-violation))) diff --git a/module/rnrs/io/6/simple.scm b/module/rnrs/io/6/simple.scm new file mode 100644 index 000000000..cf6c1307d --- /dev/null +++ b/module/rnrs/io/6/simple.scm @@ -0,0 +1,77 @@ +;;; simple.scm --- The R6RS simple I/O library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs io simple (6)) + (export eof-object + eof-object? + + call-with-input-file + call-with-output-file + + input-port? + output-port? + + current-input-port + current-output-port + current-error-port + + with-input-from-file + with-output-to-file + + open-input-file + open-output-file + + close-input-port + close-output-port + + read-char + peek-char + read + write-char + newline + display + write) + (import (only (rnrs io ports) eof-object + eof-object? + + input-port? + output-port?) + (only (guile) call-with-input-file + call-with-output-file + + current-input-port + current-output-port + current-error-port + + with-input-file + with-output-file + + open-input-file + open-output-file + + close-input-port + close-output-port + + read-char + peek-char + read + write-char + newline + display + write))) diff --git a/module/rnrs/records/6/procedural.scm b/module/rnrs/records/6/procedural.scm new file mode 100644 index 000000000..01c94de83 --- /dev/null +++ b/module/rnrs/records/6/procedural.scm @@ -0,0 +1,256 @@ +;;; procedural.scm --- Procedural interface to R6RS records + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs records procedural (6)) + (export make-record-type-descriptor + record-type-descriptor? + make-record-constructor-descriptor + + record-constructor + record-predicate + record-accessor + record-mutator) + + (import (rnrs base (6)) + (only (guile) and=> + throw + display + make-struct + make-vtable + map + simple-format + string-append + + struct? + struct-ref + struct-set! + struct-vtable + vtable-index-layout + + make-hash-table + hashq-ref + hashq-set! + + vector->list) + (ice-9 receive) + (only (srfi :1) fold-right split-at take)) + + (define (record-rtd record) (struct-ref record 1)) + (define (record-type-name rtd) (struct-ref rtd 0)) + (define (record-type-parent rtd) (struct-ref rtd 2)) + (define (record-type-uid rtd) (struct-ref rtd 1)) + (define (record-type-generative? rtd) (not (record-type-uid rtd))) + (define (record-type-sealed? rtd) (struct-ref rtd 3)) + (define (record-type-opaque? rtd) (struct-ref rtd 4)) + (define (record-type-field-names rtd) (struct-ref rtd 6)) + + (define record-type-vtable + (make-vtable "prprprprprprprprpr" + (lambda (obj port) + (display "#<r6rs:record-type-vtable>" port)))) + + (define record-constructor-vtable + (make-vtable "prprpr" + (lambda (obj port) + (display "#<r6rs:record-constructor-vtable>" port)))) + + (define uid-table (make-hash-table)) + + (define (make-record-type-descriptor name parent uid sealed? opaque? fields) + (define fields-vtable + (make-vtable (fold-right (lambda (x p) + (string-append p (case (car x) + ((immutable) "pr") + ((mutable) "pw")))) + "prpr" (vector->list fields)) + (lambda (obj port) + (simple-format + port "#<r6rs:record-field-layout-vtable:~A>" name)))) + (define field-names (map cadr (vector->list fields))) + (define late-rtd #f) + (define (private-record-predicate obj) + (and (struct? obj) + (let* ((vtable (struct-vtable obj)) + (layout (symbol->string + (struct-ref vtable vtable-index-layout)))) + (and (>= (string-length layout) 3) + (let ((rtd (struct-ref obj 1))) + (and (record-type-descriptor? rtd) + (or (eq? (struct-ref rtd 7) fields-vtable) + (and=> (struct-ref obj 0) + private-record-predicate)))))))) + + (define (field-binder parent-struct . args) + (apply make-struct (append (list fields-vtable 0 + parent-struct + late-rtd) + args))) + (if (and parent (record-type-sealed? parent)) + (r6rs-raise (make-assertion-violation))) + + (let ((matching-rtd (and uid (hashq-ref uid-table uid)))) + (if matching-rtd + (if (equal? (list name + parent + sealed? + opaque? + field-names + (struct-ref fields-vtable vtable-index-layout)) + (list (record-type-name matching-rtd) + (record-type-parent matching-rtd) + (record-type-sealed? matching-rtd) + (record-type-opaque? matching-rtd) + (record-type-field-names matching-rtd) + (struct-ref (struct-ref matching-rtd 7) + vtable-index-layout))) + matching-rtd + (r6rs-raise (make-assertion-violation))) + + (let ((rtd (make-struct record-type-vtable 0 + + name + uid + parent + sealed? + opaque? + + private-record-predicate + field-names + fields-vtable + field-binder))) + (set! late-rtd rtd) + (if uid (hashq-set! uid-table uid rtd)) + rtd)))) + + (define (record-type-descriptor? obj) + (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable))) + + (define (make-record-constructor-descriptor rtd + parent-constructor-descriptor + protocol) + (define rtd-arity (length (struct-ref rtd 6))) + (define (default-inherited-protocol n) + (lambda args + (receive + (n-args p-args) + (split-at args (- (length args) rtd-arity)) + (let ((p (apply n n-args))) + (apply p p-args))))) + (define (default-protocol p) p) + + (let* ((prtd (struct-ref rtd 1)) + (pcd (or parent-constructor-descriptor + (and=> prtd (lambda (d) (make-record-constructor-descriptor + prtd #f #f))))) + (prot (or protocol (if pcd + default-inherited-protocol + default-protocol)))) + (make-struct record-constructor-vtable 0 rtd pcd prot))) + + (define (record-constructor rctd) + (let* ((rtd (struct-ref rctd 0)) + (parent-rctd (struct-ref rctd 1)) + (protocol (struct-ref rctd 2))) + (protocol + (if parent-rctd + (let ((parent-record-constructor (record-constructor parent-rctd)) + (parent-rtd (struct-ref parent-rctd 0))) + (lambda args + (let ((struct (apply parent-record-constructor args))) + (lambda args + (apply (struct-ref rtd 8) + (cons struct args)))))) + (lambda args (apply (struct-ref rtd 8) (cons #f args))))))) + + (define (record-predicate rtd) (struct-ref rtd 5)) + + (define (record-accessor rtd k) + (define (record-accessor-inner obj) + (and obj + (or (and (eq? (struct-ref obj 1) rtd) (struct-ref obj (+ k 2))) + (record-accessor-inner (struct-ref obj 0))))) + (lambda (obj) (record-accessor-inner obj))) + + (define (record-mutator rtd k) + (define (record-mutator-inner obj val) + (and obj + (or (and (eq? (struct-ref obj 1) rtd) (struct-set! obj (+ k 2) val)) + (record-mutator-inner (struct-ref obj 0) val)))) + (let* ((rtd-vtable (struct-ref rtd 7)) + (field-layout (symbol->string + (struct-ref rtd-vtable vtable-index-layout)))) + (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w)) + (r6rs-raise (make-assertion-violation)))) + (lambda (obj val) (record-mutator-inner obj val))) + + ;; Condition types that are used in the current library. These are defined + ;; here and not in (rnrs conditions) to avoid a circular dependency. + + (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#())) + (define &condition-constructor-descriptor + (make-record-constructor-descriptor &condition #f #f)) + + (define &serious (make-record-type-descriptor + '&serious &condition #f #f #f '#())) + (define &serious-constructor-descriptor + (make-record-constructor-descriptor + &serious &condition-constructor-descriptor #f)) + + (define make-serious-condition + (record-constructor &serious-constructor-descriptor)) + (define serious-condition? (record-predicate &serious)) + + (define &violation (make-record-type-descriptor + '&violation &serious #f #f #f '#())) + (define &violation-constructor-descriptor + (make-record-constructor-descriptor + &violation &serious-constructor-descriptor #f)) + (define make-violation (record-constructor &violation-constructor-descriptor)) + (define violation? (record-predicate &violation)) + + (define &assertion (make-record-type-descriptor + '&assertion &violation #f #f #f '#())) + (define make-assertion-violation + (record-constructor + (make-record-constructor-descriptor + &assertion &violation-constructor-descriptor #f))) + (define assertion-violation? (record-predicate &assertion)) + + ;; Exception wrapper type, along with a wrapping `throw' implementation. + ;; These are used in the current library, and so they are defined here and not + ;; in (rnrs exceptions) to avoid a circular dependency. + + (define &raise-object-wrapper + (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f + '#((immutable obj) (immutable continuation)))) + (define make-raise-object-wrapper + (record-constructor (make-record-constructor-descriptor + &raise-object-wrapper #f #f))) + (define raise-object-wrapper? (record-predicate &raise-object-wrapper)) + (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0)) + (define raise-object-wrapper-continuation + (record-accessor &raise-object-wrapper 1)) + + (define (r6rs-raise obj) + (throw 'r6rs:exception (make-raise-object-wrapper obj #f))) + (define (r6rs-raise-continuable obj) + (define (r6rs-raise-continuable-internal continuation) + (raise (make-raise-object-wrapper obj continuation))) + (call/cc r6rs-raise-continuable-internal)) +) diff --git a/module/rnrs/records/6/syntactic.scm b/module/rnrs/records/6/syntactic.scm new file mode 100644 index 000000000..838f56ac0 --- /dev/null +++ b/module/rnrs/records/6/syntactic.scm @@ -0,0 +1,200 @@ +;;; syntactic.scm --- Syntactic support for R6RS records + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs records syntactic (6)) + (export define-record-type) + (import (only (guile) *unspecified* unspecified? @ @@) + (rnrs base (6)) + (rnrs lists (6)) + (rnrs records procedural (6)) + (rnrs syntax-case (6)) + (only (srfi :1) take)) + + (define-syntax define-record-type + (lambda (stx) + (define (guess-constructor-name record-name) + (string->symbol (string-append "make-" (symbol->string record-name)))) + (define (guess-predicate-name record-name) + (string->symbol (string-append (symbol->string record-name) "?"))) + (syntax-case stx () + ((_ (record-name constructor-name predicate-name) record-clause ...) + #'(define-record-type0 + (record-name constructor-name predicate-name) + record-clause ...)) + ((_ record-name record-clause ...) + (let* ((record-name-sym (syntax->datum #'record-name)) + (constructor-name + (datum->syntax + #'record-name (guess-constructor-name record-name-sym))) + (predicate-name + (datum->syntax + #'record-name (guess-predicate-name record-name-sym)))) + #`(define-record-type0 + (record-name #,constructor-name #,predicate-name) + record-clause ...)))))) + + (define-syntax define-record-type0 + (lambda (stx) + (define (sequence n) + (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1))))) + (reverse (seq-inner n))) + (define (number-fields fields) + (define (number-fields-inner fields counter) + (if (null? fields) + '() + (cons (cons fields counter) + (number-fields-inner (cdr fields) (+ counter 1))))) + (number-fields-inner fields 0)) + + (define (process-fields record-name fields) + (define record-name-str (symbol->string record-name)) + (define (guess-accessor-name field-name) + (string->symbol (string-append + record-name-str "-" (symbol->string field-name)))) + (define (guess-mutator-name field-name) + (string->symbol + (string-append + record-name-str "-" (symbol->string field-name) "-set!"))) + + (define (f x) + (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f)) + ((not (list? x)) (error)) + ((eq? (car x) 'immutable) + (cons 'immutable + (case (length x) + ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f)) + ((3) (list (cadr x) (caddr x) #f)) + (else (error))))) + ((eq? (car x) 'mutable) + (cons 'mutable + (case (length x) + ((2) (list (cadr x) + (guess-accessor-name (cadr x)) + (guess-mutator-name (cadr x)))) + ((4) (cdr x)) + (else (error))))) + (else (error)))) + (map f fields)) + + (syntax-case stx () + ((_ (record-name constructor-name predicate-name) record-clause ...) + (let loop ((fields *unspecified*) + (parent *unspecified*) + (protocol *unspecified*) + (sealed *unspecified*) + (opaque *unspecified*) + (nongenerative *unspecified*) + (constructor *unspecified*) + (parent-rtd *unspecified*) + (record-clauses (syntax->datum #'(record-clause ...)))) + (if (null? record-clauses) + (let + ((field-names + (datum->syntax + #'record-name + (if (unspecified? fields) '() + (list->vector (map (lambda (x) (take x 2)) fields))))) + (field-accessors + (fold-left (lambda (x c lst) + (cons #`(define #,(datum->syntax + #'record-name (caddr x)) + (record-accessor record-name #,c)) + lst)) + '() fields (sequence (length fields)))) + (field-mutators + (fold-left (lambda (x c lst) + (if (cadddr x) + (cons #`(define #,(datum->syntax + #'record-name (cadddr x)) + (record-mutator record-name #,c)) + lst) + lst)) + '() fields (sequence (length fields)))) + (parent (datum->syntax + #'record-name (if (unspecified? parent) #f parent))) + (protocol (datum->syntax + #'record-name (if (unspecified? protocol) + #f protocol))) + (uid (datum->syntax + #'record-name (if (unspecified? nongenerative) + #f nongenerative))) + (sealed? (if (unspecified? sealed) #f sealed)) + (opaque? (if (unspecified? opaque) #f opaque)) + (parent-cd (datum->syntax + #'record-name (if (unspecified? parent-rtd) + #f (caddr parent-rtd)))) + (parent-rtd (datum->syntax + #'record-name (if (unspecified? parent-rtd) + #f (cadr parent-rtd))))) + + #`(begin + (define record-name + (make-record-type-descriptor + #,(datum->syntax + stx (list 'quote (syntax->datum #'record-name))) + #,parent #,uid #,sealed? #,opaque? + #,field-names)) + (define constructor-name + (record-constructor + (make-record-constructor-descriptor + record-name #,parent-cd #,protocol))) + (define predicate-name (record-predicate record-name)) + #,@field-accessors + #,@field-mutators)) + (let ((cr (car record-clauses))) + (case (car cr) + ((fields) + (if (unspecified? fields) + (loop (process-fields (syntax->datum #'record-name) + (cdr cr)) + parent protocol sealed opaque nongenerative + constructor parent-rtd (cdr record-clauses)) + (error))) + ((parent) (if (unspecified? parent) + (loop fields (cadr cr) protocol sealed opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (error))) + ((protocol) (if (unspecified? protocol) + (loop fields parent (cadr cr) sealed opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (error))) + ((sealed) (if (unspecified? sealed) + (loop fields parent protocol (cadr cr) opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (error))) + ((opaque) (if (unspecified? opaque) + (loop fields parent protocol sealed (cadr cr) + nongenerative constructor parent-rtd + (cdr record-clauses)) + (error))) + ((nongenerative) (if (unspecified? nongenerative) + (loop fields parent protocol sealed + opaque (cadr cr) constructor + parent-rtd (cdr record-clauses)) + (error))) + ((parent-rtd) (if (unspecified? parent-rtd) + (loop fields parent protocol sealed opaque + nongenerative constructor parent-rtd + (cdr record-clauses)) + (error))) + (else (error)))))))))) +) |