Changeset 15585 in project


Ignore:
Timestamp:
08/27/09 21:58:03 (11 years ago)
Author:
Kon Lovett
Message:

Use of "check-errors", fix for use of R5RS promise with a lazy promise.

Location:
release/4/srfi-45/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed

  • release/4/srfi-45/trunk/srfi-45.meta

    r14155 r15585  
    77 (doc-from-wiki)
    88 (synopsis "Primitives for Expressing Iterative Lazy Algorithms")
    9  (needs setup-helper)
     9 (needs setup-helper check-errors)
    1010 (files
    1111  "tests"

  • release/4/srfi-45/trunk/srfi-45.scm

    r14170 r15585  
    2323(include "chicken-primitive-object-inlines")
    2424
     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
    2544;; Recursive promise
    2645
    2746(define-inline (%make-promise-box tag val) (cons tag val))
    2847(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))
    3049(define-inline (%promise-box-value prmbox) (%cdr prmbox))
    3150(define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val))
    … …  
    3453(define-inline (%lazy-promise-box? prmbox) (%eq? 'lazy (%promise-box-tag prmbox)))
    3554
    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))
    3857(define-inline (%promise-box prm) (%structure-ref prm 1))
    3958(define-inline (%promise-box-set! prm prmbox) (%structure-set! prm 1 prmbox))
    … …  
    4362
    4463(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))))
    6865
    6966;; Errors
    7067
    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")
    7371
    7472;; Constructors
    7573
    76 (define ($$finlzy thunk) (%make-lazy-promise thunk))
    77 (define ($$finegr ls) (%make-eager-promise ls))
     74(define (make-lazy-promise thunk) (%make-lazy-promise thunk))
     75(define (make-eager-promise ls) (%make-eager-promise ls))
    7876
    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)))))
    8182(define-syntax d-lay (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
    8283
    … …  
    8586(define (lazy-promise? obj) (%lazy-promise? obj))
    8687(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)))
    8991
    9092;; Force
    … …  
    9496  (cond
    9597    ; New fashion promise?
    96     ((%recursive-promise? prm)
     98    ((%promise? prm)
    9799      ; Unbox
    98100      (let* ((prmbox (%promise-box prm))
    … …  
    102104          ; Eager has value ready
    103105          ((eager)
    104             (apply values value))
     106            (apply values value) )
    105107          ; Force a lazy promise's value
    106108          ((lazy)
    … …  
    108110            (if (%procedure? value)
    109111                ; 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) ) ) ) ) ) )
    130131                ; This shouldn't happen
    131                 (error 'force "expected an un-forced lazy promise" value) ) )
     132                (error-promise-unforced-lazy 'force value) ) )
    132133          ; This shouldn't happen
    133134          (else
    134             (error-promise-corrupt 'force prm) ) ) ) )
     135            (error-promise-valid 'force prm) ) ) ) )
    135136    ; Old fashion promise?
    136137    ((r5rs:promise? prm)
    137138      (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.
    139140    (else
    140141      prm ) ) )

  • release/4/srfi-45/trunk/tests/run.scm

    r14158 r15585  
    2121; TESTS AND BENCHMARKS:
    2222;=========================================================================
     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))
    2333
    2434;=========================================================================
Note: See TracChangeset for help on using the changeset viewer.