Changeset 39683 in project

Timestamp:

03/12/21 23:36:32 (6 weeks ago)

Author:

Kon Lovett

Message:

fix record printing, isolate promise from tagged-box

File:

• release/5/srfi-45/trunk/srfi-45.scm (modified) (5 diffs)

release/5/srfi-45/trunk/srfi-45.scm

@@ -29 +29 @@
   (rename scheme (force r5rs:force) (delay r5rs:delay))
   (rename (chicken base) (promise? r5rs:promise?))
+  (only (chicken platform) register-feature!)
   (chicken type)
-  (chicken format)
-  (chicken platform)
   check-errors)
 
@@ -82 +81 @@
 (define-inline (%r5rs-promise-box? obj)     (%promise-box-kind? 'r5rs obj))
 
-(define-inline (%make-recursive-promise tag val)
-  (%make-structure 'recursive-promise (%make-promise-box tag val)) )
-
+;required for proper record tag identity
 (define recursive-promise 'recursive-promise)
 
+(define-inline (%make-recursive-promise cnt)              (%make-structure 'recursive-promise cnt))
 (define-inline (%recursive-promise? obj)                  (%structure-instance? obj 'recursive-promise))
 (define-inline (%recursive-promise-content prm)           (%structure-ref prm 1))
 (define-inline (%recursive-promise-content-set! prm cnt)  (%structure-set! prm 1 cnt))
+
+(define-inline (%make-recursive-promise-boxed tag val)
+  (%make-recursive-promise (%make-promise-box tag val)) )
 
 (define-inline (%recursive-promise-kind? tag obj)
@@ -96 +97 @@
        (%promise-box-kind? tag (%recursive-promise-content obj))) )
 
-(define-inline (%make-eager-promise val)  (%make-recursive-promise 'eager val))
+(define-inline (%make-eager-promise val)  (%make-recursive-promise-boxed 'eager val))
 (define-inline (%eager-promise? obj)      (%recursive-promise-kind? 'eager obj) )
 
-(define-inline (%make-lazy-promise val) (%make-recursive-promise 'lazy val))
+(define-inline (%make-lazy-promise val) (%make-recursive-promise-boxed 'lazy val))
 (define-inline (%lazy-promise? obj)     (%recursive-promise-kind? 'lazy obj))
 
@@ -114 +115 @@
   (%promise-box-value-set! promise-box promise) )
 
-;; Use SRFI 45 strict semantics for lazy promise
-
-(define lazy-strict (make-parameter #t))
-
-;; Constructors
-
-(define (*make-lazy-promise thunk)  (%make-lazy-promise thunk))
-(define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
-
-(define-syntax lazy
-  (syntax-rules ()
-    ((_ ?expr) (*make-lazy-promise (lambda () ?expr)))))
-
-(define-syntax eager
-  (syntax-rules ()
-    ((_ ?expr) (*make-eager-promise (lambda () ?expr)))))
-
-(define-syntax delay
-  (syntax-rules ()
-    ((_ ?expr) (lazy (eager ?expr)))))
-
-;; Predicates
-
-(define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
-
-(define (lazy-promise? obj)       (%lazy-promise? obj))
-(define (eager-promise? obj)      (%eager-promise? obj))
-(define (recursive-promise? obj)  (%recursive-promise? obj))
-
-;; What kinda promise
-
-;FIXME this doesn't work
-(define-record-printer (recursive-promise obj out)
+(define (print-recursive-promise obj out)
   (display "#<" out)
   (let ((content (%recursive-promise-content obj)))
@@ -155 +124 @@
       ((%r5rs-promise-box? content)   (display "r5rs promise" out))
       (else
-        (fprintf out "unknown promise ~s" content)) ) )
+        (display "unknown promise " out) (display content out)) ) )
   (display ">" out) )
+
+;; Use SRFI 45 strict semantics for lazy promise
+
+(define lazy-strict (make-parameter #t))
+
+;; Constructors
+
+(define (*make-lazy-promise thunk)  (%make-lazy-promise thunk))
+(define (*make-eager-promise thunk) (%make-eager-promise (call-with-values thunk list)))
+
+(define-syntax lazy
+  (syntax-rules ()
+    ((_ ?expr) (*make-lazy-promise (lambda () ?expr)))))
+
+(define-syntax eager
+  (syntax-rules ()
+    ((_ ?expr) (*make-eager-promise (lambda () ?expr)))))
+
+(define-syntax delay
+  (syntax-rules ()
+    ((_ ?expr) (lazy (eager ?expr)))))
+
+;; Predicates
+
+(define (promise? obj) (or (r5rs:promise? obj) (%recursive-promise? obj)))
+
+(define (lazy-promise? obj)       (%lazy-promise? obj))
+(define (eager-promise? obj)      (%eager-promise? obj))
+(define (recursive-promise? obj)  (%recursive-promise? obj))
+
+;; What kinda promise
+
+;Promise Record Printer
+;
+(set! (record-printer recursive-promise) print-recursive-promise)
 
 ;; Force