.gitlab-ci.yml

@@ -19,14 +19,14 @@ build:
 test:
   stage: test
   tags:
-    - saas-linux-medium-amd64
+    - saas-linux-large-amd64
   script:
     - make check -j$(nproc)
 
 distcheck:
   stage: test
   tags:
-    - saas-linux-medium-amd64
+    - saas-linux-large-amd64
   script:
     - make distcheck -j$(nproc)
 

lib/hoot/exceptions.scm

@@ -37,6 +37,8 @@
 
           &error make-error error?
 
+          &external-error make-external-error external-error?
+
           &violation make-violation violation?
 
           &assertion make-assertion-violation assertion-violation?
@@ -189,6 +191,9 @@ object @var{exception}."
   (define-exception-type &error &serious
     make-error
     error?)
+  (define-exception-type &external-error &error
+    make-external-error
+    external-error?)
   (define-exception-type &violation &serious
     make-violation
     violation?)

lib/hoot/ffi.scm

@@ -111,7 +111,7 @@
                (display ">" port)))))))
 
   (define-syntax define-foreign
-    (lambda (x)
+    (lambda (stx)
       (define (type-check exp proc-name)
         (define (check param predicate)
           #`(check-type #,param #,predicate '#,proc-name))
@@ -124,7 +124,8 @@
           ((x (ref extern)) (check #'x #'external-non-null?))
           ((x (ref null extern)) (check #'x #'external?))
           ((x (ref string)) (check #'x #'string?))
-          ((x type) (%error "unsupported param type" #'type))))
+          ((x type) (syntax-violation 'define-foreign "unsupported param type"
+                                      stx #'type))))
       (define (import-result-types exp)
         (syntax-case exp (none)
           (none #'())
@@ -141,7 +142,8 @@
           ((ref extern) #'((result (ref eq))))
           ((ref null extern) #'((result (ref eq))))
           ((ref eq) #'((result (ref eq))))
-          (type (%error "unsupported result type" #'type))))
+          (type (syntax-violation 'define-foreign "unsupported result type"
+                                  stx #'type))))
       (define (locals exp)
         (syntax-case exp (none i32 i64 f32 f64 ref null string extern)
           (none #'())
@@ -154,7 +156,8 @@
           ((ref extern) #'())
           ((ref null extern) #'())
           ((ref eq) #'())
-          (type (%error "unsupported result type" #'type))))
+          (type (syntax-violation 'define-foreign "unsupported result type"
+                                  stx #'type))))
       (define (lift-result exp)
         (syntax-case exp (none i32 i64 f32 f64 ref null string extern)
           ((x none) #'(x))
@@ -174,12 +177,13 @@
           ((x (ref extern)) #'((struct.new $extern-ref (i32.const 0) x)))
           ((x (ref null extern)) #'((struct.new $extern-ref (i32.const 0) x)))
           ((x (ref eq)) #'((ref.cast $heap-object x)))
-          (type (%error "unsupported result type" #'type))))
+          (type (syntax-violation 'define-foreign "unsupported result type"
+                                  stx #'type))))
       (define (fresh-wasm-id prefix)
-        (datum->syntax x (gensym prefix)))
+        (datum->syntax stx (gensym prefix)))
       (define (fresh-wasm-ids prefix lst)
         (map (lambda (_) (fresh-wasm-id prefix)) lst))
-      (syntax-case x (->)
+      (syntax-case stx (->)
         ((_ proc-name mod name ptype ... -> rtype)
          (and (string? (syntax->datum #'mod)) (string? (syntax->datum #'name)))
          (with-syntax ((iname (fresh-wasm-id "$import-"))

lib/ice-9/exceptions.scm

@@ -59,9 +59,9 @@
                make-error
                error?
 
-               ;; &external-error
-	       ;; make-external-error
-	       ;; external-error?
+               &external-error
+	       make-external-error
+	       external-error?
 
                ;; &quit-exception
                make-quit-exception

lib/srfi/srfi-1.scm

@@ -23,9 +23,52 @@
 ;;; Code:
 (define-module (srfi srfi-1)
   #:use-module ((hoot lists) #:select (alist-cons fold))
-  #:export (fold-right)
+  #:export (fold-right filter-map find)
   #:re-export ((acons . alist-cons)
                fold))
 
 (define (fold-right f seed l)
   (fold f seed (reverse l)))
+
+(define reverse! reverse)
+
+(define (any1 pred ls)
+  (let lp ((ls ls))
+    (cond ((null? ls)
+	   #f)
+	  ((null? (cdr ls))
+	   (pred (car ls)))
+	  (else
+	   (or (pred (car ls)) (lp (cdr ls)))))))
+
+(define (find pred lst)
+  "Return the first element of @var{lst} that satisfies the predicate
+@var{pred}, or return @code{#f} if no such element is found."
+  (let loop ((lst lst))
+    (and (not (null? lst))
+         (let ((head (car lst)))
+           (if (pred head)
+               head
+               (loop (cdr lst)))))))
+
+(define (filter-map proc list1 . rest)
+  "Apply PROC to the elements of LIST1... and return a list of the
+results as per SRFI-1 `map', except that any #f results are omitted from
+the list returned."
+  (if (null? rest)
+      (let lp ((l list1)
+               (rl '()))
+        (if (null? l)
+            (reverse! rl)
+            (let ((res (proc (car l))))
+              (if res
+                  (lp (cdr l) (cons res rl))
+                  (lp (cdr l) rl)))))
+      (let lp ((l (cons list1 rest))
+               (rl '()))
+        (if (any1 null? l)
+            (reverse! rl)
+            (let ((res (apply proc (map car l))))
+              (if res
+                  (lp (map cdr l) (cons res rl))
+                  (lp (map cdr l) rl)))))))