diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 240b9ebc35..a8ff36fd38 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -179,6 +179,31 @@ (values out #'rest #t)]))) (provide honu-dot) +(define-honu-fixture honu-dot + (lambda (left rest) + (syntax-parse rest #:literal-sets (cruft) + #:literals (honu-assignment) + [(_ name:identifier honu-assignment argument:honu-expression . more) + (with-syntax ([left left]) + (values #'(%racket + (let ([left* left]) + (cond + [(honu-struct? left*) + (honu-struct-set! left* 'name argument.result)] + [(object? left*) (error 'set "implement set for objects")]))) + #'more))] + [(_ name:identifier . more) + (with-syntax ([left left]) + (values #'(%racket + (let ([left* left]) + (cond + [(honu-struct? left*) (let ([use (honu-struct-get left*)]) + (use left* 'name))] + [(object? left*) (get-field name left*)] + ;; possibly handle other types of data + [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))) + #'more))]))) +#; (define-honu-operator/syntax honu-dot 10000 'left (lambda (left right) (debug "dot left ~a right ~a\n" left right) diff --git a/collects/honu/core/private/struct.rkt b/collects/honu/core/private/struct.rkt index 311faa0833..70953906a2 100644 --- a/collects/honu/core/private/struct.rkt +++ b/collects/honu/core/private/struct.rkt @@ -12,10 +12,21 @@ (define-values (honu-struct honu-struct? honu-struct-get) (make-struct-type-property 'honu-struct)) +(define-values (honu-struct-mutable honu-struct-mutable? honu-struct-mutate) + (make-struct-type-property 'honu-struct-mutable)) + (define-for-syntax (make-accessors name fields) (for/list ([field fields]) (format-unique-id name "~a-~a" name field))) +(define-for-syntax (make-mutators name fields) + (for/list ([field fields]) + (format-unique-id name "set-~a-~a!" name field))) + +(provide honu-struct-set!) +(define (honu-struct-set! instance name value) + ((honu-struct-mutate instance) instance name value)) + (provide honu-structure) (define-honu-syntax honu-structure (lambda (code context) @@ -23,9 +34,18 @@ [(_ name:id (#%braces fields:identifier-comma-list) . rest) (define out (with-syntax ([(fields.name/accessor ...) - (make-accessors #'name (syntax->list #'(fields.name ...)))]) + (make-accessors #'name (syntax->list #'(fields.name ...)))] + [(fields.name/mutator ...) + (make-mutators #'name (syntax->list #'(fields.name ...)))]) #'(%racket (struct name (fields.name ...) #:transparent + #:mutable + #:property honu-struct-mutable + (lambda (instance name value) + (case name + [(fields.name) (fields.name/mutator instance value)] + ... + [else (error 'dot "no such field name ~a" name)])) #:property honu-struct (lambda (instance name) (case name [(fields.name) (fields.name/accessor instance)]