diff options
Diffstat (limited to 'module/hnh/util.scm')
-rw-r--r-- | module/hnh/util.scm | 53 |
1 files changed, 43 insertions, 10 deletions
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>))))))) |