;;;; streams-primitive.scm
;;;; Kon Lovett, Apr '09

; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA.  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.

(module streams-primitive

  (;export
    ;; SRFI 41 primitive
    stream?
    stream-null stream-null?
    (stream-cons $$make-stream-pair) ;($$stream-eager $$stream-lazy $$stream-delay)
    stream-pair? stream-car stream-cdr
    stream-lambda ;($$stream-lazy)
    ;; Extras
    stream-occupied?
    ;; Common errors
    check-stream error-stream
    check-stream-occupied error-stream-occupied
    ;; WTF
    ($$stream-lazy $$make-stream-lazy)
    ($$stream-eager $$make-stream-eager)
    $$stream-delay ;($$stream-lazy $$stream-eager)
    $$make-stream-lazy
    $$make-stream-eager
    $$make-stream-pair)

  (import
    scheme chicken
    type-checks type-errors
    record-variants)

  (require-library type-checks type-errors record-variants)

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

;;;

(define-record-type-variant stream (unsafe unchecked inline)
  (%make-stream prom)
  $stream?  ;ignore since %stream? conflicts with predefined inline
  (prom %stream-promise %stream-promise-set!) )

(define-check+error-type stream %stream?)

(define-inline (make-stream-box tag obj) (%cons tag obj))
(define-inline (stream-box-tag box) (%car box))
(define-inline (stream-box-value box) (%cdr box))
(define-inline (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
(define-inline (stream-box-value-set! box val) (%set-cdr! box val))
(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
(define-inline (check-stream-box loc obj)
  (unless (and (%pair? obj)
               (let ((tag (%car obj)))
                 (or (%eq? 'lazy tag) (%eq? 'eager tag))))
    (error-argument-type loc obj "stream-box") ) )

;;;

(define ($$make-stream-lazy thunk) (%make-stream (make-stream-lazy-box thunk)))
(define ($$make-stream-eager obj) (%make-stream (make-stream-eager-box obj)))

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

(define-syntax $$stream-eager
  (syntax-rules ()
    ((_ ?expr) ($$make-stream-eager ?expr) ) ) )

(define-syntax $$stream-delay
  (syntax-rules ()
    ((_ ?expr) ($$stream-lazy ($$stream-eager ?expr)) ) ) )

(define (stream-force stream)
  (let ((promise (%stream-promise (check-stream #f stream))))
    ;better be there! (check-stream-box #f promise)
    (case (stream-box-tag promise)
      ((eager)
        (stream-box-value promise) )
      ((lazy)
        (let* ((stream* ((stream-box-value promise)))
               ; re-fetch promise in case changed by recursion via
               ; above call.
               (promise  (%stream-promise stream)))
          (check-stream #f stream*)
          ;better be there! (check-stream-box #f promise)
          (unless (eq? 'eager (stream-box-tag promise))
            (let ((prom (%stream-promise stream*)))
              (stream-box-tag-set! promise (stream-box-tag prom))
              (stream-box-value-set! promise (stream-box-value prom)) )
            (%stream-promise-set! stream* promise) )
         (stream-force stream) ) ) ) ) )

(define-inline (*stream-null? stream)
  (eq? (stream-force stream) (stream-force stream-null)) )

;;;

(define (stream? obj) (%stream? obj))

(define stream-null ($$stream-delay (%cons 'stream 'null)))

(define (stream-null? obj) (and (%stream? obj) (*stream-null? obj)))
(define (stream-occupied? obj) (and (%stream? obj) (not (*stream-null? obj))))

(define-check+error-type stream-occupied)

(define-syntax stream-lambda
  (syntax-rules ()
    ((_ FORMALS BODY0 BODY1 ...)
     (lambda FORMALS ($$stream-lazy (let () BODY0 BODY1 ...))) ) ) )

;;

(define-record-type-variant stream-pair (unsafe unchecked inline)
  (%make-stream-pair car cdr)
  %stream-pair?
  (car %stream-car)
  (cdr %stream-cdr) )

;want inline car/cdr but need exportable procedure for make.
(define ($$make-stream-pair car cdr) (%make-stream-pair car cdr))

(define-error-type stream-pair)

(define (check-stream-pair loc obj)
  (cond
    ((not (%stream? obj)) (error-stream loc obj 'stream) )
    ((*stream-null? obj)  (error-stream-occupied loc obj 'stream) )
    (else
      (let ((val (stream-force obj)))
        (if (%stream-pair? val) val
          (error-stream-pair loc val 'stream)) ) ) ) )

(define-syntax stream-cons
  (syntax-rules ()
    ((_ ?expr ?strm)
      ($$stream-eager
        ($$make-stream-pair ($$stream-delay ?expr)
                            ($$stream-lazy ?strm))) ) ) )

(define (stream-pair? obj) (and (%stream? obj) (%stream-pair? (stream-force obj))))

(define (stream-car strm)
  (stream-force (%stream-car (check-stream-pair 'stream-car strm))) )

(define (stream-cdr strm)
  (%stream-cdr (check-stream-pair 'stream-cdr strm)) )

) ;module streams-primitive