(module make-hash-struct mzscheme
(require (lib "etc.ss"))
(require-for-syntax (lib "etc.ss"))
(define-for-syntax (generate-n-temporaries n)
(generate-temporaries
(datum->syntax-object #f (build-list n (lambda (i) 'tmp)))))
(provide make-hash-struct)
(define-syntax (make-hash-struct stx)
(syntax-case stx ()
[(_ constructor-expr arity initial-vals-exprs mutators-exprs)
(begin
(unless (number? (syntax-e #'arity))
(raise-syntax-error
#f "not a literal number" stx #'arity))
(unless (= (length (syntax->list #'initial-vals-exprs))
(syntax-e #'arity))
(raise-syntax-error
#f "number of initial values must match arity" stx #'initial-vals-exprs))
(unless (= (length (syntax->list #'mutators-exprs))
(syntax-e #'arity))
(raise-syntax-error
#f "number of mutators must match arity" stx #'mutators-exprs))
(with-syntax ([(args-1 ...)
(generate-n-temporaries (syntax-e #'arity))]
[(args-2 ...)
(generate-n-temporaries (syntax-e #'arity))]
[(args ...)
(generate-n-temporaries (syntax-e #'arity))]
[(initial-vals-exprs ...) #'initial-vals-exprs]
[(mutators-exprs ...) #'mutators-exprs]
[(initial-vals ...)
(generate-n-temporaries
(length (syntax->list #'initial-vals-exprs)))]
[(mutators ...)
(generate-n-temporaries
(length (syntax->list #'mutators-exprs)))])
(syntax/loc stx
(local
((define constructor constructor-expr)
(define-values (initial-vals ... mutators ...)
(values initial-vals-exprs ...
mutators-exprs ...))
(define the-elt (constructor initial-vals ...))
(define ht (make-hash-table 'weak 'equal))
(define (initialize-the-elt! args-1 ...)
(mutators the-elt args-1) ...)
(define (add-to-hash&get! args-2 ...)
(let ([new-elt (constructor args-2 ...)])
(hash-table-put! ht new-elt (make-ephemeron new-elt (box new-elt)))
new-elt)))
(lambda (args ...)
(initialize-the-elt! args ...)
(let ([v (hash-table-get ht the-elt #f)])
(initialize-the-elt! initial-vals ...)
(cond
[v
(let ([v (ephemeron-value v)])
(cond
[v (unbox v)]
[else
(add-to-hash&get! args ...)]))]
[else
(add-to-hash&get! args ...)])))))))]
[else
(raise-syntax-error #f "needs arity, initial values, and mutators" stx)])))