diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-25 11:39:38 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-25 11:39:49 +0200 |
commit | 2d78e18454545801fbf3ac02c1d32ea68ef65de2 (patch) | |
tree | 96cd2d971f0369b4af2eef0c5dab475624b7c30f /module/util | |
parent | Remove take-drop-while, span already in SRFI-1. (diff) | |
download | calp-2d78e18454545801fbf3ac02c1d32ea68ef65de2.tar.gz calp-2d78e18454545801fbf3ac02c1d32ea68ef65de2.tar.xz |
Clean up util and move exceptions.
Diffstat (limited to '')
-rw-r--r-- | module/util.scm | 78 | ||||
-rw-r--r-- | module/util/exceptions.scm | 40 |
2 files changed, 55 insertions, 63 deletions
diff --git a/module/util.scm b/module/util.scm index d1bdfca1..97483222 100644 --- a/module/util.scm +++ b/module/util.scm @@ -2,17 +2,14 @@ #:use-module (srfi srfi-1) #:use-module ((ice-9 optargs) #:select (define*-public)) #:use-module ((sxml fold) #:select (fold-values)) - #:export (destructure-lambda let-multi fold-lists catch-let - for-each-in for - define-quick-record - mod! sort* sort*! - mod/r! set/r! - find-min - catch-multiple - quote? - tree-map let-lazy) - #:replace (let* set! define-syntax) - ) + #:export (for define-quick-record + mod! sort* sort*! + mod/r! set/r! + find-min + catch-multiple + quote? + tree-map let-lazy) + #:replace (let* set! define-syntax)) ((@ (guile) define-syntax) define-syntax (syntax-rules () @@ -33,25 +30,6 @@ (define-public symbol-downcase (compose string->symbol string-downcase symbol->string)) -(define-syntax destructure-lambda - (syntax-rules () - ((_ expr-list body ...) - (lambda (expr) - (apply (lambda expr-list body ...) expr))))) - -(define-syntax catch-let - (syntax-rules () - ((_ thunk ((type handler) ...)) - (catch #t thunk - (lambda (err . args) - (case err - ((type) (apply handler err args)) ... - (else (format #t "Unhandled error type ~a, rethrowing ~%" err) - (apply throw err args)))))))) - -;;; For-each with arguments in reverse order. -(define-syntax-rule (for-each-in lst proc) - (for-each proc lst)) (define-syntax for (syntax-rules (in) @@ -289,39 +267,6 @@ (call-with-values (lambda () (apply proc args)) (lambda args (list-ref args n))))) -;; Takes a (non nested) list, and replaces all single underscore -;; symbols with a generated symbol. For macro usage. -(define (multiple-ignore lst) - (cond ((not-pair? lst) lst) - ((eq? '_ (car lst)) (cons (gensym "ignored_") - (multiple-ignore (cdr lst)))) - (else (cons (car lst) - (multiple-ignore (cdr lst)))))) - -(define (catch-recur% errs thunk cases) - (let* ((v (car errs)) - (case other (partition (lambda (case) (eq? v (car case))) cases)) - (g!rest (gensym "rest"))) - `(catch (quote ,v) - ,(if (null? (cdr errs)) - thunk - `(lambda () ,(catch-recur% (cdr errs) thunk other))) - (lambda (err . ,g!rest) - (apply (lambda ,(multiple-ignore (second (car case))) - ,@(cddr (car case))) - ,g!rest))))) - -;; Like @var{catch}, but multiple handlers can be specified. -;; Each handler is on the form -;; @example -;; [err-symb (args ...) body ...] -;; @end example -;; -;; Only errors with a handler are caught. Error can *not* be given as -;; an early argument. -(define-macro (catch-multiple thunk . cases) - (catch-recur% (map car cases) thunk cases)) - (define-public (flatten lst) (fold (lambda (subl done) (append done ((if (list? subl) flatten list) subl))) @@ -349,3 +294,10 @@ ,@(tree-map (lambda (t) (if (memv t keys) `(force ,t) t)) body #:descend (negate quote?))))) + +(define-public (map/dotted proc dotted-list) + (cond ((null? dotted-list) '()) + ((not-pair? dotted-list) (proc dotted-list)) + (else + (cons (proc (car dotted-list)) + (map/dotted proc (cdr dotted-list)))))) diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm new file mode 100644 index 00000000..d649643c --- /dev/null +++ b/module/util/exceptions.scm @@ -0,0 +1,40 @@ +(define-module (util exceptions) + #:use-module (srfi srfi-1) + #:use-module (util) + #:export (throw-returnable + catch-multiple)) + +(define-syntax-rule (throw-returnable symb args ...) + (call/cc (lambda (cont) (throw symb cont args ...)))) + +;; Takes a (non nested) list, and replaces all single underscore +;; symbols with a generated symbol. For macro usage. +(define (multiple-ignore lst) + (map/dotted (lambda (symb) (if (eq? symb '_) (gensym "ignored_") symb)) + lst)) + +;; Like @var{catch}, but multiple handlers can be specified. +;; Each handler is on the form +;; @example +;; [err-symb (args ...) body ...] +;; @end example +;; +;; Only errors with a handler are caught. Error can *not* be given as +;; an early argument. +(define-macro (catch-multiple thunk . cases) + (let catch-recur% ((errs (map car cases)) (cases cases)) + (let* ((v (car errs)) + (case other (partition (lambda (case) (eq? v (car case))) cases)) + (g!rest (gensym "rest"))) + `(catch (quote ,v) + ,(if (null? (cdr errs)) + thunk + `(lambda () ,(catch-recur% (cdr errs) other))) + (lambda (err . ,g!rest) + (apply (lambda ,(let ((param-list (second (car case)))) + (if (not (pair? param-list)) + param-list + (multiple-ignore param-list))) + ,@(cddr (car case))) + ,g!rest)))))) + |