Changeset 39692 in project


Ignore:
Timestamp:
03/13/21 21:06:36 (2 months ago)
Author:
Kon Lovett
Message:

remove "primitives", use record-variants, add promise print tests

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

Legend:

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

    r39688 r39692  
    77 (maintainer "Kon Lovett")
    88 (license "BSD")
    9  (dependencies check-errors)
     9 (dependencies record-variants check-errors)
    1010 (test-dependencies test)
    1111 (components
  • release/5/srfi-45/trunk/srfi-45.scm

    r39688 r39692  
    3131  (only (chicken platform) register-feature!)
    3232  (chicken type)
    33   check-errors)
    34 
    35 ;very unsafe
    36 (include "chicken-primitive-object-inlines")
    37 
    38 (define-type recursive-promise (struct recursive-promise))
    39 
    40 ;(define-type r5rs:promise promise)
    41 ;(define-type promise* (or r5rs:promise recursive-promise))
    42 
    43 (: *make-lazy-promise ((-> . *) -> recursive-promise))
    44 (: *make-eager-promise ((-> . *) -> recursive-promise))
    45 
    46 (: force (* -> . *))
    47 
    48 (: promise? (* --> boolean))
    49 
    50 (: lazy-promise? (* -> boolean : recursive-promise))
    51 (: eager-promise? (* -> boolean : recursive-promise))
    52 (: recursive-promise? (* -> boolean : recursive-promise))
    53 
    54 (: lazy-strict (#!optional boolean -> boolean))
    55 
    56 ;; Utilities
    57 
    58 (define-inline (%length=1 ls) (and (not (%null? ls)) (%null? (%cdr ls))))
     33  (only record-variants define-record-type-variant)
     34  (only check-errors signal-type-error))
    5935
    6036;; Optional promise state constraint checking
     
    6743        (else             (begin)))) ) )
    6844
     45;;
     46
     47(define-type recursive-promise (struct recursive-promise))
     48
     49;(define-type r5rs:promise promise)
     50;(define-type promise* (or r5rs:promise recursive-promise))
     51
     52(: *make-lazy-promise ((-> . *) -> recursive-promise))
     53(: *make-eager-promise ((-> . *) -> recursive-promise))
     54
     55(: force (* -> . *))
     56
     57(: promise? (* --> boolean))
     58
     59(: lazy-promise? (* -> boolean : recursive-promise))
     60(: eager-promise? (* -> boolean : recursive-promise))
     61(: recursive-promise? (* -> boolean : recursive-promise))
     62
     63(: lazy-strict (#!optional boolean -> boolean))
     64
     65;; Utilities
     66
     67(define-inline (%length=1 ls) (and (not (null? ls)) (null? (cdr ls))))
     68
    6969;; Recursive promise
    7070
    7171(define-inline (%make-promise-box tag val)          (cons tag val))
    72 (define-inline (%promise-box-tag prmbox)            (%car prmbox))
    73 (define-inline (%promise-box-tag-set! prmbox tag)   (%set-car!/mutate prmbox tag))
    74 (define-inline (%promise-box-value prmbox)          (%cdr prmbox))
    75 (define-inline (%promise-box-value-set! prmbox val) (%set-cdr! prmbox val))
    76 
    77 (define-inline (%promise-box? obj)          (and (%pair? obj) (memq (%promise-box-tag obj) '(r5rs eager lazy))))
    78 (define-inline (%promise-box-kind? tag obj) (and (%pair? obj) (%eq? (%promise-box-tag obj) tag)))
     72(define-inline (%promise-box-tag prmbox)            (car prmbox))
     73(define-inline (%promise-box-tag-set! prmbox tag)   (set-car! prmbox tag))
     74(define-inline (%promise-box-value prmbox)          (cdr prmbox))
     75(define-inline (%promise-box-value-set! prmbox val) (set-cdr! prmbox val))
     76
     77(define-inline (%promise-box? obj)          (and (pair? obj) (memq (%promise-box-tag obj) '(r5rs eager lazy))))
     78(define-inline (%promise-box-kind? tag obj) (and (pair? obj) (eq? (%promise-box-tag obj) tag)))
    7979(define-inline (%eager-promise-box? obj)    (%promise-box-kind? 'eager obj))
    8080(define-inline (%lazy-promise-box? obj)     (%promise-box-kind? 'lazy obj))
     
    8383;required for proper record tag identity
    8484(define recursive-promise 'recursive-promise)
    85 
    86 (define-inline (%make-recursive-promise cnt)              (%make-structure 'recursive-promise cnt))
    87 (define-inline (%recursive-promise? obj)                  (%structure-instance? obj 'recursive-promise))
    88 (define-inline (%recursive-promise-content prm)           (%structure-ref prm 1))
    89 (define-inline (%recursive-promise-content-set! prm cnt)  (%structure-set! prm 1 cnt))
     85(define-record-type-variant recursive-promise (unsafe unchecked inline)
     86  (%make-recursive-promise cnt)
     87  (%recursive-promise?)
     88  (cnt %recursive-promise-content %recursive-promise-content-set!))
    9089
    9190(define-inline (%make-recursive-promise-boxed tag val)
     
    215214                      (%coerce-eager-promise-box content results) )
    216215                    ;else should be promise
    217                     (let ((promise* (%car results)))
     216                    (let ((promise* (car results)))
    218217                      (cond
    219218                        ;Per SRFI 45 only valid state
  • release/5/srfi-45/trunk/tests/srfi-45-test.scm

    r39688 r39692  
    9797(test-group "Output Tests"
    9898
     99  ;use `let' to ensure local scope; use of -strict-types so no rebinding
     100
    99101  (let ()
    100102    (define r (r5rs:delay (begin (display 'hi) (display #\space) 1)))
     
    197199
    198200  (test/string "Leak test 7" "21\n"
    199     (print (force (times3 7))) ) )
     201    (print (force (times3 7))) )
     202
     203  (test/string "Print Lazy" "#<lazy promise>\n" (print (lazy 1)))
     204  (test/string "Print Eager" "#<eager promise>\n" (print (eager 1)))
     205  (test/string "Print R5RS" "#<promise>\n" (print (r5rs:delay 1)))
     206)
    200207
    201208;=========================================================================
Note: See TracChangeset for help on using the changeset viewer.