#|-------------------- 1.2.1 |# "./stream-queue.scm" 1286
;;;; streams-queue.scm
;;;; Kon Lovett, Aug '10
;;;; From "samples.ss"
:::: Provides a functional queue abstraction using streams.

(module streams-queue

  (;export
    queue-null
    queue-null?
    queue-cons
    queue-head
    queue-tail)

  (import
    scheme chicken
    streams
    (only type-errors
      error-pair))

  (require-library streams type-errors)

  (include "chicken-primitive-object-inlines")
  (include "streams-inlines")
  (include "inline-type-checks")

(define-inline (queue-check f r)
  (if (%fx< (stream-length r) (stream-length f)) (%cons f r)
      (%cons (stream-append f (stream-reverse r)) stream-null) ) )

(define queue-null
  (%cons stream-null stream-null) )

(define (queue-null? x)
  (and (%pair? x) (stream-null (%car x))) )

(define (queue-cons q x)
  (%check-pair 'queue-cons q 'queue)
  (queue-check (%car q) (stream-cons x (%cdr q))) )

(define (queue-head q)
  (%check-pair 'queue-head q 'queue)
  (if (stream-null? (%car q)) (error 'queue-head "empty queue")
      (stream-car (%car q)) ) )

(define (queue-tail q)
  (%check-pair 'queue-tail q 'queue)
  (if (stream-null? (%car q)) (error 'queue-head "empty queue")
      (queue-check (stream-cdr (%car q)) (%cdr q)) ) )

) ;streams-queue

#|-------------------- 1.2.1 |# "./srfi-41.meta" 664
;;;; srfi-41.meta  -*- Hen -*-

((date "2009-04-02")
 (egg "srfi-41.egg")
 (category data)
 (author "Philip L. Bewig, for Chicken by [[kon lovett]]")
 (license "BSD")
 (doc-from-wiki)
 (synopsis "SRFI 41 (Streams)")
 (depends 
	(setup-helper "1.2.0")
	(check-errors "1.12.1")
	(combinators "1.2.0")
	(record-variants "0.5")
	(numbers "2.1"))
 (test-depends check-errors)
 (files "streams-inlines.scm" "srfi-41.setup" "streams-utils.scm" "chicken-primitive-object-inlines.scm" "streams-primitive.scm" "srfi-41.meta" "srfi-41.release-info" "streams.scm" "stream-queue.scm" "srfi-41.scm" "streams-derived.scm" "streams-math.scm" "tests/run.scm" "tests/streams.ss") )

#|-------------------- 1.2.1 |# "./chicken-primitive-object-inlines.scm" 36481
;;;; chicken-primitive-object-nlines.scm
;;;; Kon Lovett, Jan '09
;;;; (Was chicken-sys-macros.scm)

; ***** SHOULD RENAME SAFE ROUTINES AS '*foo', KEEPING '%foo' FOR UNSAFE *****

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

;; Notes
;;
;; Provides inlines for primitive procedures. Use of these procedures
;; by non-core is highly suspect. Many of these routines are unsafe.
;;
;; In fact, any use is suspect ;-)
;;
;; A ##core#Inline is just what it says - literal inclusion in the compiled C
;; code of the C macro/function and the arguments taken literally, i.e. as the
;; C_word value.
;;
;; These are much faster than a lambda, but very dangerous since the arguments and
;; the return value are not converted. The C code must perform any such conversions.
;;
;; ##core#inline cannot be used with a runtime C function which is coded in the
;; CPS style.
;;
;; A ##core#primitive creates a lambda for a C function which is coded in the
;; CPS style.
;;
;; These have a stereotypical argument list which begins the 3 arguments C_word
;; c, C_word closure, and C_word k. Any actual arguments follow.
;;
;; c       - number of arguments, not including 'c', but including 'closure' & 'k'
;; closure - caller
;; k       - continuation

;;; Unsafe Type Predicates

;; Fixnum

(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))

;; Character

(define-inline (%char-type? x) (##core#inline "C_charp" x))

;; Boolean

(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))

;; EOF

(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))

;; Null (the end-of-list value)

(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))

;; Undefined (void)

(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))

;; Unbound (the unbound value, not 'is a symbol unbound')

(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))

;; Byteblock

(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))

;; Bytevector

(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))

;; String

(define-inline (%string-type? x) (##core#inline "C_stringp" x))

;; Flonum

(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))

;; Lambda-info

(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))

;; Vector

(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))

;; Pair

(define-inline (%pair-type? x) (##core#inline "C_pairp" x))

;; Bucket

; A bucket is used by the runtime for the symbol-table. The bucket type is not
; "seen" by Scheme code.

;; Structure

(define-inline (%structure-type? x) (##core#inline "C_structurep" x))

;; Symbol

(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))

;; Closure

(define-inline (%closure-type? x) (##core#inline "C_closurep" x))

;; Port

(define-inline (%port-type? x) (##core#inline "C_portp" x))

;; Any-pointer

(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))

;; Simple-pointer

(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))

;; Tagged-Pointer

(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))

;; Swig-Pointer

(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))

;; Locative

(define-inline (%locative-type? x) (##core#inline "C_locativep" x))

;;; Safe Type Predicates

;; Immediate

(define-inline (%immediate? x) (##core#inline "C_immp" x))

;; Fixnum

(define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))

;; Character

(define-inline (%char? x) (and (%immediate? x) (%char-type? x)))

;; Boolean

(define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))

(define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
(define-inline (%false-value? x) (not (%true-value? x)))

;; EOF

(define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))

;; Null (the end-of-list value)

(define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))

;; Undefined (void)

(define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))

(define-inline (%undefined-value) (##core#undefined))

;; Unbound (the unbound value, not 'is a symbol unbound')

(define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))

;; Block (anything not immediate)

(define-inline (%block? x) (##core#inline "C_blockp" x))

;; Special

(define-inline (%special? x) (##core#inline "C_specialp" x))

;; Byteblock

(define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))

;; Bytevector

(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))

;; String

(define-inline (%string? x) (and (%block? x) (%string-type? x)))

;; Flonum

(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))

;; Lambda-info

(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))

;; Wordblock (special block)

(define-inline (%wordblock? x) (and (%block? x) (%special? x)))

;; Vector

(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))

;; Pair

(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))

;; Bucket

; A bucket is used by the runtime for the symbol-table. The bucket type is not
; "seen" by Scheme code.

;; Structure

(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))

;; Symbol

(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))

;; Closure

(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))

;; Port

(define-inline (%port? x) (and (%block? x) (%port-type? x)))

;; Any-pointer

(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))

;; Simple-pointer

(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))

;; Tagged-Pointer

(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))

;; Swig-Pointer

(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))

;; Locative

(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))

;; Forwarded (block object moved to new address, forwarding pointer)

(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))

;;; Operations

;Safe

(define-inline (%eq? x y) (##core#inline "C_eqp" x y))

;; Fixnum

;Safe

(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))

;Unsafe

(define-inline (%fx= x y) (%eq? x y))
(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
(define-inline (%fx< x y) (##core#inline "C_fixnum_lessp" x y))
(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))

(define-inline (%fxclosed-right? l x h) (and (fx%< l x) (%fx<= x h)))
(define-inline (%fxclosed? l x h) (and (%fx<= l x) (%fx<= x h)))
(define-inline (%fxclosed-left? l x h) (and (%fx<= l x) (%fx< x h)))

(define-inline (%fxzero? fx) (%fx= 0 fx))
(define-inline (%fxpositive? fx) (%fx< 0 fx))
(define-inline (%fxnegative? fx) (%fx< fx 0))
(define-inline (%fxnatural? fx) (%fx<= 0 fx))
(define-inline (%fxcardinal? fx) (%fxnatural? fx))
(define-inline (%fxodd? fx) (%fx= 1 (%fxand fx 1)))
(define-inline (%fxeven? fx) (%fx= 0 (%fxand fx 1)))

(define-inline (%fxmin x y) (if (%fx< x y) x y))
(define-inline (%fxmax x y) (if (%fx< x y) y x))

(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))

(define-inline (%fxadd1 fx) (##core#inline "C_fixnum_increase" fx))
(define-inline (%fxsub1 fx) (##core#inline "C_fixnum_decrease" fx))

(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))

(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))

(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))

;; Block

(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))

;Safe

(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))

;; Size of object in units of sub-object.

; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
;
; byteblock? #t - size is # of bytes, fill is-a character  -> "string"
; byteblock? #f - size is # of words, fill is-a any        -> "vector"

(define-inline (%block-allocate n bb? f a?) ((##core#primitive "C_allocate_vector") n bb? f a?))

;Unsafe

; Byteblock -> # of bytes
; Wordblock -> # of words.

(define-inline (%block-size b) (##core#inline "C_block_size" b))

;;

;; Byteblock

;Safe

(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))

;Unsafe

(define-inline (%byteblock-length bb) (%block-size bb))

(define-inline (%byteblock-ref bb i) (##core#inline "C_subbyte" bb i))

(define-inline (%byteblock-set! bb i v) (##core#inline "C_setsubbyte" bb i v))

;; Generic-byteblock

;Safe

; generic-byteblock isa bytevector, string, flonum, or lambda-info
(define-inline (%generic-byteblock? x)
  (or (%bytevector? x) (%string? x) (%flonum? x) (%lambda-info? x)) )

;; Bytevector (byteblock)

;Safe

(define-inline (%make-bytevector sz)
  (let ((bv (%make-byteblock sz #f #t)))
    (##core#inline "C_string_to_bytevector" bv)
    bv ) )

(define-inline (%string->bytevector s)
  (let* ((n (%byteblock-length s) #;(%string-size s))
	       (bv (%make-bytevector sz)) )
    (##core#inline "C_copy_memory" bv s n)
    bv ) )

;Unsafe

(define-inline (%bytevector-length bv) (%byteblock-length bv))

(define-inline (%bytevector=? bv1 bv2)
  (let ((n (%bytevector-length bv1)))
    (and (%fx= n (%bytevector-length bv2))
         (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )

(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))

(define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))

;; Blob (isa bytevector w/o accessors)

(define-inline (%make-blob sz) (%make-bytevector sz))

(define-inline (%string->blob s) (%string->bytevector s))

(define-inline (%blob? x) (%bytevector? x))

(define-inline (%blob-size b) (%bytevector-length b))

(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))

;; String (byteblock)

;Safe

(define-inline (%make-string size fill) (%make-byteblock size fill #f))

;Unsafe

(define-inline (%bytevector->string bv)
  (let* ((n (%bytevector-length bv))
	       (s (%make-string n #\space)) )
    (##core#inline "C_copy_memory" s bv n)
    s ) )

(define-inline (%blob->string bv) (%bytevector->string bv))

(define-inline (%lambda-info->string li)
  (let* ((sz (%byteblock-length li) #;(%lambda-info-length li))
         (s (%make-string sz #\space)) )
    (##core#inline "C_copy_memory" s li sz)
    s ) )

(define-inline (%string-size s) (%byteblock-length s))
(define-inline (%string-length s) (%byteblock-length s))

(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))

(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))

(define-inline (%string-compare/length s1 s2 l) (##core#inline "C_string_compare" s1 s2 l))

(define-inline (%string-compare s1 s2)
  (let* ((l1 (%string-length s1))
         (l2 (%string-length s2))
         (d (%fx- l1 l2))
         (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    (if (%fxzero? r) d
        r ) ) )

(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
(define-inline (%string<? s1 s2) (%fxnegative? (%string-compare s1 s2)))
(define-inline (%string>? s1 s2) (%fxpositive? (%string-compare s1 s2)))
(define-inline (%string<=? s1 s2) (%fx<= 0 (%string-compare s1 s2)))
(define-inline (%string>=? s1 s2) (%fx>= 0 (%string-compare s1 s2)))

(define-inline (%string-ci-compare/length s1 s2 l) (##core#inline "C_string_compare_case_insensitive" s1 s2 l))

(define-inline (%string-ci-compare s1 s2)
  (let* ((l1 (%string-length s1))
         (l2 (%string-length s2))
         (d (%fx- l1 l2))
         (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    (if (%fxzero? r) d
        r ) ) )

(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
(define-inline (%string-ci<? s1 s2) (%fxnegative? (%string-ci-compare s1 s2)))
(define-inline (%string-ci>? s1 s2) (%fxpositive? (%string-ci-compare s1 s2)))
(define-inline (%string-ci<=? s1 s2) (%fx<= 0 (%string-ci-compare s1 s2)))
(define-inline (%string-ci>=? s1 s2) (%fx>= 0 (%string-ci-compare s1 s2)))

;; Flonum (byteblock)

;Unsafe

(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))

(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
(define-inline (%fpmin x y) (##core#inline "C_i_flonum_min" x y))

(define-inline (%finite? x) (##core#inline "C_i_finitep" x))

(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))

(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))

(define-inline (%fpnegate x) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))

(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))

;Safe

(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))

; Actually 'number' operations
(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
(define-inline (%fpatan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))

;; Lambda-info (byteblock)

;Unsafe

(define-inline (%string->lambda-info s)
  (let* ((n (%string-size s))
	       (li (%make-string n)) )
    (##core#inline "C_copy_memory" li s n)
    (##core#inline "C_string_to_lambdainfo" li)
    li ) )

(define-inline (%lambda-info-length li) (%byteblock-length s))

;; Wordblock

;Safe

(define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))

;Unsafe

(define-inline (%wordblock-length wb) (%block-size wb))

(define-inline (%wordblock-ref wb i) (##core#inline "C_slot" wb i))

(define-inline (%wordblock-set!/mutate wb i v) (##core#inline "C_i_setslot" wb i v))
(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
(define-inline (%wordblock-set! wb i v)
  (if (%immediate? v) (%wordblock-set!/immediate wb i v)
      (%wordblock-set!/mutate wb i v) ) )

;; Generic-vector (wordblock)

; generic-vector isa vector, pair, structure, symbol, or keyword
(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))

;; Vector (wordblock)

;Safe

(define-inline (%make-vector size fill) (%make-wordblock size fill #f))

;Unsafe

(define-inline (%vector-length v) (%wordblock-length v))

(define-inline (%vector-ref v i) (%wordblock-ref v i))

(define-inline (%vector-set!/mutate v i x) (%wordblock-set!/mutate v i x))
(define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
(define-inline (%vector-set! v i x) (%wordblock-set! v i x))

;; Pair (wordblock)

;Safe

(define-inline (%null? x) (%eol-object? x))

(define-inline (%list? x) (or (%null? x) (%pair? x)))

(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )

(define-inline (%length ls) (##core#inline "C_i_length" ls))

;Unsafe

(define-inline (%car pr) (%wordblock-ref pr 0))

(define-inline (%set-car!/mutate pr x) (%wordblock-set!/mutate pr 0 x))
(define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
(define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))

(define-inline (%cdr pr) (%wordblock-ref pr 1))

(define-inline (%set-cdr!/mutate pr x) (%wordblock-set!/mutate pr 1 x))
(define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
(define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))

(define-inline (%caar pr) (%car (%car pr)))
(define-inline (%cadr pr) (%car (%cdr pr)))
(define-inline (%cdar pr) (%cdr (%car pr)))
(define-inline (%cddr pr) (%cdr (%cdr pr)))

(define-inline (%caaar pr) (%car (%caar pr)))
(define-inline (%caadr pr) (%car (%cadr pr)))
(define-inline (%cadar pr) (%car (%cdar pr)))
(define-inline (%caddr pr) (%car (%cddr pr)))
(define-inline (%cdaar pr) (%cdr (%caar pr)))
(define-inline (%cdadr pr) (%cdr (%cadr pr)))
(define-inline (%cddar pr) (%cdr (%cdar pr)))
(define-inline (%cdddr pr) (%cdr (%cddr pr)))

;Safe

(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
(define-inline (%memv x ls) (##core#inline "C_i_memv" x ls))
(define-inline (%member x ls) (##core#inline "C_i_member" x ls))

(define-inline (%assq x ls) (##core#inline "C_i_assq" x ls))
(define-inline (%assv x ls) (##core#inline "C_i_assv" x ls))
(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))

;Unsafe

(define-inline (%list-ref ls0 i0)
  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
  (let loop ((ls ls0) (i i0))
    (cond ((%null? ls)  '() )
	        ((%fx= 0 i)   (%car ls) )
	        (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )

(define-inline (%list-pair-ref ls0 i0)
  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
  (let loop ((ls ls0) (i i0))
    (cond ((%null? ls)  '() )
	        ((%fx= 0 i)   ls )
	        (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )

(define-inline (%last-pair ls0)
  ;(assert (and (proper-list? ls0) (pair? ls0)))
  (do ((ls ls0 (%cdr ls)))
      ((%null? (%cdr ls)) ls)) )

(define-inline (%list-copy ls0)
  ;(assert (proper-list? ls0))
  (let copy-rest ((ls ls0))
    (if (%null? ls) '()
        (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )

(define-inline (%append! . lss)
  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
  (let ((lss (let position-at-first-pair ((lss lss))
               (cond ((%null? lss)        '() )
                     ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
                     (else                 lss ) ) ) ) )
    (if (%null? lss) '()
        (let ((ls0 (%car lss)))
          ;(assert (pair? ls0))
          (let append!-rest ((lss (%cdr lss)) (pls ls0))
            (if (%null? lss) ls0
                (let ((ls (%car lss)))
                  (cond ((%null? ls)
                         (append!-rest (%cdr lss) pls) )
                        (else
                         (%set-cdr!/mutate (%last-pair pls) ls)
                         (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )

(define-inline (%delq! x ls0)
  ;(assert (proper-list? ls0))
  (let find-elm ((ls ls0) (ppr #f))
    (cond ((%null? ls)
           ls0 )
	        ((%eq? x (%car ls))
	         (cond (ppr
	                (%set-cdr! ppr (%cdr ls))
	                ls0 )
	               (else
	                (%cdr ls) ) ) )
	        (else
	         (find-elm (%cdr ls) ls) ) ) ) )

(define-inline (%list-fold/1 func init ls0)
  ;(assert (and (proper-list? ls0) (procedure? func)))
  (let loop ((ls ls0) (acc init))
    (if (%null? ls) acc
        (loop (%cdr ls) (func (%car ls) acc)) ) ) )

(define-inline (%list-map/1 func ls0)
  ;(assert (and (proper-list? ls0) (procedure? func)))
  (let loop ((ls ls0))
    (if (%null? ls) '()
        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )

(define-inline (%list-for-each/1 proc ls0)
  ;(assert (and (proper-list? ls0) (procedure? proc)))
  (let loop ((ls ls0))
    (unless (%null? ls)
      (proc (%car ls))
      (loop (%cdr ls)) ) ) )

(define-inline (%list/1 obj) (%cons obj '()))

(define-inline (%list . objs)
  (let loop ((objs objs))
    (if (%null? objs) '()
        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )

(define-inline (%make-list n e)
  (let loop ((n n) (ls '()))
    (if (%fxzero? n) ls
        (loop (%fxsub1 n) (%cons e ls)) ) ) )

(define-inline (%list-take ls0 n)
  (let loop ((ls ls0) (n n))
    (if (%fxzero? n) '()
        (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )

(define-inline (%list-drop ls0 n)
  (let loop ((ls ls0) (n n))
    (if (%fxzero? n) ls
        (loop (%cdr ls) (%fxsub1 n)) ) ) )

(define-inline (%list-any/1 pred? ls)
  (let loop ((ls ls))
    (and (not (%null? ls))
         (or (pred? (%car ls))
             (loop (%cdr ls)) ) ) ) )

(define-inline (%list-every/1 pred? ls)
  (let loop ((ls ls) (last #t))
    (if (%null? ls) last
        (let ((this (pred? (%car ls))))
          (and this
               (loop (%cdr ls) this)) ) ) ) )

(define-inline (%list-length ls0)
  (let loop ((ls ls0) (n 0))
    (if (%null? ls) n
        (loop (%cdr ls) (%fxadd1 n)) ) ) )

(define-inline (%list-find pred? ls)
  (let loop ((ls ls))
    (and (not (%null? ls))
         (or (let ((elm (%car ls))) (and (pred? elm) elm))
             (loop (%cdr ls)) ) ) ) )

(define-inline (%alist-ref key al #!optional (test eqv?) def)
  (let loop ((al al))
    (cond ((%null? al) def )
          ((test key (%caar al)) (%cdar al) )
          (else (loop (%cdr al)) ) ) ) )

(define-inline (%alist-update! key val al0 #!optional (test eqv?))
  (let loop ((al al0))
    (cond ((%null? al) (%cons (%cons key val) al0) )
          ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
          (else (loop (%cdr al)) ) ) ) )

(define-inline (%alist-delete! key al0 #!optional (test equal?))
  (let loop ((al al0) (prv #f))
    (cond ((%null? al) al0)
          ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
          (else (loop (%cdr al) al) ) ) ) )

;; Structure (wordblock)

(define-inline (%make-structure t . s) (apply (##core#primitive "C_make_structure") t s))

(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))

(define-inline (%structure-length r) (%wordblock-length r))

(define-inline (%structure-tag r) (%wordblock-ref r 0))

(define-inline (%structure-ref r i) (%wordblock-ref r i))

(define-inline (%structure-set!/mutate r i x) (%wordblock-set!/mutate r i x))
(define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
(define-inline (%structure-set! r i x) (%wordblock-set! r i x))

;; Port (wordblock)

; Port layout:
;
; 0	  FP (special - FILE *)
; 1	  input/output (bool)
; 2	  class (vector, see Port-class)
; 3	  name (string)
; 4	  row (fixnum)
; 5	  col (fixnum)
; 6	  EOF (bool)
; 7	  type (symbol)
; 8	  closed (bool)
; 9	  data
; 10-15	 reserved, port class specific

(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
(define-inline (%port-class port) (%wordblock-ref port 2))
(define-inline (%port-name port) (%wordblock-ref port 3))
(define-inline (%port-row port) (%wordblock-ref port 4))
(define-inline (%port-column port) (%wordblock-ref port 5))
(define-inline (%port-eof? port) (%wordblock-ref port 6))
(define-inline (%port-type port) (%wordblock-ref port 7))
(define-inline (%port-closed? port) (%wordblock-ref port 8))
(define-inline (%port-data port) (%wordblock-ref port 9))

(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))

(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
(define-inline (%port-input-mode-set! port f) (%wordblock-set!/immediate port 1 f))
(define-inline (%port-class-set! port v) (%wordblock-set!/mutate port 2 v))
(define-inline (%port-name-set! port s) (%wordblock-set!/mutate port 3 s))
(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
(define-inline (%port-eof-set! port f) (%wordblock-set!/immediate port 6 f))
(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
(define-inline (%port-data-set! port x) (%wordblock-set!/mutate port 9 x))

(define-inline (%make-port i/o class name type)
  ; port is 16 slots + a block-header word
  (let ((port (##core#inline_allocate ("C_a_i_port" 17))))
    (%port-input-mode-set! port i/o)
    (%port-class-set! port class)
    (%port-name-set! port name)
    (%port-row-set! port 1)
    (%port-column-set! port 0)
    (%port-type-set! port type)
    port ) )

; Port-class layout
;
; 0	  (read-char PORT) -> CHAR | EOF
; 1	  (peek-char PORT) -> CHAR | EOF
; 2	  (write-char PORT CHAR)
; 3	  (write-string PORT STRING)
; 4	  (close PORT)
; 5	  (flush-output PORT)
; 6	  (char-ready? PORT) -> BOOL
; 7	  (read-string! PORT COUNT STRING START) -> COUNT'
; 8	  (read-line PORT LIMIT) -> STRING | EOF

(define-inline (%make-port-class rc pc wc ws cl fl cr rs rl)
  (let ((class (%make-vector 9 #f)))
    (%vector-set! class 0 rc)
    (%vector-set! class 1 pc)
    (%vector-set! class 2 wc)
    (%vector-set! class 3 ws)
    (%vector-set! class 4 cl)
    (%vector-set! class 5 fl)
    (%vector-set! class 6 cr)
    (%vector-set! class 7 rs)
    (%vector-set! class 8 rl)
    class ) )

(define-inline (%port-class-read-char-ref c) (%vector-ref c 0))
(define-inline (%port-class-peek-char-ref c) (%vector-ref c 1))
(define-inline (%port-class-write-char-ref c) (%vector-ref c 2))
(define-inline (%port-class-write-string-ref c) (%vector-ref c 3))
(define-inline (%port-class-close-ref c) (%vector-ref c 4))
(define-inline (%port-class-flush-output-ref c) (%vector-ref c 5))
(define-inline (%port-class-char-ready-ref c) (%vector-ref c 6))
(define-inline (%port-class-read-string-ref c) (%vector-ref c 7))
(define-inline (%port-class-read-line-ref c) (%vector-ref c 8))

(define-inline (%port-class-read-char c p) ((%port-class-read-char-ref c) p) )
(define-inline (%port-class-peek-char c p) ((%port-class-peek-char-ref c) p))
(define-inline (%port-class-write-char c p c) ((%port-class-write-char-ref c) p c))
(define-inline (%port-class-write-string c p s) ((%port-class-write-string-ref c) p s))
(define-inline (%port-class-close c p) ((%port-class-close-ref c) p))
(define-inline (%port-class-flush-output c p) ((%port-class-flush-output-ref c) p))
(define-inline (%port-class-char-ready? c p) ((%port-class-char-ready-ref c) p))
(define-inline (%port-class-read-string! c p n d s) ((%port-class-read-string-ref c) p n d s))
(define-inline (%port-class-read-line c p l) ((%port-class-read-line-ref c) p l))

(define-inline (%port-read-char p) ((%port-class-read-char-ref (%port-class p)) p) )
(define-inline (%port-peek-char p) ((%port-class-peek-char-ref (%port-class p)) p))
(define-inline (%port-write-char p c) ((%port-class-write-char-ref (%port-class p)) p c))
(define-inline (%port-write-string p s) ((%port-class-write-string-ref (%port-class p)) p s))
(define-inline (%port-close p) ((%port-class-close-ref (%port-class p)) p))
(define-inline (%port-flush-output p) ((%port-class-flush-output-ref (%port-class p)) p))
(define-inline (%port-char-ready? p) ((%port-class-char-ready-ref (%port-class p)) p))
(define-inline (%port-read-string! p n d s) ((%port-class-read-string-ref (%port-class p)) p n d s))
(define-inline (%port-read-line p l) ((%port-class-read-line-ref (%port-class p)) p l))

;; Closure (wordblock)

;Unsafe

(define-inline (%make-closure! n)
  (let ((v (%make-vector n)))
    (##core#inline "C_vector_to_closure" v)
    v ) )

(define-inline (%procedure? x) (%closure? x))

(define-inline (%vector->closure! v a)
  (##core#inline "C_vector_to_closure" v)
  (##core#inline "C_update_pointer" a v) )

(define-inline (%closure-length c) (%wordblock-length? c))

(define-inline (%closure-ref c i) (%wordblock-ref c i))

(define-inline (%closure-set! c i v) (%wordblock-set! c i v))

(define-inline (%closure-copy tc fc l)
  (do ((i 1 (%fxadd1 i)))
      ((%fx>= i l))
    (%closure-set! tc i (%closure-ref fc i)) ) )

(define-inline (%closure-decoration c test)
  (let find-decor ((i (%fxsub1 (%closure-length c))))
    (and (%fxpositive? i)
         (let ((x (%closure-ref c i)))
           (if (test x) x
               (find-decor (%fxsub1 i)) ) ) ) ) )

(define-inline (%closure-decorate! c test dcor)
  (let ((l (%closure-length c)))
    (let find-decor ((i (%fxsub l)))
      (cond ((%fxzero? i)
             (let ((nc (%make-closure (%fxadd1 l))))
               (%closure-copy nc c l)
               (##core#inline "C_copy_pointer" c nc)
               (dcor nc i) ) )
            (else
             (let ((x (%closure-ref c i)))
               (if (test x) (dcor c i)
                   (find-decor (%fxsub i)) ) ) ) ) ) ) )

(define-inline (%closure-lambda-info c)
  (%closure-decoration c (lambda (x) (%lambda-info? x))) )

;; Symbol (wordblock)

;Unsafe

(define-inline (%symbol-binding s) (%wordblock-ref s 0))
(define-inline (%symbol-string s) (%wordblock-ref s 1))
(define-inline (%symbol-bucket s) (%wordblock-ref s 2))

(define-constant NAMESPACE-MAX-ID-LEN 31)

(define-inline (%qualified-symbol? s)
  (let ((str (%symbol-string s)))
    (and (%fxpositive? (%string-size str))
         (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )

;Safe

(define-inline (%string->symbol-interned s) ((##core#primitive "C_string_to_symbol") s))

(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))

(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))

;; Keyword (wordblock)

(define-inline (%keyword? x) (and (%symbol? x) (%fxzero? (%byteblock-ref (%symbol-string x) 0))))

;; Pointer (wordblock)

; simple-pointer, tagged-pointer, swig-pointer, locative
(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))

; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
(define-inline (%pointer-like? x) (%wordblock? x))

; These operate on pointer-like objects

(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))

(define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
(define-inline (%pointer-set! ptr y) (%wordblock-set!/mutate ptr 0 y))

(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))

(define-inline (%pointer->address ptr)
  ; Pack pointer address value into Chicken words; '4' is platform dependent!
  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref ptr)) )

;; Simple-pointer (wordblock)

(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))

(define-inline (%make-pointer-null)
  (let ((ptr (%make-simple-pointer)))
    (##core#inline "C_update_pointer" 0 ptr)
    ptr ) )

(define-inline (%address->pointer a)
  (let ((ptr (%make-simple-pointer)))
    (##core#inline "C_update_pointer" a ptr)
    ptr ) )

(define-inline (%make-block-pointer b)
  (let ((ptr (%make-simple-pointer)))
    (##core#inline "C_pointer_to_block" ptr b)
    ptr ) )

;; Tagged-pointer (wordblock)

(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))

;; Swig-pointer (wordblock)

;; Locative (wordblock)

(define-inline (%make-locative typ obj idx weak?)
  (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))

; Locative layout:
;
; 0	Object-address + byte-offset (address)
; 1	Byte-offset (fixnum)
; 2	Type (fixnum)
;	  0	vector or pair          (C_SLOT_LOCATIVE)
;	  1	string                  (C_CHAR_LOCATIVE)
;	  2	u8vector                (C_U8_LOCATIVE)
;	  3	s8vector or bytevector  (C_U8_LOCATIVE)
;	  4	u16vector		            (C_U16_LOCATIVE)
;	  5	s16vector		            (C_S16_LOCATIVE)
;	  6	u32vector		            (C_U32_LOCATIVE)
;	  7	s32vector		            (C_S32_LOCATIVE)
;	  8	f32vector		            (C_F32_LOCATIVE)
;	  9	f64vector		            (C_F64_LOCATIVE)
; 3	Object or #f, if weak (C_word)

(define-inline (%locative-address lv) (%pointer->address lv))

(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
(define-inline (%locative-type lv) (%wordblock-ref lv 2))
(define-inline (%locative-weak? lv) (not (%wordblock-ref lv 3)))
(define-inline (%locative-object lv) (%wordblock-ref lv 3))

;; Numbers

;Safe

(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
(define-inline (%exact? x) (##core#inline "C_i_exactp" x))
(define-inline (%inexact? x) (##core#inline "C_i_inexactp" x))

(define-inline (%= x y) (##core#inline "C_i_eqvp" x y))
(define-inline (%< x y) (##core#inline "C_i_lessp" x y))
(define-inline (%<= x y) (##core#inline "C_i_less_or_equalp" x y))
(define-inline (%> x y) (##core#inline "C_i_greaterp" x y))
(define-inline (%>= x y) (##core#inline "C_i_greater_or_equalp" x y))

(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
(define-inline (%natural? n) (%<= 0 n))
(define-inline (%cardinal n) (%natural n)) ;Backwards

(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
(define-inline (%even? n) (##core#inline "C_i_evenp" n))

(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
(define-inline (%- x y) ((##core#primitive "C_minus") x y))
(define-inline (%* x y) ((##core#primitive "C_times") x y))
(define-inline (%/ x y) ((##core#primitive "C_divide") x y))

(define-inline (%add1 x) (%+ x 1))
(define-inline (%sub1 x) (%- x 1))

(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
(define-inline (%remainder x y) (let ((quo (%quotient x y))) (%- x (%* quo y))))

(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
(define-inline (%abs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
(define-inline (%acos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
(define-inline (%atan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
(define-inline (%log x) (##core#inline_allocate ("C_a_i_log" 4) x))
(define-inline (%sin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
(define-inline (%sqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
(define-inline (%tan x) (##core#inline_allocate ("C_a_i_tan" 4) x))

(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
(define-inline (%bitwise-xor x y) (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x y))
(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))

(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))

(define-inline (%bit-set? n i) (##core#inline "C_i_bit_setp" n i))

(define-inline (%randomize n) (##core#inline "C_randomize" n))

;;; Operations

;Safe

(define-inline (%->boolean obj) (and obj #t))

(define-inline (%make-unique-object #!optional id) (if id (%make-vector 1 id) '#()))

#|-------------------- 1.2.1 |# "./srfi-41.scm" 2085
;;;; srfi-41.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 srfi-41

  (;export
    stream-null stream-cons stream? stream-null? stream-pair? stream-car
    stream-cdr stream-lambda define-stream list->stream port->stream stream
    stream->list stream-append stream-concat stream-constant stream-drop
    stream-drop-while stream-filter stream-fold stream-for-each stream-from
    stream-iterate stream-length stream-let stream-map stream-match
    stream-of stream-range stream-ref stream-reverse stream-scan stream-take
    stream-take-while stream-unfold stream-unfolds stream-zip
    ;; Extras
    stream-occupied?
    ;; Common errors
    check-stream error-stream
    check-stream-occupied error-stream-occupied)

  (import scheme chicken streams-primitive streams-derived)
  (require-library streams-primitive streams-derived)

(register-feature! 'srfi-41)
(register-feature! 'streams)

) ;module streams

#|-------------------- 1.2.1 |# "./srfi-41.setup" 1235
;;;; srfi-41.setup  -*- Hen -*-

(include "setup-helper")

(verify-extension-name "srfi-41")

(required-extension-version
  "record-variants"             "0.5"
  "combinators"                 "1.2.0"
  "check-errors"                "1.12.1")

(setup-shared-extension-module 'streams-primitive (extension-version "1.2.1")
  #:compile-options '(
    -optimize-level 3
    -inline-limit 50
    -fixnum-arithmetic
    -no-procedure-checks))

(setup-shared-extension-module 'streams-derived (extension-version "1.2.1")
  #:compile-options '(
    -optimize-level 3
    -inline-limit 50
    -fixnum-arithmetic
    -no-procedure-checks))

(setup-shared-extension-module 'streams (extension-version "1.2.1"))

(setup-shared-extension-module 'srfi-41 (extension-version "1.2.1"))

(setup-shared-extension-module 'streams-utils (extension-version "1.2.1")
  #:compile-options '(
    -optimize-level 3
    -inline-limit 50
    -fixnum-arithmetic
    -no-procedure-checks))

(setup-shared-extension-module 'streams-math (extension-version "1.2.1")
  #:compile-options '(
    -optimize-level 3
    -inline-limit 50
    -no-procedure-checks
    -require-extension numbers))

(install-extension 'srfi-41 '() `((version ,(extension-version "1.2.1"))))

#|-------------------- 1.2.1 |# "./streams-primitive.scm" 5407
;;;; 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
    (only type-checks define-check+error-type)
    (only type-errors define-error-type)
    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 (make-stream-box tag obj) (%cons tag obj))
(define (stream-box-tag box) (%car box))
(define (stream-box-value box) (%cdr box))
(define (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
(define (stream-box-value-set! box val) (%set-cdr! box val))

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

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

;;;

(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 promise)
  (let ((content (%stream-promise promise)))
    (case (stream-box-tag content)
      ((eager)
        (stream-box-value content) )
      ((lazy)
        (let* ((promise* ((stream-box-value content)))
               (content  (%stream-promise promise)))
          (unless (eq? 'eager (stream-box-tag content))
            (let ((prom (%stream-promise promise*)))
              (stream-box-tag-set! content (stream-box-tag prom))
              (stream-box-value-set! content (stream-box-value prom)) )
            (%stream-promise-set! promise* content) )
         (stream-force promise) ) ) ) ) )

(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) )

(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

#|-------------------- 1.2.1 |# "./streams-derived.scm" 14988
;;;; streams-derived.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-derived

  (;export
    ;; SRFI 41 derived
    define-stream stream stream-let
    stream-match
    stream-of
    stream-constant
    list->stream stream->list
    port->stream
    stream-length
    stream-ref
    stream-append stream-concat
    stream-reverse
    stream-drop stream-drop-while
    stream-take stream-take-while
    stream-filter stream-scan
    stream-fold stream-for-each stream-map
    stream-unfold stream-unfolds
    stream-from stream-iterate stream-range
    stream-zip
    ;; WTF
    stream-match-test
    stream-match-pattern)

  (import
    scheme chicken
    #;srfi-9 #;srfi-23
    streams-primitive
    (only type-errors
      error-number error-procedure
      error-natural-integer
      error-input-port error-list))

  (require-library
    #;srfi-9 #;srfi-23
    streams-primitive type-errors)

  (include "chicken-primitive-object-inlines")
  (include "streams-inlines")
  (include "inline-type-checks")

  (declare (bound-to-procedure ##sys#signal-hook))

;;;

(define-syntax define-stream
  (syntax-rules ()
    ((_ (?name . ?formal) ?body0 ?body1 ...)
     (define ?name (stream-lambda ?formal ?body0 ?body1 ...)) ) ) )

(define-syntax stream
  (syntax-rules ()
    ((_)         stream-null)
    ((_ X Y ...) (stream-cons X (stream Y ...)) ) ) )

(define-syntax stream-let
  (syntax-rules ()
    ((_ ?tag ((?name ?val) ...) ?body0 ?body1 ...)
     ((letrec ((?tag (stream-lambda (?name ...) ?body0 ?body1 ...))) ?tag) ?val ...) ) ) )

(define-syntax stream-match
  (syntax-rules ()
    ((_ ?strm-expr ?clause ...)
      (let ((strm ?strm-expr))
        (cond
          ((not (stream? strm))
            (error-stream 'stream-match strm 'stream))
          ((stream-match-test strm ?clause) => car)
          ...
          (else
            (error 'stream-match "no matching pattern")))) ) ) )

(define-syntax stream-match-test
  (syntax-rules ()

    ((_ ?strm (?pattern ?fender ?expr))
     (stream-match-pattern ?strm ?pattern () (and ?fender (list ?expr))) )

    ((_ ?strm (?pattern ?expr))
     (stream-match-pattern ?strm ?pattern () (list ?expr)) ) ) )

;FIXME - this forces use of `_' identifier
(define-syntax stream-match-pattern
  (syntax-rules (_)

    ((_ ?strm () (?binding ...) ?body)
     (and (stream-null? ?strm)
          (let (?binding ...) ?body)) )

    ((_ ?strm (_ . ?rest) (?binding ...) ?body)
     (and (stream-pair? ?strm)
          (let ((strm (stream-cdr ?strm)))
            (stream-match-pattern strm ?rest (?binding ...) ?body))) )

    ((_ ?strm (?var . ?rest) (?binding ...) ?body)
     (and (stream-pair? ?strm)
          (let ((temp (stream-car ?strm))
                (strm (stream-cdr ?strm)))
            (stream-match-pattern strm ?rest ((?var temp) ?binding ...) ?body))) )

    ((_ ?strm _ (?binding ...) ?body)
     (let (?binding ...) ?body) )

    ((_ ?strm ?var (?binding ...) ?body)
     (let ((?var ?strm) ?binding ...) ?body) ) ) )

(define-syntax stream-of
  (syntax-rules (is in)

    ((_ "aux" ?expr ?base)
     (stream-cons ?expr ?base) )

    ((_ "aux" ?expr ?base (?var in ?strm) ?rest ...)
     (stream-let loop ((strm ?strm))
       (if (stream-null? strm) ?base
           (let ((?var (stream-car strm)))
             (stream-of "aux" ?expr (loop (stream-cdr strm)) ?rest ...)))) )

    ((_ "aux" ?expr ?base (?var is ?exp) ?rest ...)
     (let ((?var ?exp)) (stream-of "aux" ?expr ?base ?rest ...)) )

    ((_ "aux" ?expr ?base ?pred? ?rest ...)
     (if ?pred? (stream-of "aux" ?expr ?base ?rest ...) ?base) )

    ((_ ?expr ?rest ...)
     (stream-of "aux" ?expr stream-null ?rest ...) ) ) )

;;

(define stream-constant
  (stream-lambda objs
    (cond
      ((%null? objs)
        stream-null )
      ((%null? (%cdr objs))
        (stream-cons (%car objs) (stream-constant (%car objs))) )
      (else
        (stream-cons
          (%car objs)
          (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) )

(define (list->stream objects)

  (define-stream (list->stream$ objs)
    (if (%null? objs) stream-null
      (stream-cons (%car objs) (list->stream$ (%cdr objs))) ) )

  (list->stream$ (%check-list 'list->stream objects 'objects)) )

(define (stream->list . args)
  (let* ((count (and (%fx< 1 (%list-length args))
                     (%check-natural-integer 'stream->list (%car args) 'count)))
         (strm (if count (%cadr args) (%car args)))
         (count (or count -1)) )
    (let loop ((n count) (strm (%check-stream 'stream->list strm 'stream)))
      (if (or (%fxzero? n) (stream-null? strm)) '()
        (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) )

(define (port->stream . port)

  (define-stream (port->stream$ p)
    (let ((c (read-char p)))
      (if (%eof-object? c) stream-null
        (stream-cons c (port->stream$ p)) ) )  )

  (let ((port (if (%null? port) (current-input-port) (%car port))))
    (port->stream$ (%check-input-port 'port->stream port 'port))) )

(define (stream-length strm)
  (let loop ((len 0) (strm (%check-stream 'stream-length strm 'stream)))
    (if (stream-null? strm) len
      (loop (%fxadd1 len) (stream-cdr strm)) ) ) )

(define (stream-ref strm index)
  (let loop ((strm (%check-stream 'stream-ref strm 'stream))
             (n (%check-natural-integer 'stream-ref index 'index)))
    (cond
      ((stream-null? strm)
        (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
      ((%fxzero? n)
        (stream-car strm) )
      (else
        (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) )

(define (stream-reverse strm)

  (define-stream (stream-reverse$ strm rev)
    (if (stream-null? strm) rev
      (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )

  (stream-reverse$ (%check-stream 'stream-reverse strm 'stream) stream-null) )

(define (stream-append . strms)

  (define-stream (stream-append$ strms)
    (cond
      ((%null? (%cdr strms))
        (%car strms) )
      ((stream-null? (%car strms))
        (stream-append$ (%cdr strms)) )
      (else
        (stream-cons
          (stream-car (%car strms))
          (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) )

  (if (%null? strms) stream-null
    (stream-append$ (%check-streams 'stream-append strms 'stream)) ) )

(define (stream-concat strm)

  (define-stream (stream-concat$ strm)
    (cond
      ((stream-null? strm)
        stream-null )
      ((not (stream? (stream-car strm)))
        (error-stream 'stream-concat strm) )
      ((stream-null? (stream-car strm))
        (stream-concat$ (stream-cdr strm)) )
      (else
        (stream-cons
          (stream-car (stream-car strm))
          (stream-concat$
            (stream-cons
              (stream-cdr (stream-car strm))
              (stream-cdr strm)))) ) ) )

  (stream-concat$ (%check-stream 'stream-concat strm 'stream)) )

(define (stream-drop count strm)

  (define-stream (stream-drop$ n strm)
    (if (or (%fxzero? n) (stream-null? strm)) strm
      (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) )

  (stream-drop$
    (%check-natural-integer 'stream-drop count 'count)
    (%check-stream 'stream-drop strm 'stream)) )

(define (stream-drop-while predicate? strm)

  (define-stream (stream-drop-while$ strm)
    (if (not (and (stream-pair? strm) (predicate? (stream-car strm)))) strm
      (stream-drop-while$ (stream-cdr strm)) ) )

  (%check-procedure 'stream-drop-while predicate? 'predicate?)
  (stream-drop-while$ (%check-stream 'stream-drop-while strm 'stream)) )

(define (stream-take count strm)

  (define-stream (stream-take$ n strm)
    (if (or (stream-null? strm) (%fxzero? n)) stream-null
      (stream-cons
        (stream-car strm)
        (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) )

  (stream-take$
    (%check-natural-integer 'stream-take count 'count)
    (%check-stream 'stream-take strm 'stream)) )

(define (stream-take-while predicate? strm)

 (define-stream (stream-take-while$ strm)
    (cond
      ((stream-null? strm)
        stream-null )
      ((predicate? (stream-car strm))
        (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) )
      (else
        stream-null ) ) )

  (%check-procedure 'stream-take-while predicate? 'predicate?)
  (stream-take-while$ (%check-stream 'stream-take-while strm 'stream)) )

(define (stream-filter predicate? strm)

  (define-stream (stream-filter$ strm)
    (cond
      ((stream-null? strm)
        stream-null )
      ((predicate? (stream-car strm))
        (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) )
      (else
        (stream-filter$ (stream-cdr strm)) ) ) )

  (%check-procedure 'stream-filter predicate? 'predicate?)
  (stream-filter$ (%check-stream 'stream-filter strm 'stream)) )

(define (stream-scan function base strm)

  (define-stream (stream-scan$ base strm)
    (if (stream-null? strm) (stream base)
      (stream-cons
        base
        (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )

  (%check-procedure 'stream-scan function 'function)
  (stream-scan$ base (%check-stream 'stream-scan strm 'stream)) )

(define (stream-fold function base . strms)

  (define (stream-folder base strms)
    (if (%list-any/1 stream-null? strms) base
      (stream-folder
        (apply function base (%list-map/1 stream-car strms))
        (%list-map/1 stream-cdr strms)) ) )

  (%check-procedure 'stream-fold function 'function)
  (stream-folder base (%check-streams 'stream-fold strms 'stream)) )

(define (stream-for-each procedure . strms)

  (define (stream-for-eacher strms)
    (unless (%list-any/1 stream-null? strms)
      (apply procedure (%list-map/1 stream-car strms))
      (stream-for-eacher (%list-map/1 stream-cdr strms)) ) )

  (%check-procedure 'stream-for-each procedure 'procedure)
  (stream-for-eacher (%check-streams 'stream-for-each strms 'stream)) )

(define (stream-map function . strms)

  ; not tail-recursive to avoid `stream-reverse'
  (define-stream (stream-map$ strms)
    (if (%list-any/1 stream-null? strms) stream-null
      (stream-cons
        (apply function (%list-map/1 stream-car strms))
        (stream-map$ (%list-map/1 stream-cdr strms))) ) )

  (%check-procedure 'stream-map function 'function)
  (stream-map$ (%check-streams 'stream-map strms 'stream)) )

(define (stream-from first . step)

  (define-stream (stream-from$ first delta)
    (stream-cons first (stream-from$ (%fx+ first delta) delta)) )

  (let ((delta (if (%null? step) 1 (%car step))))
    (stream-from$
      (%check-number 'stream-from first 'first)
      (%check-number 'stream-from delta 'delta)) ) )

(define (stream-iterate function base)

  (define-stream (stream-iterate$ base)
    (stream-cons base (stream-iterate$ (function base))) )

  (%check-procedure 'stream-iterate function 'function)
  (stream-iterate$ base) )

(define (stream-range first past . step)

  (define-stream (stream-range$ first past delta lt?)
    (if (not (lt? first past)) stream-null
      (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) )

  (%check-number 'stream-range first 'first)
  (%check-number 'stream-range past 'past)
  (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1))))
    (%check-number 'stream-range delta 'delta)
    (let ((lt? (if (< 0 delta) < >)))
      (stream-range$ first past delta lt?) ) ) )

(define (stream-unfold mapper predicate? generator base)

  (define-stream (stream-unfold$ base)
    (if (not (predicate? base)) stream-null
      (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )

  (%check-procedure 'stream-unfold mapper 'mapper)
  (%check-procedure 'stream-unfold predicate? 'predicate?)
  (%check-procedure 'stream-unfold generator 'generator)
  (stream-unfold$ base) )

(define (stream-unfolds generator seed)

  (define (len-values)
    (call-with-values
      (lambda () (generator seed))
      (lambda vs (%fxsub1 (%length vs)))) )

  (define-stream (unfold-result-stream seed)
    (call-with-values
      (lambda () (generator seed))
      (lambda (next . results)
        (stream-cons results (unfold-result-stream next)))) )

  (define-stream (result-stream->output-stream result-stream i)
    (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i))))
      (cond
        ((%pair? result)
          (stream-cons
            (%car result)
            (result-stream->output-stream (stream-cdr result-stream) i)) )
        ((not result)
          (result-stream->output-stream (stream-cdr result-stream) i) )
        ((%null? result)
          stream-null )
        (else
          (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )

  (define (result-stream->output-strms result-stream)
    (let loop ((i (len-values)) (outputs '()))
      (if (%fxzero? i) (apply values outputs)
        (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) )

  (%check-procedure 'stream-unfolds generator 'generator)
  (result-stream->output-strms (unfold-result-stream seed)) )

(define (stream-zip . strms)

  (define-stream (stream-zip$ strms)
    (if (%list-any/1 stream-null? strms) stream-null
      (stream-cons
        (%list-map/1 stream-car strms)
        (stream-zip$ (%list-map/1 stream-cdr strms))) ) )

  (stream-zip$ (%check-streams 'stream-zip strms 'stream)) )

) ;module streams-derived

#|-------------------- 1.2.1 |# "./streams-inlines.scm" 467
;;;; streams-inlines.scm
;;;; Kon Lovett, Apr '09

;;;

(define-inline (%stream? obj) (%structure-instance? obj 'stream))

(define-inline (%check-stream loc obj #!optional argnam)
  (unless (%stream? obj)
    (error-stream loc obj argnam))
  obj )

(define-inline (%check-streams loc strms #!optional argnam)
  (when (%null? strms)
    (error loc "no stream arguments"))
  (%list-for-each/1 (lambda (x) (%check-stream loc x argnam)) strms)
  strms )

#|-------------------- 1.2.1 |# "./streams-math.scm" 3376
;;;; streams-math.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-math

  (;export
    stream-max
    stream-min
    stream-sum
    odd-numbers-stream
    even-numbers-stream
    cardinal-numbers-stream
    natural-numbers-stream
    prime-numbers-stream
    hamming-sequence-stream)

  (import
    (except scheme
      max min + < = expt)
    chicken
    (only section-combinators
      left-section)
    (only numbers
      max min + < = expt)
    streams streams-utils)

  (require-library
    section-combinators
    streams streams-utils
    numbers)

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

;;;

(define (stream-max strm)
  (stream-fold-one max (%check-stream 'stream-max strm 'stream)) )

(define (stream-min strm)
  (stream-fold-one min (%check-stream 'stream-min strm 'stream)) )

(define stream-sum (left-section stream-fold + 0))

(define odd-numbers-stream (stream-from 1 2))

(define even-numbers-stream (stream-from 0 2))

(define cardinal-numbers-stream (stream-iterate add1 0))

(define natural-numbers-stream (stream-iterate add1 1))

(define-stream (prime-sieve$ strm)
  (define-stream (sift$ base strm)
    (define-stream (next$ base mult strm)
      (let ((first (stream-car strm))
            (rest (stream-cdr strm)))
        (cond
          ((< first mult)
            (stream-cons first (next$ base mult rest)) )
          ((< mult first)
            (next$ base (+ base mult) strm) )
          (else
            (next$ base (+ base mult) rest) ) ) ) )
    (next$ base (+ base base) strm) )
  (let ((first (stream-car strm))
        (rest (stream-cdr strm)))
    (stream-cons first (prime-sieve$ (sift$ first rest))) ) )

(define prime-numbers-stream (prime-sieve$ (stream-from 2)))

;; http://www.research.att.com/~njas/sequences/A051037

(define hamming-sequence-stream
  (stream-cons 1
    (stream-unique =
      (stream-merge <
        (stream-map (left-section * 2) hamming-sequence-stream)
        (stream-map (left-section * 3) hamming-sequence-stream)
        (stream-map (left-section * 5) hamming-sequence-stream)))) )

#;
(define power-table
  (stream-of
    (stream-of (expt m n) (m in (stream-from 1)))
    (n in (stream-from 2))))

) ;module streams-math

#|-------------------- 1.2.1 |# "./streams-utils.scm" 10695
;;;; streams-utils.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-utils

  (;export
    stream-intersperse
    stream-permutations
    file->stream
    stream-split
    stream-unique
    stream-fold-one
    stream-member
    stream-merge
    stream-partition
    stream-finds
    stream-find
    stream-remove
    stream-every
    stream-any
    stream-and
    stream-or
    stream-fold-right
    stream-fold-right-one
    stream-assoc
    stream-equal?
    stream-quick-sort
    stream-insertion-sort
    stream-merge-sort
    stream-maximum
    stream-minimum
    binary-tree-same-fringe?)

  (import
    scheme chicken
    (only data-structures
    complement)
    (only section-combinators
    right-section)
    streams
    (only type-errors
      error-list error-procedure
      error-string error-natural-integer))

  (require-library section-combinators streams type-errors)

  (include "chicken-primitive-object-inlines")
  (include "streams-inlines")
  (include "inline-type-checks")

;;;

(define-stream (stream-intersperse yy x)
  (%check-stream 'stream-intersperse yy 'stream)
  (stream-match yy
    (() (stream (stream x)))
    ((y . ys)
      (stream-append
        (stream (stream-cons x yy))
        (stream-map (lambda (z) (stream-cons y z)) (stream-intersperse ys x))) ) ) )

(define-stream (stream-permutations xs)
  (%check-stream 'stream-permutations xs 'stream)
  (if (stream-null? xs) (stream (stream))
    (stream-concat
      (stream-map
        (right-section stream-intersperse (stream-car xs))
        (stream-permutations (stream-cdr xs)))) ) )

(define-stream (file->stream filename #!optional (reader read-char))
  (%check-string 'file->streams filename 'filename)
  (%check-procedure 'file->streams reader 'reader)
  (let ((port (open-input-file filename)))
    (stream-let loop ((item (reader port)))
      (if (eof-object? item) (begin (close-input-port port) stream-null)
        (stream-cons item (loop (reader port))) ) ) ) )

(define (stream-split count strm)
  (%check-stream 'stream-split strm 'stream)
  (%check-natural-integer 'stream-split count 'count)
  (values (stream-take count strm) (stream-drop count strm)))

(define-stream (stream-unique eql? strm)
  (%check-procedure 'stream-unique eql? 'equivalence)
  (stream-let loop ((strm (%check-stream 'stream-unique strm 'stream)))
    (if (stream-null? strm) stream-null
      (stream-cons
        (stream-car strm)
        (loop (stream-drop-while (lambda (x) (eql? (stream-car strm) x)) strm))) ) ) )

(define (stream-fold-one func strm)
  (%check-stream 'stream-fold-one strm 'stream)
  (%check-procedure 'stream-fold-one func 'function)
  (stream-fold func (stream-car strm) (stream-cdr strm)) )

(define-stream (stream-member eql? item strm)
  (%check-procedure 'stream-member eql? 'equivalence)
  (stream-let loop ((strm (%check-stream 'stream-member strm 'stream)))
    (cond
      ((stream-null? strm)          #f)
      ((eql? item (stream-car strm)) strm)
      (else (loop (stream-cdr strm)) ) ) ) )

(define-stream (stream-merge lt? . strms)

  (define-stream (stream-merge$ xx yy)
    (stream-match xx
      (() yy )
      ((x . xs)
        (stream-match yy
          (() xx )
          ((y . ys)
            (if (lt? y x) (stream-cons y (stream-merge$ xx ys))
              (stream-cons x (stream-merge$ xs yy))))) ) ) )

  (%check-procedure 'stream-merge lt? 'less-than)
  (stream-let loop ((strms (%check-streams 'stream-merge strms 'stream)))
    (cond
      ((null? strms)        stream-null)
      ((null? (%cdr strms)) (%car strms))
      (else (stream-merge$ (%car strms) (apply stream-merge lt? (%cdr strms))) ) ) ) )

(define (stream-partition pred? strm)
  (%check-procedure 'stream-partition pred? 'predicate)
  (stream-unfolds
    (lambda (s)
      (if (stream-null? s) (values s '() '())
        (let ((a (stream-car s))
              (d (stream-cdr s)))
          (if (pred? a) (values d (list a) #f)
            (values d #f (list a)) ) ) ) )
    (%check-stream 'stream-partition strm 'stream)) )

(define-stream (stream-finds eql? item strm)
  (%check-procedure 'stream-finds eql? 'equivalence)
  (stream-of
    (%car x)
    (x in (stream-zip (stream-from 0) (%check-stream 'stream-finds strm 'stream)))
    (eql? item (%cadr x))) )

(define (stream-find eql? item strm)
  (%check-stream 'stream-find strm 'stream)
  (%check-procedure 'stream-find eql? 'equivalence)
  (stream-car (stream-append (stream-finds eql? item strm) (stream #f))) )

(define-stream (stream-remove pred? strm)
  (%check-procedure 'stream-remove pred? 'predicate)
  (stream-filter (complement pred?) (%check-stream 'stream-remove strm 'stream)) )

(define (stream-every pred? strm)
  (%check-procedure 'stream-every pred? 'predicate)
  (let loop ((strm (%check-stream 'stream-every strm 'stream)))
    (cond
      ((stream-null? strm)              #t)
      ((not (pred? (stream-car strm)))  #f)
      (else (loop (stream-cdr strm)) ) ) ) )

(define (stream-any pred? strm)
  (%check-procedure 'stream-any pred? 'predicate)
  (let loop ((strm (%check-stream 'stream-any strm 'stream)))
    (cond 
      ((stream-null? strm)        #f)
      ((pred? (stream-car strm))  #t)
      (else (loop (stream-cdr strm)) ) ) ) )

(define (stream-and strm)
  (let loop ((strm (%check-stream 'stream-and strm 'stream)))
    (cond ((stream-null? strm)      #t)
          ((not (stream-car strm))  #f)
          (else (loop (stream-cdr strm)) ) ) ) )

(define (stream-or strm)
  (%check-stream 'stream-or strm 'stream)
  (let loop ((strm strm))
    (cond
      ((stream-null? strm)  #f)
      ((stream-car strm)    #t)
      (else (loop (stream-cdr strm)) ) ) ) )

(define (stream-fold-right func base strm)
  (%check-procedure 'stream-fold-right func 'function)
  (let loop ((strm (%check-stream 'stream-fold-right strm 'stream)))
    (if (stream-null? strm) base
      (func (stream-car strm) (loop (stream-cdr strm))) ) ) )

(define (stream-fold-right-one func strm)
  (%check-procedure 'stream-fold-right-one func 'function)
  (let loop ((strm (%check-stream 'stream-fold-right-one strm 'stream)))
    (stream-match strm
      ((x) x )
      ((x . xs) (func x (loop xs)) ) ) ) )

(define (stream-assoc key dict #!optional (eql? equal?))
  (%check-procedure 'stream-assoc eql? 'equivalence)
  (let loop ((dict (%check-stream 'stream-assoc dict 'stream)))
    (cond
      ((stream-null? dict) #f)
      ((eql? key (%car (stream-car dict))) (stream-car dict) )
      (else (loop (stream-cdr dict)) ) ) ) )

; May never return
(define (stream-equal? eql? xs ys)
  (let loop ((xs (%check-stream 'stream-equal? xs 'stream1))
             (ys (%check-stream 'stream-equal? ys 'stream2)))
    (cond
      ((and (stream-null? xs) (stream-null? ys))    #t)
      ((or (stream-null? xs) (stream-null? ys))     #f)
      ((not (eql? (stream-car xs) (stream-car ys))) #f)
      (else (loop (stream-cdr xs) (stream-cdr ys)) ) ) ) )

(define-stream (stream-quick-sort lt? strm)
  (%check-procedure 'stream-quick-sort lt? 'less-than)
  (let loop ((strm (%check-stream 'stream-quick-sort strm 'stream)))
    (if (stream-null? strm) stream-null
      (let ((x (stream-car strm))
            (xs (stream-cdr strm)))
        (stream-append
          (loop (stream-filter (lambda (u) (lt? u x)) xs))
          (stream x)
          (loop (stream-filter (lambda (u) (not (lt? u x))) xs))) ) ) ) )

(define-stream (stream-insertion-sort lt? strm)

  (define-stream (insert$ strm x)
    (stream-match strm
      (()
        (stream x) )
      ((y . ys)
        (if (lt? y x) (stream-cons y (insert$ ys x))
          (stream-cons x strm) ) ) ) )

  (%check-procedure 'stream-insertion-sort lt? 'less-than)
  (stream-fold insert$ stream-null (%check-stream 'stream-insertion-sort strm 'stream)) )

(define-stream (stream-merge-sort lt? strm)
  (%check-procedure 'stream-merge-sort lt? 'less-than)
  (let loop ((strm (%check-stream 'stream-merge-sort strm 'stream)))
    (let ((n (quotient (stream-length strm) 2)))
      (if (zero? n) strm
        (stream-merge lt? (loop (stream-take n strm)) (loop (stream-drop n strm))) ) ) ) )

(define (stream-maximum lt? strm)
  (%check-procedure 'stream-maximum lt? 'less-than)
  (stream-fold-one
    (lambda (x y) (if (lt? x y) y x))
    (%check-stream 'stream-maximum strm 'stream)) )

(define (stream-minimum lt? strm)
  (%check-procedure 'stream-minimum lt? 'less-than)
  (stream-fold-one
    (lambda (x y) (if (lt? x y) x y))
    (%check-stream 'stream-minimum strm 'stream)) )

;; Lazy binary-tree "same fringe" 

(define (binary-tree-same-fringe? tree1 tree2 #!optional (eql? equal?))

  (define-stream (flatten tree)
    (cond
      ((%null? tree)
        stream-null)
      ((%pair? (%car tree))
        (stream-append (flatten (%car tree)) (flatten (%cdr tree))))
      (else
        (stream-cons (%car tree) (flatten (%cdr tree))) ) ) )

  (let loop ((t1 (flatten (%check-list 'same-fringe? tree1 'tree1)))
             (t2 (flatten (%check-list 'same-fringe? tree2 'tree2))))
    (cond
      ((and (stream-null? t1) (stream-null? t2))    #t )
      ((or  (stream-null? t1) (stream-null? t2))    #f )
      ((not (eql? (stream-car t1) (stream-car t2))) #f )
      (else
        (loop (stream-cdr t1) (stream-cdr t2)) ) ) ) )

) ;module streams-utils

#|-------------------- 1.2.1 |# "./streams.scm" 2085
;;;; streams.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

  (;export
    stream-null stream-cons stream? stream-null? stream-pair? stream-car
    stream-cdr stream-lambda define-stream list->stream port->stream stream
    stream->list stream-append stream-concat stream-constant stream-drop
    stream-drop-while stream-filter stream-fold stream-for-each stream-from
    stream-iterate stream-length stream-let stream-map stream-match
    stream-of stream-range stream-ref stream-reverse stream-scan stream-take
    stream-take-while stream-unfold stream-unfolds stream-zip
    ;; Extras
    stream-occupied?
    ;; Common errors
    check-stream error-stream
    check-stream-occupied error-stream-occupied)

  (import scheme chicken streams-primitive streams-derived)
  (require-library streams-primitive streams-derived)

(register-feature! 'srfi-41)
(register-feature! 'streams)

) ;module streams