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

Use r7rs lazy primitives in srfi 41

Browse source 
Rewrite srfi 41 primitive layer in terms of r7rs primitives for delayed
evaluation.
This commit is contained in:
Lukas Stoll 2020-06-09 14:55:44 +02:00
parent 2b82ef68d4
commit 6e2bd8d4b7
1 changed files with 34 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

87
lib/srfi/41.scm
View file

@ -1,73 +1,54 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; primitive layer adapted from SRFI 41 reference impl ;; primitive layer adapted from SRFI 41 reference impl
;; TODO: rewrite this in terms or R7RS lazy primitives
(define-record-type Stream (define-record-type <stream>
(make-stream box) (make-stream promise)
stream? stream?
(box stream-promise stream-promise!)) (promise stream-promise))
(define-record-type Stream-Pare (define-record-type <stream-null>
(make-stream-pare kar kdr) (make-stream-null)
stream-pare? %stream-null?)
(kar stream-kar)
(kdr stream-kdr))
(define-syntax stream-lazy (define-record-type <stream-pair>
(syntax-rules () (make-stream-pair head tail)
((lazy expr) %stream-pair?
(make-stream (cons 'lazy (lambda () expr)))))) (head %stream-car)
(tail %stream-cdr))
(define (stream-eager expr) (define stream-null (make-stream (make-promise (make-stream-null))))
(make-stream (cons 'eager expr)))
(define-syntax stream-delay
(syntax-rules ()
((stream-delay expr)
(stream-lazy (stream-eager expr)))))
(define (stream-force promise)
(let ((content (stream-promise promise)))
(case (car content)
((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content)))
(content (stream-promise promise)))
(if (not (eqv? (car content) 'eager))
(begin (set-car! content (car (stream-promise promise*)))
(set-cdr! content (cdr (stream-promise promise*)))
(stream-promise! promise* content)))
(stream-force promise))))))
(define stream-null (stream-delay (cons 'stream 'null)))
(define (stream-pair? obj)
(and (stream? obj) (stream-pare? (stream-force obj))))
(define (stream-null? obj)
(and (stream? obj)
(eqv? (stream-force obj)
(stream-force stream-null))))
(define-syntax stream-cons (define-syntax stream-cons
(syntax-rules () (syntax-rules ()
((stream-cons obj strm) ((stream-cons object stream)
(stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) (make-stream
(make-promise
(make-stream-pair
(delay object)
(delay-force (stream-promise stream))))))))
(define (stream-car strm) (define (stream-null? stream)
(cond ((not (stream? strm)) (error 'stream-car "non-stream")) (and (stream? stream)
((stream-null? strm) (error 'stream-car "null stream")) (%stream-null? (force (stream-promise stream)))))
(else (stream-force (stream-kar (stream-force strm))))))
(define (stream-cdr strm) (define (stream-pair? stream)
(cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) (and (stream? stream)
((stream-null? strm) (error 'stream-cdr "null stream")) (%stream-pair? (force (stream-promise stream)))))
(else (stream-kdr (stream-force strm)))))
(define (stream-car stream)
(force (%stream-car (force (stream-promise stream)))))
(define (stream-cdr stream)
(let ((t (force (%stream-cdr (force (stream-promise stream))))))
(make-stream (make-promise t))))
(define-syntax stream-lambda (define-syntax stream-lambda
(syntax-rules () (syntax-rules ()
((stream-lambda formals body0 body1 ...) ((stream-lambda formals body0 body1 ...)
(lambda formals (stream-lazy (let () body0 body1 ...)))))) (lambda formals
(make-stream
(delay-force (stream-promise (let () body0 body1 ...))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; derived ;; derived