lib/_system.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_system.scm"
   4
   5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 (##include "header.scm")
  10
  11 ;;;============================================================================
  12
  13 ;;; System procedures
  14
  15 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  16
  17 ;;; Type operations.
  18
  19 (define-prim (##type obj))
  20 (define-prim (##type-cast obj type))
  21 (define-prim (##subtype obj))
  22 (define-prim (##subtype-set! obj subtype))
  23
  24 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  25
  26 ;;; Basic type predicates.
  27
  28 (define-prim (##fixnum? obj)
  29   (##eq? (##type obj) (macro-type-fixnum)))
  30
  31 (define-prim (##subtyped? obj)
  32   (##eq? (##type obj) (macro-type-subtyped)))
  33
  34 (define-prim (##subtyped-mutable? obj))
  35
  36 (define-prim (##subtyped.vector? obj)
  37   (##eq? (##subtype obj) (macro-subtype-vector)))
  38
  39 (define-prim (##subtyped.symbol? obj)
  40   (##eq? (##subtype obj) (macro-subtype-symbol)))
  41
  42 (define-prim (##subtyped.flonum? obj)
  43   (##eq? (##subtype obj) (macro-subtype-flonum)))
  44
  45 (define-prim (##subtyped.bignum? obj)
  46   (##eq? (##subtype obj) (macro-subtype-bignum)))
  47
  48 (define-prim (##special? obj)
  49   (##eq? (##type obj) (macro-type-special)))
  50
  51 ;; (##vector? obj) is defined in "_std.scm"
  52
  53 (define-prim (##ratnum? obj)
  54   (and (##subtyped? obj)
  55        (##eq? (##subtype obj) (macro-subtype-ratnum))))
  56
  57 (define-prim (##cpxnum? obj)
  58   (and (##subtyped? obj)
  59        (##eq? (##subtype obj) (macro-subtype-cpxnum))))
  60
  61 (define-prim (##structure? obj)
  62   (and (##subtyped? obj)
  63        (##eq? (##subtype obj) (macro-subtype-structure))))
  64
  65 (define-prim (##values? obj)
  66   (and (##subtyped? obj)
  67        (##eq? (##subtype obj) (macro-subtype-boxvalues))
  68        (##not (##fixnum.= (##vector-length obj) 1))))
  69
  70 (define-prim (##meroon? obj)
  71   (and (##subtyped? obj)
  72        (##eq? (##subtype obj) (macro-subtype-meroon))))
  73
  74 (define-prim (##jazz? obj)
  75   (and (##subtyped? obj)
  76        (##eq? (##subtype obj) (macro-subtype-jazz))))
  77
  78 (define-prim (##frame? obj)
  79   (and (##subtyped? obj)
  80        (##eq? (##subtype obj) (macro-subtype-frame))))
  81
  82 (define-prim (##continuation? obj)
  83   (and (##subtyped? obj)
  84        (##eq? (##subtype obj) (macro-subtype-continuation))))
  85
  86 (define-prim (##promise? obj)
  87   (and (##subtyped? obj)
  88        (##eq? (##subtype obj) (macro-subtype-promise))))
  89
  90 (define-prim (##return? obj)
  91   (and (##subtyped? obj)
  92        (##eq? (##subtype obj) (macro-subtype-return))))
  93
  94 (define-prim (##foreign? obj)
  95   (and (##subtyped? obj)
  96        (##eq? (##subtype obj) (macro-subtype-foreign))))
  97
  98 ;; (##string? obj) is defined in "_std.scm"
  99 ;; (##s8vector? obj) is defined in "_std.scm"
 100 ;; (##u8vector? obj) is defined in "_std.scm"
 101 ;; (##s16vector? obj) is defined in "_std.scm"
 102 ;; (##u16vector? obj) is defined in "_std.scm"
 103 ;; (##s32vector? obj) is defined in "_std.scm"
 104 ;; (##u32vector? obj) is defined in "_std.scm"
 105 ;; (##s64vector? obj) is defined in "_std.scm"
 106 ;; (##u64vector? obj) is defined in "_std.scm"
 107 ;; (##f32vector? obj) is defined in "_std.scm"
 108 ;; (##f64vector? obj) is defined in "_std.scm"
 109
 110 (define-prim (##flonum? obj)
 111   (and (##subtyped? obj)
 112        (##eq? (##subtype obj) (macro-subtype-flonum))))
 113
 114 (define-prim (##bignum? obj)
 115   (and (##subtyped? obj)
 116        (##eq? (##subtype obj) (macro-subtype-bignum))))
 117
 118 (define-prim (##unbound? obj))
 119
 120 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 121
 122 ;;; Procedures for front end
 123
 124 (define-prim (##quasi-append lst1 lst2)
 125   (macro-force-vars (lst1)
 126     (if (##pair? lst1)
 127       (let ((result (##cons (##car lst1) '())))
 128         (##set-cdr!
 129           (let loop ((end result) (x (##cdr lst1)))
 130             (macro-force-vars (x)
 131               (if (##pair? x)
 132                 (let ((tail (##cons (##car x) '())))
 133                   (##set-cdr! end tail)
 134                   (loop tail (##cdr x)))
 135                 end)))
 136           lst2)
 137         result)
 138       lst2)))
 139
 140 (define-prim (##quasi-list . lst)
 141   lst)
 142
 143 (define-prim (##quasi-cons obj1 obj2)
 144   (##cons obj1 obj2))
 145
 146 (define-prim (##quasi-list->vector lst)
 147   (let loop1 ((x lst) (n 0))
 148     (macro-force-vars (x)
 149       (if (##pair? x)
 150         (loop1 (##cdr x) (##fixnum.+ n 1))
 151         (let ((vect (##make-vector n 0)))
 152           (let loop2 ((x lst) (i 0))
 153             (macro-force-vars (x)
 154               (if (and (##pair? x)      ;; double check in case another
 155                        (##fixnum.< i n));; thread mutates the list
 156                 (begin
 157                   (##vector-set! vect i (##car x))
 158                   (loop2 (##cdr x) (##fixnum.+ i 1)))
 159                 vect))))))))
 160
 161 (define-prim (##quasi-vector . lst)
 162   (##quasi-list->vector lst))
 163
 164 (define-prim (##case-memv obj lst)
 165   (macro-force-vars (obj)
 166     (let loop ((x lst))
 167       (if (##pair? x)
 168         (if (let () (##declare (generic)) (##eqv? obj (##car x)))
 169           x
 170           (loop (##cdr x)))
 171         #f))))
 172
 173 ;;;----------------------------------------------------------------------------
 174
 175 ;;; Object equality.
 176
 177 (define-prim (##eqv? obj1 obj2)
 178   (macro-number-dispatch obj1 (##eq? obj1 obj2)
 179     (and (##fixnum? obj2) (##fixnum.= obj1 obj2)) ;; obj1 = fixnum
 180     (and (##bignum? obj2) (##bignum.= obj1 obj2)) ;; obj1 = bignum
 181     (and (##ratnum? obj2) (##ratnum.= obj1 obj2)) ;; obj1 = ratnum
 182     (and (##flonum? obj2) (##bvector-equal? obj1 obj2)) ;; obj1 = flonum
 183     (and (##cpxnum? obj2) ;; obj1 = cpxnum
 184          (##eqv? (macro-cpxnum-real obj1) (macro-cpxnum-real obj2))
 185          (##eqv? (macro-cpxnum-imag obj1) (macro-cpxnum-imag obj2)))))
 186
 187 (define-prim (eqv? obj1 obj2)
 188   (macro-force-vars (obj1 obj2)
 189     (let ()
 190       (##declare (generic)) ;; avoid fixnum specific ##eqv?
 191       (##eqv? obj1 obj2))))
 192
 193 (define-prim (##eq? obj1 obj2))
 194
 195 (define-prim (eq? obj1 obj2)
 196   (macro-force-vars (obj1 obj2)
 197     (##eq? obj1 obj2)))
 198
 199 (define-prim (##bvector-equal? obj1 obj2)
 200
 201   (define (equal obj1 obj2 len)
 202     (let loop ((i (##fixnum.- len 1)))
 203       (or (##fixnum.< i 0)
 204           (and (##fixnum.= (##u16vector-ref obj1 i)
 205                            (##u16vector-ref obj2 i))
 206                (loop (##fixnum.- i 1))))))
 207
 208   (let ((len-obj1 (##u8vector-length obj1)))
 209     (and (##fixnum.= len-obj1 (##u8vector-length obj2))
 210          (if (##fixnum.odd? len-obj1)
 211            (let ((i (##fixnum.- len-obj1 1)))
 212              (and (##fixnum.= (##u8vector-ref obj1 i)
 213                               (##u8vector-ref obj2 i))
 214                   (equal obj1
 215                          obj2
 216                          (##fixnum.arithmetic-shift-right len-obj1 1))))
 217            (equal obj1
 218                   obj2
 219                   (##fixnum.arithmetic-shift-right len-obj1 1))))))
 220
 221 (define-prim (##equal? obj1 obj2)
 222
 223   (define (eqv obj1 obj2)
 224     (##declare (generic)) ;; avoid fixnum specific ##eqv?
 225     (##eqv? obj1 obj2))
 226
 227   (define (structure-equal obj1 obj2 type len)
 228     (or (##not type) ;; have we reached root of inheritance chain?
 229         (let ((fields (##type-fields type)))
 230           (let loop ((i*3 (##fixnum.- (##vector-length fields) 3))
 231                      (len len))
 232             (if (##fixnum.< i*3 0)
 233               (structure-equal obj1 obj2 (##type-super type) len)
 234               (let ((field-attributes
 235                      (##vector-ref fields (##fixnum.+ i*3 1)))
 236                     (len-1
 237                      (##fixnum.- len 1)))
 238                 (and (or (##not (##fixnum.=
 239                                  (##fixnum.bitwise-and field-attributes 4)
 240                                  0))
 241                          (equal (##unchecked-structure-ref
 242                                  obj1
 243                                  len-1
 244                                  type
 245                                  #f)
 246                                 (##unchecked-structure-ref
 247                                  obj2
 248                                  len-1
 249                                  type
 250                                  #f)))
 251                      (loop (##fixnum.- i*3 3)
 252                            len-1))))))))
 253
 254   (define (equal obj1 obj2)
 255     (macro-force-vars (obj1 obj2)
 256       (cond ((##eq? obj1 obj2)
 257              #t)
 258             ((##pair? obj1)
 259              (and (##pair? obj2)
 260                   (equal (##car obj1) (##car obj2))
 261                   (equal (##cdr obj1) (##cdr obj2))))
 262             ((##subtyped? obj1)
 263              (and (##subtyped? obj2)
 264                   (let ((subtype-obj1 (##subtype obj1)))
 265                     (and (##fixnum.= subtype-obj1 (##subtype obj2))
 266                          (cond ((macro-subtype-bvector? subtype-obj1)
 267                                 (##bvector-equal? obj1 obj2))
 268                                ((##vector? obj1)
 269                                 (let ((len-obj1 (##vector-length obj1)))
 270                                   (and (##fixnum.= len-obj1
 271                                                    (##vector-length obj2))
 272                                        (let loop ((i (##fixnum.- len-obj1 1)))
 273                                          (or (##fixnum.< i 0)
 274                                              (and (equal (##vector-ref obj1 i)
 275                                                          (##vector-ref obj2 i))
 276                                                   (loop (##fixnum.- i 1))))))))
 277                                ((macro-table? obj1)
 278                                 (and (macro-table? obj2)
 279                                      (##table-equal? obj1 obj2)))
 280                                ((##structure? obj1)
 281                                 (and (##structure? obj2)
 282                                      (let* ((type-obj1
 283                                              (##structure-type obj1))
 284                                             (type-obj2
 285                                              (##structure-type obj2))
 286                                             (type-id-obj1
 287                                              (##type-id type-obj1))
 288                                             (type-id-obj2
 289                                              (##type-id type-obj2)))
 290                                        (and (##eq? type-id-obj1
 291                                                    type-id-obj2)
 292                                             (let ((len-obj1
 293                                                    (##vector-length obj1)))
 294                                               (and (##fixnum.=
 295                                                     len-obj1
 296                                                     (##vector-length obj2))
 297                                                    (##fixnum.= ;; not opaque?
 298                                                     (##fixnum.bitwise-and
 299                                                      (##type-flags type-obj1)
 300                                                      1)
 301                                                     0)
 302                                                    (structure-equal
 303                                                     obj1
 304                                                     obj2
 305                                                     type-obj1
 306                                                     len-obj1)))))))
 307                                ((##box? obj1)
 308                                 (and (##box? obj2)
 309                                      (equal (##unbox obj1)
 310                                             (##unbox obj2))))
 311                                (else
 312                                 (eqv obj1 obj2)))))))
 313           (else
 314            (eqv obj1 obj2)))))
 315
 316   (equal obj1 obj2))
 317
 318 (define-prim (equal? obj1 obj2)
 319   (##equal? obj1 obj2))
 320
 321 ;;;----------------------------------------------------------------------------
 322
 323 ;;; Object hashing.
 324
 325 (define-prim (##symbol-hash sym)
 326   (macro-symbol-hash sym))
 327
 328 (define-prim (symbol-hash sym)
 329   (macro-force-vars (sym)
 330     (macro-check-symbol sym 1 (symbol-hash sym)
 331       (##symbol-hash sym))))
 332
 333 (define-prim (##keyword-hash key)
 334   (macro-keyword-hash key))
 335
 336 (define-prim (keyword-hash key)
 337   (macro-force-vars (key)
 338     (macro-check-keyword key 1 (keyword-hash key)
 339       (##keyword-hash key))))
 340
 341 (define-prim (##eq?-hash obj)
 342
 343   ;; for all obj2 we must have that (##eq? obj obj2) implies that
 344   ;; (= (##eq?-hash obj) (##eq?-hash obj2))
 345
 346   (cond ((##not (##mem-allocated? obj))
 347          (##fixnum.bitwise-and
 348           (##type-cast obj (macro-type-fixnum))
 349           (macro-max-fixnum32)))
 350         ((##symbol? obj)
 351          (##symbol-hash obj))
 352         ((##keyword? obj)
 353          (##keyword-hash obj))
 354         (else
 355          (##fixnum.bitwise-and
 356           (let ((sn (##object->serial-number obj)))
 357             (if (##fixnum? sn)
 358               sn
 359               (##fixnum.arithmetic-shift-left
 360                (##bignum.mdigit-ref sn 0)
 361                10)))
 362           (macro-max-fixnum32)))))
 363
 364 (define-prim (eq?-hash obj)
 365   (macro-force-vars (obj)
 366     (##eq?-hash obj)))
 367
 368 (define-prim (##eqv?-hash obj)
 369
 370   ;; for all obj2 we must have that (##eqv? obj obj2) implies that
 371   ;; (= (##eqv?-hash obj) (##eqv?-hash obj2))
 372
 373   (define (combine a b)
 374     (##fixnum.bitwise-and
 375      (##fixnum.* (##fixnum.+ a (##fixnum.arithmetic-shift-left b 1))
 376                  331804471)
 377      (macro-max-fixnum32)))
 378
 379   (define (hash obj)
 380     (macro-number-dispatch obj
 381       (##eq?-hash obj) ;; obj = not a number
 382       (##fixnum.bitwise-and obj (macro-max-fixnum32)) ;; obj = fixnum
 383       (##modulo obj 331804481) ;; obj = bignum
 384       (combine (hash (macro-ratnum-numerator obj)) ;; obj = ratnum
 385                (hash (macro-ratnum-denominator obj)))
 386       (combine (##u16vector-ref obj 0) ;; obj = flonum
 387                (combine (##u16vector-ref obj 1)
 388                         (combine (##u16vector-ref obj 2)
 389                                  (##u16vector-ref obj 3))))
 390       (combine (hash (macro-cpxnum-real obj)) ;; obj = cpxnum
 391                (hash (macro-cpxnum-imag obj)))))
 392
 393   (hash obj))
 394
 395 (define-prim (eqv?-hash obj)
 396   (macro-force-vars (obj)
 397     (##eqv?-hash obj)))
 398
 399 (define-prim (##equal?-hash obj)
 400
 401   ;; for all obj2 we must have that (##equal? obj obj2) implies that
 402   ;; (= (##equal?-hash obj) (##equal?-hash obj2))
 403
 404   (define (combine a b)
 405     (##fixnum.bitwise-and
 406      (##fixnum.* (##fixnum.+ a (##fixnum.arithmetic-shift-left b 1))
 407                  331804471)
 408      (macro-max-fixnum32)))
 409
 410   (define (bvector-hash obj)
 411
 412     (define (u16vect-hash i h)
 413       (if (##fixnum.< i 0)
 414         h
 415         (u16vect-hash (##fixnum.- i 1)
 416                       (combine (##u16vector-ref obj i) h))))
 417
 418     (let ((len (##u8vector-length obj)))
 419       (u16vect-hash (##fixnum.- (##fixnum.arithmetic-shift-right len 1) 1)
 420                     (##fixnum.bitwise-xor
 421                      (if (##fixnum.odd? len)
 422                        (##u8vector-ref obj (##fixnum.- len 1))
 423                        256)
 424                      (##fixnum.+ len
 425                                  (##fixnum.arithmetic-shift-left
 426                                   (##subtype obj)
 427                                   20))))))
 428
 429   (define (structure-hash obj type len h)
 430     (if (##not type) ;; have we reached root of inheritance chain?
 431       h
 432       (let ((fields (##type-fields type)))
 433         (let loop ((h 0)
 434                    (i*3 (##fixnum.- (##vector-length fields) 3))
 435                    (len len))
 436           (if (##fixnum.< i*3 0)
 437             (structure-hash obj (##type-super type) len h)
 438             (let ((field-attributes
 439                    (##vector-ref fields (##fixnum.+ i*3 1)))
 440                   (len-1
 441                    (##fixnum.- len 1)))
 442               (loop (if (##fixnum.=
 443                          (##fixnum.bitwise-and field-attributes 4)
 444                          0)
 445                       (combine (hash (##unchecked-structure-ref
 446                                       obj
 447                                       len-1
 448                                       type
 449                                       #f))
 450                                h)
 451                       h)
 452                     (##fixnum.- i*3 3)
 453                     len-1)))))))
 454
 455   (define (hash obj)
 456     (macro-force-vars (obj)
 457       (cond ((##pair? obj)
 458              (combine (hash (##car obj))
 459                       (hash (##cdr obj))))
 460             ((##subtyped? obj)
 461              (cond ((macro-subtype-bvector? (##subtype obj))
 462                     (cond ((##string? obj)
 463                            (##string=?-hash obj))
 464                           ((or (##flonum? obj)
 465                                (##bignum? obj))
 466                            (##eqv?-hash obj))
 467                           (else
 468                            (bvector-hash obj))))
 469                    ((##symbol? obj)
 470                     (##symbol-hash obj))
 471                    ((##keyword? obj)
 472                     (##keyword-hash obj))
 473                    ((##vector? obj)
 474                     (let loop ((i (##fixnum.- (##vector-length obj) 1))
 475                                (h 383479237))
 476                       (if (##fixnum.< i 0)
 477                         h
 478                         (loop (##fixnum.- i 1)
 479                               (combine (hash (##vector-ref obj i))
 480                                        h)))))
 481                    ((macro-table? obj)
 482                     (##table-equal?-hash obj))
 483                    ((##structure? obj)
 484                     (let* ((type
 485                             (##structure-type obj))
 486                            (type-id
 487                             (##type-id type)))
 488                       (if (##fixnum.= ;; not opaque?
 489                            (##fixnum.bitwise-and
 490                             (##type-flags type)
 491                             1)
 492                            0)
 493                         (structure-hash obj
 494                                         type
 495                                         (##vector-length obj)
 496                                         (hash type-id))
 497                         (##eq?-hash obj))))
 498                    ((##box? obj)
 499                     (combine (hash (##unbox obj))
 500                              153391703))
 501                    (else
 502                     (##eqv?-hash obj))))
 503             (else
 504              (##eqv?-hash obj)))))
 505
 506   (hash obj))
 507
 508 (define-prim (equal?-hash obj)
 509   (macro-force-vars (obj)
 510     (##equal?-hash obj)))
 511
 512 (define-prim (##string=?-hash str)
 513
 514   ;; for all str2 we must have that (##string=? str str2) implies that
 515   ;; (= (##string=?-hash str) (##string=?-hash str2))
 516
 517   (let ((len (##string-length str)))
 518     (let loop ((h 0) (i 0))
 519       (if (##fixnum.< i len)
 520         (loop (##fixnum.bitwise-and
 521                (##fixnum.* (##fixnum.+
 522                             (##fixnum.arithmetic-shift-right h 8)
 523                             (##fixnum.<-char (##string-ref str i)))
 524                            331804471)
 525                (macro-max-fixnum32))
 526               (##fixnum.+ i 1))
 527         h))))
 528
 529 (define-prim (string=?-hash str)
 530   (macro-force-vars (str)
 531     (macro-check-string str 1 (string=?-hash str)
 532       (##string=?-hash str))))
 533
 534 (define-prim (##string-ci=?-hash str)
 535
 536   ;; for all str2 we must have that (##string-ci=? str str2) implies that
 537   ;; (= (##string-ci=?-hash str) (##string-ci=?-hash str2))
 538
 539   (let ((len (##string-length str)))
 540     (let loop ((h 0) (i 0))
 541       (if (##fixnum.< i len)
 542         (loop (##fixnum.bitwise-and
 543                (##fixnum.* (##fixnum.+
 544                             (##fixnum.arithmetic-shift-right h 8)
 545                             (##fixnum.<-char
 546                              (##char-downcase (##string-ref str i))))
 547                            331804471)
 548                (macro-max-fixnum32))
 549               (##fixnum.+ i 1))
 550         h))))
 551
 552 (define-prim (string-ci=?-hash str)
 553   (macro-force-vars (str)
 554     (macro-check-string str 1 (string-ci=?-hash str)
 555       (##string-ci=?-hash str))))
 556
 557 (define-prim (##generic-hash obj)
 558   0)
 559
 560 ;;;----------------------------------------------------------------------------
 561
 562 ;;; Tables.
 563
 564 (implement-library-type-invalid-hash-number-exception)
 565
 566 (define-prim (##raise-invalid-hash-number-exception proc . args)
 567   (##extract-procedure-and-arguments
 568    proc
 569    args
 570    #f
 571    #f
 572    #f
 573    (lambda (procedure arguments dummy1 dummy2 dummy3)
 574      (macro-raise
 575       (macro-make-invalid-hash-number-exception
 576        procedure
 577        arguments)))))
 578
 579 (implement-library-type-unbound-table-key-exception)
 580
 581 (define-prim (##raise-unbound-table-key-exception proc . args)
 582   (##extract-procedure-and-arguments
 583    proc
 584    args
 585    #f
 586    #f
 587    #f
 588    (lambda (procedure arguments dummy1 dummy2 dummy3)
 589      (macro-raise
 590       (macro-make-unbound-table-key-exception
 591        procedure
 592        arguments)))))
 593
 594 (define-prim (##gc-hash-table? obj)
 595   (and (##subtyped? obj)
 596        (##eq? (##subtype obj) (macro-subtype-weak))
 597        (##not (##fixnum.= (##vector-length obj) (macro-will-size)))))
 598
 599 (define-prim (##gc-hash-table-ref gcht key))
 600 (define-prim (##gc-hash-table-set! gcht key val))
 601 (define-prim (##gc-hash-table-rehash! gcht-src gcht-dst))
 602
 603 (define-prim (##smallest-prime-no-less-than n) ;; n >= 3
 604   (let loop1 ((n (if (##fixnum.even? n) (##fixnum.+ n 1) n)))
 605     (let loop2 ((d 3))
 606       (cond ((##fixnum.< n (##fixnum.* d d))
 607              n)
 608             ((##fixnum.zero? (##fixnum.modulo n d))
 609              (loop1 (##fixnum.+ n 2)))
 610             (else
 611              (loop2 (##fixnum.+ d 2)))))))
 612
 613 (define-prim (##gc-hash-table-resize! table gcht loads)
 614   (let* ((count
 615           (macro-gc-hash-table-count gcht))
 616          (n
 617           (##fixnum.+ 1
 618                       (##flonum.->fixnum
 619                        (##flonum./ (##flonum.<-fixnum count)
 620                                    (##f64vector-ref loads 1))))))
 621     (##gc-hash-table-allocate
 622      n
 623      (##fixnum.bitwise-and
 624       (macro-gc-hash-table-flags gcht)
 625       (##fixnum.bitwise-not
 626        (##fixnum.bitwise-ior
 627         (macro-gc-hash-table-flag-key-moved)
 628         (##fixnum.bitwise-ior
 629          (macro-gc-hash-table-flag-entry-deleted)
 630          (macro-gc-hash-table-flag-need-rehash)))))
 631      loads)))
 632
 633 (define-prim (##gc-hash-table-allocate n flags loads)
 634   (if (##fixnum.< (macro-gc-hash-table-minimal-nb-entries) n)
 635     (let* ((nb-entries
 636             (##smallest-prime-no-less-than (##fixnum.+ n 1)))
 637            (min-count
 638             (##flonum.->fixnum
 639              (##flonum.* (##flonum.<-fixnum n)
 640                          (##f64vector-ref loads 0))))
 641            (free
 642             (##fixnum.+ 1
 643                         (##flonum.->fixnum
 644                          (##flonum.* (##flonum.<-fixnum
 645                                       (##fixnum.- nb-entries 1))
 646                                      (##f64vector-ref loads 2))))))
 647       (macro-make-gc-hash-table
 648        flags
 649        0
 650        min-count
 651        free
 652        nb-entries))
 653     (macro-make-minimal-gc-hash-table
 654      flags
 655      0)))
 656
 657 (define-prim (##gc-hash-table-for-each proc ht)
 658   (##declare (not interrupts-enabled))
 659   (if (##gc-hash-table? ht)
 660     (let loop ((i (macro-gc-hash-table-key0)))
 661       (if (##fixnum.< i (##vector-length ht))
 662         (let ((key (##vector-ref ht i)))
 663           (if (and (##not (##eq? key (macro-unused-obj)))
 664                    (##not (##eq? key (macro-deleted-obj))))
 665             (proc key (##vector-ref ht (##fixnum.+ i 1))))
 666           (let ()
 667             (##declare (interrupts-enabled))
 668             (loop (##fixnum.+ i 2))))
 669         (##void)))
 670     (##void)))
 671
 672 (define-prim (##gc-hash-table-search proc ht)
 673   (##declare (not interrupts-enabled))
 674   (if (##gc-hash-table? ht)
 675     (let loop ((i (macro-gc-hash-table-key0)))
 676       (if (##fixnum.< i (##vector-length ht))
 677         (let ((key (##vector-ref ht i)))
 678           (or (and (##not (##eq? key (macro-unused-obj)))
 679                    (##not (##eq? key (macro-deleted-obj)))
 680                    (proc key (##vector-ref ht (##fixnum.+ i 1))))
 681               (let ()
 682                 (##declare (interrupts-enabled))
 683                 (loop (##fixnum.+ i 2)))))
 684         #f))
 685     #f))
 686
 687 (define-prim (##gc-hash-table-foldl f base proc ht)
 688   (##declare (not interrupts-enabled))
 689   (if (##gc-hash-table? ht)
 690     (let loop ((i (macro-gc-hash-table-key0)) (base base))
 691       (if (##fixnum.< i (##vector-length ht))
 692         (let ((key (##vector-ref ht i)))
 693           (if (and (##not (##eq? key (macro-unused-obj)))
 694                    (##not (##eq? key (macro-deleted-obj))))
 695             (let ((new-base
 696                    (f base (proc key (##vector-ref ht (##fixnum.+ i 1))))))
 697               (##declare (interrupts-enabled))
 698               (loop (##fixnum.+ i 2) new-base))
 699             (let ()
 700               (##declare (interrupts-enabled))
 701               (loop (##fixnum.+ i 2) base))))
 702         base))
 703     base))
 704
 705 (define-prim (##mem-allocated? obj)
 706   (let ((type (##type obj)))
 707     (or (##fixnum.= type (macro-type-subtyped))
 708         (##fixnum.= type (macro-type-pair)))))
 709
 710 (implement-type-table)
 711
 712 (define-fail-check-type table (macro-type-table))
 713
 714 (define-check-type table (macro-type-table)
 715   macro-table?)
 716
 717 (define-prim (table? obj)
 718   (macro-table? obj))
 719
 720 (define-prim (##make-table
 721               #!optional
 722               (size (macro-absent-obj))
 723               (init (macro-absent-obj))
 724               (weak-keys (macro-absent-obj))
 725               (weak-values (macro-absent-obj))
 726               (test (macro-absent-obj))
 727               (hash (macro-absent-obj))
 728               (min-load (macro-absent-obj))
 729               (max-load (macro-absent-obj)))
 730
 731   (define-macro (macro-default-weak-keys)   0)
 732   (define-macro (macro-default-weak-values) 0)
 733
 734   (define-macro (macro-default-min-load) 0.45)
 735   (define-macro (macro-default-max-load) 0.90)
 736
 737   (define-macro (macro-load-range-lo)    0.05)
 738   (define-macro (macro-load-range-hi)    0.95)
 739   (define-macro (macro-load-min-max-gap) 0.20)
 740
 741   (define (check-size arg-num)
 742     (if (##eq? size (macro-absent-obj))
 743       (check-weak-keys 0
 744                        arg-num)
 745       (let ((arg-num (##fixnum.+ arg-num 2)))
 746         (macro-check-index
 747          size
 748          arg-num
 749          (make-table size: size
 750                      init: init
 751                      weak-keys: weak-keys
 752                      weak-values: weak-values
 753                      test: test
 754                      hash: hash
 755                      min-load: min-load
 756                      max-load: max-load)
 757          (check-weak-keys (##fixnum.min size 2000000) ;; avoid fixnum overflows
 758                           arg-num)))))
 759
 760   (define (check-weak-keys siz arg-num)
 761     (if (##eq? weak-keys (macro-absent-obj))
 762       (check-weak-values siz
 763                          (macro-default-weak-keys)
 764                          arg-num)
 765       (let ((arg-num (##fixnum.+ arg-num 2)))
 766         (check-weak-values siz
 767                            (if weak-keys
 768                              (macro-gc-hash-table-flag-weak-keys)
 769                              0)
 770                            arg-num))))
 771
 772   (define (check-weak-values siz flags arg-num)
 773     (if (##eq? weak-values (macro-absent-obj))
 774       (check-test siz
 775                   (##fixnum.+ flags
 776                               (macro-default-weak-values))
 777                   arg-num)
 778       (let ((arg-num (##fixnum.+ arg-num 2)))
 779         (check-test siz
 780                     (##fixnum.+ flags
 781                                 (if weak-values
 782                                   (macro-gc-hash-table-flag-weak-vals)
 783                                   0))
 784                     arg-num))))
 785
 786   (define (check-test siz flags arg-num)
 787     (if (##eq? test (macro-absent-obj))
 788       (check-hash siz
 789                   flags
 790                   ##equal?
 791                   arg-num)
 792       (let ((arg-num (##fixnum.+ arg-num 2)))
 793         (macro-check-procedure
 794          test
 795          arg-num
 796          (make-table size: size
 797                      init: init
 798                      weak-keys: weak-keys
 799                      weak-values: weak-values
 800                      test: test
 801                      hash: hash
 802                      min-load: min-load
 803                      max-load: max-load)
 804          (check-hash siz
 805                      flags
 806                      test
 807                      arg-num)))))
 808
 809   (define (check-hash siz flags test-fn arg-num)
 810     (if (##eq? hash (macro-absent-obj))
 811       (cond ((or (##eq? test-fn ##eq?) (##eq? test-fn eq?))
 812              (check-loads siz
 813                           flags
 814                           #f
 815                           #f
 816                           arg-num))
 817             ((or (##eq? test-fn ##eqv?) (##eq? test-fn eqv?))
 818              (check-loads siz
 819                           flags
 820                           test-fn
 821                           ##eqv?-hash
 822                           arg-num))
 823             ((or (##eq? test-fn ##equal?) (##eq? test-fn equal?))
 824              (check-loads siz
 825                           flags
 826                           test-fn
 827                           ##equal?-hash
 828                           arg-num))
 829             ((or (##eq? test-fn ##string=?) (##eq? test-fn string=?))
 830              (check-loads siz
 831                           flags
 832                           test-fn
 833                           string=?-hash
 834                           arg-num))
 835             ((or (##eq? test-fn ##string-ci=?) (##eq? test-fn string-ci=?))
 836              (check-loads siz
 837                           flags
 838                           test-fn
 839                           string-ci=?-hash
 840                           arg-num))
 841             (else
 842              (check-loads siz
 843                           flags
 844                           test-fn
 845                           ##generic-hash
 846                           arg-num)))
 847       (let ((arg-num (##fixnum.+ arg-num 2)))
 848         (macro-check-procedure
 849          hash
 850          arg-num
 851          (make-table size: size
 852                      init: init
 853                      weak-keys: weak-keys
 854                      weak-values: weak-values
 855                      test: test
 856                      hash: hash
 857                      min-load: min-load
 858                      max-load: max-load)
 859          (check-loads siz
 860                       flags
 861                       test-fn
 862                       hash
 863                       arg-num)))))
 864
 865   (define (check-loads siz flags test-fn hash-fn arg-num)
 866     (if (and (##eq? min-load (macro-absent-obj))
 867              (##eq? max-load (macro-absent-obj)))
 868       (checks-done siz
 869                    flags
 870                    test-fn
 871                    hash-fn
 872                    '#f64(.45 .6363961030678927 .9)
 873                    arg-num)
 874       (check-min-load siz
 875                       flags
 876                       test-fn
 877                       hash-fn
 878                       (##f64vector (macro-default-min-load)
 879                                    (macro-inexact-+0)
 880                                    (macro-default-max-load))
 881                       arg-num)))
 882
 883   (define (check-min-load siz flags test-fn hash-fn loads arg-num)
 884     (if (##eq? min-load (macro-absent-obj))
 885       (check-max-load siz
 886                       flags
 887                       test-fn
 888                       hash-fn
 889                       loads
 890                       arg-num)
 891       (let ((arg-num (##fixnum.+ arg-num 2)))
 892         (if (##not (##real? min-load))
 893           (##fail-check-real
 894            arg-num
 895            (##list size: size
 896                    init: init
 897                    weak-keys: weak-keys
 898                    weak-values: weak-values
 899                    test: test
 900                    hash: hash
 901                    min-load: min-load
 902                    max-load: max-load)
 903            make-table)
 904           (begin
 905             (##f64vector-set! loads 0 (macro-real->inexact min-load))
 906             (check-max-load siz
 907                             flags
 908                             test-fn
 909                             hash-fn
 910                             loads
 911                             arg-num))))))
 912
 913   (define (check-max-load siz flags test-fn hash-fn loads arg-num)
 914     (if (##eq? max-load (macro-absent-obj))
 915       (check-loads-done siz
 916                         flags
 917                         test-fn
 918                         hash-fn
 919                         loads
 920                         arg-num)
 921       (let ((arg-num (##fixnum.+ arg-num 2)))
 922         (if (##not (##real? max-load))
 923           (##fail-check-real
 924            arg-num
 925            (##list size: size
 926                    init: init
 927                    weak-keys: weak-keys
 928                    weak-values: weak-values
 929                    test: test
 930                    hash: hash
 931                    min-load: min-load
 932                    max-load: max-load)
 933            make-table)
 934           (begin
 935             (##f64vector-set! loads 2 (macro-real->inexact max-load))
 936             (check-loads-done siz
 937                               flags
 938                               test-fn
 939                               hash-fn
 940                               loads
 941                               arg-num))))))
 942
 943   (define (check-loads-done siz flags test-fn hash-fn loads arg-num)
 944     (##f64vector-set!
 945      loads
 946      0
 947      (##flonum.min (##flonum.- (macro-load-range-hi)
 948                                (macro-load-min-max-gap))
 949                    (##flonum.max (macro-load-range-lo)
 950                                  (##f64vector-ref loads 0))))
 951     (##f64vector-set!
 952      loads
 953      2
 954      (##flonum.min (macro-load-range-hi)
 955                    (##flonum.max (##flonum.+ (##f64vector-ref loads 0)
 956                                              (macro-load-min-max-gap))
 957                                  (##f64vector-ref loads 2))))
 958     (##f64vector-set!
 959      loads
 960      1
 961      (##flonum.sqrt (##flonum.* (##f64vector-ref loads 0)
 962                                 (##f64vector-ref loads 2))))
 963     (checks-done siz
 964                  flags
 965                  test-fn
 966                  hash-fn
 967                  loads
 968                  arg-num))
 969
 970   (define (checks-done siz flags test-fn hash-fn loads arg-num)
 971     (macro-make-table (if (and #f ;; don't make a special case for eq? tables
 972                                (##not test-fn)
 973                                (##eq? weak-keys (macro-absent-obj)))
 974                         (##fixnum.bitwise-ior
 975                          flags
 976                          (macro-gc-hash-table-flag-weak-keys))
 977                         flags)
 978                       test-fn
 979                       hash-fn
 980                       loads
 981                       siz
 982                       init))
 983
 984   (check-size 0))
 985
 986 (define-prim (make-table
 987               #!key
 988               (size (macro-absent-obj))
 989               (init (macro-absent-obj))
 990               (weak-keys (macro-absent-obj))
 991               (weak-values (macro-absent-obj))
 992               (test (macro-absent-obj))
 993               (hash (macro-absent-obj))
 994               (min-load (macro-absent-obj))
 995               (max-load (macro-absent-obj)))
 996   (##make-table
 997    size
 998    init
 999    weak-keys
1000    weak-values
1001    test
1002    hash
1003    min-load
1004    max-load))
1005
1006 (define (##table-get-eq-gcht table key)
1007   (##declare (not interrupts-enabled))
1008   (if (##mem-allocated? key)
1009     (##table-get-gcht table)
1010     (##table-get-gcht-not-mem-alloc table)))
1011
1012 (define (##table-get-gcht-not-mem-alloc table)
1013   (##declare (not interrupts-enabled))
1014   (or (macro-table-hash table)
1015       (let* ((n ;; initial size
1016               (let ((gcht (macro-table-gcht table)))
1017                 (if (##fixnum? gcht)
1018                   gcht
1019                   (macro-gc-hash-table-nb-entries gcht))))
1020              (gcht
1021               (##gc-hash-table-allocate
1022                n
1023                (macro-table-flags table)
1024                (macro-table-loads table))))
1025         (macro-table-hash-set! table gcht)
1026         gcht)))
1027
1028 (define (##table-get-gcht table)
1029   (##declare (not interrupts-enabled))
1030   (let ((gcht (macro-table-gcht table)))
1031     (if (##fixnum? gcht)
1032       (let* ((n ;; initial size
1033               gcht)
1034              (gcht
1035               (##gc-hash-table-allocate
1036                n
1037                (##fixnum.bitwise-ior
1038                 (macro-gc-hash-table-flag-mem-alloc-keys)
1039                 (macro-table-flags table))
1040                (macro-table-loads table))))
1041         (macro-table-gcht-set! table gcht)
1042         gcht)
1043       gcht)))
1044
1045 (define-prim (##table-length table)
1046
1047   (##declare (not interrupts-enabled))
1048
1049   (define (count ht)
1050     (if (##gc-hash-table? ht)
1051       (macro-gc-hash-table-count ht)
1052       0))
1053
1054   (if (macro-table-test table)
1055     (count (macro-table-gcht table))
1056     (##fixnum.+ (count (macro-table-hash table))
1057                 (count (macro-table-gcht table)))))
1058
1059 (define-prim (table-length table)
1060   (macro-force-vars (table)
1061     (macro-check-table table 1 (table-length table)
1062       (##table-length table))))
1063
1064 (define-prim (##table-access table key found not-found val)
1065   (##declare (not interrupts-enabled))
1066   (let ((f (macro-table-hash table)))
1067     (let loop1 ((h (f key)))
1068       (if (##not (##fixnum? h))
1069         (loop1 (##raise-invalid-hash-number-exception f key))
1070         (let* ((gcht
1071                 (let* ((gcht (##table-get-gcht table))
1072                        (flags (macro-gc-hash-table-flags gcht)))
1073                   (if (or (##not
1074                            (##fixnum.=
1075                             0
1076                             (##fixnum.bitwise-and
1077                              flags
1078                              (macro-gc-hash-table-flag-need-rehash))))
1079                           (and (##not
1080                                 (##fixnum.=
1081                                  0
1082                                  (##fixnum.bitwise-and
1083                                   flags
1084                                   (macro-gc-hash-table-flag-entry-deleted))))
1085                                (begin
1086                                  (macro-gc-hash-table-flags-set!
1087                                   gcht
1088                                   (##fixnum.bitwise-and
1089                                    (macro-gc-hash-table-flags gcht)
1090                                    (##fixnum.bitwise-not
1091                                     (macro-gc-hash-table-flag-entry-deleted))))
1092                                  (##fixnum.<
1093                                   (macro-gc-hash-table-count gcht)
1094                                   (macro-gc-hash-table-min-count gcht)))))
1095                       (begin
1096                         (##table-resize! table)
1097                         (macro-table-gcht table))
1098                       gcht)))
1099                (size
1100                 (macro-gc-hash-table-nb-entries gcht))
1101                (probe2
1102                 (##fixnum.arithmetic-shift-left
1103                  (##fixnum.modulo h size)
1104                  1))
1105                (step2
1106                 (##fixnum.arithmetic-shift-left
1107                  (##fixnum.+ (##fixnum.modulo h (##fixnum.- size 1)) 1)
1108                  1))
1109                (size2
1110                 (##fixnum.arithmetic-shift-left size 1))
1111                (test
1112                 (macro-table-test table)))
1113           (let loop2 ((probe2 probe2)
1114                       (deleted2 #f))
1115             (let ((k (macro-gc-hash-table-key-ref gcht probe2)))
1116               (cond ((##eq? k (macro-unused-obj))
1117                      (not-found table key gcht probe2 deleted2 val))
1118                     ((##eq? k (macro-deleted-obj))
1119                      (let ((next-probe2 (##fixnum.- probe2 step2)))
1120                        (loop2 (if (##fixnum.< next-probe2 0)
1121                                 (##fixnum.+ next-probe2 size2)
1122                                 next-probe2)
1123                               (or deleted2 probe2))))
1124                     ((test key k)
1125                      (found table key gcht probe2 val))
1126                     (else
1127                      (let ((next-probe2 (##fixnum.- probe2 step2)))
1128                        (loop2 (if (##fixnum.< next-probe2 0)
1129                                 (##fixnum.+ next-probe2 size2)
1130                                 next-probe2)
1131                               deleted2)))))))))))
1132
1133 (define-prim (##table-ref
1134               table
1135               key
1136               #!optional
1137               (default-value (macro-absent-obj)))
1138   (##declare (not interrupts-enabled))
1139   (let ((test (macro-table-test table)))
1140     (if test
1141
1142       (##table-access
1143        table
1144        key
1145        (lambda (table key gcht probe2 default-value)
1146          ;; key was found at position "probe2" so just return value field
1147          (macro-gc-hash-table-val-ref gcht probe2))
1148        (lambda (table key gcht probe2 deleted2 default-value)
1149          ;; key was not found (search ended at position "probe2" and the
1150          ;; first deleted entry encountered is at position "deleted2")
1151          (cond ((##not (##eq? default-value (macro-absent-obj)))
1152                 default-value)
1153                ((##not (##eq? (macro-table-init table) (macro-absent-obj)))
1154                 (macro-table-init table))
1155                (else
1156                 (##raise-unbound-table-key-exception
1157                  table-ref
1158                  table
1159                  key))))
1160        default-value)
1161
1162       (let* ((gcht (##table-get-eq-gcht table key))
1163              (val (##gc-hash-table-ref gcht key)))
1164         (if (##eq? val (macro-unused-obj))
1165           (cond ((##not (##eq? default-value (macro-absent-obj)))
1166                  default-value)
1167                 ((##not (##eq? (macro-table-init table) (macro-absent-obj)))
1168                  (macro-table-init table))
1169                 (else
1170                  (##raise-unbound-table-key-exception
1171                   table-ref
1172                   table
1173                   key)))
1174           val)))))
1175
1176 (define-prim (table-ref
1177               table
1178               key
1179               #!optional
1180               (default-value (macro-absent-obj)))
1181   (macro-force-vars (table key default-value)
1182     (macro-check-table table 1 (table-ref table key default-value)
1183       (##table-ref table key default-value))))
1184
1185 (define-prim (##table-resize! table)
1186   (##declare (not interrupts-enabled))
1187   (let ((gcht (macro-table-gcht table)))
1188     (let ((new-gcht
1189            (##gc-hash-table-resize! table gcht (macro-table-loads table))))
1190       (macro-table-gcht-set! table new-gcht)
1191       (let loop ((i (macro-gc-hash-table-key0)))
1192         (if (##fixnum.< i (##vector-length gcht))
1193           (let ((key (##vector-ref gcht i)))
1194             (if (and (##not (##eq? key (macro-unused-obj)))
1195                      (##not (##eq? key (macro-deleted-obj))))
1196               (let ((val (##vector-ref gcht (##fixnum.+ i 1))))
1197                 (##table-set! table key val)))
1198             (let ()
1199               (##declare (interrupts-enabled))
1200               (loop (##fixnum.+ i 2))))
1201           (##void))))))
1202
1203 (define-prim (##table-set!
1204               table
1205               key
1206               #!optional
1207               (val (macro-absent-obj)))
1208   (##declare (not interrupts-enabled))
1209   (let ((test (macro-table-test table)))
1210     (if test
1211
1212       (##table-access
1213        table
1214        key
1215        (lambda (table key gcht probe2 val)
1216          ;; key was found at position "probe2"
1217          (if (##eq? val (macro-absent-obj))
1218            (let ((count (##fixnum.- (macro-gc-hash-table-count gcht) 1)))
1219              (macro-gc-hash-table-count-set! gcht count)
1220              (macro-gc-hash-table-key-set! gcht probe2 (macro-deleted-obj))
1221              (macro-gc-hash-table-val-set! gcht probe2 (macro-unused-obj))
1222              (if (##fixnum.< count (macro-gc-hash-table-min-count gcht))
1223                (##table-resize! table)
1224                (##void)))
1225            (begin
1226              (macro-gc-hash-table-val-set! gcht probe2 val)
1227              (##void))))
1228        (lambda (table key gcht probe2 deleted2 val)
1229          ;; key was not found (search ended at position "probe2" and the
1230          ;; first deleted entry encountered is at position "deleted2")
1231          (if (##eq? val (macro-absent-obj))
1232            (##void)
1233            (if deleted2
1234              (let ((count (##fixnum.+ (macro-gc-hash-table-count gcht) 1)))
1235                (macro-gc-hash-table-count-set! gcht count)
1236                (macro-gc-hash-table-key-set! gcht deleted2 key)
1237                (macro-gc-hash-table-val-set! gcht deleted2 val)
1238                (##void))
1239              (let ((count (##fixnum.+ (macro-gc-hash-table-count gcht) 1))
1240                    (free (##fixnum.- (macro-gc-hash-table-free gcht) 1)))
1241                (macro-gc-hash-table-count-set! gcht count)
1242                (macro-gc-hash-table-free-set! gcht free)
1243                (macro-gc-hash-table-key-set! gcht probe2 key)
1244                (macro-gc-hash-table-val-set! gcht probe2 val)
1245                (if (##fixnum.< free 0)
1246                  (##table-resize! table)
1247                  (##void))))))
1248        val)
1249
1250       (let ((gcht (##table-get-eq-gcht table key)))
1251         (if (##gc-hash-table-set! gcht key val)
1252           (let ((new-gcht
1253                  (##gc-hash-table-rehash!
1254                   gcht
1255                   (##gc-hash-table-resize! table gcht (macro-table-loads table)))))
1256             (if (##mem-allocated? key)
1257               (macro-table-gcht-set! table new-gcht)
1258               (macro-table-hash-set! table new-gcht))))
1259         (##void)))))
1260
1261 (define-prim (table-set!
1262               table
1263               key
1264               #!optional
1265               (val (macro-absent-obj)))
1266   (macro-force-vars (table key val)
1267     (macro-check-table table 1 (table-set! table key val)
1268       (##table-set! table key val))))
1269
1270 (define-prim (##table-search proc table)
1271   (or (##gc-hash-table-search proc (macro-table-gcht table))
1272       (and (##not (macro-table-test table))
1273            (##gc-hash-table-search proc (macro-table-hash table)))))
1274
1275 (define-prim (table-search proc table)
1276   (macro-force-vars (proc table)
1277     (macro-check-procedure proc 1 (table-search proc table)
1278       (macro-check-table table 2 (table-search proc table)
1279         (##table-search proc table)))))
1280
1281 (define-prim (##table-for-each proc table)
1282   (##gc-hash-table-for-each proc (macro-table-gcht table))
1283   (if (##not (macro-table-test table))
1284     (##gc-hash-table-for-each proc (macro-table-hash table))))
1285
1286 (define-prim (table-for-each proc table)
1287   (macro-force-vars (proc table)
1288     (macro-check-procedure proc 1 (table-for-each proc table)
1289       (macro-check-table table 2 (table-for-each proc table)
1290         (##table-for-each proc table)))))
1291
1292 (define-prim (##table-foldl f base proc table)
1293   (let ((x (##gc-hash-table-foldl f base proc (macro-table-gcht table))))
1294     (if (macro-table-test table)
1295       x
1296       (##gc-hash-table-foldl f x proc (macro-table-hash table)))))
1297
1298 (define-prim (##table->list table)
1299   (let ((cons (lambda (x y) (##cons x y)))
1300         (rcons (lambda (x y) (##cons y x))))
1301     (##table-foldl rcons '() cons table)))
1302
1303 (define-prim (table->list table)
1304   (macro-force-vars (table)
1305     (macro-check-table table 1 (table->list table)
1306       (##table->list table))))
1307
1308 (define-prim (##list->table
1309               lst
1310               #!optional
1311               (size (macro-absent-obj))
1312               (init (macro-absent-obj))
1313               (weak-keys (macro-absent-obj))
1314               (weak-values (macro-absent-obj))
1315               (test (macro-absent-obj))
1316               (hash (macro-absent-obj))
1317               (min-load (macro-absent-obj))
1318               (max-load (macro-absent-obj)))
1319   (let ((table
1320          (##make-table
1321           size
1322           init
1323           weak-keys
1324           weak-values
1325           test
1326           hash
1327           min-load
1328           max-load)))
1329     (let loop ((x lst))
1330       (macro-force-vars (x)
1331         (if (##pair? x)
1332           (let ((couple (##car x)))
1333             (macro-force-vars (couple)
1334               (macro-check-pair-list
1335                couple
1336                1
1337                (list->table lst
1338                             size: size
1339                             init: init
1340                             weak-keys: weak-keys
1341                             weak-values: weak-values
1342                             test: test
1343                             hash: hash
1344                             min-load: min-load
1345                             max-load: max-load)
1346                (let ((key (##car couple)))
1347                  (if (##eq? table (##table-ref table key table))
1348                    (##table-set! table key (##cdr couple)))
1349                  (loop (##cdr x))))))
1350           (macro-check-list
1351            x
1352            1
1353            (list->table lst
1354                         size: size
1355                         init: init
1356                         weak-keys: weak-keys
1357                         weak-values: weak-values
1358                         test: test
1359                         hash: hash
1360                         min-load: min-load
1361                         max-load: max-load)
1362            table))))))
1363
1364 (define-prim (list->table
1365               lst
1366               #!key
1367               (size (macro-absent-obj))
1368               (init (macro-absent-obj))
1369               (weak-keys (macro-absent-obj))
1370               (weak-values (macro-absent-obj))
1371               (test (macro-absent-obj))
1372               (hash (macro-absent-obj))
1373               (min-load (macro-absent-obj))
1374               (max-load (macro-absent-obj)))
1375   (##list->table
1376    lst
1377    size
1378    init
1379    weak-keys
1380    weak-values
1381    test
1382    hash
1383    min-load
1384    max-load))
1385
1386 (define-prim (##table-copy table)
1387   (let* ((size
1388           (##table-length table))
1389          (init
1390           (macro-table-init table))
1391          (flags
1392           (macro-table-flags table))
1393          (weak-keys
1394           (##not (##fixnum.= 0 (##fixnum.bitwise-and
1395                                 flags
1396                                 (macro-gc-hash-table-flag-weak-keys)))))
1397          (weak-values
1398           (##not (##fixnum.= 0 (##fixnum.bitwise-and
1399                                 flags
1400                                 (macro-gc-hash-table-flag-weak-vals)))))
1401          (test-field
1402           (macro-table-test table))
1403          (test
1404           (or test-field
1405               ##eq?)) ;; test-field = #f means test function = ##eq?
1406          (hash
1407           (if test-field
1408             (macro-table-hash table)
1409             (macro-absent-obj))) ;; test-field = #f means special hash function
1410          (loads
1411           (macro-table-loads table))
1412          (min-load
1413           (##f64vector-ref loads 0))
1414          (max-load
1415           (##f64vector-ref loads 2)))
1416     (let ((t
1417            (##make-table
1418             size
1419             init
1420             weak-keys
1421             weak-values
1422             test
1423             hash
1424             min-load
1425             max-load)))
1426       (##table-for-each
1427        (lambda (k v)
1428          (##table-set! t k v))
1429        table)
1430       t)))
1431
1432 (define-prim (table-copy table)
1433   (macro-force-vars (table)
1434     (macro-check-table table 1 (table-copy table)
1435       (##table-copy table))))
1436
1437 (define-prim (##table-merge! table1 table2 table2-takes-precedence?)
1438   (if table2-takes-precedence?
1439       (##table-for-each
1440        (lambda (k v)
1441          (##table-set! table1 k v))
1442        table2)
1443       (##table-for-each
1444        (lambda (k v)
1445          (if (##eq? (##table-ref table1 k (macro-unused-obj))
1446                     (macro-unused-obj))
1447              (##table-set! table1 k v)))
1448        table2))
1449   table1)
1450
1451 (define-prim (table-merge! table1
1452                            table2
1453                            #!optional
1454                            (table2-takes-precedence? (macro-absent-obj)))
1455   (macro-force-vars (table1 table2 table2-takes-precedence?)
1456     (macro-check-table
1457       table1
1458       1
1459       (table-merge! table1 table2 table2-takes-precedence?)
1460       (macro-check-table
1461         table2
1462         2
1463         (table-merge! table1 table2 table2-takes-precedence?)
1464         (let ((t2-takes-precedence?
1465                (if (##eq? table2-takes-precedence? (macro-absent-obj))
1466                    #f
1467                    table2-takes-precedence?)))
1468           (##table-merge! table1 table2 t2-takes-precedence?))))))
1469
1470 (define-prim (##table-merge table1 table2 table2-takes-precedence?)
1471   (##table-merge! (##table-copy table1)
1472                   table2
1473                   table2-takes-precedence?))
1474
1475 (define-prim (table-merge table1
1476                           table2
1477                           #!optional
1478                           (table2-takes-precedence? (macro-absent-obj)))
1479   (macro-force-vars (table1 table2 table2-takes-precedence?)
1480     (macro-check-table
1481       table1
1482       1
1483       (table-merge table1 table2 table2-takes-precedence?)
1484       (macro-check-table
1485         table2
1486         2
1487         (table-merge table1 table2 table2-takes-precedence?)
1488         (let ((t2-takes-precedence?
1489                (if (##eq? table2-takes-precedence? (macro-absent-obj))
1490                    #f
1491                    table2-takes-precedence?)))
1492           (##table-merge table1 table2 t2-takes-precedence?))))))
1493
1494 (define-prim (##table-equal? table1 table2)
1495
1496   (##declare (not interrupts-enabled))
1497
1498   (and (##fixnum.= (macro-table-flags table1)
1499                    (macro-table-flags table2))
1500        (##eq? (macro-table-test table1)
1501               (macro-table-test table2))
1502        (if (macro-table-test table1)
1503          (##eq? (macro-table-hash table1)
1504                 (macro-table-hash table2))
1505          #t)
1506        (let* ((len1 (##table-length table1))
1507               (len2 (##table-length table2)))
1508          (and (##fixnum.= len1 len2)
1509               (##not (##table-search
1510                       (lambda (key1 val1)
1511                         (let ((val2
1512                                (##table-ref table2 key1 (macro-unused-obj))))
1513                           (##not (##equal? val1 val2))))
1514                       table1))))))
1515
1516 (define-prim (##table-equal?-hash table)
1517
1518   (define (combine a b)
1519     (##fixnum.bitwise-and
1520      (##fixnum.* (##fixnum.+ a (##fixnum.arithmetic-shift-left b 1))
1521                  331804471)
1522      (macro-max-fixnum32)))
1523
1524   (##table-foldl
1525    (lambda (a b) ;; must be associative and commutative
1526      (##fixnum.bitwise-xor a b))
1527    (combine
1528     (macro-table-flags table)
1529     (combine
1530      (##eq?-hash (macro-table-test table))
1531      (combine
1532       (if (macro-table-test table)
1533         (##eq?-hash (macro-table-hash table))
1534         0)
1535       (##table-length table))))
1536    (lambda (key val)
1537      (combine
1538       (if (macro-table-test table)
1539         (let ((f (macro-table-hash table)))
1540           (f key))
1541         0)
1542       (##equal?-hash val)))
1543    table))
1544
1545 ;;;----------------------------------------------------------------------------
1546
1547 ;;; Serial numbers.
1548
1549 (implement-library-type-unbound-serial-number-exception)
1550
1551 (define-prim (##raise-unbound-serial-number-exception proc . args)
1552   (##extract-procedure-and-arguments
1553    proc
1554    args
1555    #f
1556    #f
1557    #f
1558    (lambda (procedure arguments dummy1 dummy2 dummy3)
1559      (macro-raise
1560       (macro-make-unbound-serial-number-exception
1561        procedure
1562        arguments)))))
1563
1564 (define ##last-serial-number 0)
1565
1566 (define ##object-to-serial-number-table (##make-table 0 #f #t #f ##eq?))
1567 (define ##serial-number-to-object-table (##make-table 0 #f #f #t ##eq?))
1568
1569 (define-prim (##object->serial-number obj)
1570   (let loop ()
1571     (##declare (not interrupts-enabled))
1572     (or (##table-ref ##object-to-serial-number-table obj #f)
1573         (let* ((n ##last-serial-number)
1574                (n+1 (or (##fixnum.+? n 1) 0)))
1575           (set! ##last-serial-number n+1)
1576           (if (##table-ref ##serial-number-to-object-table n+1 #f)
1577             (loop)
1578             (begin
1579               (##table-set! ##object-to-serial-number-table obj n+1)
1580               (##table-set! ##serial-number-to-object-table n+1 obj)
1581               n+1))))))
1582
1583 (define-prim (object->serial-number obj)
1584   (##object->serial-number obj))
1585
1586 (define-prim (##serial-number->object
1587               sn
1588               #!optional
1589               (default-value (macro-absent-obj)))
1590   (let ((result
1591          (##table-ref ##serial-number-to-object-table sn (macro-unused-obj))))
1592     (cond ((##not (##eq? result (macro-unused-obj)))
1593            result)
1594           ((##eq? default-value (macro-absent-obj))
1595            (##raise-unbound-serial-number-exception serial-number->object sn))
1596           (else
1597            default-value))))
1598
1599 (define-prim (serial-number->object
1600               sn
1601               #!optional
1602               (default-value (macro-absent-obj)))
1603   (macro-force-vars (sn default-value)
1604     (macro-check-index sn 1 (serial-number->object sn default-value)
1605       (##serial-number->object sn default-value))))
1606
1607 ;;;============================================================================
1608
1609 ;;; Binary serialization/deserialization.
1610
1611 ;;;============================================================================
1612
1613 ;;; General object representation.
1614
1615 ;;; Type tags.
1616
1617 (##define-macro (macro-type-fixnum)   0)
1618 (##define-macro (macro-type-subtyped) 1)
1619 (##define-macro (macro-type-special)  2)
1620 (##define-macro (macro-type-pair)     3)
1621
1622 ;;; Subtype tags.
1623
1624 (##define-macro (macro-subtype-vector)       0)
1625 (##define-macro (macro-subtype-pair)         1)
1626 (##define-macro (macro-subtype-ratnum)       2)
1627 (##define-macro (macro-subtype-cpxnum)       3)
1628 (##define-macro (macro-subtype-structure)    4)
1629 (##define-macro (macro-subtype-boxvalues)    5)
1630 (##define-macro (macro-subtype-meroon)       6)
1631 (##define-macro (macro-subtype-jazz)         7)
1632
1633 (##define-macro (macro-subtype-symbol)       8)
1634 (##define-macro (macro-subtype-keyword)      9)
1635 (##define-macro (macro-subtype-frame)        10)
1636 (##define-macro (macro-subtype-continuation) 11)
1637 (##define-macro (macro-subtype-promise)      12)
1638 (##define-macro (macro-subtype-weak)         13)
1639 (##define-macro (macro-subtype-procedure)    14)
1640 (##define-macro (macro-subtype-return)       15)
1641
1642 (##define-macro (macro-subtype-foreign)      18)
1643 (##define-macro (macro-subtype-string)       19)
1644 (##define-macro (macro-subtype-s8vector)     20)
1645 (##define-macro (macro-subtype-u8vector)     21)
1646 (##define-macro (macro-subtype-s16vector)    22)
1647 (##define-macro (macro-subtype-u16vector)    23)
1648 (##define-macro (macro-subtype-s32vector)    24)
1649 (##define-macro (macro-subtype-u32vector)    25)
1650 (##define-macro (macro-subtype-f32vector)    26)
1651
1652 ;; for alignment these 5 must be last:
1653 (##define-macro (macro-subtype-s64vector)    27)
1654 (##define-macro (macro-subtype-u64vector)    28)
1655 (##define-macro (macro-subtype-f64vector)    29)
1656 (##define-macro (macro-subtype-flonum)       30)
1657 (##define-macro (macro-subtype-bignum)       31)
1658
1659 (##define-macro (macro-absent-obj)  `(##type-cast -6 2))
1660 (##define-macro (macro-unused-obj)  `(##type-cast -14 2))
1661 (##define-macro (macro-deleted-obj) `(##type-cast -15 2))
1662
1663 (##define-macro (macro-slot index struct . val)
1664   (if (null? val)
1665     `(##vector-ref ,struct ,index)
1666     `(##vector-set! ,struct ,index ,@val)))
1667
1668 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1669
1670 ;;; Symbol objects
1671
1672 ;; A symbol is represented by an object vector of length 4
1673 ;; slot 0 = symbol name (a string or a fixnum <n> for a symbol named "g<n>")
1674 ;; slot 1 = hash code (non-negative fixnum)
1675 ;; slot 2 = link to next symbol in symbol table (#f for uninterned)
1676 ;; slot 3 = pointer to corresponding global variable (0 if none exists)
1677
1678 (##define-macro (macro-make-uninterned-symbol name hash)
1679   `(##subtype-set!
1680     (##vector ,name ,hash #f 0)
1681     (macro-subtype-symbol)))
1682
1683 (##define-macro (macro-symbol-name s)        `(macro-slot 0 ,s))
1684 (##define-macro (macro-symbol-name-set! s x) `(macro-slot 0 ,s ,x))
1685 (##define-macro (macro-symbol-hash s)        `(macro-slot 1 ,s))
1686 (##define-macro (macro-symbol-hash-set! s x) `(macro-slot 1 ,s ,x))
1687 (##define-macro (macro-symbol-next s)        `(macro-slot 2 ,s))
1688 (##define-macro (macro-symbol-next-set! s x) `(macro-slot 2 ,s ,x))
1689
1690 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1691
1692 ;;; Keyword objects
1693
1694 ;; A keyword is represented by an object vector of length 3
1695 ;; slot 0 = keyword name (a string or a fixnum <n> for a keyword named "g<n>")
1696 ;; slot 1 = hash code (non-negative fixnum)
1697 ;; slot 2 = link to next keyword in keyword table (#f for uninterned)
1698
1699 (##define-macro (macro-make-uninterned-keyword name hash)
1700   `(##subtype-set!
1701     (##vector ,name ,hash #f)
1702     (macro-subtype-keyword)))
1703
1704 (##define-macro (macro-keyword-name k)        `(macro-slot 0 ,k))
1705 (##define-macro (macro-keyword-name-set! k x) `(macro-slot 0 ,k ,x))
1706 (##define-macro (macro-keyword-hash k)        `(macro-slot 1 ,k))
1707 (##define-macro (macro-keyword-hash-set! k x) `(macro-slot 1 ,k ,x))
1708 (##define-macro (macro-keyword-next k)        `(macro-slot 2 ,k))
1709 (##define-macro (macro-keyword-next-set! k x) `(macro-slot 2 ,k ,x))
1710
1711 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1712
1713 (##define-macro (macro-ratnum-make num den)
1714   `(##subtype-set!
1715     (##vector ,num ,den)
1716     (macro-subtype-ratnum)))
1717
1718 (##define-macro (macro-ratnum-numerator r)          `(macro-slot 0 ,r))
1719 (##define-macro (macro-ratnum-numerator-set! r x)   `(macro-slot 0 ,r ,x))
1720 (##define-macro (macro-ratnum-denominator r)        `(macro-slot 1 ,r))
1721 (##define-macro (macro-ratnum-denominator-set! r x) `(macro-slot 1 ,r ,x))
1722
1723 (##define-macro (macro-cpxnum-make r i)
1724   `(##subtype-set!
1725     (##vector ,r ,i)
1726     (macro-subtype-cpxnum)))
1727
1728 (##define-macro (macro-cpxnum-real c)        `(macro-slot 0 ,c))
1729 (##define-macro (macro-cpxnum-real-set! c x) `(macro-slot 0 ,c ,x))
1730 (##define-macro (macro-cpxnum-imag c)        `(macro-slot 1 ,c))
1731 (##define-macro (macro-cpxnum-imag-set! c x) `(macro-slot 1 ,c ,x))
1732
1733 ;;;----------------------------------------------------------------------------
1734
1735 (##define-macro (shared-tag-mask)    #x80)
1736 (##define-macro (shared-tag)         #x80)
1737
1738 (##define-macro (other-tag-mask)     #xf0)
1739 (##define-macro (symbol-tag)         #x00)
1740 (##define-macro (string-tag)         #x10)
1741 (##define-macro (vector-tag)         #x20)
1742 (##define-macro (structure-tag)      #x30)
1743 (##define-macro (subprocedure-tag)   #x40)
1744 (##define-macro (exact-int-tag)      #x50)
1745
1746 (##define-macro (character-tag)      #x60)
1747 (##define-macro (flonum-tag)         #x61)
1748 (##define-macro (ratnum-tag)         #x62)
1749 (##define-macro (cpxnum-tag)         #x63)
1750 (##define-macro (pair-tag)           #x64)
1751 (##define-macro (continuation-tag)   #x65)
1752 (##define-macro (boxvalues-tag)      #x66)
1753 (##define-macro (ui-symbol-tag)      #x67)
1754 (##define-macro (keyword-tag)        #x68)
1755 (##define-macro (ui-keyword-tag)     #x69)
1756 (##define-macro (closure-tag)        #x6a)
1757 (##define-macro (frame-tag)          #x6b)
1758 (##define-macro (gchashtable-tag)    #x6c)
1759 (##define-macro (meroon-tag)         #x6d)
1760 (##define-macro (jazz-tag)           #x6f) ;; note: tag is not consecutive
1761 (##define-macro (homvector-tag)      #x6e)
1762
1763 (##define-macro (false-tag)          #x70)
1764 (##define-macro (true-tag)           #x71)
1765 (##define-macro (nil-tag)            #x72)
1766 (##define-macro (eof-tag)            #x73)
1767 (##define-macro (void-tag)           #x74)
1768 (##define-macro (absent-tag)         #x75)
1769 (##define-macro (unbound-tag)        #x76)
1770 (##define-macro (unbound2-tag)       #x77)
1771 (##define-macro (optional-tag)       #x78)
1772 (##define-macro (key-tag)            #x79)
1773 (##define-macro (rest-tag)           #x7a)
1774 (##define-macro (unused-tag)         #x7b)
1775 (##define-macro (deleted-tag)        #x7c)
1776 (##define-macro (promise-tag)        #x7d)
1777 (##define-macro (unassigned1-tag)    #x7e)
1778 (##define-macro (unassigned2-tag)    #x7f)
1779
1780 (##define-macro (s8vector-tag)       #x00)
1781 (##define-macro (u8vector-tag)       #x01)
1782 (##define-macro (s16vector-tag)      #x02)
1783 (##define-macro (u16vector-tag)      #x03)
1784 (##define-macro (s32vector-tag)      #x04)
1785 (##define-macro (u32vector-tag)      #x05)
1786 (##define-macro (f32vector-tag)      #x06)
1787 (##define-macro (s64vector-tag)      #x07)
1788 (##define-macro (u64vector-tag)      #x08)
1789 (##define-macro (f64vector-tag)      #x09)
1790
1791 (##define-macro (structure? obj) `(##structure? ,obj))
1792 (##define-macro (gc-hash-table? obj) `(##gc-hash-table? ,obj))
1793 (##define-macro (fixnum? obj) `(##fixnum? ,obj))
1794
1795 (define-prim (##object->u8vector
1796               obj
1797               #!optional
1798               (transform (macro-absent-obj)))
1799
1800 (##define-macro (subtype-set! obj subtype)
1801   `(##subtype-set! ,obj ,subtype))
1802
1803 (##define-macro (subvector-move! src-vect src-start src-end dst-vect dst-start)
1804   `(##subvector-move! ,src-vect ,src-start ,src-end ,dst-vect ,dst-start))
1805
1806 (##define-macro (max-fixnum)
1807   `##max-fixnum)
1808
1809 (##define-macro (max-char)
1810   `##max-char)
1811
1812
1813 (##define-macro (continuation? obj)
1814   `(##continuation? ,obj))
1815
1816 (##define-macro (continuation-frame cont)
1817   `(##continuation-frame ,cont))
1818
1819 (##define-macro (continuation-denv cont)
1820   `(##continuation-denv ,cont))
1821
1822 (##define-macro (frame? obj)
1823   `(##frame? ,obj))
1824
1825 (##define-macro (frame-fs frame)
1826   `(##frame-fs ,frame))
1827
1828 (##define-macro (frame-ret frame)
1829   `(##frame-ret ,frame))
1830
1831 (##define-macro (frame-ref frame i)
1832   `(##frame-ref ,frame ,i))
1833
1834 (##define-macro (frame-slot-live? frame i)
1835   `(##frame-slot-live? ,frame ,i))
1836
1837 (##define-macro (subprocedure-parent-name subproc)
1838   `(##subprocedure-parent-name ,subproc))
1839
1840 (##define-macro (subprocedure-id subproc)
1841   `(##subprocedure-id ,subproc))
1842
1843 (##define-macro (subprocedure-nb-closed subproc)
1844   `(##subprocedure-nb-closed ,subproc))
1845
1846 (##define-macro (closure? obj)
1847   `(##closure? ,obj))
1848
1849 (##define-macro (closure-code closure)
1850   `(##closure-code ,closure))
1851
1852 (##define-macro (closure-ref closure i)
1853   `(##closure-ref ,closure ,i))
1854
1855 (##define-macro (extract-bit-field size position n)
1856   `(##extract-bit-field ,size ,position ,n))
1857
1858 (##define-macro (bignum? obj)
1859   `(##bignum? ,obj))
1860
1861 (##define-macro (subtyped? obj)
1862   `(##subtyped? ,obj))
1863
1864 (##define-macro (flonum? obj)
1865   `(##flonum? ,obj))
1866
1867 (##define-macro (ratnum? obj)
1868   `(##ratnum? ,obj))
1869
1870 (##define-macro (cpxnum? obj)
1871   `(##cpxnum? ,obj))
1872
1873 (##define-macro (boxvalues? obj)
1874   `(##fixnum.= (##subtype ,obj) (macro-subtype-boxvalues)))
1875
1876 (##define-macro (promise? obj)
1877   `(##promise? ,obj))
1878
1879
1880 (##define-macro (make-string . args)
1881   `(##make-string ,@args))
1882
1883 (##define-macro (string? . args)
1884   `(##string? ,@args))
1885
1886 (##define-macro (string-length str)
1887   `(##string-length ,str))
1888
1889 (##define-macro (string-ref str i)
1890   `(##string-ref ,str ,i))
1891
1892 (##define-macro (string-set! str i x)
1893   `(##string-set! ,str ,i ,x))
1894
1895
1896 (##define-macro (make-vector . args)
1897   `(##make-vector ,@args))
1898
1899 (##define-macro (vector? . args)
1900   `(##vector? ,@args))
1901
1902 (##define-macro (vector-length vect)
1903   `(##vector-length ,vect))
1904
1905 (##define-macro (vector-ref vect i)
1906   `(##vector-ref ,vect ,i))
1907
1908 (##define-macro (vector-set! vect i x)
1909   `(##vector-set! ,vect ,i ,x))
1910
1911
1912 (##define-macro (make-s8vector . args)
1913   `(##make-s8vector ,@args))
1914
1915 (##define-macro (s8vector? . args)
1916   `(##s8vector? ,@args))
1917
1918 (##define-macro (s8vector-length s8vect)
1919   `(##s8vector-length ,s8vect))
1920
1921 (##define-macro (s8vector-ref s8vect i)
1922   `(##s8vector-ref ,s8vect ,i))
1923
1924 (##define-macro (s8vector-set! s8vect i x)
1925   `(##s8vector-set! ,s8vect ,i ,x))
1926
1927 (##define-macro (s8vector-shrink! s8vect len)
1928   `(##s8vector-shrink! ,s8vect ,len))
1929
1930 (##define-macro (make-u8vector . args)
1931   `(##make-u8vector ,@args))
1932
1933 (##define-macro (u8vector? . args)
1934   `(##u8vector? ,@args))
1935
1936 (##define-macro (u8vector-length u8vect)
1937   `(##u8vector-length ,u8vect))
1938
1939 (##define-macro (u8vector-ref u8vect i)
1940   `(##u8vector-ref ,u8vect ,i))
1941
1942 (##define-macro (u8vector-set! u8vect i x)
1943   `(##u8vector-set! ,u8vect ,i ,x))
1944
1945 (##define-macro (u8vector-shrink! u8vect len)
1946   `(##u8vector-shrink! ,u8vect ,len))
1947
1948 (##define-macro (fifo->u8vector fifo start end)
1949   `(##fifo->u8vector ,fifo ,start ,end))
1950
1951
1952 (##define-macro (make-s16vector . args)
1953   `(##make-s16vector ,@args))
1954
1955 (##define-macro (s16vector? . args)
1956   `(##s16vector? ,@args))
1957
1958 (##define-macro (s16vector-length s16vect)
1959   `(##s16vector-length ,s16vect))
1960
1961 (##define-macro (s16vector-ref s16vect i)
1962   `(##s16vector-ref ,s16vect ,i))
1963
1964 (##define-macro (s16vector-set! s16vect i x)
1965   `(##s16vector-set! ,s16vect ,i ,x))
1966
1967 (##define-macro (s16vector-shrink! s16vect len)
1968   `(##s16vector-shrink! ,s16vect ,len))
1969
1970 (##define-macro (make-u16vector . args)
1971   `(##make-u16vector ,@args))
1972
1973 (##define-macro (u16vector? . args)
1974   `(##u16vector? ,@args))
1975
1976 (##define-macro (u16vector-length u16vect)
1977   `(##u16vector-length ,u16vect))
1978
1979 (##define-macro (u16vector-ref u16vect i)
1980   `(##u16vector-ref ,u16vect ,i))
1981
1982 (##define-macro (u16vector-set! u16vect i x)
1983   `(##u16vector-set! ,u16vect ,i ,x))
1984
1985 (##define-macro (u16vector-shrink! u16vect len)
1986   `(##u16vector-shrink! ,u16vect ,len))
1987
1988
1989 (##define-macro (make-s32vector . args)
1990   `(##make-s32vector ,@args))
1991
1992 (##define-macro (s32vector? . args)
1993   `(##s32vector? ,@args))
1994
1995 (##define-macro (s32vector-length s32vect)
1996   `(##s32vector-length ,s32vect))
1997
1998 (##define-macro (s32vector-ref s32vect i)
1999   `(##s32vector-ref ,s32vect ,i))
2000
2001 (##define-macro (s32vector-set! s32vect i x)
2002   `(##s32vector-set! ,s32vect ,i ,x))
2003
2004 (##define-macro (s32vector-shrink! s32vect len)
2005   `(##s32vector-shrink! ,s32vect ,len))
2006
2007 (##define-macro (make-u32vector . args)
2008   `(##make-u32vector ,@args))
2009
2010 (##define-macro (u32vector? . args)
2011   `(##u32vector? ,@args))
2012
2013 (##define-macro (u32vector-length u32vect)
2014   `(##u32vector-length ,u32vect))
2015
2016 (##define-macro (u32vector-ref u32vect i)
2017   `(##u32vector-ref ,u32vect ,i))
2018
2019 (##define-macro (u32vector-set! u32vect i x)
2020   `(##u32vector-set! ,u32vect ,i ,x))
2021
2022 (##define-macro (u32vector-shrink! u32vect len)
2023   `(##u32vector-shrink! ,u32vect ,len))
2024
2025
2026 (##define-macro (make-s64vector . args)
2027   `(##make-s64vector ,@args))
2028
2029 (##define-macro (s64vector? . args)
2030   `(##s64vector? ,@args))
2031
2032 (##define-macro (s64vector-length s64vect)
2033   `(##s64vector-length ,s64vect))
2034
2035 (##define-macro (s64vector-ref s64vect i)
2036   `(##s64vector-ref ,s64vect ,i))
2037
2038 (##define-macro (s64vector-set! s64vect i x)
2039   `(##s64vector-set! ,s64vect ,i ,x))
2040
2041 (##define-macro (s64vector-shrink! s64vect len)
2042   `(##s64vector-shrink! ,s64vect ,len))
2043
2044 (##define-macro (make-u64vector . args)
2045   `(##make-u64vector ,@args))
2046
2047 (##define-macro (u64vector? . args)
2048   `(##u64vector? ,@args))
2049
2050 (##define-macro (u64vector-length u64vect)
2051   `(##u64vector-length ,u64vect))
2052
2053 (##define-macro (u64vector-ref u64vect i)
2054   `(##u64vector-ref ,u64vect ,i))
2055
2056 (##define-macro (u64vector-set! u64vect i x)
2057   `(##u64vector-set! ,u64vect ,i ,x))
2058
2059 (##define-macro (u64vector-shrink! u64vect len)
2060   `(##u64vector-shrink! ,u64vect ,len))
2061
2062
2063 (##define-macro (make-f32vector . args)
2064   `(##make-f32vector ,@args))
2065
2066 (##define-macro (f32vector? . args)
2067   `(##f32vector? ,@args))
2068
2069 (##define-macro (f32vector-length f32vect)
2070   `(##f32vector-length ,f32vect))
2071
2072 (##define-macro (f32vector-ref f32vect i)
2073   `(##f32vector-ref ,f32vect ,i))
2074
2075 (##define-macro (f32vector-set! f32vect i x)
2076   `(##f32vector-set! ,f32vect ,i ,x))
2077
2078 (##define-macro (f32vector-shrink! f32vect len)
2079   `(##f32vector-shrink! ,f32vect ,len))
2080
2081 (##define-macro (make-f64vector . args)
2082   `(##make-f64vector ,@args))
2083
2084 (##define-macro (f64vector? . args)
2085   `(##f64vector? ,@args))
2086
2087 (##define-macro (f64vector-length f64vect)
2088   `(##f64vector-length ,f64vect))
2089
2090 (##define-macro (f64vector-ref f64vect i)
2091   `(##f64vector-ref ,f64vect ,i))
2092
2093 (##define-macro (f64vector-set! f64vect i x)
2094   `(##f64vector-set! ,f64vect ,i ,x))
2095
2096 (##define-macro (f64vector-shrink! f64vect len)
2097   `(##f64vector-shrink! ,f64vect ,len))
2098
2099
2100 (##define-macro (symbol? . args)
2101   `(##symbol? ,@args))
2102
2103 (##define-macro (symbol->string . args)
2104   `(##symbol->string ,@args))
2105
2106 (##define-macro (string->symbol . args)
2107   `(##string->symbol ,@args))
2108
2109 (##define-macro (keyword? . args)
2110   `(##keyword? ,@args))
2111
2112 (##define-macro (keyword->string . args)
2113   `(##keyword->string ,@args))
2114
2115 (##define-macro (string->keyword . args)
2116   `(##string->keyword ,@args))
2117
2118
2119 (##define-macro (+ . args)
2120   `(##fixnum.+ ,@args))
2121
2122 (##define-macro (- . args)
2123   `(##fixnum.- ,@args))
2124
2125 (##define-macro (* . args)
2126   `(##fixnum.* ,@args))
2127
2128 (##define-macro (< . args)
2129   `(##fixnum.< ,@args))
2130
2131 (##define-macro (> . args)
2132   `(##fixnum.> ,@args))
2133
2134 (##define-macro (= . args)
2135   `(##fixnum.= ,@args))
2136
2137 (##define-macro (>= . args)
2138   `(##fixnum.>= ,@args))
2139
2140 (##define-macro (<= . args)
2141   `(##fixnum.<= ,@args))
2142
2143 (##define-macro (bitwise-and . args)
2144   `(##fixnum.bitwise-and ,@args))
2145
2146 (##define-macro (bitwise-ior . args)
2147   `(##fixnum.bitwise-ior ,@args))
2148
2149 (##define-macro (arithmetic-shift-left . args)
2150   `(##fixnum.arithmetic-shift-left ,@args))
2151
2152 (##define-macro (arithmetic-shift-right . args)
2153   `(##fixnum.arithmetic-shift-right ,@args))
2154
2155 (##define-macro (generic.+ . args)
2156   `(##+ ,@args))
2157
2158 (##define-macro (generic.arithmetic-shift . args)
2159   `(##arithmetic-shift ,@args))
2160
2161 (##define-macro (generic.bit-set? . args)
2162   `(##bit-set? ,@args))
2163
2164 (##define-macro (generic.bitwise-ior . args)
2165   `(##bitwise-ior ,@args))
2166
2167 (##define-macro (generic.extract-bit-field . args)
2168   `(##extract-bit-field ,@args))
2169
2170 (##define-macro (generic.gcd . args)
2171   `(##gcd ,@args))
2172
2173 (##define-macro (generic.negative? . args)
2174   `(##negative? ,@args))
2175
2176 (##define-macro (integer-length . args)
2177   `(##integer-length ,@args))
2178
2179 (##define-macro (make-table . args)
2180   `(##make-table 0 #f #f #f ##eq?))
2181
2182 (##define-macro (table-ref . args)
2183   `(##table-ref ,@args))
2184
2185 (##define-macro (table-set! . args)
2186   `(##table-set! ,@args))
2187
2188 (##define-macro (uninterned-keyword? . args)
2189   `(##uninterned-keyword? ,@args))
2190
2191 (##define-macro (uninterned-symbol? . args)
2192   `(##uninterned-symbol? ,@args))
2193
2194
2195 (##define-macro (char->integer . args)
2196   `(##fixnum.<-char ,@args))
2197
2198 (##define-macro (integer->char . args)
2199   `(##fixnum.->char ,@args))
2200
2201
2202 (##define-macro (vector . args)
2203   `(##vector ,@args))
2204
2205
2206 (##define-macro (cons . args)
2207   `(##cons ,@args))
2208
2209 (##define-macro (pair? . args)
2210   `(##pair? ,@args))
2211
2212 (##define-macro (car . args)
2213   `(##car ,@args))
2214
2215 (##define-macro (cdr . args)
2216   `(##cdr ,@args))
2217
2218 (##define-macro (set-car! . args)
2219   `(##set-car! ,@args))
2220
2221 (##define-macro (set-cdr! . args)
2222   `(##set-cdr! ,@args))
2223
2224
2225 (##define-macro (procedure? . args)
2226   `(##procedure? ,@args))
2227
2228 (##define-macro (char? . args)
2229   `(##char? ,@args))
2230
2231 (##define-macro (real? . args)
2232   `(##real? ,@args))
2233
2234 (##define-macro (not . args)
2235   `(##not ,@args))
2236
2237 (##define-macro (eq? . args)
2238   `(##eq? ,@args))
2239
2240 ;;; Representation of fifos.
2241
2242 (##define-macro (macro-make-fifo)
2243   `(let ((fifo (##cons '() '())))
2244      (macro-fifo-tail-set! fifo fifo)
2245      fifo))
2246
2247 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
2248 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
2249 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
2250 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
2251 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
2252 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
2253
2254 (##define-macro (macro-fifo->list fifo)
2255   `(macro-fifo-next ,fifo))
2256
2257 (##define-macro (macro-fifo-remove-all! fifo)
2258   `(let ((fifo ,fifo))
2259
2260      (##declare (not interrupts-enabled))
2261
2262      (let ((head (macro-fifo-next fifo)))
2263        (macro-fifo-tail-set! fifo fifo)
2264        (macro-fifo-next-set! fifo '())
2265        head)))
2266
2267 (##define-macro (macro-fifo-remove-head! fifo)
2268   `(let ((fifo ,fifo))
2269
2270      (##declare (not interrupts-enabled))
2271
2272      (let ((head (macro-fifo-next fifo)))
2273        (if (##pair? head)
2274          (let ((next (macro-fifo-next head)))
2275            (if (##null? next)
2276              (macro-fifo-tail-set! fifo fifo))
2277            (macro-fifo-next-set! fifo next)
2278            (macro-fifo-next-set! head '())))
2279        head)))
2280
2281 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
2282   `(let ((fifo ,fifo) (elem ,elem))
2283      (let ((x (##cons elem '())))
2284
2285        (##declare (not interrupts-enabled))
2286
2287        (let ((tail (macro-fifo-tail fifo)))
2288          (macro-fifo-next-set! tail x)
2289          (macro-fifo-tail-set! fifo x)
2290          (##void)))))
2291
2292 (##define-macro (macro-fifo-insert-at-head! fifo elem)
2293   `(let ((fifo ,fifo) (elem ,elem))
2294      (let ((x (##cons elem '())))
2295
2296        (##declare (not interrupts-enabled))
2297
2298        ;; To obtain an atomic update of the fifo, we must force a
2299        ;; garbage-collection to occur right away if needed by the
2300        ;; ##cons, so that any finalization that might mutate this fifo
2301        ;; will be done before updating the fifo.
2302
2303        (##check-heap-limit)
2304
2305        (let ((head (macro-fifo-next fifo)))
2306          (if (##null? head)
2307            (macro-fifo-tail-set! fifo x))
2308          (macro-fifo-next-set! fifo x)
2309          (macro-fifo-next-set! x head)
2310          (##void)))))
2311
2312 (##define-macro (macro-fifo-advance-to-tail! fifo)
2313   `(let ((fifo ,fifo))
2314      ;; It is assumed that the fifo contains at least one element
2315      ;; (i.e. the fifo's tail does not change).
2316      (let ((new-head (macro-fifo-tail fifo)))
2317        (macro-fifo-next-set! fifo new-head)
2318        (macro-fifo-elem new-head))))
2319
2320 (##define-macro (macro-fifo-advance! fifo)
2321   `(let ((fifo ,fifo))
2322      ;; It is assumed that the fifo contains at least two elements
2323      ;; (i.e. the fifo's tail does not change).
2324      (let* ((head (macro-fifo-next fifo))
2325             (new-head (macro-fifo-next head)))
2326        (macro-fifo-next-set! fifo new-head)
2327        (macro-fifo-elem new-head))))
2328
2329
2330   (define (cannot-serialize obj)
2331     (error "can't serialize" obj))
2332
2333   (define chunk-len 256) ;; must be a power of 2
2334
2335   (define state
2336     (vector 0
2337             (macro-make-fifo)
2338             0
2339             (make-table test: ##eq?)
2340             (if (eq? transform (macro-absent-obj))
2341                 (lambda (x) x)
2342                 transform)))
2343
2344   (define (write-u8 x)
2345     (let ((ptr (vector-ref state 0)))
2346       (vector-set! state 0 (+ ptr 1))
2347       (let ((fifo (vector-ref state 1))
2348             (i (bitwise-and ptr (- chunk-len 1))))
2349         (u8vector-set!
2350          (if (= i 0)
2351              (let ((chunk (make-u8vector chunk-len)))
2352                (macro-fifo-insert-at-tail! fifo chunk)
2353                chunk)
2354              (macro-fifo-elem (macro-fifo-tail fifo)))
2355          i
2356          x))))
2357
2358   (define (get-output-u8vector)
2359     (let ((ptr (vector-ref state 0))
2360           (fifo (vector-ref state 1)))
2361       (if (and (< 0 ptr) (<= ptr chunk-len))
2362           (let ((u8vect (macro-fifo-elem (macro-fifo-tail fifo))))
2363             (u8vector-shrink! u8vect ptr)
2364             u8vect)
2365           (fifo->u8vector fifo 0 ptr))))
2366
2367   (define (share obj)
2368     (let ((n (table-ref (vector-ref state 3) obj #f)))
2369       (if n
2370           (begin
2371             (serialize-shared! n)
2372             #t)
2373           #f)))
2374
2375   (define (alloc! obj)
2376     (let ((n (vector-ref state 2)))
2377       (vector-set! state 2 (+ n 1))
2378       (table-set! (vector-ref state 3) obj n)))
2379
2380   (define (serialize-shared! n)
2381     (let ((lo (bitwise-and n #x7f))
2382           (hi (arithmetic-shift-right n 7)))
2383       (write-u8 (bitwise-ior (shared-tag) lo))
2384       (serialize-nonneg-fixnum! hi)))
2385
2386   (define (serialize-nonneg-fixnum! n)
2387     (let ((lo (bitwise-and n #x7f))
2388           (hi (arithmetic-shift-right n 7)))
2389       (if (= hi 0)
2390           (write-u8 lo)
2391           (begin
2392             (write-u8 (bitwise-ior #x80 lo))
2393             (serialize-nonneg-fixnum! hi)))))
2394
2395   (define (serialize-flonum-32! n)
2396     (serialize-exact-int-of-length!
2397      (##flonum.->ieee754-32 n)
2398      4))
2399
2400   (define (serialize-flonum-64! n)
2401     (serialize-exact-int-of-length!
2402      (##flonum.->ieee754-64 n)
2403      8))
2404
2405   (define (serialize-exact-int-of-length! n len)
2406     (if (fixnum? n)
2407         (let loop ((n n) (len len))
2408           (if (> len 0)
2409               (begin
2410                 (write-u8 (bitwise-and n #xff))
2411                 (loop (arithmetic-shift-right n 8) (- len 1)))))
2412         (let* ((len/2 (arithmetic-shift-right len 1))
2413                (len/2*8 (* len/2 8)))
2414           (serialize-exact-int-of-length!
2415            (generic.extract-bit-field len/2*8 0 n)
2416            len/2)
2417           (serialize-exact-int-of-length!
2418            (generic.arithmetic-shift n (- len/2*8))
2419            (- len len/2)))))
2420
2421   (define (exact-int-length n signed?)
2422     (arithmetic-shift-right
2423      (+ (integer-length n) (if signed? 8 7))
2424      3))
2425
2426   (define (serialize-exact-int! n)
2427     (or (share n)
2428         (let ((len (exact-int-length n #t)))
2429           (if (<= len 4)
2430               (write-u8 (bitwise-ior (exact-int-tag) (- #x0f len)))
2431               (begin
2432                 (write-u8 (bitwise-ior (exact-int-tag) #x0f))
2433                 (serialize-nonneg-fixnum! len)))
2434           (serialize-exact-int-of-length! n len)
2435           (alloc! n))))
2436
2437   (define (serialize-vector-like! vect tag)
2438     (let ((len (vector-length vect)))
2439       (if (< len #x0f)
2440           (begin
2441             (write-u8 (bitwise-ior tag len))
2442             (serialize-subvector! vect 0 len))
2443           (serialize-vector-like-long! vect (bitwise-ior tag #x0f)))))
2444
2445   (define (serialize-vector-like-long! vect tag)
2446     (let ((len (vector-length vect)))
2447       (write-u8 tag)
2448       (serialize-nonneg-fixnum! len)
2449       (serialize-subvector! vect 0 len)))
2450
2451   (define (serialize-subvector! vect start end)
2452     (let loop ((i start))
2453       (if (< i end)
2454           (begin
2455             (serialize! (vector-ref vect i))
2456             (loop (+ i 1))))))
2457
2458   (define (serialize-string-like! str tag mask)
2459     (let ((len (string-length str)))
2460       (if (< len mask)
2461           (begin
2462             (write-u8 (bitwise-ior tag len))
2463             (serialize-string! str))
2464           (begin
2465             (write-u8 (bitwise-ior tag mask))
2466             (serialize-nonneg-fixnum! len)
2467             (serialize-string! str)))))
2468
2469   (define (serialize-string! str)
2470     (serialize-elements!
2471      0
2472      (string-length str)
2473      (lambda (i)
2474        (serialize-nonneg-fixnum! (char->integer (string-ref str i))))))
2475
2476   (define (serialize-elements! start end serialize-element!)
2477     (let loop ((i start))
2478       (if (< i end)
2479           (begin
2480             (serialize-element! i)
2481             (loop (+ i 1))))))
2482
2483   (define (serialize-homintvector! vect vect-tag vect-length vect-ref elem-len)
2484     (or (share vect)
2485         (let ((len (vect-length vect)))
2486           (write-u8 (homvector-tag))
2487           (serialize-nonneg-fixnum!
2488            (bitwise-ior vect-tag (arithmetic-shift-left len 4)))
2489           (serialize-elements!
2490            0
2491            len
2492            (lambda (i)
2493              (serialize-exact-int-of-length!
2494               (vect-ref vect i)
2495               elem-len)))
2496           (alloc! vect))))
2497
2498   (define (serialize-homfloatvector! vect vect-tag vect-length vect-ref f32?)
2499     (or (share vect)
2500         (let ((len (vect-length vect)))
2501           (write-u8 (homvector-tag))
2502           (serialize-nonneg-fixnum!
2503            (bitwise-ior vect-tag (arithmetic-shift-left len 4)))
2504           (serialize-elements!
2505            0
2506            len
2507            (lambda (i)
2508              (let ((n (vect-ref vect i)))
2509                (if f32?
2510                    (serialize-flonum-32! n)
2511                    (serialize-flonum-64! n)))))
2512           (alloc! vect))))
2513
2514   (define (serialize-subprocedure! subproc tag mask)
2515     (or (share subproc)
2516         (let ((parent-name (subprocedure-parent-name subproc)))
2517           (if (not parent-name)
2518               (cannot-serialize subproc)
2519               (let ((subproc-id (subprocedure-id subproc)))
2520                 (if (< subproc-id mask)
2521                     (write-u8 (bitwise-ior tag subproc-id))
2522                     (begin
2523                       (write-u8 (bitwise-ior tag mask))
2524                       (serialize-nonneg-fixnum! subproc-id)))
2525                 (serialize! (##system-version))
2526                 (or (share parent-name)
2527                     (let ((str (symbol->string parent-name)))
2528                       (serialize-string-like! str 0 #x7f)
2529                       (alloc! parent-name)))
2530                 (alloc! subproc))))))
2531
2532   (define (serialize! obj)
2533     (let* ((transform (vector-ref state 4))
2534            (obj (transform obj)))
2535       (cond ((subtyped? obj)
2536
2537              (cond ((symbol? obj)
2538                     (or (share obj)
2539                         (begin
2540                           (if (uninterned-symbol? obj)
2541                               (begin
2542                                 (write-u8 (ui-symbol-tag))
2543                                 (serialize-string-like!
2544                                  (symbol->string obj)
2545                                  0
2546                                  #xff)
2547                                 (serialize-exact-int-of-length!
2548                                  (##symbol-hash obj)
2549                                  4))
2550                               (serialize-string-like!
2551                                (symbol->string obj)
2552                                (symbol-tag)
2553                                #x0f))
2554                           (write-u8 (if (##global-var? obj) 1 0))
2555                           (alloc! obj))))
2556
2557                    ((keyword? obj)
2558                     (or (share obj)
2559                         (begin
2560                           (if (uninterned-keyword? obj)
2561                               (begin
2562                                 (write-u8 (ui-keyword-tag))
2563                                 (serialize-string-like!
2564                                  (keyword->string obj)
2565                                  0
2566                                  #xff)
2567                                 (serialize-exact-int-of-length!
2568                                  (##keyword-hash obj)
2569                                  4))
2570                               (serialize-string-like!
2571                                (keyword->string obj)
2572                                (keyword-tag)
2573                                0))
2574                           (alloc! obj))))
2575
2576                    ((string? obj)
2577                     (or (share obj)
2578                         (begin
2579                           (serialize-string-like!
2580                            obj
2581                            (string-tag)
2582                            #x0f)
2583                           (alloc! obj))))
2584
2585                    ((vector? obj)
2586                     (or (share obj)
2587                         (begin
2588                           (alloc! obj)
2589                           (serialize-vector-like! obj (vector-tag)))))
2590
2591                    ((structure? obj)
2592                     (if (or (macro-thread? obj)
2593                             (macro-tgroup? obj)
2594                             (macro-mutex? obj)
2595                             (macro-condvar? obj))
2596                       (cannot-serialize obj)
2597                       (or (share obj)
2598                           (begin
2599                             (alloc! obj)
2600                             (serialize-vector-like! obj (structure-tag))))))
2601
2602                    ((procedure? obj)
2603                     (if (closure? obj)
2604
2605                         (or (share obj)
2606                             (begin
2607                               (write-u8 (closure-tag))
2608                               (let* ((subproc
2609                                       (closure-code obj))
2610                                      (nb-closed
2611                                       (subprocedure-nb-closed subproc)))
2612                                 (serialize-subprocedure! subproc 0 #x7f)
2613                                 (alloc! obj)
2614                                 (serialize-subvector! obj 1 (+ nb-closed 1)))))
2615
2616                         (serialize-subprocedure! obj (subprocedure-tag) #x0f)))
2617
2618                    ((flonum? obj)
2619                     (or (share obj)
2620                         (begin
2621                           (write-u8 (flonum-tag))
2622                           (serialize-flonum-64! obj)
2623                           (alloc! obj))))
2624
2625                    ((bignum? obj)
2626                     (serialize-exact-int! obj))
2627
2628                    ((ratnum? obj)
2629                     (or (share obj)
2630                         (begin
2631                           (write-u8 (ratnum-tag))
2632                           (serialize! (macro-ratnum-numerator obj))
2633                           (serialize! (macro-ratnum-denominator obj))
2634                           (alloc! obj))))
2635
2636                    ((cpxnum? obj)
2637                     (or (share obj)
2638                         (begin
2639                           (write-u8 (cpxnum-tag))
2640                           (serialize! (macro-cpxnum-real obj))
2641                           (serialize! (macro-cpxnum-imag obj))
2642                           (alloc! obj))))
2643
2644                    ((continuation? obj)
2645                     (let ()
2646
2647                       (define (serialize-cont-frame! cont)
2648                         (write-u8 (frame-tag))
2649                         (let ((subproc (##continuation-ret cont))
2650                               (fs (##continuation-fs cont)))
2651                           (serialize-subprocedure! subproc 0 #x7f)
2652                           (alloc! (##cons 11 22))
2653                           (let loop ((i fs))
2654                             (if (##fixnum.> i 0)
2655                                 (begin
2656                                   (serialize-cont-frame-ref! cont i)
2657                                   (loop (##fixnum.- i 1)))))))
2658
2659                       (define (serialize-cont-frame-ref! cont i)
2660                         (let* ((fs (##continuation-fs cont))
2661                                (j (##fixnum.+ (##fixnum.- fs i) 1)))
2662                           (if (##continuation-slot-live? cont j)
2663                               (if (##fixnum.= j (##fixnum.+ (##continuation-link cont) 1))
2664                                   (let ((next (##continuation-next cont)))
2665                                     (if next
2666                                         (serialize-cont-frame! next)
2667                                         (serialize! 0)))
2668                                   (serialize! (##continuation-ref cont j))))))
2669
2670                       (or (share obj)
2671                           (begin
2672                             (alloc! obj)
2673                             (write-u8 (continuation-tag))
2674                             (serialize-cont-frame! obj)
2675                             (serialize! (continuation-denv obj))))))
2676
2677                    ((frame? obj)
2678                     (or (share obj)
2679                         (begin
2680                           (write-u8 (frame-tag))
2681                           (let* ((subproc (frame-ret obj))
2682                                  (fs (frame-fs obj)))
2683                             (serialize-subprocedure! subproc 0 #x7f)
2684                             (alloc! obj)
2685                             (let loop ((i 1))
2686                               (if (<= i fs)
2687                                   (begin
2688                                     (if (frame-slot-live? obj i)
2689                                         (serialize! (frame-ref obj i)))
2690                                     (loop (+ i 1)))))))))
2691
2692                    ((boxvalues? obj)
2693                     (or (share obj)
2694                         (begin
2695                           (alloc! obj)
2696                           (serialize-vector-like-long! obj (boxvalues-tag)))))
2697
2698                    ((gc-hash-table? obj)
2699                     (or (share obj)
2700                         (begin
2701                           (alloc! obj)
2702                           (write-u8 (gchashtable-tag))
2703                           (let ()
2704                             (##declare (not interrupts-enabled))
2705                             (let ((len
2706                                    (vector-length obj))
2707                                   (flags
2708                                    (macro-gc-hash-table-flags obj))
2709                                   (count
2710                                    (macro-gc-hash-table-count obj))
2711                                   (min-count
2712                                    (macro-gc-hash-table-min-count obj))
2713                                   (free
2714                                    (macro-gc-hash-table-free obj)))
2715                               (serialize-nonneg-fixnum! len)
2716                               (serialize-nonneg-fixnum! flags)
2717                               (serialize-nonneg-fixnum! count)
2718                               (serialize-nonneg-fixnum! min-count)
2719                               (serialize-nonneg-fixnum! free))
2720                             (let loop ((i (macro-gc-hash-table-key0)))
2721                               (if (< i (vector-length obj))
2722                                   (let ((key (vector-ref obj i)))
2723                                     (if (and (not (eq? key (macro-unused-obj)))
2724                                              (not (eq? key (macro-deleted-obj))))
2725                                         (let ((val (vector-ref obj (+ i 1))))
2726                                           (serialize! key)
2727                                           (serialize! val)))
2728                                     (let ()
2729                                       (##declare (interrupts-enabled))
2730                                       (loop (+ i 2))))
2731                                   (serialize! (macro-unused-obj))))))))
2732
2733                    ((s8vector? obj)
2734                     (serialize-homintvector!
2735                      obj
2736                      (s8vector-tag)
2737                      (lambda (v) (s8vector-length v))
2738                      (lambda (v i) (s8vector-ref v i))
2739                      1))
2740
2741                    ((u8vector? obj)
2742                     (serialize-homintvector!
2743                      obj
2744                      (u8vector-tag)
2745                      (lambda (v) (u8vector-length v))
2746                      (lambda (v i) (u8vector-ref v i))
2747                      1))
2748
2749                    ((s16vector? obj)
2750                     (serialize-homintvector!
2751                      obj
2752                      (s16vector-tag)
2753                      (lambda (v) (s16vector-length v))
2754                      (lambda (v i) (s16vector-ref v i))
2755                      2))
2756
2757                    ((u16vector? obj)
2758                     (serialize-homintvector!
2759                      obj
2760                      (u16vector-tag)
2761                      (lambda (v) (u16vector-length v))
2762                      (lambda (v i) (u16vector-ref v i))
2763                      2))
2764
2765                    ((s32vector? obj)
2766                     (serialize-homintvector!
2767                      obj
2768                      (s32vector-tag)
2769                      (lambda (v) (s32vector-length v))
2770                      (lambda (v i) (s32vector-ref v i))
2771                      4))
2772
2773                    ((u32vector? obj)
2774                     (serialize-homintvector!
2775                      obj
2776                      (u32vector-tag)
2777                      (lambda (v) (u32vector-length v))
2778                      (lambda (v i) (u32vector-ref v i))
2779                      4))
2780
2781                    ((s64vector? obj)
2782                     (serialize-homintvector!
2783                      obj
2784                      (s64vector-tag)
2785                      (lambda (v) (s64vector-length v))
2786                      (lambda (v i) (s64vector-ref v i))
2787                      8))
2788
2789                    ((u64vector? obj)
2790                     (serialize-homintvector!
2791                      obj
2792                      (u64vector-tag)
2793                      (lambda (v) (u64vector-length v))
2794                      (lambda (v i) (u64vector-ref v i))
2795                      8))
2796
2797                    ((f32vector? obj)
2798                     (serialize-homfloatvector!
2799                      obj
2800                      (f32vector-tag)
2801                      (lambda (v) (f32vector-length v))
2802                      (lambda (v i) (f32vector-ref v i))
2803                      #t))
2804
2805                    ((f64vector? obj)
2806                     (serialize-homfloatvector!
2807                      obj
2808                      (f64vector-tag)
2809                      (lambda (v) (f64vector-length v))
2810                      (lambda (v i) (f64vector-ref v i))
2811                      #f))
2812
2813                    ((promise? obj)
2814                     (or (share obj)
2815                         (begin
2816                           (alloc! obj)
2817                           (serialize-vector-like-long! obj (promise-tag)))))
2818
2819                    (else
2820                     (cannot-serialize obj))))
2821
2822             ((pair? obj)
2823              (or (share obj)
2824                  (begin
2825                    (alloc! obj)
2826                    (write-u8 (pair-tag))
2827                    (serialize! (car obj))
2828                    (serialize! (cdr obj)))))
2829
2830             ((fixnum? obj)
2831              (cond ((and (>= obj #x00)
2832                          (< obj #x0b))
2833                     (write-u8 (bitwise-ior (exact-int-tag) obj)))
2834                    ((and (>= obj #x-80)
2835                          (< obj #x80))
2836                     (write-u8 (bitwise-ior (exact-int-tag) #x0e))
2837                     (write-u8 (bitwise-and obj #xff)))
2838                    (else
2839                     (serialize-exact-int! obj))))
2840
2841             ((char? obj)
2842              (let ((n (char->integer obj)))
2843                (write-u8 (character-tag))
2844                (serialize-nonneg-fixnum! n)))
2845
2846             ((eq? obj #f)                  (write-u8 (false-tag)))
2847             ((eq? obj #t)                  (write-u8 (true-tag)))
2848             ((eq? obj '())                 (write-u8 (nil-tag)))
2849             ((eq? obj #!eof)               (write-u8 (eof-tag)))
2850             ((eq? obj #!void)              (write-u8 (void-tag)))
2851             ((eq? obj (macro-absent-obj))  (write-u8 (absent-tag)))
2852             ((eq? obj #!unbound)           (write-u8 (unbound-tag)))
2853             ((eq? obj #!unbound2)          (write-u8 (unbound2-tag)))
2854             ((eq? obj #!optional)          (write-u8 (optional-tag)))
2855             ((eq? obj #!key)               (write-u8 (key-tag)))
2856             ((eq? obj #!rest)              (write-u8 (rest-tag)))
2857             ((eq? obj (macro-unused-obj))  (write-u8 (unused-tag)))
2858             ((eq? obj (macro-deleted-obj)) (write-u8 (deleted-tag)))
2859
2860             (else
2861              (cannot-serialize obj)))))
2862
2863   (serialize! obj)
2864
2865   (get-output-u8vector))
2866
2867 (define-prim (object->u8vector
2868               obj
2869               #!optional
2870               (transform (macro-absent-obj)))
2871   (macro-force-vars (obj transform)
2872     (if (eq? transform (macro-absent-obj))
2873         (##object->u8vector obj)
2874         (macro-check-procedure transform 2 (object->u8vector obj transform)
2875           (##object->u8vector obj transform)))))
2876
2877 (define-prim (##u8vector->object
2878               u8vect
2879               #!optional
2880               (transform (macro-absent-obj)))
2881
2882 (##define-macro (subtype-set! obj subtype)
2883   `(##subtype-set! ,obj ,subtype))
2884
2885 (##define-macro (subvector-move! src-vect src-start src-end dst-vect dst-start)
2886   `(##subvector-move! ,src-vect ,src-start ,src-end ,dst-vect ,dst-start))
2887
2888 (##define-macro (max-fixnum)
2889   `##max-fixnum)
2890
2891 (##define-macro (max-char)
2892   `##max-char)
2893
2894
2895 (##define-macro (continuation? obj)
2896   `(##continuation? ,obj))
2897
2898 (##define-macro (continuation-frame cont)
2899   `(##continuation-frame ,cont))
2900
2901 (##define-macro (continuation-denv cont)
2902   `(##continuation-denv ,cont))
2903
2904 (##define-macro (frame? obj)
2905   `(##frame? ,obj))
2906
2907 (##define-macro (frame-fs frame)
2908   `(##frame-fs ,frame))
2909
2910 (##define-macro (frame-ret frame)
2911   `(##frame-ret ,frame))
2912
2913 (##define-macro (frame-ref frame i)
2914   `(##frame-ref ,frame ,i))
2915
2916 (##define-macro (frame-slot-live? frame i)
2917   `(##frame-slot-live? ,frame ,i))
2918
2919 (##define-macro (subprocedure-parent-name subproc)
2920   `(##subprocedure-parent-name ,subproc))
2921
2922 (##define-macro (subprocedure-id subproc)
2923   `(##subprocedure-id ,subproc))
2924
2925 (##define-macro (subprocedure-nb-closed subproc)
2926   `(##subprocedure-nb-closed ,subproc))
2927
2928 (##define-macro (closure? obj)
2929   `(##closure? ,obj))
2930
2931 (##define-macro (closure-code closure)
2932   `(##closure-code ,closure))
2933
2934 (##define-macro (closure-ref closure i)
2935   `(##closure-ref ,closure ,i))
2936
2937 (##define-macro (extract-bit-field size position n)
2938   `(##extract-bit-field ,size ,position ,n))
2939
2940 (##define-macro (bignum? obj)
2941   `(##bignum? ,obj))
2942
2943 (##define-macro (subtyped? obj)
2944   `(##subtyped? ,obj))
2945
2946 (##define-macro (flonum? obj)
2947   `(##flonum? ,obj))
2948
2949 (##define-macro (ratnum? obj)
2950   `(##ratnum? ,obj))
2951
2952 (##define-macro (cpxnum? obj)
2953   `(##cpxnum? ,obj))
2954
2955 (##define-macro (boxvalues? obj)
2956   `(##fixnum.= (##subtype ,obj) (macro-subtype-boxvalues)))
2957
2958
2959 (##define-macro (make-string . args)
2960   `(##make-string ,@args))
2961
2962 (##define-macro (string? . args)
2963   `(##string? ,@args))
2964
2965 (##define-macro (string-length str)
2966   `(##string-length ,str))
2967
2968 (##define-macro (string-ref str i)
2969   `(##string-ref ,str ,i))
2970
2971 (##define-macro (string-set! str i x)
2972   `(##string-set! ,str ,i ,x))
2973
2974
2975 (##define-macro (make-vector . args)
2976   `(##make-vector ,@args))
2977
2978 (##define-macro (vector? . args)
2979   `(##vector? ,@args))
2980
2981 (##define-macro (vector-length vect)
2982   `(##vector-length ,vect))
2983
2984 (##define-macro (vector-ref vect i)
2985   `(##vector-ref ,vect ,i))
2986
2987 (##define-macro (vector-set! vect i x)
2988   `(##vector-set! ,vect ,i ,x))
2989
2990
2991 (##define-macro (make-s8vector . args)
2992   `(##make-s8vector ,@args))
2993
2994 (##define-macro (s8vector? . args)
2995   `(##s8vector? ,@args))
2996
2997 (##define-macro (s8vector-length s8vect)
2998   `(##s8vector-length ,s8vect))
2999
3000 (##define-macro (s8vector-ref s8vect i)
3001   `(##s8vector-ref ,s8vect ,i))
3002
3003 (##define-macro (s8vector-set! s8vect i x)
3004   `(##s8vector-set! ,s8vect ,i ,x))
3005
3006 (##define-macro (s8vector-shrink! s8vect len)
3007   `(##s8vector-shrink! ,s8vect ,len))
3008
3009 (##define-macro (make-u8vector . args)
3010   `(##make-u8vector ,@args))
3011
3012 (##define-macro (u8vector? . args)
3013   `(##u8vector? ,@args))
3014
3015 (##define-macro (u8vector-length u8vect)
3016   `(##u8vector-length ,u8vect))
3017
3018 (##define-macro (u8vector-ref u8vect i)
3019   `(##u8vector-ref ,u8vect ,i))
3020
3021 (##define-macro (u8vector-set! u8vect i x)
3022   `(##u8vector-set! ,u8vect ,i ,x))
3023
3024 (##define-macro (u8vector-shrink! u8vect len)
3025   `(##u8vector-shrink! ,u8vect ,len))
3026
3027 (##define-macro (fifo->u8vector fifo start end)
3028   `(##fifo->u8vector ,fifo ,start ,end))
3029
3030
3031 (##define-macro (make-s16vector . args)
3032   `(##make-s16vector ,@args))
3033
3034 (##define-macro (s16vector? . args)
3035   `(##s16vector? ,@args))
3036
3037 (##define-macro (s16vector-length s16vect)
3038   `(##s16vector-length ,s16vect))
3039
3040 (##define-macro (s16vector-ref s16vect i)
3041   `(##s16vector-ref ,s16vect ,i))
3042
3043 (##define-macro (s16vector-set! s16vect i x)
3044   `(##s16vector-set! ,s16vect ,i ,x))
3045
3046 (##define-macro (s16vector-shrink! s16vect len)
3047   `(##s16vector-shrink! ,s16vect ,len))
3048
3049 (##define-macro (make-u16vector . args)
3050   `(##make-u16vector ,@args))
3051
3052 (##define-macro (u16vector? . args)
3053   `(##u16vector? ,@args))
3054
3055 (##define-macro (u16vector-length u16vect)
3056   `(##u16vector-length ,u16vect))
3057
3058 (##define-macro (u16vector-ref u16vect i)
3059   `(##u16vector-ref ,u16vect ,i))
3060
3061 (##define-macro (u16vector-set! u16vect i x)
3062   `(##u16vector-set! ,u16vect ,i ,x))
3063
3064 (##define-macro (u16vector-shrink! u16vect len)
3065   `(##u16vector-shrink! ,u16vect ,len))
3066
3067
3068 (##define-macro (make-s32vector . args)
3069   `(##make-s32vector ,@args))
3070
3071 (##define-macro (s32vector? . args)
3072   `(##s32vector? ,@args))
3073
3074 (##define-macro (s32vector-length s32vect)
3075   `(##s32vector-length ,s32vect))
3076
3077 (##define-macro (s32vector-ref s32vect i)
3078   `(##s32vector-ref ,s32vect ,i))
3079
3080 (##define-macro (s32vector-set! s32vect i x)
3081   `(##s32vector-set! ,s32vect ,i ,x))
3082
3083 (##define-macro (s32vector-shrink! s32vect len)
3084   `(##s32vector-shrink! ,s32vect ,len))
3085
3086 (##define-macro (make-u32vector . args)
3087   `(##make-u32vector ,@args))
3088
3089 (##define-macro (u32vector? . args)
3090   `(##u32vector? ,@args))
3091
3092 (##define-macro (u32vector-length u32vect)
3093   `(##u32vector-length ,u32vect))
3094
3095 (##define-macro (u32vector-ref u32vect i)
3096   `(##u32vector-ref ,u32vect ,i))
3097
3098 (##define-macro (u32vector-set! u32vect i x)
3099   `(##u32vector-set! ,u32vect ,i ,x))
3100
3101 (##define-macro (u32vector-shrink! u32vect len)
3102   `(##u32vector-shrink! ,u32vect ,len))
3103
3104
3105 (##define-macro (make-s64vector . args)
3106   `(##make-s64vector ,@args))
3107
3108 (##define-macro (s64vector? . args)
3109   `(##s64vector? ,@args))
3110
3111 (##define-macro (s64vector-length s64vect)
3112   `(##s64vector-length ,s64vect))
3113
3114 (##define-macro (s64vector-ref s64vect i)
3115   `(##s64vector-ref ,s64vect ,i))
3116
3117 (##define-macro (s64vector-set! s64vect i x)
3118   `(##s64vector-set! ,s64vect ,i ,x))
3119
3120 (##define-macro (s64vector-shrink! s64vect len)
3121   `(##s64vector-shrink! ,s64vect ,len))
3122
3123 (##define-macro (make-u64vector . args)
3124   `(##make-u64vector ,@args))
3125
3126 (##define-macro (u64vector? . args)
3127   `(##u64vector? ,@args))
3128
3129 (##define-macro (u64vector-length u64vect)
3130   `(##u64vector-length ,u64vect))
3131
3132 (##define-macro (u64vector-ref u64vect i)
3133   `(##u64vector-ref ,u64vect ,i))
3134
3135 (##define-macro (u64vector-set! u64vect i x)
3136   `(##u64vector-set! ,u64vect ,i ,x))
3137
3138 (##define-macro (u64vector-shrink! u64vect len)
3139   `(##u64vector-shrink! ,u64vect ,len))
3140
3141
3142 (##define-macro (make-f32vector . args)
3143   `(##make-f32vector ,@args))
3144
3145 (##define-macro (f32vector? . args)
3146   `(##f32vector? ,@args))
3147
3148 (##define-macro (f32vector-length f32vect)
3149   `(##f32vector-length ,f32vect))
3150
3151 (##define-macro (f32vector-ref f32vect i)
3152   `(##f32vector-ref ,f32vect ,i))
3153
3154 (##define-macro (f32vector-set! f32vect i x)
3155   `(##f32vector-set! ,f32vect ,i ,x))
3156
3157 (##define-macro (f32vector-shrink! f32vect len)
3158   `(##f32vector-shrink! ,f32vect ,len))
3159
3160 (##define-macro (make-f64vector . args)
3161   `(##make-f64vector ,@args))
3162
3163 (##define-macro (f64vector? . args)
3164   `(##f64vector? ,@args))
3165
3166 (##define-macro (f64vector-length f64vect)
3167   `(##f64vector-length ,f64vect))
3168
3169 (##define-macro (f64vector-ref f64vect i)
3170   `(##f64vector-ref ,f64vect ,i))
3171
3172 (##define-macro (f64vector-set! f64vect i x)
3173   `(##f64vector-set! ,f64vect ,i ,x))
3174
3175 (##define-macro (f64vector-shrink! f64vect len)
3176   `(##f64vector-shrink! ,f64vect ,len))
3177
3178
3179 (##define-macro (symbol? . args)
3180   `(##symbol? ,@args))
3181
3182 (##define-macro (symbol->string . args)
3183   `(##symbol->string ,@args))
3184
3185 (##define-macro (string->symbol . args)
3186   `(##string->symbol ,@args))
3187
3188 (##define-macro (keyword? . args)
3189   `(##keyword? ,@args))
3190
3191 (##define-macro (keyword->string . args)
3192   `(##keyword->string ,@args))
3193
3194 (##define-macro (string->keyword . args)
3195   `(##string->keyword ,@args))
3196
3197
3198 (##define-macro (+ . args)
3199   `(##fixnum.+ ,@args))
3200
3201 (##define-macro (- . args)
3202   `(##fixnum.- ,@args))
3203
3204 (##define-macro (* . args)
3205   `(##fixnum.* ,@args))
3206
3207 (##define-macro (< . args)
3208   `(##fixnum.< ,@args))
3209
3210 (##define-macro (> . args)
3211   `(##fixnum.> ,@args))
3212
3213 (##define-macro (= . args)
3214   `(##fixnum.= ,@args))
3215
3216 (##define-macro (>= . args)
3217   `(##fixnum.>= ,@args))
3218
3219 (##define-macro (<= . args)
3220   `(##fixnum.<= ,@args))
3221
3222 (##define-macro (bitwise-and . args)
3223   `(##fixnum.bitwise-and ,@args))
3224
3225 (##define-macro (bitwise-ior . args)
3226   `(##fixnum.bitwise-ior ,@args))
3227
3228 (##define-macro (arithmetic-shift-left . args)
3229   `(##fixnum.arithmetic-shift-left ,@args))
3230
3231 (##define-macro (arithmetic-shift-right . args)
3232   `(##fixnum.arithmetic-shift-right ,@args))
3233
3234 (##define-macro (generic.+ . args)
3235   `(##+ ,@args))
3236
3237 (##define-macro (generic.arithmetic-shift . args)
3238   `(##arithmetic-shift ,@args))
3239
3240 (##define-macro (generic.bit-set? . args)
3241   `(##bit-set? ,@args))
3242
3243 (##define-macro (generic.bitwise-ior . args)
3244   `(##bitwise-ior ,@args))
3245
3246 (##define-macro (generic.extract-bit-field . args)
3247   `(##extract-bit-field ,@args))
3248
3249 (##define-macro (generic.gcd . args)
3250   `(##gcd ,@args))
3251
3252 (##define-macro (generic.negative? . args)
3253   `(##negative? ,@args))
3254
3255 (##define-macro (integer-length . args)
3256   `(##integer-length ,@args))
3257
3258 (##define-macro (make-table . args)
3259   `(##make-table 0 #f #f #f ##eq?))
3260
3261 (##define-macro (table-ref . args)
3262   `(##table-ref ,@args))
3263
3264 (##define-macro (table-set! . args)
3265   `(##table-set! ,@args))
3266
3267 (##define-macro (uninterned-keyword? . args)
3268   `(##uninterned-keyword? ,@args))
3269
3270 (##define-macro (uninterned-symbol? . args)
3271   `(##uninterned-symbol? ,@args))
3272
3273
3274 (##define-macro (char->integer . args)
3275   `(##fixnum.<-char ,@args))
3276
3277 (##define-macro (integer->char . args)
3278   `(##fixnum.->char ,@args))
3279
3280
3281 (##define-macro (vector . args)
3282   `(##vector ,@args))
3283
3284
3285 (##define-macro (cons . args)
3286   `(##cons ,@args))
3287
3288 (##define-macro (pair? . args)
3289   `(##pair? ,@args))
3290
3291 (##define-macro (car . args)
3292   `(##car ,@args))
3293
3294 (##define-macro (cdr . args)
3295   `(##cdr ,@args))
3296
3297 (##define-macro (set-car! . args)
3298   `(##set-car! ,@args))
3299
3300 (##define-macro (set-cdr! . args)
3301   `(##set-cdr! ,@args))
3302
3303
3304 (##define-macro (procedure? . args)
3305   `(##procedure? ,@args))
3306
3307 (##define-macro (char? . args)
3308   `(##char? ,@args))
3309
3310 (##define-macro (real? . args)
3311   `(##real? ,@args))
3312
3313 (##define-macro (not . args)
3314   `(##not ,@args))
3315
3316 (##define-macro (eq? . args)
3317   `(##eq? ,@args))
3318
3319 ;; Representation of fifos.
3320
3321 (##define-macro (macro-make-fifo)
3322   `(let ((fifo (##cons '() '())))
3323      (macro-fifo-tail-set! fifo fifo)
3324      fifo))
3325
3326 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
3327 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
3328 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
3329 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
3330 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
3331 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
3332
3333 (##define-macro (macro-fifo->list fifo)
3334   `(macro-fifo-next ,fifo))
3335
3336 (##define-macro (macro-fifo-remove-all! fifo)
3337   `(let ((fifo ,fifo))
3338
3339      (##declare (not interrupts-enabled))
3340
3341      (let ((head (macro-fifo-next fifo)))
3342        (macro-fifo-tail-set! fifo fifo)
3343        (macro-fifo-next-set! fifo '())
3344        head)))
3345
3346 (##define-macro (macro-fifo-remove-head! fifo)
3347   `(let ((fifo ,fifo))
3348
3349      (##declare (not interrupts-enabled))
3350
3351      (let ((head (macro-fifo-next fifo)))
3352        (if (##pair? head)
3353          (let ((next (macro-fifo-next head)))
3354            (if (##null? next)
3355              (macro-fifo-tail-set! fifo fifo))
3356            (macro-fifo-next-set! fifo next)
3357            (macro-fifo-next-set! head '())))
3358        head)))
3359
3360 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
3361   `(let ((fifo ,fifo) (elem ,elem))
3362      (let ((x (##cons elem '())))
3363
3364        (##declare (not interrupts-enabled))
3365
3366        (let ((tail (macro-fifo-tail fifo)))
3367          (macro-fifo-next-set! tail x)
3368          (macro-fifo-tail-set! fifo x)
3369          (##void)))))
3370
3371 (##define-macro (macro-fifo-insert-at-head! fifo elem)
3372   `(let ((fifo ,fifo) (elem ,elem))
3373      (let ((x (##cons elem '())))
3374
3375        (##declare (not interrupts-enabled))
3376
3377        ;; To obtain an atomic update of the fifo, we must force a
3378        ;; garbage-collection to occur right away if needed by the
3379        ;; ##cons, so that any finalization that might mutate this fifo
3380        ;; will be done before updating the fifo.
3381
3382        (##check-heap-limit)
3383
3384        (let ((head (macro-fifo-next fifo)))
3385          (if (##null? head)
3386            (macro-fifo-tail-set! fifo x))
3387          (macro-fifo-next-set! fifo x)
3388          (macro-fifo-next-set! x head)
3389          (##void)))))
3390
3391 (##define-macro (macro-fifo-advance-to-tail! fifo)
3392   `(let ((fifo ,fifo))
3393      ;; It is assumed that the fifo contains at least one element
3394      ;; (i.e. the fifo's tail does not change).
3395      (let ((new-head (macro-fifo-tail fifo)))
3396        (macro-fifo-next-set! fifo new-head)
3397        (macro-fifo-elem new-head))))
3398
3399 (##define-macro (macro-fifo-advance! fifo)
3400   `(let ((fifo ,fifo))
3401      ;; It is assumed that the fifo contains at least two elements
3402      ;; (i.e. the fifo's tail does not change).
3403      (let* ((head (macro-fifo-next fifo))
3404             (new-head (macro-fifo-next head)))
3405        (macro-fifo-next-set! fifo new-head)
3406        (macro-fifo-elem new-head))))
3407
3408
3409   (define (err)
3410     (error "deserialization error"))
3411
3412   (define state
3413     (vector 0
3414             u8vect
3415             0
3416             (make-vector 64)
3417             (if (eq? transform (macro-absent-obj))
3418                 (lambda (x) x)
3419                 transform)))
3420
3421   (define (read-u8)
3422     (let ((ptr (vector-ref state 0))
3423           (u8vect (vector-ref state 1)))
3424       (if (< ptr (u8vector-length u8vect))
3425           (begin
3426             (vector-set! state 0 (+ ptr 1))
3427             (u8vector-ref u8vect ptr))
3428           (err))))
3429
3430   (define (eof?)
3431     (let ((ptr (vector-ref state 0))
3432           (u8vect (vector-ref state 1)))
3433       (= ptr (u8vector-length u8vect))))
3434
3435   (define (alloc! obj)
3436     (let* ((n (vector-ref state 2))
3437            (vect (vector-ref state 3))
3438            (len (vector-length vect)))
3439       (vector-set! state 2 (+ n 1))
3440       (if (= n len)
3441           (let* ((new-len (+ (arithmetic-shift-right (* len 3) 1) 1))
3442                  (new-vect (make-vector new-len)))
3443             (vector-set! state 3 new-vect)
3444             (subvector-move! vect 0 n new-vect 0)
3445             (vector-set! new-vect n obj))
3446           (vector-set! vect n obj))
3447       n))
3448
3449   (define (shared-ref i)
3450     (let* ((n (vector-ref state 2))
3451            (vect (vector-ref state 3)))
3452       (if (< i n)
3453           (vector-ref vect i)
3454           (err))))
3455
3456   (define (deserialize-nonneg-fixnum! n shift)
3457     (let loop ((n n)
3458                (shift shift)
3459                (range (arithmetic-shift-right (max-fixnum) shift)))
3460       (if (= range 0)
3461           (err)
3462           (let ((x (read-u8)))
3463             (if (< x #x80)
3464                 (if (< range x)
3465                     (err)
3466                     (bitwise-ior n (arithmetic-shift-left x shift)))
3467                 (let ((b (bitwise-and x #x7f)))
3468                   (if (< range b)
3469                       (err)
3470                       (loop (bitwise-ior n (arithmetic-shift-left b shift))
3471                             (+ shift 7)
3472                             (arithmetic-shift-right range 7)))))))))
3473
3474   (define (deserialize-flonum-32!)
3475     (let ((n (deserialize-nonneg-exact-int-of-length! 4)))
3476       (##flonum.<-ieee754-32 n)))
3477
3478   (define (deserialize-flonum-64!)
3479     (let ((n (deserialize-nonneg-exact-int-of-length! 8)))
3480       (##flonum.<-ieee754-64 n)))
3481
3482   (define (deserialize-nonneg-exact-int-of-length! len)
3483     (if (<= len 3) ;; result fits in a 32 bit fixnum?
3484         (let ((a (read-u8)))
3485           (if (= len 1)
3486               a
3487               (+ a
3488                  (arithmetic-shift-left
3489                   (let ((b (read-u8)))
3490                     (if (= len 2)
3491                         b
3492                         (+ b
3493                            (arithmetic-shift-left
3494                             (let ((c (read-u8)))
3495                               c)
3496                             8))))
3497                   8))))
3498         (let* ((len/2 (arithmetic-shift-right len 1))
3499                (a (deserialize-nonneg-exact-int-of-length! len/2))
3500                (b (deserialize-nonneg-exact-int-of-length! (- len len/2))))
3501           (generic.bitwise-ior a (generic.arithmetic-shift b (* 8 len/2))))))
3502
3503   (define (deserialize-exact-int-of-length! len)
3504     (let ((n (deserialize-nonneg-exact-int-of-length! len)))
3505       (if (generic.bit-set? (- (* 8 len) 1) n)
3506           (generic.+ n (generic.arithmetic-shift -1 (* 8 len)))
3507           n)))
3508
3509   (define (deserialize-string! x mask)
3510     (deserialize-string-of-length!
3511      (let ((lo (bitwise-and x mask)))
3512        (if (< lo mask)
3513            lo
3514            (deserialize-nonneg-fixnum! 0 0)))))
3515
3516   (define (deserialize-string-of-length! len)
3517     (let ((obj (make-string len)))
3518       (let loop ((i 0))
3519         (if (< i len)
3520             (let ((n (deserialize-nonneg-fixnum! 0 0)))
3521               (if (<= n (max-char))
3522                   (begin
3523                     (string-set! obj i (integer->char n))
3524                     (loop (+ i 1)))
3525                   (err)))
3526             obj))))
3527
3528   (define (deserialize-vector-like! subtype x)
3529     (let* ((len (bitwise-and x #x0f)))
3530       (if (< len #x0f)
3531           (deserialize-vector-like-fill! subtype len)
3532           (deserialize-vector-like-long! subtype))))
3533
3534   (define (deserialize-vector-like-long! subtype)
3535     (let ((len (deserialize-nonneg-fixnum! 0 0)))
3536       (deserialize-vector-like-fill! subtype len)))
3537
3538   (define (deserialize-vector-like-fill! subtype len)
3539     (let ((obj (make-vector len)))
3540       (alloc! obj)
3541       (let loop ((i 0))
3542         (if (< i len)
3543             (begin
3544               (vector-set! obj i (deserialize!))
3545               (loop (+ i 1)))
3546             (begin
3547               (subtype-set! obj subtype)
3548               obj)))))
3549
3550   (define (deserialize-homintvector! make-vect vect-set! elem-len signed? len)
3551     (let ((obj (make-vect len)))
3552       (let loop ((i 0))
3553         (if (< i len)
3554             (begin
3555               (vect-set!
3556                obj
3557                i
3558                (if signed?
3559                    (deserialize-exact-int-of-length! elem-len)
3560                    (deserialize-nonneg-exact-int-of-length! elem-len)))
3561               (loop (+ i 1)))
3562             (begin
3563               (alloc! obj)
3564               obj)))))
3565
3566   (define (deserialize-homfloatvector! make-vect vect-set! len f32?)
3567     (let ((obj (make-vect len)))
3568       (let loop ((i 0))
3569         (if (< i len)
3570             (begin
3571               (vect-set!
3572                obj
3573                i
3574                (if f32?
3575                    (deserialize-flonum-32!)
3576                    (deserialize-flonum-64!)))
3577               (loop (+ i 1)))
3578             (begin
3579               (alloc! obj)
3580               obj)))))
3581
3582   (define (deserialize-subprocedure!)
3583     (let ((x (read-u8)))
3584       (if (>= x (shared-tag))
3585           (shared-ref
3586            (deserialize-nonneg-fixnum! (bitwise-and x #x7f) 7))
3587           (let ((subproc-id
3588                  (let ((id (bitwise-and x #x7f)))
3589                    (if (< id #x7f)
3590                        id
3591                        (deserialize-nonneg-fixnum! 0 0)))))
3592             (deserialize-subprocedure-with-id! subproc-id)))))
3593
3594   (define (deserialize-subprocedure-with-id! subproc-id)
3595     (let ((v (deserialize!)))
3596       (if (not (eq? v (##system-version)))
3597           (err)
3598           (let* ((x
3599                   (read-u8))
3600                  (parent-name
3601                   (if (>= x (shared-tag))
3602                       (let ((name
3603                              (shared-ref
3604                               (deserialize-nonneg-fixnum!
3605                                (bitwise-and x #x7f)
3606                                7))))
3607                         (if (not (symbol? name))
3608                             (err)
3609                             name))
3610                       (let ((name
3611                              (string->symbol (deserialize-string! x #x7f))))
3612                         (alloc! name)
3613                         name)))
3614                  (parent
3615                   (##global-var-primitive-ref
3616                    (##make-global-var parent-name))))
3617             (if (not (procedure? parent)) ;; should also check subproc-id
3618                 (err)
3619                 (let ((obj (##make-subprocedure parent subproc-id)))
3620                   (alloc! obj)
3621                   obj))))))
3622
3623   (define (create-global-var-if-needed sym)
3624     (let ((x (read-u8)))
3625       (if (= x 1)
3626           (##make-global-var sym))))
3627
3628   (define (deserialize-without-transform!)
3629     (let ((x (read-u8)))
3630
3631       (cond ((>= x (shared-tag))
3632              (shared-ref
3633               (deserialize-nonneg-fixnum! (bitwise-and x #x7f) 7)))
3634
3635             ((>= x (false-tag))
3636              (cond ((= x (false-tag))
3637                     #f)
3638
3639                    ((= x (true-tag))
3640                     #t)
3641
3642                    ((= x (nil-tag))
3643                     '())
3644
3645                    ((= x (eof-tag))
3646                     #!eof)
3647
3648                    ((= x (void-tag))
3649                     #!void)
3650
3651                    ((= x (absent-tag))
3652                     (macro-absent-obj))
3653
3654                    ((= x (unbound-tag))
3655                     #!unbound)
3656
3657                    ((= x (unbound2-tag))
3658                     #!unbound2)
3659
3660                    ((= x (optional-tag))
3661                     #!optional)
3662
3663                    ((= x (key-tag))
3664                     #!key)
3665
3666                    ((= x (rest-tag))
3667                     #!rest)
3668
3669                    ((= x (unused-tag))
3670                     (macro-unused-obj))
3671
3672                    ((= x (deleted-tag))
3673                     (macro-deleted-obj))
3674
3675                    ((= x (promise-tag))
3676                     (deserialize-vector-like-long!
3677                      (macro-subtype-promise)))
3678
3679                    (else
3680                     (err))))
3681
3682             ((>= x (character-tag))
3683              (cond ((= x (character-tag))
3684                     (let ((n (deserialize-nonneg-fixnum! 0 0)))
3685                       (if (<= n (max-char))
3686                           (integer->char n)
3687                           (err))))
3688
3689                    ((= x (flonum-tag))
3690                     (let ((obj (deserialize-flonum-64!)))
3691                       (alloc! obj)
3692                       obj))
3693
3694                    ((= x (ratnum-tag))
3695                     (let* ((num (deserialize!))
3696                            (den (deserialize!)))
3697                       (if (or (and (fixnum? den)
3698                                    (<= den 1))
3699                               (and (bignum? den)
3700                                    (generic.negative? den))
3701                               (not (eq? 1 (generic.gcd num den))))
3702                           (err)
3703                           (let ((obj (macro-ratnum-make num den)))
3704                             (alloc! obj)
3705                             obj))))
3706
3707                    ((= x (cpxnum-tag))
3708                     (let* ((real (deserialize!))
3709                            (imag (deserialize!)))
3710                       (if (or (not (real? real))
3711                               (not (real? imag)))
3712                           (err)
3713                           (let ((obj (macro-cpxnum-make real imag)))
3714                             (alloc! obj)
3715                             obj))))
3716
3717                    ((= x (pair-tag))
3718                     (let ((obj (cons #f #f)))
3719                       (alloc! obj)
3720                       (let* ((a (deserialize!))
3721                              (d (deserialize!)))
3722                         (set-car! obj a)
3723                         (set-cdr! obj d)
3724                         obj)))
3725
3726                    ((= x (continuation-tag))
3727                     (let ((obj (vector #f #f)))
3728                       (alloc! obj)
3729                       (let* ((frame (deserialize!))
3730                              (denv (deserialize!)))
3731                         (if (not (frame? frame)) ;; should also check denv
3732                             (err)
3733                             (begin
3734                               (vector-set! obj 0 frame)
3735                               (vector-set! obj 1 denv)
3736                               (subtype-set! obj (macro-subtype-continuation))
3737                               obj)))))
3738
3739                    ((= x (boxvalues-tag))
3740                     (deserialize-vector-like-long!
3741                      (macro-subtype-boxvalues)))
3742
3743                    ((= x (ui-symbol-tag))
3744                     (let* ((y (read-u8))
3745                            (name (deserialize-string! y #xff))
3746                            (hash (deserialize-exact-int-of-length! 4))
3747                            (obj (macro-make-uninterned-symbol name hash)))
3748                       (create-global-var-if-needed obj)
3749                       (alloc! obj)
3750                       obj))
3751
3752                    ((= x (keyword-tag))
3753                     (let* ((name (deserialize-string! 0 0))
3754                            (obj (string->keyword name)))
3755                       (alloc! obj)
3756                       obj))
3757
3758                    ((= x (ui-keyword-tag))
3759                     (let* ((y (read-u8))
3760                            (name (deserialize-string! y #xff))
3761                            (hash (deserialize-exact-int-of-length! 4))
3762                            (obj (macro-make-uninterned-keyword name hash)))
3763                       (alloc! obj)
3764                       obj))
3765
3766                    ((= x (closure-tag))
3767                     (let ((subproc (deserialize-subprocedure!)))
3768                       (if #f;;;;;;;not subprocedure
3769                           (err)
3770                           (let ((nb-closed
3771                                  (subprocedure-nb-closed subproc)))
3772                             (if #f;;;;; nb-closed = 0
3773                                 (err)
3774                                 (let ((obj (make-vector (+ nb-closed 1))))
3775                                   (vector-set! obj 0 subproc)
3776                                   (alloc! obj)
3777                                   (let loop ((i 1))
3778                                     (if (<= i nb-closed)
3779                                         (begin
3780                                           (vector-set! obj i (deserialize!))
3781                                           (loop (+ i 1)))
3782                                         (begin
3783                                           (subtype-set!
3784                                            obj
3785                                            (macro-subtype-procedure))
3786                                           obj)))))))))
3787
3788                    ((= x (frame-tag))
3789                     (let ((subproc (deserialize-subprocedure!)))
3790                       (if (not (##return? subproc))
3791                           (err)
3792                           (let* ((fs (##return-fs subproc))
3793                                  (obj (make-vector (+ fs 1))))
3794                             (vector-set! obj 0 subproc)
3795                             (alloc! obj)
3796                             (let loop ((i 1))
3797                               (if (<= i fs)
3798                                   (begin
3799                                     (vector-set!
3800                                      obj
3801                                      (+ (- fs i) 1)
3802                                      (if (frame-slot-live? obj i)
3803                                          (deserialize!)
3804                                          0))
3805                                     (loop (+ i 1)))
3806                                   (begin
3807                                     (subtype-set! obj (macro-subtype-frame))
3808                                     obj)))))))
3809
3810                    ((= x (gchashtable-tag))
3811                     (let* ((len (deserialize-nonneg-fixnum! 0 0))
3812                            (flags (deserialize-nonneg-fixnum! 0 0))
3813                            (count (deserialize-nonneg-fixnum! 0 0))
3814                            (min-count (deserialize-nonneg-fixnum! 0 0))
3815                            (free (deserialize-nonneg-fixnum! 0 0)))
3816                       (if #f;;;;;;;;parameters OK?
3817                           (err)
3818                           (let ((obj (make-vector len (macro-unused-obj))))
3819                             (alloc! obj)
3820                             (macro-gc-hash-table-flags-set!
3821                              obj
3822                              (bitwise-ior ;; force rehash at next access!
3823                               flags
3824                               (+ (macro-gc-hash-table-flag-key-moved)
3825                                  (macro-gc-hash-table-flag-need-rehash))))
3826                             (macro-gc-hash-table-count-set! obj count)
3827                             (macro-gc-hash-table-min-count-set! obj min-count)
3828                             (macro-gc-hash-table-free-set! obj free)
3829                             (let loop ((i (macro-gc-hash-table-key0)))
3830                               (if (< i (vector-length obj))
3831                                   (let ((key (deserialize!)))
3832                                     (if (not (eq? key (macro-unused-obj)))
3833                                         (let ((val (deserialize!)))
3834                                           (vector-set! obj i key)
3835                                           (vector-set! obj (+ i 1) val)
3836                                           (loop (+ i 2)))
3837                                         (begin
3838                                           (subtype-set!
3839                                            obj
3840                                            (macro-subtype-weak))
3841                                           obj)))
3842                                   (err)))))))
3843
3844                    ((= x (meroon-tag))
3845                     (deserialize-vector-like-long!
3846                      (macro-subtype-meroon)))
3847
3848                    ((= x (jazz-tag))
3849                     (deserialize-vector-like-long!
3850                      (macro-subtype-jazz)))
3851
3852                    ((= x (homvector-tag))
3853                     (let* ((len/type
3854                             (deserialize-nonneg-fixnum! 0 0))
3855                            (len
3856                             (arithmetic-shift-right len/type 4))
3857                            (type
3858                             (bitwise-and len/type #x0f)))
3859                       (cond ((= type (s8vector-tag))
3860                              (deserialize-homintvector!
3861                               (lambda (n) (make-s8vector n))
3862                               (lambda (v i n) (s8vector-set! v i n))
3863                               1
3864                               #t
3865                               len))
3866                             ((= type (u8vector-tag))
3867                              (deserialize-homintvector!
3868                               (lambda (n) (make-u8vector n))
3869                               (lambda (v i n) (u8vector-set! v i n))
3870                               1
3871                               #f
3872                               len))
3873                             ((= type (s16vector-tag))
3874                              (deserialize-homintvector!
3875                               (lambda (n) (make-s16vector n))
3876                               (lambda (v i n) (s16vector-set! v i n))
3877                               2
3878                               #t
3879                               len))
3880                             ((= type (u16vector-tag))
3881                              (deserialize-homintvector!
3882                               (lambda (n) (make-u16vector n))
3883                               (lambda (v i n) (u16vector-set! v i n))
3884                               2
3885                               #f
3886                               len))
3887                             ((= type (s32vector-tag))
3888                              (deserialize-homintvector!
3889                               (lambda (n) (make-s32vector n))
3890                               (lambda (v i n) (s32vector-set! v i n))
3891                               4
3892                               #t
3893                               len))
3894                             ((= type (u32vector-tag))
3895                              (deserialize-homintvector!
3896                               (lambda (n) (make-u32vector n))
3897                               (lambda (v i n) (u32vector-set! v i n))
3898                               4
3899                               #f
3900                               len))
3901                             ((= type (s64vector-tag))
3902                              (deserialize-homintvector!
3903                               (lambda (n) (make-s64vector n))
3904                               (lambda (v i n) (s64vector-set! v i n))
3905                               8
3906                               #t
3907                               len))
3908                             ((= type (u64vector-tag))
3909                              (deserialize-homintvector!
3910                               (lambda (n) (make-u64vector n))
3911                               (lambda (v i n) (u64vector-set! v i n))
3912                               8
3913                               #f
3914                               len))
3915                             ((= type (f32vector-tag))
3916                              (deserialize-homfloatvector!
3917                               (lambda (n) (make-f32vector n))
3918                               (lambda (v i n) (f32vector-set! v i n))
3919                               len
3920                               #t))
3921                             ((= type (f64vector-tag))
3922                              (deserialize-homfloatvector!
3923                               (lambda (n) (make-f64vector n))
3924                               (lambda (v i n) (f64vector-set! v i n))
3925                               len
3926                               #f))
3927                             (else
3928                              (err)))))
3929
3930                    (else
3931                     (err))))
3932
3933             ((>= x (exact-int-tag))
3934              (let ((lo (bitwise-and x #x0f)))
3935                (if (< lo #x0b)
3936                    lo
3937                    (let* ((len
3938                            (if (= lo #x0f)
3939                                (deserialize-nonneg-fixnum! 0 0)
3940                                (- #x0f lo)))
3941                           (n
3942                            (deserialize-exact-int-of-length! len)))
3943                      (if (= lo #x0e)
3944                          n
3945                          (begin
3946                            (alloc! n)
3947                            n))))))
3948
3949             ((>= x (subprocedure-tag))
3950              (let ((subproc-id
3951                     (let ((id (bitwise-and x #x0f)))
3952                       (if (< id #x0f)
3953                           id
3954                           (deserialize-nonneg-fixnum! 0 0)))))
3955                (deserialize-subprocedure-with-id! subproc-id)))
3956
3957             ((>= x (structure-tag))
3958              (deserialize-vector-like!
3959               (macro-subtype-structure)
3960               x))
3961
3962             ((>= x (vector-tag))
3963              (deserialize-vector-like!
3964               (macro-subtype-vector)
3965               x))
3966
3967             ((>= x (string-tag))
3968              (let ((obj (deserialize-string! x #x0f)))
3969                (alloc! obj)
3970                obj))
3971
3972             (else ;; symbol-tag
3973              (let* ((name (deserialize-string! x #x0f))
3974                     (obj (string->symbol name)))
3975                (create-global-var-if-needed obj)
3976                (alloc! obj)
3977                obj)))))
3978
3979   (define (deserialize!)
3980     (let* ((obj (deserialize-without-transform!))
3981            (transform (vector-ref state 4)))
3982       (transform obj)))
3983
3984   (let ((obj (deserialize!)))
3985     (if (eof?)
3986         obj
3987         (err))))
3988
3989 (define-prim (u8vector->object
3990               u8vect
3991               #!optional
3992               (transform (macro-absent-obj)))
3993   (macro-force-vars (u8vect transform)
3994     (macro-check-u8vector u8vect 1 (u8vector->object u8vect transform)
3995       (if (eq? transform (macro-absent-obj))
3996           (##u8vector->object u8vect)
3997           (macro-check-procedure transform 2 (u8vector->object u8vect transform)
3998             (##u8vector->object u8vect transform))))))
3999
4000 ;;;============================================================================