Skip to content

Instantly share code, notes, and snippets.

Created July 28, 2011 18:01
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save anonymous/1112122 to your computer and use it in GitHub Desktop.
Save anonymous/1112122 to your computer and use it in GitHub Desktop.
#lang racket
(require (for-syntax racket/struct-info))
(require rackunit)
;; (increment! a-struct type field [amount 1]) -> void
;; increments a mutable field in a structure
(define-syntax (increment! stx)
(syntax-case stx ()
[(_ s sn fn i)
(with-syntax ([(_ _ _ getters setters _)
(extract-struct-info (syntax-local-value #'sn))])
(let ([seek (string->symbol
(format "~a-~a" (syntax-e #'sn) (syntax-e #'fn)))])
(let iter ([gets (syntax->list #'getters)] [sets (syntax->list #'setters)])
(cond [(null? gets)
(raise-syntax-error #f "unknown field-name" stx)]
[(eq? (syntax-e (car gets)) seek)
(if (identifier? (car sets))
(with-syntax ([set! (car sets)] [get (car gets)])
#'(set! s (+ i (get s))))
(raise-syntax-error #f (format "~s not mutable" (syntax-e #'fn)) stx))]
[else
(iter (cdr gets) (cdr sets))]))))]
[(increment! s sn fn) #'(increment! s sn fn 1)]))
(struct vault ([dollars #:mutable]
pounds
[euros #:mutable]))
(define v (vault 0 50 20))
(increment! v vault dollars 100)
(increment! v vault euros)
(test-case "sums"
(check-equal? (vault-dollars v) 100)
(check-equal? (vault-euros v) 21))
;(test-exn "not mutable" exn:fail:syntax? (λ () (increment! v vault pounds)))
;(test-exn "unknown name" exn:fail:syntax? (λ () (increment! v vault yen)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment