#|-------------------- 2.1.5 |# "./chicken-primitive-object-inlines.scm" 36380
;;;; 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 (%fxcardinal? fx) (%fx<= 0 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 (%cardinal? fx) (%<= 0 fx))

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

#|-------------------- 2.1.5 |# "./chicken-thread-object-inlines.scm" 7916
;;;; chicken-thread-object-primitive-inlines.scm
;;;; Kon Lovett, Jan '09

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

;; Notes
;
; Provides inlines & macros for thread objects. Use of these procedures
; by non-core & non-core-extensions is highly suspect. Many of these routines
; are unsafe.
;
; In fact, any use is suspect ;-)


;;; Mutex object helpers:

;; Mutex layout:
;
; 0     Tag - 'mutex
; 1     Name (object)
; 2     Thread (thread or #f)
; 3     Waiting threads (FIFO list)
; 4     Abandoned? (boolean)
; 5     Locked? (boolean)
; 6     Specific (object)

(define-inline (%mutex? x)
  (%structure-instance? x 'mutex) )

(define-inline (%mutex-name mx)
  (%structure-ref mx 1) )

(define-inline (%mutex-thread mx)
  (%structure-ref mx 2) )

(define-inline (%mutex-thread-set! mx th)
  (%structure-set!/mutate mx 2 th) )

(define-inline (%mutex-thread-clear! mx)
  (%structure-set!/immediate mx 2 #f) )

(define-inline (%mutex-waiters mx)
  (%structure-ref mx 3) )

(define-inline (%mutex-waiters-set! mx wt)
  (%structure-set!/mutate mx 3 wt) )

(define-inline (%mutex-waiters-empty? mx)
  (%null? (%mutex-waiters mx)) )

(define-inline (%mutex-waiters-empty! mx)
  (%structure-set!/immediate mx 3 '()) )

(define-inline (%mutex-waiters-add! mx th)
  (%mutex-waiters-set! mx (%append! (%mutex-waiters mx) (%cons th '()))) )

(define-inline (%mutex-waiters-delete! mx th)
  (%mutex-waiters-set! mx (%delq! th (%mutex-waiters mx))) )

(define-inline (%mutex-waiters-pop! mx)
  (let* ([wt (%mutex-waiters mx)]
         [top (%car wt)])
    (%mutex-waiters-set! mx (%cdr wt))
    top ) )

(define-inline (%mutex-abandoned? mx)
  (%structure-ref mx 4) )

(define-inline (%mutex-abandoned-set! mx f)
  (%structure-set!/immediate mx 4 f) )

(define-inline (%mutex-locked? mx)
  (%structure-ref mx 5) )

(define-inline (%mutex-locked-set! mx f)
  (%structure-set!/immediate mx 5 f) )

(define-inline (%mutex-specific mx)
  (%structure-ref mx 6) )

(define-inline (%mutex-specific-set! mx x)
  (%structure-set!/mutate mx 6 x) )


;;; Thread object helpers:

;; Thread layout:
;
; 0     Tag - 'thread
; 1     Thunk (procedure)
; 2     Results (#f until thunk return then list-of object)
; 3     State (symbol)
; 4     Block-timeout (fixnum or #f)
; 5     State buffer (vector)
;       0       Dynamic winds (list)
;       1       Standard input (port)
;       2       Standard output (port)
;       3       Standard error (port)
;       4       Exception handler (procedure)
;       5       Parameters (vector)
; 6     Name (object)
; 7     Reason (condition or #f)
; 8     Owned Mutexes (list-of mutex)
; 9     Quantum (fixnum)
; 10    Specific (object)
; 11    Block object (type depends on blocking type)
; 12    Recipients (list-of thread)
; 13    Unblocked by timeout? (boolean)

(define-inline (%thread? x)
  (%structure-instance? x 'thread) )

(define-inline (%thread-thunk th)
  (%structure-ref th 1) )

(define-inline (%thread-thunk-set! th tk)
  (%structure-set!/mutate th 1 tk) )

(define-inline (%thread-results th)
  (%structure-ref th 2) )

(define-inline (%thread-results-set! th rs)
  (%structure-set!/mutate th 2 rs) )

(define-inline (%thread-state th)
  (%structure-ref th 3) )

(define-inline (%thread-state-set! th st)
  (%structure-set!/mutate th 3 st) )

(define-inline (%thread-block-timeout th)
  (%structure-ref th 4) )

(define-inline (%thread-block-timeout-set! th to)
  (%structure-set!/immediate th 4 to) )

(define-inline (%thread-block-timeout-clear! th)
  (%thread-block-timeout-set! th #f) )

(define-inline (%thread-state-buffer th)
  (%structure-ref th 5) )

(define-inline (%thread-state-buffer-set! th v)
  (%structure-set!/mutate th 5 v) )

(define-inline (%thread-name th)
  (%structure-ref th 6) )

(define-inline (%thread-reason th)
  (%structure-ref th 7) )

(define-inline (%thread-reason-set! th cd)
  (%structure-set!/mutate th 7 cd) )

(define-inline (%thread-mutexes th)
  (%structure-ref th 8) )

(define-inline (%thread-mutexes-set! th wt)
  (%structure-set!/mutate th 8 wx) )

(define-inline (%thread-mutexes-empty? th)
  (%null? (%thread-mutexes th)) )

(define-inline (%thread-mutexes-empty! th)
  (%structure-set!/immediate th 8 '()) )

(define-inline (%thread-mutexes-add! th mx)
  (%thread-mutexes-set! th (%cons mx (%thread-mutexes th))) )

(define-inline (%thread-mutexes-delete! th mx)
  (%thread-mutexes-set! th (%delq! mx (%thread-mutexes th))) )

(define-inline (%thread-quantum th)
  (%structure-ref th 9) )

(define-inline (%thread-quantum-set! th qt)
  (%structure-set!/immediate th 9 qt) )

(define-inline (%thread-specific th)
  (%structure-ref th 10) )

(define-inline (%thread-specific-set! th x)
  (%structure-set!/mutate th 10 x) )

(define-inline (%thread-block-object th)
  (%structure-ref th 11) )

(define-inline (%thread-block-object-set! th x)
  (%structure-set!/mutate th 11 x) )

(define-inline (%thread-block-object-clear! th)
  (%structure-set!/immediate th 11 #f) )

(define-inline (%thread-recipients th)
  (%structure-ref th 12) )

(define-inline (%thread-recipients-set! th x)
  (%structure-set!/mutate th 12 x) )

(define-inline (%thread-recipients-empty? th)
  (%null? (%condition-variable-waiters th)) )

(define-inline (%thread-recipients-empty! th)
  (%structure-set!/immediate th 12 '()) )

(define-inline (%thread-recipients-add! th rth)
  (%thread-recipients-set! t (%cons rth (%thread-recipients t))) )

(define-inline (%thread-recipients-process! th tk)
  (let ([rs (%thread-recipients t)])
    (unless (%null? rs) (for-each tk rs) ) )
  (%thread-recipients-empty! t) )

(define-inline (%thread-unblocked-by-timeout? th)
  (%structure-ref th 13) )

(define-inline (%thread-unblocked-by-timeout-set! th f)
  (%structure-set!/immediate th 13 f) )

(define-inline (%thread-blocked-for-timeout? th)
  (and (%thread-block-timeout th)
       (not (%thread-block-object th))) )

(define-inline (%thread-blocked? th)
  (%eq? 'blocked (%thread-state th)) )

(define-inline (%thread-created? th)
  (%eq? 'created (%thread-state th)) )

(define-inline (%thread-ready? th)
  (%eq? 'ready (%thread-state th)) )

(define-inline (%thread-sleeping? th)
  (%eq? 'sleeping (%thread-state th)) )

(define-inline (%thread-suspended? th)
  (%eq? 'suspended (%thread-state th)) )

(define-inline (%thread-terminated? th)
  (%eq? 'terminated (%thread-state th)) )

(define-inline (%thread-dead? th)
  (%eq? 'dead (%thread-state th)) )

;; Synonyms

(define-inline (%current-thread)
  ##sys#current-thread )


;;; Condition-variable object:

;; Condition-variable layout:
;
; 0     Tag - 'condition-variable
; 1     Name (object)
; 2     Waiting threads (FIFO list)
; 3     Specific (object)

(define-inline (%condition-variable? x)
  (%structure-instance? x 'condition-variable) )

(define-inline (%condition-variable-name cv)
  (%structure-ref cv 1) )

(define-inline (%condition-variable-waiters cv)
  (%structure-ref cv 2) )

(define-inline (%condition-variable-waiters-set! cv x)
  (%structure-set!/mutate cv 2 x) )

(define-inline (%condition-variable-waiters-empty? cv)
  (%null? (%condition-variable-waiters cv)) )

(define-inline (%condition-variable-waiters-empty! cv)
  (%structure-set!/immediate cv 2 '()) )

(define-inline (%condition-variable-waiters-add! cv th)
  (%condition-variable-waiters-set! cv (%append! (%condition-variable-waiters cv) (%cons th '()))) )

(define-inline (%condition-variable-waiters-delete! cv th)
  (%condition-variable-waiters-set! cv (%delq! th (%condition-variable-waiters cv))) )

(define-inline (%condition-variable-waiters-pop! mx)
  (let* ([wt (%condition-variable-waiters mx)]
         [top (%car wt)])
    (%condition-variable-waiters-set! mx (%cdr wt))
    top ) )

(define-inline (%condition-variable-specific cv)
  (%structure-ref cv 3) )

(define-inline (%condition-variable-specific-set! cv x)
  (%structure-set!/mutate cv 3 x) )

#|-------------------- 2.1.5 |# "./inline-queue.scm" 2275
;;;; inline-queue.scm
;;;; Kon Lovett, Jun '10

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

;; Support

(define-record-type-variant queue (unsafe unchecked inline)
  (%%make-queue hd tl)
  %queue?
  (hd %queue-first-pair %queue-first-pair-set!)
  (tl %queue-last-pair %queue-last-pair-set!) )

(define-inline (%make-queue) (%%make-queue '() '()))

(define-inline (%queue-empty? q) ($null? (%queue-first-pair q)))
(define-inline (%queue-count q) ($length (%queue-first-pair q)))

;; Operations

(define-inline (%queue-last-pair-empty! q) (%queue-last-pair-set! q '()))

(define-inline (%queue-add! q datum)
  (let ((new-pair ($cons datum '())))
    (if ($null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
        ($set-cdr! (%queue-last-pair q) new-pair) )
    (%queue-last-pair-set! q new-pair) ) )

(define-inline (%queue-remove! q)
  (let* ((first-pair (%queue-first-pair q))
         (next-pair ($cdr first-pair)))
    (%queue-first-pair-set! q next-pair)
    (when ($null? next-pair) (%queue-last-pair-empty! q) )
    ($car first-pair) ) )

(define-inline (%queue-push-back! q item)
  (let ((newlist ($cons item (%queue-first-pair q))))
    (%queue-first-pair-set! q newlist)
    (when ($null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )

(define-inline (%queue-push-back-list! q itemlist)
  (let ((newlist ($append! ($list-copy itemlist) (%queue-first-pair q))))
    (%queue-first-pair-set! q newlist)
    (if ($null? newlist) (%queue-last-pair-empty! q)
        (%queue-last-pair-set! q ($last-pair newlist) ) ) ) )

(define-inline (%queue-extract-pair! q targ-pair)
  ; Scan queue list until we find the item to remove
  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
    ; Keep scanning until found
    (if (not ($eq? this-pair targ-pair)) (scanning ($cdr this-pair) this-pair)
        ;found so cut out the pair
        (let ((next-pair ($cdr this-pair)))
          ; At the head of the list, or in the body?
          (if ($null? prev-pair) (%queue-first-pair-set! q next-pair)
              ($set-cdr! prev-pair next-pair) )
          ; When the cut pair is the last item update the last pair ref.
          (when ($eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) ) ) ) )

#|-------------------- 2.1.5 |# "./mailbox.meta" 563
;;; mailbox.meta -*- Hen -*-

((egg "mailbox.egg")
 (synopsis "Thread-safe queues with timeout")
 (category hell)
 (author "[[felix winkelman]] and [[kon lovett]]")
 (license "BSD")
 (doc-from-wiki)
 (depends
	(setup-helper "1.5.2")
	(check-errors "1.12.5")
	(condition-utils "1.0.0")
	(record-variants "0.5"))
 (files "mailbox.meta" "mailbox.scm" "chicken-thread-object-inlines.scm" "chicken-primitive-object-inlines.scm" "mailbox.release-info" "inline-queue.scm" "mailbox.setup" "tests/mailbox-cursor-test.scm" "tests/reader-writer-test.scm" "tests/run.scm") )

#|-------------------- 2.1.5 |# "./mailbox.scm" 17821
;;;; mailbox.scm
;;;; Kon Lovett, Mar '09
;;;; From Chicken 3 "mailbox" by Felix & Kon

;; Issues
;;
;; - When compile-time feature `unsafe-operations' inlined & primitive routines used.
;;
;; - Has explicit "unspecified" returns in some cases to avoid leaks of internal
;; objects.
;;
;; - 'wait-mailbox' may not return should a timeout exception occur.
;;
;; - Uses ##sys#thread-unblock!
;;
;; - Has knowledge of Unit srfi-18 time object internals.
;;
;; - Uses the Chicken extensions 'thread-suspend' & 'thread-resume'.
;;
;; - The thread waiting on a mailbox cursor may miss items since only
;; the end of the queue is available safely.
;;
;; - Probably should be rewritten to use a mutex & condition-variable rather than
;; disabling interrupts and having own thread waiting queue.

(module mailbox

  (;export
    ;Mailbox Exception API
    mailbox-timeout-condition? mailbox-timeout-exception?
    ;Mailbox API
    make-mailbox
    mailbox?
    mailbox-name
    mailbox-empty?
    mailbox-count
    mailbox-waiting?
    mailbox-waiters
    mailbox-send!
    mailbox-wait!
    mailbox-receive!
    mailbox-push-back!
    mailbox-push-back-list!
    ;Mailbox Cursor API
    make-mailbox-cursor
    mailbox-cursor?
    mailbox-cursor-mailbox
    mailbox-cursor-next
    mailbox-cursor-rewind
    mailbox-cursor-rewound?
    mailbox-cursor-unwound?
    mailbox-cursor-extract-and-rewind!)

  (import
    scheme
    chicken
    (only ports with-output-to-port)
    (only srfi-1 append! delete! list-copy last-pair)
    (only srfi-18
      current-thread
      thread-signal! thread-sleep!
      thread-suspend! thread-resume!
      time?)
    (only type-errors define-error-type error-list)
    (only condition-utils make-exn-condition+ make-condition-predicate)
    record-variants)

  (require-library
    ports srfi-1 srfi-18
    type-errors condition-utils
    record-variants)

  (declare
    (disable-interrupts) ;A MUST!
    (bound-to-procedure
      ##sys#signal-hook
      ##sys#thread-unblock!) )

;;; Primitives

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

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

(cond-expand
  (unsafe-operations
    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (%eq? ?arg0 ...))))
    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (%null? ?arg0 ...))))
    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (%list? ?arg0 ...))))
    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (%length ?arg0 ...))))
    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (%append! ?arg0 ...))))
    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (%delq! ?arg0 ...))))
    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (%cons ?arg0 ...))))
    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (%car ?arg0 ...))))
    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (%cdr ?arg0 ...))))
    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (%set-car! ?arg0 ...))))
    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (%set-cdr! ?arg0 ...))))
    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (%list-copy ?arg0 ...))))
    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (%last-pair ?arg0 ...))))
    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (%current-thread ?arg0 ...))))
    (define-syntax $thread-blocked? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked? ?arg0 ...))))
    (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...))))
    )
  (else
    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (eq? ?arg0 ...))))
    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (null? ?arg0 ...))))
    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (list? ?arg0 ...))))
    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (length ?arg0 ...))))
    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (append! ?arg0 ...))))
    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (delete! ?arg0 ...))))
    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (cons ?arg0 ...))))
    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (car ?arg0 ...))))
    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (cdr ?arg0 ...))))
    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (set-car! ?arg0 ...))))
    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (set-cdr! ?arg0 ...))))
    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (list-copy ?arg0 ...))))
    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (last-pair ?arg0 ...))))
    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (current-thread ?arg0 ...))))
    (define ($thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
    (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
    ) )

;;; Mailbox Support

(define-record-type-variant mailbox (unsafe unchecked inline)
  (%%make-mailbox nm qu wt)
  %mailbox?
  (nm %mailbox-name)
  (qu %mailbox-queue)
  (wt %mailbox-waiters %mailbox-waiters-set!) )

(define-inline (%make-mailbox nm) (%%make-mailbox nm (%make-queue) '()))

(define-error-type mailbox)
(define-inline-check-type mailbox)

;; Message queue

(define-inline (%mailbox-queue-first-pair mb) (%queue-first-pair (%mailbox-queue mb)))
(define-inline (%mailbox-queue-last-pair mb) (%queue-last-pair (%mailbox-queue mb)))
(define-inline (%mailbox-queue-empty? mb) (%queue-empty? (%mailbox-queue mb)))
(define-inline (%mailbox-queue-count mb) (%queue-count (%mailbox-queue mb)))
(define-inline (%mailbox-queue-add! mb x) (%queue-add! (%mailbox-queue mb) x))
(define-inline (%mailbox-queue-remove! mb) (%queue-remove! (%mailbox-queue mb)))
(define-inline (%mailbox-queue-push-back! mb x) (%queue-push-back! (%mailbox-queue mb) x))
(define-inline (%mailbox-queue-push-back-list! mb ls) (%queue-push-back-list! (%mailbox-queue mb) ls))

;; Waiting threads

(define-inline (%mailbox-waiters-empty? mb) ($null? (%mailbox-waiters mb)))
(define-inline (%mailbox-waiters-count mb) ($length (%mailbox-waiters mb)))

(define-inline (%mailbox-waiters-add! mb th)
  (%mailbox-waiters-set! mb ($append! (%mailbox-waiters mb) ($cons th '()))) )

(define-inline (%mailbox-waiters-delete! mb th)
  (%mailbox-waiters-set! mb ($delq! th (%mailbox-waiters mb))) )

(define-inline (%mailbox-waiters-pop! mb)
  (let ((ts (%mailbox-waiters mb)))
    (%mailbox-waiters-set! mb ($cdr ts))
    ($car ts) ) )

;;; Mailbox Cursor Support

(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
  (%%make-mailbox-cursor np pp mb)
  %mailbox-cursor?
  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
  (mb %mailbox-cursor-mailbox) )

(define-inline (%make-mailbox-cursor mb) (%%make-mailbox-cursor '() #f mb))

(define-error-type mailbox-cursor)
(define-inline-check-type mailbox-cursor)

(define-inline (%mailbox-cursor-winding? mbc) (->boolean (%mailbox-cursor-prev-pair mbc)))
(define-inline (%mailbox-cursor-next-pair-empty! mbc) (%mailbox-cursor-next-pair-set! mbc '()))
(define-inline (%mailbox-cursor-prev-pair-clear! mbc) (%mailbox-cursor-prev-pair-set! mbc #f))

(define-inline (%mailbox-cursor-rewind! mbc)
  (%mailbox-cursor-next-pair-empty! mbc)
  (%mailbox-cursor-prev-pair-clear! mbc) )

(define-inline (%mailbox-cursor-extract! mbc)
  ;Unless 'mailbox-cursor-next' has been called don't remove
  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )

;; Time Support

(define-inline (%timeout? obj) (or (number? obj) (time? obj)))
(define-error-type timeout)
(define-inline-check-type timeout)

;;;

;Unique objects used as tags
(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
#; ;XXX
(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))

;;; Mailbox Exceptions

(define (make-mailbox-timeout-condition loc timout timout-value)
  (let ((args (if ($eq? timout-value NO-TOVAL-TAG) (list timout)
                  (list timout timout-value))))
    (make-exn-condition+ loc "mailbox wait timeout occured" args 'mailbox 'timeout) ) )

;;; Mailbox Threading

;; Select next waiting thread for the mailbox

(define (ready-mailbox-thread! mb)
  ;Ready oldest waiting thread
  (unless (%mailbox-waiters-empty? mb)
    (let ((thread (%mailbox-waiters-pop! mb)))
      ;Ready the thread based on wait mode
      (if (not ($thread-blocked? thread)) (thread-resume! thread)
          ;else wake early if sleeping
          (when ($thread-blocked-for-timeout? thread)
            ;Ready the thread
            (##sys#thread-unblock! thread)
            ;Tell 'wait-mailbox-thread!' we unblocked early
            (thread-signal! thread UNBLOCKED-TAG) ) ) )
    (void) ) )

;; Sleep current thread until timeout, known condition,
;; or some other condition

(define-inline (thread-sleep/maybe-unblock! tim unblocked-tag)
  ;Sleep current thread for desired seconds, unless unblocked "early".
  (call/cc
    (lambda (return)
      (with-exception-handler
        (lambda (exp)
          (if ($eq? unblocked-tag exp) (return #f)
              ;Propagate any "real" exception.
              (signal exp)))
        (lambda () (thread-sleep! tim) #t)))) )

;; Wait current thread on the mailbox until timeout, available message
;; or some other condition

(define (wait-mailbox-thread! loc mb timout timout-value)
  ;Push current thread on mailbox waiting queue
  (%mailbox-waiters-add! mb ($current-thread))
  ;Waiting action
  (cond
    (timout   ;Timeout wanted so sleep until something happens
      (cond
        ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
          ;Timedout, so no message
          ;Remove from wait queue
          (%mailbox-waiters-delete! mb ($current-thread))
          ;Indicate no available message
          (if (not ($eq? timout-value NO-TOVAL-TAG)) timout-value
            (begin
              (thread-signal!
                ($current-thread)
                (make-mailbox-timeout-condition loc timout timout-value))
              SEQ-FAIL-TAG ) ) )
        (else
          ;Unblocked early
          UNBLOCKED-TAG ) ) )
    (else   ;No timeout so suspend until something delivered
      (thread-suspend! ($current-thread))
      ;We're resumed
      UNBLOCKED-TAG ) ) )

;; Wait current thread on the mailbox unless a message available

;Note that the arguments, except the ?expr0 ..., must be base values.
(define-syntax on-mailbox-available
  (syntax-rules ()
    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
      (let waiting ()
        (cond
          ((%mailbox-queue-empty? ?mb)
            (let ((res (wait-mailbox-thread! ?loc ?mb ?timout ?timout-value)))
              ;When a thread ready then check mailbox again, could be empty.
              (if ($eq? UNBLOCKED-TAG res) (waiting)
                  ;else some sort of problem
                  res ) ) )
          (else
            ?expr0 ... ) ) ) ) ) )

#; ;XXX
(define (wait-mailbox-if-empty! loc mb timout timout-value)
  (on-mailbox-available loc mb timout timout-value
    MESSAGE-WAITING-TAG ) )

;;; Mailbox

;; Mailbox Exceptions

(define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
(define mailbox-timeout-exception? mailbox-timeout-condition?)

;; Mailbox Constructor

(define (make-mailbox #!optional (nm (gensym 'mailbox)))
  (%make-mailbox nm) )

(define (mailbox? obj) (%mailbox? obj))

;; Mailbox Properties

(define (mailbox-name mb)
  (%check-mailbox 'mailbox-name mb)
  (%mailbox-name mb) )

(define (mailbox-empty? mb)
  (%check-mailbox 'mailbox-empty? mb)
  (%mailbox-queue-empty? mb) )

(define (mailbox-count mb)
  (%check-mailbox 'mailbox-count mb)
  (%mailbox-queue-count mb) )

(define (mailbox-waiting? mb)
  (%check-mailbox 'mailbox-waiting? mb)
  (not ($null? (%mailbox-waiters mb))) )

(define (mailbox-waiters mb)
  (%check-mailbox 'mailbox-waiters mb)
  ($list-copy (%mailbox-waiters mb)) )

;; Mailbox Operations

(define (mailbox-send! mb x)
  (%check-mailbox 'mailbox-send! mb)
  (%mailbox-queue-add! mb x)
  (ready-mailbox-thread! mb) )

(define (mailbox-wait! mb #!optional timout)
  (%check-mailbox 'mailbox-wait! mb)
  (when timout (%check-timeout 'mailbox-wait! timout))
  (on-mailbox-available 'mailbox-wait! mb timout NO-TOVAL-TAG
    (void) ) )

(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
  (%check-mailbox 'mailbox-receive! mb)
  (when timout (%check-timeout 'mailbox-receive! timout))
  (on-mailbox-available 'mailbox-receive! mb timout timout-value
    (%mailbox-queue-remove! mb) ) )

(define (mailbox-push-back! mb x)
  (%check-mailbox 'mailbox-send! mb)
  (%mailbox-queue-push-back! mb x)
  (ready-mailbox-thread! mb) )

(define (mailbox-push-back-list! mb ls)
  (%check-mailbox 'mailbox-send! mb)
  (%check-list ls 'mailbox-send!)
  (%mailbox-queue-push-back-list! mb ls)
  (ready-mailbox-thread! mb) )

;;; Mailbox Cursor

;; Mailbox Cursor Constructor

(define (make-mailbox-cursor mb)
  (%check-mailbox 'make-mailbox-cursor mb)
  (%make-mailbox-cursor mb) )

;; Mailbox Cursor Properties

(define (mailbox-cursor? obj)
  (%mailbox-cursor? obj) )

(define (mailbox-cursor-mailbox mbc)
  (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
  (%mailbox-cursor-mailbox mbc) )

(define (mailbox-cursor-rewound? mbc)
  (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
  (not (%mailbox-cursor-winding? mbc)) )

(define (mailbox-cursor-unwound? mbc)
  (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)
  ($null? (%mailbox-cursor-next-pair mbc)) )

;; Mailbox Cursor Operations

(define (mailbox-cursor-rewind mbc)
  (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
  (%mailbox-cursor-rewind! mbc) )

#; ;XXX
(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
  (when timout (%check-timeout 'mailbox-cursor-next timout))
  ;Waiting mailbox peek.
  (let ((mb (%mailbox-cursor-mailbox mbc)))
    (receive (mailbox-waiter cursor-pair-getter)
               (if (%mailbox-cursor-winding? mbc)
                   ;then unconditionally wait until something added
                   (values wait-mailbox-thread!
                           (lambda () (%mailbox-queue-last-pair mb)))
                   ;else grab the start of a, probably, non-empty queue
                   (values wait-mailbox-if-empty!
                           (lambda () (%mailbox-queue-first-pair mb))))
      (let scanning ()
        (let ((next-pair (%mailbox-cursor-next-pair mbc)))
          ;Anything next?
          (if (not (%null? next-pair))
              ;then peek into the queue for the next item
              (let ((item (%car next-pair)))
                (%mailbox-cursor-prev-pair-set! mbc next-pair)
                (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
                item )
              ;else wait for something in the mailbox
              (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
                (cond
                  ((or ($eq? MESSAGE-WAITING-TAG res) ;so continue scanning
                       ($eq? UNBLOCKED-TAG res))
                    (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
                    (scanning) )
                  (else                               ;otherwise timedout
                    res ) ) ) ) ) ) ) ) )

(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
  (when timout (%check-timeout 'mailbox-cursor-next timout))
  (let ((mb (%mailbox-cursor-mailbox mbc)))
    ;Seed rewound cursor
    (unless (%mailbox-cursor-winding? mbc)
      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
    ;Pull next item from queue at cursor
    (let scanning ()
      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
        ;Anything next?
        (if (not ($null? curr-pair))
            ;then peek into the queue for the next item
            (let ((item ($car curr-pair)))
              (%mailbox-cursor-prev-pair-set! mbc curr-pair)
              (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
              item )
            ;else wait for something in the mailbox
            (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
              (cond
                (($eq? UNBLOCKED-TAG res) ;so continue scanning
                  (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
                  (scanning) )
                (else                     ;some problem (timeout maybe)
                  res ) ) ) ) ) ) ) )

(define (mailbox-cursor-extract-and-rewind! mbc)
  (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
  (%mailbox-cursor-extract! mbc)
  (%mailbox-cursor-rewind! mbc) )

;;; Read/Print Syntax

(define-record-printer (mailbox mb out)
  (with-output-to-port out
    (lambda ()
      (display "#<mailbox")
      (display #\space) (display (%mailbox-name mb))
      (display " queued = ") (display (%mailbox-queue-count mb))
      (display " waiters = ") (display (%mailbox-waiters-count mb))
      (display ">") ) ) )

(define-record-printer (mailbox-cursor mbc out)
  (with-output-to-port out
    (lambda ()
      (display "#<mailbox-cursor")
      (display " mailbox = ") (display (%mailbox-name (%mailbox-cursor-mailbox mbc)))
      (display " status = ") (display (if (%mailbox-cursor-winding? mbc) "winding" "rewound"))
      (display ">") ) ) )

) ;module mailbox

#|-------------------- 2.1.5 |# "./mailbox.setup" 326
;;;; mailbox.setup  -*- Hen -*-

(use setup-helper-mod)

(verify-extension-name 'mailbox)

(setup-shared-extension-module 'mailbox (extension-version "2.1.5")
  #:compile-options '(
    -scrutinize
    -feature unsafe-operations
    -optimize-level 3 -debug-level 1
    -no-procedure-checks -no-bound-checks -no-argc-checks))