From d87136a9ca74b0b145800e362144eeefff803eba Mon Sep 17 00:00:00 2001
From: Javier Sancho <jsf@jsancho.org>
Date: Tue, 14 Aug 2012 17:25:13 +0200
Subject: [PATCH] Functions for playing with arguments when apply to
 procedures.

---
 src/utils.scm | 112 +++++++++++++++++++++++++++++++++++++++++++++++++-
 src/views.scm |   9 ++--
 2 files changed, 116 insertions(+), 5 deletions(-)

diff --git a/src/utils.scm b/src/utils.scm
index 4a27f88..28cc163 100644
--- a/src/utils.scm
+++ b/src/utils.scm
@@ -16,12 +16,15 @@
 
 
 (define-module (gacela utils)
-  #:use-module (ice-9 session)
-  #:export (use-cache-with))
+  #:export (use-cache-with
+	    arguments-calling
+	    arguments-apply))
 
 
 ;;; Cache for procedures
+
 (define (use-cache-with proc)
+  "Cache for procedures"
   (let ((cache (make-weak-value-hash-table)))
     (lambda (. param)
       (let* ((key param)
@@ -31,3 +34,108 @@
 	       (set! res (apply proc param))
 	       (hash-set! cache key res)
 	       res))))))
+
+
+;;; Playing with procedures arguments
+
+(define undefined)
+(define (bound? var) (not (eq? var undefined)))
+
+(define (required-arguments args values)
+  "Return an alist with required arguments and their values"
+  (define (f vars values)
+    (cond ((or (null? vars) (null? values)) '())
+	  (else (assoc-set! (f (cdr vars) (cdr values))
+			    (car vars)
+			    (car values)))))
+  (f (assoc-ref args 'required) values))
+
+(define (optional-arguments args values)
+  "Return an alist with optional arguments and their values"
+  (define (f vars values)
+    (cond ((null? vars) '())
+	  ((null? values) (assoc-set! (f (cdr vars) '())
+				      (car vars)
+				      undefined))
+	  (else (assoc-set! (f (cdr vars) (cdr values))
+			    (car vars)
+			    (car values)))))
+  (f (assoc-ref args 'optional)
+     (list-tail values
+		(min (length (assoc-ref args 'required))
+		     (length values)))))
+
+(define (keyword-arguments args values)
+  "Return an alist with keyword arguments and their values"
+  (define (f vars values)
+    (cond ((null? vars) '())
+	  (else
+	   (let ((val (member (car vars) values)))
+	     (assoc-set! (f (cdr vars) values)
+			    (keyword->symbol (car vars))
+			    (if val (cadr val) undefined))))))
+  (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
+
+(define (rest-arguments args values)
+  "Return an alist with rest arguments"
+  (let ((rest (assoc-ref args 'rest)))
+    (cond (rest (assoc-set! '()
+			    rest
+			    (list-tail values
+				       (min (+ (length (assoc-ref args 'required))
+					       (length (assoc-ref args 'optional)))
+					    (length values)))))
+	  (else '()))))
+
+(define (arguments-calling proc values)
+  "Return an alist with procedure arguments and their values"
+  (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
+    (append (required-arguments args values)
+	    (optional-arguments args values)
+	    (keyword-arguments args values)
+	    (rest-arguments args values))))
+
+(define (required-arguments-apply args values)
+  "Return a list with required arguments for use with apply"
+  (define (f vars values)
+    (cond ((null? vars) '())
+	  (else 
+	   (cons (assoc-ref values (car vars))
+		 (f (cdr vars) values)))))
+  (f (assoc-ref args 'required) values))
+
+(define (optional-arguments-apply args values)
+  "Return a list with optional arguments for use with apply"
+  (define (f vars values)
+    (cond ((null? vars) '())
+	  (else (let ((a (f (cdr vars) values))
+		      (val (assoc (car vars) values)))
+		  (cond ((and val (bound? (cdr val)))
+			 (cons (cdr val) a))
+			(else a))))))
+  (f (assoc-ref args 'optional) values))
+
+(define (keyword-arguments-apply args values)
+  "Return a list with keyword arguments for use with apply"
+  (define (f vars values)
+    (cond ((null? vars) '())
+	  (else (let ((a (f (cdr vars) values))
+		      (val (assoc (keyword->symbol (car vars)) values)))
+		  (cond ((and val (bound? (cdr val)))
+			 (cons (car vars) (cons (cdr val) a)))
+			(else a))))))
+  (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
+
+(define (rest-arguments-apply args values)
+  "Return a list with rest arguments for use with apply"
+  (let ((rest (assoc-ref args 'rest)))
+    (cond (rest (assoc-ref values rest))
+	  (else '()))))
+  
+(define (arguments-apply proc values)
+  "Return a list for use with apply"
+  (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
+    (append (required-arguments-apply args values)
+	    (optional-arguments-apply args values)
+	    (keyword-arguments-apply args values)
+	    (rest-arguments-apply args values))))
diff --git a/src/views.scm b/src/views.scm
index 805a47d..c19bf33 100644
--- a/src/views.scm
+++ b/src/views.scm
@@ -42,7 +42,7 @@
 	    (video:rotate ax ay az)
 	    (video:translate x y z)
 	    (video:rotate rx ry rz)
-	    (primitive)))
+	    (primitive (assoc-ref properties 'args))))
 	  ((translate)
 	   (set! x (+ x (car params)))
 	   (set! y (+ y (cadr params)))
@@ -93,8 +93,11 @@
 
 ;;; Primitives
 
-(define (basic proc)
-  ((@ (system vm program) program-lambda-list) proc))
+(define-macro (primitive proc)
+  `(lambda (. params)
+     (let ((m (mesh (lambda (args) (apply ,proc args)))))
+       (m 'property-set! 'args params)
+       m)))
 
 (define-macro (define-primitives . symbols)
   (cond ((null? symbols)
-- 
2.39.2