Changeset 20930 in project


Ignore:
Timestamp:
10/22/10 04:42:46 (11 years ago)
Author:
Kon Lovett
Message:

Added `lazy-strict' & compile-time feature srfi-45-paranoia to enable state constraints. Better support for a lazy r5rs promise.

Location:
release/4/srfi-45
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/srfi-45/tags/3.1.0/srfi-45.scm

    r17440 r20930  
    77;;
    88;; - This has been heavily modified from the original in order to extend
    9 ;; rather than supplant the R5RS 'delay'.
     9;; rather than supplant the R5RS 'delay' and to allow multiple value return.
     10;;
     11;; - See `+lazy-strict+' & r5rs usage for potentially dangerous code.
    1012
    1113;;; Module srfi-45
    1214
    13 (module srfi-45 (;export
    14   ; SRFI 45
    15   (lazy make-lazy-promise)
    16   (eager make-eager-promise)
    17   delay
    18   promise?
    19   force
    20   ; Extras
    21   lazy-promise?
    22   eager-promise?
    23   recursive-promise?)
    24 
    25   (import (rename scheme (force r5rs:force) (delay r5rs:delay))
    26           (rename chicken (promise? r5rs:promise?))
    27           type-errors)
    28 
    29   (require-library type-errors)
     15(module srfi-45
     16
     17  (;export
     18    ;SRFI 45
     19    (lazy *make-lazy-promise)
     20    (eager *make-eager-promise)
     21    delay
     22    promise?
     23    force
     24    ;Extras
     25    lazy-promise?
     26    eager-promise?
     27    recursive-promise?
     28    lazy-strict)
     29
     30  (import
     31    (rename scheme (force r5rs:force) (delay r5rs:delay))
     32    (rename chicken (promise? r5rs:promise?))
     33    (only extras fprintf))
     34
     35  (require-extension type-errors)
    3036
    3137  (include "chicken-primitive-object-inlines")
    3238
     39;; Utilities
     40
     41(define-inline (%length=1 ls) (and (not (%null? ls)) (%null? (%cdr ls))))
     42
     43;; Use SRFI 45 strict semantics for lazy promise
     44
     45(define +lazy-strict?+ #t)
     46
     47;; Optional promise state constraint checking
     48
     49(define-syntax paranoid
     50  (syntax-rules ()
     51    ((paranoid ?expr0 ...)
     52      (cond-expand
     53        (srfi-45-paranoia (begin ?expr0 ...))
     54        (else             (begin)))) ) )
     55
    3356;; Recursive promise
    3457
    3558(define-inline (%make-promise-box tag val) (cons tag val))
     59(define-inline (%maybe-promise-box? obj) (%pair? obj))
    3660(define-inline (%promise-box-tag prmbox) (%car prmbox))
    3761(define-inline (%promise-box-tag-set! prmbox tag) (%set-car!/mutate prmbox tag))
     
    3963(define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val))
    4064
    41 (define-inline (%eager-promise-box? prmbox) (%eq? 'eager (%promise-box-tag prmbox)))
    42 (define-inline (%lazy-promise-box? prmbox) (%eq? 'lazy (%promise-box-tag prmbox)))
    43 
    44 (define-inline (%make-promise tag val) (%make-structure 'recursive-promise (%make-promise-box tag val)))
    45 (define-inline (%promise? obj) (%structure-instance? obj 'recursive-promise))
    46 (define-inline (%promise-box prm) (%structure-ref prm 1))
    47 (define-inline (%promise-box-set! prm prmbox) (%structure-set! prm 1 prmbox))
    48 
    49 (define-inline (%make-eager-promise val) (%make-promise 'eager val))
    50 (define-inline (%make-lazy-promise val) (%make-promise 'lazy val))
    51 
    52 (define-inline (%eager-promise? obj) (and (%promise? obj) (%eager-promise-box? (%promise-box obj))))
    53 (define-inline (%lazy-promise? obj) (and (%promise? obj) (%lazy-promise-box? (%promise-box obj))))
    54 
    55 ;; Errors
    56 
    57 (define-error-type promise)
    58 (define-error-type promise-valid "valid promise")
    59 (define-error-type promise-unforced-lazy "unforced lazy promise")
     65(define-inline (%eager-promise-box? obj)
     66  (and (%maybe-promise-box? obj)
     67       (%eq? 'eager (%promise-box-tag obj))) )
     68(define-inline (%lazy-promise-box? obj)
     69  (and (%maybe-promise-box? obj)
     70       (%eq? 'lazy (%promise-box-tag obj))) )
     71(define-inline (%r5rs-promise-box? obj)
     72  (and (%maybe-promise-box? obj)
     73       (%eq? 'r5rs (%promise-box-tag obj))) )
     74
     75(define-inline (%promise-box? obj)
     76  (and (%maybe-promise-box? obj)
     77       (memq (%promise-box-tag obj) '(r5rs eager lazy))) )
     78
     79(define-inline (%make-recursive-promise tag val)
     80  (%make-structure 'recursive-promise (%make-promise-box tag val)) )
     81(define-inline (%recursive-promise? obj) (%structure-instance? obj 'recursive-promise))
     82(define-inline (%promise-content prm) (%structure-ref prm 1))
     83(define-inline (%promise-content-set! prm prmbox) (%structure-set! prm 1 prmbox))
     84
     85(define-inline (%make-eager-promise val) (%make-recursive-promise 'eager val))
     86(define-inline (%eager-promise? obj)
     87  (and (%recursive-promise? obj)
     88       (%eager-promise-box? (%promise-content obj))) )
     89
     90(define-inline (%make-lazy-promise val) (%make-recursive-promise 'lazy val))
     91(define-inline (%lazy-promise? obj)
     92  (and (%recursive-promise? obj)
     93       (%lazy-promise-box? (%promise-content obj))))
     94
     95(define-inline (%coerce-eager-promise-box promise-box results)
     96  #;(assert (%lazy-promise-box? promise-box))
     97  #;(assert (list? results))
     98  (%promise-box-tag-set! promise-box 'eager)
     99  (%promise-box-value-set! promise-box results) )
     100
     101(define-inline (%coerce-r5rs-promise-box promise-box promise)
     102  #;(assert (%lazy-promise-box? promise-box))
     103  #;(assert (r5rs:promise? promise))
     104  (%promise-box-tag-set! promise-box 'r5rs)
     105  (%promise-box-value-set! promise-box promise) )
     106
     107;;
     108
     109(define (*make-lazy-promise thunk) (%make-lazy-promise thunk))
     110(define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
    60111
    61112;; Constructors
    62113
    63 (define (make-lazy-promise thunk) (%make-lazy-promise thunk))
    64 (define (make-eager-promise ls) (%make-eager-promise ls))
    65 
    66 (define-syntax lazy (syntax-rules () ((_ ?expr) (make-lazy-promise (lambda () ?expr)))))
    67 (define-syntax eager (syntax-rules () ((_ ?expr) (make-eager-promise (receive ?expr)))))
    68 (define-syntax delay (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
     114(define-syntax lazy
     115  (syntax-rules ()
     116    ((_ ?expr) (*make-lazy-promise (lambda () ?expr)))))
     117
     118(define-syntax eager
     119  (syntax-rules ()
     120    ((_ ?expr) (*make-eager-promise (lambda () ?expr)))))
     121
     122(define-syntax delay
     123  (syntax-rules ()
     124    ((_ ?expr) (lazy (eager ?expr)))))
    69125
    70126;; Predicates
     
    72128(define (lazy-promise? obj) (%lazy-promise? obj))
    73129(define (eager-promise? obj) (%eager-promise? obj))
    74 (define (recursive-promise? obj) (%promise? obj))
    75 
    76 (define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
     130(define (recursive-promise? obj) (%recursive-promise? obj))
     131
     132(define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
     133
     134;; Use SRFI 45 strict semantics for lazy promise
     135
     136(define (lazy-strict . args)
     137  (if (null? args) +lazy-strict?+
     138    (set! +lazy-strict?+ (%->boolean (car args))) ) )
     139
     140;; What kinda promise
     141
     142(define-record-printer (recursive-promise obj out)
     143  (display "#<" out)
     144  (let ((content (%promise-content obj)))
     145    (cond
     146      ((%eager-promise-box? content)  (display "eager promise" out))
     147      ((%lazy-promise-box? content)   (display "lazy promise" out))
     148      ;This shouldn't be visible
     149      ((%r5rs-promise-box? content)   (display "r5rs promise" out))
     150      (else
     151        (fprintf out "unknown promise ~s" content)) ) )
     152  (display ">" out) )
    77153
    78154;; Force
    79155
    80 (define (force prm)
    81   ; What kind of promise?
     156(define (force promise)
     157  ;What kind of promise?
    82158  (cond
    83     ; New fashion promise?
    84     ((%promise? prm)
    85       ; Unbox
    86       (let* ((prmbox (%promise-box prm))
    87              (value (%promise-box-value prmbox)))
    88         ; Process by kind
    89         (case (%promise-box-tag prmbox)
    90           ; Eager has value ready
    91           ((eager)
    92             (apply values value) )
    93           ; Force a lazy promise's value
    94           ((lazy)
    95             ; Better be an un-evaluated thunk
    96             (if (%procedure? value)
    97                 ; Force the promise by invoking the thunk
    98                 (let ((value* (receive (value))))
    99                   ; Re-fetch and check the top promise again in case it recursed into `force'
    100                   (let ((prmbox (and (%promise? prm) (%promise-box prm))))
    101                     ; Forced value, R5RS or Eager promise?
    102                     (if (or (not prmbox) (%eager-promise-box? prmbox)) (force prm)
    103                         ; Value better be a promise (and only a promise)
    104                         (let ((prm* (and (= 1 (length value*)) (%car value*))))
    105                           (cond
    106                             ((%promise? prm*)
    107                               ; Copy the promise to the top
    108                               (let ((prmbox* (%promise-box prm*)))
    109                                 (%promise-box-tag-set! prmbox (%promise-box-tag prmbox*))
    110                                 (%promise-box-value-set! prmbox (%promise-box-value prmbox*)) )
    111                               (%promise-box-set! prm* prmbox)
    112                               (force prm) )
    113                             ((r5rs:promise? prm*)
    114                               (r5rs:force prm*) )
    115                             (else
    116                               (error-promise 'force value*) ) ) ) ) ) )
    117                 ; This shouldn't happen
    118                 (error-promise-unforced-lazy 'force value) ) )
    119           ; This shouldn't happen
    120           (else
    121             (error-promise-valid 'force prm) ) ) ) )
    122     ; Old fashion promise?
    123     ((r5rs:promise? prm)
    124       (r5rs:force prm) )
    125     ; Not a promise at all. Return object per the Chicken manual.
     159    ;New fashion promise?
     160    ((%recursive-promise? promise)
     161      ;Unbox
     162      (let ((content (%promise-content promise)))
     163        (paranoid
     164          (unless (%maybe-promise-box? content)
     165            (signal-type-error 'force
     166              "[1] not a promise-box" content) ) )
     167        ;Process by kind
     168        (let ((value (%promise-box-value content)))
     169          (case (%promise-box-tag content)
     170            ;Hack to allow lazy to have an R5RS promise
     171            ((r5rs)
     172              (paranoid
     173                (unless (r5rs:promise? value)
     174                  (signal-type-error 'force
     175                    "[2] not a R5RS promise" value) ) )
     176              (r5rs:force value) )
     177            ;Eager has value ready
     178            ((eager)
     179              (paranoid
     180                (unless (%pair? value)
     181                  (signal-type-error 'force
     182                    "[3] not an eager promise value" value) ) )
     183              (apply values value) )
     184            ;Force a lazy promise's value
     185            ((lazy)
     186              (paranoid
     187                ;Must be an un-forced value (i.e. still a thunk)
     188                (unless (%procedure? value)
     189                  (signal-type-error 'force
     190                    "[4] not a lazy promise thunk" value) ) )
     191              ;Force the promise by invoking the thunk
     192              (let ((results (call-with-values value list)))
     193                (paranoid
     194                  ;Still a valid state?
     195                  (unless (%recursive-promise? promise)
     196                    (signal-type-error 'force
     197                      "[5] not a promise" promise) ) )
     198                ;Re-fetch the top promise in case it was "forced"
     199                (let ((content (%promise-content promise)))
     200                  (paranoid
     201                    ;Still a valid state?
     202                    (unless (%promise-box? content)
     203                      (signal-type-error 'force
     204                        "[6] not a promise-box" content) ) )
     205                  ;Check for proper use
     206                  (if (not (%length=1 results))
     207                    ;then `lazy' used improperly
     208                    (if +lazy-strict?+
     209                      (error 'force "improper use of `lazy'" results)
     210                      ;Ignore misuse - What was lazy is now eager
     211                      (%coerce-eager-promise-box content results) )
     212                    ;else should be promise
     213                    (let ((promise* (%car results)))
     214                      (cond
     215                        ;Per SRFI 45 only valid state
     216                        ((%recursive-promise? promise*)
     217                          (if (%lazy-promise-box? content)
     218                            ;then copy the promise to the top
     219                            (let ((content* (%promise-content promise*)))
     220                              (paranoid
     221                                (unless (%promise-box? content*)
     222                                  (signal-type-error 'force
     223                                    "[7] not a promise-box" content*) ) )
     224                              (%promise-box-tag-set! content (%promise-box-tag content*))
     225                              (%promise-box-value-set! content (%promise-box-value content*))
     226                              (%promise-content-set! promise* content) )
     227                            (paranoid
     228                              (unless (%eager-promise-box? content)
     229                                (signal-type-error 'force
     230                                  "[8] not an eager promise" promise))
     231                              (unless (%eager-promise-box? (%promise-content promise*))
     232                                (signal-type-error 'force
     233                                  "[9] not an eager promise" promise*)) ) ) )
     234                        ;This is a hack & 1/2
     235                        ((r5rs:promise? promise*)
     236                          (if (%lazy-promise-box? content)
     237                            (%coerce-r5rs-promise-box content promise*)
     238                            (paranoid
     239                              ;FIXME Only possiblility is lazy
     240                              (unless (%eager-promise-box? content)
     241                                (signal-type-error 'force
     242                                  "[10] not an eager promise" promise)) ) ) )
     243                        ;So `lazy' used improperly
     244                        (else
     245                          (if +lazy-strict?+
     246                            (error 'force "improper use of `lazy'" promise*)
     247                            ;Ignore misuse - What was lazy is now eager
     248                            (%coerce-eager-promise-box content results) ) ) ) ) ) ) )
     249              ;Recursive forcing - remember
     250              (force promise) )
     251            ;Not a proper recursive promise
     252            (else
     253              (signal-type-error 'force
     254                "unknown recursive promise content" content) ) ) ) ) )
     255    ;Old fashion promise?
     256    ((r5rs:promise? promise)
     257      (r5rs:force promise) )
     258    ;Not a promise at all
     259    ;Return object per the Chicken manual
    126260    (else
    127       prm ) ) )
     261      promise ) ) )
     262
     263#; ;Essentially the reference implmenentation
     264(define (force promise)
     265  (cond
     266    ((%recursive-promise? promise)
     267      (let ((content (%promise-content promise)))
     268        (unless (%maybe-promise-box? content)
     269          (signal-type-error 'force "not a promise-box" content) )
     270        (let ((value (%promise-box-value content)))
     271          (case (%promise-box-tag content)
     272            ((eager)
     273              (apply values value))
     274            ((lazy)
     275              ;Assumes lazy can only be applied to an expression yielding
     276              ;another promise
     277              (let* ((promise* (value))
     278                     ;Re-fetch the top promise in case it was "forced"
     279                     (content  (%promise-content promise)))
     280                (unless (%eager-promise-box? content)
     281                  (let ((content* (%promise-content promise*)))
     282                    (%promise-box-tag-set! content (%promise-box-tag content*))
     283                    (%promise-box-value-set! content (%promise-box-value content*)) )
     284                  (%promise-content-set! promise* content) ) )
     285              (force promise) ) ) ) ) )
     286    ;Old fashion promise?
     287    ((r5rs:promise? promise)
     288      (r5rs:force promise) )
     289    ;Not a promise at all
     290    ;Return object per the Chicken manual
     291    (else
     292      promise ) ) )
    128293
    129294;;;
  • release/4/srfi-45/tags/3.1.0/srfi-45.setup

    r20308 r20930  
    55(verify-extension-name "srfi-45")
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "3.0.0")
     7(setup-shared-extension-module (extension-name) (extension-version "3.1.0")
    88  #:compile-options '(
    99    -disable-interrupts
    10     -optimize-level 3
    1110    -fixnum-arithmetic
     11    -optimize-level 3 -debug-level 1
    1212    -no-procedure-checks))
  • release/4/srfi-45/tags/3.1.0/tests/run.scm

    r15602 r20930  
    33(module test ()
    44
    5 (import (rename scheme (force r5rs:force) (delay r5rs:delay))
    6         (rename chicken (promise? r5rs:promise?))
    7         srfi-45)
    8 
    9 (require-library srfi-45)
     5(import
     6  (rename scheme (force r5rs:force) (delay r5rs:delay))
     7  (rename chicken (promise? r5rs:promise?)))
     8
     9(require-extension srfi-45)
    1010
    1111;; Perform, or not, a bounded space test.
  • release/4/srfi-45/trunk/srfi-45.scm

    r17440 r20930  
    77;;
    88;; - This has been heavily modified from the original in order to extend
    9 ;; rather than supplant the R5RS 'delay'.
     9;; rather than supplant the R5RS 'delay' and to allow multiple value return.
     10;;
     11;; - See `+lazy-strict+' & r5rs usage for potentially dangerous code.
    1012
    1113;;; Module srfi-45
    1214
    13 (module srfi-45 (;export
    14   ; SRFI 45
    15   (lazy make-lazy-promise)
    16   (eager make-eager-promise)
    17   delay
    18   promise?
    19   force
    20   ; Extras
    21   lazy-promise?
    22   eager-promise?
    23   recursive-promise?)
    24 
    25   (import (rename scheme (force r5rs:force) (delay r5rs:delay))
    26           (rename chicken (promise? r5rs:promise?))
    27           type-errors)
    28 
    29   (require-library type-errors)
     15(module srfi-45
     16
     17  (;export
     18    ;SRFI 45
     19    (lazy *make-lazy-promise)
     20    (eager *make-eager-promise)
     21    delay
     22    promise?
     23    force
     24    ;Extras
     25    lazy-promise?
     26    eager-promise?
     27    recursive-promise?
     28    lazy-strict)
     29
     30  (import
     31    (rename scheme (force r5rs:force) (delay r5rs:delay))
     32    (rename chicken (promise? r5rs:promise?))
     33    (only extras fprintf))
     34
     35  (require-extension type-errors)
    3036
    3137  (include "chicken-primitive-object-inlines")
    3238
     39;; Utilities
     40
     41(define-inline (%length=1 ls) (and (not (%null? ls)) (%null? (%cdr ls))))
     42
     43;; Use SRFI 45 strict semantics for lazy promise
     44
     45(define +lazy-strict?+ #t)
     46
     47;; Optional promise state constraint checking
     48
     49(define-syntax paranoid
     50  (syntax-rules ()
     51    ((paranoid ?expr0 ...)
     52      (cond-expand
     53        (srfi-45-paranoia (begin ?expr0 ...))
     54        (else             (begin)))) ) )
     55
    3356;; Recursive promise
    3457
    3558(define-inline (%make-promise-box tag val) (cons tag val))
     59(define-inline (%maybe-promise-box? obj) (%pair? obj))
    3660(define-inline (%promise-box-tag prmbox) (%car prmbox))
    3761(define-inline (%promise-box-tag-set! prmbox tag) (%set-car!/mutate prmbox tag))
     
    3963(define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val))
    4064
    41 (define-inline (%eager-promise-box? prmbox) (%eq? 'eager (%promise-box-tag prmbox)))
    42 (define-inline (%lazy-promise-box? prmbox) (%eq? 'lazy (%promise-box-tag prmbox)))
    43 
    44 (define-inline (%make-promise tag val) (%make-structure 'recursive-promise (%make-promise-box tag val)))
    45 (define-inline (%promise? obj) (%structure-instance? obj 'recursive-promise))
    46 (define-inline (%promise-box prm) (%structure-ref prm 1))
    47 (define-inline (%promise-box-set! prm prmbox) (%structure-set! prm 1 prmbox))
    48 
    49 (define-inline (%make-eager-promise val) (%make-promise 'eager val))
    50 (define-inline (%make-lazy-promise val) (%make-promise 'lazy val))
    51 
    52 (define-inline (%eager-promise? obj) (and (%promise? obj) (%eager-promise-box? (%promise-box obj))))
    53 (define-inline (%lazy-promise? obj) (and (%promise? obj) (%lazy-promise-box? (%promise-box obj))))
    54 
    55 ;; Errors
    56 
    57 (define-error-type promise)
    58 (define-error-type promise-valid "valid promise")
    59 (define-error-type promise-unforced-lazy "unforced lazy promise")
     65(define-inline (%eager-promise-box? obj)
     66  (and (%maybe-promise-box? obj)
     67       (%eq? 'eager (%promise-box-tag obj))) )
     68(define-inline (%lazy-promise-box? obj)
     69  (and (%maybe-promise-box? obj)
     70       (%eq? 'lazy (%promise-box-tag obj))) )
     71(define-inline (%r5rs-promise-box? obj)
     72  (and (%maybe-promise-box? obj)
     73       (%eq? 'r5rs (%promise-box-tag obj))) )
     74
     75(define-inline (%promise-box? obj)
     76  (and (%maybe-promise-box? obj)
     77       (memq (%promise-box-tag obj) '(r5rs eager lazy))) )
     78
     79(define-inline (%make-recursive-promise tag val)
     80  (%make-structure 'recursive-promise (%make-promise-box tag val)) )
     81(define-inline (%recursive-promise? obj) (%structure-instance? obj 'recursive-promise))
     82(define-inline (%promise-content prm) (%structure-ref prm 1))
     83(define-inline (%promise-content-set! prm prmbox) (%structure-set! prm 1 prmbox))
     84
     85(define-inline (%make-eager-promise val) (%make-recursive-promise 'eager val))
     86(define-inline (%eager-promise? obj)
     87  (and (%recursive-promise? obj)
     88       (%eager-promise-box? (%promise-content obj))) )
     89
     90(define-inline (%make-lazy-promise val) (%make-recursive-promise 'lazy val))
     91(define-inline (%lazy-promise? obj)
     92  (and (%recursive-promise? obj)
     93       (%lazy-promise-box? (%promise-content obj))))
     94
     95(define-inline (%coerce-eager-promise-box promise-box results)
     96  #;(assert (%lazy-promise-box? promise-box))
     97  #;(assert (list? results))
     98  (%promise-box-tag-set! promise-box 'eager)
     99  (%promise-box-value-set! promise-box results) )
     100
     101(define-inline (%coerce-r5rs-promise-box promise-box promise)
     102  #;(assert (%lazy-promise-box? promise-box))
     103  #;(assert (r5rs:promise? promise))
     104  (%promise-box-tag-set! promise-box 'r5rs)
     105  (%promise-box-value-set! promise-box promise) )
     106
     107;;
     108
     109(define (*make-lazy-promise thunk) (%make-lazy-promise thunk))
     110(define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
    60111
    61112;; Constructors
    62113
    63 (define (make-lazy-promise thunk) (%make-lazy-promise thunk))
    64 (define (make-eager-promise ls) (%make-eager-promise ls))
    65 
    66 (define-syntax lazy (syntax-rules () ((_ ?expr) (make-lazy-promise (lambda () ?expr)))))
    67 (define-syntax eager (syntax-rules () ((_ ?expr) (make-eager-promise (receive ?expr)))))
    68 (define-syntax delay (syntax-rules () ((_ ?expr) (lazy (eager ?expr)))))
     114(define-syntax lazy
     115  (syntax-rules ()
     116    ((_ ?expr) (*make-lazy-promise (lambda () ?expr)))))
     117
     118(define-syntax eager
     119  (syntax-rules ()
     120    ((_ ?expr) (*make-eager-promise (lambda () ?expr)))))
     121
     122(define-syntax delay
     123  (syntax-rules ()
     124    ((_ ?expr) (lazy (eager ?expr)))))
    69125
    70126;; Predicates
     
    72128(define (lazy-promise? obj) (%lazy-promise? obj))
    73129(define (eager-promise? obj) (%eager-promise? obj))
    74 (define (recursive-promise? obj) (%promise? obj))
    75 
    76 (define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
     130(define (recursive-promise? obj) (%recursive-promise? obj))
     131
     132(define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
     133
     134;; Use SRFI 45 strict semantics for lazy promise
     135
     136(define (lazy-strict . args)
     137  (if (null? args) +lazy-strict?+
     138    (set! +lazy-strict?+ (%->boolean (car args))) ) )
     139
     140;; What kinda promise
     141
     142(define-record-printer (recursive-promise obj out)
     143  (display "#<" out)
     144  (let ((content (%promise-content obj)))
     145    (cond
     146      ((%eager-promise-box? content)  (display "eager promise" out))
     147      ((%lazy-promise-box? content)   (display "lazy promise" out))
     148      ;This shouldn't be visible
     149      ((%r5rs-promise-box? content)   (display "r5rs promise" out))
     150      (else
     151        (fprintf out "unknown promise ~s" content)) ) )
     152  (display ">" out) )
    77153
    78154;; Force
    79155
    80 (define (force prm)
    81   ; What kind of promise?
     156(define (force promise)
     157  ;What kind of promise?
    82158  (cond
    83     ; New fashion promise?
    84     ((%promise? prm)
    85       ; Unbox
    86       (let* ((prmbox (%promise-box prm))
    87              (value (%promise-box-value prmbox)))
    88         ; Process by kind
    89         (case (%promise-box-tag prmbox)
    90           ; Eager has value ready
    91           ((eager)
    92             (apply values value) )
    93           ; Force a lazy promise's value
    94           ((lazy)
    95             ; Better be an un-evaluated thunk
    96             (if (%procedure? value)
    97                 ; Force the promise by invoking the thunk
    98                 (let ((value* (receive (value))))
    99                   ; Re-fetch and check the top promise again in case it recursed into `force'
    100                   (let ((prmbox (and (%promise? prm) (%promise-box prm))))
    101                     ; Forced value, R5RS or Eager promise?
    102                     (if (or (not prmbox) (%eager-promise-box? prmbox)) (force prm)
    103                         ; Value better be a promise (and only a promise)
    104                         (let ((prm* (and (= 1 (length value*)) (%car value*))))
    105                           (cond
    106                             ((%promise? prm*)
    107                               ; Copy the promise to the top
    108                               (let ((prmbox* (%promise-box prm*)))
    109                                 (%promise-box-tag-set! prmbox (%promise-box-tag prmbox*))
    110                                 (%promise-box-value-set! prmbox (%promise-box-value prmbox*)) )
    111                               (%promise-box-set! prm* prmbox)
    112                               (force prm) )
    113                             ((r5rs:promise? prm*)
    114                               (r5rs:force prm*) )
    115                             (else
    116                               (error-promise 'force value*) ) ) ) ) ) )
    117                 ; This shouldn't happen
    118                 (error-promise-unforced-lazy 'force value) ) )
    119           ; This shouldn't happen
    120           (else
    121             (error-promise-valid 'force prm) ) ) ) )
    122     ; Old fashion promise?
    123     ((r5rs:promise? prm)
    124       (r5rs:force prm) )
    125     ; Not a promise at all. Return object per the Chicken manual.
     159    ;New fashion promise?
     160    ((%recursive-promise? promise)
     161      ;Unbox
     162      (let ((content (%promise-content promise)))
     163        (paranoid
     164          (unless (%maybe-promise-box? content)
     165            (signal-type-error 'force
     166              "[1] not a promise-box" content) ) )
     167        ;Process by kind
     168        (let ((value (%promise-box-value content)))
     169          (case (%promise-box-tag content)
     170            ;Hack to allow lazy to have an R5RS promise
     171            ((r5rs)
     172              (paranoid
     173                (unless (r5rs:promise? value)
     174                  (signal-type-error 'force
     175                    "[2] not a R5RS promise" value) ) )
     176              (r5rs:force value) )
     177            ;Eager has value ready
     178            ((eager)
     179              (paranoid
     180                (unless (%pair? value)
     181                  (signal-type-error 'force
     182                    "[3] not an eager promise value" value) ) )
     183              (apply values value) )
     184            ;Force a lazy promise's value
     185            ((lazy)
     186              (paranoid
     187                ;Must be an un-forced value (i.e. still a thunk)
     188                (unless (%procedure? value)
     189                  (signal-type-error 'force
     190                    "[4] not a lazy promise thunk" value) ) )
     191              ;Force the promise by invoking the thunk
     192              (let ((results (call-with-values value list)))
     193                (paranoid
     194                  ;Still a valid state?
     195                  (unless (%recursive-promise? promise)
     196                    (signal-type-error 'force
     197                      "[5] not a promise" promise) ) )
     198                ;Re-fetch the top promise in case it was "forced"
     199                (let ((content (%promise-content promise)))
     200                  (paranoid
     201                    ;Still a valid state?
     202                    (unless (%promise-box? content)
     203                      (signal-type-error 'force
     204                        "[6] not a promise-box" content) ) )
     205                  ;Check for proper use
     206                  (if (not (%length=1 results))
     207                    ;then `lazy' used improperly
     208                    (if +lazy-strict?+
     209                      (error 'force "improper use of `lazy'" results)
     210                      ;Ignore misuse - What was lazy is now eager
     211                      (%coerce-eager-promise-box content results) )
     212                    ;else should be promise
     213                    (let ((promise* (%car results)))
     214                      (cond
     215                        ;Per SRFI 45 only valid state
     216                        ((%recursive-promise? promise*)
     217                          (if (%lazy-promise-box? content)
     218                            ;then copy the promise to the top
     219                            (let ((content* (%promise-content promise*)))
     220                              (paranoid
     221                                (unless (%promise-box? content*)
     222                                  (signal-type-error 'force
     223                                    "[7] not a promise-box" content*) ) )
     224                              (%promise-box-tag-set! content (%promise-box-tag content*))
     225                              (%promise-box-value-set! content (%promise-box-value content*))
     226                              (%promise-content-set! promise* content) )
     227                            (paranoid
     228                              (unless (%eager-promise-box? content)
     229                                (signal-type-error 'force
     230                                  "[8] not an eager promise" promise))
     231                              (unless (%eager-promise-box? (%promise-content promise*))
     232                                (signal-type-error 'force
     233                                  "[9] not an eager promise" promise*)) ) ) )
     234                        ;This is a hack & 1/2
     235                        ((r5rs:promise? promise*)
     236                          (if (%lazy-promise-box? content)
     237                            (%coerce-r5rs-promise-box content promise*)
     238                            (paranoid
     239                              ;FIXME Only possiblility is lazy
     240                              (unless (%eager-promise-box? content)
     241                                (signal-type-error 'force
     242                                  "[10] not an eager promise" promise)) ) ) )
     243                        ;So `lazy' used improperly
     244                        (else
     245                          (if +lazy-strict?+
     246                            (error 'force "improper use of `lazy'" promise*)
     247                            ;Ignore misuse - What was lazy is now eager
     248                            (%coerce-eager-promise-box content results) ) ) ) ) ) ) )
     249              ;Recursive forcing - remember
     250              (force promise) )
     251            ;Not a proper recursive promise
     252            (else
     253              (signal-type-error 'force
     254                "unknown recursive promise content" content) ) ) ) ) )
     255    ;Old fashion promise?
     256    ((r5rs:promise? promise)
     257      (r5rs:force promise) )
     258    ;Not a promise at all
     259    ;Return object per the Chicken manual
    126260    (else
    127       prm ) ) )
     261      promise ) ) )
     262
     263#; ;Essentially the reference implmenentation
     264(define (force promise)
     265  (cond
     266    ((%recursive-promise? promise)
     267      (let ((content (%promise-content promise)))
     268        (unless (%maybe-promise-box? content)
     269          (signal-type-error 'force "not a promise-box" content) )
     270        (let ((value (%promise-box-value content)))
     271          (case (%promise-box-tag content)
     272            ((eager)
     273              (apply values value))
     274            ((lazy)
     275              ;Assumes lazy can only be applied to an expression yielding
     276              ;another promise
     277              (let* ((promise* (value))
     278                     ;Re-fetch the top promise in case it was "forced"
     279                     (content  (%promise-content promise)))
     280                (unless (%eager-promise-box? content)
     281                  (let ((content* (%promise-content promise*)))
     282                    (%promise-box-tag-set! content (%promise-box-tag content*))
     283                    (%promise-box-value-set! content (%promise-box-value content*)) )
     284                  (%promise-content-set! promise* content) ) )
     285              (force promise) ) ) ) ) )
     286    ;Old fashion promise?
     287    ((r5rs:promise? promise)
     288      (r5rs:force promise) )
     289    ;Not a promise at all
     290    ;Return object per the Chicken manual
     291    (else
     292      promise ) ) )
    128293
    129294;;;
  • release/4/srfi-45/trunk/srfi-45.setup

    r20308 r20930  
    55(verify-extension-name "srfi-45")
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "3.0.0")
     7(setup-shared-extension-module (extension-name) (extension-version "3.1.0")
    88  #:compile-options '(
    99    -disable-interrupts
    10     -optimize-level 3
    1110    -fixnum-arithmetic
     11    -optimize-level 3 -debug-level 1
    1212    -no-procedure-checks))
  • release/4/srfi-45/trunk/tests/run.scm

    r15602 r20930  
    33(module test ()
    44
    5 (import (rename scheme (force r5rs:force) (delay r5rs:delay))
    6         (rename chicken (promise? r5rs:promise?))
    7         srfi-45)
    8 
    9 (require-library srfi-45)
     5(import
     6  (rename scheme (force r5rs:force) (delay r5rs:delay))
     7  (rename chicken (promise? r5rs:promise?)))
     8
     9(require-extension srfi-45)
    1010
    1111;; Perform, or not, a bounded space test.
Note: See TracChangeset for help on using the changeset viewer.