;;;; srfi-45.scm
;;;; Kon Lovett, May '09

;; Issues
;;
;; - All operations inlined & primitive due to high-performance nature.
;;
;; - This has been heavily modified from the original in order to extend
;; rather than supplant the R5RS 'delay'.

;;; Prelude

(declare
  (usual-integrations)
  (disable-interrupts)
  (fixnum)
  (local)
  (inline)
  (no-procedure-checks)
  (bound-to-procedure
    ##sys#signal-hook))

(include "chicken-primitive-object-inlines")

;; Recursive promise

(define-inline (%make-promise-box tag val) (%cons tag val))
(define-inline (%promise-box? obj) (%pair? obj))
(define-inline (%promise-box-tag prm) (%car prm))
(define-inline (%promise-box-value prm) (%cdr prm))
(define-inline (%promise-box-tag-set! prm tag) (%set-car!/mutate prm tag))
(define-inline (%promise-box-value-set! prm val) (%set-cdr! prm val))

(define-inline (%make-promise tag val) (make-box (%make-promise-box tag val)))
(define-inline (%promise-box-ref prmbox) (*box-structure-ref prmbox))
(define-inline (%promise-box-set! box prmbox) (*box-structure-set! box prmbox))

(define-inline (%promise-box?->promise-box obj)
  (and (*box-structure? obj)
       (let ((boxed (%promise-box-ref obj)))
         (and (%promise-box? boxed)
              boxed ) ) ) )

(define-inline (%lazy-promise? obj)
  (and-let* ((boxed (%promise-box?->promise-box obj)))
    (%eq? lazy-tag (%promise-box-tag boxed))) )

(define-inline (%eager-promise? obj)
  (and-let* ((boxed (%promise-box?->promise-box obj)))
    (%eq? eager-tag (%promise-box-tag boxed) ) ) )

(define-inline (%promise? obj)
  (and-let* ((boxed (%promise-box?->promise-box obj)))
    (let ((tag (%promise-box-tag boxed)))
      (or (%eq? lazy-tag tag)
          (%eq? eager-tag tag) ) ) ) )

(define-inline (%lazy-thunk? obj)
  (and-let* ((dat (procedure-data obj)))
    (%eq? thunk-tag dat) ) )

;;; Module srfi-45

(require-library box)

(module srfi-45 (;export
  ; SRFI 45
  lazy
  eager
  promise?
  force
  ; Extras
  lazy-promise?
  eager-promise?
  recursive-promise?
  ; Macro support
  $finlzy)

(import (rename scheme (force r5rs:force))
        (rename chicken (promise? r5rs:promise?))
        (only lolevel procedure-data extend-procedure)
        (only box make-box *box-structure? *box-structure-ref *box-structure-set!))

;; Errors

(define (error-promise-type loc obj)
  (##sys#signal-hook #:type-error loc "bad argument type - not a promise" obj) )

(define (error-promise-corrupt loc prm)
  (##sys#signal-hook #:type-error loc "promise is corrupt" prm) )

;; Unique Ids

(define lazy-tag (%make-unique-object 'lazy))
(define eager-tag (%make-unique-object 'eager))
(define thunk-tag (%make-unique-object 'thunk))

;; Helpers

(define ($finlzy thunk)
  (%make-promise lazy-tag (extend-procedure thunk thunk-tag)) )

;; Constructors

(define-syntax lazy
  (syntax-rules ()
    ((_ ?expr)
     ($finlzy (lambda () ?expr)) ) ) )

(define (eager value) (%make-promise eager-tag value))

;; Predicates

(define (lazy-promise? obj) (%lazy-promise? obj))
(define (eager-promise? obj) (%eager-promise? obj))
(define (recursive-promise? obj) (%promise? obj))
(define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))

;; Force

(define (force top)

  ; What kind of promise?
  (cond

    ; New fashion promise?
    ((%promise? top)

     ; Unbox
     (let* ((top-box (%promise-box-ref top))
            (value (%promise-box-value top-box)))

       ; Process by kind
       (select (%promise-box-tag top-box)

         ; Eager has value ready
         ((eager-tag) (apply values value))

         ; Force a lazy promise's value
         ((lazy-tag)
          (cond

            ; Wrapped r5rs promise?
            ((r5rs:promise? value) (r5rs:force value))

            ; Actual lazy promise?
            ((%lazy-thunk? value)

             ; Force the promise by invoking the thunk
             (let* ((promise (call-with-values
                              value
                              (lambda xs
                                (cond ((%null? xs) '())
                                      ((%null? (%cdr xs)) (%car xs))
                                      (else xs))))))

               ; Fetch and check the top promise again in case it recursed
               ; into `force'
               (let ((top-box (%promise-box-ref top)))

                 ; Possible eager, lazy, r5rs or actual results
                 (cond

                   ; Maybe eager now
                   ((%eq? eager-tag (%promise-box-tag top-box))
                    (apply values (%promise-box-value top-box)) )

                   ; Results or a R5RS promise - force w/ updated top
                   ((not (%lazy-promise? promise))
                    (%promise-box-value-set! top-box promise)
                    (force top) )

                   ; Lazy promise - force w/ updated top
                   (else
                    (let ((promise-box (%promise-box-ref promise)))
                      ; Copy the enclosed promise to the top
                      (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
                      (%promise-box-value-set! top-box (%promise-box-value promise-box))
                      (%promise-box-set! promise top-box) )
                    (force top) ) ) ) ) )

            ; Already "forced"
            (else (apply values value) ) ) )

         ; This shouldn't happen
         (else
          (error-promise-corrupt 'force top) ) ) ) )

    ; Old fashion promise?
    ((r5rs:promise? top) (r5rs:force top) )

    ; No promise at all
    (else
     (error-promise-type 'force top) ) ) )

;;;

(register-feature! 'srfi-45)

) ;module srfi-45

#|
Copyright (C) AndrŽ van Tonder (2003). All Rights Reserved.


Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:


The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.


THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|#