Changeset 39675 in project


Ignore:
Timestamp:
03/12/21 00:29:45 (2 months ago)
Author:
Kon Lovett
Message:

need toplevel symbol, force is not a thunk, type promise predicates, lazy-strict parameter boolean, common code, specific kind of promise, reflow, use larger test limits (should have compiled use >> limits)

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

Legend:

Unmodified
Added
Removed
  • release/5/srfi-45/trunk/srfi-45.egg

    r39663 r39675  
    22
    33((synopsis "SRFI-45: Primitives for Expressing Iterative Lazy Algorithms")
    4  (version "4.0.1")
     4 (version "4.0.2")
    55 (category lang-exts)
    66 (author "André van Tonder, for Chicken 4 by Kon Lovett, for Chicken 5 by [[Sergey Goldgaber]]")
  • release/5/srfi-45/trunk/srfi-45.scm

    r39670 r39675  
    2828(import
    2929  (rename scheme (force r5rs:force) (delay r5rs:delay))
    30   (rename chicken.base (promise? r5rs:promise?))
     30  (rename (chicken base) (promise? r5rs:promise?))
    3131  (chicken type)
    3232  (chicken format)
     
    3737(include "chicken-primitive-object-inlines")
    3838
    39 ;(define recursive-promise 'recursive-promise)
    40 
    4139(define-type recursive-promise (struct recursive-promise))
    4240
     
    4745(: *make-eager-promise ((-> . *) -> recursive-promise))
    4846
    49 (: force (* --> . *))
     47(: force (* -> . *))
    5048
    5149(: promise? (* --> boolean))
    52 (: lazy-promise? (* --> boolean))
    53 (: eager-promise? (* --> boolean))
    54 (: recursive-promise? (* --> boolean))
    55 
    56 (: lazy-strict (#!optional * -> boolean))
     50
     51(: lazy-promise? (* -> boolean : recursive-promise))
     52(: eager-promise? (* -> boolean : recursive-promise))
     53(: recursive-promise? (* -> boolean : recursive-promise))
     54
     55(: lazy-strict (#!optional boolean -> boolean))
    5756
    5857;; Utilities
     
    7170;; Recursive promise
    7271
    73 (define-inline (%make-promise-box tag val) (cons tag val))
    74 (define-inline (%maybe-promise-box? obj) (%pair? obj))
    75 (define-inline (%promise-box-tag prmbox) (%car prmbox))
    76 (define-inline (%promise-box-tag-set! prmbox tag) (%set-car!/mutate prmbox tag))
    77 (define-inline (%promise-box-value prmbox) (%cdr prmbox))
     72(define-inline (%make-promise-box tag val)          (cons tag val))
     73(define-inline (%promise-box-tag prmbox)            (%car prmbox))
     74(define-inline (%promise-box-tag-set! prmbox tag)   (%set-car!/mutate prmbox tag))
     75(define-inline (%promise-box-value prmbox)          (%cdr prmbox))
    7876(define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val))
    7977
    80 (define-inline (%eager-promise-box? obj)
    81   (and (%maybe-promise-box? obj)
    82        (%eq? 'eager (%promise-box-tag obj))) )
    83 
    84 (define-inline (%lazy-promise-box? obj)
    85   (and (%maybe-promise-box? obj)
    86        (%eq? 'lazy (%promise-box-tag obj))) )
    87 
    88 (define-inline (%r5rs-promise-box? obj)
    89   (and (%maybe-promise-box? obj)
    90        (%eq? 'r5rs (%promise-box-tag obj))) )
    91 
    92 (define-inline (%promise-box? obj)
    93   (and (%maybe-promise-box? obj)
    94        (memq (%promise-box-tag obj) '(r5rs eager lazy))) )
     78(define-inline (%promise-box? obj)          (and (%pair? obj) (memq (%promise-box-tag obj) '(r5rs eager lazy))))
     79(define-inline (%promise-box-kind? tag obj) (and (%pair? obj) (%eq? (%promise-box-tag obj) tag)))
     80(define-inline (%eager-promise-box? obj)    (%promise-box-kind? 'eager obj))
     81(define-inline (%lazy-promise-box? obj)     (%promise-box-kind? 'lazy obj))
     82(define-inline (%r5rs-promise-box? obj)     (%promise-box-kind? 'r5rs obj))
    9583
    9684(define-inline (%make-recursive-promise tag val)
    9785  (%make-structure 'recursive-promise (%make-promise-box tag val)) )
    98 (define-inline (%recursive-promise? obj) (%structure-instance? obj 'recursive-promise))
    99 (define-inline (%promise-content prm) (%structure-ref prm 1))
    100 (define-inline (%promise-content-set! prm prmbox) (%structure-set! prm 1 prmbox))
    101 
    102 (define-inline (%make-eager-promise val) (%make-recursive-promise 'eager val))
    103 (define-inline (%eager-promise? obj)
     86
     87(define recursive-promise 'recursive-promise)
     88
     89(define-inline (%recursive-promise? obj)                  (%structure-instance? obj 'recursive-promise))
     90(define-inline (%recursive-promise-content prm)           (%structure-ref prm 1))
     91(define-inline (%recursive-promise-content-set! prm cnt)  (%structure-set! prm 1 cnt))
     92
     93(define-inline (%recursive-promise-kind? tag obj)
     94  ;FIXME assumes promise-content isa promise-box; currently true but ...
    10495  (and (%recursive-promise? obj)
    105        (%eager-promise-box? (%promise-content obj))) )
     96       (%promise-box-kind? tag (%recursive-promise-content obj))) )
     97
     98(define-inline (%make-eager-promise val)  (%make-recursive-promise 'eager val))
     99(define-inline (%eager-promise? obj)      (%recursive-promise-kind? 'eager obj) )
    106100
    107101(define-inline (%make-lazy-promise val) (%make-recursive-promise 'lazy val))
    108 (define-inline (%lazy-promise? obj)
    109   (and (%recursive-promise? obj)
    110        (%lazy-promise-box? (%promise-content obj))))
     102(define-inline (%lazy-promise? obj)     (%recursive-promise-kind? 'lazy obj))
    111103
    112104(define-inline (%coerce-eager-promise-box promise-box results)
     
    124116;;
    125117
    126 (define (*make-lazy-promise thunk) (%make-lazy-promise thunk))
     118(define (*make-lazy-promise thunk)  (%make-lazy-promise thunk))
    127119(define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
    128120
     
    155147;; What kinda promise
    156148
     149#; ;FIXME this doesn't work
    157150(define-record-printer (recursive-promise obj out)
    158151  (display "#<" out)
    159   (let ((content (%promise-content obj)))
     152  (let ((content (%recursive-promise-content obj)))
    160153    (cond
    161154      ((%eager-promise-box? content)  (display "eager promise" out))
     
    175168    ((%recursive-promise? promise)
    176169      ;Unbox
    177       (let ((content (%promise-content promise)))
     170      (let ((content (%recursive-promise-content promise)))
    178171        (paranoid
    179           (unless (%maybe-promise-box? content)
     172          (unless (%promise-box? content)
    180173            (signal-type-error 'force "[1] not a promise-box" content) ) )
    181174        ;Process by kind
     
    207200                    (signal-type-error 'force "[5] not a promise" promise) ) )
    208201                ;Re-fetch the top promise in case it was "forced"
    209                 (let ((content (%promise-content promise)))
     202                (let ((content (%recursive-promise-content promise)))
    210203                  (paranoid
    211204                    ;Still a valid state?
     
    226219                          (if (%lazy-promise-box? content)
    227220                            ;then copy the promise to the top
    228                             (let ((content* (%promise-content promise*)))
     221                            (let ((content* (%recursive-promise-content promise*)))
    229222                              (paranoid
    230223                                (unless (%promise-box? content*)
     
    232225                              (%promise-box-tag-set! content (%promise-box-tag content*))
    233226                              (%promise-box-value-set! content (%promise-box-value content*))
    234                               (%promise-content-set! promise* content) )
     227                              (%recursive-promise-content-set! promise* content) )
    235228                            (paranoid
    236229                              (unless (%eager-promise-box? content)
    237230                                (signal-type-error 'force "[8] not an eager promise" promise))
    238                               (unless (%eager-promise-box? (%promise-content promise*))
     231                              (unless (%eager-promise-box? (%recursive-promise-content promise*))
    239232                                (signal-type-error 'force "[9] not an eager promise" promise*)) ) ) )
    240233                        ;This is a hack & 1/2
     
    270263  (cond
    271264    ((%recursive-promise? promise)
    272       (let ((content (%promise-content promise)))
    273         (unless (%maybe-promise-box? content)
     265      (let ((content (%recursive-promise-content promise)))
     266        (unless (%promise-box? content)
    274267          (signal-type-error 'force "not a promise-box" content) )
    275268        (let ((value (%promise-box-value content)))
     
    282275              (let* ((promise* (value))
    283276                     ;Re-fetch the top promise in case it was "forced"
    284                      (content  (%promise-content promise)))
     277                     (content  (%recursive-promise-content promise)))
    285278                (unless (%eager-promise-box? content)
    286                   (let ((content* (%promise-content promise*)))
     279                  (let ((content* (%recursive-promise-content promise*)))
    287280                    (%promise-box-tag-set! content (%promise-box-tag content*))
    288281                    (%promise-box-value-set! content (%promise-box-value content*)) )
    289                   (%promise-content-set! promise* content) ) )
     282                  (%recursive-promise-content-set! promise* content) ) )
    290283              (force promise) ) ) ) ) )
    291284    ;Old fashion promise?
  • release/5/srfi-45/trunk/tests/srfi-45-test.scm

    r39670 r39675  
    242242(print (force (stream-ref (stream-filter zero? (from 0)) 0)))
    243243
    244 (define s (stream-ref (from 0) 10000 #;100000000))
     244(define s (stream-ref (from 0) 100000 #;10000000000))
    245245
    246246(+bounded-space (force s))
     
    256256(print (force (times3 7)))
    257257
    258 (+bounded-space (force (times3 10000 #;100000000)))
     258(+bounded-space (force (times3 100000 #;10000000000)))
Note: See TracChangeset for help on using the changeset viewer.