another try of guile-mod

parent 1c2c942b
......@@ -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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment