mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source
This commit is contained in:
Mark H Weaver 2012-11-09 23:09:38 -05:00
commit ad84cc8b84
3 changed files with 288 additions and 134 deletions
Download patch file Download diff file Expand all files Collapse all files

44
module/srfi/srfi-9.scm
View file

@ -205,8 +205,10 @@
(let ((name (syntax->datum field))) (let ((name (syntax->datum field)))
(or (memq name field-names) (or (memq name field-names)
(syntax-violation (syntax-violation
'define-record-type (syntax-case form ()
"unknown field in constructor-spec" ((macro . args)
(syntax->datum #'macro)))
"unknown field in constructor spec"
form field)) form field))
(cons name field))) (cons name field)))
#'(field ...)))) #'(field ...))))
@ -262,9 +264,30 @@
(string-concatenate (make-list count desc)))) (string-concatenate (make-list count desc))))
(syntax-case x () (syntax-case x ()
((_ immutable? type-name constructor-spec predicate-name ((_ immutable? form type-name constructor-spec predicate-name
field-spec ...) field-spec ...)
(boolean? (syntax->datum #'immutable?)) (let ()
(define (syntax-error message subform)
(syntax-violation (syntax-case #'form ()
((macro . args) (syntax->datum #'macro)))
message #'form subform))
(and (boolean? (syntax->datum #'immutable?))
(or (identifier? #'type-name)
(syntax-error "expected type name" #'type-name))
(syntax-case #'constructor-spec ()
((ctor args ...)
(every identifier? #'(ctor args ...))
#t)
(_ (syntax-error "invalid constructor spec"
#'constructor-spec)))
(or (identifier? #'predicate-name)
(syntax-error "expected predicate name" #'predicate-name))
(every (lambda (spec)
(syntax-case spec ()
((field getter) #t)
((field getter setter) #t)
(_ (syntax-error "invalid field spec" spec))))
#'(field-spec ...))))
(let* ((field-ids (field-identifiers #'(field-spec ...))) (let* ((field-ids (field-identifiers #'(field-spec ...)))
(getter-ids (getter-identifiers #'(field-spec ...))) (getter-ids (getter-identifiers #'(field-spec ...)))
(field-count (length field-ids)) (field-count (length field-ids))
@ -275,7 +298,7 @@
((ctor args ...) #'ctor))) ((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name))) (copier-id (make-copier-id #'type-name)))
#`(begin #`(begin
#,(constructor x #'type-name #'constructor-spec field-names) #,(constructor #'form #'type-name #'constructor-spec field-names)
(define type-name (define type-name
(let ((rtd (make-struct/no-tail (let ((rtd (make-struct/no-tail
@ -296,9 +319,16 @@
#,(copier #'type-name getter-ids copier-id) #,(copier #'type-name getter-ids copier-id)
#,@(if immutable? #,@(if immutable?
(functional-setters copier-id #'(field-spec ...)) (functional-setters copier-id #'(field-spec ...))
(setters #'type-name #'(field-spec ...))))))))) (setters #'type-name #'(field-spec ...))))))
((_ immutable? form . rest)
(syntax-violation
(syntax-case #'form ()
((macro . args) (syntax->datum #'macro)))
"invalid record definition syntax"
#'form)))))
(define-syntax-rule (define-record-type name ctor pred fields ...) (define-syntax-rule (define-record-type name ctor pred fields ...)
(%define-record-type #f name ctor pred fields ...)) (%define-record-type #f (define-record-type name ctor pred fields ...)
name ctor pred fields ...))
;;; srfi-9.scm ends here ;;; srfi-9.scm ends here

4
module/srfi/srfi-9/gnu.scm
View file

@ -34,7 +34,9 @@
(struct-set! type vtable-index-printer thunk)) (struct-set! type vtable-index-printer thunk))
(define-syntax-rule (define-immutable-record-type name ctor pred fields ...) (define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
((@@ (srfi srfi-9) %define-record-type) #t name ctor pred fields ...)) ((@@ (srfi srfi-9) %define-record-type)
#t (define-immutable-record-type name ctor pred fields ...)
name ctor pred fields ...))
(define-syntax-rule (set-field (getter ...) s expr) (define-syntax-rule (set-field (getter ...) s expr)
(%set-fields #t (set-field (getter ...) s expr) () (%set-fields #t (set-field (getter ...) s expr) ()

374
test-suite/tests/srfi-9.test
View file

@ -118,7 +118,10 @@
(pass-if-exception "set-field on number" exception:wrong-type-arg (pass-if-exception "set-field on number" exception:wrong-type-arg
(set-field (foo-x bar-j) 4 3)) (set-field (foo-x bar-j) 4 3))
(pass-if "set-field with unknown first getter" (pass-if-equal "set-field with unknown first getter"
'(syntax-error set-fields "unknown getter"
(set-field (blah) s 3)
blah)
(catch 'syntax-error (catch 'syntax-error
(lambda () (lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2))) (compile '(let ((s (make-bar (make-foo 5) 2)))
@ -126,12 +129,12 @@
#:env (current-module)) #:env (current-module))
#f) #f)
(lambda (key whom what src form subform) (lambda (key whom what src form subform)
(equal? (list key whom what form subform) (list key whom what form subform))))
'(syntax-error set-fields "unknown getter"
(set-field (blah) s 3)
blah)))))
(pass-if "set-field with unknown second getter" (pass-if-equal "set-field with unknown second getter"
'(syntax-error set-fields "unknown getter"
(set-field (bar-j blah) s 3)
blah)
(catch 'syntax-error (catch 'syntax-error
(lambda () (lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2))) (compile '(let ((s (make-bar (make-foo 5) 2)))
@ -139,10 +142,7 @@
#:env (current-module)) #:env (current-module))
#f) #f)
(lambda (key whom what src form subform) (lambda (key whom what src form subform)
(equal? (list key whom what form subform) (list key whom what form subform))))
'(syntax-error set-fields "unknown getter"
(set-field (bar-j blah) s 3)
blah)))))
(pass-if "set-fields" (pass-if "set-fields"
(let ((s (make-foo (make-bar 1 2)))) (let ((s (make-foo (make-bar 1 2))))
@ -167,7 +167,10 @@
((foo-x bar-j) 3) ((foo-x bar-j) 3)
((foo-z) 'bar))) ((foo-z) 'bar)))
(pass-if "set-fields with unknown first getter" (pass-if-equal "set-fields with unknown first getter"
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah)
(catch 'syntax-error (catch 'syntax-error
(lambda () (lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2))) (compile '(let ((s (make-bar (make-foo 5) 2)))
@ -175,12 +178,12 @@
#:env (current-module)) #:env (current-module))
#f) #f)
(lambda (key whom what src form subform) (lambda (key whom what src form subform)
(equal? (list key whom what form subform) (list key whom what form subform))))
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah)))))
(pass-if "set-fields with unknown second getter" (pass-if-equal "set-fields with unknown second getter"
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah)
(catch 'syntax-error (catch 'syntax-error
(lambda () (lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2))) (compile '(let ((s (make-bar (make-foo 5) 2)))
@ -188,12 +191,15 @@
#:env (current-module)) #:env (current-module))
#f) #f)
(lambda (key whom what src form subform) (lambda (key whom what src form subform)
(equal? (list key whom what form subform) (list key whom what form subform))))
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah)))))
(pass-if "set-fields with duplicate field path" (pass-if-equal "set-fields with duplicate field path"
'(syntax-error set-fields "duplicate field path"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3))
(bar-i foo-x))
(catch 'syntax-error (catch 'syntax-error
(lambda () (lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2))) (compile '(let ((s (make-bar (make-foo 5) 2)))
@ -204,15 +210,16 @@
#:env (current-module)) #:env (current-module))
#f) #f)
(lambda (key whom what src form subform) (lambda (key whom what src form subform)
(equal? (list key whom what form subform) (list key whom what form subform))))
'(syntax-error set-fields "duplicate field path"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3))
(bar-i foo-x))))))
(pass-if "set-fields with one path as a prefix of another" (pass-if-equal "set-fields with one path as a prefix of another"
'(syntax-error set-fields
"one field path is a prefix of another"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3))
(bar-i))
(catch 'syntax-error (catch 'syntax-error
(lambda () (lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2))) (compile '(let ((s (make-bar (make-foo 5) 2)))
@ -223,14 +230,7 @@
#:env (current-module)) #:env (current-module))
#f) #f)
(lambda (key whom what src form subform) (lambda (key whom what src form subform)
(equal? (list key whom what form subform) (list key whom what form subform)))))
'(syntax-error set-fields
"one field path is a prefix of another"
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3))
(bar-i)))))))
(with-test-prefix "side-effecting arguments" (with-test-prefix "side-effecting arguments"
@ -489,110 +489,232 @@
(equal? p (make-person 30 "foo@example.com" (equal? p (make-person 30 "foo@example.com"
(make-address "Foo" "Paris" "France"))))))) (make-address "Foo" "Paris" "France")))))))
(pass-if "set-fields with unknown first getter" (pass-if-equal "set-fields with unknown first getter"
(let () '(syntax-error set-fields "unknown getter"
(define-immutable-record-type foo (make-foo x) foo? (set-fields s ((bar-i foo-x) 1) ((blah) 3))
(x foo-x) blah)
(y foo-y set-foo-y) (catch 'syntax-error
(z foo-z set-foo-z)) (lambda ()
(compile '(let ()
(define-immutable-record-type foo
(make-foo x)
foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar? (define-immutable-record-type :bar
(i bar-i) (make-bar i j)
(j bar-j set-bar-j)) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error (let ((s (make-bar (make-foo 5) 2)))
(lambda () (set-fields s ((bar-i foo-x) 1) ((blah) 3))))
(compile '(let ((s (make-bar (make-foo 5) 2))) #:env (current-module))
(set-fields s ((bar-i foo-x) 1) ((blah) 3))) #f)
#:env (current-module)) (lambda (key whom what src form subform)
#f) (list key whom what form subform))))
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah))))))
(pass-if "set-fields with unknown second getter" (pass-if-equal "set-fields with unknown second getter"
(let () '(syntax-error set-fields "unknown getter"
(define-immutable-record-type foo (make-foo x) foo? (set-fields s ((bar-i foo-x) 1) ((blah) 3))
(x foo-x) blah)
(y foo-y set-foo-y) (catch 'syntax-error
(z foo-z set-foo-z)) (lambda ()
(compile '(let ()
(define-immutable-record-type foo
(make-foo x)
foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar? (define-immutable-record-type :bar
(i bar-i) (make-bar i j)
(j bar-j set-bar-j)) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error (let ((s (make-bar (make-foo 5) 2)))
(lambda () (set-fields s ((bar-i foo-x) 1) ((blah) 3))))
(compile '(let ((s (make-bar (make-foo 5) 2))) #:env (current-module))
(set-fields s ((bar-i foo-x) 1) ((blah) 3))) #f)
#:env (current-module)) (lambda (key whom what src form subform)
#f) (list key whom what form subform))))
(lambda (key whom what src form subform)
(equal? (list key whom what form subform)
'(syntax-error set-fields "unknown getter"
(set-fields s ((bar-i foo-x) 1) ((blah) 3))
blah))))))
(pass-if "set-fields with duplicate field path" (pass-if-equal "set-fields with duplicate field path"
(let () '(syntax-error set-fields "duplicate field path"
(define-immutable-record-type foo (make-foo x) foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar?
(i bar-i)
(j bar-j set-bar-j))
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
(set-fields s (set-fields s
((bar-i foo-x) 1) ((bar-i foo-x) 1)
((bar-i foo-z) 2) ((bar-i foo-z) 2)
((bar-i foo-x) 3))) ((bar-i foo-x) 3))
#:env (current-module)) (bar-i foo-x))
#f) (catch 'syntax-error
(lambda (key whom what src form subform) (lambda ()
(equal? (list key whom what form subform) (compile '(let ()
'(syntax-error set-fields "duplicate field path" (define-immutable-record-type foo
(set-fields s (make-foo x)
((bar-i foo-x) 1) foo?
((bar-i foo-z) 2) (x foo-x)
((bar-i foo-x) 3)) (y foo-y set-foo-y)
(bar-i foo-x))))))) (z foo-z set-foo-z))
(pass-if "set-fields with one path as a prefix of another" (define-immutable-record-type :bar
(let () (make-bar i j)
(define-immutable-record-type foo (make-foo x) foo? bar?
(x foo-x) (i bar-i)
(y foo-y set-foo-y) (j bar-j set-bar-j))
(z foo-z set-foo-z))
(define-immutable-record-type :bar (make-bar i j) bar? (let ((s (make-bar (make-foo 5) 2)))
(i bar-i) (set-fields s
(j bar-j set-bar-j)) ((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i foo-x) 3))))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))
(catch 'syntax-error (pass-if-equal "set-fields with one path as a prefix of another"
(lambda () '(syntax-error set-fields
(compile '(let ((s (make-bar (make-foo 5) 2))) "one field path is a prefix of another"
(set-fields s (set-fields s
((bar-i foo-x) 1) ((bar-i foo-x) 1)
((bar-i foo-z) 2) ((bar-i foo-z) 2)
((bar-i) 3))) ((bar-i) 3))
#:env (current-module)) (bar-i))
#f) (catch 'syntax-error
(lambda (key whom what src form subform) (lambda ()
(equal? (list key whom what form subform) (compile '(let ()
'(syntax-error set-fields (define-immutable-record-type foo
"one field path is a prefix of another" (make-foo x)
(set-fields s foo?
((bar-i foo-x) 1) (x foo-x)
((bar-i foo-z) 2) (y foo-y set-foo-y)
((bar-i) 3)) (z foo-z set-foo-z))
(bar-i)))))))))
(define-immutable-record-type :bar
(make-bar i j)
bar?
(i bar-i)
(j bar-j set-bar-j))
(let ((s (make-bar (make-foo 5) 2)))
(set-fields s
((bar-i foo-x) 1)
((bar-i foo-z) 2)
((bar-i) 3))))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))))
(with-test-prefix "record type definition error reporting"
(pass-if-equal "invalid type name"
'(syntax-error define-immutable-record-type
"expected type name"
(define-immutable-record-type
(foobar x y)
foobar?
(x foobar-x)
(y foobar-y))
(foobar x y))
(catch 'syntax-error
(lambda ()
(compile '(define-immutable-record-type
(foobar x y)
foobar?
(x foobar-x)
(y foobar-y))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))
(pass-if-equal "invalid constructor spec"
'(syntax-error define-immutable-record-type
"invalid constructor spec"
(define-immutable-record-type :foobar
(make-foobar x y 3)
foobar?
(x foobar-x)
(y foobar-y))
(make-foobar x y 3))
(catch 'syntax-error
(lambda ()
(compile '(define-immutable-record-type :foobar
(make-foobar x y 3)
foobar?
(x foobar-x)
(y foobar-y))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))
(pass-if-equal "invalid predicate name"
'(syntax-error define-immutable-record-type
"expected predicate name"
(define-immutable-record-type :foobar
(foobar x y)
(x foobar-x)
(y foobar-y))
(x foobar-x))
(catch 'syntax-error
(lambda ()
(compile '(define-immutable-record-type :foobar
(foobar x y)
(x foobar-x)
(y foobar-y))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))
(pass-if-equal "invalid field spec"
'(syntax-error define-record-type
"invalid field spec"
(define-record-type :foobar
(make-foobar x y)
foobar?
(x)
(y foobar-y))
(x))
(catch 'syntax-error
(lambda ()
(compile '(define-record-type :foobar
(make-foobar x y)
foobar?
(x)
(y foobar-y))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))
(pass-if-equal "unknown field in constructor spec"
'(syntax-error define-record-type
"unknown field in constructor spec"
(define-record-type :foobar
(make-foobar x z)
foobar?
(x foobar-x)
(y foobar-y))
z)
(catch 'syntax-error
(lambda ()
(compile '(define-record-type :foobar
(make-foobar x z)
foobar?
(x foobar-x)
(y foobar-y))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform)))))
(with-test-prefix "record compatibility" (with-test-prefix "record compatibility"