chez-openbsd/ta6ob/s/library.ss

;;; library.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.

;;; Library entries should not contain references that could themselves
;;; compile into library entries.  (Actually it will work as long as the
;;; use follows the definition, but...)  Consequently they should be
;;; kept simple.

(eval-when (compile)
   (optimize-level 3)
   (generate-inspector-information #f)
   ($compile-profile #f)
   ($optimize-closures #t)
   (run-cp0 (default-run-cp0))
   (generate-interrupt-trap #f)
   ($track-dynamic-closure-counts #f))

(eval-when (compile)
(define-syntax define-library-entry
  (lambda (x)
    (define name->libspec
      (lambda (name)
        (or ($sgetprop name '*libspec* #f)
            ($oops 'define-library-entry "~s is undefined" name))))
    (define name->does-not-expect-headroom-libspec
      (lambda (name)
        (or ($sgetprop name '*does-not-expect-headroom-libspec* #f)
            ($oops 'define-library-entry "~s is missing no headroom libspec" name))))
    (syntax-case x ()
      [(_ (name . args) e1 e2 ...)
       (identifier? #'name)
       (let ([libspec (name->libspec (datum name))]
             [does-not-expect-headroom-libspec (name->does-not-expect-headroom-libspec (datum name))])
         (with-syntax ([index (libspec-index libspec)]
                       [does-not-expect-headroom-index (libspec-index does-not-expect-headroom-libspec)]
                       [libspec (datum->syntax #'name libspec)]
                       [does-not-expect-headroom-libspec (datum->syntax #'name does-not-expect-headroom-libspec)])
           ; NB: we are duplicating code here, because looking up the library entry fails on startup.
           #'(begin
               ($install-library-entry
                 'index
                 (case-lambda libspec (args e1 e2 ...)))
               ($install-library-entry
                 'does-not-expect-headroom-index
                 (case-lambda does-not-expect-headroom-libspec (args e1 e2 ...))))))])))
)

; we can't evaluate any dirty writes (eg. defines) until scan-remembered-set
; is ready, so install it up front.
(let ([install-library-entry ($hand-coded '$install-library-entry-procedure)])
  (install-library-entry
    (libspec-index (lookup-libspec scan-remembered-set))
    ($hand-coded 'scan-remembered-set)))

(let ([install-library-entry ($hand-coded '$install-library-entry-procedure)])
 ; no top-level defines before this point, or the linker won't have
 ; nonprocedure-code to insert in pvalue slot
  (install-library-entry
    (libspec-index (lookup-libspec nonprocedure-code))
    ($hand-coded 'nonprocedure-code)))

(define $foreign-entry ($hand-coded '$foreign-entry-procedure))
(define $install-library-entry
  ($hand-coded '$install-library-entry-procedure))

(eval-when (compile)
(define-syntax define-hand-coded-library-entry
  (lambda (x)
    (syntax-case x ()
      ((_ name)
       (identifier? #'name)
       #'($install-library-entry (libspec-index (lookup-libspec name))
           ($hand-coded 'name))))))
)

(define-hand-coded-library-entry get-room)
(define-hand-coded-library-entry call-error)
(define-hand-coded-library-entry dooverflood)
(define-hand-coded-library-entry dooverflow)
(define-hand-coded-library-entry dorest0)
(define-hand-coded-library-entry dorest1)
(define-hand-coded-library-entry dorest2)
(define-hand-coded-library-entry dorest3)
(define-hand-coded-library-entry dorest4)
(define-hand-coded-library-entry dorest5)
;;; doargerr must come before dounderflow*
(define-hand-coded-library-entry doargerr)

;;; dounderflow* must come before dounderflow
(define-library-entry (dounderflow* k args)
  ($do-wind ($current-winders) ($continuation-winders k))
  (cond
    ((null? args) (k))
    ((null? (cdr args)) (k (car args)))
    (else (#2%apply k args)))) ; library apply not available yet

;;; dounderflow & nuate must come before callcc
(define-hand-coded-library-entry dounderflow)
(define-hand-coded-library-entry nuate)
(define-hand-coded-library-entry callcc)
(define-hand-coded-library-entry call1cc)
(define-hand-coded-library-entry dofargint32)
(define-hand-coded-library-entry dofretint32)
(define-hand-coded-library-entry dofretuns32)
(define-hand-coded-library-entry dofargint64)
(define-hand-coded-library-entry dofretint64)
(define-hand-coded-library-entry dofretuns64)
(define-hand-coded-library-entry dofretu8*)
(define-hand-coded-library-entry dofretu16*)
(define-hand-coded-library-entry dofretu32*)
(define-hand-coded-library-entry domvleterr)
(define-hand-coded-library-entry values-error)
(define-hand-coded-library-entry bytevector=?)

(define $instantiate-code-object ($hand-coded '$instantiate-code-object))

;;; set up $nuate for overflow
(define $nuate ($closure-code (call/1cc (lambda (k) k))))

(set! #{raw-ref-count bhowt6w0coxl0s2y-1} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{raw-create-count bhowt6w0coxl0s2y-2} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{raw-alloc-count bhowt6w0coxl0s2y-3} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{ref-count bhowt6w0coxl0s2y-4} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{pair-create-count bhowt6w0coxl0s2y-5} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{vector-create-count bhowt6w0coxl0s2y-6} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{vector-alloc-count bhowt6w0coxl0s2y-8} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{padded-vector-alloc-count bhowt6w0coxl0s2y-11} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{closure-create-count bhowt6w0coxl0s2y-7} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{closure-alloc-count bhowt6w0coxl0s2y-9} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
(set! #{padded-closure-alloc-count bhowt6w0coxl0s2y-10} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])

(let ()
  (include "hashtable-types.ss")
  (set! $eq-ht-rtd (record-type-descriptor eq-ht))
  (set! $symbol-ht-rtd (record-type-descriptor symbol-ht)))

(define-library-entry (cfl* x y)
   ;; a+bi * c+di => ac-bd + (ad+bc)i
   ;; spurious overflows
   (cond
      [(flonum? x)
       (if (flonum? y)
           (fl* x y)
           (fl-make-rectangular
              (fl* x ($inexactnum-real-part y))
              (fl* x ($inexactnum-imag-part y))))]
      [(flonum? y)
       (fl-make-rectangular
          (fl* ($inexactnum-real-part x) y)
          (fl* ($inexactnum-imag-part x) y))]
      [else
       (let ([a ($inexactnum-real-part x)] [b ($inexactnum-imag-part x)]
             [c ($inexactnum-real-part y)] [d ($inexactnum-imag-part y)])
          (fl-make-rectangular
             (fl- (fl* a c) (fl* b d))
             (fl+ (fl* a d) (fl* b c))))]))

(define-library-entry (cfl+ x y)
   ;; a+bi + c+di => (a+c) + (b+d)i
   (cond
      [(flonum? x)
       (if (flonum? y)
           (fl+ x y)
           (fl-make-rectangular
              (fl+ x ($inexactnum-real-part y))
              ($inexactnum-imag-part y)))]
      [(flonum? y)
       (fl-make-rectangular
          (fl+ ($inexactnum-real-part x) y)
          ($inexactnum-imag-part x))]
      [else
       (fl-make-rectangular
          (fl+ ($inexactnum-real-part x) ($inexactnum-real-part y))
          (fl+ ($inexactnum-imag-part x) ($inexactnum-imag-part y)))]))

(define-library-entry (cfl- x y)
   ;; a+bi - c+di => (a-c) + (b-d)i
   (cond
      [(flonum? x)
       (if (flonum? y)
           (fl- x y)
           (fl-make-rectangular
              (fl- x ($inexactnum-real-part y))
              (fl- ($inexactnum-imag-part y))))]
      [(flonum? y)
       (fl-make-rectangular
          (fl- ($inexactnum-real-part x) y)
          ($inexactnum-imag-part x))]
      [else
       (fl-make-rectangular
          (fl- ($inexactnum-real-part x) ($inexactnum-real-part y))
          (fl- ($inexactnum-imag-part x) ($inexactnum-imag-part y)))]))

(define-library-entry (cfl/ x y)
   ;; spurious overflows, underflows, and division by zero
   (cond
      [(flonum? y)
       ;; a+bi/c => a/c + (b/c)i
       (if (flonum? x)
           (fl/ x y)
           (fl-make-rectangular
              (fl/ ($inexactnum-real-part x) y)
              (fl/ ($inexactnum-imag-part x) y)))]
      [(flonum? x)
       ;; a / c+di => c(a/(cc+dd)) + (-d(a/cc+dd))i
       (let ([c ($inexactnum-real-part y)] [d ($inexactnum-imag-part y)])
          (let ([t (fl/ x (fl+ (fl* c c) (fl* d d)))])
             (fl-make-rectangular (fl* c t) (fl- (fl* d t)))))]
      [else
       ;; a+bi / c+di => (ac+bd)/(cc+dd) + ((bc-ad)/(cc+dd))i
       (let ([a ($inexactnum-real-part x)] [b ($inexactnum-imag-part x)]
             [c ($inexactnum-real-part y)] [d ($inexactnum-imag-part y)])
          (let ([t (fl+ (fl* c c) (fl* d d))])
             (fl-make-rectangular (fl/ (fl+ (fl* a c) (fl* b d)) t)
                                  (fl/ (fl- (fl* b c) (fl* a d)) t))))]))

(let ()
  (define char-oops
    (lambda (who x)
      ($oops who "~s is not a character" x)))
  (define fixnum-oops
    (lambda (who x)
      ($oops who "~s is not a fixnum" x)))
  (define string-oops
    (lambda (who x)
      ($oops who "~s is not a string" x)))
  (define mutable-string-oops
    (lambda (who x)
      ($oops who "~s is not a mutable string" x)))
  (define vector-oops
    (lambda (who x)
      ($oops who "~s is not a vector" x)))
  (define mutable-vector-oops
    (lambda (who x)
      ($oops who "~s is not a mutable vector" x)))
  (define fxvector-oops
    (lambda (who x)
      ($oops who "~s is not an fxvector" x)))
  (define mutable-fxvector-oops
    (lambda (who x)
      ($oops who "~s is not a mutable fxvector" x)))
  (define bytevector-oops
    (lambda (who x)
      ($oops who "~s is not a bytevector" x)))
  (define mutable-bytevector-oops
    (lambda (who x)
      ($oops who "~s is not a mutable bytevector" x)))
  (define index-oops
    (lambda (who x i)
      ($oops who "~s is not a valid index for ~s" i x)))

  (define-library-entry (char->integer x) (char-oops 'char->integer x))

  (define-library-entry (string-ref s i)
    (if (string? s)
        (index-oops 'string-ref s i)
        (string-oops 'string-ref s)))

  (define-library-entry (string-set! s i c)
    (if ($string-set!-check? s i)
        (if (char? c)
            (string-set! s i c)
            (char-oops 'string-set! c))
        (if (mutable-string? s)
            (index-oops 'string-set! s i)
            (mutable-string-oops 'string-set! s))))

  (define-library-entry (string-length s)
    (string-oops 'string-length s))

  (define-library-entry (vector-ref v i)
    (if (vector? v)
        (index-oops 'vector-ref v i)
        (vector-oops 'vector-ref v)))

  (define-library-entry (vector-set! v i x)
    (if (mutable-vector? v)
        (index-oops 'vector-set! v i)
        (mutable-vector-oops 'vector-set! v)))

  (define-library-entry (vector-set-fixnum! v i x)
    (if (fixnum? x)
        (if (mutable-vector? v)
            (index-oops 'vector-set-fixnum! v i)
            (mutable-vector-oops 'vector-set-fixnum! v))
        ($oops 'vector-set-fixnum! "~s is not a fixnum" x)))

  (define-library-entry (vector-length v)
    (vector-oops 'vector-length v))

  (define-library-entry (vector-cas! v i old-x new-x)
    (if (mutable-vector? v)
        (index-oops 'vector-cas! v i)
        (mutable-vector-oops 'vector-cas! v)))

  (define-library-entry (fxvector-ref v i)
    (if (fxvector? v)
        (index-oops 'fxvector-ref v i)
        (fxvector-oops 'fxvector-ref v)))

  (define-library-entry (fxvector-set! v i x)
    (if (mutable-fxvector? v)
        (if (and (fixnum? i) ($fxu< i (fxvector-length v)))
            (fixnum-oops 'fxvector-set! x)
            (index-oops 'fxvector-set! v i))
        (mutable-fxvector-oops 'fxvector-set! v)))

  (define-library-entry (fxvector-length v)
    (fxvector-oops 'fxvector-length v))

  (define-library-entry (bytevector-s8-ref v i)
    (if (bytevector? v)
        (index-oops 'bytevector-s8-ref v i)
        (bytevector-oops 'bytevector-s8-ref v)))

  (define-library-entry (bytevector-u8-ref v i)
    (if (bytevector? v)
        (index-oops 'bytevector-u8-ref v i)
        (bytevector-oops 'bytevector-u8-ref v)))

  (define-library-entry (bytevector-s8-set! v i k)
    (if ($bytevector-set!-check? 8 v i)
        (if (and (fixnum? k) (fx<= -128 k 127))
            (bytevector-s8-set! v i k)
            ($oops 'bytevector-s8-set! "invalid value ~s" k))
        (if (mutable-bytevector? v)
            (index-oops 'bytevector-s8-set! v i)
            (mutable-bytevector-oops 'bytevector-s8-set! v))))

  (define-library-entry (bytevector-u8-set! v i k)
    (if ($bytevector-set!-check? 8 v i)
        (if (and (fixnum? k) (fx<= 0 k 255))
            (bytevector-u8-set! v i k)
            ($oops 'bytevector-u8-set! "invalid value ~s" k))
        (if (mutable-bytevector? v)
            (index-oops 'bytevector-u8-set! v i)
            (mutable-bytevector-oops 'bytevector-u8-set! v))))

  (define-library-entry (bytevector-length v)
    (bytevector-oops 'bytevector-length v))

  (define-library-entry (char=? x y) (char-oops 'char=? (if (char? x) y x)))
  (define-library-entry (char<? x y) (char-oops 'char<? (if (char? x) y x)))
  (define-library-entry (char>? x y) (char-oops 'char>? (if (char? x) y x)))
  (define-library-entry (char<=? x y) (char-oops 'char<=? (if (char? x) y x)))
  (define-library-entry (char>=? x y) (char-oops 'char>=? (if (char? x) y x)))
)

(define-library-entry (real->flonum x who)
  (cond
    [(fixnum? x) (fixnum->flonum x)]
    [(or (bignum? x) (ratnum? x)) (inexact x)]
    [(flonum? x) x]
    [else ($oops who "~s is not a real number" x)]))

(let ()
  (define pair-oops
    (lambda (who x)
      ($oops who "~s is not a pair" x)))

  (define-library-entry (car x) (pair-oops 'car x))
  (define-library-entry (cdr x) (pair-oops 'cdr x))
  (define-library-entry (set-car! x y) (pair-oops 'set-car! x))
  (define-library-entry (set-cdr! x y) (pair-oops 'set-cdr! x))
)

(let ()
  (define c..r-oops
    (lambda (who obj)
      ($oops who "incorrect list structure ~s" obj)))

  (define-library-entry (caar x) (c..r-oops 'caar x))
  (define-library-entry (cadr x) (c..r-oops 'cadr x))
  (define-library-entry (cdar x) (c..r-oops 'cdar x))
  (define-library-entry (cddr x) (c..r-oops 'cddr x))
  (define-library-entry (caaar x) (c..r-oops 'caaar x))
  (define-library-entry (caadr x) (c..r-oops 'caadr x))
  (define-library-entry (cadar x) (c..r-oops 'cadar x))
  (define-library-entry (caddr x) (c..r-oops 'caddr x))
  (define-library-entry (cdaar x) (c..r-oops 'cdaar x))
  (define-library-entry (cdadr x) (c..r-oops 'cdadr x))
  (define-library-entry (cddar x) (c..r-oops 'cddar x))
  (define-library-entry (cdddr x) (c..r-oops 'cdddr x))
  (define-library-entry (caaaar x) (c..r-oops 'caaaar x))
  (define-library-entry (caaadr x) (c..r-oops 'caaadr x))
  (define-library-entry (caadar x) (c..r-oops 'caadar x))
  (define-library-entry (caaddr x) (c..r-oops 'caaddr x))
  (define-library-entry (cadaar x) (c..r-oops 'cadaar x))
  (define-library-entry (cadadr x) (c..r-oops 'cadadr x))
  (define-library-entry (caddar x) (c..r-oops 'caddar x))
  (define-library-entry (cadddr x) (c..r-oops 'cadddr x))
  (define-library-entry (cdaaar x) (c..r-oops 'cdaaar x))
  (define-library-entry (cdaadr x) (c..r-oops 'cdaadr x))
  (define-library-entry (cdadar x) (c..r-oops 'cdadar x))
  (define-library-entry (cdaddr x) (c..r-oops 'cdaddr x))
  (define-library-entry (cddaar x) (c..r-oops 'cddaar x))
  (define-library-entry (cddadr x) (c..r-oops 'cddadr x))
  (define-library-entry (cdddar x) (c..r-oops 'cdddar x))
  (define-library-entry (cddddr x) (c..r-oops 'cddddr x))
)

(define-library-entry (unbox x)
  ($oops 'unbox "~s is not a box" x))

(define-library-entry (set-box! b v)
  ($oops 'set-box! "~s is not a mutable box" b))

(define-library-entry (box-cas! b old-v new-v)
  ($oops 'box-cas! "~s is not a mutable box" b))

(let ()
(define (fxnonfixnum1 who x)
  ($oops who "~s is not a fixnum" x))

(define (fxnonfixnum2 who x y)
  ($oops who "~s is not a fixnum" (if (fixnum? x) y x)))

(define (fxoops1 who x)
   (if (fixnum? x)
       ($impoops who "fixnum overflow with argument ~s" x)
       (fxnonfixnum1 who x)))

(define (fxoops2 who x y)
   (if (fixnum? x)
       (if (fixnum? y)
           ($impoops who "fixnum overflow with arguments ~s and ~s" x y)
           (fxnonfixnum1 who y))
       (fxnonfixnum1 who x)))

(define (shift-count-oops who x)
  ($oops who "invalid shift count ~s" x))

(define-library-entry (fx+ x y) (fxoops2 'fx+ x y))
(define-library-entry (fx- x y) (fxoops2 'fx- x y))
(define-library-entry (fx* x y) (fxoops2 'fx* x y))
(define-library-entry (fx1+ x) (fxoops1 'fx1+ x))
(define-library-entry (fx1- x) (fxoops1 'fx1- x))

(define-library-entry (fx= x y) (fxnonfixnum2 'fx= x y))
(define-library-entry (fx< x y) (fxnonfixnum2 'fx< x y))
(define-library-entry (fx> x y) (fxnonfixnum2 'fx> x y))
(define-library-entry (fx<= x y) (fxnonfixnum2 'fx<= x y))
(define-library-entry (fx>= x y) (fxnonfixnum2 'fx>= x y))
(define-library-entry (fx=? x y) (fxnonfixnum2 'fx=? x y))
(define-library-entry (fx<? x y) (fxnonfixnum2 'fx<? x y))
(define-library-entry (fx>? x y) (fxnonfixnum2 'fx>? x y))
(define-library-entry (fx<=? x y) (fxnonfixnum2 'fx<=? x y))
(define-library-entry (fx>=? x y) (fxnonfixnum2 'fx>=? x y))
(define-library-entry (fxzero? x) (fxnonfixnum1 'fxzero? x))
(define-library-entry (fxpositive? x) (fxnonfixnum1 'fxpositive? x))
(define-library-entry (fxnonpositive? x) (fxnonfixnum1 'fxnonpositive? x))
(define-library-entry (fxnegative? x) (fxnonfixnum1 'fxnegative? x))
(define-library-entry (fxnonnegative? x) (fxnonfixnum1 'fxnonnegative? x))
(define-library-entry (fxeven? x) (fxnonfixnum1 'fxeven? x))
(define-library-entry (fxodd? x) (fxnonfixnum1 'fxodd? x))
(define-library-entry (fxlogior x y) (fxnonfixnum2 'fxlogior x y))
(define-library-entry (fxlogor x y) (fxnonfixnum2 'fxlogor x y))
(define-library-entry (fxlogxor x y) (fxnonfixnum2 'fxlogxor x y))
(define-library-entry (fxlogand x y) (fxnonfixnum2 'fxlogand x y))
(define-library-entry (fxlognot x) (fxnonfixnum1 'fxlognot x))
(define-library-entry (fxior x y) (fxnonfixnum2 'fxior x y))
(define-library-entry (fxxor x y) (fxnonfixnum2 'fxxor x y))
(define-library-entry (fxand x y) (fxnonfixnum2 'fxand x y))
(define-library-entry (fxnot x) (fxnonfixnum1 'fxnot x))

(define-library-entry (fxsll x y)
  (cond
    [(not (fixnum? x)) (fxnonfixnum1 'fxsll x)]
    [(not (fixnum? y)) (fxnonfixnum1 'fxsll y)]
    [(fx= 0 y) x]
    [($fxu< y (constant fixnum-bits))
     (if (fx>= x 0)
         (if (fx< x (fxsll 1 (fx- (- (constant fixnum-bits) 1) y)))
             (fxsll x y)
             (fxoops2 'fxsll x y))
         (if (fx>= x (fxsll -1 (fx- (- (constant fixnum-bits) 1) y)))
             (fxsll x y)
             (fxoops2 'fxsll x y)))]
    [(fx= y (constant fixnum-bits)) (if (fx= x 0) x (fxoops2 'fxsll x y))]
    [else (shift-count-oops 'fxsll y)]))

(define-library-entry (fxarithmetic-shift-left x y)
  (cond
    [(not (fixnum? x)) (fxnonfixnum1 'fxarithmetic-shift-left x)]
    [(not (fixnum? y)) (fxnonfixnum1 'fxarithmetic-shift-left y)]
    [(fx= 0 y) x]
    [($fxu< y (constant fixnum-bits))
     (if (fx>= x 0)
         (if (fx< x (fxsll 1 (fx- (- (constant fixnum-bits) 1) y)))
             (fxsll x y)
             (fxoops2 'fxarithmetic-shift-left x y))
         (if (fx>= x (fxsll -1 (fx- (- (constant fixnum-bits) 1) y)))
             (fxsll x y)
             (fxoops2 'fxarithmetic-shift-left x y)))]
    [else (shift-count-oops 'fxarithmetic-shift-left y)]))

(define-library-entry (fxsrl x y)
  (cond
    [(not (fixnum? x)) (fxnonfixnum1 'fxsrl x)]
    [(not (fixnum? y)) (fxnonfixnum1 'fxsrl y)]
    [else (shift-count-oops 'fxsrl y)]))

(define-library-entry (fxsra x y)
  (cond
    [(not (fixnum? x)) (fxnonfixnum1 'fxsra x)]
    [(not (fixnum? y)) (fxnonfixnum1 'fxsra y)]
    [else (shift-count-oops 'fxsra y)]))

(define-library-entry (fxarithmetic-shift-right x y)
  (cond
    [(not (fixnum? x)) (fxnonfixnum1 'fxarithmetic-shift-right x)]
    [(not (fixnum? y)) (fxnonfixnum1 'fxarithmetic-shift-right y)]
    [else (shift-count-oops 'fxarithmetic-shift-right y)]))

(define-library-entry (fxarithmetic-shift x y)
  (cond
    [(not (fixnum? x)) (fxnonfixnum1 'fxarithmetic-shift x)]
    [(not (fixnum? y)) (fxnonfixnum1 'fxarithmetic-shift y)]
    [(fx= 0 y) x]
    [($fxu< y (constant fixnum-bits))
     (if (fx>= x 0)
         (if (fx< x (fxsll 1 (fx- (- (constant fixnum-bits) 1) y)))
             (fxsll x y)
             (fxoops2 'fxarithmetic-shift x y))
         (if (fx>= x (fxsll -1 (fx- (- (constant fixnum-bits) 1) y)))
             (fxsll x y)
             (fxoops2 'fxarithmetic-shift x y)))]
    [(fx< (fx- (constant fixnum-bits)) y 0) (fxsra x (fx- y))]
    [else (shift-count-oops 'fxarithmetic-shift y)]))

(define-library-entry (fxlogbit? k n)
  (if (fixnum? n)
      (if (fixnum? k)
          (if (fx< k 0)
              ($oops 'fxlogbit? "invalid bit index ~s" k)
             ; this case left to us by cp1in fxlogbit? handler
              (fx< n 0))
          (fxnonfixnum1 'fxlogbit? k))
      (fxnonfixnum1 'fxlogbit? n)))

(define-library-entry (fxbit-set? n k)
  (if (fixnum? n)
      (if (fixnum? k)
          (if (fx< k 0)
              ($oops 'fxbit-set? "invalid bit index ~s" k)
             ; this case left to us by cp1in fxbit-set? handler
              (fx< n 0))
          (fxnonfixnum1 'fxbit-set? k))
      (fxnonfixnum1 'fxbit-set? n)))

(define-library-entry (fxlogbit0 k n)
  (if (fixnum? n)
      (if (fixnum? k)
          ($oops 'fxlogbit0 "invalid bit index ~s" k)
          (fxnonfixnum1 'fxlogbit0 k))
      (fxnonfixnum1 'fxlogbit0 n)))

(define-library-entry (fxlogbit1 k n)
  (if (fixnum? n)
      (if (fixnum? k)
          ($oops 'fxlogbit1 "invalid bit index ~s" k)
          (fxnonfixnum1 'fxlogbit1 k))
      (fxnonfixnum1 'fxlogbit1 n)))

(define-library-entry (fxcopy-bit n k)
 ; get here only if third argument is 0 or 1
  (if (fixnum? n)
      (if (fixnum? k)
          ($oops 'fxcopy-bit "invalid bit index ~s" k)
          (fxnonfixnum1 'fxcopy-bit k))
      (fxnonfixnum1 'fxcopy-bit n)))

(define-library-entry (fxlogtest x y) (fxnonfixnum2 'fxlogtest x y))
)

(let ()
  (define flonum-oops
    (lambda (who x)
      ($oops who "~s is not a flonum" x)))

  (define-library-entry (fl= x y) (flonum-oops 'fl= (if (flonum? x) y x)))
  (define-library-entry (fl< x y) (flonum-oops 'fl< (if (flonum? x) y x)))
  (define-library-entry (fl> x y) (flonum-oops 'fl> (if (flonum? x) y x)))
  (define-library-entry (fl<= x y) (flonum-oops 'fl<= (if (flonum? x) y x)))
  (define-library-entry (fl>= x y) (flonum-oops 'fl>= (if (flonum? x) y x)))
  (define-library-entry (fl=? x y) (flonum-oops 'fl=? (if (flonum? x) y x)))
  (define-library-entry (fl<? x y) (flonum-oops 'fl<? (if (flonum? x) y x)))
  (define-library-entry (fl>? x y) (flonum-oops 'fl>? (if (flonum? x) y x)))
  (define-library-entry (fl<=? x y) (flonum-oops 'fl<=? (if (flonum? x) y x)))
  (define-library-entry (fl>=? x y) (flonum-oops 'fl>=? (if (flonum? x) y x)))

  (define-library-entry (fl+ x y) (flonum-oops 'fl+ (if (flonum? x) y x)))
  (define-library-entry (fl- x y) (flonum-oops 'fl- (if (flonum? x) y x)))
  (define-library-entry (fl* x y) (flonum-oops 'fl* (if (flonum? x) y x)))
  (define-library-entry (fl/ x y) (flonum-oops 'fl/ (if (flonum? x) y x)))
  (define-library-entry (flnegate x) (flonum-oops 'fl- x))
)

(define-library-entry (flround x)
 ; assumes round-to-nearest-or-even
  (float-type-case
    [(ieee)
     (define threshold+ #i#x10000000000000)
     (define threshold- #i#x-10000000000000)])
  (if (fl>= x 0.0)
      (if (fl< x threshold+)
          (fl- (fl+ x threshold+) threshold+)
          x)
      (if (fl> x threshold-)
          (fl- (fl+ x threshold-) threshold-)
          x)))

;;; The generic comparison entries assume the fixnum case is inlined.

(define-library-entry (= x y)
   (cond
      [(flonum? x)
       (cond 
          [(flonum? y) (fl= x y)]
          [($inexactnum? y) (and (fl= ($inexactnum-imag-part y) 0.0)
                                  (fl= ($inexactnum-real-part y) x))]
          [else ($= '= x y)])]
      [($inexactnum? x)
       (cond 
          [(flonum? y) (and (fl= ($inexactnum-imag-part x) 0.0)
                            (fl= ($inexactnum-real-part x) y))]
          [($inexactnum? y)
           (and (fl= ($inexactnum-imag-part x) ($inexactnum-imag-part y))
                (fl= ($inexactnum-real-part x) ($inexactnum-real-part y)))]
          [else ($= '= x y)])]
      [else ($= '= x y)]))

(define-library-entry (zero? x)
   (cond
      [(cflonum? x) (cfl= x 0.0)]
      [(or (bignum? x) (ratnum? x) ($exactnum? x)) #f]
      [else ($= 'zero? x 0)]))

(define-library-entry (< x y)
   (cond
      [(and (flonum? x) (flonum? y)) (fl< x y)]
      [else ($< '< x y)]))

(define-library-entry (> x y)
   (cond
      [(and (flonum? x) (flonum? y)) (fl> x y)]
      [else ($< '> y x)]))

(define-library-entry (<= x y)
   (cond
      [(and (flonum? x) (flonum? y)) (fl<= x y)]
      [else ($<= '<= x y)]))

(define-library-entry (>= x y)
   (cond
      [(and (flonum? x) (flonum? y)) (fl>= x y)]
      [else ($<= '>= y x)]))

(define-library-entry (+ x y)
   (cond
      [(flonum? x)
       (cond
          [(flonum? y) (fl+ x y)]
          [($inexactnum? y) (cfl+ x y)]
          [else ($+ '+ x y)])]
      [(and ($inexactnum? x) (cflonum? y)) (cfl+ x y)]
      [else ($+ '+ x y)]))

(define-library-entry (1+ x)
   (cond
      [(flonum? x) (fl+ x 1.0)]
      [($inexactnum? x) (cfl+ x 1.0)]
      [else ($+ '1+ x 1)]))

(define-library-entry (add1 x)
   (cond
      [(flonum? x) (fl+ x 1.0)]
      [($inexactnum? x) (cfl+ x 1.0)]
      [else ($+ 'add1 x 1)]))

(define-library-entry (negate x)
   (cond
      [(flonum? x) (fl- x)]
      [($inexactnum? x) (cfl- x)]
      [else ($- '- 0 x)]))

(define-library-entry (- x y)
   (cond
      [(flonum? x)
       (cond
          [(flonum? y) (fl- x y)]
          [($inexactnum? y) (cfl- x y)]
          [else ($- '- x y)])]
      [(and ($inexactnum? x) (cflonum? y)) (cfl- x y)]
      [else ($- '- x y)]))

(define-library-entry (1- x)
   (cond
      [(flonum? x) (fl- x 1.0)]
      [($inexactnum? x) (cfl- x 1.0)]
      [else ($- '1- x 1)]))

(define-library-entry (-1+ x)
   (cond
      [(flonum? x) (fl- x 1.0)]
      [($inexactnum? x) (cfl- x 1.0)]
      [else ($- '-1+ x 1)]))

(define-library-entry (sub1 x)
   (cond
      [(flonum? x) (fl- x 1.0)]
      [($inexactnum? x) (cfl- x 1.0)]
      [else ($- 'sub1 x 1)]))

(define-library-entry (* x y)
   (cond
      [(flonum? x)
       (cond
          [(flonum? y) (fl* x y)]
          [($inexactnum? y) (cfl* x y)]
          [else ($* '* x y)])]
      [(and ($inexactnum? x) (cflonum? y)) (cfl* x y)]
      [else ($* '* x y)]))

(define-library-entry (/ x y)
   (cond
      [(flonum? x)
       (cond
          [(flonum? y) (fl/ x y)]
          [($inexactnum? y) (cfl/ x y)]
          [else ($/ '/ x y)])]
      [(and ($inexactnum? x) (cflonum? y)) (cfl/ x y)]
      [else ($/ '/  x y)]))

;;; The logical operators assume the fixnum case is inlined.
(let ()
  (define exactintoops1
    (lambda (who x)
      ($oops who "~s is not an exact integer" x)))
  (define exactintoops2
    (lambda (who x y)
      (exactintoops1 who (if (or (fixnum? x) (bignum? x)) y x))))

  (define-library-entry (logand x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logand x y)
        (exactintoops2 'logand x y)))

  (define-library-entry (bitwise-and x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logand x y)
        (exactintoops2 'bitwise-and x y)))

  (define-library-entry (logior x y) ; same as logor
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logor x y)
        (exactintoops2 'logior x y)))

  (define-library-entry (logor x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logor x y)
        (exactintoops2 'logor x y)))

  (define-library-entry (bitwise-ior x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logor x y)
        (exactintoops2 'bitwise-ior x y)))

  (define-library-entry (logxor x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logxor x y)
        (exactintoops2 'logxor x y)))

  (define-library-entry (bitwise-xor x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logxor x y)
        (exactintoops2 'bitwise-xor x y)))

  (define-library-entry (lognot x)
    (if (bignum? x)
        ($lognot x)
        (exactintoops1 'lognot x)))

  (define-library-entry (bitwise-not x)
    (if (bignum? x)
        ($lognot x)
        (exactintoops1 'bitwise-not x)))

  (let ()
    (define (do-logbit? who k n)
      (cond
        [(fixnum? n)
         (cond
           [(fixnum? k)
            (if (fx< k 0)
                ($oops who "invalid bit index ~s" k)
               ; this case left to us by cp1in logbit? handler
                (fx< n 0))]
           [(bignum? k)
            (if (< k 0)
                ($oops who "invalid bit index ~s" k)
               ; this case left to us by cp1in logbit? handler
                (fx< n 0))]
           [else (exactintoops1 who k)])]
        [(bignum? n)
         (cond
           [(fixnum? k)
            (if (fx< k 0)
                ($oops who "invalid bit index ~s" k)
                ($logbit? k n))]
           [(bignum? k)
            (if (< k 0)
                ($oops who "invalid bit index ~s" k)
               ; $logbit? requires k to be a fixnum
                (fxlogtest (ash n (- k)) 1))]
           [else (exactintoops1 who k)])]
        [else (exactintoops1 who n)]))
    (define-library-entry (logbit? k n) (do-logbit? 'logbit? k n))
    (define-library-entry (bitwise-bit-set? n k) (do-logbit? 'bitwise-bit-set? k n)))

  (define-library-entry (logbit0 k n)
    (if (or (fixnum? n) (bignum? n))
        (cond
          [(fixnum? k)
           (if (fx< k 0)
               ($oops 'logbit0 "invalid bit index ~s" k)
               ($logbit0 k n))]
          [(bignum? k)
           (if (< k 0)
               ($oops 'logbit0 "invalid bit index ~s" k)
              ; $logbit0 requires k to be a fixnum
               ($logand n ($lognot (ash 1 k))))]
          [else (exactintoops1 'logbit0 k)])
        (exactintoops1 'logbit0 n)))

  (define-library-entry (logbit1 k n)
    (if (or (fixnum? n) (bignum? n))
        (cond
          [(fixnum? k)
           (if (fx< k 0)
               ($oops 'logbit1 "invalid bit index ~s" k)
               ($logbit1 k n))]
          [(bignum? k)
           (if (< k 0)
               ($oops 'logbit1 "invalid bit index ~s" k)
              ; $logbit1 requires k to be a fixnum
               ($logor n (ash 1 k)))]
          [else (exactintoops1 'logbit1 k)])
        (exactintoops1 'logbit1 n)))

  (define-library-entry (logtest x y)
    (if (if (fixnum? x)
            (bignum? y)
            (and (bignum? x)
                 (or (fixnum? y) (bignum? y))))
        ($logtest x y)
        (exactintoops2 'logtest x y)))
)

(let ()
  (include "io-types.ss")
  (define-syntax define-safe/unsafe
    (lambda (x)
      (syntax-case x ()
        [(k (name arg ...) e ...)
         (with-syntax ([safe-name (construct-name #'k "safe-" #'name)]
                       [unsafe-name (construct-name #'k "unsafe-" #'name)]
                       [who (datum->syntax #'k 'who)]
                       [check (datum->syntax #'k 'check)])
           #'(let ()
               (define who 'name)
               (let ()
                 (define-syntax check (identifier-syntax if))
                 (define-library-entry (safe-name arg ...) e ...))
               (let ()
                 (define-syntax check (syntax-rules () [(_ e1 e2 e3) e2]))
                 (define-library-entry (unsafe-name arg ...) e ...))))])))
  (define-safe/unsafe (get-u8 p)
    (check (and (input-port? p) (binary-port? p))
      ((port-handler-get ($port-handler p)) 'get-u8 p)
      ($oops who "~s is not a binary input port" p)))
  (define-safe/unsafe (get-char p)
    (check (and (input-port? p) (textual-port? p))
      ((port-handler-get ($port-handler p)) who p)
      ($oops who "~s is not a textual input port" p)))
  (define-safe/unsafe (read-char p)
    (check (and (input-port? p) (textual-port? p))
      ((port-handler-get ($port-handler p)) who p)
      ($oops who "~s is not a textual input port" p)))
  (define-safe/unsafe (lookahead-u8 p)
    (check (and (input-port? p) (binary-port? p))
      ((port-handler-lookahead ($port-handler p)) 'lookahead-u8 p)
      ($oops who "~s is not a binary input port" p)))
  (define-safe/unsafe (lookahead-char p)
    (check (and (input-port? p) (textual-port? p))
      ((port-handler-lookahead ($port-handler p)) who p)
      ($oops who "~s is not a textual input port" p)))
  (define-safe/unsafe (peek-char p)
    (check (and (input-port? p) (textual-port? p))
      ((port-handler-lookahead ($port-handler p)) who p)
      ($oops who "~s is not a textual input port" p)))
  (define-safe/unsafe (unget-u8 p x)
    (check (and (input-port? p) (binary-port? p))
      (check (or (and (fixnum? x) (fx<= 0 x 255)) (eof-object? x))
        ((port-handler-unget ($port-handler p)) who p x)
        ($oops who "~s is not an octet or the eof object" x))
      ($oops who "~s is not a binary input port" p)))
  (define-safe/unsafe (unget-char p x)
    (check (and (input-port? p) (textual-port? p))
      (check (or (char? x) (eof-object? x))
        ((port-handler-unget ($port-handler p)) who p x)
        ($oops who "~s is not an character or the eof object" x))
      ($oops who "~s is not a textual input port" p)))
  (define-safe/unsafe (unread-char x p)
    (check (and (input-port? p) (textual-port? p))
      (check (or (char? x) (eof-object? x))
        ((port-handler-unget ($port-handler p)) who p x)
        ($oops who "~s is not an character or the eof object" x))
      ($oops who "~s is not a textual input port" p)))
  (define-safe/unsafe (put-u8 p x)
    (check (and (output-port? p) (binary-port? p))
      (check (and (fixnum? x) (fx<= 0 x 255))
        ((port-handler-put ($port-handler p)) who p x)
        ($oops who "~s is not an octet" x))
      ($oops who "~s is not a binary output port" p)))
  (define-safe/unsafe (put-char p x)
    (check (and (output-port? p) (textual-port? p))
      (check (char? x)
        ((port-handler-put ($port-handler p)) who p x)
        ($oops who "~s is not a character" x))
      ($oops who "~s is not a textual output port" p)))
  (define-safe/unsafe (write-char x p)
    (check (and (output-port? p) (textual-port? p))
      (check (char? x)
        ((port-handler-put ($port-handler p)) who p x)
        ($oops who "~s is not a character" x))
      ($oops who "~s is not a textual output port" p)))
  (define-safe/unsafe (newline p)
    (check (and (output-port? p) (textual-port? p))
      ((port-handler-put ($port-handler p)) who p #\newline)
      ($oops who "~s is not a textual output port" p)))
  (define-safe/unsafe (port-eof? p)
    (check (input-port? p)
      (eof-object? ((port-handler-lookahead ($port-handler p)) who p))
      ($oops who "~s is not an input port" p)))
  (define-library-entry (put-bytevector bop bv start count)
    (define who 'put-bytevector)
    (if (or (fx> count max-put-copy) (fx> count (binary-port-output-count bop)))
        (let ([put-some (port-handler-put-some ($port-handler bop))])
          (let loop ([start start] [count count])
            (unless (eq? 0 count)
              (let ([n (put-some who bop bv start count)])
                (loop (fx+ start n) (fx- count n))))))
        (let ([i (binary-port-output-index bop)])
         ; counting on cp1in generating call to $byte-copy here and
         ; $byte-copy foreign procedure to be compiled w/o interrupt
         ; trap check in prims.ss.  otherwise this won't be safe for
         ; multitasking.
          (bytevector-copy! bv start (binary-port-output-buffer bop) i count)
          (set-binary-port-output-index! bop (fx+ i count)))))
  (define-library-entry (put-bytevector-some bop bv start count)
    (define who 'put-bytevector-some)
    (if (or (fx> count max-put-copy) (fx> count (binary-port-output-count bop)))
        (let ([put-some (port-handler-put-some ($port-handler bop))])
          (put-some who bop bv start count))
        (let ([i (binary-port-output-index bop)])
         ; counting on cp1in generating call to $byte-copy here and
         ; $byte-copy foreign procedure to be compiled w/o interrupt
         ; trap check in prims.ss.  otherwise this won't be safe for
         ; multitasking.
          (bytevector-copy! bv start (binary-port-output-buffer bop) i count)
          (set-binary-port-output-index! bop (fx+ i count))
          count)))
  (define-library-entry (put-string top st start count)
    (define who 'put-string)
    (if (or (fx> count max-put-copy) (fx> count (textual-port-output-count top)))
        (let ([put-some (port-handler-put-some ($port-handler top))])
          (let loop ([start start] [count count])
            (unless (eq? 0 count)
              (let ([n (put-some who top st start count)])
                (loop (fx+ start n) (fx- count n))))))
        (let ([i (textual-port-output-index top)])
         ; counting on cp1in generating call to $byte-copy here and
         ; $byte-copy foreign procedure to be compiled w/o interrupt
         ; trap check in prims.ss.  otherwise this won't be safe for
         ; multitasking.
          (string-copy! st start (textual-port-output-buffer top) i count)
          (set-textual-port-output-index! top (fx+ i count)))))
  (define-library-entry (put-string-some top st start count)
    (define who 'put-string-some)
    (if (or (fx> count max-put-copy) (fx> count (textual-port-output-count top)))
        (let ([put-some (port-handler-put-some ($port-handler top))])
          (put-some who top st start count))
        (let ([i (textual-port-output-index top)])
         ; counting on cp1in generating call to $byte-copy here and
         ; $byte-copy foreign procedure to be compiled w/o interrupt
         ; trap check in prims.ss.  otherwise this won't be safe for
         ; multitasking.
          (string-copy! st start (textual-port-output-buffer top) i count)
          (set-textual-port-output-index! top (fx+ i count))
          count)))
  (define-library-entry (display-string st top)
    (define who 'display-string)
    (let ([start 0] [count (string-length st)])
      (if (or (fx> count max-put-copy) (fx> count (textual-port-output-count top)))
          (let ([put-some (port-handler-put-some ($port-handler top))])
            (let loop ([start start] [count count])
              (unless (eq? 0 count)
                (let ([n (put-some who top st start count)])
                  (loop (fx+ start n) (fx- count n))))))
          (let ([i (textual-port-output-index top)])
           ; counting on cp1in generating call to $byte-copy here and
           ; $byte-copy foreign procedure to be compiled w/o interrupt
           ; trap check in prims.ss.  otherwise this won't be safe for
           ; multitasking.
            (string-copy! st start (textual-port-output-buffer top) i count)
            (set-textual-port-output-index! top (fx+ i count))))))
)

(define-library-entry ($top-level-value x)
  (unless (symbol? x)
    ($oops '$top-level-value "~s is not a symbol" x))
  (unless ($top-level-bound? x)
    ($oops #f "variable ~:s is not bound" x))
  (#3%$top-level-value x))

(define-library-entry (event)
  (define (timer)
    (if (eq? ($tc-field 'timer-ticks ($tc)) 0)
        (let ([handler (timer-interrupt-handler)])
          ($tc-field 'timer-ticks ($tc) #f)
          (signal)
          (handler))
        (signal)))
  (define (signal)
    (let ([x ($tc-field 'signal-interrupt-pending ($tc))])
      (if x
          (let ([handler $signal-interrupt-handler])
            ($tc-field 'signal-interrupt-pending ($tc) #f)
            (keyboard)
            (for-each handler ($dequeue-scheme-signals ($tc))))
          (keyboard))))
  (define (keyboard)
    (if ($tc-field 'keyboard-interrupt-pending ($tc))
        (let ([handler (keyboard-interrupt-handler)])
          ($tc-field 'keyboard-interrupt-pending ($tc) #f)
          (collector)
          (handler))
        (collector)))
  (define (collector)
    (if $collect-request-pending
        (let ([handler $collect-rendezvous])
          (restart-timer)
          (handler))
        (restart-timer)))
  (define (restart-timer)
    (cond
      [($tc-field 'timer-ticks ($tc)) =>
       (lambda (t)
         (let ([ticks (fxmin t (constant default-timer-ticks))])
           ($tc-field 'timer-ticks ($tc) (fx- t ticks))
           ($tc-field 'something-pending ($tc) #t)
           ($set-timer ticks)))]
      [else
       ($set-timer (constant default-timer-ticks))]))
  (if (and (fx= ($tc-field 'disable-count ($tc)) 0) ($tc-field 'something-pending ($tc)))
      (begin
        ($set-timer (most-positive-fixnum))
        ($tc-field 'something-pending ($tc) #f)
        (timer))
      ($set-timer (constant default-timer-ticks))))

(define-library-entry (virtual-register idx)
  ($oops 'virtual-register "invalid index ~s" idx))

(define-library-entry (set-virtual-register! idx)
  ($oops 'set-virtual-register! "invalid index ~s" idx))

(define-library-entry (map1 f ls)
  (let map ([f f] [ls ls])
    (if (null? ls)
        '()
        (let ((r (cdr ls)))
          (if (null? r)
              (list (f (car ls)))
              ; cdr first to avoid getting sick if f mutates input
              (let ([tail (map f (cdr r))])
                (list* (f (car ls)) (f (car r)) tail)))))))

(define-library-entry (map2 f ls1 ls2)
  (let map ([f f] [ls1 ls1] [ls2 ls2])
    (if (null? ls1)
        '()
        (let ((r1 (cdr ls1)))
          (if (null? r1)
              (list (f (car ls1) (car ls2)))
              (let ((r2 (cdr ls2)))
                ; cdr first to avoid getting sick if f mutates input
                (let ([tail (map f (cdr r1) (cdr r2))])
                  (list* (f (car ls1) (car ls2))
                    (f (car r1) (car r2))
                    tail))))))))

(define-library-entry (map-car ls)
  (let map ([ls ls])
    (if (null? ls)
        '()
        (let ((r (cdr ls)))
          (if (null? r)
              (list (car (car ls)))
              (list* (car (car ls)) (car (car r)) (map (cdr r))))))))

(define-library-entry (map-cdr ls)
  (let map ([ls ls])
    (if (null? ls)
        '()
        (let ((r (cdr ls)))
          (if (null? r)
              (list (cdr (car ls)))
              (list* (cdr (car ls)) (cdr (car r)) (map (cdr r))))))))

(define-library-entry (map-cons ls1 ls2)
  (let map ([ls1 ls1] [ls2 ls2])
    (if (null? ls1)
        '()
        (let ((r1 (cdr ls1)))
          (if (null? r1)
              (list (cons (car ls1) (car ls2)))
              (let ((r2 (cdr ls2)))
                (list* (cons (car ls1) (car ls2))
                  (cons (car r1) (car r2))
                  (map (cdr r1) (cdr r2)))))))))

(define-library-entry (for-each1 f ls)
  (unless (null? ls)
    (let for-each ([x (car ls)] [ls (cdr ls)])
      (if (null? ls)
          (f x)
          (begin
            (f x)
            (for-each (car ls) (cdr ls)))))))

(define-library-entry (for-each2 f ls1 ls2)
  (unless (null? ls1)
    (let for-each ([x (car ls1)] [ls1 (cdr ls1)] [ls2 ls2])
      (if (null? ls1)
          (f x (car ls2))
          (begin
            (f x (car ls2))
            (for-each (car ls1) (cdr ls1) (cdr ls2)))))))

(define-library-entry (andmap1 f ls)
  (or (null? ls)
      (let andmap ([ls ls])
        (let ([x (car ls)] [ls (cdr ls)])
          (if (null? ls)
              (f x)
              (and (f x) (andmap ls)))))))

(define-library-entry (ormap1 f ls)
  (and (not (null? ls))
       (let ormap ([ls ls])
         (let ([x (car ls)] [ls (cdr ls)])
           (if (null? ls)
               (f x)
               (or (f x) (ormap ls)))))))

(define-library-entry (vector-for-each1 p v)
  (let ([n (vector-length v)])
    (unless (fx= n 0)
      (let loop ([i 0])
        (let ([j (fx+ i 1)])
          (if (fx= j n)
              (p (vector-ref v i))
              (begin
                (p (vector-ref v i))
                (loop j))))))))

(define-library-entry (vector-for-each2 p u v)
  (let ([n (vector-length u)])
    (unless (fx= n 0)
      (let loop ([i 0])
        (let ([j (fx+ i 1)])
          (if (fx= j n)
              (p (vector-ref u i) (vector-ref v i))
              (begin
                (p (vector-ref u i) (vector-ref v i))
                (loop j))))))))

(define-library-entry (vector-map1 p v)
  (let ([n (vector-length v)])
    (let f ([i (fx- n 1)])
      (if (fx> i 0)
          (let ([x1 (p (vector-ref v i))] [x2 (p (vector-ref v (fx- i 1)))])
            (let ([vout (f (fx- i 2))])
              (vector-set! vout i x1)
              (vector-set! vout (fx- i 1) x2)
              vout))
          (make-vector n (if (fx= i 0) (p (vector-ref v 0)) 0))))))

(define-library-entry (vector-map2 p u v)
  (let ([n (vector-length u)])
    (let f ([i (fx- n 1)])
      (if (fx> i 0)
          (let ([x1 (p (vector-ref u i) (vector-ref v i))]
                [x2 (let ([j (fx- i 1)])
                      (p (vector-ref u j) (vector-ref v j)))])
            (let ([vout (f (fx- i 2))])
              (vector-set! vout i x1)
              (vector-set! vout (fx- i 1) x2)
              vout))
          (make-vector n
            (if (fx= i 0)
                (p (vector-ref u 0) (vector-ref v 0))
                0))))))

(define-library-entry (string-for-each1 p s)
  (let ([n (string-length s)])
    (unless (fx= n 0)
      (let loop ([i 0])
        (let ([j (fx+ i 1)])
          (if (fx= j n)
              (p (string-ref s i))
              (begin
                (p (string-ref s i))
                (loop j))))))))

(define-library-entry (string-for-each2 p s t)
  (let ([n (string-length s)])
    (unless (fx= n 0)
      (let loop ([i 0])
        (let ([j (fx+ i 1)])
          (if (fx= j n)
              (p (string-ref s i) (string-ref t i))
              (begin
                (p (string-ref s i) (string-ref t i))
                (loop j))))))))

(define-library-entry (fold-left1 combine nil ls)
  (if (null? ls)
      nil
      (let fold-left ([ls ls] [acc nil])
        (let ([cdrls (cdr ls)])
          (if (null? cdrls)
              (combine acc (car ls))
              (fold-left cdrls (combine acc (car ls))))))))

(define-library-entry (fold-left2 combine nil ls1 ls2)
  (if (null? ls1)
      nil
      (let fold-left ([ls1 ls1] [ls2 ls2] [acc nil])
        (let ([cdrls1 (cdr ls1)])
          (if (null? cdrls1)
              (combine acc (car ls1) (car ls2))
              (fold-left cdrls1 (cdr ls2)
                (combine acc (car ls1) (car ls2))))))))

(define-library-entry (fold-right1 combine nil ls)
  (let fold-right1 ([combine combine] [nil nil] [ls ls])
    (if (null? ls)
        nil
        ; naturally does cdrs first to avoid mutation sickness
        (combine (car ls) (fold-right1 combine nil (cdr ls))))))

(define-library-entry (fold-right2 combine nil ls1 ls2)
  (let fold-right2 ([combine combine] [nil nil] [ls1 ls1] [ls2 ls2])
    (if (null? ls1)
        nil
        ; naturally does cdrs first to avoid mutation sickness
        (combine (car ls1) (car ls2)
          (fold-right2 combine nil (cdr ls1) (cdr ls2))))))

(eval-when (compile)
(define-syntax doapply
  (syntax-rules ()
    [(_ p (x ...) ls) (if (null? ls) (p x ...) (doapply p (x ...) ls (ls)))]
    [(_ p (x ...) ls (ls1 ... lsn))
     (= (length #'(ls1 ...)) 4)
     ($apply p (fx+ (length '(x ...)) (length '(ls1 ...)) (length lsn))
       (list* x ... ls))]
    [(_ p (x ...) ls (ls1 ... lsn-1))
     (let ([lsn (cdr lsn-1)])
       (if (null? lsn)
           (p x ... (car ls1) ... (car lsn-1))
           (doapply p (x ...) ls (ls1 ... lsn-1 lsn))))]))
)

(define-library-entry (apply0 p ls)
  (doapply p () ls))

(define-library-entry (apply1 p x1 ls)
  (doapply p (x1) ls))

(define-library-entry (apply2 p x1 x2 ls)
  (doapply p (x1 x2) ls))

(define-library-entry (apply3 p x1 x2 x3 ls)
  (doapply p (x1 x2 x3) ls))

(define-library-entry (eqv? x y)
  (if (eq? x y) 
      #t
      (exclusive-cond
        [(flonum? x) (and (flonum? y) ($fleqv? x y))]
        [($inexactnum? x)
         (and ($inexactnum? y)
              ($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
              ($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y)))]
        [(bignum? x) (and (bignum? y) (= x y))]
        [(ratnum? x) (and (ratnum? y) (= x y))]
        [($exactnum? x) (and ($exactnum? y) (= x y))]
        [else #f])))

(define-library-entry (memv x ls)
  (if (or (symbol? x) (#%$immediate? x))
      (memq x ls)
      (let memv ([ls ls])
        (and (not (null? ls))
             (if (eqv? (car ls) x)
                 ls
                 (let ([ls (cdr ls)])
                   (and (not (null? ls))
                        (if (eqv? (car ls) x)
                            ls
                            (memv (cdr ls))))))))))

(define-library-entry (reverse ls)
  (let loop ([ls ls] [a '()])
    (if (null? ls)
        a
        (let ([ls2 (cdr ls)])
          (if (null? ls2)
              (cons (car ls) a)
              (loop (cdr ls2) (cons* (car ls2) (car ls) a)))))))

(let ()
  (include "hashtable-types.ss")

  ;;; eq hashtable operations must be compiled with
  ;;; generate-interrupt-trap #f and optimize-level 3
  ;;; so they can't be interrupted by a collection
  (let ()
    (define-syntax lookup-keyval
      (syntax-rules ()
        [(_ ?x ?b succ fail)
         (let ([x ?x])
           (let loop ([b ?b])
             (if (fixnum? b)
                 fail
                 (let ([keyval ($tlc-keyval b)])
                   (if (eq? (car keyval) x)
                       (succ keyval)
                       (loop ($tlc-next b)))))))]))
  
    (define-syntax incr-size!
      (syntax-rules ()
        [(_ h vec)
         (let ([size (fx+ (ht-size h) 1)] [n (vector-length vec)])
           (ht-size-set! h size)
           (when (and (fx> size n) (fx< n (fxsrl (most-positive-fixnum) 1)))
             (adjust! h vec n (fxsll n 1))))]))
  
    (define-syntax decr-size!
      (syntax-rules ()
        [(_ h vec)
         (let ([size (fx- (ht-size h) 1)] [n (vector-length vec)])
           (ht-size-set! h size)
           (when (and (fx< size (fxsrl n 2)) (fx> n (ht-minlen h)))
             (let ([target (fxmax (fxsll size 2) (ht-minlen h))])
               (let loop ([n2 n])
                 (let ([n2 (fxsrl n2 1)])
                   (if (fx<= n2 target)
                       (adjust! h vec n n2)
                       (loop n2)))))))]))
  
    (define adjust!
      (lambda (h vec1 n1 n2)
        (let ([vec2 ($make-eqhash-vector n2)] [mask2 (fx- n2 1)])
          (do ([i1 0 (fx+ i1 1)])
            ((fx= i1 n1))
            (let loop ([b (vector-ref vec1 i1)])
              (unless (fixnum? b)
                (let ([next ($tlc-next b)] [keyval ($tlc-keyval b)])
                  (let ([i2 (fxlogand ($fxaddress (car keyval)) mask2)])
                    ($set-tlc-next! b (vector-ref vec2 i2))
                    (vector-set! vec2 i2 b))
                  (loop next)))))
          (ht-vec-set! h vec2))))
  
    (define-library-entry (eq-hashtable-ref h x v)
      (lookup-keyval x
        (let ([vec (ht-vec h)])
          (vector-ref vec (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))))
        cdr v))
  
    (define-library-entry (eq-hashtable-contains? h x)
      (lookup-keyval x
        (let ([vec (ht-vec h)])
          (vector-ref vec (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))))
        (lambda (x) #t)
        #f))
  
    (define-library-entry (eq-hashtable-cell h x v)
      (let* ([vec (ht-vec h)]
             [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))]
             [b (vector-ref vec idx)])
        (lookup-keyval x b
          values
          (let ([keyval (let ([subtype (eq-ht-subtype h)])
                          (cond
                           [(eq? subtype (constant eq-hashtable-subtype-normal)) (cons x v)]
                           [(eq? subtype (constant eq-hashtable-subtype-weak)) (weak-cons x v)]
                           [else (ephemeron-cons x v)]))])
            (vector-set! vec idx ($make-tlc h keyval b))
            (incr-size! h vec)
            keyval))))
  
    (let ()
      (define do-set!
        (lambda (h x v)
          (let* ([vec (ht-vec h)]
                 [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))]
                 [b (vector-ref vec idx)])
            (lookup-keyval x b
              (lambda (keyval) (set-cdr! keyval v))
              (begin
                (vector-set! vec idx
                  ($make-tlc h
                    (let ([subtype (eq-ht-subtype h)])
                      (cond
                       [(eq? subtype (constant eq-hashtable-subtype-normal)) (cons x v)]
                       [(eq? subtype (constant eq-hashtable-subtype-weak)) (weak-cons x v)]
                       [else (ephemeron-cons x v)]))
                    b))
                (incr-size! h vec))))))
  
      (define-library-entry (eq-hashtable-set! h x v)
        (do-set! h x v))
  
      (define-library-entry (eq-hashtable-update! h x p v)
        (let* ([vec (ht-vec h)]
               [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))]
               [b (vector-ref vec idx)])
          (lookup-keyval x b
            (lambda (a) (set-cdr! a (p (cdr a))))
            (do-set! h x (p v))))))
  
    (define-library-entry (eq-hashtable-delete! h x)
      (let* ([vec (ht-vec h)]
             [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))]
             [b (vector-ref vec idx)])
        (unless (fixnum? b)
          (if (eq? (car ($tlc-keyval b)) x)
              (begin
                (vector-set! vec idx ($tlc-next b))
                ($set-tlc-next! b #f)
                (decr-size! h vec))
              (let loop ([b b])
                (let ([n ($tlc-next b)])
                  (unless (fixnum? n)
                    (if (eq? (car ($tlc-keyval n)) x)
                        (begin
                          ($set-tlc-next! b ($tlc-next n))
                          ($set-tlc-next! n #f)
                          (decr-size! h vec))
                        (loop n)))))))))
  )

  ; symbol hashtable operations
  (let ()
    (define-syntax incr-size!
      (syntax-rules ()
        [(_ h vec)
         (let ([size (fx+ (ht-size h) 1)] [n (vector-length vec)])
           (ht-size-set! h size)
           (when (and (fx> size n) (fx< n (fxsrl (most-positive-fixnum) 1)))
             (adjust! h vec (fxsll n 1))))]))

    (define-syntax decr-size!
      (syntax-rules ()
        [(_ h vec)
         (let ([size (fx- (ht-size h) 1)] [n (vector-length vec)])
           (ht-size-set! h size)
           (when (and (fx< size (fxsrl n 2)) (fx> n (ht-minlen h)))
             (adjust! h vec (fxsrl n 1))))]))

    (define adjust!
      (lambda (h vec1 n2)
        (let ([vec2 (make-vector n2 '())]
              [mask2 (fx- n2 1)])
          (vector-for-each
            (lambda (b)
              (for-each
                (lambda (a)
                  (let ([hc (fxlogand ($symbol-hash (car a)) mask2)])
                    (vector-set! vec2 hc (cons a (vector-ref vec2 hc)))))
                b))
            vec1)
          (ht-vec-set! h vec2))))

    (define-library-entry (symbol-hashtable-ref h x v)
      (let ([hc ($symbol-hash x)])
        (if hc
            (let ([vec (ht-vec h)])
              (let loop ([b (vector-ref vec (fxlogand hc (fx- (vector-length vec) 1)))])
                (if (null? b)
                    v
                    (let ([a (car b)])
                      (if (eq? (car a) x) (cdr a) (loop (cdr b)))))))
            (pariah v))))

    (define-library-entry (symbol-hashtable-contains? h x)
      (let ([hc ($symbol-hash x)])
        (and hc
             (let ([vec (ht-vec h)])
               (let loop ([b (vector-ref vec (fxlogand hc (fx- (vector-length vec) 1)))])
                 (and (not (null? b))
                      (or (eq? (caar b) x)
                          (loop (cdr b)))))))))

    (define-library-entry (symbol-hashtable-cell h x v)
      (let ([vec (ht-vec h)] [hc ($symbol-hash x)])
        (if hc
            (let ([idx (fxlogand hc (fx- (vector-length vec) 1))])
              (let ([bucket (vector-ref vec idx)])
                (let loop ([b bucket])
                  (if (null? b)
                      (let ([a (cons x v)])
                        (vector-set! vec idx (cons a bucket))
                        (incr-size! h vec)
                        a)
                      (let ([a (car b)])
                        (if (eq? (car a) x)
                            a
                            (loop (cdr b))))))))
            (let ([idx (fxlogand (symbol-hash x) (fx- (vector-length vec) 1))])
              (let ([a (cons x v)])
                (vector-set! vec idx (cons a (vector-ref vec idx)))
                (incr-size! h vec)
                a)))))

    (define-library-entry (symbol-hashtable-set! h x v)
      (let ([vec (ht-vec h)] [hc ($symbol-hash x)])
        (if hc
            (let ([idx (fxlogand hc (fx- (vector-length vec) 1))])
              (let ([bucket (vector-ref vec idx)])
                (let loop ([b bucket])
                  (if (null? b)
                      (begin
                        (vector-set! vec idx (cons (cons x v) bucket))
                        (incr-size! h vec))
                      (let ([a (car b)])
                        (if (eq? (car a) x) (set-cdr! a v) (loop (cdr b))))))))
            (let ([idx (fxlogand (symbol-hash x) (fx- (vector-length vec) 1))])
              (vector-set! vec idx (cons (cons x v) (vector-ref vec idx)))
              (incr-size! h vec)))))

    (define-library-entry (symbol-hashtable-update! h x p v)
      (let ([vec (ht-vec h)] [hc ($symbol-hash x)])
        (if hc
            (let ([idx (fxlogand hc (fx- (vector-length vec) 1))])
              (let ([bucket (vector-ref vec idx)])
                (let loop ([b bucket])
                  (if (null? b)
                      (begin
                        (vector-set! vec idx (cons (cons x (p v)) bucket))
                        (incr-size! h vec))
                      (let ([a (car b)])
                        (if (eq? (car a) x)
                            (set-cdr! a (p (cdr a)))
                            (loop (cdr b))))))))
            (let ([idx (fxlogand (symbol-hash x) (fx- (vector-length vec) 1))])
              (vector-set! vec idx (cons (cons x (p v)) (vector-ref vec idx)))
              (incr-size! h vec)))))

    (define-library-entry (symbol-hashtable-delete! h x)
      (let ([hc ($symbol-hash x)])
        (when hc
          (let ([vec (ht-vec h)])
            (let ([idx (fxlogand hc (fx- (vector-length vec) 1))])
              (let loop ([b (vector-ref vec idx)] [p #f])
                (unless (null? b)
                  (let ([a (car b)])
                    (if (eq? (car a) x)
                        (begin
                          (if p (set-cdr! p (cdr b)) (vector-set! vec idx (cdr b)))
                          (decr-size! h vec))
                        (loop (cdr b) b))))))))))
  )
)

;;; the routines below may cause significant allocation without any
;;; embedded calls to other trap-checking routines, so we enable
;;; generation-interrupt-trap for them.
(eval-when (compile) (generate-interrupt-trap #t))

(define-library-entry (append ls1 ls2)
  (let append ([ls1 ls1] [ls2 ls2])
    (if (null? ls1)
        ls2
        (let ((cdr-ls1 (cdr ls1)))
          (if (null? cdr-ls1)
              (cons (car ls1) ls2)
              (list* (car ls1) (car cdr-ls1) (append (cdr cdr-ls1) ls2)))))))