diff --git a/lang/whalesong.rkt b/lang/whalesong.rkt index 9a6ff26..9b96d14 100644 --- a/lang/whalesong.rkt +++ b/lang/whalesong.rkt @@ -6,6 +6,8 @@ ;; * Automatically running tests ;; * Annotating all applications so they produce stack traces on error ;; * Adding the "shared" form by default. +;; * define-struct automatically has #:transparent and #:mutable + (require "base.rkt" "private/traced-app.rkt" @@ -19,9 +21,11 @@ (provide (except-out (all-from-out "base.rkt") #%app - #%module-begin) + #%module-begin + define-struct) (rename-out [traced-app #%app] - [my-module-begin #%module-begin]) + [my-module-begin #%module-begin] + [my-define-struct define-struct]) shared (all-from-out "bool.rkt") (except-out (all-from-out "check-expect/check-expect.rkt") @@ -34,4 +38,23 @@ [(_ body ...) (syntax/loc stx (#%module-begin body ... - (run-tests)))])) \ No newline at end of file + (run-tests)))])) + + + +(define-syntax (my-define-struct stx) + (syntax-case stx () + [(_ id (fields ...) options ...) + (let* ([new-options (syntax->list #'(options ...))] + [new-options (cond [(memq '#:transparent (map syntax-e new-options)) + new-options] + [else + (cons (syntax #:transparent) new-options)])] + [new-options (cond [(memq '#:mutable (map syntax-e new-options)) + new-options] + [else + (cons (syntax #:mutable) new-options)])]) + (with-syntax [((new-options ...) new-options)] + (syntax/loc stx + (define-struct id (fields ...) new-options ...))))])) +