diff options
Diffstat (limited to 'module/srfi/srfi-9.scm')
-rw-r--r-- | module/srfi/srfi-9.scm | 61 |
1 files changed, 34 insertions, 27 deletions
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index 324fe9cee..355362af4 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -144,6 +144,7 @@ (display ">" p)) (define (throw-bad-struct s who) + #((definite-bailout? . #t)) (throw 'wrong-type-arg who "Wrong type argument: ~S" (list s) (list s))) @@ -159,7 +160,8 @@ ((_ type-name (getter-id ...) check? s (getter expr) ...) (every identifier? #'(getter ...)) (let ((copier-name (syntax->datum (make-copier-id #'type-name))) - (getter+exprs #'((getter expr) ...))) + (getter+exprs #'((getter expr) ...)) + (nfields (length #'(getter-id ...)))) (define (lookup id default-expr) (let ((results (filter (lambda (g+e) @@ -178,12 +180,16 @@ copier-name "unknown getter" x id))) #'(getter ...)) (with-syntax ((unsafe-expr - #`(make-struct - type-name 0 - #,@(map (lambda (getter index) - (lookup getter #`(struct-ref s #,index))) - #'(getter-id ...) - (iota (length #'(getter-id ...))))))) + #`(let ((new (allocate-struct type-name #,nfields))) + #,@(map (lambda (getter index) + #`(struct-set! + new + #,index + #,(lookup getter + #`(struct-ref s #,index)))) + #'(getter-id ...) + (iota nfields)) + new))) (if (syntax->datum #'check?) #`(if (eq? (struct-vtable s) type-name) unsafe-expr @@ -207,26 +213,27 @@ ((name getter setter) #'getter))) field-specs)) - (define (constructor form type-name constructor-spec field-names) + (define (constructor form type-name constructor-spec field-ids) (syntax-case constructor-spec () ((ctor field ...) (every identifier? #'(field ...)) - (let ((ctor-args (map (lambda (field) - (let ((name (syntax->datum field))) - (or (memq name field-names) - (syntax-violation - (syntax-case form () - ((macro . args) - (syntax->datum #'macro))) - "unknown field in constructor spec" - form field)) - (cons name field))) - #'(field ...)))) + (let ((slots (map (lambda (field) + (or (list-index (lambda (x) + (free-identifier=? x field)) + field-ids) + (syntax-violation + (syntax-case form () + ((macro . args) + (syntax->datum #'macro))) + "unknown field in constructor spec" + form field))) + #'(field ...)))) #`(define-inlinable #,constructor-spec - (make-struct #,type-name 0 - #,@(map (lambda (name) - (assq-ref ctor-args name)) - field-names))))))) + (let ((s (allocate-struct #,type-name #,(length field-ids)))) + #,@(map (lambda (arg slot) + #`(struct-set! s #,slot #,arg)) + #'(field ...) slots) + s)))))) (define (getters type-name getter-ids copier-id) (map (lambda (getter index) @@ -270,8 +277,9 @@ (iota (length field-specs)))) (define (record-layout immutable? count) - (let ((desc (if immutable? "pr" "pw"))) - (string-concatenate (make-list count desc)))) + ;; Mutability is expressed on the record level; all structs in the + ;; future will be mutable. + (string-concatenate (make-list count "pw"))) (syntax-case x () ((_ immutable? form type-name constructor-spec predicate-name @@ -303,12 +311,11 @@ (field-count (length field-ids)) (immutable? (syntax->datum #'immutable?)) (layout (record-layout immutable? field-count)) - (field-names (map syntax->datum field-ids)) (ctor-name (syntax-case #'constructor-spec () ((ctor args ...) #'ctor))) (copier-id (make-copier-id #'type-name))) #`(begin - #,(constructor #'form #'type-name #'constructor-spec field-names) + #,(constructor #'form #'type-name #'constructor-spec field-ids) (define type-name (let ((rtd (make-struct/no-tail |