diff options
Diffstat (limited to 'module/hnh')
| -rw-r--r-- | module/hnh/module-introspection/all-modules.scm | 25 | ||||
| -rw-r--r-- | module/hnh/util.scm | 53 | ||||
| -rw-r--r-- | module/hnh/util/env.scm | 6 | ||||
| -rw-r--r-- | module/hnh/util/exceptions.scm | 3 | ||||
| -rw-r--r-- | module/hnh/util/path.scm | 11 |
5 files changed, 68 insertions, 30 deletions
diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm index 1bf39e1e..4b224d2f 100644 --- a/module/hnh/module-introspection/all-modules.scm +++ b/module/hnh/module-introspection/all-modules.scm @@ -7,8 +7,9 @@ :use-module (hnh module-introspection) :use-module ((hnh module-introspection static-util) :select (get-forms)) :export (all-files-and-modules-under-directory + all-files-under-directory all-modules-under-directory - fs-find-base fs-find + fs-find module-file-mapping )) @@ -20,22 +21,24 @@ ;; (define (fs-find proc dir) ;; (filter proc (fs-find-base dir))) -(define (all-files-and-modules-under-directory dir) - (define re (make-regexp "\\.scm$")) +(define* (all-files-under-directory dir extension) + (define extension-rx ((@ (texinfo string-utils) escape-special-chars) + extension "[](){}+*?.^$" #\\)) + (define re (make-regexp (string-append extension-rx "$"))) - (define files - (map car - (filter (match-lambda ((filename _ 'regular) - (and (regexp-exec re filename) - (not (file-hidden? filename)))) - (_ #f)) - (fs-find dir)))) + (map car + (filter (match-lambda ((filename _ 'regular) + (and (regexp-exec re filename) + (not (file-hidden? filename)))) + (_ #f)) + (fs-find dir)))) +(define (all-files-and-modules-under-directory dir) (map (lambda (file) (list file (call-with-input-file file (compose find-module-declaration get-forms)))) - files)) + (all-files-under-directory dir ".scm"))) (define (all-modules-under-directory dir) "Returns two values, all scm files in dir, and all top diff --git a/module/hnh/util.scm b/module/hnh/util.scm index c88a029e..9f71c1ec 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -4,7 +4,8 @@ :use-module (srfi srfi-88) ; postfix keywords :use-module ((sxml fold) :select (fold-values)) :use-module ((srfi srfi-9 gnu) :select (set-fields)) - :re-export (fold-values) + :use-module ((ice-9 copy-tree) :select (copy-tree)) + :use-module ((ice-9 control) :select (call/ec)) :export (aif awhen for @@ -59,7 +60,6 @@ uniqx uniq univ - uniqv unique vector-last @@ -118,17 +118,50 @@ -(define-syntax for - (syntax-rules (in) +(define-syntax (for stx) + (syntax-case stx (in) ((for (<var> <vars> ...) in <collection> b1 body ...) - (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...]) - <collection>)) + (with-syntax ((break (datum->syntax stx 'break)) + (continue (datum->syntax stx 'continue))) + #'(call/ec + (lambda (break) + (map ((@ (ice-9 match) match-lambda) + [(<var> <vars> ...) + (call/ec + (lambda (raw-continue) + (let ((continue + (case-lambda + (() #f) + (args (apply raw-continue args))))) + b1 body ...)))]) + <collection>))))) + ((for (<var> <vars> ... . <tail>) in <collection> b1 body ...) - (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ... . <tail>) b1 body ...]) - <collection>)) + #'(call/ec + (lambda (break) + (map ((@ (ice-9 match) match-lambda) + [(<var> <vars> ... . <tail>) + (call/ec + (lambda (raw-continue) + (let ((continue + (case-lambda + (() (raw-continue #f)) + (args (apply raw-continue args))))) + b1 body ...)))]) + <collection>)))) ((for <var> in <collection> b1 body ...) - (map (lambda (<var>) b1 body ...) - <collection>)))) + (with-syntax ((break (datum->syntax stx 'break)) + (continue (datum->syntax stx 'continue))) + #'(call/ec + (lambda (break) + (map (lambda (<var>) + (call/ec (lambda (raw-continue) + (let ((continue + (case-lambda + (() (raw-continue #f)) + (args (apply raw-continue args))))) + b1 body ...)))) + <collection>))))))) diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm index 32ea1cc1..f5992245 100644 --- a/module/hnh/util/env.scm +++ b/module/hnh/util/env.scm @@ -16,7 +16,11 @@ (list n new-value (getenv n))) (list (symbol->string (quote name)) ...) (list value ...))) - (for-each (lambda (pair) (setenv (car pair) (cadr pair))) + (for-each (lambda (pair) + (if (cadr pair) + (setenv (car pair) + (cadr pair)) + (unsetenv (car pair)))) env-pairs)) (lambda () body ...) (lambda () diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index 344eb27a..1c3de8c7 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -33,8 +33,7 @@ (define (fatal fmt . args) (display (format #f "FATAL: ~?~%" fmt (or args '())) (current-error-port)) - (raise 2) - ) + (raise SIGINT)) (define (filter-stack pred? stk) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index b0991073..b92de8cd 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -17,7 +17,8 @@ (define path-absolute? absolute-file-name?) ;; TODO remove intermidiate period components -(define (path-append . strings) +;; e.x. /a/../b => /b +(define (path-append path . paths) (fold (lambda (s done) (string-append done @@ -33,11 +34,9 @@ ;; the path absolute. This isn't exactly correct if we have ;; drive letters, but on those system the user should make ;; sure that the first component of the path is non-empty. - (let ((s (car strings))) - (if (string-null? s) - // s)) - (cdr strings) - )) + (if (string-null? path) + // path) + paths)) (define (path-join lst) (apply path-append lst)) |