diff options
Diffstat (limited to 'src/guile')
| -rw-r--r-- | src/guile/de-paul-records.scm | 38 |
1 files changed, 29 insertions, 9 deletions
diff --git a/src/guile/de-paul-records.scm b/src/guile/de-paul-records.scm index 57d65e5..4b4e91b 100644 --- a/src/guile/de-paul-records.scm +++ b/src/guile/de-paul-records.scm @@ -107,8 +107,8 @@ #'args-rest))))))) (define-immutable-record-type <field-init> (make-field-init) field-init? - (name field-init-name field-init-set-name) - (value-expr field-init-value-expr field-init-set-value-expr)) + (name field-init-name field-init-set-name) + (make-value-expr field-init-make-value-expr field-init-set-make-value-expr)) (define %null-field-init (make-field-init)) @@ -119,10 +119,28 @@ (identifier? #'field-name) (set-fields %null-field-init ((field-init-name) #'field-name) - ((field-init-value-expr) #'value-expr))) + ((field-init-make-value-expr) (const #'value-expr)))) + (field-name (identifier? #'field-name) - (syntax->field-init #'(field-name field-name))))) + (syntax->field-init #'(field-name field-name))) + + ((field-name #:=> value-update-proc) + (identifier? #'field-name) + (set-fields %null-field-init + ((field-init-name) #'field-name) + ((field-init-make-value-expr) + (lambda (record-name record-base) + #`(value-update-proc + (#,(format-identifiers "~a-~a" record-name #'field-name) + #,record-base)))))) + + ((field-name #:-> value-update-expr) + (identifier? #'field-name) + (syntax->field-init #'(field-name #:=> (lambda (field-name) + value-update-expr)))))) + + (define-immutable-record-type <record-init> (make-record-init) record-init? (inherit record-init-inherit record-init-set-inherit) @@ -156,12 +174,14 @@ (match init-form ((= syntax->record-init (and (= record-init-inherit inherit) (= record-init-fields field-inits))) - #`(let* (#,@(map (match-lambda - ((and (= field-init-name field-name) - (= field-init-value-expr value-expr)) - #`(#,field-name #,value-expr))) + #`(let* ((base #,(or inherit %null-record)) + #,@(map (match-lambda + ((and (= field-init-name field-name) + (= field-init-make-value-expr make-value-expr)) + #`(#,field-name + #,(make-value-expr record-name #'base)))) field-inits)) - (set-fields #,(or inherit %null-record) + (set-fields base #,@(map (match-lambda ((= field-init-name field-name) #`((#,(format-identifiers "~a-~a" |