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

104
collects/mzlib/struct.ss
View File

@ -7,54 +7,64 @@
(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 ()
[(_ info structure (accessor-name new-val) ...)
(let ([ans (syntax->list #'((accessor-name new-val) ...))])
(unless (identifier? #'info)
(raise-syntax-error #f "not an identifier for structure type" stx #'info))
(for-each (lambda (an)
(unless (identifier? (stx-car an))
(raise-syntax-error #f "not an identifier for accessor name" stx (stx-car an))))
ans)
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
(let ((new-binding-for
(lambda (f)
(ormap (lambda (x)
(if (eq? (syntax-object->datum (stx-car x)) (syntax-object->datum f))
(cadr (syntax-e x))
#f))
ans))))
(let-values ([(construct pred accessors)
(let ([v (syntax-local-value #'info (lambda () #f))])
(unless (struct-declaration-info? v)
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
(values (cadr v)
(caddr v)
(cadddr v)))]
[(as) (map (lambda (an) (stx-car an)) ans)])
(for-each
(lambda (field)
(unless (ormap (lambda (f2) (module-or-top-identifier=? field f2)) accessors)
(raise-syntax-error #f "accessor name not associated with the given structure type" stx field)))
as)
(let ((dupe (check-duplicate-identifier as)))
(when dupe
(raise-syntax-error #f
"duplicate field assignment"
stx
dupe)))
;; the actual result
#`(let ((the-struct structure))
(if (#,pred the-struct)
(#,construct
#,@(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))))))])))
[_ #'(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) ...))])
(unless (identifier? #'info)
(raise-syntax-error #f "not an identifier for structure type" stx #'info))
(for-each (lambda (an)
(unless (identifier? (stx-car an))
(raise-syntax-error #f "not an identifier for accessor name" stx (stx-car an))))
ans)
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
(let ((new-binding-for
(lambda (f)
(ormap (lambda (x)
(if (eq? (syntax-object->datum (stx-car x)) (syntax-object->datum f))
(cadr (syntax-e x))
#f))
ans))))
(let-values ([(construct pred accessors)
(let ([v (syntax-local-value #'info (lambda () #f))])
(unless (struct-declaration-info? v)
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
(values (cadr v)
(caddr v)
(cadddr v)))]
[(as) (map (lambda (an) (stx-car an)) ans)])
(for-each
(lambda (field)
(unless (ormap (lambda (f2) (module-or-top-identifier=? field f2)) accessors)
(raise-syntax-error #f "accessor name not associated with the given structure type" stx field)))
as)
(let ((dupe (check-duplicate-identifier as)))
(when dupe
(raise-syntax-error #f
"duplicate field assignment"
stx
dupe)))
;; the actual result
#`(let ((the-struct structure))
(if (#,pred the-struct)
(#,construct
#,@(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))))))]))])))

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)