1;;; library.ss 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16;;; Library entries should not contain references that could themselves 17;;; compile into library entries. (Actually it will work as long as the 18;;; use follows the definition, but...) Consequently they should be 19;;; kept simple. 20 21(eval-when (compile) 22 (optimize-level 3) 23 (generate-inspector-information #f) 24 ($compile-profile #f) 25 ($optimize-closures #t) 26 (run-cp0 (default-run-cp0)) 27 (generate-interrupt-trap #f) 28 ($track-dynamic-closure-counts #f)) 29 30(eval-when (compile) 31(define-syntax define-library-entry 32 (lambda (x) 33 (define name->libspec 34 (lambda (name) 35 (or ($sgetprop name '*libspec* #f) 36 ($oops 'define-library-entry "~s is undefined" name)))) 37 (define name->does-not-expect-headroom-libspec 38 (lambda (name) 39 (or ($sgetprop name '*does-not-expect-headroom-libspec* #f) 40 ($oops 'define-library-entry "~s is missing no headroom libspec" name)))) 41 (syntax-case x () 42 [(_ (name . args) e1 e2 ...) 43 (identifier? #'name) 44 (let ([libspec (name->libspec (datum name))] 45 [does-not-expect-headroom-libspec (name->does-not-expect-headroom-libspec (datum name))]) 46 (with-syntax ([index (libspec-index libspec)] 47 [does-not-expect-headroom-index (libspec-index does-not-expect-headroom-libspec)] 48 [libspec (datum->syntax #'name libspec)] 49 [does-not-expect-headroom-libspec (datum->syntax #'name does-not-expect-headroom-libspec)]) 50 ; NB: we are duplicating code here, because looking up the library entry fails on startup. 51 #'(begin 52 ($install-library-entry 53 'index 54 (case-lambda libspec (args e1 e2 ...))) 55 ($install-library-entry 56 'does-not-expect-headroom-index 57 (case-lambda does-not-expect-headroom-libspec (args e1 e2 ...))))))]))) 58) 59 60; we can't evaluate any dirty writes (eg. defines) until scan-remembered-set 61; is ready, so install it up front. 62(let ([install-library-entry ($hand-coded '$install-library-entry-procedure)]) 63 (install-library-entry 64 (libspec-index (lookup-libspec scan-remembered-set)) 65 ($hand-coded 'scan-remembered-set))) 66 67(let ([install-library-entry ($hand-coded '$install-library-entry-procedure)]) 68 ; no top-level defines before this point, or the linker won't have 69 ; nonprocedure-code to insert in pvalue slot 70 (install-library-entry 71 (libspec-index (lookup-libspec nonprocedure-code)) 72 ($hand-coded 'nonprocedure-code))) 73 74(define $foreign-entry ($hand-coded '$foreign-entry-procedure)) 75;; The name `$install-library-entry` is special to `vfasl-can-combine?` 76(define $install-library-entry 77 ($hand-coded '$install-library-entry-procedure)) 78 79(eval-when (compile) 80(define-syntax define-hand-coded-library-entry 81 (lambda (x) 82 (syntax-case x () 83 ((_ name) 84 (identifier? #'name) 85 #'($install-library-entry (libspec-index (lookup-libspec name)) 86 ($hand-coded 'name)))))) 87) 88 89(define-hand-coded-library-entry get-room) 90(define-hand-coded-library-entry call-error) 91(define-hand-coded-library-entry dooverflood) 92(define-hand-coded-library-entry dooverflow) 93(define-hand-coded-library-entry dorest0) 94(define-hand-coded-library-entry dorest1) 95(define-hand-coded-library-entry dorest2) 96(define-hand-coded-library-entry dorest3) 97(define-hand-coded-library-entry dorest4) 98(define-hand-coded-library-entry dorest5) 99;;; doargerr must come before dounderflow* 100(define-hand-coded-library-entry doargerr) 101 102;;; dounderflow* must come before dounderflow 103(define-library-entry (dounderflow* k args) 104 ($do-wind ($current-winders) ($continuation-winders k)) 105 (cond 106 ((null? args) (k)) 107 ((null? (cdr args)) (k (car args))) 108 (else (#2%apply k args)))) ; library apply not available yet 109 110;; before anything that returns multiple values 111(define-hand-coded-library-entry values-error) 112 113;;; dounderflow & nuate must come before callcc 114(define-hand-coded-library-entry dounderflow) 115(define-hand-coded-library-entry nuate) 116(define-hand-coded-library-entry reify-1cc) 117(define-hand-coded-library-entry maybe-reify-cc) 118(define-hand-coded-library-entry callcc) 119(define-hand-coded-library-entry call1cc) 120(define-hand-coded-library-entry dofargint32) 121(define-hand-coded-library-entry dofretint32) 122(define-hand-coded-library-entry dofretuns32) 123(define-hand-coded-library-entry dofargint64) 124(define-hand-coded-library-entry dofretint64) 125(define-hand-coded-library-entry dofretuns64) 126(define-hand-coded-library-entry dofretu8*) 127(define-hand-coded-library-entry dofretu16*) 128(define-hand-coded-library-entry dofretu32*) 129(define-hand-coded-library-entry domvleterr) 130(define-hand-coded-library-entry bytevector=?) 131(define-hand-coded-library-entry $wrapper-apply) 132(define-hand-coded-library-entry wrapper-apply) 133(define-hand-coded-library-entry arity-wrapper-apply) 134(define-hand-coded-library-entry event-detour) 135(define-hand-coded-library-entry popcount-slow) ; before fxpopcount use 136(define-hand-coded-library-entry cpu-features) ; before fxpopcount use 137 138(define $instantiate-code-object ($hand-coded '$instantiate-code-object)) 139 140;;; set up $nuate for overflow 141(define $nuate ($closure-code (call/1cc (lambda (k) k)))) 142 143(set! #{raw-ref-count bhowt6w0coxl0s2y-1} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 144(set! #{raw-create-count bhowt6w0coxl0s2y-2} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 145(set! #{raw-alloc-count bhowt6w0coxl0s2y-3} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 146(set! #{ref-count bhowt6w0coxl0s2y-4} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 147(set! #{pair-create-count bhowt6w0coxl0s2y-5} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 148(set! #{vector-create-count bhowt6w0coxl0s2y-6} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 149(set! #{vector-alloc-count bhowt6w0coxl0s2y-8} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 150(set! #{padded-vector-alloc-count bhowt6w0coxl0s2y-11} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 151(set! #{closure-create-count bhowt6w0coxl0s2y-7} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 152(set! #{closure-alloc-count bhowt6w0coxl0s2y-9} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 153(set! #{padded-closure-alloc-count bhowt6w0coxl0s2y-10} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0]) 154 155(let () 156 (include "hashtable-types.ss") 157 (set! $eq-ht-rtd (record-type-descriptor eq-ht)) 158 (set! $symbol-ht-rtd (record-type-descriptor symbol-ht))) 159 160(define-library-entry (cfl* x y) 161 ;; a+bi * c+di => ac-bd + (ad+bc)i 162 ;; spurious overflows 163 (cond 164 [(flonum? x) 165 (if (flonum? y) 166 (fl* x y) 167 (fl-make-rectangular 168 (fl* x ($inexactnum-real-part y)) 169 (fl* x ($inexactnum-imag-part y))))] 170 [(flonum? y) 171 (fl-make-rectangular 172 (fl* ($inexactnum-real-part x) y) 173 (fl* ($inexactnum-imag-part x) y))] 174 [else 175 (let ([a ($inexactnum-real-part x)] [b ($inexactnum-imag-part x)] 176 [c ($inexactnum-real-part y)] [d ($inexactnum-imag-part y)]) 177 (fl-make-rectangular 178 (fl- (fl* a c) (fl* b d)) 179 (fl+ (fl* a d) (fl* b c))))])) 180 181(define-library-entry (cfl+ x y) 182 ;; a+bi + c+di => (a+c) + (b+d)i 183 (cond 184 [(flonum? x) 185 (if (flonum? y) 186 (fl+ x y) 187 (fl-make-rectangular 188 (fl+ x ($inexactnum-real-part y)) 189 ($inexactnum-imag-part y)))] 190 [(flonum? y) 191 (fl-make-rectangular 192 (fl+ ($inexactnum-real-part x) y) 193 ($inexactnum-imag-part x))] 194 [else 195 (fl-make-rectangular 196 (fl+ ($inexactnum-real-part x) ($inexactnum-real-part y)) 197 (fl+ ($inexactnum-imag-part x) ($inexactnum-imag-part y)))])) 198 199(define-library-entry (cfl- x y) 200 ;; a+bi - c+di => (a-c) + (b-d)i 201 (cond 202 [(flonum? x) 203 (if (flonum? y) 204 (fl- x y) 205 (fl-make-rectangular 206 (fl- x ($inexactnum-real-part y)) 207 (fl- ($inexactnum-imag-part y))))] 208 [(flonum? y) 209 (fl-make-rectangular 210 (fl- ($inexactnum-real-part x) y) 211 ($inexactnum-imag-part x))] 212 [else 213 (fl-make-rectangular 214 (fl- ($inexactnum-real-part x) ($inexactnum-real-part y)) 215 (fl- ($inexactnum-imag-part x) ($inexactnum-imag-part y)))])) 216 217(define-library-entry (cfl/ x y) 218 ;; spurious overflows, underflows, and division by zero 219 (cond 220 [(flonum? y) 221 ;; a+bi/c => a/c + (b/c)i 222 (if (flonum? x) 223 (fl/ x y) 224 (fl-make-rectangular 225 (fl/ ($inexactnum-real-part x) y) 226 (fl/ ($inexactnum-imag-part x) y)))] 227 [(flonum? x) 228 ;; a / c+di => c(a/(cc+dd)) + (-d(a/cc+dd))i 229 (let ([c ($inexactnum-real-part y)] [d ($inexactnum-imag-part y)]) 230 (let ([t (fl/ x (fl+ (fl* c c) (fl* d d)))]) 231 (fl-make-rectangular (fl* c t) (fl- (fl* d t)))))] 232 [else 233 ;; a+bi / c+di => (ac+bd)/(cc+dd) + ((bc-ad)/(cc+dd))i 234 (let ([a ($inexactnum-real-part x)] [b ($inexactnum-imag-part x)] 235 [c ($inexactnum-real-part y)] [d ($inexactnum-imag-part y)]) 236 ;; a+bi / c+di => (ac+bd)/(cc+dd) + ((bc-ad)/(cc+dd))i 237 (define (simpler-divide a b c d) 238 ;; Direct calculuation does not work as well for complex numbers with 239 ;; large parts, such as `(/ 1e+300+1e+300i 4e+300+4e+300i)`, but it 240 ;; works better for small parts, as in `(/ 0.0+0.0i 1+1e-320i)` 241 (let ([t (fl+ (fl* c c) (fl* d d))]) 242 (fl-make-rectangular (fl/ (fl+ (fl* a c) (fl* b d)) t) 243 (fl/ (fl- (fl* b c) (fl* a d)) t)))) 244 ;; Let r = c/d or d/c, depending on which is larger 245 (cond 246 [(fl< (flabs c) (flabs d)) 247 (let ([r (fl/ d c)]) 248 (if (infinity? r) 249 ;; Too large; try form that works better with small c or d 250 (simpler-divide a b c d) 251 ;; a+bi / c+di => 252 (let ([x (fl+ c (fl* d r))]) ; x = c+dd/c = (cc+dd)/c 253 ;; (a+br)/x + ((b-ar)/x)i = (a+bd/c)c/(cc+dd) + ((b-ad/c)c/(cc+dd))i 254 ;; = (ac+bd)/(cc+dd) + ((bc-ad)/(cc+dd))i 255 (fl-make-rectangular (fl/ (fl+ a (fl* b r)) x) 256 (fl/ (fl- b (fl* a r)) x)))))] 257 [else 258 (let ([r (fl/ c d)]) 259 (if (infinity? r) 260 ;; Too large; try form that works better with small c or d 261 (simpler-divide a b c d) 262 (let ([x (fl+ d (fl* c r))]) ; x = d+cc/d = (cc+dd)/d 263 ;; (b+ar)/x + ((br-a)/x)i = (b+ac/d)d/(cc+dd) + ((bc/d-a)d/(cc+dd))i 264 ;; = (bd+ac)/(cc+dd) + ((bc-ad)/(cc+dd))i 265 (fl-make-rectangular (fl/ (fl+ b (fl* a r)) x) 266 (fl/ (fl- (fl* b r) a) x)))))]))])) 267 268(let () 269 (define char-oops 270 (lambda (who x) 271 ($oops who "~s is not a character" x))) 272 (define fixnum-oops 273 (lambda (who x) 274 ($oops who "~s is not a fixnum" x))) 275 (define string-oops 276 (lambda (who x) 277 ($oops who "~s is not a string" x))) 278 (define mutable-string-oops 279 (lambda (who x) 280 ($oops who "~s is not a mutable string" x))) 281 (define vector-oops 282 (lambda (who x) 283 ($oops who "~s is not a vector" x))) 284 (define mutable-vector-oops 285 (lambda (who x) 286 ($oops who "~s is not a mutable vector" x))) 287 (define fxvector-oops 288 (lambda (who x) 289 ($oops who "~s is not an fxvector" x))) 290 (define flvector-oops 291 (lambda (who x) 292 ($oops who "~s is not an flvector" x))) 293 (define bytevector-oops 294 (lambda (who x) 295 ($oops who "~s is not a bytevector" x))) 296 (define mutable-bytevector-oops 297 (lambda (who x) 298 ($oops who "~s is not a mutable bytevector" x))) 299 (define index-oops 300 (lambda (who x i) 301 ($oops who "~s is not a valid index for ~s" i x))) 302 (define bytevector-index-oops 303 ;; for consistency with error before library entry was introduced: 304 (lambda (who x i) 305 ($oops who "invalid index ~s for bytevector ~s" i x))) 306 307 (define stencil-vector-oops 308 (lambda (who x) 309 ($oops who "~s is not a vector" x))) 310 311 (define-library-entry (char->integer x) (char-oops 'char->integer x)) 312 313 (define-library-entry (string-ref s i) 314 (if (string? s) 315 (index-oops 'string-ref s i) 316 (string-oops 'string-ref s))) 317 318 (define-library-entry (string-set! s i c) 319 (if ($string-set!-check? s i) 320 (if (char? c) 321 (string-set! s i c) 322 (char-oops 'string-set! c)) 323 (if (mutable-string? s) 324 (index-oops 'string-set! s i) 325 (mutable-string-oops 'string-set! s)))) 326 327 (define-library-entry (string-length s) 328 (string-oops 'string-length s)) 329 330 (define-library-entry (vector-ref v i) 331 (if (vector? v) 332 (index-oops 'vector-ref v i) 333 (vector-oops 'vector-ref v))) 334 335 (define-library-entry (vector-set! v i x) 336 (if (mutable-vector? v) 337 (index-oops 'vector-set! v i) 338 (mutable-vector-oops 'vector-set! v))) 339 340 (define-library-entry (vector-set-fixnum! v i x) 341 (if (fixnum? x) 342 (if (mutable-vector? v) 343 (index-oops 'vector-set-fixnum! v i) 344 (mutable-vector-oops 'vector-set-fixnum! v)) 345 ($oops 'vector-set-fixnum! "~s is not a fixnum" x))) 346 347 (define-library-entry (vector-length v) 348 (vector-oops 'vector-length v)) 349 350 (define-library-entry (vector-cas! v i old-x new-x) 351 (if (mutable-vector? v) 352 (index-oops 'vector-cas! v i) 353 (mutable-vector-oops 'vector-cas! v))) 354 355 (define-library-entry (fxvector-ref v i) 356 (if (fxvector? v) 357 (index-oops 'fxvector-ref v i) 358 (fxvector-oops 'fxvector-ref v))) 359 360 (define-library-entry (fxvector-set! v i x) 361 (if (fxvector? v) 362 (if (and (fixnum? i) ($fxu< i (fxvector-length v))) 363 (fixnum-oops 'fxvector-set! x) 364 (index-oops 'fxvector-set! v i)) 365 (fxvector-oops 'fxvector-set! v))) 366 367 (define-library-entry (fxvector-length v) 368 (fxvector-oops 'fxvector-length v)) 369 370 (define-library-entry (flvector-ref v i) 371 (if (flvector? v) 372 (index-oops 'flvector-ref v i) 373 (flvector-oops 'flvector-ref v))) 374 375 (define-library-entry (flvector-set! v i x) 376 (if (flvector? v) 377 (if (and (fixnum? i) ($fxu< i (flvector-length v))) 378 ($oops 'flvector-set! "~s is not a flonum" x) 379 (index-oops 'flvector-set! v i)) 380 (flvector-oops 'flvector-set! v))) 381 382 (define-library-entry (flvector-length v) 383 (flvector-oops 'flvector-length v)) 384 385 (define-library-entry (bytevector-s8-ref v i) 386 (if (bytevector? v) 387 (index-oops 'bytevector-s8-ref v i) 388 (bytevector-oops 'bytevector-s8-ref v))) 389 390 (define-library-entry (bytevector-u8-ref v i) 391 (if (bytevector? v) 392 (index-oops 'bytevector-u8-ref v i) 393 (bytevector-oops 'bytevector-u8-ref v))) 394 395 (define-library-entry (bytevector-s8-set! v i k) 396 (if ($bytevector-set!-check? 8 v i) 397 (if (and (fixnum? k) (fx<= -128 k 127)) 398 (bytevector-s8-set! v i k) 399 ($oops 'bytevector-s8-set! "invalid value ~s" k)) 400 (if (mutable-bytevector? v) 401 (index-oops 'bytevector-s8-set! v i) 402 (mutable-bytevector-oops 'bytevector-s8-set! v)))) 403 404 (define-library-entry (bytevector-u8-set! v i k) 405 (if ($bytevector-set!-check? 8 v i) 406 (if (and (fixnum? k) (fx<= 0 k 255)) 407 (bytevector-u8-set! v i k) 408 ($oops 'bytevector-u8-set! "invalid value ~s" k)) 409 (if (mutable-bytevector? v) 410 (index-oops 'bytevector-u8-set! v i) 411 (mutable-bytevector-oops 'bytevector-u8-set! v)))) 412 413 (define-library-entry (bytevector-length v) 414 (bytevector-oops 'bytevector-length v)) 415 416 (define-library-entry (stencil-vector-mask v) 417 (stencil-vector-oops 'stencil-vector-mask v)) 418 419 (define-library-entry (bytevector-ieee-double-native-ref v i) 420 (if (bytevector? v) 421 (bytevector-index-oops 'bytevector-ieee-double-native-ref v i) 422 (bytevector-oops 'bytevector-ieee-double-native-ref v))) 423 424 (define-library-entry (bytevector-ieee-double-native-set! v i) 425 (if (mutable-bytevector? v) 426 (bytevector-index-oops 'bytevector-ieee-double-native-set! v i) 427 (mutable-bytevector-oops 'bytevector-ieee-double-native-set! v))) 428 429 (define-library-entry (char=? x y) (char-oops 'char=? (if (char? x) y x))) 430 (define-library-entry (char<? x y) (char-oops 'char<? (if (char? x) y x))) 431 (define-library-entry (char>? x y) (char-oops 'char>? (if (char? x) y x))) 432 (define-library-entry (char<=? x y) (char-oops 'char<=? (if (char? x) y x))) 433 (define-library-entry (char>=? x y) (char-oops 'char>=? (if (char? x) y x))) 434) 435 436(define-library-entry (real->flonum x who) 437 (cond 438 [(fixnum? x) (fixnum->flonum x)] 439 [(or (bignum? x) (ratnum? x)) (inexact x)] 440 [(flonum? x) x] 441 [else ($oops who "~s is not a real number" x)])) 442 443(let () 444 (define pair-oops 445 (lambda (who x) 446 ($oops who "~s is not a pair" x))) 447 448 (define-library-entry (car x) (pair-oops 'car x)) 449 (define-library-entry (cdr x) (pair-oops 'cdr x)) 450 (define-library-entry (set-car! x y) (pair-oops 'set-car! x)) 451 (define-library-entry (set-cdr! x y) (pair-oops 'set-cdr! x)) 452) 453 454(let () 455 (define c..r-oops 456 (lambda (who obj) 457 ($oops who "incorrect list structure ~s" obj))) 458 459 (define-library-entry (caar x) (c..r-oops 'caar x)) 460 (define-library-entry (cadr x) (c..r-oops 'cadr x)) 461 (define-library-entry (cdar x) (c..r-oops 'cdar x)) 462 (define-library-entry (cddr x) (c..r-oops 'cddr x)) 463 (define-library-entry (caaar x) (c..r-oops 'caaar x)) 464 (define-library-entry (caadr x) (c..r-oops 'caadr x)) 465 (define-library-entry (cadar x) (c..r-oops 'cadar x)) 466 (define-library-entry (caddr x) (c..r-oops 'caddr x)) 467 (define-library-entry (cdaar x) (c..r-oops 'cdaar x)) 468 (define-library-entry (cdadr x) (c..r-oops 'cdadr x)) 469 (define-library-entry (cddar x) (c..r-oops 'cddar x)) 470 (define-library-entry (cdddr x) (c..r-oops 'cdddr x)) 471 (define-library-entry (caaaar x) (c..r-oops 'caaaar x)) 472 (define-library-entry (caaadr x) (c..r-oops 'caaadr x)) 473 (define-library-entry (caadar x) (c..r-oops 'caadar x)) 474 (define-library-entry (caaddr x) (c..r-oops 'caaddr x)) 475 (define-library-entry (cadaar x) (c..r-oops 'cadaar x)) 476 (define-library-entry (cadadr x) (c..r-oops 'cadadr x)) 477 (define-library-entry (caddar x) (c..r-oops 'caddar x)) 478 (define-library-entry (cadddr x) (c..r-oops 'cadddr x)) 479 (define-library-entry (cdaaar x) (c..r-oops 'cdaaar x)) 480 (define-library-entry (cdaadr x) (c..r-oops 'cdaadr x)) 481 (define-library-entry (cdadar x) (c..r-oops 'cdadar x)) 482 (define-library-entry (cdaddr x) (c..r-oops 'cdaddr x)) 483 (define-library-entry (cddaar x) (c..r-oops 'cddaar x)) 484 (define-library-entry (cddadr x) (c..r-oops 'cddadr x)) 485 (define-library-entry (cdddar x) (c..r-oops 'cdddar x)) 486 (define-library-entry (cddddr x) (c..r-oops 'cddddr x)) 487) 488 489(define-library-entry (unbox x) 490 ($oops 'unbox "~s is not a box" x)) 491 492(define-library-entry (set-box! b v) 493 ($oops 'set-box! "~s is not a mutable box" b)) 494 495(define-library-entry (box-cas! b old-v new-v) 496 ($oops 'box-cas! "~s is not a mutable box" b)) 497 498(let () 499(define (fxnonfixnum1 who x) 500 ($oops who "~s is not a fixnum" x)) 501 502(define (fxnonfixnum2 who x y) 503 ($oops who "~s is not a fixnum" (if (fixnum? x) y x))) 504 505(define (fxoops1 who x) 506 (if (fixnum? x) 507 ($impoops who "fixnum overflow with argument ~s" x) 508 (fxnonfixnum1 who x))) 509 510(define (fxoops2 who x y) 511 (if (fixnum? x) 512 (if (fixnum? y) 513 ($impoops who "fixnum overflow with arguments ~s and ~s" x y) 514 (fxnonfixnum1 who y)) 515 (fxnonfixnum1 who x))) 516 517(define (shift-count-oops who x) 518 ($oops who "invalid shift count ~s" x)) 519 520(define-library-entry (fx+ x y) (fxoops2 'fx+ x y)) 521(define-library-entry (fx- x y) (fxoops2 'fx- x y)) 522(define-library-entry (fx* x y) (fxoops2 'fx* x y)) 523(define-library-entry (fx1+ x) (fxoops1 'fx1+ x)) 524(define-library-entry (fx1- x) (fxoops1 'fx1- x)) 525 526(define-library-entry (fx+/wraparound x y) (fxoops2 'fx+/wraparound x y)) 527(define-library-entry (fx-/wraparound x y) (fxoops2 'fx-/wraparound x y)) 528(define-library-entry (fx*/wraparound x y) (fxoops2 'fx*/wraparound x y)) 529(define-library-entry (fxsll/wraparound x y) 530 (if (and (fixnum? x) (fixnum? y)) 531 (shift-count-oops 'fxsll/wraparound y) 532 (fxoops2 'fxsll/wraparound x y))) 533 534(define-library-entry (fx= x y) (fxnonfixnum2 'fx= x y)) 535(define-library-entry (fx< x y) (fxnonfixnum2 'fx< x y)) 536(define-library-entry (fx> x y) (fxnonfixnum2 'fx> x y)) 537(define-library-entry (fx<= x y) (fxnonfixnum2 'fx<= x y)) 538(define-library-entry (fx>= x y) (fxnonfixnum2 'fx>= x y)) 539(define-library-entry (fx=? x y) (fxnonfixnum2 'fx=? x y)) 540(define-library-entry (fx<? x y) (fxnonfixnum2 'fx<? x y)) 541(define-library-entry (fx>? x y) (fxnonfixnum2 'fx>? x y)) 542(define-library-entry (fx<=? x y) (fxnonfixnum2 'fx<=? x y)) 543(define-library-entry (fx>=? x y) (fxnonfixnum2 'fx>=? x y)) 544(define-library-entry (fxzero? x) (fxnonfixnum1 'fxzero? x)) 545(define-library-entry (fxpositive? x) (fxnonfixnum1 'fxpositive? x)) 546(define-library-entry (fxnonpositive? x) (fxnonfixnum1 'fxnonpositive? x)) 547(define-library-entry (fxnegative? x) (fxnonfixnum1 'fxnegative? x)) 548(define-library-entry (fxnonnegative? x) (fxnonfixnum1 'fxnonnegative? x)) 549(define-library-entry (fxeven? x) (fxnonfixnum1 'fxeven? x)) 550(define-library-entry (fxodd? x) (fxnonfixnum1 'fxodd? x)) 551(define-library-entry (fxlogior x y) (fxnonfixnum2 'fxlogior x y)) 552(define-library-entry (fxlogor x y) (fxnonfixnum2 'fxlogor x y)) 553(define-library-entry (fxlogxor x y) (fxnonfixnum2 'fxlogxor x y)) 554(define-library-entry (fxlogand x y) (fxnonfixnum2 'fxlogand x y)) 555(define-library-entry (fxlognot x) (fxnonfixnum1 'fxlognot x)) 556(define-library-entry (fxior x y) (fxnonfixnum2 'fxior x y)) 557(define-library-entry (fxxor x y) (fxnonfixnum2 'fxxor x y)) 558(define-library-entry (fxand x y) (fxnonfixnum2 'fxand x y)) 559(define-library-entry (fxnot x) (fxnonfixnum1 'fxnot x)) 560(define-library-entry (fixnum->flonum x) (fxnonfixnum1 'fixnum->flonum x)) 561(define-library-entry (fxpopcount x) ($oops 'fxpopcount32 "~s is not a non-negative fixnum" x)) 562(define-library-entry (fxpopcount32 x) ($oops 'fxpopcount32 "~s is not a 32-bit fixnum" x)) 563(define-library-entry (fxpopcount16 x) ($oops 'fxpopcount16 "~s is not a 16-bit fixnum" x)) 564 565(define-library-entry (fxsll x y) 566 (cond 567 [(not (fixnum? x)) (fxnonfixnum1 'fxsll x)] 568 [(not (fixnum? y)) (fxnonfixnum1 'fxsll y)] 569 [(fx= 0 y) x] 570 [($fxu< y (constant fixnum-bits)) 571 (if (fx>= x 0) 572 (if (fx< x (fxsll 1 (fx- (- (constant fixnum-bits) 1) y))) 573 (fxsll x y) 574 (fxoops2 'fxsll x y)) 575 (if (fx>= x (fxsll -1 (fx- (- (constant fixnum-bits) 1) y))) 576 (fxsll x y) 577 (fxoops2 'fxsll x y)))] 578 [(fx= y (constant fixnum-bits)) (if (fx= x 0) x (fxoops2 'fxsll x y))] 579 [else (shift-count-oops 'fxsll y)])) 580 581(define-library-entry (fxarithmetic-shift-left x y) 582 (cond 583 [(not (fixnum? x)) (fxnonfixnum1 'fxarithmetic-shift-left x)] 584 [(not (fixnum? y)) (fxnonfixnum1 'fxarithmetic-shift-left y)] 585 [(fx= 0 y) x] 586 [($fxu< y (constant fixnum-bits)) 587 (if (fx>= x 0) 588 (if (fx< x (fxsll 1 (fx- (- (constant fixnum-bits) 1) y))) 589 (fxsll x y) 590 (fxoops2 'fxarithmetic-shift-left x y)) 591 (if (fx>= x (fxsll -1 (fx- (- (constant fixnum-bits) 1) y))) 592 (fxsll x y) 593 (fxoops2 'fxarithmetic-shift-left x y)))] 594 [else (shift-count-oops 'fxarithmetic-shift-left y)])) 595 596(define-library-entry (fxsrl x y) 597 (cond 598 [(not (fixnum? x)) (fxnonfixnum1 'fxsrl x)] 599 [(not (fixnum? y)) (fxnonfixnum1 'fxsrl y)] 600 [else (shift-count-oops 'fxsrl y)])) 601 602(define-library-entry (fxsra x y) 603 (cond 604 [(not (fixnum? x)) (fxnonfixnum1 'fxsra x)] 605 [(not (fixnum? y)) (fxnonfixnum1 'fxsra y)] 606 [else (shift-count-oops 'fxsra y)])) 607 608(define-library-entry (fxarithmetic-shift-right x y) 609 (cond 610 [(not (fixnum? x)) (fxnonfixnum1 'fxarithmetic-shift-right x)] 611 [(not (fixnum? y)) (fxnonfixnum1 'fxarithmetic-shift-right y)] 612 [else (shift-count-oops 'fxarithmetic-shift-right y)])) 613 614(define-library-entry (fxarithmetic-shift x y) 615 (cond 616 [(not (fixnum? x)) (fxnonfixnum1 'fxarithmetic-shift x)] 617 [(not (fixnum? y)) (fxnonfixnum1 'fxarithmetic-shift y)] 618 [(fx= 0 y) x] 619 [($fxu< y (constant fixnum-bits)) 620 (if (fx>= x 0) 621 (if (fx< x (fxsll 1 (fx- (- (constant fixnum-bits) 1) y))) 622 (fxsll x y) 623 (fxoops2 'fxarithmetic-shift x y)) 624 (if (fx>= x (fxsll -1 (fx- (- (constant fixnum-bits) 1) y))) 625 (fxsll x y) 626 (fxoops2 'fxarithmetic-shift x y)))] 627 [(fx< (fx- (constant fixnum-bits)) y 0) (fxsra x (fx- y))] 628 [else (shift-count-oops 'fxarithmetic-shift y)])) 629 630(define-library-entry (fxlogbit? k n) 631 (if (fixnum? n) 632 (if (fixnum? k) 633 (if (fx< k 0) 634 ($oops 'fxlogbit? "invalid bit index ~s" k) 635 ; this case left to us by cp1in fxlogbit? handler 636 (fx< n 0)) 637 (fxnonfixnum1 'fxlogbit? k)) 638 (fxnonfixnum1 'fxlogbit? n))) 639 640(define-library-entry (fxbit-set? n k) 641 (if (fixnum? n) 642 (if (fixnum? k) 643 (if (fx< k 0) 644 ($oops 'fxbit-set? "invalid bit index ~s" k) 645 ; this case left to us by cp1in fxbit-set? handler 646 (fx< n 0)) 647 (fxnonfixnum1 'fxbit-set? k)) 648 (fxnonfixnum1 'fxbit-set? n))) 649 650(define-library-entry (fxlogbit0 k n) 651 (if (fixnum? n) 652 (if (fixnum? k) 653 ($oops 'fxlogbit0 "invalid bit index ~s" k) 654 (fxnonfixnum1 'fxlogbit0 k)) 655 (fxnonfixnum1 'fxlogbit0 n))) 656 657(define-library-entry (fxlogbit1 k n) 658 (if (fixnum? n) 659 (if (fixnum? k) 660 ($oops 'fxlogbit1 "invalid bit index ~s" k) 661 (fxnonfixnum1 'fxlogbit1 k)) 662 (fxnonfixnum1 'fxlogbit1 n))) 663 664(define-library-entry (fxcopy-bit n k) 665 ; get here only if third argument is 0 or 1 666 (if (fixnum? n) 667 (if (fixnum? k) 668 ($oops 'fxcopy-bit "invalid bit index ~s" k) 669 (fxnonfixnum1 'fxcopy-bit k)) 670 (fxnonfixnum1 'fxcopy-bit n))) 671 672(define-library-entry (fxlogtest x y) (fxnonfixnum2 'fxlogtest x y)) 673) 674 675(let () 676 (define flonum-oops 677 (lambda (who x) 678 ($oops who "~s is not a flonum" x))) 679 680 (define-library-entry (fl= x y) (flonum-oops 'fl= (if (flonum? x) y x))) 681 (define-library-entry (fl< x y) (flonum-oops 'fl< (if (flonum? x) y x))) 682 (define-library-entry (fl> x y) (flonum-oops 'fl> (if (flonum? x) y x))) 683 (define-library-entry (fl<= x y) (flonum-oops 'fl<= (if (flonum? x) y x))) 684 (define-library-entry (fl>= x y) (flonum-oops 'fl>= (if (flonum? x) y x))) 685 (define-library-entry (fl=? x y) (flonum-oops 'fl=? (if (flonum? x) y x))) 686 (define-library-entry (fl<? x y) (flonum-oops 'fl<? (if (flonum? x) y x))) 687 (define-library-entry (fl>? x y) (flonum-oops 'fl>? (if (flonum? x) y x))) 688 (define-library-entry (fl<=? x y) (flonum-oops 'fl<=? (if (flonum? x) y x))) 689 (define-library-entry (fl>=? x y) (flonum-oops 'fl>=? (if (flonum? x) y x))) 690 691 (define-library-entry (fl+ x y) (flonum-oops 'fl+ (if (flonum? x) y x))) 692 (define-library-entry (fl- x y) (flonum-oops 'fl- (if (flonum? x) y x))) 693 (define-library-entry (fl* x y) (flonum-oops 'fl* (if (flonum? x) y x))) 694 (define-library-entry (fl/ x y) (flonum-oops 'fl/ (if (flonum? x) y x))) 695 (define-library-entry (flnegate x) (flonum-oops 'fl- x)) 696 (define-library-entry (flabs x) (flonum-oops 'flabs x)) 697 698 (define-library-entry (flsqrt x) (flonum-oops 'flsqrt x)) 699 (define-library-entry (flround x) (flonum-oops 'flround x)) 700 (define-library-entry (flfloor x) (flonum-oops 'flfloor x)) 701 (define-library-entry (flceiling x) (flonum-oops 'flceiling x)) 702 (define-library-entry (fltruncate x) (flonum-oops 'fltruncate x)) 703 (define-library-entry (flsingle x) (flonum-oops 'flsingle x)) 704 (define-library-entry (flsin x) (flonum-oops 'flsin x)) 705 (define-library-entry (flcos x) (flonum-oops 'flcos x)) 706 (define-library-entry (fltan x) (flonum-oops 'fltan x)) 707 (define-library-entry (flasin x) (flonum-oops 'flasin x)) 708 (define-library-entry (flacos x) (flonum-oops 'flacos x)) 709 (define-library-entry (flatan x) (flonum-oops 'flatan x)) 710 (define-library-entry (flatan2 x y) (flonum-oops 'flatan (if (flonum? x) y x))) 711 (define-library-entry (flexp x) (flonum-oops 'flexp x)) 712 (define-library-entry (fllog x) (flonum-oops 'fllog x)) 713 (define-library-entry (fllog2 x y) (flonum-oops 'fllog (if (flonum? x) y x))) 714 (define-library-entry (flexpt x y) (flonum-oops 'flexpt (if (flonum? x) y x))) 715 716 (define-library-entry (flonum->fixnum x) (if (flonum? x) 717 ($oops 'flonum->fixnum "result for ~s would be outside of fixnum range" x) 718 (flonum-oops 'flonum->fixnum x))) 719) 720 721;; Now using `rint` via a C entry 722#; 723(define-library-entry (flround x) 724 ; assumes round-to-nearest-or-even 725 (float-type-case 726 [(ieee) 727 (define threshold+ #i#x10000000000000) 728 (define threshold- #i#x-10000000000000)]) 729 (if (fl= x 0.0) 730 x ; don't change sign 731 (if (fl>= x 0.0) 732 (if (fl< x threshold+) 733 (fl- (fl+ x threshold+) threshold+) 734 x) 735 (if (fl>= x -0.5) 736 -0.0 ; keep negative 737 (if (fl> x threshold-) 738 (fl- (fl+ x threshold-) threshold-) 739 x))))) 740 741;;; The generic comparison entries assume the fixnum case is inlined. 742 743(define-library-entry (= x y) 744 (cond 745 [(flonum? x) 746 (cond 747 [(flonum? y) (fl= x y)] 748 [($inexactnum? y) (and (fl= ($inexactnum-imag-part y) 0.0) 749 (fl= ($inexactnum-real-part y) x))] 750 [else ($= '= x y)])] 751 [($inexactnum? x) 752 (cond 753 [(flonum? y) (and (fl= ($inexactnum-imag-part x) 0.0) 754 (fl= ($inexactnum-real-part x) y))] 755 [($inexactnum? y) 756 (and (fl= ($inexactnum-imag-part x) ($inexactnum-imag-part y)) 757 (fl= ($inexactnum-real-part x) ($inexactnum-real-part y)))] 758 [else ($= '= x y)])] 759 [else ($= '= x y)])) 760 761(define-library-entry (zero? x) 762 (cond 763 [(cflonum? x) (cfl= x 0.0)] 764 [(or (bignum? x) (ratnum? x) ($exactnum? x)) #f] 765 [else ($= 'zero? x 0)])) 766 767(define-library-entry (< x y) 768 (cond 769 [(and (flonum? x) (flonum? y)) (fl< x y)] 770 [else ($< '< x y)])) 771 772(define-library-entry (> x y) 773 (cond 774 [(and (flonum? x) (flonum? y)) (fl> x y)] 775 [else ($< '> y x)])) 776 777(define-library-entry (<= x y) 778 (cond 779 [(and (flonum? x) (flonum? y)) (fl<= x y)] 780 [else ($<= '<= x y)])) 781 782(define-library-entry (>= x y) 783 (cond 784 [(and (flonum? x) (flonum? y)) (fl>= x y)] 785 [else ($<= '>= y x)])) 786 787(define-library-entry (+ x y) 788 (cond 789 [(flonum? x) 790 (cond 791 [(flonum? y) (fl+ x y)] 792 [($inexactnum? y) (cfl+ x y)] 793 [else ($+ '+ x y)])] 794 [(and ($inexactnum? x) (cflonum? y)) (cfl+ x y)] 795 [else ($+ '+ x y)])) 796 797(define-library-entry (1+ x) 798 (cond 799 [(flonum? x) (fl+ x 1.0)] 800 [($inexactnum? x) (cfl+ x 1.0)] 801 [else ($+ '1+ x 1)])) 802 803(define-library-entry (add1 x) 804 (cond 805 [(flonum? x) (fl+ x 1.0)] 806 [($inexactnum? x) (cfl+ x 1.0)] 807 [else ($+ 'add1 x 1)])) 808 809(define-library-entry (negate x) 810 (cond 811 [(flonum? x) (fl- x)] 812 [($inexactnum? x) (cfl- x)] 813 [else ($- '- 0 x)])) 814 815(define-library-entry (- x y) 816 (cond 817 [(flonum? x) 818 (cond 819 [(flonum? y) (fl- x y)] 820 [($inexactnum? y) (cfl- x y)] 821 [else ($- '- x y)])] 822 [(and ($inexactnum? x) (cflonum? y)) (cfl- x y)] 823 [else ($- '- x y)])) 824 825(define-library-entry (1- x) 826 (cond 827 [(flonum? x) (fl- x 1.0)] 828 [($inexactnum? x) (cfl- x 1.0)] 829 [else ($- '1- x 1)])) 830 831(define-library-entry (-1+ x) 832 (cond 833 [(flonum? x) (fl- x 1.0)] 834 [($inexactnum? x) (cfl- x 1.0)] 835 [else ($- '-1+ x 1)])) 836 837(define-library-entry (sub1 x) 838 (cond 839 [(flonum? x) (fl- x 1.0)] 840 [($inexactnum? x) (cfl- x 1.0)] 841 [else ($- 'sub1 x 1)])) 842 843(define-library-entry (* x y) 844 (cond 845 [(flonum? x) 846 (cond 847 [(flonum? y) (fl* x y)] 848 [($inexactnum? y) (cfl* x y)] 849 [else ($* '* x y)])] 850 [(and ($inexactnum? x) (cflonum? y)) (cfl* x y)] 851 [else ($* '* x y)])) 852 853(define-library-entry (/ x y) 854 (cond 855 [(flonum? x) 856 (cond 857 [(flonum? y) (fl/ x y)] 858 [($inexactnum? y) (cfl/ x y)] 859 [else ($/ '/ x y)])] 860 [(and ($inexactnum? x) (cflonum? y)) (cfl/ x y)] 861 [else ($/ '/ x y)])) 862 863;;; The logical operators assume the fixnum case is inlined. 864(let () 865 (define exactintoops1 866 (lambda (who x) 867 ($oops who "~s is not an exact integer" x))) 868 (define exactintoops2 869 (lambda (who x y) 870 (exactintoops1 who (if (or (fixnum? x) (bignum? x)) y x)))) 871 872 (define-library-entry (logand x y) 873 (if (if (fixnum? x) 874 (bignum? y) 875 (and (bignum? x) 876 (or (fixnum? y) (bignum? y)))) 877 ($logand x y) 878 (exactintoops2 'logand x y))) 879 880 (define-library-entry (bitwise-and x y) 881 (if (if (fixnum? x) 882 (bignum? y) 883 (and (bignum? x) 884 (or (fixnum? y) (bignum? y)))) 885 ($logand x y) 886 (exactintoops2 'bitwise-and x y))) 887 888 (define-library-entry (logior x y) ; same as logor 889 (if (if (fixnum? x) 890 (bignum? y) 891 (and (bignum? x) 892 (or (fixnum? y) (bignum? y)))) 893 ($logor x y) 894 (exactintoops2 'logior x y))) 895 896 (define-library-entry (logor x y) 897 (if (if (fixnum? x) 898 (bignum? y) 899 (and (bignum? x) 900 (or (fixnum? y) (bignum? y)))) 901 ($logor x y) 902 (exactintoops2 'logor x y))) 903 904 (define-library-entry (bitwise-ior x y) 905 (if (if (fixnum? x) 906 (bignum? y) 907 (and (bignum? x) 908 (or (fixnum? y) (bignum? y)))) 909 ($logor x y) 910 (exactintoops2 'bitwise-ior x y))) 911 912 (define-library-entry (logxor x y) 913 (if (if (fixnum? x) 914 (bignum? y) 915 (and (bignum? x) 916 (or (fixnum? y) (bignum? y)))) 917 ($logxor x y) 918 (exactintoops2 'logxor x y))) 919 920 (define-library-entry (bitwise-xor x y) 921 (if (if (fixnum? x) 922 (bignum? y) 923 (and (bignum? x) 924 (or (fixnum? y) (bignum? y)))) 925 ($logxor x y) 926 (exactintoops2 'bitwise-xor x y))) 927 928 (define-library-entry (lognot x) 929 (if (bignum? x) 930 ($lognot x) 931 (exactintoops1 'lognot x))) 932 933 (define-library-entry (bitwise-not x) 934 (if (bignum? x) 935 ($lognot x) 936 (exactintoops1 'bitwise-not x))) 937 938 (let () 939 (define (do-logbit? who k n) 940 (cond 941 [(fixnum? n) 942 (cond 943 [(fixnum? k) 944 (if (fx< k 0) 945 ($oops who "invalid bit index ~s" k) 946 ; this case left to us by cp1in logbit? handler 947 (fx< n 0))] 948 [(bignum? k) 949 (if (< k 0) 950 ($oops who "invalid bit index ~s" k) 951 ; this case left to us by cp1in logbit? handler 952 (fx< n 0))] 953 [else (exactintoops1 who k)])] 954 [(bignum? n) 955 (cond 956 [(fixnum? k) 957 (if (fx< k 0) 958 ($oops who "invalid bit index ~s" k) 959 ($logbit? k n))] 960 [(bignum? k) 961 (if (< k 0) 962 ($oops who "invalid bit index ~s" k) 963 ; $logbit? requires k to be a fixnum 964 (fxlogtest (ash n (- k)) 1))] 965 [else (exactintoops1 who k)])] 966 [else (exactintoops1 who n)])) 967 (define-library-entry (logbit? k n) (do-logbit? 'logbit? k n)) 968 (define-library-entry (bitwise-bit-set? n k) (do-logbit? 'bitwise-bit-set? k n))) 969 970 (define-library-entry (logbit0 k n) 971 (if (or (fixnum? n) (bignum? n)) 972 (cond 973 [(fixnum? k) 974 (if (fx< k 0) 975 ($oops 'logbit0 "invalid bit index ~s" k) 976 ($logbit0 k n))] 977 [(bignum? k) 978 (if (< k 0) 979 ($oops 'logbit0 "invalid bit index ~s" k) 980 ; $logbit0 requires k to be a fixnum 981 ($logand n ($lognot (ash 1 k))))] 982 [else (exactintoops1 'logbit0 k)]) 983 (exactintoops1 'logbit0 n))) 984 985 (define-library-entry (logbit1 k n) 986 (if (or (fixnum? n) (bignum? n)) 987 (cond 988 [(fixnum? k) 989 (if (fx< k 0) 990 ($oops 'logbit1 "invalid bit index ~s" k) 991 ($logbit1 k n))] 992 [(bignum? k) 993 (if (< k 0) 994 ($oops 'logbit1 "invalid bit index ~s" k) 995 ; $logbit1 requires k to be a fixnum 996 ($logor n (ash 1 k)))] 997 [else (exactintoops1 'logbit1 k)]) 998 (exactintoops1 'logbit1 n))) 999 1000 (define-library-entry (logtest x y) 1001 (if (if (fixnum? x) 1002 (bignum? y) 1003 (and (bignum? x) 1004 (or (fixnum? y) (bignum? y)))) 1005 ($logtest x y) 1006 (exactintoops2 'logtest x y))) 1007) 1008 1009(let () 1010 (include "io-types.ss") 1011 (define-syntax define-safe/unsafe 1012 (lambda (x) 1013 (syntax-case x () 1014 [(k (name arg ...) e ...) 1015 (with-syntax ([safe-name (construct-name #'k "safe-" #'name)] 1016 [unsafe-name (construct-name #'k "unsafe-" #'name)] 1017 [who (datum->syntax #'k 'who)] 1018 [check (datum->syntax #'k 'check)]) 1019 #'(let () 1020 (define who 'name) 1021 (let () 1022 (define-syntax check (identifier-syntax if)) 1023 (define-library-entry (safe-name arg ...) e ...)) 1024 (let () 1025 (define-syntax check (syntax-rules () [(_ e1 e2 e3) e2])) 1026 (define-library-entry (unsafe-name arg ...) e ...))))]))) 1027 (define-safe/unsafe (get-u8 p) 1028 (check (and (input-port? p) (binary-port? p)) 1029 ((port-handler-get ($port-handler p)) 'get-u8 p) 1030 ($oops who "~s is not a binary input port" p))) 1031 (define-safe/unsafe (get-char p) 1032 (check (and (input-port? p) (textual-port? p)) 1033 ((port-handler-get ($port-handler p)) who p) 1034 ($oops who "~s is not a textual input port" p))) 1035 (define-safe/unsafe (read-char p) 1036 (check (and (input-port? p) (textual-port? p)) 1037 ((port-handler-get ($port-handler p)) who p) 1038 ($oops who "~s is not a textual input port" p))) 1039 (define-safe/unsafe (lookahead-u8 p) 1040 (check (and (input-port? p) (binary-port? p)) 1041 ((port-handler-lookahead ($port-handler p)) 'lookahead-u8 p) 1042 ($oops who "~s is not a binary input port" p))) 1043 (define-safe/unsafe (lookahead-char p) 1044 (check (and (input-port? p) (textual-port? p)) 1045 ((port-handler-lookahead ($port-handler p)) who p) 1046 ($oops who "~s is not a textual input port" p))) 1047 (define-safe/unsafe (peek-char p) 1048 (check (and (input-port? p) (textual-port? p)) 1049 ((port-handler-lookahead ($port-handler p)) who p) 1050 ($oops who "~s is not a textual input port" p))) 1051 (define-safe/unsafe (unget-u8 p x) 1052 (check (and (input-port? p) (binary-port? p)) 1053 (check (or (and (fixnum? x) (fx<= 0 x 255)) (eof-object? x)) 1054 ((port-handler-unget ($port-handler p)) who p x) 1055 ($oops who "~s is not an octet or the eof object" x)) 1056 ($oops who "~s is not a binary input port" p))) 1057 (define-safe/unsafe (unget-char p x) 1058 (check (and (input-port? p) (textual-port? p)) 1059 (check (or (char? x) (eof-object? x)) 1060 ((port-handler-unget ($port-handler p)) who p x) 1061 ($oops who "~s is not an character or the eof object" x)) 1062 ($oops who "~s is not a textual input port" p))) 1063 (define-safe/unsafe (unread-char x p) 1064 (check (and (input-port? p) (textual-port? p)) 1065 (check (or (char? x) (eof-object? x)) 1066 ((port-handler-unget ($port-handler p)) who p x) 1067 ($oops who "~s is not an character or the eof object" x)) 1068 ($oops who "~s is not a textual input port" p))) 1069 (define-safe/unsafe (put-u8 p x) 1070 (check (and (output-port? p) (binary-port? p)) 1071 (check (and (fixnum? x) (fx<= 0 x 255)) 1072 ((port-handler-put ($port-handler p)) who p x) 1073 ($oops who "~s is not an octet" x)) 1074 ($oops who "~s is not a binary output port" p))) 1075 (define-safe/unsafe (put-char p x) 1076 (check (and (output-port? p) (textual-port? p)) 1077 (check (char? x) 1078 ((port-handler-put ($port-handler p)) who p x) 1079 ($oops who "~s is not a character" x)) 1080 ($oops who "~s is not a textual output port" p))) 1081 (define-safe/unsafe (write-char x p) 1082 (check (and (output-port? p) (textual-port? p)) 1083 (check (char? x) 1084 ((port-handler-put ($port-handler p)) who p x) 1085 ($oops who "~s is not a character" x)) 1086 ($oops who "~s is not a textual output port" p))) 1087 (define-safe/unsafe (newline p) 1088 (check (and (output-port? p) (textual-port? p)) 1089 ((port-handler-put ($port-handler p)) who p #\newline) 1090 ($oops who "~s is not a textual output port" p))) 1091 (define-safe/unsafe (port-eof? p) 1092 (check (input-port? p) 1093 (eof-object? ((port-handler-lookahead ($port-handler p)) who p)) 1094 ($oops who "~s is not an input port" p))) 1095 (define-library-entry (put-bytevector bop bv start count) 1096 (define who 'put-bytevector) 1097 (if (or (fx> count max-put-copy) (fx> count (binary-port-output-count bop))) 1098 (let ([put-some (port-handler-put-some ($port-handler bop))]) 1099 (let loop ([start start] [count count]) 1100 (unless (eq? 0 count) 1101 (let ([n (put-some who bop bv start count)]) 1102 (loop (fx+ start n) (fx- count n)))))) 1103 (let ([i (binary-port-output-index bop)]) 1104 ; counting on cp1in generating call to $byte-copy here and 1105 ; $byte-copy foreign procedure to be compiled w/o interrupt 1106 ; trap check in prims.ss. otherwise this won't be safe for 1107 ; multitasking. 1108 (bytevector-copy! bv start (binary-port-output-buffer bop) i count) 1109 (set-binary-port-output-index! bop (fx+ i count))))) 1110 (define-library-entry (put-bytevector-some bop bv start count) 1111 (define who 'put-bytevector-some) 1112 (if (or (fx> count max-put-copy) (fx> count (binary-port-output-count bop))) 1113 (let ([put-some (port-handler-put-some ($port-handler bop))]) 1114 (put-some who bop bv start count)) 1115 (let ([i (binary-port-output-index bop)]) 1116 ; counting on cp1in generating call to $byte-copy here and 1117 ; $byte-copy foreign procedure to be compiled w/o interrupt 1118 ; trap check in prims.ss. otherwise this won't be safe for 1119 ; multitasking. 1120 (bytevector-copy! bv start (binary-port-output-buffer bop) i count) 1121 (set-binary-port-output-index! bop (fx+ i count)) 1122 count))) 1123 (define-library-entry (put-string top st start count) 1124 (define who 'put-string) 1125 (if (or (fx> count max-put-copy) (fx> count (textual-port-output-count top))) 1126 (let ([put-some (port-handler-put-some ($port-handler top))]) 1127 (let loop ([start start] [count count]) 1128 (unless (eq? 0 count) 1129 (let ([n (put-some who top st start count)]) 1130 (loop (fx+ start n) (fx- count n)))))) 1131 (let ([i (textual-port-output-index top)]) 1132 ; counting on cp1in generating call to $byte-copy here and 1133 ; $byte-copy foreign procedure to be compiled w/o interrupt 1134 ; trap check in prims.ss. otherwise this won't be safe for 1135 ; multitasking. 1136 (string-copy! st start (textual-port-output-buffer top) i count) 1137 (set-textual-port-output-index! top (fx+ i count))))) 1138 (define-library-entry (put-string-some top st start count) 1139 (define who 'put-string-some) 1140 (if (or (fx> count max-put-copy) (fx> count (textual-port-output-count top))) 1141 (let ([put-some (port-handler-put-some ($port-handler top))]) 1142 (put-some who top st start count)) 1143 (let ([i (textual-port-output-index top)]) 1144 ; counting on cp1in generating call to $byte-copy here and 1145 ; $byte-copy foreign procedure to be compiled w/o interrupt 1146 ; trap check in prims.ss. otherwise this won't be safe for 1147 ; multitasking. 1148 (string-copy! st start (textual-port-output-buffer top) i count) 1149 (set-textual-port-output-index! top (fx+ i count)) 1150 count))) 1151 (define-library-entry (display-string st top) 1152 (define who 'display-string) 1153 (let ([start 0] [count (string-length st)]) 1154 (if (or (fx> count max-put-copy) (fx> count (textual-port-output-count top))) 1155 (let ([put-some (port-handler-put-some ($port-handler top))]) 1156 (let loop ([start start] [count count]) 1157 (unless (eq? 0 count) 1158 (let ([n (put-some who top st start count)]) 1159 (loop (fx+ start n) (fx- count n)))))) 1160 (let ([i (textual-port-output-index top)]) 1161 ; counting on cp1in generating call to $byte-copy here and 1162 ; $byte-copy foreign procedure to be compiled w/o interrupt 1163 ; trap check in prims.ss. otherwise this won't be safe for 1164 ; multitasking. 1165 (string-copy! st start (textual-port-output-buffer top) i count) 1166 (set-textual-port-output-index! top (fx+ i count)))))) 1167) 1168 1169(define-library-entry ($top-level-value x) 1170 (unless (symbol? x) 1171 ($oops '$top-level-value "~s is not a symbol" x)) 1172 (unless ($top-level-bound? x) 1173 ($oops #f "variable ~:s is not bound" x)) 1174 (#3%$top-level-value x)) 1175 1176(define-library-entry (event) 1177 (define (timer) 1178 (if (eq? ($tc-field 'timer-ticks ($tc)) 0) 1179 (let ([handler (timer-interrupt-handler)]) 1180 ($tc-field 'timer-ticks ($tc) #f) 1181 (signal) 1182 (handler)) 1183 (signal))) 1184 (define (signal) 1185 (let ([x ($tc-field 'signal-interrupt-pending ($tc))]) 1186 (if x 1187 (let ([handler $signal-interrupt-handler]) 1188 ($tc-field 'signal-interrupt-pending ($tc) #f) 1189 (keyboard) 1190 (for-each handler ($dequeue-scheme-signals ($tc)))) 1191 (keyboard)))) 1192 (define (keyboard) 1193 (if ($tc-field 'keyboard-interrupt-pending ($tc)) 1194 (let ([handler (keyboard-interrupt-handler)]) 1195 ($tc-field 'keyboard-interrupt-pending ($tc) #f) 1196 (collector) 1197 (handler)) 1198 (collector))) 1199 (define (collector) 1200 (if $collect-request-pending 1201 (let ([handler $collect-rendezvous]) 1202 (restart-timer) 1203 (handler)) 1204 (restart-timer))) 1205 (define (restart-timer) 1206 (cond 1207 [($tc-field 'timer-ticks ($tc)) => 1208 (lambda (t) 1209 (let ([ticks (fxmin t (constant default-timer-ticks))]) 1210 ($tc-field 'timer-ticks ($tc) (fx- t ticks)) 1211 ($tc-field 'something-pending ($tc) #t) 1212 ($set-timer ticks)))] 1213 [else 1214 ($set-timer (constant default-timer-ticks))])) 1215 (if (and (fx= ($tc-field 'disable-count ($tc)) 0) ($tc-field 'something-pending ($tc))) 1216 (begin 1217 ($set-timer (most-positive-fixnum)) 1218 ($tc-field 'something-pending ($tc) #f) 1219 (timer)) 1220 ($set-timer (constant default-timer-ticks)))) 1221 1222(define-library-entry (virtual-register idx) 1223 ($oops 'virtual-register "invalid index ~s" idx)) 1224 1225(define-library-entry (set-virtual-register! idx) 1226 ($oops 'set-virtual-register! "invalid index ~s" idx)) 1227 1228(define-library-entry (map1 f ls) 1229 (let map ([f f] [ls ls]) 1230 (if (null? ls) 1231 '() 1232 (let ((r (cdr ls))) 1233 (if (null? r) 1234 (list (f (car ls))) 1235 ; cdr first to avoid getting sick if f mutates input 1236 (let ([tail (map f (cdr r))]) 1237 (list* (f (car ls)) (f (car r)) tail))))))) 1238 1239(define-library-entry (map2 f ls1 ls2) 1240 (let map ([f f] [ls1 ls1] [ls2 ls2]) 1241 (if (null? ls1) 1242 '() 1243 (let ((r1 (cdr ls1))) 1244 (if (null? r1) 1245 (list (f (car ls1) (car ls2))) 1246 (let ((r2 (cdr ls2))) 1247 ; cdr first to avoid getting sick if f mutates input 1248 (let ([tail (map f (cdr r1) (cdr r2))]) 1249 (list* (f (car ls1) (car ls2)) 1250 (f (car r1) (car r2)) 1251 tail)))))))) 1252 1253(define-library-entry (map-car ls) 1254 (let map ([ls ls]) 1255 (if (null? ls) 1256 '() 1257 (let ((r (cdr ls))) 1258 (if (null? r) 1259 (list (car (car ls))) 1260 (list* (car (car ls)) (car (car r)) (map (cdr r)))))))) 1261 1262(define-library-entry (map-cdr ls) 1263 (let map ([ls ls]) 1264 (if (null? ls) 1265 '() 1266 (let ((r (cdr ls))) 1267 (if (null? r) 1268 (list (cdr (car ls))) 1269 (list* (cdr (car ls)) (cdr (car r)) (map (cdr r)))))))) 1270 1271(define-library-entry (map-cons ls1 ls2) 1272 (let map ([ls1 ls1] [ls2 ls2]) 1273 (if (null? ls1) 1274 '() 1275 (let ((r1 (cdr ls1))) 1276 (if (null? r1) 1277 (list (cons (car ls1) (car ls2))) 1278 (let ((r2 (cdr ls2))) 1279 (list* (cons (car ls1) (car ls2)) 1280 (cons (car r1) (car r2)) 1281 (map (cdr r1) (cdr r2))))))))) 1282 1283(define-library-entry (for-each1 f ls) 1284 (unless (null? ls) 1285 (let for-each ([x (car ls)] [ls (cdr ls)]) 1286 (if (null? ls) 1287 (f x) 1288 (begin 1289 (f x) 1290 (for-each (car ls) (cdr ls))))))) 1291 1292(define-library-entry (for-each2 f ls1 ls2) 1293 (unless (null? ls1) 1294 (let for-each ([x (car ls1)] [ls1 (cdr ls1)] [ls2 ls2]) 1295 (if (null? ls1) 1296 (f x (car ls2)) 1297 (begin 1298 (f x (car ls2)) 1299 (for-each (car ls1) (cdr ls1) (cdr ls2))))))) 1300 1301(define-library-entry (andmap1 f ls) 1302 (or (null? ls) 1303 (let andmap ([ls ls]) 1304 (let ([x (car ls)] [ls (cdr ls)]) 1305 (if (null? ls) 1306 (f x) 1307 (and (f x) (andmap ls))))))) 1308 1309(define-library-entry (ormap1 f ls) 1310 (and (not (null? ls)) 1311 (let ormap ([ls ls]) 1312 (let ([x (car ls)] [ls (cdr ls)]) 1313 (if (null? ls) 1314 (f x) 1315 (or (f x) (ormap ls))))))) 1316 1317(define-library-entry (vector-for-each1 p v) 1318 (let ([n (vector-length v)]) 1319 (unless (fx= n 0) 1320 (let loop ([i 0]) 1321 (let ([j (fx+ i 1)]) 1322 (if (fx= j n) 1323 (p (vector-ref v i)) 1324 (begin 1325 (p (vector-ref v i)) 1326 (loop j)))))))) 1327 1328(define-library-entry (vector-for-each2 p u v) 1329 (let ([n (vector-length u)]) 1330 (unless (fx= n 0) 1331 (let loop ([i 0]) 1332 (let ([j (fx+ i 1)]) 1333 (if (fx= j n) 1334 (p (vector-ref u i) (vector-ref v i)) 1335 (begin 1336 (p (vector-ref u i) (vector-ref v i)) 1337 (loop j)))))))) 1338 1339(define-library-entry (vector-map1 p v) 1340 (let ([n (vector-length v)]) 1341 (let f ([i (fx- n 1)]) 1342 (if (fx> i 0) 1343 (let ([x1 (p (vector-ref v i))] [x2 (p (vector-ref v (fx- i 1)))]) 1344 (let ([vout (f (fx- i 2))]) 1345 (vector-set! vout i x1) 1346 (vector-set! vout (fx- i 1) x2) 1347 vout)) 1348 (make-vector n (if (fx= i 0) (p (vector-ref v 0)) 0)))))) 1349 1350(define-library-entry (vector-map2 p u v) 1351 (let ([n (vector-length u)]) 1352 (let f ([i (fx- n 1)]) 1353 (if (fx> i 0) 1354 (let ([x1 (p (vector-ref u i) (vector-ref v i))] 1355 [x2 (let ([j (fx- i 1)]) 1356 (p (vector-ref u j) (vector-ref v j)))]) 1357 (let ([vout (f (fx- i 2))]) 1358 (vector-set! vout i x1) 1359 (vector-set! vout (fx- i 1) x2) 1360 vout)) 1361 (make-vector n 1362 (if (fx= i 0) 1363 (p (vector-ref u 0) (vector-ref v 0)) 1364 0)))))) 1365 1366(define-library-entry (string-for-each1 p s) 1367 (let ([n (string-length s)]) 1368 (unless (fx= n 0) 1369 (let loop ([i 0]) 1370 (let ([j (fx+ i 1)]) 1371 (if (fx= j n) 1372 (p (string-ref s i)) 1373 (begin 1374 (p (string-ref s i)) 1375 (loop j)))))))) 1376 1377(define-library-entry (string-for-each2 p s t) 1378 (let ([n (string-length s)]) 1379 (unless (fx= n 0) 1380 (let loop ([i 0]) 1381 (let ([j (fx+ i 1)]) 1382 (if (fx= j n) 1383 (p (string-ref s i) (string-ref t i)) 1384 (begin 1385 (p (string-ref s i) (string-ref t i)) 1386 (loop j)))))))) 1387 1388(define-library-entry (fold-left1 combine nil ls) 1389 (if (null? ls) 1390 nil 1391 (let fold-left ([ls ls] [acc nil]) 1392 (let ([cdrls (cdr ls)]) 1393 (if (null? cdrls) 1394 (combine acc (car ls)) 1395 (fold-left cdrls (combine acc (car ls)))))))) 1396 1397(define-library-entry (fold-left2 combine nil ls1 ls2) 1398 (if (null? ls1) 1399 nil 1400 (let fold-left ([ls1 ls1] [ls2 ls2] [acc nil]) 1401 (let ([cdrls1 (cdr ls1)]) 1402 (if (null? cdrls1) 1403 (combine acc (car ls1) (car ls2)) 1404 (fold-left cdrls1 (cdr ls2) 1405 (combine acc (car ls1) (car ls2)))))))) 1406 1407(define-library-entry (fold-right1 combine nil ls) 1408 (let fold-right1 ([combine combine] [nil nil] [ls ls]) 1409 (if (null? ls) 1410 nil 1411 ; naturally does cdrs first to avoid mutation sickness 1412 (combine (car ls) (fold-right1 combine nil (cdr ls)))))) 1413 1414(define-library-entry (fold-right2 combine nil ls1 ls2) 1415 (let fold-right2 ([combine combine] [nil nil] [ls1 ls1] [ls2 ls2]) 1416 (if (null? ls1) 1417 nil 1418 ; naturally does cdrs first to avoid mutation sickness 1419 (combine (car ls1) (car ls2) 1420 (fold-right2 combine nil (cdr ls1) (cdr ls2)))))) 1421 1422(eval-when (compile) 1423(define-syntax doapply 1424 (syntax-rules () 1425 [(_ p (x ...) ls) (if (null? ls) (p x ...) (doapply p (x ...) ls (ls)))] 1426 [(_ p (x ...) ls (ls1 ... lsn)) 1427 (= (length #'(ls1 ...)) 4) 1428 ($apply p (fx+ (length '(x ...)) (length '(ls1 ...)) (length lsn)) 1429 (list* x ... ls))] 1430 [(_ p (x ...) ls (ls1 ... lsn-1)) 1431 (let ([lsn (cdr lsn-1)]) 1432 (if (null? lsn) 1433 (p x ... (car ls1) ... (car lsn-1)) 1434 (doapply p (x ...) ls (ls1 ... lsn-1 lsn))))])) 1435) 1436 1437(define-library-entry (apply0 p ls) 1438 (doapply p () ls)) 1439 1440(define-library-entry (apply1 p x1 ls) 1441 (doapply p (x1) ls)) 1442 1443(define-library-entry (apply2 p x1 x2 ls) 1444 (doapply p (x1 x2) ls)) 1445 1446(define-library-entry (apply3 p x1 x2 x3 ls) 1447 (doapply p (x1 x2 x3) ls)) 1448 1449(define-library-entry ($check-continuation c check-as? as) 1450 (let ([who 'call-in-other-continuation]) 1451 (unless ($continuation? c) 1452 ($oops who "~s is not a continuation" c)) 1453 (when check-as? 1454 (unless (let ([c-as ($continuation-attachments c)]) 1455 (or (eq? as c-as) 1456 (and (pair? as) 1457 (eq? (cdr as) c-as)))) 1458 ($oops who "~s is not an extension of of the attachments of ~s" as c))) 1459 ($do-wind ($current-winders) ($continuation-winders c)))) 1460 1461(define-library-entry (eqv? x y) 1462 (if (eq? x y) 1463 #t 1464 (exclusive-cond 1465 [(flonum? x) (and (flonum? y) ($fleqv? x y))] 1466 [($inexactnum? x) 1467 (and ($inexactnum? y) 1468 ($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y)) 1469 ($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y)))] 1470 [(bignum? x) (and (bignum? y) (= x y))] 1471 [(ratnum? x) (and (ratnum? y) (= x y))] 1472 [($exactnum? x) (and ($exactnum? y) (= x y))] 1473 [else #f]))) 1474 1475(define-library-entry (memv x ls) 1476 (if (or (symbol? x) (fixmediate? x)) 1477 (memq x ls) 1478 (let memv ([ls ls]) 1479 (and (not (null? ls)) 1480 (if (eqv? (car ls) x) 1481 ls 1482 (let ([ls (cdr ls)]) 1483 (and (not (null? ls)) 1484 (if (eqv? (car ls) x) 1485 ls 1486 (memv (cdr ls)))))))))) 1487 1488(define-library-entry (reverse ls) 1489 (let loop ([ls ls] [a '()]) 1490 (if (null? ls) 1491 a 1492 (let ([ls2 (cdr ls)]) 1493 (if (null? ls2) 1494 (cons (car ls) a) 1495 (loop (cdr ls2) (cons* (car ls2) (car ls) a))))))) 1496 1497(let () 1498 (include "hashtable-types.ss") 1499 1500 (define (ht-size-cas! ht old new) 1501 (let-syntax ([size-field-pos 1502 (lambda (stx) 1503 (include "hashtable-types.ss") 1504 (let loop ([names (csv7:record-type-field-names (record-type-descriptor ht))]) 1505 (if (eq? (car names) 'size) 1506 0 1507 (fx+ 1 (loop (cdr names))))))]) 1508 ($record-cas! ht (size-field-pos) old new))) 1509 1510 ;;; eq hashtable operations must be compiled with 1511 ;;; generate-interrupt-trap #f and optimize-level 3 1512 ;;; so they can't be interrupted by a collection 1513 (let () 1514 (define-syntax lookup-keyval 1515 (syntax-rules () 1516 [(_ ?x ?b succ fail) 1517 (let ([x ?x]) 1518 (let loop ([b ?b]) 1519 (if (fixnum? b) 1520 fail 1521 (let ([keyval ($tlc-keyval b)]) 1522 (if (eq? (car keyval) x) 1523 (succ keyval) 1524 (loop ($tlc-next b)))))))])) 1525 1526 (define-syntax incr-size! 1527 (syntax-rules () 1528 [(_ h vec) 1529 (let ([size (fx+ (ht-size h) 1)] [n (vector-length vec)]) 1530 (ht-size-set! h size) 1531 (when (and (fx> size n) (fx< n (fxsrl (most-positive-fixnum) 1))) 1532 (adjust! h vec n (fxsll n 1))))])) 1533 1534 (define-syntax decr-size! 1535 (syntax-rules () 1536 [(_ h vec) 1537 (let ([size (fx- (ht-size h) 1)] [n (vector-length vec)]) 1538 (ht-size-set! h size) 1539 (when (and (fx< size (fxsrl n 2)) (fx> n (ht-minlen h))) 1540 (let ([target (fxmax (fxsll size 2) (ht-minlen h))]) 1541 (let loop ([n2 n]) 1542 (let ([n2 (fxsrl n2 1)]) 1543 (if (fx<= n2 target) 1544 (adjust! h vec n n2) 1545 (loop n2)))))))])) 1546 1547 ;; Must be consistent with `eq_hash` in "../c/segment.h" 1548 (define-syntax eq-hash 1549 (syntax-rules () 1550 [(_ v-expr) (fixmix ($fxaddress v-expr))])) 1551 1552 (define adjust! 1553 (lambda (h vec1 n1 n2) 1554 (let ([vec2 ($make-eqhash-vector n2)] [mask2 (fx- n2 1)]) 1555 (do ([i1 0 (fx+ i1 1)]) 1556 ((fx= i1 n1)) 1557 (let loop ([b (vector-ref vec1 i1)]) 1558 (unless (fixnum? b) 1559 (let ([next ($tlc-next b)] [keyval ($tlc-keyval b)]) 1560 (let ([i2 (fxlogand (eq-hash (car keyval)) mask2)]) 1561 ($set-tlc-next! b (vector-ref vec2 i2)) 1562 (vector-set! vec2 i2 b)) 1563 (loop next))))) 1564 (ht-vec-set! h vec2)))) 1565 1566 (define-library-entry (eq-hashtable-ref h x v) 1567 (lookup-keyval x 1568 (let ([vec (ht-vec h)]) 1569 (vector-ref vec (fxlogand (eq-hash x) (fx- (vector-length vec) 1)))) 1570 cdr v)) 1571 1572 (define-library-entry (eq-hashtable-ref-cell h x) 1573 (lookup-keyval x 1574 (let ([vec (ht-vec h)]) 1575 (vector-ref vec (fxlogand (eq-hash x) (fx- (vector-length vec) 1)))) 1576 (lambda (x) x) 1577 #f)) 1578 1579 (define-library-entry (eq-hashtable-contains? h x) 1580 (lookup-keyval x 1581 (let ([vec (ht-vec h)]) 1582 (vector-ref vec (fxlogand (eq-hash x) (fx- (vector-length vec) 1)))) 1583 (lambda (x) #t) 1584 #f)) 1585 1586 (define-library-entry (eq-hashtable-cell h x v) 1587 (let* ([vec (ht-vec h)] 1588 [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] 1589 [b (vector-ref vec idx)]) 1590 (lookup-keyval x b 1591 values 1592 (let ([keyval (let ([subtype (eq-ht-subtype h)]) 1593 (cond 1594 [(eq? subtype (constant eq-hashtable-subtype-normal)) (cons x v)] 1595 [(eq? subtype (constant eq-hashtable-subtype-weak)) (weak-cons x v)] 1596 [else (ephemeron-cons x v)]))]) 1597 (vector-set! vec idx ($make-tlc h keyval b)) 1598 (incr-size! h vec) 1599 keyval)))) 1600 1601 ;; Note: never adjusts the vector size. Use `eq-hashtable-set!` 1602 ;; with exclusive access (perhaps in a GC callback) to enable 1603 ;; resizing. 1604 (define-library-entry (eq-hashtable-try-atomic-cell h x v) 1605 (let* ([vec (ht-vec h)] 1606 [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] 1607 [b (vector-ref vec idx)]) 1608 (lookup-keyval x b 1609 values 1610 (let ([keyval (let ([subtype (eq-ht-subtype h)]) 1611 (cond 1612 [(eq? subtype (constant eq-hashtable-subtype-normal)) (cons x v)] 1613 [(eq? subtype (constant eq-hashtable-subtype-weak)) (weak-cons x v)] 1614 [else (ephemeron-cons x v)]))]) 1615 (and (vector-cas! vec idx b ($make-tlc h keyval b)) 1616 (let loop () 1617 (let* ([old-size (ht-size h)] 1618 [size (fx+ old-size 1)]) 1619 (or (ht-size-cas! h old-size size) 1620 (loop)))) 1621 keyval))))) 1622 1623 (let () 1624 (define do-set! 1625 (lambda (h x v) 1626 (let* ([vec (ht-vec h)] 1627 [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] 1628 [b (vector-ref vec idx)]) 1629 (lookup-keyval x b 1630 (lambda (keyval) (set-cdr! keyval v)) 1631 (begin 1632 (vector-set! vec idx 1633 ($make-tlc h 1634 (let ([subtype (eq-ht-subtype h)]) 1635 (cond 1636 [(eq? subtype (constant eq-hashtable-subtype-normal)) (cons x v)] 1637 [(eq? subtype (constant eq-hashtable-subtype-weak)) (weak-cons x v)] 1638 [else (ephemeron-cons x v)])) 1639 b)) 1640 (incr-size! h vec)))))) 1641 1642 (define-library-entry (eq-hashtable-set! h x v) 1643 (do-set! h x v)) 1644 1645 (define-library-entry (eq-hashtable-update! h x p v) 1646 (let* ([vec (ht-vec h)] 1647 [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] 1648 [b (vector-ref vec idx)]) 1649 (lookup-keyval x b 1650 (lambda (a) (set-cdr! a (p (cdr a)))) 1651 (do-set! h x (p v)))))) 1652 1653 (define-library-entry (eq-hashtable-delete! h x) 1654 (let* ([vec (ht-vec h)] 1655 [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] 1656 [b (vector-ref vec idx)]) 1657 (unless (fixnum? b) 1658 (if (eq? (car ($tlc-keyval b)) x) 1659 (begin 1660 (vector-set! vec idx ($tlc-next b)) 1661 ($set-tlc-next! b #f) 1662 (decr-size! h vec)) 1663 (let loop ([b b]) 1664 (let ([n ($tlc-next b)]) 1665 (unless (fixnum? n) 1666 (if (eq? (car ($tlc-keyval n)) x) 1667 (begin 1668 ($set-tlc-next! b ($tlc-next n)) 1669 ($set-tlc-next! n #f) 1670 (decr-size! h vec)) 1671 (loop n))))))))) 1672 ) 1673 1674 ; symbol hashtable operations 1675 (let () 1676 (define-syntax incr-size! 1677 (syntax-rules () 1678 [(_ h vec) 1679 (let ([size (fx+ (ht-size h) 1)] [n (vector-length vec)]) 1680 (ht-size-set! h size) 1681 (when (and (fx> size n) (fx< n (fxsrl (most-positive-fixnum) 1))) 1682 (adjust! h vec (fxsll n 1))))])) 1683 1684 (define-syntax decr-size! 1685 (syntax-rules () 1686 [(_ h vec) 1687 (let ([size (fx- (ht-size h) 1)] [n (vector-length vec)]) 1688 (ht-size-set! h size) 1689 (when (and (fx< size (fxsrl n 2)) (fx> n (ht-minlen h))) 1690 (adjust! h vec (fxsrl n 1))))])) 1691 1692 (define adjust! 1693 (lambda (h vec1 n2) 1694 (let ([vec2 (make-vector n2 '())] 1695 [mask2 (fx- n2 1)]) 1696 (vector-for-each 1697 (lambda (b) 1698 (for-each 1699 (lambda (a) 1700 (let ([hc (fxlogand ($symbol-hash (car a)) mask2)]) 1701 (vector-set! vec2 hc (cons a (vector-ref vec2 hc))))) 1702 b)) 1703 vec1) 1704 (ht-vec-set! h vec2)))) 1705 1706 (define-library-entry (symbol-hashtable-ref h x v) 1707 (let ([hc ($symbol-hash x)]) 1708 (if hc 1709 (let ([vec (ht-vec h)]) 1710 (let loop ([b (vector-ref vec (fxlogand hc (fx- (vector-length vec) 1)))]) 1711 (if (null? b) 1712 v 1713 (let ([a (car b)]) 1714 (if (eq? (car a) x) (cdr a) (loop (cdr b))))))) 1715 (pariah v)))) 1716 1717 (define-library-entry (symbol-hashtable-ref-cell h x) 1718 (let ([hc ($symbol-hash x)]) 1719 (if hc 1720 (let ([vec (ht-vec h)]) 1721 (let loop ([b (vector-ref vec (fxlogand hc (fx- (vector-length vec) 1)))]) 1722 (if (null? b) 1723 #f 1724 (let ([a (car b)]) 1725 (if (eq? (car a) x) a (loop (cdr b))))))) 1726 (pariah #f)))) 1727 1728 (define-library-entry (symbol-hashtable-contains? h x) 1729 (let ([hc ($symbol-hash x)]) 1730 (and hc 1731 (let ([vec (ht-vec h)]) 1732 (let loop ([b (vector-ref vec (fxlogand hc (fx- (vector-length vec) 1)))]) 1733 (and (not (null? b)) 1734 (or (eq? (caar b) x) 1735 (loop (cdr b))))))))) 1736 1737 (define-library-entry (symbol-hashtable-cell h x v) 1738 (let ([vec (ht-vec h)] [hc ($symbol-hash x)]) 1739 (if hc 1740 (let ([idx (fxlogand hc (fx- (vector-length vec) 1))]) 1741 (let ([bucket (vector-ref vec idx)]) 1742 (let loop ([b bucket]) 1743 (if (null? b) 1744 (let ([a (cons x v)]) 1745 (vector-set! vec idx (cons a bucket)) 1746 (incr-size! h vec) 1747 a) 1748 (let ([a (car b)]) 1749 (if (eq? (car a) x) 1750 a 1751 (loop (cdr b)))))))) 1752 (let ([idx (fxlogand (symbol-hash x) (fx- (vector-length vec) 1))]) 1753 (let ([a (cons x v)]) 1754 (vector-set! vec idx (cons a (vector-ref vec idx))) 1755 (incr-size! h vec) 1756 a))))) 1757 1758 (define-library-entry (symbol-hashtable-set! h x v) 1759 (let ([vec (ht-vec h)] [hc ($symbol-hash x)]) 1760 (if hc 1761 (let ([idx (fxlogand hc (fx- (vector-length vec) 1))]) 1762 (let ([bucket (vector-ref vec idx)]) 1763 (let loop ([b bucket]) 1764 (if (null? b) 1765 (begin 1766 (vector-set! vec idx (cons (cons x v) bucket)) 1767 (incr-size! h vec)) 1768 (let ([a (car b)]) 1769 (if (eq? (car a) x) (set-cdr! a v) (loop (cdr b)))))))) 1770 (let ([idx (fxlogand (symbol-hash x) (fx- (vector-length vec) 1))]) 1771 (vector-set! vec idx (cons (cons x v) (vector-ref vec idx))) 1772 (incr-size! h vec))))) 1773 1774 (define-library-entry (symbol-hashtable-update! h x p v) 1775 (let ([vec (ht-vec h)] [hc ($symbol-hash x)]) 1776 (if hc 1777 (let ([idx (fxlogand hc (fx- (vector-length vec) 1))]) 1778 (let ([bucket (vector-ref vec idx)]) 1779 (let loop ([b bucket]) 1780 (if (null? b) 1781 (begin 1782 (vector-set! vec idx (cons (cons x (p v)) bucket)) 1783 (incr-size! h vec)) 1784 (let ([a (car b)]) 1785 (if (eq? (car a) x) 1786 (set-cdr! a (p (cdr a))) 1787 (loop (cdr b)))))))) 1788 (let ([idx (fxlogand (symbol-hash x) (fx- (vector-length vec) 1))]) 1789 (vector-set! vec idx (cons (cons x (p v)) (vector-ref vec idx))) 1790 (incr-size! h vec))))) 1791 1792 (define-library-entry (symbol-hashtable-delete! h x) 1793 (let ([hc ($symbol-hash x)]) 1794 (when hc 1795 (let ([vec (ht-vec h)]) 1796 (let ([idx (fxlogand hc (fx- (vector-length vec) 1))]) 1797 (let loop ([b (vector-ref vec idx)] [p #f]) 1798 (unless (null? b) 1799 (let ([a (car b)]) 1800 (if (eq? (car a) x) 1801 (begin 1802 (if p (set-cdr! p (cdr b)) (vector-set! vec idx (cdr b))) 1803 (decr-size! h vec)) 1804 (loop (cdr b) b)))))))))) 1805 ) 1806) 1807 1808;;; the routines below may cause significant allocation without any 1809;;; embedded calls to other trap-checking routines, so we enable 1810;;; generation-interrupt-trap for them. 1811(eval-when (compile) (generate-interrupt-trap #t)) 1812 1813(define-library-entry (append ls1 ls2) 1814 (let append ([ls1 ls1] [ls2 ls2]) 1815 (if (null? ls1) 1816 ls2 1817 (let ((cdr-ls1 (cdr ls1))) 1818 (if (null? cdr-ls1) 1819 (cons (car ls1) ls2) 1820 (list* (car ls1) (car cdr-ls1) (append (cdr cdr-ls1) ls2))))))) 1821