suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: dd0ba73e796b2740efe4501753feece1bc8eb079
This commit is contained in:
Matthew Flatt 2005-01-14 21:06:43 +00:00
parent ada948ed61
commit 1ec734b5d8
2 changed files with 92 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mzlib/struct.ss
View File

@ -7,7 +7,17 @@
(require-for-syntax (lib "struct.ss" "syntax")
(lib "stx.ss" "syntax"))
;; copy-struct expands to `do-copy-struct' to delay the expansion
;; in an internal-definition context. (The `begin0' wrapper
;; effectively declares the form to be an expression.)
(define-syntax (copy-struct stx)
(syntax-case stx ()
[_ #'(begin0 (do-copy-struct _))]))
(define-syntax (do-copy-struct dstx)
(syntax-case dstx ()
[(_ stx)
(let ([stx #'stx])
(syntax-case stx ()
[(_ info structure (accessor-name new-val) ...)
(let ([ans (syntax->list #'((accessor-name new-val) ...))])
@ -55,6 +65,6 @@
#,@(map
(lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
(reverse accessors)))
(raise-type-error '_ #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))])))
(raise-type-error '_ #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))]))])))

35
collects/tests/mzscheme/structlib.ss Normal file
View File

@ -0,0 +1,35 @@
(load-relative "loadtest.ss")
(SECTION 'structlib)
(require (lib "struct.ss"))
(let ([now (seconds->date (current-seconds))])
(test #t equal? now (copy-struct date now))
(test #f equal? now (copy-struct date now (date-second -1)))
(test -1 date-second (copy-struct date now (date-second -1)))
(test (date-year now) date-year (copy-struct date now (date-second -1))))
(err/rt-test (copy-struct date 10))
(err/rt-test (copy-struct date 10 (date-second 0)))
(syntax-test #'copy-struct)
(syntax-test #'(copy-struct))
(syntax-test #'(copy-struct date))
(syntax-test #'(copy-struct date 10 foo))
(syntax-test #'(copy-struct date 10 . foo))
(syntax-test #'(copy-struct date 10 (foo)))
(syntax-test #'(copy-struct date 10 (foo . bar)))
(syntax-test #'(copy-struct x 10))
(syntax-test #'(copy-struct date 10 (date-foo 12)))
(syntax-test #'(copy-struct date 10 (date-second 12) (date-yeeer 10)))
(let ([v (let ()
(define-struct a (b c) (make-inspector))
;; This `copy-struct' is expanded in an internal-defn context
(copy-struct a (make-a 1 2) (a-c 13)))])
(test #(struct:a 1 13) struct->vector v))
(report-errs)