From: Javier Sancho <jsf@jsancho.org>
Date: Thu, 3 Apr 2014 07:36:16 +0000 (+0200)
Subject: Components with similar headers to functions
X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=929ba6a645c92ebea58c8c93c412197b56aa775f;p=gacela.git

Components with similar headers to functions

* src/system.scm: Support to #:optional and #:key when defining new
                  components with define-component
---

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))))))