Changeset 15585 in project
- Timestamp:
- 08/27/09 21:58:03 (10 years ago)
- Location:
- release/4/srfi-45/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/srfi-45/trunk/srfi-45.meta
r14155 r15585 7 7 (doc-from-wiki) 8 8 (synopsis "Primitives for Expressing Iterative Lazy Algorithms") 9 (needs setup-helper )9 (needs setup-helper check-errors) 10 10 (files 11 11 "tests" -
release/4/srfi-45/trunk/srfi-45.scm
r14170 r15585 23 23 (include "chicken-primitive-object-inlines") 24 24 25 ;;; Module srfi-45 26 27 (module srfi-45 (;export 28 ; SRFI 45 29 (lazy make-lazy-promise) 30 (eager make-eager-promise) 31 promise? 32 #;delay 33 force 34 ; Extras 35 delay-recursive d-lay ; since we don't redefine R5RS `delay' 36 lazy-promise? 37 eager-promise? 38 recursive-promise?) 39 40 (import (rename scheme (force r5rs:force) #;(delay r5rs:delay)) 41 (rename chicken (promise? r5rs:promise?)) 42 type-errors) 43 25 44 ;; Recursive promise 26 45 27 46 (define-inline (%make-promise-box tag val) (cons tag val)) 28 47 (define-inline (%promise-box-tag prmbox) (%car prmbox)) 29 (define-inline (%promise-box-tag-set! prmbox tag) (%set-car!/ immediate prmbox tag))48 (define-inline (%promise-box-tag-set! prmbox tag) (%set-car!/mutate prmbox tag)) 30 49 (define-inline (%promise-box-value prmbox) (%cdr prmbox)) 31 50 (define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val)) … … 34 53 (define-inline (%lazy-promise-box? prmbox) (%eq? 'lazy (%promise-box-tag prmbox))) 35 54 36 (define-inline (%make-promise tag val) (%make-structure ' promise (%make-promise-box tag val)))37 (define-inline (%promise? obj) (%structure-instance? obj ' promise))55 (define-inline (%make-promise tag val) (%make-structure 'recursive-promise (%make-promise-box tag val))) 56 (define-inline (%promise? obj) (%structure-instance? obj 'recursive-promise)) 38 57 (define-inline (%promise-box prm) (%structure-ref prm 1)) 39 58 (define-inline (%promise-box-set! prm prmbox) (%structure-set! prm 1 prmbox)) … … 43 62 44 63 (define-inline (%eager-promise? obj) (and (%promise? obj) (%eager-promise-box? (%promise-box obj)))) 45 (define-inline (%lazy-promise? obj)(and (%promise? obj) (%lazy-promise-box? (%promise-box obj)))) 46 47 (define-inline (%recursive-promise? obj) 48 (and (%promise? obj) 49 (let ((prmbox (%promise-box obj))) 50 (or (%eager-promise-box? prmbox) (%lazy-promise-box? prmbox)))) ) 51 52 ;;; Module srfi-45 53 54 (module srfi-45 (;export 55 ; SRFI 45 56 (lazy $$finlzy) 57 (eager $$finegr) 58 d-lay ; since we don't redefine R5RS `delay' 59 promise? 60 force 61 ; Extras 62 lazy-promise? 63 eager-promise? 64 recursive-promise?) 65 66 (import (rename scheme (force r5rs:force) (delay r5rs:delay)) 67 (rename chicken (promise? r5rs:promise?))) 64 (define-inline (%lazy-promise? obj) (and (%promise? obj) (%lazy-promise-box? (%promise-box obj)))) 68 65 69 66 ;; Errors 70 67 71 (define (error-promise-corrupt loc prm) 72 (##sys#signal-hook #:type-error loc "promise is corrupt" prm) ) 68 (define-error-type promise) 69 (define-error-type promise-valid "valid promise") 70 (define-error-type promise-unforced-lazy "unforced lazy promise") 73 71 74 72 ;; Constructors 75 73 76 (define ( $$finlzythunk) (%make-lazy-promise thunk))77 (define ( $$finegrls) (%make-eager-promise ls))74 (define (make-lazy-promise thunk) (%make-lazy-promise thunk)) 75 (define (make-eager-promise ls) (%make-eager-promise ls)) 78 76 79 (define-syntax lazy (syntax-rules () ((_ ?expr) ($$finlzy (lambda () ?expr))))) 80 (define-syntax eager (syntax-rules () ((_ ?expr) ($$finegr (receive ?expr))))) 77 (define-syntax lazy (syntax-rules () ((_ ?expr) (make-lazy-promise (lambda () ?expr))))) 78 (define-syntax eager (syntax-rules () ((_ ?expr) (make-eager-promise (receive ?expr))))) 79 #;(define-syntax delay (syntax-rules () ((_ ?expr) (lazy (eager ?expr))))) 80 81 (define-syntax delay-recursive (syntax-rules () ((_ ?expr) (lazy (eager ?expr))))) 81 82 (define-syntax d-lay (syntax-rules () ((_ ?expr) (lazy (eager ?expr))))) 82 83 … … 85 86 (define (lazy-promise? obj) (%lazy-promise? obj)) 86 87 (define (eager-promise? obj) (%eager-promise? obj)) 87 (define (recursive-promise? obj) (%recursive-promise? obj)) 88 (define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj))) 88 (define (recursive-promise? obj) (%promise? obj)) 89 90 (define (promise? obj) (or (r5rs:promise? obj) (%promise? obj))) 89 91 90 92 ;; Force … … 94 96 (cond 95 97 ; New fashion promise? 96 ((% recursive-promise? prm)98 ((%promise? prm) 97 99 ; Unbox 98 100 (let* ((prmbox (%promise-box prm)) … … 102 104 ; Eager has value ready 103 105 ((eager) 104 (apply values value) )106 (apply values value) ) 105 107 ; Force a lazy promise's value 106 108 ((lazy) … … 108 110 (if (%procedure? value) 109 111 ; Force the promise by invoking the thunk 110 (let* ((value (receive (value))) 111 ; Re-fetch and check the top promise again in case it recursed into `force' 112 (prmbox (and (%recursive-promise? prm) (%promise-box prm))) ) 113 ; 114 (cond 115 ; R5RS promise or Eager 116 ((or (not prmbox) (%eager-promise-box? prmbox)) 117 (force prm) ) 118 (else 119 (let* ((prm* (and (= 1 (length value)) (%car value))) 120 (prmbox* (and (%recursive-promise? prm*) (%promise-box prm*))) ) 121 (cond 122 ; Copy the promise to the top 123 (prmbox* 124 (%promise-box-tag-set! prmbox (%promise-box-tag prmbox*)) 125 (%promise-box-value-set! prmbox (%promise-box-value prmbox*)) 126 (%promise-box-set! prm* prmbox) 127 (force prm) ) 128 (else 129 (error 'force "expected a recursive promise" value) ) ) ) ) ) ) 112 (let ((value (receive (value)))) 113 ; Re-fetch and check the top promise again in case it recursed into `force' 114 (let ((prmbox (and (%promise? prm) (%promise-box prm)))) 115 ; Forced value, R5RS or Eager promise? 116 (if (or (not prmbox) (%eager-promise-box? prmbox)) (force prm) 117 ; Value better be a promise (and only a promise) 118 (let ((prm* (and (= 1 (length value)) (%car value)))) 119 (cond 120 ((%promise? prm*) 121 ; Copy the promise to the top 122 (let ((prmbox* (%promise-box prm*))) 123 (%promise-box-tag-set! prmbox (%promise-box-tag prmbox*)) 124 (%promise-box-value-set! prmbox (%promise-box-value prmbox*)) ) 125 (%promise-box-set! prm* prmbox) 126 (force prm) ) 127 ((r5rs:promise? prm*) 128 (r5rs:force prm*) ) 129 (else 130 (error-promise 'force value) ) ) ) ) ) ) 130 131 ; This shouldn't happen 131 (error 'force "expected an un-forced lazy promise"value) ) )132 (error-promise-unforced-lazy 'force value) ) ) 132 133 ; This shouldn't happen 133 134 (else 134 (error-promise- corrupt'force prm) ) ) ) )135 (error-promise-valid 'force prm) ) ) ) ) 135 136 ; Old fashion promise? 136 137 ((r5rs:promise? prm) 137 138 (r5rs:force prm) ) 138 ; No promise at all. Return object per the Chicken manual.139 ; Not a promise at all. Return object per the Chicken manual. 139 140 (else 140 141 prm ) ) ) -
release/4/srfi-45/trunk/tests/run.scm
r14158 r15585 21 21 ; TESTS AND BENCHMARKS: 22 22 ;========================================================================= 23 24 ;========================================================================= 25 ; R5RS & SRFI-45 test 1: 26 27 (print "+++ Should print 'hi 1 +++") 28 29 (define r (delay (begin (display 'hi) (display #\space) 1))) 30 (define s (lazy r)) 31 (define t (lazy s)) 32 (print (force t)) 23 33 24 34 ;=========================================================================
Note: See TracChangeset
for help on using the changeset viewer.