compatibility/collects/mzlib/struct.ss
Matthew Flatt ada948ed61 .
original commit: aa19749bb33cb757a5b6f331669eb0f9f76304d5
2005-01-14 20:42:50 +00:00

60 lines
1.9 KiB
Scheme

;; by Jacob Matthews
(module struct mzscheme
(provide copy-struct)
(require-for-syntax (lib "struct.ss" "syntax")
(lib "stx.ss" "syntax"))
(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))))))])))