aa9bba9328
Move "racket/src/cs/bootstrap" from the Racket source repository to this one, because the bootstrapping implementation needs to track the Chez Scheme source much more closely than the Racket implementation. Currently, any Racket v7.1 or later works. Also update "README.md" and "BUILDING" to get all the information consistent and in sync with revised build options. original commit: a9e6e99ea414b4625fe9705e4f3cfd62bbf38ae2
69 lines
2.3 KiB
Racket
69 lines
2.3 KiB
Racket
#lang racket/base
|
|
(require "scheme-struct.rkt"
|
|
(for-template racket/base))
|
|
|
|
(provide rcd->constructor
|
|
(struct-out rcd-info)
|
|
rcd->rcdi)
|
|
|
|
(define (rcd->constructor rcd lookup-protocol)
|
|
(define rtd (rec-cons-desc-rtd rcd))
|
|
(define ctr (struct-type-make-constructor rtd))
|
|
((record-constructor-generator rcd lookup-protocol) ctr))
|
|
|
|
(define (record-constructor-generator rcd lookup-protocol)
|
|
(define rtd (rec-cons-desc-rtd rcd))
|
|
(define p (rec-cons-desc-protocol rcd))
|
|
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
|
(struct-type-info rtd))
|
|
(cond
|
|
[(not p) (lambda (ctr) ctr)]
|
|
[(rec-cons-desc-parent-rcd rcd)
|
|
=> (lambda (p-rcd)
|
|
(define p-gen (record-constructor-generator p-rcd lookup-protocol))
|
|
(and p-gen
|
|
(lambda (ctr)
|
|
(p (p-gen
|
|
(lambda args1
|
|
(lambda args2
|
|
(apply ctr (append args1 args2)))))))))]
|
|
[(and super (not lookup-protocol)) #f]
|
|
[super
|
|
(define parent-p (lookup-protocol super))
|
|
(lambda (ctr)
|
|
(p (parent-p
|
|
(lambda args1
|
|
(lambda args2
|
|
(apply ctr (append args1 args2)))))))]
|
|
[else p]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(struct rcd-info (rtd proto-expr base-rcdi init-cnt)
|
|
#:transparent)
|
|
|
|
(define (rcd->rcdi rcd)
|
|
(cond
|
|
[(rec-cons-desc-parent-rcd rcd)
|
|
=> (lambda (p-rcd)
|
|
(define p-rcdi (rcd->rcdi p-rcd))
|
|
(and p-rcdi
|
|
(let ()
|
|
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
|
(struct-type-info (rec-cons-desc-rtd rcd)))
|
|
(define proto (rec-cons-desc-protocol rcd))
|
|
(rcd-info (rec-cons-desc-rtd rcd)
|
|
proto
|
|
p-rcdi
|
|
(+ init-cnt
|
|
(rcd-info-init-cnt p-rcdi))))))]
|
|
[else
|
|
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
|
(struct-type-info (rec-cons-desc-rtd rcd)))
|
|
(define proto (rec-cons-desc-protocol rcd))
|
|
(and (not super)
|
|
(rcd-info (rec-cons-desc-rtd rcd)
|
|
proto
|
|
#f
|
|
init-cnt))]))
|