;;; prims.ss
;;; Copyright 1984-2017 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))

(begin
;;; 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 immutable-vector ($hand-coded 'immutable-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 __atomic "(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 __atomic __alloc "(cs)s_weak_cons"
    (scheme-object scheme-object)
    scheme-object))

(define weak-pair?
  (constant-case architecture
    [(pb)
     (foreign-procedure "(cs)s_weak_pairp" (scheme-object) scheme-object)]
    [else (lambda (p) (weak-pair? p))]))

(define ephemeron-cons
  (foreign-procedure __atomic __alloc "(cs)s_ephemeron_cons"
    (scheme-object scheme-object)
    scheme-object))

(define ephemeron-pair?
  (constant-case architecture
    [(pb)
     (foreign-procedure "(cs)s_ephemeron_pairp" (scheme-object) scheme-object)]
    [else
     (lambda (p) (ephemeron-pair? p))]))

(define reference-bytevector?
  (constant-case architecture
    [(pb)
     (foreign-procedure "(cs)s_reference_bytevectorp" (scheme-object) scheme-object)]
    [else
     (lambda (p) (reference-bytevector? p))]))

(define-who bytevector-reference-ref
  (lambda (bv i)
    (unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv))
    (unless (and (fixnum? i)
                 (fx<= 0 i (fx- (bytevector-length bv) (constant ptr-bytes))))
      ($oops who "invalid index ~s for ~s" i bv))
    (bytevector-reference-ref bv i)))

(define-who bytevector-reference*-ref
  (let ([ref (foreign-procedure "(cs)s_bytevector_reference_star_ref" (ptr uptr) ptr)])
    (lambda (bv i)
      (unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv))
      (unless (and (fixnum? i)
                   (fx<= 0 i (fx- (bytevector-length bv) (constant ptr-bytes))))
        ($oops who "invalid index ~s for ~s" i bv))
      (ref bv i))))

(define-who bytevector-reference-set!
  (lambda (bv i val)
    (unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv))
    (unless (and (fixnum? i)
                 (fx<= 0 i (fx- (bytevector-length bv) (constant ptr-bytes))))
      ($oops who "invalid index ~s for ~s" i bv))
    (bytevector-reference-set! bv i val)))

(define-who object->reference-address
  (lambda (v)
    (object->reference-address v)))

(define-who reference-address->object
  (lambda (a)
    (unless (and (or (fixnum? a) (bignum? a))
                 (< -1 a (bitwise-arithmetic-shift 1 (constant ptr-bits))))
      ($oops who "invalid address ~s" a))
    (reference-address->object a)))

(define-who reference*-address->object
  (let ([ref->obj (foreign-procedure "(cs)s_reference_star_address_object" (uptr) ptr)])
    (lambda (a)
      (unless (and (or (fixnum? a) (bignum? a))
                   (< -1 a (bitwise-arithmetic-shift 1 (constant ptr-bits))))
        ($oops who "invalid address ~s" a))
      (ref->obj a))))

(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 $dequeue-scheme-signals
  (foreign-procedure "(cs)dequeue_scheme_signals"
    (ptr)
    ptr))

(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 string->uninterned-symbol
  (foreign-procedure "(cs)s_uninterned"
    (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 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-who $procedure-name
  (lambda (x)
    (unless (procedure? x)
      ($oops who "~s is not a procedure" x))
    (let name ([x x])
      (let ([code ($closure-code x)])
        (if ($code-arity-in-closure? code)
            (name ($closure-ref x 0))
            ($code-name code))))))

(define-who $procedure-realm
  (lambda (x)
    (unless (procedure? x)
      ($oops who "~s is not a procedure" x))
    (let realm ([x x])
      (let ([code ($closure-code x)])
        (if ($code-arity-in-closure? code)
            (realm ($closure-ref x 0))
            (let ([info ($code-info code)])
              (include "types.ss")
              (and (code-info? info)
                   (code-info-realm info))))))))

(define-who procedure-arity-mask
  (lambda (x)
    (unless (procedure? x) ($oops who "~s is not a procedure" x))
    (let ([c ($closure-code x)])
      (if ($code-arity-in-closure? c)
          ($closure-ref x 1)
          ($code-arity-mask c)))))

(define-who procedure-known-single-valued?
  (lambda (x)
    (unless (procedure? x) ($oops who "~s is not a procedure" x))
    (if (wrapper-procedure? x)
        (procedure-known-single-valued? ($closure-ref x 0))
        (let ([c ($closure-code x)])
          ($code-single-valued? c)))))

(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! flvector (frob-proc flvector make-flvector flvector-set! flonum?
                  "~s is not a flonum"))
  (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 (mutable-bytevector? bv) ($oops who "~s is not a mutable 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 (mutable-string? st) ($oops who "~s is not a mutable 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-uninitialized-string
  (lambda (n)
    (unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
      ($oops who "~s is not a valid string length" n))
    ($make-uninitialized-string n)))

(define-who make-string
  (case-lambda
    [(n c)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
       ($oops who "~s is not a valid string length" n))
     (unless (char? c)
       ($oops who "~s is not a character" c))
     (make-string n c)]
    [(n)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
       ($oops who "~s is not a valid string length" n))
     (make-string n)]))

(define-who make-vector
   (case-lambda
      [(n x)
       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
         ($oops who "~s is not a valid vector length" n))
       (make-vector n x)]
      [(n)
       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
         ($oops who "~s is not a valid vector length" n))
       (make-vector n)]))

(define-who $make-vector/no-interrupt-trap
   (case-lambda
      [(n x)
       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
         ($oops who "~s is not a valid vector length" n))
       ($make-vector/no-interrupt-trap n x)]
      [(n)
       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
         ($oops who "~s is not a valid vector length" n))
       ($make-vector/no-interrupt-trap n)]))

(define-who make-immobile-vector
  (let ([$make-immobile-vector (foreign-procedure "(cs)make_immobile_vector" (uptr ptr) ptr)])
   (case-lambda
      [(n x)
       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
         ($oops who "~s is not a valid vector length" n))
       (let ([v ($make-immobile-vector n x)])
         ($use-trap-fuel n (constant fuel-word-count-shift))
         v)]
      [(n)
       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
         ($oops who "~s is not a valid vector length" n))
       (let ([v ($make-immobile-vector n 0)])
         ($use-trap-fuel n (constant fuel-word-count-shift))
         v)])))

(define-who make-reference-bytevector
  (let ([$make-reference-bytevector (foreign-procedure "(cs)s_make_reference_bytevector" (uptr) ptr)])
    (lambda (n)
      (unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
        ($oops who "~s is not a valid bytevector length" n))
      (let ([v ($make-reference-bytevector n)])
        ($use-trap-fuel n (+ (constant fuel-word-count-shift) (constant log2-ptr-bytes)))
        v))))

(define-who make-immobile-reference-bytevector
  (let ([$make-immobile-reference-bytevector (foreign-procedure "(cs)s_make_immobile_reference_bytevector" (uptr) ptr)])
    (lambda (n)
      (unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
        ($oops who "~s is not a valid bytevector length" n))
      (let ([v ($make-immobile-reference-bytevector n)])
        ($use-trap-fuel n (+ (constant fuel-word-count-shift) (constant log2-ptr-bytes)))
        v))))

(define $make-eqhash-vector
  (case-lambda
    [(n)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
       ($oops '$make-eqhash-vector "~s is not a nonnegative fixnum" n))
     ($make-eqhash-vector n)]))

(define-who make-fxvector
  (case-lambda
    [(n x)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-fxvector-length) n)))
       ($oops who "~s is not a valid fxvector length" n))
     (unless (fixnum? x)
       ($oops who "~s is not a fixnum" x))
     (make-fxvector n x)]
    [(n)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-fxvector-length) n)))
       ($oops who "~s is not a valid fxvector length" n))
     (make-fxvector n)]))

(define-who make-flvector
  (case-lambda
    [(n x)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-flvector-length) n)))
       ($oops who "~s is not a valid flvector length" n))
     (unless (flonum? x)
       ($oops who "~s is not a flonum" x))
     (if (eqv? x 0.0)
         (make-flvector n)
         ;; Room for improvement: vector is filled with 0.0, then with `x`:
         (let ([flv (make-flvector n)])
           (let loop ([i 0])
             (if (fx= i n)
                 flv
                 (begin
                   (flvector-set! flv i x)
                   (loop (fx+ i 1)))))))]
    [(n)
     (unless (and (fixnum? n) (not ($fxu< (constant maximum-flvector-length) n)))
       ($oops who "~s is not a valid flvector length" n))
     (make-flvector n)]))

(define string-fill!
   (lambda (s c)
      (unless (mutable-string? s)
         ($oops 'string-fill! "~s is not a mutable 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 a fxvector" v))
      (unless (fixnum? n)
        ($oops 'fxvector-fill! "~s is not a fixnum" n))
      (fxvector-fill! v n)))

(define flvector-fill!
   (lambda (v x)
      (unless (flvector? v)
         ($oops 'flvector-fill! "~s is not a flvector" v))
      (unless (flonum? x)
        ($oops 'flvector-fill! "~s is not a flonum" x))
      (let ([n (flvector-length v)])
        (let loop ([i 0])
          (unless (fx= i n)
            (flvector-set! v i x)
            (loop (fx+ i 1)))))))

;;; multiple return values stuff

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

;; When applied, ensures the argument expression produces a single
;; value. Unlike other primitives, an immediate application of
;; `$value` won't be optimized away with optimization level 3 unless
;; the argument expression definitely produces a single value.
(define $value (lambda (x) x))

;; Intended mainly for use as `#3%$app` to indicate that no check
;; is needed to ensure that the first argument is a function, as
;; recognized in cp0.
(define $app
  (lambda (f . args)
    (#2%apply f args)))

(define $app/no-inline
  (lambda (f . args)
    (#2%apply f args)))

;; Implies no-inline, and in unsafe mode, asserts that the
;; application will not return and that it does not inspect/change
;; the immediate continuation attachment (so it can be moved to a
;; more-tail position)
(define $app/no-return
  (lambda (f . args)
    (#2%apply f args)))

;; In unsafe mode, asserts that the applicaiton returns a single value
;; and that it does not inspect/change the immediate continuation
;; attachment (so it can be moved to a more-tail position)
(define $app/value
  (lambda (f . args)
    (#2%apply f args)))

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

;; calls `p` with the continuation `c` and either no immediate
;; attachments or the given attachments `as` that must be either
;; the same as the attachments saved by `c` or one immediate
;; attachment extending those attachments
(define-who $call-in-continuation
  (case-lambda
   [(c p)
    (unless (procedure? p)
      ($oops who "~s is not a procedure" p))
    (#2%$call-in-continuation c (lambda () (p)))]
   [(c as p)
    (unless (procedure? p)
      ($oops who "~s is not a procedure" p))
    (#2%$call-in-continuation c as (lambda () (p)))]))

;; checks `c` and consistency of `as` with `c`, and also runs any needed winders
(define $assert-continuation
  (case-lambda
   [(c) (#2%$assert-continuation c)]
   [(c as) (#2%$assert-continuation c as)]))

(define-who $call-setting-continuation-attachment
  (lambda (v p)
    (unless (procedure? p)
      ($oops who "~s is not a procedure" p))
    (#3%$call-setting-continuation-attachment v (lambda () (p)))))

(define-who $call-getting-continuation-attachment
  (lambda (default-val p)
    (unless (procedure? p)
      ($oops who "~s is not a procedure" p))
    (#3%$call-getting-continuation-attachment default-val (lambda (x) (p x)))))

(define-who $call-consuming-continuation-attachment
  (lambda (default-val p)
    (unless (procedure? p)
      ($oops who "~s is not a procedure" p))
    (#3%$call-consuming-continuation-attachment default-val (lambda (x) (p x)))))

(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 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-arity-mask
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-arity-mask 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-who $code-mutable-closure?
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-mutable-closure? x)))

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

(define-who $code-single-valued?
  (lambda (x)
    (unless ($code? x) ($oops who "~s is not code" x))
    ($code-single-valued? 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)
    (constant-case architecture
      [(pb)
       (unless (vector? x)
         ($oops 'foreign-callable-entry-point "~s is not a vector" x))
       (bitwise-and (bitwise-arithmetic-shift-left (vector-ref x 2) (constant fixnum-offset))
                    (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1))]
      [else
       (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
  (constant-case architecture
    [(pb)
     (let ([find-callable-code-object (foreign-procedure "(cs)find_callable_code_object" (uptr) ptr)])
       (lambda (x)
         (unless (and (integer? x) (exact? x))
           ($oops who "~s is not an entry point" x))
         (find-callable-code-object x)))]
    [else
     (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 $closure-set!
   (lambda (x i new)
     (unless (and (procedure? x)
                  ($code-mutable-closure? ($closure-code x)))
         ($oops '$closure-ref "~s is not a mutable closure" x))
      (unless (and (fixnum? i) (fx< -1 i ($closure-length x)))
         ($oops '$closure-ref "invalid index ~s" i))
      ($closure-set! x i new)))

(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-attachments
   (lambda (x)
      (unless ($continuation? x)
         ($oops '$continuation-attachments "~s is not a continuation" x))
      ($continuation-attachments 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-who $continuation-return-frame-words
   (lambda (x)
      (unless ($continuation? x)
         ($oops who "~s is not a continuation" x))
      ($continuation-return-frame-words x)))

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

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

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

(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 $get-timer
  (lambda ()
    ($get-timer)))

(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 $string-set!-check? (lambda (s i) ($string-set!-check? s i)))

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

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

(define $flvector-ref-check? (lambda (v i) ($flvector-ref-check? v i)))
(define $flvector-set!-check? (lambda (v i) ($flvector-set!-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 memory-order-acquire
  (lambda ()
    (memory-order-acquire)))

(define memory-order-release
  (lambda ()
    (memory-order-release)))

(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-who $string-set-immutable!
   (lambda (s)
     (unless (string? s)
       ($oops who "~s is not a string" s))
     (#3%$string-set-immutable! s)))

(define-who mutable-string?
  (lambda (v)
    (#3%mutable-string? v)))

(define-who immutable-string?
  (lambda (v)
    (#3%immutable-string? v)))

(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-cas!
   (lambda (v i old-x new-x)
      (#2%vector-cas! v i old-x new-x)))

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

(define-who $vector-set-immutable!
   (lambda (v)
     (unless (vector? v)
       ($oops who "~s is not a vector" v))
     (#3%$vector-set-immutable! v)))

(define mutable-vector?
   (lambda (v)
     (#3%mutable-vector? v)))

(define immutable-vector?
   (lambda (v)
     (#3%immutable-vector? v)))

(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 flvector-length
   (lambda (v)
      (#2%flvector-length v)))

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

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

(define stencil-vector-mask
   (lambda (v)
      (#2%stencil-vector-mask v)))

(define $stencil-vector-mask
   (lambda (v)
      (#2%$stencil-vector-mask v)))

(define-who $make-stencil-vector
  (lambda (len mask)
    ($oops who "should only be used as inlined with GC disabled")))

(define-who $make-system-stencil-vector
  (lambda (len mask)
    ($oops who "should only be used as inlined with GC disabled")))

; not safe; assumes `val` is older than `v`
(define $stencil-vector-fill-set!
  (lambda (v i val)
    ($stencil-vector-fill-set! v i val)))

; not safe
(define $record-ref
   (lambda (v i)
      (#3%$record-ref v i)))

; not safe
(define $record-set!
   (lambda (v i x)
      (#3%$record-set! v i x)))

; not safe
(define $record-cas!
   (lambda (v i old-x new-x)
      (#3%$record-cas! v i old-x new-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 car-cas!
  (lambda (p old-v new-v)
    (#2%car-cas! p old-v new-v)))

(define cdr-cas!
  (lambda (p old-v new-v)
    (#2%cdr-cas! p old-v new-v)))

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

(define box-immutable (lambda (x) (box-immutable x)))

(define box-immobile (foreign-procedure "(cs)box_immobile" (ptr) ptr))

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

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

(define-who box-cas!
   (lambda (b old-v new-v)
      (if (mutable-box? b)
          (box-cas! b old-v new-v)
          ($oops who "~s is not a mutable box" b))))

(define mutable-box?
  (lambda (b)
    (#3%mutable-box? b)))

(define immutable-box?
  (lambda (b) 
    (#3%immutable-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 uninterned-symbol? (lambda (x) (uninterned-symbol? 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 flvector? (lambda (x) (flvector? x)))

(define stencil-vector? (lambda (x) (stencil-vector? x)))

(define $stencil-vector? (lambda (x) ($stencil-vector? x)))

(define $system-stencil-vector? (lambda (x) ($system-stencil-vector? 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)))

;; Used to communicate fixmediateness from cptypes to cpnanopass:
(define-who $fixmediate
  (lambda (x)
    (if (fixmediate? x)
        x
        ($oops who "~s is not a fixnum or immediate value" 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-who $current-winders
  (let ()
    (include "types.ss")
    (case-lambda
      [() ($current-winders)]
      [(w)
       ;; this check could be helpful, but it's not constant-time:
       #;
       (unless (and (list? w) (andmap winder? w))
         ($oops who "malformed winders ~s" w))
       ($current-winders w)])))

(define $current-attachments
  (case-lambda
    [() ($current-attachments)]
    [(w)
     ;; this check could be helpful, but it's not constant-time:
     #;
     (unless (list? w)
       ($oops '$current-attachments "malformed attachments ~s" w))
     ($current-attachments w)]))

(define-who $current-handler-stack
  (case-lambda
   [() ($current-handler-stack)]
   [(w) ($current-handler-stack w)]))

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

(define-who $install-guardian
  (lambda (obj rep tconc)
    ; tconc is assumed to be valid at all call sites
    (#3%$install-guardian obj rep tconc)))

(define-who $install-ftype-guardian
  (lambda (obj tconc)
    ; tconc is assumed to be valid at all call sites
    (#3%$install-ftype-guardian obj tconc)))

(define guardian?
  (lambda (g)
    (#3%guardian? g)))

(define-who unregister-guardian
  (let ([fp (foreign-procedure __atomic __alloc "(cs)unregister_guardian" (scheme-object) scheme-object)])
    (define probable-tconc? ; full tconc? could be expensive ...
      (lambda (x)
        (and (pair? x) (pair? (car x)) (pair? (cdr x)))))
    (lambda (g)
      (unless (guardian? g) ($oops who "~s is not a guardian" g))
      ; at present, guardians should have either one free variable (the tcond) or two(the tconc and an ftd)
      ; but we just look for a probable tconc among whatever free variables it has
      (fp (let ([n ($code-free-count ($closure-code g))])
            (let loop ([i 0])
              (if (fx= i n)
                  ($oops #f "failed to find a tconc among the free variables of guardian ~s" g)
                  (let ([x ($closure-ref g i)])
                    (if (probable-tconc? x)
                        x
                        (loop (fx+ i 1)))))))))))

(define-who $ftype-guardian-oops
  (lambda (ftd obj)
    ($oops 'ftype-guardian "~s is not an ftype pointer of the expected type ~s" obj ftd)))

(define make-guardian (case-lambda
                        [() (#2%make-guardian)]
                        [(o) (#2%make-guardian o)]))

(define $make-ftype-guardian (lambda (ftd) (#2%$make-ftype-guardian ftd)))

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

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

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

;; expected to be inlined, but if not, the fact that an uninlined
;; function is called will create a trap check
(define $event-trap-check (lambda () (void)))

(let ()
  (define (inc)
    ;; make up for decrement that will happen immediately on retry:
    (let ([t ($get-timer)])
      (when (fx< t (most-positive-fixnum))
        ($set-timer (fx+ t 1)))))

  (set! $event-and-resume
        (case-lambda
         [(proc)
          ($event)
          (inc)
          (proc)]
         [(proc arg)
          ($event)
          (inc)
          (proc arg)]
         [(proc arg1 arg2)
          ($event)
          (inc)
          (proc arg1 arg2)]
         [(proc arg1 arg2 arg3)
          ($event)
          (inc)
          (proc arg1 arg2 arg3)]
         [(proc arg1 arg2 arg3 arg4)
          ($event)
          (inc)
          (proc arg1 arg2 arg3 arg4)]
         ;; Cases above should cover `event-resume-max-preferred-arg-cnt`,
         ;; including `proc` in th count
         [(proc . args)
          ($event)
          (inc)
          (apply proc args)]))

  (set! $event-and-resume*
        (lambda (proc+args)
          ($event)
          (inc)
          (apply (car proc+args) (cdr proc+args)))))

(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-collect-thread0-cond (lambda () ($raw-collect-thread0-cond)))
(define $raw-tc-mutex (lambda () ($raw-tc-mutex)))
(define $raw-terminated-cond (lambda () ($raw-terminated-cond)))
(define fork-thread)
(define thread-join)
(define thread-preserve-ownership!)
(define make-mutex)
(define mutex?)
(define mutex-name)
(define mutex-acquire)
(define mutex-release)
(define make-condition)
(define thread-condition?)
(define condition-name)
(define condition-wait)
(define condition-signal)
(define condition-broadcast)
(define $close-resurrected-mutexes&conditions)
(define $tc-mutex)
(define $collect-cond)
(define $collect-thread0-cond)
(define $terminated-cond)
(define get-initial-thread)
(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 mf (foreign-procedure "(cs)mutex_free" (scheme-object) void))
(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 cf (foreign-procedure "(cs)condition_free" (scheme-object) void))
(define cw (foreign-procedure "(cs)condition_wait" (scheme-object scheme-object scheme-object) boolean))
(define cb (foreign-procedure "(cs)condition_broadcast" (scheme-object) void))
(define cs (foreign-procedure "(cs)condition_signal" (scheme-object) void))
(define ts (foreign-procedure "(cs)threads" () scheme-object))

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

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

(define make-mutex-no-check
  (lambda (name)
    (let ([m ($make-mutex (mm) name)])
      (mutex-guardian m)
      m)))

(define make-condition-no-check
  (lambda (name)
    (let ([c ($make-condition (mc) name)])
      (condition-guardian c)
      c)))

(define mutex-guardian (make-guardian #t))
(define condition-guardian (make-guardian #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-who! thread-join
  (lambda (t)
    (unless (thread? t)
      ($oops who "~a is not a thread" t))
    ;; not using `with-tc-mutex` because we don't want to
    ;; disable interrupts
    (mutex-acquire $tc-mutex)
    (let f ()
      (unless (eq? ($thread-tc t) 0)
        (condition-wait $terminated-cond $tc-mutex)
        (f)))
    (mutex-release $tc-mutex)))

(set-who! thread-preserve-ownership!
  (let ([preserve! (foreign-procedure "(cs)thread_preserve_ownership" (ptr) void)])
    (case-lambda
     [(t)
      (unless (thread? t)
        ($oops who "~a is not a thread" t))
      (with-tc-mutex
       (let ([tc ($thread-tc t)])
         (unless (eq? tc 0)
           (preserve! tc))))]
     [()
      (with-tc-mutex (preserve! ($tc)))])))

(set-who! make-mutex
  (case-lambda
    [() (make-mutex-no-check #f)]
    [(name)
     (unless (or (not name) (symbol? name)) ($oops who "~s is not a symbol or #f" name))
     (make-mutex-no-check name)]))

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

(set-who! mutex-name
  (lambda (m)
    (unless (mutex? m) ($oops who "~s is not a mutex" m))
    ($mutex-name m)))

(set! mutex-acquire
  (case-lambda
    [(m) (mutex-acquire m #t)]
    [(m block?)
     (unless (mutex? m)
       ($oops 'mutex-acquire "~s is not a mutex" m))
     (let ([addr ($mutex-addr m)])
       (when (eq? addr 0)
         ($oops 'mutex-acquire "mutex is defunct"))
       (let ([r ((if block? ma ma-nb) addr)])
         (keep-live m)
         r))]))

(set! mutex-release
  (lambda (m)
    (unless (mutex? m)
      ($oops 'mutex-release "~s is not a mutex" m))
    (let ([addr ($mutex-addr m)])
      (when (eq? addr 0)
        ($oops 'mutex-release "mutex is defunct"))
      (mr addr))))

(set-who! make-condition
  (case-lambda
    [() (make-condition-no-check #f)]
    [(name)
     (unless (or (not name) (symbol? name)) ($oops who "~s is not a symbol or #f" name))
     (make-condition-no-check name)]))

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

(set-who! condition-name
  (lambda (c)
    (unless (thread-condition? c) ($oops who "~s is not a condition" c))
    ($condition-name c)))

(set! condition-wait
  (case-lambda
   [(c m) (condition-wait c m #f)]
   [(c m t)
    (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))
    (unless (or (not t)
		(and (time? t) (memq (time-type t) '(time-duration time-utc))))
      ($oops 'condition-wait "~s is not a time record of type time-duration or time-utc" t))
    (let ([caddr ($condition-addr c)] [maddr ($mutex-addr m)])
      (when (eq? caddr 0)
        ($oops 'condition-wait "condition is defunct"))
      (when (eq? maddr 0)
        ($oops 'condition-wait "mutex is defunct"))
      (let ([r (cw caddr maddr t)])
        (keep-live c)
        (keep-live m)
        r))]))

(set! condition-broadcast
  (lambda (c)
    (unless (thread-condition? c)
      ($oops 'condition-broadcast "~s is not a condition" c))
    (let ([addr ($condition-addr c)])
      (when (eq? addr 0)
        ($oops 'condition-broadcast "condition is defunct"))
      (cb addr))))

(set! condition-signal
  (lambda (c)
    (unless (thread-condition? c)
      ($oops 'condition-signal "~s is not a condition" c))
    (let ([addr ($condition-addr c)])
      (when (eq? addr 0)
        ($oops 'condition-signal "condition is defunct"))
      (cs addr))))

(set! $close-resurrected-mutexes&conditions
  ; called from single-threaded docollect
  (lambda ()
    (let f ()
      (let mg ([m (mutex-guardian)])
        (when m
          (let ([addr ($mutex-addr m)])
	    (unless (eq? addr 0)
	      (mf addr)
              ($mutex-addr-set! m 0)))
          (f))))
    (let f ()
      (let cg ([c (condition-guardian)])
        (when c
	  (let ([addr ($condition-addr c)])
	    (unless (eq? addr 0)
	      (cf addr)
              ($condition-addr-set! c 0)))
          (f))))))

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

(set! get-initial-thread
  (let ([thread (car (ts))])
    (lambda () thread)))
))
(begin
(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 $current-mso (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure 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))) "a valid optimize level" 0)
  (define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "a valid compile-profile flag" #f)
  (define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "a valid subset mode" #f)
  (define-tc-parameter default-record-equal-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
  (define-tc-parameter default-record-hash-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
  (define-tc-parameter current-errno-source (lambda (x) (memq x (if-feature windows '(#f msvcrt ucrt) '(#f)))) "a valid errno source")
)

(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-procedure-source-information #f)
  (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!)
)

(constant-case architecture
  [(pb)
   ;; can't inline seginfo access
   (define-who $maybe-seginfo
     (lambda (x) ($oops who "unsupported for pb")))
   (define-who $seginfo
     (lambda (x) ($oops who "unsupported for pb")))
   (define-who $seginfo-generation
     (lambda (x) ($oops who "unsupported for pb")))
   (define-who $seginfo-space
     (lambda (x) ($oops who "unsupported for pb")))
   (define-who $generation
     (foreign-procedure __atomic "(cs)generation" (scheme-object) scheme-object))
   (define-who $list-bits-ref
     (let ([list_bits_ref (foreign-procedure __atomic "(cs)list_bits_ref" (ptr) ptr)])
       (lambda (x)
         (unless (pair? x) ($oops who "~s is not a pair" x))
         (list_bits_ref x))))
   (define-who $list-bits-set!
     (foreign-procedure __atomic __alloc "(cs)list_bits_set" (ptr iptr) void))]
  [else
   (define $generation
     (lambda (x)
       ($generation x)))
   (define $maybe-seginfo
     (lambda (x)
       ($maybe-seginfo x)))
   (define $seginfo
     (lambda (x)
       ($seginfo x)))
   (define $seginfo-generation
     (lambda (x)
       ($seginfo-generation x)))
   (define $seginfo-space
     (lambda (x)
       ($seginfo-space x)))
   (define-who $list-bits-ref
     (lambda (x)
       (unless (pair? x) ($oops who "~s is not a pair" x))
       ($list-bits-ref x)))
   (define-who $list-bits-set!
     (foreign-procedure __atomic __alloc "(cs)list_bits_set" (ptr iptr) void))])

(let ()
  (define $phantom-bytevector-adjust!
    (foreign-procedure "(cs)phantom_bytevector_adjust"
      (scheme-object uptr)
      void))
  
  (set-who! phantom-bytevector?
    (lambda (v) (phantom-bytevector? v)))

  (set-who! $make-phantom-bytevector
    (lambda () (#3%$make-phantom-bytevector)))

  (set-who! make-phantom-bytevector
    (lambda (n)
      (define addr?
        (constant-case ptr-bits
          [(32) $integer-32?]
          [(64) $integer-64?]))
      (unless (and (addr? n) (>= n 0))
        ($oops who "~s is not a valid phantom bytevector length" n))
      (let ([ph ($make-phantom-bytevector)])
        ($phantom-bytevector-adjust! ph n)
        ph)))
  
  (set-who! phantom-bytevector-length
    (lambda (ph)
      (unless (phantom-bytevector? ph) ($oops who "~s is not a phantom bytevector" ph))
      (#3%phantom-bytevector-length ph)))
  
  (set-who! set-phantom-bytevector-length!
    (lambda (ph n)
      (define addr?
        (constant-case ptr-bits
          [(32) $integer-32?]
          [(64) $integer-64?]))
      (unless (phantom-bytevector? ph) ($oops who "~s is not a phantom bytevector" ph))
      (unless (and (addr? n) (>= n 0))
        ($oops who "~s is not a valid phantom bytevector length" n))
      ($phantom-bytevector-adjust! ph n))))

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

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

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

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

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

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

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

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

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

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

(define put-registry!
  (let ([fp (foreign-procedure "(windows)PutRegistry"
              (wstring wstring)
              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"
              (wstring)
              void)])
    (lambda (s)
      (unless (string? s) ($oops 'remove-registry! "~s is not a string" s))
      (fp s))))
)

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

(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 $use-trap-fuel
  (lambda (n shift)
    (unless (fixnum? n) ($oops '$use-trap-fuel "~s is not a fixnum" n))
    (unless (and (fixnum? shift) ($fxu< shift (constant fixnum-bits)))
      ($oops '$use-trap-fuel "invalid shift count ~s" shift))
    ($use-trap-fuel n shift)))

(define $byte-copy!
  (let ([byte-copy! (foreign-procedure __atomic "(cs)byte-copy"
                      (scheme-object fixnum scheme-object fixnum fixnum)
                      void)])
    (lambda (src srcoff dst dstoff cnt)
      (byte-copy! src srcoff dst dstoff cnt)
      ($use-trap-fuel cnt (+ (constant fuel-word-count-shift) (constant log2-ptr-bytes))))))

(define $ptr-copy!
  (let ([ptr-copy! (foreign-procedure __atomic "(cs)ptr-copy"
                     (scheme-object fixnum scheme-object fixnum fixnum)
                     void)])
    (lambda (src srcoff dst dstoff cnt)
      (ptr-copy! src srcoff dst dstoff cnt)
      ($use-trap-fuel cnt (constant fuel-word-count-shift)))))

(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-who ($sealed-record-instance? x rtd)
  (unless (record? x)
    ($oops who "~s is not a record" x))
  (unless (record-type-descriptor? rtd)
    ($oops who "~s is not a record type descriptor" rtd))
  (#3%$sealed-record-instance? x rtd))

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

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

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

;; Assumes that the record that has only pointer fields:
(define-who ($record-type-field-count rtd)
  (unless (record-type-descriptor? rtd)
    ($oops who "~s is not a record type descriptor" rtd))
  ($record-type-field-count rtd))

(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<= #xc0 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) #\xfffd (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 (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 (native-endianness) 2)
                   (if (fx= BOM #xfffe)
                       (slurp bv (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 (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 (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 (native-endianness) 4)
                   (if (= BOM #xfffe0000)
                       (slurp bv (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 (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 __atomic "(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)))

(define keep-live
  (lambda (x)
    (#2%keep-live x)))

(define black-box
  (lambda (x)
    (#2%black-box x)))

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

(define-who $make-wrapper-procedure
  (lambda (proc arity-mask)
    (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
    (unless (or (fixnum? arity-mask) (bignum? arity-mask)) ($oops who "~s is not an arity mask" arity-mask))
    (#3%$make-wrapper-procedure proc arity-mask)))

(define-who make-wrapper-procedure
  (lambda (proc arity-mask data)
    (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
    (unless (or (fixnum? arity-mask) (bignum? arity-mask)) ($oops who "~s is not an arity mask" arity-mask))
    (#3%make-wrapper-procedure proc arity-mask data)))

(define-who make-arity-wrapper-procedure
  (lambda (proc arity-mask data)
    (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
    (unless (or (fixnum? arity-mask) (bignum? arity-mask)) ($oops who "~s is not an arity mask" arity-mask))
    (#3%make-arity-wrapper-procedure proc arity-mask data)))

(define-who wrapper-procedure?
  (lambda (x)
    (and (procedure? x)
         (let ([c ($closure-code x)])
           (and ($code-arity-in-closure? c)
                ;; Indirect way of distinguishing from `$make-wrapper-procedure` result:
                ($code-mutable-closure? c))))))

(define-who wrapper-procedure-procedure
  (lambda (x)
    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
    ($closure-ref x 0)))

(define-who set-wrapper-procedure-procedure!
  (lambda (x proc)
    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
    (unless (procedure? proc)  ($oops who "~s is not a procedure" proc))
    ($closure-set! x 0 proc)))

(define-who wrapper-procedure-data
  (lambda (x)
    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
    ($closure-ref x 2)))

(define-who set-wrapper-procedure-data!
  (lambda (x v)
    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
    ($closure-set! x 2 v)))

)
