-(define* (make-syntactic-constructor type name ctor fields
- #:key (thunked '()) (defaults '())
- (delayed '()))
- "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
-all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
-tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is
-the list of identifiers of delayed fields."
- (with-syntax ((type type)
- (name name)
- (ctor ctor)
- (expected fields)
- (defaults defaults))
- #`(define-syntax name
- (lambda (s)
- (define (record-inheritance orig-record field+value)
- ;; Produce code that returns a record identical to ORIG-RECORD,
- ;; except that values for the FIELD+VALUE alist prevail.
- (define (field-inherited-value f)
- (and=> (find (lambda (x)
- (eq? f (car (syntax->datum x))))
- field+value)
- car))
-
- ;; Make sure there are no unknown field names.
- (let* ((fields (map (compose car syntax->datum) field+value))
- (unexpected (lset-difference eq? fields 'expected)))
- (when (pair? unexpected)
- (record-error 'name s "extraneous field initializers ~a"
- unexpected)))
-
- #`(make-struct type 0
- #,@(map (lambda (field index)
- (or (field-inherited-value field)
- #`(struct-ref #,orig-record
- #,index)))
- 'expected
- (iota (length 'expected)))))
-
- (define (thunked-field? f)
- (memq (syntax->datum f) '#,thunked))
-
- (define (delayed-field? f)
- (memq (syntax->datum f) '#,delayed))
-
- (define (wrap-field-value f value)
- (cond ((thunked-field? f)
- #`(lambda () #,value))
- ((delayed-field? f)
- #`(delay #,value))
- (else value)))
-
- (define (field-bindings field+value)
- ;; Return field to value bindings, for use in 'let*' below.
- (map (lambda (field+value)
- (syntax-case field+value ()
- ((field value)
- #`(field
- #,(wrap-field-value #'field #'value)))))
- field+value))
-
- (syntax-case s (inherit #,@fields)
- ((_ (inherit orig-record) (field value) (... ...))
- #`(let* #,(field-bindings #'((field value) (... ...)))
- #,(record-inheritance #'orig-record
- #'((field value) (... ...)))))
- ((_ (field value) (... ...))
- (let ((fields (map syntax->datum #'(field (... ...))))
- (dflt (map (match-lambda
- ((f v)
- (list (syntax->datum f) v)))
- #'defaults)))
-
- (define (field-value f)
- (or (and=> (find (lambda (x)
- (eq? f (car (syntax->datum x))))
+(eval-when (expand load eval)
+ ;; The procedures below are needed both at run time and at expansion time.
+
+ (define (current-abi-identifier type)
+ "Return an identifier unhygienically derived from TYPE for use as its
+\"current ABI\" variable."
+ (let ((type-name (syntax->datum type)))
+ (datum->syntax
+ type
+ (string->symbol
+ (string-append "% " (symbol->string type-name)
+ " abi-cookie")))))
+
+ (define (abi-check type cookie)
+ "Return syntax that checks that the current \"application binary
+interface\" (ABI) for TYPE is equal to COOKIE."
+ (with-syntax ((current-abi (current-abi-identifier type)))
+ #`(unless (eq? current-abi #,cookie)
+ ;; The source file where this exception is thrown must be
+ ;; recompiled.
+ (throw 'record-abi-mismatch-error 'abi-check
+ "~a: record ABI mismatch; recompilation needed"
+ (list #,type) '()))))
+
+ (define* (report-invalid-field-specifier name bindings
+ #:optional parent-form)
+ "Report the first invalid binding among BINDINGS. PARENT-FORM is used for
+error-reporting purposes."
+ (let loop ((bindings bindings))
+ (syntax-case bindings ()
+ (((field value) rest ...) ;good
+ (loop #'(rest ...)))
+ ((weird _ ...) ;weird!
+ ;; WEIRD may be an identifier, thus lacking source location info, and
+ ;; BINDINGS is a list, also lacking source location info. Hopefully
+ ;; PARENT-FORM provides source location info.
+ (apply syntax-violation name "invalid field specifier"
+ (if parent-form
+ (list parent-form #'weird)
+ (list #'weird)))))))
+
+ (define (report-duplicate-field-specifier name ctor)
+ "Report the first duplicate identifier among the bindings in CTOR."
+ (syntax-case ctor ()
+ ((_ bindings ...)
+ (let loop ((bindings #'(bindings ...))
+ (seen '()))
+ (syntax-case bindings ()
+ (((field value) rest ...)
+ (not (memq (syntax->datum #'field) seen))
+ (loop #'(rest ...) (cons (syntax->datum #'field) seen)))
+ ((duplicate rest ...)
+ (syntax-violation name "duplicate field initializer"
+ #'duplicate))
+ (()
+ #t)))))))
+
+(define-syntax-parameter this-record
+ (lambda (s)
+ "Return the record being defined. This macro may only be used in the
+context of the definition of a thunked field."
+ (syntax-case s ()
+ (id
+ (identifier? #'id)
+ (syntax-violation 'this-record
+ "cannot be used outside of a record instantiation"
+ #'id)))))
+
+(define-syntax make-syntactic-constructor
+ (syntax-rules ()
+ "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
+expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
+FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
+fields, and DELAYED is the list of identifiers of delayed fields.
+
+ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
+of TYPE matches the expansion-time ABI."
+ ((_ type name ctor (expected ...)
+ #:abi-cookie abi-cookie
+ #:thunked thunked
+ #:this-identifier this-identifier
+ #:delayed delayed
+ #:innate innate
+ #:defaults defaults)
+ (define-syntax name
+ (lambda (s)
+ (define (record-inheritance orig-record field+value)
+ ;; Produce code that returns a record identical to ORIG-RECORD,
+ ;; except that values for the FIELD+VALUE alist prevail.
+ (define (field-inherited-value f)
+ (and=> (find (lambda (x)
+ (eq? f (car (syntax->datum x))))
+ field+value)
+ car))
+
+ ;; Make sure there are no unknown field names.
+ (let* ((fields (map (compose car syntax->datum) field+value))
+ (unexpected (lset-difference eq? fields '(expected ...))))
+ (when (pair? unexpected)
+ (record-error 'name s "extraneous field initializers ~a"
+ unexpected)))
+
+ #`(make-struct/no-tail type
+ #,@(map (lambda (field index)
+ (or (field-inherited-value field)
+ (if (innate-field? field)
+ (wrap-field-value
+ field (field-default-value field))
+ #`(struct-ref #,orig-record
+ #,index))))
+ '(expected ...)
+ (iota (length '(expected ...))))))
+
+ (define (thunked-field? f)
+ (memq (syntax->datum f) 'thunked))
+
+ (define (delayed-field? f)
+ (memq (syntax->datum f) 'delayed))
+
+ (define (innate-field? f)
+ (memq (syntax->datum f) 'innate))
+
+ (define (wrap-field-value f value)
+ (cond ((thunked-field? f)
+ #`(lambda (x)
+ (syntax-parameterize ((#,this-identifier
+ (lambda (s)
+ (syntax-case s ()
+ (id
+ (identifier? #'id)
+ #'x)))))
+ #,value)))
+ ((delayed-field? f)
+ #`(delay #,value))
+ (else value)))
+
+ (define default-values
+ ;; List of symbol/value tuples.
+ (map (match-lambda
+ ((f v)
+ (list (syntax->datum f) v)))
+ #'defaults))
+
+ (define (field-default-value f)
+ (car (assoc-ref default-values (syntax->datum f))))
+
+ (define (field-bindings field+value)
+ ;; Return field to value bindings, for use in 'let*' below.
+ (map (lambda (field+value)
+ (syntax-case field+value ()
+ ((field value)
+ #`(field
+ #,(wrap-field-value #'field #'value)))))
+ field+value))
+
+ (syntax-case s (inherit expected ...)
+ ((_ (inherit orig-record) (field value) (... ...))
+ #`(let* #,(field-bindings #'((field value) (... ...)))
+ #,(abi-check #'type abi-cookie)
+ #,(record-inheritance #'orig-record
+ #'((field value) (... ...)))))
+ ((_ (field value) (... ...))
+ (let ((fields (map syntax->datum #'(field (... ...)))))
+ (define (field-value f)
+ (or (find (lambda (x)
+ (eq? f (syntax->datum x)))
+ #'(field (... ...)))
+ (wrap-field-value f (field-default-value f))))
+
+ ;; Pass S to make sure source location info is preserved.
+ (report-duplicate-field-specifier 'name s)
+
+ (let ((fields (append fields (map car default-values))))
+ (cond ((lset= eq? fields '(expected ...))
+ #`(let* #,(field-bindings