public
anonymous / gist:1112122
Created

  • Download Gist
gistfile1.rkt
Racket
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
#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)))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.