Changeset 39683 in project


Ignore:
Timestamp:
03/12/21 23:36:32 (6 weeks ago)
Author:
Kon Lovett
Message:

fix record printing, isolate promise from tagged-box

File:
1 edited

Legend:

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

    r39681 r39683  
    2929  (rename scheme (force r5rs:force) (delay r5rs:delay))
    3030  (rename (chicken base) (promise? r5rs:promise?))
     31  (only (chicken platform) register-feature!)
    3132  (chicken type)
    32   (chicken format)
    33   (chicken platform)
    3433  check-errors)
    3534
     
    8281(define-inline (%r5rs-promise-box? obj)     (%promise-box-kind? 'r5rs obj))
    8382
    84 (define-inline (%make-recursive-promise tag val)
    85   (%make-structure 'recursive-promise (%make-promise-box tag val)) )
    86 
     83;required for proper record tag identity
    8784(define recursive-promise 'recursive-promise)
    8885
     86(define-inline (%make-recursive-promise cnt)              (%make-structure 'recursive-promise cnt))
    8987(define-inline (%recursive-promise? obj)                  (%structure-instance? obj 'recursive-promise))
    9088(define-inline (%recursive-promise-content prm)           (%structure-ref prm 1))
    9189(define-inline (%recursive-promise-content-set! prm cnt)  (%structure-set! prm 1 cnt))
     90
     91(define-inline (%make-recursive-promise-boxed tag val)
     92  (%make-recursive-promise (%make-promise-box tag val)) )
    9293
    9394(define-inline (%recursive-promise-kind? tag obj)
     
    9697       (%promise-box-kind? tag (%recursive-promise-content obj))) )
    9798
    98 (define-inline (%make-eager-promise val)  (%make-recursive-promise 'eager val))
     99(define-inline (%make-eager-promise val)  (%make-recursive-promise-boxed 'eager val))
    99100(define-inline (%eager-promise? obj)      (%recursive-promise-kind? 'eager obj) )
    100101
    101 (define-inline (%make-lazy-promise val) (%make-recursive-promise 'lazy val))
     102(define-inline (%make-lazy-promise val) (%make-recursive-promise-boxed 'lazy val))
    102103(define-inline (%lazy-promise? obj)     (%recursive-promise-kind? 'lazy obj))
    103104
     
    114115  (%promise-box-value-set! promise-box promise) )
    115116
    116 ;; Use SRFI 45 strict semantics for lazy promise
    117 
    118 (define lazy-strict (make-parameter #t))
    119 
    120 ;; Constructors
    121 
    122 (define (*make-lazy-promise thunk)  (%make-lazy-promise thunk))
    123 (define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
    124 
    125 (define-syntax lazy
    126   (syntax-rules ()
    127     ((_ ?expr) (*make-lazy-promise (lambda () ?expr)))))
    128 
    129 (define-syntax eager
    130   (syntax-rules ()
    131     ((_ ?expr) (*make-eager-promise (lambda () ?expr)))))
    132 
    133 (define-syntax delay
    134   (syntax-rules ()
    135     ((_ ?expr) (lazy (eager ?expr)))))
    136 
    137 ;; Predicates
    138 
    139 (define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
    140 
    141 (define (lazy-promise? obj)       (%lazy-promise? obj))
    142 (define (eager-promise? obj)      (%eager-promise? obj))
    143 (define (recursive-promise? obj)  (%recursive-promise? obj))
    144 
    145 ;; What kinda promise
    146 
    147 ;FIXME this doesn't work
    148 (define-record-printer (recursive-promise obj out)
     117(define (print-recursive-promise obj out)
    149118  (display "#<" out)
    150119  (let ((content (%recursive-promise-content obj)))
     
    155124      ((%r5rs-promise-box? content)   (display "r5rs promise" out))
    156125      (else
    157         (fprintf out "unknown promise ~s" content)) ) )
     126        (display "unknown promise " out) (display content out)) ) )
    158127  (display ">" out) )
     128
     129;; Use SRFI 45 strict semantics for lazy promise
     130
     131(define lazy-strict (make-parameter #t))
     132
     133;; Constructors
     134
     135(define (*make-lazy-promise thunk)  (%make-lazy-promise thunk))
     136(define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
     137
     138(define-syntax lazy
     139  (syntax-rules ()
     140    ((_ ?expr) (*make-lazy-promise (lambda () ?expr)))))
     141
     142(define-syntax eager
     143  (syntax-rules ()
     144    ((_ ?expr) (*make-eager-promise (lambda () ?expr)))))
     145
     146(define-syntax delay
     147  (syntax-rules ()
     148    ((_ ?expr) (lazy (eager ?expr)))))
     149
     150;; Predicates
     151
     152(define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
     153
     154(define (lazy-promise? obj)       (%lazy-promise? obj))
     155(define (eager-promise? obj)      (%eager-promise? obj))
     156(define (recursive-promise? obj)  (%recursive-promise? obj))
     157
     158;; What kinda promise
     159
     160;Promise Record Printer
     161;
     162(set! (record-printer recursive-promise) print-recursive-promise)
    159163
    160164;; Force
Note: See TracChangeset for help on using the changeset viewer.