[PATCH 10/25] Refactor type validation in `define-foreign-function'

[KAction]

From: Dmitry Bogatov <kact...@gnu.org>

---
 module/system/foreign/declarative.scm | 27 ++++++++++++++++++---------
 1 file changed, 18 insertions(+), 9 deletions(-)

diff --git a/module/system/foreign/declarative.scm 
b/module/system/foreign/declarative.scm
index 5a5d688..fb949db 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -136,6 +136,23 @@
     (set! function-name (string-drop function-name 2)))
   function-name)
 
+(define *validate-function-name* (make-parameter #f))
+(define *validate-argument-name* (make-parameter #f))
+(define *validate-argument-value* (make-parameter #f))
+
+(define (validate-type function-name type arg-name arg-value)
+  (define validate-proc (ft-validate-proc type))
+  (parameterize ((*validate-function-name* function-name)
+                 (*validate-argument-name* arg-name)
+                 (*validate-argument-value* arg-value))
+    (unless (validate-proc arg-value)
+      (throw
+       'wrong-type-arg
+       function-name
+       "Wrong type argument named `~A' (failed to satisfy validator `~A'): ~S"
+       (list arg-name (procedure-name validate-proc) arg-value)
+       (list arg-value)))))
+
 (export define-foreign-function)
 (define-syntax define-foreign-function
   (syntax-rules (::)
@@ -151,15 +168,7 @@
                   (map %make-foreign-argument (list type ...))))
                 (frontend-function
                  (lambda (arg-name ...)
-                   (let ((validate (ft-validate-proc type)))
-                     (unless (validate arg-name)
-                       (throw
-                        'wrong-type-arg
-                        'function-name
-                        "Wrong type argument named `~A' (failed to satisfy 
validator `~A'): ~S"
-                        (list 'arg-name (procedure-name validate) arg-name)
-                        (list arg-name))))
-                   ...
+                   (validate-type 'function-name type 'arg-name arg-name) ...
                    (backend-function arg-name ...))))
            (set-procedure-property! backend-function 'name 'function-name)
            (set-procedure-property! frontend-function 'name 'function-name)
-- 
I may be not subscribed. Please, keep me in carbon copy.