diff --git a/buffer.rkt b/buffer.rkt index ac79502..88c5293 100644 --- a/buffer.rkt +++ b/buffer.rkt @@ -2,10 +2,8 @@ (require racket/generic racket/match racket/contract/base - (prefix-in A: ansi)) - -;; XXX these programs really need remix syntax or something like -;; define-generics-object + (prefix-in A: ansi) + "struct-define.rkt") (define-generics buffer (buffer-resize! buffer rows cols) @@ -148,10 +146,8 @@ (struct output-buffer (op [cells #:mutable]) #:methods gen:buffer [(define (buffer-resize! buf new-rows new-cols) - (set-output-buffer-cells! - buf - (maybe-make-cells (output-buffer-cells buf) - new-rows new-cols))) + (struct-define output-buffer buf) + (set! cells (maybe-make-cells cells new-rows new-cols))) (define (buffer-start! buf draw-rows draw-cols) (buffer-resize! buf draw-rows draw-cols) (define cs (output-buffer-cells buf)) diff --git a/struct-define.rkt b/struct-define.rkt new file mode 100644 index 0000000..38945a1 --- /dev/null +++ b/struct-define.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info + syntax/parse)) + +(define-syntax (struct-define stx) + (syntax-parse stx + [(_ the-struct the-instance:expr) + #:declare the-struct + (static struct-info? "structure type transformer binding") + #:do [(define struct+-len + (add1 (string-length (symbol->string (syntax->datum #'the-struct))))) + (define si (extract-struct-info (attribute the-struct.value)))] + #:with ([field-name field-ref field-set!] ...) + (for/list ([field-ref (in-list (list-ref si 3))] + [field-set (in-list (list-ref si 4))]) + (define field-ref-s + (symbol->string (syntax->datum field-ref))) + (define field-name-s + (substring field-ref-s struct+-len)) + (define field-name + (datum->syntax stx (string->symbol field-name-s))) + (list field-name field-ref field-set)) + #:with (field-val-id ...) + (generate-temporaries #'(field-name ...)) + + (syntax/loc stx + (begin (define the-instance-id the-instance) + (define-syntax field-name + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! id v) + (if (syntax->datum #'field-set!) + (quasisyntax/loc stx + (field-set! the-instance-id v)) + (raise-syntax-error 'set! "field not mutable" stx #'id))] + [id (identifier? #'id) + (syntax/loc stx + (field-ref the-instance-id))])))) + ...))])) + +(provide struct-define)