From 929ba6a645c92ebea58c8c93c412197b56aa775f Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Thu, 3 Apr 2014 09:36:16 +0200 Subject: [PATCH] Components with similar headers to functions * src/system.scm: Support to #:optional and #:key when defining new components with define-component --- src/system.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/system.scm b/src/system.scm index e6feb4e..1df24f9 100644 --- a/src/system.scm +++ b/src/system.scm @@ -39,22 +39,31 @@ a (syntax->datum a))) args)))) + (define (filtered-args args) + (let ((datum (map (lambda (a) (syntax->datum a)) args))) + (map (lambda (a) (datum->syntax x a)) + (map (lambda (a) (if (list? a) (car a) a)) + (filter (lambda (a) (not (keyword? a))) datum))))) (syntax-case x () ((_ name field ...) (with-syntax ((make-name (concat "make-" #'name)) + (make-name-record (concat "make-" #'name "-record")) (name? (concat #'name "?")) - ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) #'(field ...))) - ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) #'(field ...)))) + ((field-name ...) (filtered-args #'(field ...))) + ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) (filtered-args #'(field ...)))) + ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) (filtered-args #'(field ...))))) #'(begin + (define* (make-name field ...) + (make-name-record field-name ...)) (define-record-type name - (make-name field ...) + (make-name-record field-name ...) name? - (field field-getter field-setter) + (field-name field-getter field-setter) ...) (set-record-type-printer! name (lambda (record port) (format port "#<[~a]" 'name) - (format port " ~a: ~a" 'field (field-getter record)) + (format port " ~a: ~a" 'field-name (field-getter record)) ... (format port ">"))) 'name)))))) -- 2.39.2