;;;; 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 base)
  type-checks type-errors
  record-variants)

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

;;;

;; ensure identifier defined
(define stream 'stream)

(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 (stream-tagged-pair? obj)
  (and
    (%pair? obj)
    (let ((tag (%car obj)))
      (or (%eq? 'lazy tag) (%eq? 'eager tag)) ) ) )

(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 (stream-tagged-pair? obj)
    (error-argument-type loc obj "stream-box") )
  obj )

;;;

(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 ()
    (($$stream-lazy ?expr)
      ($$make-stream-lazy (lambda () ?expr)) ) ) )

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

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

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

;;;

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

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

(define-inline (*stream-null? strm)
  (eq? (stream-force strm) (stream-force 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 ()
    ((stream-lambda ?formals ?body0 ?body1 ...)
     (lambda ?formals ($$stream-lazy (let () ?body0 ?body1 ...))) ) ) )

;;

;; ensure identifier defined
(define stream-pair 'stream-pair)

(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-inline (checked-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 (checked-stream-pair 'stream-car strm))) )

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

) ;module streams-primitive