summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-9.scm
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2012-11-09 05:04:13 -0500
committerMark H Weaver <mhw@netris.org>2012-11-10 01:37:20 -0500
commit92fac8c056f8c2e61852625d48b5f7a8e66b72b9 (patch)
treeebf9659bff5783af70df0dd7a697e5fcad0611e7 /module/srfi/srfi-9.scm
parentf31a0762328b9cffa328ce1540ceaa6f1497e083 (diff)
downloadguile-92fac8c056f8c2e61852625d48b5f7a8e66b72b9.tar.gz
Improve error for set-fields paths leading to different types.
* module/system/base/ck.scm: New module. * module/srfi/srfi-9.scm: Import (system base ck). (getter-type, getter-index, getter-copier): Convert incoming argument convention to CK form. (define-tagged-inlinable): Convert return value convention for key lookup to CK form. * module/srfi/srfi-9/gnu.scm: Import (system base ck). Rename '%set-fields-unknown-getter' to 'unknown-getter'. (c-list, c-same-type-check): New macros. (%set-fields): Using the CK abstract machine, arrange to check (at macro expansion time) that all of the getters in head position correspond to the same record type. * test-suite/tests/srfi-9.test: Add test.
Diffstat (limited to 'module/srfi/srfi-9.scm')
-rw-r--r--module/srfi/srfi-9.scm21
1 files changed, 14 insertions, 7 deletions
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index de4945952..d213a8656 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -60,6 +60,7 @@
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
+ #:use-module (system base ck)
#:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
@@ -81,16 +82,22 @@
(define-syntax-rule (%%on-error err) err)
(define %%type #f) ; a private syntax literal
-(define-syntax-rule (getter-type getter err)
- (getter (%%on-error err) %%type))
+(define-syntax getter-type
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%type s))))
(define %%index #f) ; a private syntax literal
-(define-syntax-rule (getter-index getter err)
- (getter (%%on-error err) %%index))
+(define-syntax getter-index
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%index s))))
(define %%copier #f) ; a private syntax literal
-(define-syntax-rule (getter-copier getter err)
- (getter (%%on-error err) %%copier))
+(define-syntax getter-copier
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%copier s))))
(define-syntax define-tagged-inlinable
(lambda (x)
@@ -110,7 +117,7 @@
(define-syntax name
(lambda (x)
(syntax-case x (%%on-error key ...)
- ((_ (%%on-error err) key) #'value) ...
+ ((_ (%%on-error err) key s) #'(ck s 'value)) ...
((_ args ...)
#'((lambda (formals ...)
body ...)