Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • vivicat/guile-hoot
  • LukeSmithFanBoy/guile-hoot
  • spritely/guile-hoot
  • dannyob/guile-hoot
  • ShalokShalom/guile-hoot
  • squaremo/guile-hoot
  • aarong11/guile-hoot
  • Z572/guile-hoot
  • klavul/guile-hoot
  • Pinjontall94/guile-hoot
  • createyourpersonalaccount/guile-hoot
  • sbensu/guile-hoot
  • itorres/guile-hoot
  • abcdw/guile-hoot
  • kakafarm/guile-hoot
  • kyurivlis/guile-hoot
  • hierophantos/guile-hoot
  • wordempire/guile-hoot
18 results
Show changes
Commits on Source (8)
......@@ -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)
......
......@@ -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?)
......
......@@ -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-"))
......
......@@ -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
......
......@@ -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)))))))