another try of guile-mod

1 files changed, 40 insertions, 16 deletions

diff --git a/modules/language/python/guilemod.scm b/modules/language/python/guilemod.scm
index 9bcfa74..9445d29 100644
--- a/modules/language/python/guilemod.scm
+++ b/modules/language/python/guilemod.scm
@@ -36,22 +36,20 @@
 (define-C default-language
   (lambda (file)
     (define default ((C current-language)))
-    (pk file)
-    (pk
-     (if (C *do-extension-dispatch*)
-         (let ((ext (car (reverse (string-split file #\.)))))
-           (let lp ((l (C *extension-dispatches*)))
-             (if (pair? l)
-                 (if (member ext (caar l))
-                     (let ((r (cdar l)))
-                       (if ((C language?) default)
-                           (if (eq? ((C language-name) default) r)
-                               default
-                               r)
-                           r))
-                     (lp (cdr l)))
-                 default)))
-         default))))
+    (if (C *do-extension-dispatch*)
+        (let ((ext (car (reverse (string-split file #\.)))))
+          (let lp ((l (C *extension-dispatches*)))
+            (if (pair? l)
+                (if (member ext (caar l))
+                    (let ((r (cdar l)))
+                      (if ((C language?) default)
+                          (if (eq? ((C language-name) default) r)
+                              default
+                              r)
+                          r))
+                    (lp (cdr l)))
+                default)))
+        default)))
 
 
 (define-exp-C %in-compile (make-fluid #f))
@@ -239,3 +237,29 @@
                    loc))
                  (else
                   (emit port "~A: `format' warning~%" loc)))))))))
+
+
+(define pload
+  (let ((guile-load (@ (guile) primitive-load-path)))
+    (lambda (p . q)
+      (let ((tag (make-prompt-tag)))
+        (call-with-prompt
+         tag
+         (lambda ()
+           (guile-load p (lambda () (abort-to-prompt tag))))
+         (lambda (k)
+           (let lp ((l *extension-dispatches*))
+             (if (pair? l)
+                 (let lp2 ((u (caar l)))
+                   (if (pair? u)
+                       (aif it (%search-load-path
+                                (string-append p "." (car u)))
+                            (apply guile-load  it q)
+                            (lp (cdr u)))
+                       (lp (cdr l))))                 
+                 (if (pair? q)
+                     ((car q))
+                     (error (string-append "no code for path " p)))))))))))
+ 
+ 
+ (define-set-G primitive-load-path pload)