Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

make-promise is idempotent (issue #625)

Browse source
This commit is contained in:
Alex Shinn 2020-04-10 17:17:15 +09:00
parent 0a83939866
commit f74c34b99b
3 changed files with 30 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/scheme/lazy.sld
View file

@ -4,4 +4,4 @@
(export delay force delay-force make-promise promise?) (export delay force delay-force make-promise promise?)
(begin (begin
(define (make-promise x) (define (make-promise x)
(delay x)))) (if (promise? x) x (delay x)))))

2
tests/r7rs-tests.scm
View file

@ -325,6 +325,8 @@
(let ((x (make-promise (+ 2 2)))) (let ((x (make-promise (+ 2 2))))
(force x) (force x)
(promise? x))) (promise? x)))
(test 4 (force (make-promise (+ 2 2))))
(test 4 (force (make-promise (make-promise (+ 2 2)))))
(define radix (define radix
(make-parameter (make-parameter

47
tools/chibi-ffi
View file

@ -53,7 +53,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type objects ;; type objects
(define (make-type) (make-vector 18 #f)) (define (make-type) (make-vector 19 #f))
(define (type-base type) (vector-ref type 0)) (define (type-base type) (vector-ref type 0))
(define (type-free? type) (vector-ref type 1)) (define (type-free? type) (vector-ref type 1))
@ -72,8 +72,9 @@
(define (type-error type) (vector-ref type 14)) (define (type-error type) (vector-ref type 14))
(define (type-address-of? type) (vector-ref type 15)) (define (type-address-of? type) (vector-ref type 15))
(define (type-no-free? type) (vector-ref type 16)) (define (type-no-free? type) (vector-ref type 16))
(define (type-index type) (vector-ref type 17)) (define (type-as-sexp type) (vector-ref type 17))
(define (type-index-set! type i) (vector-set! type 17 i)) (define (type-index type) (vector-ref type 18))
(define (type-index-set! type i) (vector-set! type 18 i))
(define (spec->type type . o) (define (spec->type type . o)
(let ((res (make-type))) (let ((res (make-type)))
@ -132,6 +133,9 @@
((no-free) ((no-free)
(vector-set! res 16 #t) (vector-set! res 16 #t)
(lp (next))) (lp (next)))
((as-sexp)
(vector-set! res 17 #t)
(lp (next)))
(else (else
(let ((base (if (and (pair? type) (null? (cdr type))) (let ((base (if (and (pair? type) (null? (cdr type)))
(car type) (car type)
@ -196,18 +200,15 @@
(define-syntax define-c-enum (define-syntax define-c-enum
;; TODO: support conversion to/from symbolic names ;; TODO: support conversion to/from symbolic names
(syntax-rules () (er-macro-transformer
((define-c-enum (scheme-name c-name) . args) (lambda (expr rename compare)
(if (not (assq 'scheme-name *c-enum-types*)) (let ((name (if (pair? (cadr expr)) (car (cadr expr)) (cadr expr)))
(set! *c-enum-types* (c-name (if (pair? (cadr expr)) (cadr (cadr expr)) (cadr expr))))
`((scheme-name . c-name) ,@*c-enum-types*))) (set! *c-enum-types*
#f) `((,name . ,c-name) ,@*c-enum-types*))
((define-c-enum scheme-name . args) `(,(rename 'define-c-const)
(let ((c-name (mangle 'scheme-name))) ,name
(if (not (assq 'scheme-name *c-enum-types*)) ,@(cddr expr))))))
(set! *c-enum-types*
`((scheme-name . ,c-name) ,@*c-enum-types*)))
#f))))
(define (enum-type? type) (define (enum-type? type)
(assq type *c-enum-types*)) (assq type *c-enum-types*))
@ -253,6 +254,9 @@
(not (void-pointer-type? type)) (not (void-pointer-type? type))
(not (lookup-type (type-base type)))))) (not (lookup-type (type-base type))))))
(define (void-type? type)
(and (eq? 'void (type-base type)) (not (type-pointer? type))))
(define (void-pointer-type? type) (define (void-pointer-type? type)
(or (and (eq? 'void (type-base type)) (type-pointer? type)) (or (and (eq? 'void (type-base type)) (type-pointer? type))
(eq? 'void* (type-base type)))) (eq? 'void* (type-base type))))
@ -969,10 +973,12 @@
(define (type-c-name type) (define (type-c-name type)
(let ((type (parse-type type))) (let ((type (parse-type type)))
(string-append (if (type-as-sexp type)
(type-c-name-derefed type) "sexp"
(if (type-struct-type type) "*" "") (string-append
(if (type-pointer? type) "*" "")))) (type-c-name-derefed type)
(if (type-struct-type type) "*" "")
(if (type-pointer? type) "*" "")))))
(define (type-finalizer-name type) (define (type-finalizer-name type)
(let ((name (type-c-name-derefed type))) (let ((name (type-c-name-derefed type)))
@ -1363,7 +1369,8 @@
(c-args (func-c-args func))) (c-args (func-c-args func)))
(if (any type-auto-expand? (func-c-args func)) (if (any type-auto-expand? (func-c-args func))
(cat " loop:\n")) (cat " loop:\n"))
(cat (cond ((error-type? ret-type) " err = ") (cat (cond ;;((void-type? ret-type) "")
((error-type? ret-type) " err = ")
((type-array ret-type) " tmp = ") ((type-array ret-type) " tmp = ")
((type-struct? ret-type) " struct_res = ") ((type-struct? ret-type) " struct_res = ")
(else " res = "))) (else " res = ")))