"prims.ss"
;;; prims.ss
;;; Copyright 1984-2016 Cisco Systems, Inc.
;;; 
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;; http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(eval-when (compile)
   (optimize-level 3)
   (run-cp0 (default-run-cp0))
   (generate-interrupt-trap #f))

;;; hand-coded primitives

(define-who $hand-coded
  (lambda (name)
    ($oops who
      "must invoke with quoted name and compile at optimize level 2 or 3")))

(define list ($hand-coded 'list-procedure))
(define $record ($hand-coded '$record-procedure))
(define vector ($hand-coded 'vector-procedure))
(define cons* ($hand-coded 'cons*-procedure))
(define list* ($hand-coded 'list*-procedure))
(define $apply ($hand-coded '$apply-procedure))

;;; basic C-coded primitives

(define $oops ; boot-time error procedure
  (foreign-procedure "(cs)boot-error"
    (scheme-object scheme-object scheme-object)
    void))
(define errorf $oops)
(define assertion-violationf $oops)

(define $lookup-library-entry
  (foreign-procedure "(cs)lookup_library_entry"
    (fixnum boolean)
    scheme-object))

(define $flonum->fixnum
  (foreign-procedure "(cs)s_fltofx"
    (scheme-object)
    scheme-object))

; must be compiled w/generate-interrupt-trap #f for library eq-hashtable operations
(define weak-cons
  (foreign-procedure "(cs)s_weak_cons"
    (scheme-object scheme-object)
    scheme-object))

(define weak-pair?
  (foreign-procedure "(cs)s_weak_pairp"
    (scheme-object)
    scheme-object))

(define $split-continuation
  (foreign-procedure "(cs)single_continuation"
    (scheme-object iptr)
    scheme-object))

(define $set-collect-trip-bytes
  (foreign-procedure "(cs)s_set_collect_trip_bytes"
    (scheme-object)
    scheme-object))

(define oblist
  (foreign-procedure "(cs)s_oblist"
    ()
    scheme-object))

(define-who $show-allocation
  (let ([fp (foreign-procedure "(cs)s_showalloc" (boolean string) void)])
    (case-lambda
      [() (fp #f #f)]
      [(x) (fp x #f)]
      [(x s)
       (unless (string? s) ($oops who "~s is not a string" s))
       (fp x s)])))

(define-who $enable-check-heap
  (let ([get (foreign-procedure "(cs)check_heap_enabledp" () boolean)]
        [set (foreign-procedure "(cs)enable_check_heap" (boolean) void)])
    (case-lambda
      [() (get)]
      [(x) (set x)])))

(define-who $check-heap-errors
  (foreign-procedure "(cs)check_heap_errors"
    ()
    uptr))

(define-who system
  (let ([p (foreign-procedure "(cs)s_system" (string) scheme-object)])
    (lambda (x)
      (unless (string? x) ($oops who "~s is not a string" x))
      (p x))))

(define $set-code-byte!
  (foreign-procedure "(cs)s_set_code_byte"
    (scheme-object scheme-object scheme-object)
    scheme-object))

(define $set-code-word!
  (foreign-procedure "(cs)s_set_code_word"
    (scheme-object scheme-object scheme-object)
    scheme-object))

(define $set-code-long!
  (foreign-procedure "(cs)s_set_code_long"
    (scheme-object scheme-object scheme-object)
    scheme-object))

(define $set-code-quad!
  (foreign-procedure "(cs)s_set_code_quad"
    (scheme-object scheme-object scheme-object)
    scheme-object))

(define $flush-instruction-cache
  (foreign-procedure "(cs)s_flush_instruction_cache"
    ()
    scheme-object))

(define $make-closure
  (foreign-procedure "(cs)s_make_closure"
    (scheme-object scheme-object)
    scheme-object))

(define string->symbol
  (foreign-procedure "(cs)s_intern"
    (scheme-object)
    scheme-object))

(define $intern2
  (foreign-procedure "(cs)s_intern2"
    (scheme-object scheme-object)
    scheme-object))

(define $intern3
  (foreign-procedure "(cs)s_intern3"
    (scheme-object scheme-object scheme-object)
    scheme-object))

(define $intern-gensym
  (foreign-procedure "(cs)s_intern_gensym"
    (scheme-object)
    void))

(define cpu-time
  (foreign-procedure "(cs)cputime"
    ()
    scheme-object))

(define real-time
  (foreign-procedure "(cs)realtime"
    ()
    scheme-object))

(define $fixed-path?
  (foreign-procedure "(cs)fixedpathp"
    (string)
    boolean))

(define getenv
  (let ([getenv (foreign-procedure "(cs)getenv" (string) scheme-object)])
    (lambda (s)
      (unless (string? s) ($oops 'getenv "~s is not a string" s))
      (getenv s))))

(define putenv
  (let ([putenv (foreign-procedure "(cs)putenv" (string string) void)])
    (lambda (s1 s2)
      (unless (string? s1) ($oops 'putenv "~s is not a string" s1))
      (unless (string? s2) ($oops 'putenv "~s is not a string" s2))
      (putenv s1 s2))))

(define decode-float
  (foreign-procedure "(cs)s_decode_float"
    (scheme-object)
    scheme-object))

(define $fx*
  (foreign-procedure "(cs)fxmul" (fixnum fixnum)
    fixnum))

(define $fx/
  (foreign-procedure "(cs)fxdiv" (fixnum fixnum)
    fixnum))

(define $procedure-name
  (lambda (x)
    (unless (procedure? x)
      ($oops '$procedure-name "~s is not a procedure" x))
    ($code-name ($closure-code x))))

(let ()
  (define-syntax frob-proc
    (syntax-rules ()
      [(_ frob make-frob frob-set! elt? elt-msg)
       (let ([elt-error
              (lambda args
                 (do ([args args (cdr args)])
                     ((null? args))
                   (unless (elt? (car args))
                     ($oops 'frob elt-msg (car args)))))])
          (define-syntax frob-clause
            (syntax-rules ()
              ((_ c (... ...))
               (if (and (elt? c) (... ...))
                   (frob c (... ...))
                   (elt-error c (... ...))))))
          (case-lambda
             [() (frob-clause)]
             [(c1) (frob-clause c1)]
             [(c1 c2)
              (frob-clause c1 c2)]
             [(c1 c2 c3)
              (frob-clause c1 c2 c3)]
             [(c1 c2 c3 c4)
              (frob-clause c1 c2 c3 c4)]
             [(c1 c2 c3 c4 c5)
              (frob-clause c1 c2 c3 c4 c5)]
             [(c1 c2 c3 c4 c5 c6)
              (frob-clause c1 c2 c3 c4 c5 c6)]
             [l (let ([s (make-frob (length l))])
                   (do ([ls l (cdr ls)] [i 0 (fx+ i 1)])
                       ((null? ls) s)
                       (let ([c (car ls)])
                          (unless (elt? c) (elt-error c))
                          (frob-set! s i c))))]))]))


  (set! string (frob-proc string make-string string-set! char?
                  "~s is not a character"))
  (set! fxvector (frob-proc fxvector make-fxvector fxvector-set! fixnum?
                  "~s is not a fixnum"))
  (set! bytevector
    (let ([fill? (lambda (k) (and (fixnum? k) (fx<= -128 k 255)))])
      (frob-proc bytevector make-bytevector $bytevector-set! fill?
                    "invalid value ~s")))
)

(define-who (bytevector-truncate! bv n)
  (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
  (unless (and (fixnum? n) (not ($fxu< (bytevector-length bv) n)))
    ($oops who "invalid new length ~s for ~s" n bv))
  (bytevector-truncate! bv n))

(define-who (string-truncate! st n)
  (unless (string? st) ($oops who "~s is not a string" st))
  (unless (and (fixnum? n) (not ($fxu< (string-length st) n)))
    ($oops who "invalid new length ~s for ~s" n st))
  (string-truncate! st n))

(define-who make-string
  (case-lambda
    [(n c)
    ; if this fails, we have to change the test and message below
     (meta-assert (= (constant maximum-string-length) (constant most-positive-fixnum)))
     (unless (and (fixnum? n) (fx>= n 0))
       ($oops who "~s is not a nonnegative fixnum" n))
     (unless (char? c)
       ($oops who "~s is not a character" c))
     (make-string n c)]
    [(n)
    ; if this fails, we have to change the test and message below
     (meta-assert (= (constant maximum-string-length) (constant most-positive-fixnum)))
     (unless (and (fixnum? n) (fx>= n 0))
       ($oops who "~s is not a nonnegative fixnum" n))
     (make-string n)]))

(define make-vector
   (case-lambda
      [(n x)
       (unless (and (fixnum? n) (fx>= n 0))
          ($oops 'make-vector "~s is not a nonnegative fixnum" n))
       (make-vector n x)]
      [(n)
       (unless (and (fixnum? n) (fx>= n 0))
          ($oops 'make-vector "~s is not a nonnegative fixnum" n))
       (make-vector n)]))

(define $make-eqhash-vector
  (case-lambda
    [(n)
     (unless (and (fixnum? n) (fx>= n 0))
       ($oops '$make-eqhash-vector "~s is not a nonnegative fixnum" n))
     ($make-eqhash-vector n)]))

(define-who make-fxvector
  (case-lambda
    [(n x)
    ; if this fails, we have to change the test and message below
     (meta-assert (= (constant maximum-fxvector-length) (constant most-positive-fixnum)))
     (unless (and (fixnum? n) (fx>= n 0))
       ($oops who "~s is not a nonnegative fixnum" n))
     (unless (fixnum? x)
       ($oops who "~s is not a fixnum" x))
     (make-fxvector n x)]
    [(n)
    ; if this fails, we have to change the test and message below
     (meta-assert (= (constant maximum-fxvector-length) (constant most-positive-fixnum)))
     (unless (and (fixnum? n) (fx>= n 0))
       ($oops who "~s is not a nonnegative fixnum" n))
     (make-fxvector n)]))

(define string-fill!
   (lambda (s c)
      (unless (string? s)
         ($oops 'string-fill! "~s is not a string" s))
      (unless (char? c)
         ($oops 'string-fill! "~s is not a character" c))
      (string-fill! s c)))

(define fxvector-fill!
   (lambda (v n)
      (unless (fxvector? v)
         ($oops 'fxvector-fill! "~s is not an fxvector" v))
      (unless (fixnum? n)
         ($oops 'fxvector-fill! "~s is not a fixnum" n))
      (fxvector-fill! v n)))

;;; multiple return values stuff

(define values ($hand-coded 'values-procedure))

(define call-with-values
  (lambda (producer consumer)
    (unless (procedure? producer)
      ($oops 'call-with-values "~s is not a procedure" producer))
    (unless (procedure? consumer)
      ($oops 'call-with-values "~s is not a procedure" consumer))
    (call-with-values producer consumer)))

(define call/1cc
  (lambda (p)
    (unless (procedure? p)
      ($oops 'call/1cc "~s is not a procedure" p))
    (#3%call/1cc p)))

(define call/cc
  (lambda (p)
    (unless (procedure? p)
      ($oops 'call/cc "~s is not a procedure" p))
    (#3%call/cc p)))

(define-who call-with-current-continuation
  (lambda (p)
    (unless (procedure? p)
      ($oops who "~s is not a procedure" p))
    (#3%call/cc p)))

(define $code? (lambda (x) ($code? x)))

(define $system-code? (lambda (x) ($system-code? x)))

(define $system-procedure?
   (lambda (x)
      (and (procedure? x) ($system-code? ($closure-code x)))))

(define-who $make-code-object
  (foreign-procedure "(cs)s_make_code"
     (iptr iptr ptr iptr ptr ptr)
     ptr))

(define-who $code-name
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-name x)))

(define-who $code-free-count
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-free-count x)))

(define-who $code-info
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-info x)))

(define-who $code-pinfo*
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-pinfo* x)))

(define $object-address ; not safe and can't be
  (lambda (x offset)
    ($object-address x offset)))

(define $address->object ; also not safe and can't be
  (lambda (x offset)
    ;; could do address-in-heap? checking here if we passed a who.
    ($address->object x offset)))

(define foreign-callable-entry-point
  (lambda (x)
    (unless ($code? x)
      ($oops 'foreign-callable-entry-point "~s is not a code object" x))
    ($object-address x (constant code-data-disp))))

(define-who foreign-callable-code-object
  (lambda (x)
    (unless (and (integer? x) (exact? x) ($address-in-heap? x))
      ($oops who "~s is not an entry point" x))
    ($address->object x (constant code-data-disp))))

(define $closure-code
   (lambda (x)
      (unless (procedure? x)
         ($oops '$closure-code "~s is not a closure" x))
      ($closure-code x)))

(define $closure-length
   (lambda (x)
      (unless (procedure? x)
         ($oops '$closure-length "~s is not a closure" x))
      ($code-free-count ($closure-code x))))

(define $closure-ref
   (lambda (x i)
      (unless (procedure? x)
         ($oops '$closure-ref "~s is not a closure" x))
      (unless (and (fixnum? i) (fx< -1 i ($closure-length x)))
         ($oops '$closure-ref "invalid index ~s" i))
      ($closure-ref x i)))

(define $continuation? (lambda (x) ($continuation? x)))

(define $continuation-stack-length
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-stack-length "~s is not a continuation" x))
      ($continuation-stack-length x)))

(define $continuation-stack-clength
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-stack-clength "~s is not a continuation" x))
      ($continuation-stack-clength x)))

(define $continuation-stack-ref
   (lambda (x i)
      (unless ($continuation? x)
         ($oops '$continuation-stack-ref "~s is not a continuation" x))
      (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x)))
         ($oops '$continuation-stack-ref "invalid index ~s" i))
      ($continuation-stack-ref x i)))

(define $continuation-link
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-link "~s is not a continuation" x))
      ($continuation-link x)))

(define $continuation-winders
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-winders "~s is not a continuation" x))
      ($continuation-winders x)))

(define $continuation-return-code
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-return-code "~s is not a continuation" x))
      ($continuation-return-code x)))

(define $continuation-return-livemask
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-return-livemask "~s is not a continuation" x))
      ($continuation-return-livemask x)))

(define $continuation-return-offset
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-return-offset "~s is not a continuation" x))
      ($continuation-return-offset x)))

(define void
   (lambda ()
      (void)))

(define eof-object (lambda () (eof-object)))

(define $unbound-object
   (lambda ()
      ($unbound-object)))

(define $unbound-object?
   (lambda (x)
      ($unbound-object? x)))

(define $set-timer
   (lambda (ticks)
      (unless (and (fixnum? ticks) (fx> ticks 0))
         ($oops '$set-timer "~s is not a positive fixnum" ticks))
      ($set-timer ticks)))

(define $fx+?
   (lambda (x y)
      ($fx+? x y)))

(define $fx-?
   (lambda (x y)
      ($fx-? x y)))

(define $bigpositive?
   (lambda (x)
      (unless (bignum? x)
         ($oops '$bigpositive "~s is not a bignum" x))
      ($bigpositive? x)))

(define $string-ref-check? (lambda (s i) ($string-ref-check? s i)))

(define $vector-ref-check? (lambda (v i) ($vector-ref-check? v i)))

(define $fxvector-ref-check? (lambda (v i) ($fxvector-ref-check? v i)))

(define $ratio-numerator
   (lambda (q)
      (if (ratnum? q)
          ($ratio-numerator q)
          ($oops '$ratio-numerator "~s is not a ratnum" q))))

(define $ratio-denominator
   (lambda (q)
      (if (ratnum? q)
          ($ratio-denominator q)
          ($oops '$ratio-denominator "~s is not a ratnum" q))))

(let ()
  (include "io-types.ss")
  (set-who! $make-binary-output-port
    (rec $make-binary-output-port
      (case-lambda
        [(name handler buffer) ($make-binary-output-port name handler buffer #f)]
        [(name handler buffer info)
         (unless (string? name) ($oops who "invalid name ~s" name))
         (unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
         (unless (bytevector? buffer) ($oops who "invalid buffer ~s" buffer))
         (#3%$make-binary-output-port name handler buffer info)])))

  (set-who! $make-binary-input-port
    (rec $make-binary-input-port
      (case-lambda
        [(name handler buffer) ($make-binary-input-port name handler buffer #f)]
        [(name handler buffer info)
         (unless (string? name) ($oops who "invalid name ~s" name))
         (unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
         (unless (bytevector? buffer) ($oops who "invalid buffer ~s" buffer))
         (#3%$make-binary-input-port name handler buffer info)])))

  (set-who! $make-binary-input/output-port
    (rec $make-binary-input/output-port
      (case-lambda
        [(name handler ibuffer obuffer) ($make-binary-input/output-port name handler ibuffer obuffer #f)]
        [(name handler ibuffer obuffer info)
         (unless (string? name) ($oops who "invalid name ~s" name))
         (unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
         (unless (bytevector? ibuffer) ($oops who "invalid input buffer ~s" ibuffer))
         (unless (bytevector? obuffer) ($oops who "invalid output buffer ~s" obuffer))
         (#3%$make-binary-input/output-port name handler ibuffer obuffer info)])))

  (set-who! $make-textual-output-port
    (rec $make-textual-output-port
      (case-lambda
        [(name handler buffer) ($make-textual-output-port name handler buffer #f)]
        [(name handler buffer info)
         (unless (string? name) ($oops who "invalid name ~s" name))
         (unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
         (unless (string? buffer)
           ($oops who "invalid buffer ~s" buffer))
         (#3%$make-textual-output-port name handler buffer info)])))

  (set-who! $make-textual-input-port
    (rec $make-textual-input-port
      (case-lambda
        [(name handler buffer) ($make-textual-input-port name handler buffer #f)]
        [(name handler buffer info)
         (unless (string? name) ($oops who "invalid name ~s" name))
         (unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
         (unless (string? buffer) ($oops who "invalid buffer ~s" buffer))
         (#3%$make-textual-input-port name handler buffer info)])))

  (set-who! $make-textual-input/output-port
    (rec $make-textual-input/output-port
      (case-lambda
        [(name handler ibuffer obuffer) ($make-textual-input/output-port name handler ibuffer obuffer #f)]
        [(name handler ibuffer obuffer info)
         (unless (string? name) ($oops who "invalid name ~s" name))
         (unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
         (unless (string? ibuffer) ($oops who "invalid input buffer ~s" ibuffer))
         (unless (string? obuffer) ($oops who "invalid output buffer ~s" obuffer))
         (#3%$make-textual-input/output-port name handler ibuffer obuffer info)]))))

(define-who $port-flags-set?
  (lambda (p mask)
    (unless (port? p) ($oops who "~s is not a port" p))
    (unless (fixnum? mask) ($oops who "invalid mask ~s" mask))
    ($port-flags-set? p mask)))

(define-who $set-port-flags!
  (lambda (p mask)
    (unless (port? p) ($oops who "~s is not a port" p))
    (unless (fixnum? mask) ($oops who "invalid mask ~s" mask))
    ($set-port-flags! p mask)))

(define-who $reset-port-flags!
  (lambda (p mask)
    (unless (port? p) ($oops who "~s is not a port" p))
    (unless (fixnum? mask) ($oops who "invalid mask ~s" mask))
    ($reset-port-flags! p mask)))

(define port-closed?
   (lambda (p)
      (if (port? p)
          (port-closed? p)
          ($oops 'port-closed? "~s is not a port" p))))

(define mark-port-closed!
   (lambda (p)
      (if (port? p)
          (mark-port-closed! p)
          ($oops 'mark-port-closed! "~s is not a port" p))))

(define-who $port-handler
  (lambda (p)
    (unless (port? p)
      ($oops who "~s is not a port" p))
    ($port-handler p)))

(define-who set-port-bol!
  (lambda (p x)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (set-port-bol! p x)))

(define-who set-port-eof!
  (lambda (p x)
    (unless (input-port? p) ($oops who "~s is not an input port" p))
    (set-port-eof! p x)))

(define-who $port-info
  (lambda (p)
    (unless (port? p) ($oops who "~s is not a port" p))
    ($port-info p)))

(define-who $set-port-info!
  (lambda (p x)
    (unless (port? p) ($oops who "~s is not a port" p))
    ($set-port-info! p x)))

(define-who port-name
  (lambda (p)
    (unless (port? p) ($oops who "~s is not a port" p))
    (port-name p)))

(define-who set-port-name!
  (lambda (p x)
    (unless (port? p) ($oops who "~s is not a port" p))
    (set-port-name! p x)))

(let ()
 ; defines port-input-index, port-output-index, port-input-size, port-output-size, port-input-buffer, and port-output-buffer
  (define-syntax get/set
    (lambda (x)
      (syntax-case x ()
        [(_ direction what bpred? tpred?)
         (with-syntax ([port-dir-x (construct-name #'what "port-" #'direction "-" #'what)]
                       [set-port-dir-x! (construct-name #'what "set-port-" #'direction "-" #'what "!")]
                       [textual-port-dir-x (construct-name #'what "textual-port-" #'direction "-" #'what)]
                       [set-textual-port-dir-x! (construct-name #'what "set-textual-port-" #'direction "-" #'what "!")]
                       [binary-port-dir-x (construct-name #'what "binary-port-" #'direction "-" #'what)]
                       [set-binary-port-dir-x! (construct-name #'what "set-binary-port-" #'direction "-" #'what "!")]
                       [dir-port? (construct-name #'direction #'direction "-port?")])
           #`(begin
               (set-who! port-dir-x
                 (lambda (p)
                   (cond
                     [(and (dir-port? p) (textual-port? p)) (textual-port-dir-x p)]
                     [(and (dir-port? p) (binary-port? p)) (binary-port-dir-x p)]
                     [else ($oops who #,(format "~~s is not an ~a port" (datum direction)) p)])))
               (set-who! set-port-dir-x!
                 (lambda (p x)
                   (cond
                     [(and (dir-port? p) (textual-port? p))
                      (unless (tpred? p x) ($oops who #,(format "invalid ~a ~~s" (datum what)) x))
                      (set-textual-port-dir-x! p x)]
                     [(and (dir-port? p) (binary-port? p))
                      (unless (bpred? p x) ($oops who #,(format "invalid ~a ~~s" (datum what)) x))
                      (set-binary-port-dir-x! p x)]
                     [else ($oops who #,(format "~~s is not an ~a port" (datum direction)) p)])))))])))

  (get/set input buffer (lambda (p x) (bytevector? x)) (lambda (p x) (string? x)))
  (get/set input index
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (binary-port-input-size p))))
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (textual-port-input-size p)))))
  (get/set input size
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-input-buffer p)))))
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (string-length (textual-port-input-buffer p))))))
  (get/set output buffer (lambda (p x) (bytevector? x)) (lambda (p x) (string? x)))
  (get/set output index
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (binary-port-output-size p))))
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (textual-port-output-size p)))))
  (get/set output size
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-output-buffer p)))))
    (lambda (p n) (and (fixnum? n) (fx<= 0 n (string-length (textual-port-output-buffer p)))))))

(define-who port-input-count
  (lambda (p)
    (cond
      [(and (input-port? p) (textual-port? p))
       (textual-port-input-count p)]
      [(and (input-port? p) (binary-port? p))
       (binary-port-input-count p)]
      [else ($oops who "~s is not an input port" p)])))

(define-who port-output-count
  (lambda (p)
    (cond
      [(and (output-port? p) (textual-port? p))
       (textual-port-output-count p)]
      [(and (output-port? p) (binary-port? p))
       (binary-port-output-count p)]
      [else ($oops who "~s is not an output port" p)])))

(define-who textual-port-input-buffer
  (lambda (p)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (textual-port-input-buffer p)))

(define-who set-textual-port-input-buffer!
  (lambda (p s)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (unless (string? s) ($oops who "~s is not a string" s))
    (set-textual-port-input-buffer! p s)))

(define-who textual-port-input-index
  (lambda (p)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (textual-port-input-index p)))

(define-who set-textual-port-input-index!
  (lambda (p n)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (unless (and (fixnum? n) (fx<= 0 n (textual-port-input-size p)))
      ($oops who "~s is not a valid index for ~s" n p))
    (set-textual-port-input-index! p n)))

(define-who textual-port-input-size
  (lambda (p)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (textual-port-input-size p)))

(define-who set-textual-port-input-size!
  (lambda (p n)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (unless (and (fixnum? n) (fx<= 0 n (string-length (textual-port-input-buffer p))))
       ($oops who "~s is not a valid size for ~s" n p))
    (set-textual-port-input-size! p n)))

(define-who textual-port-output-buffer
  (lambda (p)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (textual-port-output-buffer p)))

(define-who set-textual-port-output-buffer!
  (lambda (p s)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (unless (string? s) ($oops who "~s is not a string" s))
    (set-textual-port-output-buffer! p s)))

(define-who textual-port-output-index
  (lambda (p)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (textual-port-output-index p)))

(define-who set-textual-port-output-index!
  (lambda (p n)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (unless (and (fixnum? n) (fx<= 0 n (textual-port-output-size p)))
       ($oops who "~s is not a valid index for ~s" n p))
    (set-textual-port-output-index! p n)))

(define-who textual-port-output-size
  (lambda (p)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (textual-port-output-size p)))

(define-who set-textual-port-output-size!
  (lambda (p n)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (unless (and (fixnum? n) (fx<= 0 n (string-length (textual-port-output-buffer p))))
       ($oops who "~s is not a valid size for ~s" n p))
    (set-textual-port-output-size! p n)))

(define-who binary-port-input-buffer
  (lambda (p)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (binary-port-input-buffer p)))

(define-who set-binary-port-input-buffer!
  (lambda (p bv)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
    (set-binary-port-input-buffer! p bv)))

(define-who binary-port-input-index
  (lambda (p)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (binary-port-input-index p)))

(define-who set-binary-port-input-index!
  (lambda (p n)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (unless (and (fixnum? n) (fx<= 0 n (binary-port-input-size p)))
      ($oops who "~s is not a valid index for ~s" n p))
    (set-binary-port-input-index! p n)))

(define-who binary-port-input-size
  (lambda (p)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (binary-port-input-size p)))

(define-who set-binary-port-input-size!
  (lambda (p n)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (unless (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-input-buffer p))))
      ($oops who "~s is not a valid size for ~s" n p))
    (set-binary-port-input-size! p n)))

(define-who binary-port-input-count
  (lambda (p)
    (unless (and (input-port? p) (binary-port? p))
      ($oops who "~s is not a binary input port" p))
    (binary-port-input-count p)))

(define-who binary-port-output-count
  (lambda (p)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (binary-port-output-count p)))

(define-who textual-port-input-count
  (lambda (p)
    (unless (and (input-port? p) (textual-port? p))
      ($oops who "~s is not a textual input port" p))
    (textual-port-input-count p)))

(define-who textual-port-output-count
  (lambda (p)
    (unless (and (output-port? p) (textual-port? p))
      ($oops who "~s is not a textual output port" p))
    (textual-port-output-count p)))

(define-who port-input-empty?
  (lambda (p)
    (unless (input-port? p) ($oops who "~s is not an input port" p))
    (#3%port-input-empty? p)))

(define-who port-output-full?
  (lambda (p)
    (unless (output-port? p) ($oops who "~s is not an output port" p))
    (#3%port-output-full? p)))

(define-who binary-port-output-buffer
  (lambda (p)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (binary-port-output-buffer p)))

(define-who set-binary-port-output-buffer!
  (lambda (p bv)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
    (set-binary-port-output-buffer! p bv)))

(define-who binary-port-output-index
  (lambda (p)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (binary-port-output-index p)))

(define-who set-binary-port-output-index!
  (lambda (p n)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (unless (and (fixnum? n) (fx<= 0 n (binary-port-output-size p)))
      ($oops who "~s is not a valid index for ~s" n p))
    (set-binary-port-output-index! p n)))

(define-who binary-port-output-size
  (lambda (p)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (binary-port-output-size p)))

(define-who set-binary-port-output-size!
  (lambda (p n)
    (unless (and (output-port? p) (binary-port? p))
      ($oops who "~s is not a binary output port" p))
    (unless (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-output-buffer p))))
      ($oops who "~s is not a valid size for ~s" n p))
    (set-binary-port-output-size! p n)))

(define $symbol-name
   (lambda (s)
      (if (symbol? s)
          ($symbol-name s)
          ($oops '$symbol-name "~s is not a symbol" s))))

(define $set-symbol-name!
   (lambda (s l)
      (if (symbol? s)
          ($set-symbol-name! s l)
          ($oops '$set-symbol-name! "~s is not a symbol" s))))

(define $symbol-property-list
   (lambda (s)
      (if (symbol? s)
          ($symbol-property-list s)
          ($oops '$symbol-property-list "~s is not a symbol" s))))

(define $set-symbol-property-list!
   (lambda (s l)
      (if (symbol? s)
          ($set-symbol-property-list! s l)
          ($oops '$set-symbol-property-list! "~s is not a symbol" s))))

(define $system-property-list
   (lambda (s)
      (if (symbol? s)
          ($system-property-list s)
          ($oops '$system-property-list "~s is not a symbol" s))))

(define $set-system-property-list!
   (lambda (s l)
      (if (symbol? s)
          ($set-system-property-list! s l)
          ($oops '$set-system-property-list! "~s is not a symbol" s))))

(define-who $symbol-hash
  (lambda (x)
    (unless (symbol? x) ($oops who "~s is not a symbol" x))
    (#3%$symbol-hash x)))

(define-who $set-symbol-hash!
  (lambda (x y)
    (unless (symbol? x) ($oops who "~s is not a symbol" x))
    (#3%$set-symbol-hash! x y)))

(define symbol->string
  (lambda (s)
    (unless (symbol? s)
      ($oops 'symbol->string "~s is not a symbol" s))
    (#3%symbol->string s)))

(define $top-level-value
  (lambda (s)
    (#2%$top-level-value s)))

(define $set-top-level-value!
  (lambda (s v)
    (if (symbol? s)
        ($set-top-level-value! s v)
        ($oops '$set-top-level-value! "~s is not a symbol" s))))

(define $top-level-bound?
  (lambda (s)
    (if (symbol? s)
        ($top-level-bound? s)
        ($oops '$top-level-bound? "~s is not a symbol" s))))

(define-who $bignum-length
  (lambda (n)
    (unless (bignum? n) ($oops who "~s is not a bignum" n))
    (#3%$bignum-length n)))

(define string-length
   (lambda (s)
      (#2%string-length s)))

(define string-ref
   (lambda (s i)
      (#2%string-ref s i)))

(define string-set!
   ; could use #2%string-set!
   (lambda (v i x)
      (#2%string-set! v i x)))

(define char->integer
   (lambda (x)
      (#2%char->integer x)))

(define-who integer->char
  (lambda (n)
    (if (and (fixnum? n)
             (or ($fxu< n #xD800)
                 (fx<= #xE000 n #x10FFFF)))
        (#3%integer->char n)
        ($oops 'integer->char "~s is not a valid unicode scalar value" n))))

(define vector-length
   (lambda (v)
      (#2%vector-length v)))

(define vector-ref
   (lambda (v i)
      (#2%vector-ref v i)))

(define vector-set!
   (lambda (v i x)
      (#2%vector-set! v i x)))

(define vector-set-fixnum!
  (lambda (v i x)
    (#2%vector-set-fixnum! v i x)))

(define fxvector-length
   (lambda (v)
      (#2%fxvector-length v)))

(define fxvector-ref
   (lambda (v i)
      (#2%fxvector-ref v i)))

(define fxvector-set!
   (lambda (v i x)
      (#2%fxvector-set! v i x)))

(define cons (lambda (x y) (cons x y)))

(define car
   (lambda (p)
      (#2%car p)))

(define cdr
   (lambda (p)
      (#2%cdr p)))

(define set-car!
   (lambda (p v)
      (#2%set-car! p v)))

(define set-cdr!
   (lambda (p v)
      (#2%set-cdr! p v)))

(define box (lambda (x) (box x)))

(define unbox
   (lambda (b)
      (if (box? b)
          (unbox b)
          ($oops 'unbox "~s is not a box" b))))

(define set-box!
   (lambda (b v)
      (if (box? b)
          (set-box! b v)
          ($oops 'set-box! "~s is not a box" b))))

(define pair? (lambda (x) (pair? x)))

(define box? (lambda (x) (box? x)))

(define symbol? (lambda (x) (symbol? x)))

(define gensym? (lambda (x) (gensym? x)))

(define fixnum? (lambda (x) (fixnum? x)))

(define bignum? (lambda (x) (bignum? x)))

(define ratnum? (lambda (x) (ratnum? x)))

(define string? (lambda (x) (string? x)))

(define vector? (lambda (x) (vector? x)))

(define fxvector? (lambda (x) (fxvector? x)))

(define procedure? (lambda (x) (procedure? x)))

(define flonum? (lambda (x) (flonum? x)))

(define char? (lambda (x) (char? x)))

(define eof-object? (lambda (x) (eof-object? x)))

(define bwp-object? (lambda (x) (bwp-object? x)))

(define port? (lambda (p) (port? p)))

(define input-port? (lambda (p) (input-port? p)))

(define output-port? (lambda (p) (output-port? p)))

(define-who port-eof?
  (lambda (input-port)
    (unless (input-port? input-port)
      ($oops who "~s is not an input port" input-port))
    (port-eof? input-port)))

(define-who binary-port?
  (lambda (p)
    (unless (port? p) ($oops who "~s is not a port" p))
    (#3%binary-port? p)))

(define-who textual-port?
  (lambda (p)
    (unless (port? p) ($oops who "~s is not a port" p))
    (#3%textual-port? p)))

(define eq?
   (lambda (x y)
      (eq? x y)))

(define char-
   (lambda (x y)
      (unless (char? x)
         ($oops 'char- "~s is not a character" x))
      (unless (char? y)
         ($oops 'char- "~s is not a character" y))
      (char- x y)))

(define most-positive-fixnum (lambda () (#2%most-positive-fixnum)))
(define most-negative-fixnum (lambda () (#2%most-negative-fixnum)))
(define greatest-fixnum (lambda () (#2%greatest-fixnum)))
(define least-fixnum (lambda () (#2%least-fixnum)))
(define fixnum-width (lambda () (#2%fixnum-width)))

(define-who (get-u8 p)
  (#2%get-u8 p))

(define-who (get-char p)
  (#2%get-char p))

(define-who (lookahead-u8 p)
  (#2%lookahead-u8 p))

(define-who (lookahead-char p)
  (#2%lookahead-char p))

(define-who unget-u8
  (lambda (binary-input-port octet)
    (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
      ($oops who "~s is not a binary input port" binary-input-port))
    (unless (or (and (fixnum? octet) (fx<= 0 octet 255)) (eof-object? octet))
      ($oops who "~s is not an octet or the eof object" octet))
    (#3%unget-u8 binary-input-port octet)))

(define-who unget-char
  (lambda (textual-input-port char)
    (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
      ($oops who "~s is not a textual input port" textual-input-port))
    (unless (or (char? char) (eof-object? char))
      ($oops who "~s is not a character or the eof object" char))
    (#3%unget-char textual-input-port char)))

(define-who (put-u8 binary-output-port octet)
  (unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
    ($oops who "~s is not a binary output port" binary-output-port))
  (unless (and (fixnum? octet) (fx<= 0 octet 255))
    ($oops who "~s is not an octet" octet))
  (#3%put-u8 binary-output-port octet))

(define-who (put-char textual-output-port char)
  (unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
    ($oops who "~s is not a textual output port" textual-output-port))
  (unless (char? char) ($oops who "~s is not a char" char))
  (#3%put-char textual-output-port char))

(define peek-char
  (case-lambda
    [(p) (#2%peek-char p)]
    [() (#3%peek-char)]))

(define read-char
  (case-lambda
    [(p) (#2%read-char p)]
    [() (#3%read-char)]))

(define unread-char
  (case-lambda
    [(x p)
     (unless (and (input-port? p) (textual-port? p))
       ($oops 'unread-char "~s is not a textual input port" p))
     (unless (char? x)
       ($oops 'unread-char "~s is not a character" x))
     (unread-char x p)]
    [(x)
     (unless (char? x)
       ($oops 'unread-char "~s is not a character" x))
     (unread-char x)]))

(define write-char
  (case-lambda
    [(x p)
     (unless (and (output-port? p) (textual-port? p))
       ($oops 'write-char "~s is not a textual output port" p))
     (unless (char? x)
       ($oops 'write-char "~s is not a character" x))
     (write-char x p)]
    [(x)
     (unless (char? x)
       ($oops 'write-char "~s is not a character" x))
     (write-char x)]))

(define newline
  (case-lambda
    [(p)
     (unless (and (output-port? p) (textual-port? p))
       ($oops 'newline "~s is not a textual output port" p))
     (newline p)]
    [() (newline)]))

(define display-string
  (case-lambda
    [(s p)
     (unless (and (output-port? p) (textual-port? p))
       ($oops 'display-string "~s is not a textual output port" p))
     (unless (string? s)
       ($oops 'display-string "~s is not a character" s))
     (display-string s p)]
    [(s)
     (unless (string? s)
       ($oops 'display-string "~s is not a character" s))
     (display-string s)]))

(define $immediate? (lambda (x) ($immediate? x)))
(define $inexactnum? (lambda (x) ($inexactnum? x)))

(define $inexactnum-real-part
   (lambda (x)
      (unless ($inexactnum? x)
         ($oops '$inexactnum-real-part "~s is not an inexactnum" x))
      ($inexactnum-real-part x)))

(define $inexactnum-imag-part
   (lambda (x)
      (unless ($inexactnum? x)
         ($oops '$inexactnum-imag-part "~s is not an inexactnum" x))
      ($inexactnum-imag-part x)))

(define $exactnum? (lambda (x) ($exactnum? x)))

(define $exactnum-real-part
   (lambda (x)
      (unless ($exactnum? x)
         ($oops '$exactnum-real-part "~s is not an exactnum" x))
      ($exactnum-real-part x)))

(define $exactnum-imag-part
   (lambda (x)
      (unless ($exactnum? x)
         ($oops '$exactnum-imag-part "~s is not an exactnum" x))
      ($exactnum-imag-part x)))

(define $make-exactnum
   (lambda (x y)
      (unless (or (fixnum? x) (bignum? x) (ratnum? x))
         ($oops '$make-exactnum "~s is not an exact real number" x))
      (unless (or (and (fixnum? y) (not (fx= y 0))) (bignum? y) (ratnum? y))
         ($oops '$make-exactnum "~s is not an nonzero exact real number" y))
      ($make-exactnum x y)))

(define $rtd-counts? (lambda (x) ($rtd-counts? x)))

(define getprop
   (case-lambda
      [(s p)
       (if (symbol? s)
           (getprop s p)
           ($oops 'getprop "~s is not a symbol" s))]
      [(s p d)
       (if (symbol? s)
           (getprop s p d)
           ($oops 'getprop "~s is not a symbol" s))]))

(define $current-stack-link
  (case-lambda
    [() ($current-stack-link)]
    [(k)
     (unless (or ($continuation? k) (zero? k))
       ($oops '$current-stack-link "invalid argument ~s" k))
     ($current-stack-link k)]))

(define $current-winders
  (case-lambda
    [() ($current-winders)]
    [(w)
     (unless (and (list? w) (andmap (lambda (x) (winder? x)) w))
       ($oops '$current-winders "malformed winders ~s" w))
     ($current-winders w)]))

(define lock-object
  (foreign-procedure "(cs)lock_object" (scheme-object) void))
(define unlock-object
  (foreign-procedure "(cs)unlock_object" (scheme-object) void))
(define locked-object?
  (foreign-procedure "(cs)locked_objectp" (scheme-object) boolean))

(define-who $install-guardian
  (lambda (obj rep tconc)
    (unless (and (pair? tconc) (pair? (car tconc)) (pair? (cdr tconc))) ($oops who "~s is not a tconc" tconc))
    (#3%$install-guardian obj rep tconc)))

(define make-guardian (lambda () (#2%make-guardian)))

(define $address-in-heap?
  (foreign-procedure "(cs)s_addr_in_heap" (uptr) boolean))

(define $object-in-heap?
  (foreign-procedure "(cs)s_ptr_in_heap" (ptr) boolean))

(define $event (lambda () ($event)))

(define $tc (lambda () ($tc)))
(define $thread-list (lambda () ($thread-list)))

(define $tc-field
  (let ()
    (define bogus
      (lambda (fld)
        ($oops '$tc-field "invalid tc field ~s" fld)))
    (define-syntax alpha
      (with-syntax ([(param ...)
                     (fold-left
                       (lambda (ls field)
                         (apply
                           (lambda (name type disp len)
                             (if (eq? type 'ptr)
                                 (cons (datum->syntax #'* name) ls)
                                 ls))
                           field))
                       '() (getprop 'tc '*fields* '()))])
        (lambda (x)
          #'(case-lambda
              [(fld tc)
               (case fld
                 [(param) ($tc-field 'param tc)]
                 ...
                 [else (bogus fld)])]
              [(fld tc v)
               (case fld
                 [(param) ($tc-field 'param tc v)]
                 ...
                 [else (bogus fld)])]))))
    alpha))

(define virtual-register-count (lambda () (#2%virtual-register-count)))
(define virtual-register (lambda (idx) (#2%virtual-register idx)))
(define set-virtual-register! (lambda (idx val) (#2%set-virtual-register! idx val)))

(define thread? (lambda (x) (thread? x)))
(define $thread-tc
  (lambda (thread)
    (unless (thread? thread)
      ($oops '$thread-tc "~s is not a thread" thread))
    ($thread-tc thread)))

(when-feature pthreads

(define $raw-collect-cond (lambda () ($raw-collect-cond)))
(define $raw-tc-mutex (lambda () ($raw-tc-mutex)))
(define fork-thread)
(define make-mutex)
(define mutex?)
(define mutex-acquire)
(define mutex-release)
(define make-condition)
(define thread-condition?)
(define condition-wait)
(define condition-signal)
(define condition-broadcast)
(define $tc-mutex)
(define $collect-cond)
(let ()
; scheme-object's below are mutex and condition addresses, which are
; assumed to be at least ptr aligned and therefore look like fixnums
(define ft (foreign-procedure "(cs)fork_thread" (scheme-object)
              scheme-object))
(define mm (foreign-procedure "(cs)make_mutex" () scheme-object))
(define ma (foreign-procedure "(cs)mutex_acquire" (scheme-object) void))
(define ma-nb (foreign-procedure "(cs)mutex_acquire_noblock" (scheme-object)
                  scheme-object))
(define mr (foreign-procedure "(cs)mutex_release" (scheme-object) void))
(define mc (foreign-procedure "(cs)make_condition" () scheme-object))
(define cw (foreign-procedure "(cs)condition_wait" (scheme-object scheme-object) void))
(define cb (foreign-procedure "(cs)condition_broadcast" (scheme-object) void))
(define cs (foreign-procedure "(cs)condition_signal" (scheme-object) void))

(define-record-type (condition $make-condition $condition?)
  (fields (immutable addr $condition-addr))
  (nongenerative)
  (sealed #t))

(define-record-type (mutex $make-mutex $mutex?)
  (fields (immutable addr $mutex-addr))
  (nongenerative)
  (sealed #t))

(set! fork-thread
  (lambda (t)
    (unless (procedure? t)
      ($oops 'fork-thread "~s is not a procedure" t))
    (ft (lambda ()
          (call/cc
            (lambda (k)
              (parameterize ([abort-handler
                              (case-lambda [() (k -1)] [(x) (k x)])]
                             [exit-handler
                              (case-lambda [() (k (void))] [(x . args) (k x)])]
                             [reset-handler (lambda () (k (void)))])
                (t)
                (void))))))))

(set! make-mutex
  (lambda ()
    ($make-mutex (mm))))

(set! mutex?
  (lambda (x)
    ($mutex? x)))

(set! mutex-acquire
  (case-lambda
    [(m) (mutex-acquire m #t)]
    [(m block?)
     (unless (mutex? m)
       ($oops 'mutex-acquire "~s is not a mutex" m))
     ((if block? ma ma-nb) ($mutex-addr m))]))

(set! mutex-release
  (lambda (m)
    (unless (mutex? m)
      ($oops 'mutex-release "~s is not a mutex" m))
    (mr ($mutex-addr m))))

(set! make-condition
  (lambda ()
    ($make-condition (mc))))

(set! thread-condition?
  (lambda (x)
    ($condition? x)))

(set! condition-wait
  (lambda (c m)
    (unless (thread-condition? c)
      ($oops 'condition-wait "~s is not a condition" c))
    (unless (mutex? m)
      ($oops 'condition-wait "~s is not a mutex" m))
    (cw ($condition-addr c) ($mutex-addr m))))

(set! condition-broadcast
  (lambda (c)
    (unless (thread-condition? c)
      ($oops 'condition-broadcast "~s is not a condition" c))
    (cb ($condition-addr c))))

(set! condition-signal
  (lambda (c)
    (unless (thread-condition? c)
      ($oops 'condition-signal "~s is not a condition" c))
    (cs ($condition-addr c))))

(set! $tc-mutex ($make-mutex ($raw-tc-mutex)))
(set! $collect-cond ($make-condition ($raw-collect-cond)))
))

(let ()
  (define-syntax define-tc-parameter
    (lambda (x)
      (syntax-case x ()
        [(_ name pred type init)
         #'(begin (define-tc-parameter name pred type) (name init))]
        [(_ name pred type)
         (with-syntax ([msg (format "~~s is not ~a" (datum type))])
           #'(set! name
               (case-lambda
                 [() (name)]
                 [(x)
                  (unless (pred x) ($oops 'name msg x))
                  (name x)])))])))
  (define-tc-parameter current-input-port (lambda (x) (and (input-port? x) (textual-port? x))) "a textual input port")
  (define-tc-parameter current-output-port (lambda (x) (and (output-port? x) (textual-port? x))) "a textual output port")
  (define-tc-parameter current-error-port (lambda (x) (and (output-port? x) (textual-port? x))) "a textual output port")
  (define-tc-parameter $block-counter (lambda (x) (and (fixnum? x) (fx<= x 0))) "a nonpositive fixnum" 0)
  (define-tc-parameter $sfd (lambda (x) (or (eq? x #f) (source-file-descriptor? x))) "a source-file descriptor or #f" #f)
  (define-tc-parameter $target-machine symbol? "a symbol")
  (define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0)
  (define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f)
  (define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "valid subset mode" #f)
)

(define-who compile-profile
  ; this wrapper is used to filter #t => source
  (case-lambda
    [() ($compile-profile)]
    [(x)
     ($compile-profile
       (case x
         [(#f source block) x]
         [(#t) 'source]
         [else ($oops who "invalid mode ~s [must be #f, #t, source, or block]" x)]))]))

(let ()
  (define-syntax define-boolean-tc-parameter
    (lambda (x)
      (syntax-case x ()
        [(_ name init)
         #'(begin
             (set! name
               (case-lambda
                 [() (name)]
                 [(x) (name (and x #t))]))
             (name init))])))
  (define-boolean-tc-parameter generate-inspector-information #t)
  (define-boolean-tc-parameter generate-profile-forms #t)
  (define-boolean-tc-parameter $suppress-primitive-inlining #f)
)

(define $make-tlc
  (lambda (ht keyval next)
    (unless (eq-hashtable? ht)
      ($oops '$make-tlc "~s is not an eq hashtable" ht))
    (unless (or ($tlc? next) (fixnum? next))
      ($oops '$make-tlc "invalid next argument ~s" next))
    (unless (pair? keyval)
      ($oops '$make-tlc "invalid keyval argument ~s" keyval))
    (#3%$make-tlc ht keyval next)))

(define $tlc? (lambda (x) (#3%$tlc? x)))

(let ()
  (define-syntax define-tlc-parameter
    (syntax-rules ()
      [(_ name)
       (set! name
         (lambda (tlc)
           (unless ($tlc? tlc) ($oops 'name "~s is not a tlc" tlc))
           (#3%name tlc)))]
      [(_ name name!)
       (begin
         (define-tlc-parameter name)
         (set! name!
           (lambda (tlc x)
             (unless ($tlc? tlc) ($oops 'name "~s is not a tlc" tlc))
             (#3%name! tlc x))))]))
  (define-tlc-parameter $tlc-keyval)
  (define-tlc-parameter $tlc-ht)
  (define-tlc-parameter $tlc-next $set-tlc-next!)
)

(define ($fxaddress x) (#3%$fxaddress x))

(define $logand
  (foreign-procedure "(cs)logand"
    (scheme-object scheme-object)
    scheme-object))

(define $logor
  (foreign-procedure "(cs)logor"
    (scheme-object scheme-object)
    scheme-object))

(define $logxor
  (foreign-procedure "(cs)logxor"
    (scheme-object scheme-object)
    scheme-object))

(define $lognot
  (foreign-procedure "(cs)lognot"
    (scheme-object)
    scheme-object))

(define $logbit?
  (foreign-procedure "(cs)logbitp"
    (scheme-object scheme-object)
    scheme-object))

(define $logbit0
  (foreign-procedure "(cs)logbit0"
    (scheme-object scheme-object)
    scheme-object))

(define $logbit1
  (foreign-procedure "(cs)logbit1"
    (scheme-object scheme-object)
    scheme-object))

(define $logtest
  (foreign-procedure "(cs)logtest"
    (scheme-object scheme-object)
    scheme-object))

(when-feature windows
(define get-registry
  (let ([fp (foreign-procedure "(windows)GetRegistry"
              (string)
              scheme-object)])
    (lambda (s)
      (unless (string? s) ($oops 'get-registry "~s is not a string" s))
      (let ([x (fp s)])
        (and x (utf8->string x))))))

(define put-registry!
  (let ([fp (foreign-procedure "(windows)PutRegistry"
              (string string)
              void)])
    (lambda (s1 s2)
      (unless (string? s1) ($oops 'put-registry! "~s is not a string" s1))
      (unless (string? s2) ($oops 'put-registry! "~s is not a string" s2))
      (fp s1 s2))))

(define remove-registry!
  (let ([fp (foreign-procedure "(windows)RemoveRegistry"
              (string)
              void)])
    (lambda (s)
      (unless (string? s) ($oops 'remove-registry! "~s is not a string" s))
      (fp s))))
)

(define ($real->flonum x who)
  (unless (or (not who) (symbol? who) (string? who))
    ($oops '$real->flonum "invalid who argument ~s" who))
  (#3%$real->flonum x who))

(define (real->flonum x) (#2%real->flonum x))

(define $integer-8? (lambda (x) (#3%$integer-8? x)))
(define $integer-16? (lambda (x) (#3%$integer-16? x)))
(define $integer-24? (lambda (x) (#3%$integer-24? x)))
(define $integer-32? (lambda (x) (#3%$integer-32? x)))
(define $integer-40? (lambda (x) (#3%$integer-40? x)))
(define $integer-48? (lambda (x) (#3%$integer-48? x)))
(define $integer-56? (lambda (x) (#3%$integer-56? x)))
(define $integer-64? (lambda (x) (#3%$integer-64? x)))
(define $foreign-char? (lambda (x) (#3%$foreign-char? x)))
(define $foreign-wchar? (lambda (x) (#3%$foreign-wchar? x)))

(define $byte-copy!
  (foreign-procedure "(cs)byte-copy"
    (scheme-object fixnum scheme-object fixnum fixnum)
    void))

(define $ptr-copy!
  (foreign-procedure "(cs)ptr-copy"
    (scheme-object fixnum scheme-object fixnum fixnum)
    void))

(define-who ($sealed-record? x rtd)
  (unless (record-type-descriptor? rtd)
    ($oops who "~s is not a record type descriptor" rtd))
  (#3%$sealed-record? x rtd))

(define ($record? x) (#3%$record? x))

(define-who ($record-type-descriptor r)
  (unless ($record? r) ($oops who "~s is not a record" r))
  (#3%$record-type-descriptor r))

(define-who utf8->string
  (let ()
    (define slurp
      (lambda (bv start)
        (let ([n (bytevector-length bv)])
          (let ([s (make-string (fx- n start))])
            (define (fini j)
              (if (fx= j (string-length s))
                  s
                  (string-truncate! s j)))
            (let loop ([i start] [j 0])
              (if (fx= i n)
                  (fini j)
                  (let ([b1 (bytevector-u8-ref bv i)])
                    (cond
                      [(fx<= b1 #x7f) ; one-byte encoding
                       (string-set! s j (integer->char b1))
                       (loop (fx+ i 1) (fx+ j 1))]
                      [(fx<= #xc2 b1 #xdf) ; two-byte encoding
                       (if (fx< i (fx- n 1)) ; have at least two bytes?
                           (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                             (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                 (begin
                                   (string-set! s j
                                     (let ([x (fxlogor (fxsll (fxlogand b1 #b11111) 6) (fxlogand b2 #b111111))])
                                       (if (fx<= x #x7f) #\x8ffd (integer->char x))))
                                   (loop (fx+ i 2) (fx+ j 1)))
                                ; second byte is not a continuation byte
                                 (begin
                                   (string-set! s j #\xfffd)
                                   (loop (fx+ i 1) (fx+ j 1)))))
                          ; have only one byte
                           (begin
                             (string-set! s j #\xfffd)
                             (fini (fx+ j 1))))]
                      [(fx<= #xe0 b1 #xef) ; three-byte encoding
                       (if (fx< i (fx- n 1)) ; have at least two bytes?
                           (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                             (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                 (if (fx< i (fx- n 2)) ; have at least three bytes?
                                     (let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
                                       (if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
                                           (begin
                                             (string-set! s j
                                               (let ([x (fxlogor
                                                          (fxsll (fxlogand b1 #b1111) 12)
                                                          (fxsll (fxlogand b2 #b111111) 6)
                                                          (fxlogand b3 #b111111))])
                                                 (if (and (fx>= x #x800) (not (fx<= #xd800 x #xdfff)))
                                                     (integer->char x)
                                                     #\xfffd)))
                                             (loop (fx+ i 3) (fx+ j 1)))
                                          ; third byte is not a continuation byte
                                           (begin
                                             (string-set! s j #\xfffd)
                                             (loop (fx+ i 2) (fx+ j 1)))))
                                    ; have only two bytes
                                     (begin
                                       (string-set! s j #\xfffd)
                                       (fini (fx+ j 1))))
                                ; second byte is not a continuation byte
                                 (begin
                                   (string-set! s j #\xfffd)
                                   (loop (fx+ i 1) (fx+ j 1)))))
                          ; have only one byte
                           (begin
                             (string-set! s j #\xfffd)
                             (fini (fx+ j 1))))]
                      [(fx<= #xf0 b1 #xf4) ; four-byte encoding
                       (if (fx< i (fx- n 1)) ; have at least two bytes?
                           (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                             (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                 (if (fx< i (fx- n 2)) ; have at least three bytes?
                                     (let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
                                       (if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
                                           (if (fx< i (fx- n 3)) ; have at least four bytes?
                                               (let ([b4 (bytevector-u8-ref bv (fx+ i 3))])
                                                 (if (fx= (fxsrl b4 6) #b10) ; fourth byte a continuation byte?
                                                     (begin
                                                       (string-set! s j
                                                         (let ([x (fxlogor
                                                                    (fxsll (fxlogand b1 #b111) 18)
                                                                    (fxsll (fxlogand b2 #b111111) 12)
                                                                    (fxsll (fxlogand b3 #b111111) 6)
                                                                    (fxlogand b4 #b111111))])
                                                           (if (fx<= #x10000 x #x10ffff)
                                                               (integer->char x)
                                                               #\xfffd)))
                                                       (loop (fx+ i 4) (fx+ j 1)))
                                                    ; fourth byte is not a continuation byte
                                                     (begin
                                                       (string-set! s j #\xfffd)
                                                       (loop (fx+ i 3) (fx+ j 1)))))
                                              ; have only three bytes
                                               (begin
                                                 (string-set! s j #\xfffd)
                                                 (fini (fx+ j 1))))
                                          ; third byte is not a continuation byte
                                           (begin
                                             (string-set! s j #\xfffd)
                                             (loop (fx+ i 2) (fx+ j 1)))))
                                    ; have only two bytes
                                     (begin
                                       (string-set! s j #\xfffd)
                                       (fini (fx+ j 1))))
                                ; second byte is not a continuation byte
                                 (begin
                                   (string-set! s j #\xfffd)
                                   (loop (fx+ i 1) (fx+ j 1)))))
                          ; have only one byte
                           (begin
                             (string-set! s j #\xfffd)
                             (fini (fx+ j 1))))]
                      [else
                       (string-set! s j #\xfffd)
                       (loop (fx+ i 1) (fx+ j 1))]))))))))
    (lambda (bv)
      (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
      (slurp bv
        (if (and (fx>= (bytevector-length bv) 3)
                 (fx= (bytevector-u8-ref bv 0) #xef)
                 (fx= (bytevector-u8-ref bv 1) #xbb)
                 (fx= (bytevector-u8-ref bv 2) #xbf))
            3 0)))))

(let ()
  (define ($string->utf8 s nul?)
    (let ([sn (string-length s)])
      (let ([bv (do ([si 0 (fx+ si 1)]
                     [bvn 0 (+ bvn (let ([k (char->integer (string-ref s si))])
                                     (if (fx<= k #x7ff)
                                         (if (fx<= k #x7f) 1 2)
                                         (if (fx<= k #xffff) 3 4))))])
                  ((fx= si sn)
                   (if nul?
                       (let ([real-bvn (fx+ bvn 1)])
                         (unless (fixnum? real-bvn)
                           ($oops 'string->utf8 "result would be too large"))
                         (let ([bv (make-bytevector real-bvn)])
                           (bytevector-u8-set! bv bvn 0)
                           bv))
                       (begin
                         (unless (fixnum? bvn)
                           ($oops 'string->utf8 "result would be too large"))
                         (make-bytevector bvn)))))])
        (let f ([si 0] [bvi 0])
          (if (fx= si sn)
              bv
              (let ([k (char->integer (string-ref s si))])
                (if (fx<= k #x7ff)
                    (if (fx<= k #x7f)
                        (begin
                          (bytevector-u8-set! bv bvi k)
                          (f (fx+ si 1) (fx+ bvi 1)))
                        (begin
                          (bytevector-u8-set! bv bvi (fxlogor #b11000000 (fxsrl k 6)))
                          (bytevector-u8-set! bv (fx+ bvi 1) (fxlogor #b10000000 (fxlogand k #b111111)))
                          (f (fx+ si 1) (fx+ bvi 2))))
                    (if (fx<= k #xffff)
                        (begin
                          (bytevector-u8-set! bv bvi (fxlogor #b11100000 (fxsrl k 12)))
                          (bytevector-u8-set! bv (fx+ bvi 1) (fxlogor #b10000000 (fxlogand (fxsrl k 6) #b111111)))
                          (bytevector-u8-set! bv (fx+ bvi 2) (fxlogor #b10000000 (fxlogand k #b111111)))
                          (f (fx+ si 1) (fx+ bvi 3)))
                        (begin
                          (bytevector-u8-set! bv bvi (fxlogor #b11110000 (fxsrl k 18)))
                          (bytevector-u8-set! bv (fx+ bvi 1) (fxlogor #b10000000 (fxlogand (fxsrl k 12) #b111111)))
                          (bytevector-u8-set! bv (fx+ bvi 2) (fxlogor #b10000000 (fxlogand (fxsrl k 6) #b111111)))
                          (bytevector-u8-set! bv (fx+ bvi 3) (fxlogor #b10000000 (fxlogand k #b111111)))
                          (f (fx+ si 1) (fx+ bvi 4)))))))))))
  (set! $fp-string->utf8
    (lambda (s)
      ($string->utf8 s #t)))
  (set-who! string->utf8
    (lambda (s)
      (unless (string? s) ($oops who "~s is not a string" s))
      ($string->utf8 s #f))))

(define-who utf16->string
  (let ()
    (define slurp
      (lambda (bv eness start)
        (let ([n (bytevector-length bv)])
          (let ([s (make-string (fxsrl (fx+ (fx- n start) 1) 1))])
            (define (fini j)
              (if (fx= j (string-length s))
                  s
                  (string-truncate! s j)))
            (define-syntax go
              (syntax-rules ()
                [(_ bv-u16-ref)
                 (let loop ([i start] [j 0])
                   (cond
                     [(fx= i n) (fini j)]
                     [(fx= i (fx- n 1))
                      (string-set! s j #\xfffd)
                      (fini (fx+ j 1))]
                     [else
                      (let ([w1 (bv-u16-ref bv i)])
                        (cond
                          [(fx<= #xD800 w1 #xDBFF) ; two-word encoding
                           (cond
                             [(fx>= i (fx- n 3))
                              (string-set! s j #\xfffd)
                              (fini (fx+ j 1))]
                             [else
                              (let ([w2 (bv-u16-ref bv (fx+ i 2))])
                                (string-set! s j
                                  (if (fx<= #xDC00 w2 #xDFFF)
                                      (integer->char
                                        (fx+ (fxlogor
                                               (fxsll (fx- w1 #xD800) 10)
                                               (fx- w2 #xDC00))
                                             #x10000))
                                      #\xfffd))
                                (loop (fx+ i 4) (fx+ j 1)))])]
                          [(fx<= #xDC00 w1 #xDFFF) ; misplaced continuation word
                           (string-set! s j #\xfffd)
                           (loop (fx+ i 2) (fx+ j 1))]
                          [else
                           (string-set! s j (integer->char w1))
                           (loop (fx+ i 2) (fx+ j 1))]))]))]))
            (if (eq? eness (constant native-endianness))
                (go bytevector-u16-native-ref)
                (go (lambda (bv i) (bytevector-u16-ref bv i eness))))))))
    (rec utf16->string
      (case-lambda
        [(bv eness) (utf16->string bv eness #f)]
        [(bv eness mandatory?)
         (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
         (unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
         (if (or mandatory? (< (bytevector-length bv) 2))
             (slurp bv eness 0)
             (let ([BOM (bytevector-u16-native-ref bv 0)])
               (if (fx= BOM #xfeff)
                   (slurp bv (constant native-endianness) 2)
                   (if (fx= BOM #xfffe)
                       (slurp bv (constant-case native-endianness [(big) 'little] [(little) 'big]) 2)
                       (slurp bv eness 0)))))]))))

(let ()
  (define ($string->utf16 s eness nul?)
    (let ([sn (string-length s)])
      (let ([bv (do ([si 0 (fx+ si 1)]
                     [bvn 0 (+ bvn (if (char<=? (string-ref s si) #\xffff) 2 4))])
                  ((fx= si sn)
                   (if nul?
                       (let ([real-bvn (+ bvn 2)])
                         (unless (fixnum? real-bvn)
                           ($oops 'string->utf16 "result would be too large"))
                         (let ([bv (make-bytevector real-bvn)])
                           (bytevector-u16-native-set! bv bvn 0)
                           bv))
                       (begin
                         (unless (fixnum? bvn)
                           ($oops 'string->utf16 "result would be too large"))
                         (make-bytevector bvn)))))])
        (define-syntax go
          (syntax-rules ()
            [(_ bv-u16-set!)
             (let f ([si 0] [bvi 0])
               (unless (fx= si sn)
                 (let ([x (char->integer (string-ref s si))])
                   (if (fx<= x #xffff)
                       (begin
                         (bv-u16-set! bv bvi x)
                         (f (fx+ si 1) (fx+ bvi 2)))
                       (let ([x (fx- x #x10000)])
                         (bv-u16-set! bv bvi (fxior #xD800 (fxsrl x 10)))
                         (bv-u16-set! bv (fx+ bvi 2) (fxior #xDC00 (fxand x #x3ff)))
                         (f (fx+ si 1) (fx+ bvi 4)))))))]))
        (if (eq? eness (constant native-endianness))
            (go bytevector-u16-native-set!)
            (go (lambda (bv i n) (bytevector-u16-set! bv i n eness))))
        bv)))
  (set! $fp-string->utf16
    (lambda (s eness)
      ($string->utf16 s eness #t)))
  (set-who! string->utf16
    (rec string->utf16
      (case-lambda
        [(s)
         (unless (string? s) ($oops who "~s is not a string" s))
         ($string->utf16 s 'big #f)]
        [(s eness)
         (unless (string? s) ($oops who "~s is not a string" s))
         (unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
         ($string->utf16 s eness #f)]))))

(define-who utf32->string
  (let ()
    (define slurp
      (lambda (bv eness start)
        (let ([n (bytevector-length bv)])
          (let ([s (make-string (fxsrl (fx+ (fx- n start) 3) 2))])
            (define-syntax go
              (syntax-rules ()
                [(_ bv-u32-ref)
                 (let loop ([i start] [j 0])
                   (cond
                     [(fx= i n) s]
                     [(fx>= i (fx- n 3))
                      (string-set! s j #\xfffd)
                      s]
                     [else
                      (let ([x (bv-u32-ref bv i)])
                        (string-set! s j
                          (if (and (fixnum? x) (fx<= x #x10ffff) (not (fx<= #xd800 x #xdfff)))
                              (integer->char x)
                              #\xfffd))
                        (loop (fx+ i 4) (fx+ j 1)))]))]))
            (if (eq? eness (constant native-endianness))
                (go bytevector-u32-native-ref)
                (go (lambda (bv i) (bytevector-u32-ref bv i eness))))))))
    (rec utf32->string
      (case-lambda
        [(bv eness) (utf32->string bv eness #f)]
        [(bv eness mandatory?)
         (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
         (unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
         (if (or mandatory? (< (bytevector-length bv) 4))
             (slurp bv eness 0)
             (let ([BOM (bytevector-u32-native-ref bv 0)])
               (if (and (fixnum? BOM) (fx= BOM #xfeff))
                   (slurp bv (constant native-endianness) 4)
                   (if (= BOM #xfffe0000)
                       (slurp bv (constant-case native-endianness [(big) 'little] [(little) 'big]) 4)
                       (slurp bv eness 0)))))]))))

(let ()
  (define ($string->utf32 s eness nul?)
    (let ([sn (string-length s)])
      (unless (fx<= (if nul? sn (fx+ sn 1)) (fxsrl (greatest-fixnum) 2))
        ($oops 'string->utf32 "result would be too large"))
      (let ([bv (if nul?
                    (let* ([bvn (fxsll sn 2)] [bv (make-bytevector (fx+ bvn 4))])
                      (bytevector-u32-native-set! bv bvn 0)
                      bv)
                    (make-bytevector (fxsll sn 2)))])
        (define-syntax go
          (syntax-rules ()
            [(_ bv-u32-set!)
             (do ([si 0 (fx+ si 1)])
                 ((fx= si sn))
               (bv-u32-set! bv (fxsll si 2) (char->integer (string-ref s si))))]))
        (if (eq? eness (constant native-endianness))
            (go bytevector-u32-native-set!)
            (go (lambda (bv i n) (bytevector-u32-set! bv i n eness))))
        bv)))
  (set! $fp-string->utf32
    (lambda (s eness)
      ($string->utf32 s eness #t)))
  (set-who! string->utf32
    (rec string->utf32
      (case-lambda
        [(s)
         (type-check who string s)
         ($string->utf32 s 'big #f)]
        [(s eness)
         (type-check who string s)
         (unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
         ($string->utf32 s eness #f)]))))

(define $breakhere (foreign-procedure "(cs)s_breakhere" (ptr) void))

(define $errno->string (foreign-procedure "(cs)s_strerror" (int) scheme-object))

(define $errno (foreign-procedure "(cs)s_errno" () int))

(define interactive? (foreign-procedure "(cs)s_interactivep" () boolean))

(define-who $read-performance-monitoring-counter
  (lambda (x)
   ; might should check valid range (which is fixed by the hardware we are running on)
    (type-check who fixnum x)
    (#3%$read-performance-monitoring-counter x)))

(define $read-time-stamp-counter
  (lambda ()
    (#3%$read-time-stamp-counter)))

(when-feature windows
(let ()
  (define mbtwc
    (foreign-procedure "(cs)s_multibytetowidechar"
      (unsigned ptr)
      ptr))
  (define wctmb
    (foreign-procedure "(cs)s_widechartomultibyte"
      (unsigned ptr)
      ptr))
  (define (cp->unsigned who cp)
    (case cp
      [(cp-acp) 0]
      [(cp-maccp) 2]
      [(cp-oemcp) 1]
      [(cp-symbol) 42]
      [(cp-thread-acp) 3]
      [(cp-utf7) 65000]
      [(cp-utf8) 65001]
      [else
       (if (and (fixnum? cp) (fx>= cp 0))
           cp
           ($oops who "invalid code page ~s" cp))]))
  (set-who! multibyte->string
    (lambda (cp bv)
      (let ([cp (cp->unsigned who cp)])
        (unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
        (utf16->string (mbtwc cp bv) 'little #t))))
  (set-who! string->multibyte
    (lambda (cp str)
      (let ([cp (cp->unsigned who cp)])
        (unless (string? str) ($oops who "~s is not a string" str))
        (wctmb cp (string->utf16 str 'little))))))
)
