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: ...@@ -19,14 +19,14 @@ build:
test: test:
stage: test stage: test
tags: tags:
- saas-linux-medium-amd64 - saas-linux-large-amd64
script: script:
- make check -j$(nproc) - make check -j$(nproc)
distcheck: distcheck:
stage: test stage: test
tags: tags:
- saas-linux-medium-amd64 - saas-linux-large-amd64
script: script:
- make distcheck -j$(nproc) - make distcheck -j$(nproc)
......
...@@ -37,6 +37,8 @@ ...@@ -37,6 +37,8 @@
&error make-error error? &error make-error error?
&external-error make-external-error external-error?
&violation make-violation violation? &violation make-violation violation?
&assertion make-assertion-violation assertion-violation? &assertion make-assertion-violation assertion-violation?
...@@ -189,6 +191,9 @@ object @var{exception}." ...@@ -189,6 +191,9 @@ object @var{exception}."
(define-exception-type &error &serious (define-exception-type &error &serious
make-error make-error
error?) error?)
(define-exception-type &external-error &error
make-external-error
external-error?)
(define-exception-type &violation &serious (define-exception-type &violation &serious
make-violation make-violation
violation?) violation?)
......
...@@ -111,7 +111,7 @@ ...@@ -111,7 +111,7 @@
(display ">" port))))))) (display ">" port)))))))
(define-syntax define-foreign (define-syntax define-foreign
(lambda (x) (lambda (stx)
(define (type-check exp proc-name) (define (type-check exp proc-name)
(define (check param predicate) (define (check param predicate)
#`(check-type #,param #,predicate '#,proc-name)) #`(check-type #,param #,predicate '#,proc-name))
...@@ -124,7 +124,8 @@ ...@@ -124,7 +124,8 @@
((x (ref extern)) (check #'x #'external-non-null?)) ((x (ref extern)) (check #'x #'external-non-null?))
((x (ref null extern)) (check #'x #'external?)) ((x (ref null extern)) (check #'x #'external?))
((x (ref string)) (check #'x #'string?)) ((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) (define (import-result-types exp)
(syntax-case exp (none) (syntax-case exp (none)
(none #'()) (none #'())
...@@ -141,7 +142,8 @@ ...@@ -141,7 +142,8 @@
((ref extern) #'((result (ref eq)))) ((ref extern) #'((result (ref eq))))
((ref null extern) #'((result (ref eq)))) ((ref null extern) #'((result (ref eq))))
((ref eq) #'((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) (define (locals exp)
(syntax-case exp (none i32 i64 f32 f64 ref null string extern) (syntax-case exp (none i32 i64 f32 f64 ref null string extern)
(none #'()) (none #'())
...@@ -154,7 +156,8 @@ ...@@ -154,7 +156,8 @@
((ref extern) #'()) ((ref extern) #'())
((ref null extern) #'()) ((ref null extern) #'())
((ref eq) #'()) ((ref eq) #'())
(type (%error "unsupported result type" #'type)))) (type (syntax-violation 'define-foreign "unsupported result type"
stx #'type))))
(define (lift-result exp) (define (lift-result exp)
(syntax-case exp (none i32 i64 f32 f64 ref null string extern) (syntax-case exp (none i32 i64 f32 f64 ref null string extern)
((x none) #'(x)) ((x none) #'(x))
...@@ -174,12 +177,13 @@ ...@@ -174,12 +177,13 @@
((x (ref extern)) #'((struct.new $extern-ref (i32.const 0) x))) ((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 null extern)) #'((struct.new $extern-ref (i32.const 0) x)))
((x (ref eq)) #'((ref.cast $heap-object 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) (define (fresh-wasm-id prefix)
(datum->syntax x (gensym prefix))) (datum->syntax stx (gensym prefix)))
(define (fresh-wasm-ids prefix lst) (define (fresh-wasm-ids prefix lst)
(map (lambda (_) (fresh-wasm-id prefix)) lst)) (map (lambda (_) (fresh-wasm-id prefix)) lst))
(syntax-case x (->) (syntax-case stx (->)
((_ proc-name mod name ptype ... -> rtype) ((_ proc-name mod name ptype ... -> rtype)
(and (string? (syntax->datum #'mod)) (string? (syntax->datum #'name))) (and (string? (syntax->datum #'mod)) (string? (syntax->datum #'name)))
(with-syntax ((iname (fresh-wasm-id "$import-")) (with-syntax ((iname (fresh-wasm-id "$import-"))
......
...@@ -59,9 +59,9 @@ ...@@ -59,9 +59,9 @@
make-error make-error
error? error?
;; &external-error &external-error
;; make-external-error make-external-error
;; external-error? external-error?
;; &quit-exception ;; &quit-exception
make-quit-exception make-quit-exception
......
...@@ -23,9 +23,52 @@ ...@@ -23,9 +23,52 @@
;;; Code: ;;; Code:
(define-module (srfi srfi-1) (define-module (srfi srfi-1)
#:use-module ((hoot lists) #:select (alist-cons fold)) #:use-module ((hoot lists) #:select (alist-cons fold))
#:export (fold-right) #:export (fold-right filter-map find)
#:re-export ((acons . alist-cons) #:re-export ((acons . alist-cons)
fold)) fold))
(define (fold-right f seed l) (define (fold-right f seed l)
(fold f seed (reverse 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)))))))